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

New changes from l2g

Browse Source 
w
This commit is contained in:
poprhythm
2022-09-12 16:40:28 +00:00
parent 78eb7147d0
commit d713d4f61a
110 changed files with 87672 additions and 1098 deletions
Download Patch File Download Diff File Expand all files Collapse all files
dataassim/math/optimization/CompassSearch.f
+4 -4
View File
@@ -3,7 +3,7 @@
implicit none
integer ndim
double precision xbest(1:ndim),fbest,
& bmin(1:ndim),bmax(1:ndim),xtol
& bmin(1:ndim),bmax(1:ndim),xtol,f1dim
double precision fvalpre,dmax,xpre(1:ndim),ftol,direction(ndim)
integer i,n
logical resetran2
@@ -62,7 +62,7 @@
! =1 convergence criterion reached (minimum found)
!
integer ndim
double precision xbest(1:ndim),fbest,
double precision xbest(1:ndim),fbest,f1dim,
& bmin(1:ndim),bmax(1:ndim),xtol,dx1,dx2
external funkmin,f1dim
!------------------------------- Locals -----------------------------------------------------------
@@ -71,10 +71,10 @@
& 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)
parameter(shrink=0.95d0)
!
diftol=xtol
delta=0.618d0
delta=0.95d0
do i=1,ndim
xcent(i)=xbest(i)
enddo
dataassim/math/optimization/GenericOptim.f
+35
View File
@@ -0,0 +1,35 @@
subroutine GenericOptim(FuncToMinimize,f1dim_FuncToMinimize,
&ndim,beta,betamin,betamax,fatbeta)
implicit none
integer ndim,i
double precision beta(ndim),betamin(ndim),betamax(ndim),
&fatbeta
!
double precision ftol,fatbeta0,beta0(ndim)
parameter(ftol=1.0d-10)
external FuncToMinimize,f1dim_FuncToMinimize
call FuncToMinimize(ndim,beta,fatbeta)
10 fatbeta0=fatbeta
do i=1,ndim
beta0(i)=beta(i)
enddo
call nongradopt(ndim,FuncToMinimize,f1dim_FuncToMinimize,beta,
&betamin,betamax,ftol,fatbeta)
call FuncToMinimize(ndim,beta,fatbeta)
write(*,*)fatbeta
call RepeatCompassSearch(ndim,beta,fatbeta,betamin,betamax,
&FuncToMinimize,f1dim_FuncToMinimize,ftol)
call FuncToMinimize(ndim,beta,fatbeta)
write(*,*)fatbeta
write(*,*)
if((fatbeta0-fatbeta).gt.ftol)goto 10
if(fatbeta0.lt.fatbeta)then
fatbeta=fatbeta0
do i=1,ndim
beta(i)=beta0(i)
enddo
endif
return
end subroutine GenericOptim
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
dataassim/math/optimization/GenericRegres.f
+224 -91
View File
@@ -17,10 +17,11 @@
&beta_in_out(ndim0),betamin0(ndim0),betamax0(ndim0),
&shorty0(npoints,ny),shortx0(npoints,nx),fatbeta
!
integer i,j,INFO,ndim,k
integer i,j,INFO,ndim,k,n,i2,icompete,isitnaninf,nave
double precision xtol,beta(ndim0+nx*npoints),
&betacp(ndim0+nx*npoints),fatbetacp,beta0(ndim0+nx*npoints),
&fatbeta0,ftol,gacontrol(12),ran2,ftol_relax
&fatbeta0,ftol,gacontrol(12),ran2,ftol_relax,term1,term2,discount,
&history(2000,ndim0+3),upper,lower,f1dim_generic,generic_pikaia
parameter(xtol=1.0d-7,ftol=1.0d-7)
external funkmin_generic,FCN_generic,f1dim_generic,generic_pikaia
!-----------------------------------------------------
@@ -97,26 +98,124 @@ c (default is 0)
10 call funkmin_generic(ndim,beta,fatbeta)
do i=1,ndim
beta0(i)=beta(i)
history(1,i)=beta(i)
enddo
fatbeta0=fatbeta
history(1,ndim+1)=fatbeta
!entrance counter
history(1,ndim+2)=1.0d0
!failure counter
history(1,ndim+3)=0.0d0
!Is it a competition among different initial guesses?
icompete=0
!j the total number of calls to nongradopt; k is the number of returns to the current best and reset
!to zero if a better minumum is found; n is the number of scouting points over the landscape of the cost function.
!The first initial guess provided by the user is always part of the set of scouting points.the rest consist of outcomes
!from calls to nongradopt if they are significantly different from the current best.
j=0
k=0
ftol_relax=ftol*100.0d0
30 call nongradopt(ndim,funkmin_generic,
&f1dim_generic,beta,betamin,betamax,ftol_relax,fatbeta)
n=1
nave=1
ftol_relax=ftol*1000.0d0
discount=2.0d0
!relax the convergence criterion for scouting
30 fatbetacp=fatbeta
do i=1,ndim
betacp(i)=beta(i)
enddo
INFO=iregrestype
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)
call funkmin_generic(ndim,beta,fatbeta)
if((fatbeta+1.0d0).eq.fatbeta.or.fatbeta.gt.fatbeta0)then
if(isitnaninf(fatbeta).eq.1.or.fatbeta.gt.fatbetacp)then
fatbeta=fatbetacp
do i=1,ndim
beta(i)=betacp(i)
enddo
else
fatbetacp=fatbeta
do i=1,ndim
betacp(i)=beta(i)
enddo
endif
call nongradopt(ndim,funkmin_generic,f1dim_generic,
&beta,betamin,betamax,ftol_relax,fatbeta)
if(isitnaninf(fatbeta).eq.1.or.fatbeta.gt.fatbetacp)then
fatbeta=fatbetacp
do i=1,ndim
beta(i)=betacp(i)
enddo
endif
if(fatbeta.gt.1.0d0)then
term1=fatbeta*ftol_relax
else
term1=ftol_relax*10.0d0
endif
if(fatbeta.gt.fatbeta0)then
!failure
if((fatbeta-fatbeta0).gt.term1)then
if(icompete.eq.1)history(1,ndim+3)=history(1,ndim+3)+1.5d0
!even though fatbeta is much worse than fatbeta0, it is an output of optimization after all so
!include it in the set if it has not already been included in the set.
i=1
i2=1
40 if(dabs(history(i2,i)-beta(i)).gt.ftol_relax)then
if(dabs(history(i2,ndim+1)-fatbeta).lt.term1)then
history(i2,ndim+3)=history(i2,ndim+3)+1.0d0
goto 60
endif
if(i2.ge.n)goto 50
i2=i2+1
i=1
goto 40
else
if(i.ge.ndim)goto 60
i=i+1
goto 40
endif
50 n=n+1
do i=1,ndim
history(n,i)=beta(i)
enddo
history(n,ndim+1)=fatbeta
history(n,ndim+2)=0.0d0
history(n,ndim+3)=0.0d0
!use average only when there is imporvement
nave=n
else
!the difference is minimal even though fatbeta is larger than fatbeta0.
!Increment the counter for arriving at the same minimum.
if(icompete.eq.1)history(1,ndim+3)=history(1,ndim+3)+1.0d0
k=k+1
endif
60 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
!success
if((fatbeta0-fatbeta).lt.term1)then
!negligible improvement. Increment the counter for arriving at the same minimum.
!no increment for the set of central initial guesses
if(icompete.eq.1)history(1,ndim+3)=history(1,ndim+3)+0.5d0
k=k+1
else
!reset the counter for arriving at a better minimum
!reset the counter for arriving at a better minimum.
!Increment the set of central initial guesses
if(dabs(discount-2.0d0).lt.ftol)then
discount=dmax1(0.001d0,(fatbeta0-fatbeta)/1000.0d0)
endif
k=0
n=n+1
do i=1,ndim
history(n,i)=beta(i)
enddo
history(n,ndim+1)=fatbeta
history(n,ndim+2)=0.0d0
history(n,ndim+3)=0.0d0
endif
do i=1,ndim
beta0(i)=beta(i)
@@ -124,54 +223,125 @@ c (default is 0)
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
if(j.lt.20.and.k.lt.2)then
if(j.lt.10)then
term1=0.01d0+dmin1(history(1,ndim+3)*0.025d0,0.9d0)
history(1,ndim+2)=history(1,ndim+2)+1.0d0
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))
lower=history(1,i)-term1*(history(1,i)-betamin(i))
upper=history(1,i)+term1*(betamax(i)-history(1,i))
beta(i)=lower+ran2()*(upper-lower)
enddo
icompete=1
goto 70
endif
!try average
if(n.gt.nave)then
term1=1.0d0/(history(1,ndim+1)+1.0d-5)
do i=2,n
term1=term1+1.0d0/(history(i,ndim+1)+1.0d-5)
enddo
do i=1,ndim
beta(i)=history(1,i)/(term1*(history(1,ndim+1)+1.0d-5))
do icompete=2,n
beta(i)=beta(i)+history(icompete,i)/
&(term1*(history(icompete,ndim+1)+1.0d-5))
enddo
enddo
nave=n
icompete=0
goto 70
endif
!try different initial guesses
if(ran2().gt.0.2d0)then
!guess around the best
icompete=1
term1=history(1,ndim+1)+
&discount*history(1,ndim+2)*history(1,ndim+3)
do i=2,n
term2=history(i,ndim+1)+
&discount*history(i,ndim+2)*history(i,ndim+3)
if(term2.le.term1)then
term1=term2
do i2=1,ndim+3
history(n+1,i2)=history(i,i2)
history(i,i2)=history(1,i2)
history(1,i2)=history(n+1,i2)
enddo
endif
enddo
term1=0.01d0+dmin1(history(1,ndim+2)*history(1,ndim+3)*
&0.015d0,0.9d0)
history(1,ndim+2)=history(1,ndim+2)+1.0d0
do i=1,ndim
lower=history(1,i)-term1*(history(1,i)-betamin(i))
upper=history(1,i)+term1*(betamax(i)-history(1,i))
beta(i)=lower+ran2()*(upper-lower)
enddo
else
!completely random guess
do i=1,ndim
beta(i)=betamin(i)+ran2()*(betamax(i)-betamin(i))
enddo
icompete=0
endif
call funkmin_generic(ndim,beta,fatbeta)
70 call funkmin_generic(ndim,beta,fatbeta)
goto 30
else
if((ftol_relax-ftol).gt.ftol)then
if(k.le.1)then
n=n+1
do i=1,ndim+3
history(n,i)=history(1,i)
enddo
do i=1,ndim
history(1,i)=beta(i)
enddo
history(1,ndim+1)=fatbeta
history(1,ndim+2)=0.0d0
history(1,ndim+3)=0.0d0
do i=1,n
do icompete=1,ndim
betacp(icompete)=history(i,icompete)
enddo
fatbetacp=history(i,ndim+1)
call RepeatCompassSearch(ndim,betacp,fatbetacp,
&betamin,betamax,funkmin_generic,f1dim_generic,ftol_relax)
call funkmin_generic(ndim,betacp,fatbetacp)
if(isitnaninf(fatbetacp).eq.0.and.fatbetacp.lt.
&fatbeta)then
do icompete=1,ndim
beta(icompete)=betacp(icompete)
enddo
fatbeta=fatbetacp
endif
enddo
do i=1,ndim
beta0(i)=beta(i)
enddo
fatbeta0=fatbeta
icompete=1
j=0
else
icompete=0
endif
ftol_relax=ftol
goto 30
endif
endif
goto 110
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(isitnaninf(fatbeta).eq.1.or.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
@@ -182,65 +352,40 @@ c (default is 0)
do i=1,ndim
beta0(i)=(beta(i)-betamin(i))/(betamax(i)-betamin(i))
enddo
idobounded=0
fatbeta0=fatbeta
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
80 if(isitnaninf(fatbeta0).eq.1.or.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
!
INFO=iregrestype
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)
call funkmin_generic(ndim,beta,fatbeta)
if(isitnaninf(fatbeta).eq.1.or.fatbeta.gt.fatbeta0)then
do i=1,ndim
beta(i)=beta0(i)
enddo
fatbeta=fatbeta0
endif
iregrestype=iregrestype0
if(iregrestype.eq.2)then
do i=1,npoints
@@ -266,13 +411,7 @@ c (default is 0)
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
if(isitnaninf(fatbeta).eq.1.or.fatbeta.ge.fatbeta0)then
fatbeta=fatbeta0
do i=1,ndim
beta(i)=beta0(i)
@@ -286,19 +425,13 @@ c (default is 0)
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
if(isitnaninf(fatbetacp).eq.1.or.fatbetacp.ge.fatbeta)then
goto 110
else
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
@@ -310,7 +443,7 @@ c (default is 0)
call linmin(beta,betamin,betamax,betacp,ndim,
&f1dim_generic,fatbeta)
call funkmin_generic(ndim,beta,fatbeta)
if(dabs(fatbeta).lt.dabs(fatbeta0))goto 100
if(isitnaninf(fatbeta).eq.0.and.fatbeta.lt.fatbeta0)goto 100
fatbeta=fatbeta0
do i=1,ndim
beta(i)=beta0(i)
dataassim/math/optimization/cpCompassSearch.f
+2 -2
View File
@@ -3,7 +3,7 @@
implicit none
integer ndim
double precision xbest(1:ndim),fbest,
& bmin(1:ndim),bmax(1:ndim),xtol
& bmin(1:ndim),bmax(1:ndim),xtol,f1dim
double precision fvalpre,dmax,xpre(1:ndim),ftol,direction(ndim)
parameter(ftol=1.0d-7)
integer i,n
@@ -62,7 +62,7 @@
! =1 convergence criterion reached (minimum found)
!
integer ndim
double precision xbest(1:ndim),fbest,
double precision xbest(1:ndim),fbest,f1dim,
& bmin(1:ndim),bmax(1:ndim),xtol,dx1,dx2
external funkmin,f1dim
!------------------------------- Locals -----------------------------------------------------------
dataassim/math/optimization/cpnongradopt.f
+1 -1
View File
@@ -7,7 +7,7 @@
!
integer ndim
double precision beta(1:ndim),bmin(1:ndim),
& bmax(1:ndim),ftol,fatbeta
&bmax(1:ndim),ftol,fatbeta,f1dim
!
! ------------------ Inputs -----------------------------
! ndim: the total number of parameters to be estimated
dataassim/math/optimization/cppowell.f
+2 -2
View File
@@ -4,7 +4,7 @@
implicit none
INTEGER iter,n,np,NMAX,ITMAX
double precision fret,ftol,p(np),xi(np,np),TINY,
& pmin(np),pmax(np)
& pmin(np),pmax(np),f1dim
PARAMETER (NMAX=1000,TINY=1.0d-25)
CU USES funkmin,linmin
INTEGER i,ibig,j
@@ -57,7 +57,7 @@ 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)
double precision fret,p(n),xi(n),TOL,pmin(n),pmax(n),f1dim
PARAMETER (TOL=1.0d-8)
CU USES brent,f1dim,mnbrak
INTEGER j,k,ierr
dataassim/math/optimization/lbfgsroutines.f
+15 -15
View File
@@ -192,7 +192,7 @@ c ************
integer l1,l2,l3,lws,lr,lz,lt,ld,lwa,lwy,lsy,lss,lwt,lwn,lsnd
if (task .eq. 'START') then
if (task .eqv. 'START') then
isave(1) = m*n
isave(2) = m**2
isave(3) = 4*m**2
@@ -442,7 +442,7 @@ c ************
double precision one,zero
parameter (one=1.0d0,zero=0.0d0)
if (task .eq. 'START') then
if (task .eqv. 'START') then
call timer(time1)
@@ -508,7 +508,7 @@ c open a summary file 'iterate.dat'
c Check the input arguments for errors.
call errclb(n,m,factr,l,u,nbd,task,info,k)
if (task(1:5) .eq. 'ERROR') then
if (task(1:5) .eqv. 'ERROR') then
call prn3lb(n,x,f,task,iprint,info,itfile,
+ iter,nfgv,nintol,nskip,nact,sbgnrm,
+ zero,nint,word,iback,stp,xstep,k,
@@ -571,11 +571,11 @@ c restore local variables.
c After returning from the driver go to the point where execution
c is to resume.
if (task(1:5) .eq. 'FG_LN') goto 666
if (task(1:5) .eq. 'NEW_X') goto 777
if (task(1:5) .eq. 'FG_ST') goto 111
if (task(1:4) .eq. 'STOP') then
if (task(7:9) .eq. 'CPU') then
if (task(1:5) .eqv. 'FG_LN') goto 666
if (task(1:5) .eqv. 'NEW_X') goto 777
if (task(1:5) .eqv. 'FG_ST') goto 111
if (task(1:4) .eqv. 'STOP') then
if (task(7:9) .eqv. 'CPU') then
c restore the previous iterate.
call dcopy(n,t,1,x,1)
call dcopy(n,r,1,g,1)
@@ -771,7 +771,7 @@ c refresh the lbfgs memory and restart the iteration.
lnscht = lnscht + cpu2 - cpu1
goto 222
endif
else if (task(1:5) .eq. 'FG_LN') then
else if (task(1:5) .eqv. 'FG_LN') then
c return to the driver for calculating f and g; reenter at 666.
goto 1000
else
@@ -2444,7 +2444,7 @@ c **********
double precision ftol,gtol,xtol
parameter (ftol=1.0d-3,gtol=0.9d0,xtol=0.1d0)
if (task(1:5) .eq. 'FG_LN') goto 556
if (task(1:5) .eqv. 'FG_LN') goto 556
dtd = ddot(n,d,1,d,1)
dnorm = sqrt(dtd)
@@ -2789,7 +2789,7 @@ c ************
integer i
if (task(1:5) .eq. 'ERROR') goto 999
if (task(1:5) .eqv. 'ERROR') goto 999
if (iprint .ge. 0) then
write (6,3003)
@@ -3271,7 +3271,7 @@ c
c task = 'START'
c 10 continue
c call dcsrch( ... )
c if (task .eq. 'FG') then
c if (task .eqv. 'FG') then
c Evaluate the function and the gradient at stp
c goto 10
c end if
@@ -3377,7 +3377,7 @@ c **********
c Initialization block.
if (task(1:5) .eq. 'START') then
if (task(1:5) .eqv. 'START') then
c Check the input arguments for errors.
@@ -3392,7 +3392,7 @@ c Check the input arguments for errors.
c Exit if there are errors on input.
if (task(1:5) .eq. 'ERROR') return
if (task(1:5) .eqv. 'ERROR') return
c Initialize local variables.
@@ -3479,7 +3479,7 @@ c Test for convergence.
c Test for termination.
if (task(1:4) .eq. 'WARN' .or. task(1:4) .eq. 'CONV') goto 1000
if (task(1:4) .eqv. 'WARN' .or. task(1:4) .eqv. 'CONV') goto 1000
c A modified function is used to predict the step during the
c first stage if a lower function value has been obtained but
dataassim/math/optimization/mcts.f
+173
View File
@@ -0,0 +1,173 @@
Subroutine mctsglobalmin(ndim,funkmin_nongrad,f1dim_nongrad,
&beta,betamin,betamax,ftol,fatbeta)
implicit none
integer ndim
double precision beta(ndim),betamin(ndim),betamax(ndim),
&ftol,fatbeta
!
integer i,j,k,n,i2,icompete
double precision ran2,ftol_relax,term1,term2,beta0(ndim),
&fatbeta0,history(2000,ndim+3),discount
external funkmin_nongrad,f1dim_nongrad
!-----------------------------------------------------
!the cost funcation value for the first initial guess must be provided!
do i=1,ndim
beta0(i)=beta(i)
history(1,i)=beta(i)
enddo
fatbeta0=fatbeta
history(1,ndim+1)=fatbeta
!entrance counter
history(1,ndim+2)=1.0d0
!failure counter
history(1,ndim+3)=0.0d0
!Is it a competition among different initial guesses?
icompete=0
!j the total number of calls to nongradopt; k is the number of returns to the current best and reset
!to zero if a better minumum is found; n is the number of scouting points over the landscape of the cost function.
!The first initial guess provided by the user is always part of the set of scouting points.the rest consist of outcomes
!from calls to nongradopt if they are significantly different from the current best.
j=0
k=0
n=1
ftol_relax=ftol*1000.0d0
discount=2.0d0
!relax the convergence criterion for scouting
30 call nongradopt(ndim,funkmin_nongrad,f1dim_nongrad,
&beta,betamin,betamax,ftol_relax,fatbeta)
call funkmin_generic(ndim,beta,fatbeta)
if((fatbeta+1.0d0).eq.fatbeta.or.fatbeta.gt.fatbeta0)then
!failure
if((fatbeta+1.0d0).ne.fatbeta)then
if((fatbeta-fatbeta0).gt.10.0d0*ftol_relax)then
if(icompete.eq.1)history(1,ndim+3)=history(1,ndim+3)+1.5d0
!even though fatbeta is much worse than fatbeta0, it is an output of optimization after all so
!include it in the set if it has not already been included in the set.
i=1
i2=1
40 if(dabs(history(i2,i)-beta(i)).gt.ftol_relax)then
if(dabs(history(i2,ndim+1)-fatbeta).lt.ftol_relax)then
history(i2,ndim+3)=history(i2,ndim+3)+1.0d0
goto 60
endif
if(i2.ge.n)goto 50
i2=i2+1
i=1
goto 40
else
if(i.ge.ndim)goto 60
i=i+1
goto 40
endif
50 n=n+1
do i=1,ndim
history(n,i)=beta(i)
enddo
history(n,ndim+1)=fatbeta
history(n,ndim+2)=0.0d0
history(n,ndim+3)=0.0d0
else
!the difference is minimal even though fatbeta is larger than fatbeta0.
!Increment the counter for arriving at the same minimum.
if(icompete.eq.1)history(1,ndim+3)=history(1,ndim+3)+1.0d0
k=k+1
endif
else
if(icompete.eq.1)history(1,ndim+3)=history(1,ndim+3)+2.0d0
endif
60 do i=1,ndim
beta(i)=beta0(i)
enddo
fatbeta=fatbeta0
else
!success
if((fatbeta0-fatbeta).lt.10.0d0*ftol_relax)then
!negligible improvement. Increment the counter for arriving at the same minimum.
!no increment for the set of central initial guesses
if(icompete.eq.1)history(1,ndim+3)=history(1,ndim+3)+0.1d0
k=k+1
else
!reset the counter for arriving at a better minimum.
!Increment the set of central initial guesses
if(dabs(discount-2.0d0).lt.ftol)then
discount=dmax1(0.001d0,(fatbeta0-fatbeta)/1000.0d0)
endif
k=0
n=n+1
do i=1,ndim+3
history(n,i)=history(1,i)
enddo
do i=1,ndim
history(1,i)=beta(i)
enddo
history(1,ndim+1)=fatbeta
history(1,ndim+2)=0.0d0
history(1,ndim+3)=0.0d0
endif
do i=1,ndim
beta0(i)=beta(i)
enddo
fatbeta0=fatbeta
endif
j=j+1
if(j.lt.990.and.k.lt.3)then
!try different initial guesses
if(ran2().gt.0.1d0)then
!guess around the best
icompete=1
term1=history(1,ndim+1)+
&discount*history(1,ndim+2)*history(1,ndim+3)
do i=2,n
term2=history(i,ndim+1)+
&discount*history(i,ndim+2)*history(i,ndim+3)
if(term2.le.term1)then
term1=term2
do i2=1,ndim+3
history(n+1,i2)=history(i,i2)
history(i,i2)=history(1,i2)
history(1,i2)=history(n+1,i2)
enddo
endif
enddo
term1=0.5d0*history(i,ndim+2)*history(i,ndim+3)
history(1,ndim+2)=history(1,ndim+2)+1.0d0
do i=1,ndim
if(ran2().gt.0.5d0)then
if((betamax(i)-history(1,i)).gt.
&(betamax(i)-betamin(i))*1.0d-5)then
beta(i)=history(1,i)+(ran2()**(4.0d0/(term1+1.0d0)))*
&(betamax(i)-history(1,i))
else
beta(i)=betamax(i)-
&(ran2()**4.0d0)*(betamax(i)-betamin(i))
endif
else
if((history(1,i)-betamin(i)).gt.
&(betamax(i)-betamin(i))*1.0d-5)then
beta(i)=history(1,i)-(ran2()**(4.0d0/(term1+1.0d0)))*
&(history(1,i)-betamin(i))
else
beta(i)=betamin(i)+
&(ran2()**4.0d0)*(betamax(i)-betamin(i))
endif
endif
enddo
else
!completely random guess
icompete=0
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
if(k.le.1)j=0
goto 30
endif
endif
return
end subroutine mctsglobalmin
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
dataassim/math/optimization/nongradopt.f
+17 -14
View File
@@ -6,7 +6,7 @@
!
integer ndim
double precision beta(1:ndim),bmin(1:ndim),
& bmax(1:ndim),ftol,fatbeta
&bmax(1:ndim),ftol,fatbeta,f1dim
!
! ------------------ Inputs -----------------------------
! ndim: the total number of parameters to be estimated
@@ -24,7 +24,7 @@
integer n,nn,mpamoeba,npamoeba,iredo,maxredo,ITMAX,
& icycle
parameter(maxredo=10,ITMAX=10000)
parameter(maxredo=5,ITMAX=50000)
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)
@@ -50,7 +50,7 @@
fatbeta=fbest
goto 10
endif
if((fbest-fatbeta).gt.ftol)then
if((fbest-fatbeta).gt.100.0d0*ftol)then
if(iredo.gt.maxredo)goto 10
iredo=iredo+1
goto 3
@@ -92,6 +92,9 @@
if((fbest-fatbeta).gt.ftol*100.0d0.and.term.gt.1.0d-2)then
term=term/3.0d0
fbest=fatbeta
do n=1,ndim
xbest(n)=beta(n)
enddo
goto 30
endif
do n=1,ndim
@@ -144,7 +147,7 @@
return
endif
enddo
if((fbest-fatbeta).gt.ftol)then
if((fbest-fatbeta).gt.ftol*100.0d0)then
if(iredo.gt.maxredo)then
if(icycle.lt.maxredo)then
icycle=icycle+1
@@ -167,15 +170,15 @@
external funkmin
CU USES guamotry,funkmin
INTEGER i,ihi,ilo,inhi,j,m,n
double precision rtol,sum,swap,ysave,ytry,psum(ndim),
double precision rtol,cumx,swap,ysave,ytry,pcumx(ndim),
& guamotry,degen
iter=0
1 do 12 n=1,ndim
sum=0.0d0
cumx=0.0d0
do 11 m=1,ndim+1
sum=sum+p(m,n)
cumx=cumx+p(m,n)
11 continue
psum(n)=sum
pcumx(n)=cumx
12 continue
2 ilo=1
if (y(1).gt.y(2)) then
@@ -232,20 +235,20 @@ CU USES guamotry,funkmin
endif
if(iter.ge.ITMAX)return
iter=iter+2
ytry=guamotry(p,y,psum,mp,np,ndim,funkmin,ihi,-1.0d0)
ytry=guamotry(p,y,pcumx,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)
ytry=guamotry(p,y,pcumx,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)
ytry=guamotry(p,y,pcumx,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)
pcumx(j)=0.5d0*(p(i,j)+p(ilo,j))
p(i,j)=pcumx(j)
15 continue
call funkmin(ndim,psum,y(i))
call funkmin(ndim,pcumx,y(i))
endif
16 continue
iter=iter+ndim
dataassim/math/optimization/odr_leastsquare.f
+3 -4
View File
@@ -24,7 +24,6 @@ C VARIABLE DECLARATIONS
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)
@@ -96,7 +95,7 @@ C VARIABLE DECLARATIONS
+ WORK(LWORK),X(N,M),Y(N,NQ)
!------------For using information in WORK----------------------------
LOGICAL
+ ISODR
+ISODR
INTEGER
+ DELTAI,EPSI,XPLUSI,FNI,SDI,VCVI,
+ RVARI,WSSI,WSSDEI,WSSEPI,RCONDI,ETAI,
@@ -105,7 +104,7 @@ C VARIABLE DECLARATIONS
+ 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,
+ WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I,
+ LWKMN
c
integer i1,i2,i3,i4,i5,iderivative
@@ -230,7 +229,7 @@ C READ PROBLEM DATA, AND SET NONDEFAULT VALUE FOR ARGUMENT IFIXX
+ 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,
+ WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I,
+ LWKMN)
fvalue=0.0d0
do I=1,N
dataassim/math/optimization/odrpack.f
+150 -155
View File
@@ -6,7 +6,7 @@
*DMPREC
DOUBLE PRECISION FUNCTION DMPREC()
implicit none
integer ibeta,it,irnd,ngrd,machep,negep,iexp,minexp,
integer ibeta,it,irnd,ngrd,machep,negep,iexp,minexp,
*maxexp
double precision eps,epsneg,xmin,xmax
@@ -209,146 +209,146 @@ c TD = I1MACH(14)
c DMPREC = B ** (1-TD)
call machar_odr(ibeta,it,irnd,ngrd,machep,negep,iexp,
*minexp, maxexp,eps,epsneg,xmin,xmax)
*minexp,maxexp,eps,epsneg,xmin,xmax)
DMPREC=eps
RETURN
END
SUBROUTINE machar_odr(ibeta,it,irnd,ngrd,machep,negep,
*iexp,minexp, maxexp,eps,epsneg,xmin,xmax)
*iexp,minexp,maxexp,eps,epsneg,xmin,xmax)
implicit none
INTEGER ibeta,iexp,irnd,it,machep,maxexp,minexp,negep,ngrd
double precision eps,epsneg,xmax,xmin
INTEGER i,itemp,iz,j,k,mx,nxres
INTEGER ibeta,iexp,irnd,it,machep,maxexp,minexp,negep,ngrd
double precision eps,epsneg,xmax,xmin
INTEGER i,itemp,iz,j,k,mx,nxres
double precision a,b,beta,betah,betain,one,t,temp,temp1,tempa,
&two,y,z,zero, CONV
CONV(i)=dble(i)
one=CONV(1)
two=one+one
zero=one-one
a=one
1 continue
a=a+a
temp=a+one
temp1=temp-a
if (temp1-one.eq.zero) goto 1
b=one
2 continue
b=b+b
temp=a+b
itemp=int(temp-a)
if (itemp.eq.0) goto 2
ibeta=itemp
beta=CONV(ibeta)
it=0
b=one
3 continue
it=it+1
b=b*beta
temp=b+one
temp1=temp-b
if (temp1-one.eq.zero) goto 3
irnd=0
betah=beta/two
temp=a+betah
if (temp-a.ne.zero) irnd=1
tempa=a+beta
temp=tempa+betah
if ((irnd.eq.0).and.(temp-tempa.ne.zero)) irnd=2
negep=it+3
betain=one/beta
a=one
do 11 i=1, negep
a=a*betain
11 continue
b=a
4 continue
temp=one-a
if (temp-one.ne.zero) goto 5
a=a*beta
negep=negep-1
goto 4
5 negep=-negep
epsneg=a
machep=-it-3
a=b
6 continue
temp=one+a
if (temp-one.ne.zero) goto 7
a=a*beta
machep=machep+1
goto 6
7 eps=a
ngrd=0
temp=one+eps
if ((irnd.eq.0).and.(temp*one-one.ne.zero)) ngrd=1
i=0
k=1
z=betain
t=one+eps
nxres=0
8 continue
y=z
z=y*y
a=z*one
temp=z*t
if ((a+a.eq.zero).or.(dabs(z).ge.y)) goto 9
temp1=temp*betain
if (temp1*beta.eq.z) goto 9
i=i+1
k=k+k
goto 8
9 if (ibeta.ne.10) then
iexp=i+1
mx=k+k
else
iexp=2
iz=ibeta
10 if (k.ge.iz) then
iz=iz*ibeta
iexp=iexp+1
goto 10
endif
mx=iz+iz-1
endif
20 xmin=y
y=y*betain
a=y*one
temp=y*t
if (((a+a).ne.zero).and.(dabs(y).lt.xmin)) then
k=k+1
temp1=temp*betain
if ((temp1*beta.ne.y).or.(temp.eq.y)) then
goto 20
else
nxres=3
xmin=y
endif
endif
minexp=-k
if ((mx.le.k+k-3).and.(ibeta.ne.10)) then
mx=mx+mx
iexp=iexp+1
endif
maxexp=mx+minexp
irnd=irnd+nxres
if (irnd.ge.2) maxexp=maxexp-2
i=maxexp+minexp
if ((ibeta.eq.2).and.(i.eq.0)) maxexp=maxexp-1
if (i.gt.20) maxexp=maxexp-1
if (a.ne.y) maxexp=maxexp-2
xmax=one-epsneg
if (xmax*one.ne.xmax) xmax=one-beta*epsneg
xmax=xmax/(beta*beta*beta*xmin)
i=maxexp+minexp+3
do 12 j=1,i
if (ibeta.eq.2) xmax=xmax+xmax
if (ibeta.ne.2) xmax=xmax*beta
12 continue
return
END
C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
&two,y,z,zero,CONV
CONV(i)=dble(i)
one=CONV(1)
two=one+one
zero=one-one
a=one
1 continue
a=a+a
temp=a+one
temp1=temp-a
if (temp1-one.eq.zero) goto 1
b=one
2 continue
b=b+b
temp=a+b
itemp=int(temp-a)
if (itemp.eq.0) goto 2
ibeta=itemp
beta=CONV(ibeta)
it=0
b=one
3 continue
it=it+1
b=b*beta
temp=b+one
temp1=temp-b
if (temp1-one.eq.zero) goto 3
irnd=0
betah=beta/two
temp=a+betah
if (temp-a.ne.zero) irnd=1
tempa=a+beta
temp=tempa+betah
if ((irnd.eq.0).and.(temp-tempa.ne.zero)) irnd=2
negep=it+3
betain=one/beta
a=one
do 11 i=1, negep
a=a*betain
11 continue
b=a
4 continue
temp=one-a
if (temp-one.ne.zero) goto 5
a=a*beta
negep=negep-1
goto 4
5 negep=-negep
epsneg=a
machep=-it-3
a=b
6 continue
temp=one+a
if (temp-one.ne.zero) goto 7
a=a*beta
machep=machep+1
goto 6
7 eps=a
ngrd=0
temp=one+eps
if ((irnd.eq.0).and.(temp*one-one.ne.zero)) ngrd=1
i=0
k=1
z=betain
t=one+eps
nxres=0
8 continue
y=z
z=y*y
a=z*one
temp=z*t
if ((a+a.eq.zero).or.(dabs(z).ge.y)) goto 9
temp1=temp*betain
if (temp1*beta.eq.z) goto 9
i=i+1
k=k+k
goto 8
9 if (ibeta.ne.10) then
iexp=i+1
mx=k+k
else
iexp=2
iz=ibeta
10 if (k.ge.iz) then
iz=iz*ibeta
iexp=iexp+1
goto 10
endif
mx=iz+iz-1
endif
20 xmin=y
y=y*betain
a=y*one
temp=y*t
if (((a+a).ne.zero).and.(dabs(y).lt.xmin)) then
k=k+1
temp1=temp*betain
if ((temp1*beta.ne.y).or.(temp.eq.y)) then
goto 20
else
nxres=3
xmin=y
endif
endif
minexp=-k
if ((mx.le.k+k-3).and.(ibeta.ne.10)) then
mx=mx+mx
iexp=iexp+1
endif
maxexp=mx+minexp
irnd=irnd+nxres
if (irnd.ge.2) maxexp=maxexp-2
i=maxexp+minexp
if ((ibeta.eq.2).and.(i.eq.0)) maxexp=maxexp-1
if (i.gt.20) maxexp=maxexp-1
if (a.ne.y) maxexp=maxexp-2
xmax=one-epsneg
if (xmax*one.ne.xmax) xmax=one-beta*epsneg
xmax=xmax/(beta*beta*beta*xmin)
i=maxexp+minexp+3
do 12 j=1,i
if (ibeta.eq.2) xmax=xmax+xmax
if (ibeta.ne.2) xmax=xmax*beta
12 continue
return
END
C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
*DODR
SUBROUTINE DODR
@@ -966,7 +966,6 @@ C FIND STARTING LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE
+ DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI,
+ WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I,
+ LWKMN)
IF (ACCESS) THEN
C SET STARTING LOCATIONS FOR WORK VECTORS
@@ -1050,9 +1049,8 @@ C STORE VALUES INTO THE WORK VECTORS
IWORK(NITERI) = NITER
IWORK(NJEVI) = NJEV
IWORK(IDFI) = IDF
IWORK(INT2I) = INT2
IWORK(INT2I) = INT2
END IF
RETURN
END
*DESUBI
@@ -5916,7 +5914,6 @@ C***FIRST EXECUTABLE STATEMENT DODMN
C INITIALIZE NECESSARY VARIABLES
CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ,
+ ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT)
ACCESS = .TRUE.
@@ -5936,7 +5933,6 @@ C INITIALIZE NECESSARY VARIABLES
DIDVCV = .FALSE.
INTDBL = .FALSE.
LSTEP = .TRUE.
C PRINT INITIAL SUMMARY IF DESIRED
IF (IPR1.NE.0 .AND. LUNRPT.NE.0) THEN
@@ -6295,7 +6291,6 @@ C PRINT ITERATION REPORT
END IF
END IF
END IF
C CHECK IF FINISHED
IF (INFO.EQ.0) THEN
@@ -6315,9 +6310,7 @@ C STEP FAILED - RECOMPUTE UNLESS A STOPPING CRITERIA HAS BEEN MET
GO TO 110
END IF
END IF
150 CONTINUE
IF (ISTOP.GT.0) INFO = INFO + 100
C STORE UNWEIGHTED EPSILONS AND X+DELTA TO RETURN TO USER
@@ -6329,12 +6322,9 @@ C STORE UNWEIGHTED EPSILONS AND X+DELTA TO RETURN TO USER
END IF
CALL DUNPAC(NP,BETAC,BETA,IFIXB)
CALL DXPY(N,M,X,LDX,DELTA,N,XPLUSD,N)
C COMPUTE COVARIANCE MATRIX OF ESTIMATED PARAMETERS
C IN UPPER NP BY NP PORTION OF WORK(VCV) IF REQUESTED
IF (DOVCV .AND. ISTOP.EQ.0) THEN
IF (DOVCV .AND. ISTOP.EQ.0) THEN
C RE-EVALUATE JACOBIAN AT FINAL SOLUTION, IF REQUESTED
C OTHERWISE, JACOBIAN FROM BEGINNING OF LAST ITERATION WILL BE USED
C TO COMPUTE COVARIANCE MATRIX
@@ -6350,8 +6340,6 @@ C TO COMPUTE COVARIANCE MATRIX
+ T,WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK6),
+ FJACB,ISODR,FJACD,WE1,LDWE,LD2WE,
+ NJEV,NFEV,ISTOP,INFO)
IF (ISTOP.NE.0) THEN
INFO = 51000
GO TO 200
@@ -6359,7 +6347,6 @@ C TO COMPUTE COVARIANCE MATRIX
GO TO 200
END IF
END IF
IF (IMPLCT) THEN
CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,WRK(N*NQ+1),N)
RSS = DDOT_odr(N*M,DELTA,1,WRK(N*NQ+1),1)
@@ -6383,9 +6370,7 @@ C TO COMPUTE COVARIANCE MATRIX
END IF
DIDVCV = .TRUE.
END IF
END IF
C SET JPVT TO INDICATE DROPPED, FIXED AND ESTIMATED PARAMETERS
200 DO 210 I=0,NP-1
@@ -12072,15 +12057,23 @@ C***FIRST EXECUTABLE STATEMENT DNRM2_odr
DNRM2_odr = ZERO
GO TO 300
10 ASSIGN 30 TO NEXT
! 10 ASSIGN 30 TO NEXT
10 NEXT=30
SUM = ZERO
NN = N * INCX
C BEGIN MAIN LOOP
I = 1
C 20 GO TO NEXT,(30, 50, 70, 110)
20 GO TO NEXT
! 20 GO TO NEXT
!------------------------------
20 IF(NEXT.EQ.30) goto 30
IF(NEXT.EQ.50) goto 50
IF(NEXT.EQ.70) goto 70
IF(NEXT.EQ.110) goto 110
30 IF( DABS(DX(I)) .GT. CUTLO) GO TO 85
ASSIGN 50 TO NEXT
! ASSIGN 50 TO NEXT
NEXT=50
XMAX = ZERO
C PHASE 1. SUM IS ZERO
@@ -12089,13 +12082,15 @@ C PHASE 1. SUM IS ZERO
IF( DABS(DX(I)) .GT. CUTLO) GO TO 85
C PREPARE FOR PHASE 2.
ASSIGN 70 TO NEXT
! ASSIGN 70 TO NEXT
NEXT=70
GO TO 105
C PREPARE FOR PHASE 4.
100 I = J
ASSIGN 110 TO NEXT
! ASSIGN 110 TO NEXT
NEXT=110
SUM = (SUM / DX(I)) / DX(I)
105 XMAX = DABS(DX(I))
GO TO 115
dataassim/math/optimization/odrpack95/d_drive1.f
+226
View File
@@ -0,0 +1,226 @@
PROGRAM SAMPLE
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=5,MAXN=25,MAXNP=5,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)
EXTERNAL FCN
C SPECIFY DEFAULT VALUES FOR DODRC ARGUMENTS
WE(1,1,1) = -1.0D0
WD(1,1,1) = -1.0D0
IFIXB(1) = -1
IFIXX(1,1) = -1
JOB = -1
NDIGIT = -1
TAUFAC = -1.0D0
SSTOL = -1.0D0
PARTOL = -1.0D0
MAXIT = -1
IPRINT = -1
LUNERR = -1
LUNRPT = -1
STPB(1) = -1.0D0
STPD(1,1) = -1.0D0
SCLB(1) = -1.0D0
SCLD(1,1) = -1.0D0
C SET UP ODRPACK REPORT FILES
LUNERR = 9
LUNRPT = 9
OPEN (UNIT=9,FILE='REPORT1')
C READ PROBLEM DATA, AND SET NONDEFAULT VALUE FOR ARGUMENT IFIXX
OPEN (UNIT=5,FILE='DATA1')
READ (5,FMT=*) N,M,NP,NQ
READ (5,FMT=*) (BETA(I),I=1,NP)
DO 10 I=1,N
READ (5,FMT=*) (X(I,J),J=1,M),(Y(I,L),L=1,NQ)
IF (X(I,1).EQ.0.0D0 .OR. X(I,1).EQ.100.0D0) THEN
IFIXX(I,1) = 0
ELSE
IFIXX(I,1) = 1
END IF
10 CONTINUE
C SPECIFY TASK: EXPLICIT ORTHOGONAL DISTANCE REGRESSION
C WITH USER SUPPLIED DERIVATIVES (CHECKED)
C COVARIANCE MATRIX CONSTRUCTED WITH RECOMPUTED DERIVATIVES
C DELTA INITIALIZED TO ZERO
C NOT A RESTART
C AND INDICATE SHORT INITIAL REPORT
C SHORT ITERATION REPORTS EVERY ITERATION, AND
C LONG FINAL REPORT
JOB = 00020
IPRINT = 1112
C COMPUTE SOLUTION
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)
END
SUBROUTINE FCN(N,M,NP,NQ,
+ LDN,LDM,LDNP,
+ BETA,XPLUSD,
+ IFIXB,IFIXX,LDIFX,
+ IDEVAL,F,FJACB,FJACD,
+ ISTOP)
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)
C LOCAL VARIABLES
INTRINSIC EXP
C CHECK FOR UNACCEPTABLE VALUES FOR THIS PROBLEM
IF (BETA(1) .LT. 0.0D0) THEN
ISTOP = 1
RETURN
ELSE
ISTOP = 0
END IF
C COMPUTE PREDICTED VALUES
IF (MOD(IDEVAL,10).GE.1) THEN
DO 110 L = 1,NQ
DO 100 I = 1,N
F(I,L) = BETA(1) +
+ BETA(2)*(EXP(BETA(3)*XPLUSD(I,1)) - 1.0D0)**2
100 CONTINUE
110 CONTINUE
END IF
C COMPUTE DERIVATIVES WITH RESPECT TO BETA
IF (MOD(IDEVAL/10,10).GE.1) THEN
DO 210 L = 1,NQ
DO 200 I = 1,N
FJACB(I,1,L) = 1.0D0
FJACB(I,2,L) = (EXP(BETA(3)*XPLUSD(I,1)) - 1.0D0)**2
FJACB(I,3,L) = BETA(2)*2*
+ (EXP(BETA(3)*XPLUSD(I,1)) - 1.0D0)*
+ EXP(BETA(3)*XPLUSD(I,1))*XPLUSD(I,1)
200 CONTINUE
210 CONTINUE
END IF
C COMPUTE DERIVATIVES WITH RESPECT TO DELTA
IF (MOD(IDEVAL/100,10).GE.1) THEN
DO 310 L = 1,NQ
DO 300 I = 1,N
FJACD(I,1,L) = BETA(2)*2*
+ (EXP(BETA(3)*XPLUSD(I,1)) - 1.0D0)*
+ EXP(BETA(3)*XPLUSD(I,1))*BETA(3)
300 CONTINUE
310 CONTINUE
END IF
RETURN
END
dataassim/math/optimization/odrpack95/d_drive2.f
+160
View File
@@ -0,0 +1,160 @@
PROGRAM SAMPLE
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 (UNUSED WHEN MODEL IS IMPLICIT)
C ==> LDY LEADING DIMENSION OF ARRAY Y
C ==> X EXPLANATORY VARIABLE
C ==> LDX LEADING DIMENSION OF ARRAY X
C ==> WE INITIAL PENALTY PARAMETER FOR IMPLICIT MODEL
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 ==> JOB TASK TO BE PERFORMED
C ==> IPRINT PRINT CONTROL
C ==> LUNERR LOGICAL UNIT FOR ERROR REPORTS
C ==> LUNRPT LOGICAL UNIT FOR COMPUTATION REPORTS
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 LDWD,LDWE,LDX,LDY,LD2WD,LD2WE,
+ LIWORK,LWORK,MAXM,MAXN,MAXNP,MAXNQ
PARAMETER (MAXM=5,MAXN=25,MAXNP=5,MAXNQ=2,
+ LDY=MAXN,LDX=MAXN,
+ LDWE=1,LD2WE=1,LDWD=1,LD2WD=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,LUNERR,LUNRPT,M,N,NP,NQ
INTEGER IWORK(LIWORK)
DOUBLE PRECISION BETA(MAXNP),
+ WD(LDWD,LD2WD,MAXM),WE(LDWE,LD2WE,MAXNQ),
+ WORK(LWORK),X(LDX,MAXM),Y(LDY,MAXNQ)
EXTERNAL FCN
C SPECIFY DEFAULT VALUES FOR DODR ARGUMENTS
WE(1,1,1) = -1.0D0
WD(1,1,1) = -1.0D0
JOB = -1
IPRINT = -1
LUNERR = -1
LUNRPT = -1
C SET UP ODRPACK REPORT FILES
LUNERR = 9
LUNRPT = 9
OPEN (UNIT=9,FILE='REPORT2')
C READ PROBLEM DATA
OPEN (UNIT=5,FILE='DATA2')
READ (5,FMT=*) N,M,NP,NQ
READ (5,FMT=*) (BETA(I),I=1,NP)
DO 10 I=1,N
READ (5,FMT=*) (X(I,J),J=1,M)
10 CONTINUE
C SPECIFY TASK: IMPLICIT ORTHOGONAL DISTANCE REGRESSION
C WITH FORWARD FINITE DIFFERENCE DERIVATIVES
C COVARIANCE MATRIX CONSTRUCTED WITH RECOMPUTED DERIVATIVES
C DELTA INITIALIZED TO ZERO
C NOT A RESTART
JOB = 00001
C COMPUTE SOLUTION
CALL DODR(FCN,
+ N,M,NP,NQ,
+ BETA,
+ Y,LDY,X,LDX,
+ WE,LDWE,LD2WE,WD,LDWD,LD2WD,
+ JOB,
+ IPRINT,LUNERR,LUNRPT,
+ WORK,LWORK,IWORK,LIWORK,
+ INFO)
END
SUBROUTINE FCN(N,M,NP,NQ,
+ LDN,LDM,LDNP,
+ BETA,XPLUSD,
+ IFIXB,IFIXX,LDIFX,
+ IDEVAL,F,FJACB,FJACD,
+ ISTOP)
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)
C CHECK FOR UNACCEPTABLE VALUES FOR THIS PROBLEM
IF (BETA(1) .GT. 0.0D0) THEN
ISTOP = 1
RETURN
ELSE
ISTOP = 0
END IF
C COMPUTE PREDICTED VALUES
IF (MOD(IDEVAL,10).GE.1) THEN
DO 110 L = 1,NQ
DO 100 I = 1,N
F(I,L) = BETA(3)*(XPLUSD(I,1)-BETA(1))**2 +
+ 2*BETA(4)*(XPLUSD(I,1)-BETA(1))*
+ (XPLUSD(I,2)-BETA(2)) +
+ BETA(5)*(XPLUSD(I,2)-BETA(2))**2 - 1.0D0
100 CONTINUE
110 CONTINUE
END IF
RETURN
END
dataassim/math/optimization/odrpack95/d_drive3.f
+248
View File
@@ -0,0 +1,248 @@
PROGRAM SAMPLE
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 FCN 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=5,MAXN=100,MAXNP=25,MAXNQ=5,
+ LDY=MAXN,LDX=MAXN,
+ LDWE=MAXN,LD2WE=MAXNQ,LDWD=MAXN,LD2WD=1,
+ LDIFX=MAXN,LDSCLD=1,LDSTPD=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)
EXTERNAL FCN
C SPECIFY DEFAULT VALUES FOR DODRC ARGUMENTS
WE(1,1,1) = -1.0D0
WD(1,1,1) = -1.0D0
IFIXB(1) = -1
IFIXX(1,1) = -1
JOB = -1
NDIGIT = -1
TAUFAC = -1.0D0
SSTOL = -1.0D0
PARTOL = -1.0D0
MAXIT = -1
IPRINT = -1
LUNERR = -1
LUNRPT = -1
STPB(1) = -1.0D0
STPD(1,1) = -1.0D0
SCLB(1) = -1.0D0
SCLD(1,1) = -1.0D0
C SET UP ODRPACK REPORT FILES
LUNERR = 9
LUNRPT = 9
OPEN (UNIT=9,FILE='REPORT3')
C READ PROBLEM DATA
OPEN (UNIT=5,FILE='DATA3')
READ (5,FMT=*) N,M,NP,NQ
READ (5,FMT=*) (BETA(I),I=1,NP)
DO 10 I=1,N
READ (5,FMT=*) (X(I,J),J=1,M),(Y(I,L),L=1,NQ)
10 CONTINUE
C SPECIFY TASK AS EXPLICIT ORTHOGONAL DISTANCE REGRESSION
C WITH CENTRAL DIFFERENCE DERIVATIVES
C COVARIANCE MATRIX CONSTRUCTED WITH RECOMPUTED DERIVATIVES
C DELTA INITIALIZED BY USER
C NOT A RESTART
C AND INDICATE LONG INITIAL REPORT
C NO ITERATION REPORTS
C LONG FINAL REPORT
JOB = 01010
IPRINT = 2002
C INITIALIZE DELTA, AND SPECIFY FIRST DECADE OF FREQUENCIES AS FIXED
DO 20 I=1,N
IF (X(I,1).LT.100.0D0) THEN
WORK(I) = 0.0D0
IFIXX(I,1) = 0
ELSE IF (X(I,1).LE.150.0D0) THEN
WORK(I) = 0.0D0
IFIXX(I,1) = 1
ELSE IF (X(I,1).LE.1000.0D0) THEN
WORK(I) = 25.0D0
IFIXX(I,1) = 1
ELSE IF (X(I,1).LE.10000.0D0) THEN
WORK(I) = 560.0D0
IFIXX(I,1) = 1
ELSE IF (X(I,1).LE.100000.0D0) THEN
WORK(I) = 9500.0D0
IFIXX(I,1) = 1
ELSE
WORK(I) = 144000.0D0
IFIXX(I,1) = 1
END IF
20 CONTINUE
C SET WEIGHTS
DO 30 I=1,N
IF (X(I,1).EQ.100.0D0 .OR. X(I,1).EQ.150.0D0) THEN
WE(I,1,1) = 0.0D0
WE(I,1,2) = 0.0D0
WE(I,2,1) = 0.0D0
WE(I,2,2) = 0.0D0
ELSE
WE(I,1,1) = 559.6D0
WE(I,1,2) = -1634.0D0
WE(I,2,1) = -1634.0D0
WE(I,2,2) = 8397.0D0
END IF
WD(I,1,1) = (1.0D-4)/(X(I,1)**2)
30 CONTINUE
C COMPUTE SOLUTION
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)
END
SUBROUTINE FCN(N,M,NP,NQ,
+ LDN,LDM,LDNP,
+ BETA,XPLUSD,
+ IFIXB,IFIXX,LDIFX,
+ IDEVAL,F,FJACB,FJACD,
+ ISTOP)
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,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)
C LOCAL VARIABLES
DOUBLE PRECISION FREQ,PI,OMEGA,CTHETA,STHETA,THETA,PHI,R
INTRINSIC ATAN2,EXP,SQRT
C CHECK FOR UNACCEPTABLE VALUES FOR THIS PROBLEM
DO 10 I=1,N
IF (XPLUSD(I,1).LT.0.0D0) THEN
ISTOP = 1
RETURN
END IF
10 CONTINUE
ISTOP = 0
PI = 3.141592653589793238462643383279D0
THETA = PI*BETA(4)*0.5D0
CTHETA = COS(THETA)
STHETA = SIN(THETA)
C COMPUTE PREDICTED VALUES
IF (MOD(IDEVAL,10).GE.1) THEN
DO 100 I = 1,N
FREQ = XPLUSD(I,1)
OMEGA = (2.0D0*PI*FREQ*EXP(-BETA(3)))**BETA(4)
PHI = ATAN2((OMEGA*STHETA),(1+OMEGA*CTHETA))
R = (BETA(1)-BETA(2)) *
+ SQRT((1+OMEGA*CTHETA)**2+
+ (OMEGA*STHETA)**2)**(-BETA(5))
F(I,1) = BETA(2) + R*COS(BETA(5)*PHI)
F(I,2) = R*SIN(BETA(5)*PHI)
100 CONTINUE
END IF
RETURN
END
dataassim/math/optimization/odrpack95/d_lpkbls.f
+2249
View File
File diff suppressed because it is too large Load Diff
dataassim/math/optimization/odrpack95/d_mprec0.f
+203
View File
@@ -0,0 +1,203 @@
*DMPREC
DOUBLE PRECISION FUNCTION DMPREC()
C***BEGIN PROLOGUE DPREC
C***REFER TO DODR,DODRC
C***ROUTINES CALLED (NONE)
C***DATE WRITTEN 860529 (YYMMDD)
C***REVISION DATE 920304 (YYMMDD)
C***PURPOSE DETERMINE MACHINE PRECISION FOR TARGET MACHINE AND COMPILER
C ASSUMING FLOATING-POINT NUMBERS ARE REPRESENTED IN THE
C T-DIGIT, BASE-B FORM
C SIGN (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
C WHERE 0 .LE. X(I) .LT. B FOR I=1,...,T, AND
C 0 .LT. X(1).
C TO ALTER THIS FUNCTION FOR A PARTICULAR TARGET MACHINE,
C EITHER
C ACTIVATE THE DESIRED SET OF DATA STATEMENTS BY
C REMOVING THE C FROM COLUMN 1
C OR
C SET B, TD AND TS USING I1MACH BY ACTIVATING
C THE DECLARATION STATEMENTS FOR I1MACH
C AND THE STATEMENTS PRECEEDING THE FIRST
C EXECUTABLE STATEMENT BELOW.
C***END PROLOGUE DPREC
C...LOCAL SCALARS
DOUBLE PRECISION
+ B
INTEGER
+ TD,TS
C...EXTERNAL FUNCTIONS
C INTEGER
C + I1MACH
C EXTERNAL
C + I1MACH
C...VARIABLE DEFINITIONS (ALPHABETICALLY)
C DOUBLE PRECISION B
C THE BASE OF THE TARGET MACHINE.
C (MAY BE DEFINED USING I1MACH(10).)
C INTEGER TD
C THE NUMBER OF BASE-B DIGITS IN DOUBLE PRECISION.
C (MAY BE DEFINED USING I1MACH(14).)
C INTEGER TS
C THE NUMBER OF BASE-B DIGITS IN SINGLE PRECISION.
C (MAY BE DEFINED USING I1MACH(11).)
C MACHINE CONSTANTS FOR COMPUTERS FOLLOWING IEEE ARITHMETIC STANDARD
C (E.G., MOTOROLA 68000 BASED MACHINES SUCH AS SUN AND SPARC
C WORKSTATIONS, AND AT&T PC 7300; AND 8087 BASED MICROS SUCH AS THE
C IBM PC AND THE AT&T 6300).
C DATA B / 2 /
C DATA TS / 24 /
C DATA TD / 53 /
C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM.
C DATA B / 2 /
C DATA TS / 24 /
C DATA TD / 60 /
C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM
C THE BURROUGHS 6700/7700 SYSTEMS
C DATA B / 8 /
C DATA TS / 13 /
C DATA TD / 26 /
C MACHINE CONSTANTS FOR THE CDC 6000/7000 (FTN5 COMPILER)
C THE CYBER 170/180 SERIES UNDER NOS
C DATA B / 2 /
C DATA TS / 48 /
C DATA TD / 96 /
C MACHINE CONSTANTS FOR THE CDC 6000/7000 (FTN COMPILER)
C THE CYBER 170/180 SERIES UNDER NOS/VE
C THE CYBER 200 SERIES
C DATA B / 2 /
C DATA TS / 47 /
C DATA TD / 94 /
C MACHINE CONSTANTS FOR THE CRAY
C DATA B / 2 /
C DATA TS / 47 /
C DATA TD / 94 /
C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200
C DATA B / 16 /
C DATA TS / 6 /
C DATA TD / 14 /
C MACHINE CONSTANTS FOR THE HARRIS COMPUTER
C DATA B / 2 /
C DATA TS / 23 /
C DATA TD / 38 /
C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70
C THE HONEYWELL 600/6000 SERIES
C DATA B / 2 /
C DATA TS / 27 /
C DATA TD / 63 /
C MACHINE CONSTANTS FOR THE HP 2100
C (3 WORD DOUBLE PRECISION OPTION WITH FTN4)
C DATA B / 2 /
C DATA TS / 23 /
C DATA TD / 39 /
C MACHINE CONSTANTS FOR THE HP 2100
C (4 WORD DOUBLE PRECISION OPTION WITH FTN4)
C DATA B / 2 /
C DATA TS / 23 /
C DATA TD / 55 /
C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES
C DATA B / 16 /
C DATA TS / 6 /
C DATA TD / 14 /
C MACHINE CONSTANTS FOR THE IBM PC
C DATA B / 2 /
C DATA TS / 24 /
C DATA TD / 53 /
C MACHINE CONSTANTS FOR THE INTERDATA (PERKIN ELMER) 7/32
C INTERDATA (PERKIN ELMER) 8/32
C DATA B / 16 /
C DATA TS / 6 /
C DATA TD / 14 /
C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR).
C DATA B / 2 /
C DATA TS / 27 /
C DATA TD / 54 /
C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR).
C DATA B / 2 /
C DATA TS / 27 /
C DATA TD / 62 /
C MACHINE CONSTANTS FOR THE PDP-11 SYSTEM
C DATA B / 2 /
C DATA TS / 24 /
C DATA TD / 56 /
C MACHINE CONSTANTS FOR THE PERKIN-ELMER 3230
C DATA B / 16 /
C DATA TS / 6 /
C DATA TD / 14 /
C MACHINE CONSTANTS FOR THE PRIME 850 AND PRIME 4050
C DATA B / 2 /
C DATA TS / 23 /
C DATA TD / 47 /
C MACHINE CONSTANTS FOR THE SEL SYSTEMS 85/86
C DATA B / 16 /
C DATA TS / 6 /
C DATA TD / 14 /
C MACHINE CONSTANTS FOR SUN AND SPARC WORKSTATIONS
C DATA B / 2 /
C DATA TS / 24 /
C DATA TD / 53 /
C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES
C DATA B / 2 /
C DATA TS / 27 /
C DATA TD / 60 /
C MACHINE CONSTANTS FOR THE VAX-11 WITH FORTRAN IV-PLUS COMPILER
C DATA B / 2 /
C DATA TS / 24 /
C DATA TD / 56 /
C MACHINE CONSTANTS FOR THE VAX/VMS SYSTEM WITHOUT G_FLOATING
C DATA B / 2 /
C DATA TS / 24 /
C DATA TD / 56 /
C MACHINE CONSTANTS FOR THE VAX/VMS SYSTEM WITH G_FLOATING
C DATA B / 2 /
C DATA TS / 24 /
C DATA TD / 53 /
C MACHINE CONSTANTS FOR THE XEROX SIGMA 5/7/9
C DATA B / 16 /
C DATA TS / 6 /
C DATA TD / 14 /
C***FIRST EXECUTABLE STATEMENT DMPREC
C B = I1MACH(10)
C TS = I1MACH(11)
C TD = I1MACH(14)
DMPREC = B ** (1-TD)
RETURN
END
dataassim/math/optimization/odrpack95/d_odr.f
+10985
View File
File diff suppressed because it is too large Load Diff
dataassim/math/optimization/odrpack95/data1.dat
+14
View File
@@ -0,0 +1,14 @@
12 1 3 1
1500.0 -50.0 -0.1
0.0 1265.0
0.0 1263.6
5.0 1258.0
7.0 1254.0
7.5 1253.0
10.0 1249.8
16.0 1237.0
26.0 1218.0
30.0 1220.6
34.0 1213.8
34.5 1215.5
100.0 1212.0
dataassim/math/optimization/odrpack95/data2.dat
+22
View File
@@ -0,0 +1,22 @@
20 2 5 1
-1.0 -3.0 0.09 0.02 0.08
0.50 -0.12
1.20 -0.60
1.60 -1.00
1.86 -1.40
2.12 -2.54
2.36 -3.36
2.44 -4.00
2.36 -4.75
2.06 -5.25
1.74 -5.64
1.34 -5.97
0.90 -6.32
-0.28 -6.44
-0.78 -6.44
-1.36 -6.41
-1.90 -6.25
-2.50 -5.88
-2.88 -5.50
-3.18 -5.24
-3.44 -4.86
dataassim/math/optimization/odrpack95/data3.dat
+25
View File
@@ -0,0 +1,25 @@
23 1 5 2
4.0 2.0 7.0 0.40 0.50
30.0 4.220 0.136
50.0 4.167 0.167
70.0 4.132 0.188
100.0 4.038 0.212
150.0 4.019 0.236
200.0 3.956 0.257
300.0 3.884 0.276
500.0 3.784 0.297
700.0 3.713 0.309
1000.0 3.633 0.311
1500.0 3.540 0.314
2000.0 3.433 0.311
3000.0 3.358 0.305
5000.0 3.258 0.289
7000.0 3.193 0.277
10000.0 3.128 0.255
15000.0 3.059 0.240
20000.0 2.984 0.218
30000.0 2.934 0.202
50000.0 2.876 0.182
70000.0 2.838 0.168
100000.0 2.798 0.153
150000.0 2.759 0.139
dataassim/math/optimization/odrpack95/drive1.f
+236
View File
@@ -0,0 +1,236 @@
PROGRAM SAMPLE
USE ODRPACK95
USE REAL_PRECISION
C ODRPACK95 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 ==> WE "Epsilon" weights
C ==> WD "Delta" weights
C ==> IFIXB Indicators for "fixing" parameters (BETA)
C ==> IFIXX Indicators for "fixing" explanatory variable (X)
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 ==> SCLB Scale values for parameters BETA
C ==> SCLD Scale values for errors delta in explanatory variable
C <==> WORK REAL (KIND=R8) work vector
C <== IWORK Integer work vector
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=5,MAXN=25,MAXNP=5,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(:)
REAL (KIND=R8) PARTOL,SSTOL,TAUFAC
REAL (KIND=R8) BETA(MAXNP),SCLB(MAXNP),SCLD(LDSCLD,MAXM),
& STPB(MAXNP),STPD(LDSTPD,MAXM),
& WD(LDWD,LD2WD,MAXM),WE(LDWE,LD2WE,MAXNQ),
& WORK(:),X(LDX,MAXM),Y(LDY,MAXNQ)
EXTERNAL FCN
POINTER IWORK,WORK
C Allocate work arrays
ALLOCATE(IWORK(LIWORK),WORK(LWORK))
C Specify default values for ODR arguments
WE(1,1,1) = -1.0E0_R8
WD(1,1,1) = -1.0E0_R8
IFIXB(1) = -1
IFIXX(1,1) = -1
JOB = -1
NDIGIT = -1
TAUFAC = -1.0E0_R8
SSTOL = -1.0E0_R8
PARTOL = -1.0E0_R8
MAXIT = -1
IPRINT = -1
LUNERR = -1
LUNRPT = -1
STPB(1) = -1.0E0_R8
STPD(1,1) = -1.0E0_R8
SCLB(1) = -1.0E0_R8
SCLD(1,1) = -1.0E0_R8
C Set up ODRPACK95 report files
LUNERR = 9
LUNRPT = 9
OPEN (UNIT=9,FILE='REPORT1')
C Read problem data, and set nondefault value for argument IFIXX
OPEN (UNIT=5,FILE='DATA1')
READ (5,FMT=*) N,M,NP,NQ
READ (5,FMT=*) (BETA(I),I=1,NP)
DO 10 I=1,N
READ (5,FMT=*) (X(I,J),J=1,M),(Y(I,L),L=1,NQ)
IF (X(I,1).EQ.0.0E0_R8 .OR. X(I,1).EQ.100.0E0_R8) THEN
IFIXX(I,1) = 0
ELSE
IFIXX(I,1) = 1
END IF
10 CONTINUE
C Specify task: Explicit orthogonal distance regression
C With user supplied derivatives (checked)
C Covariance matrix constructed with recomputed derivatives
C Delta initialized to zero
C Not a restart
C And indicate short initial report
C Short iteration reports every iteration, and
C Long final report
JOB = 00020
IPRINT = 1112
C Compute solution
CALL ODR(FCN=FCN,
& N=N,M=M,NP=NP,NQ=NQ,
& BETA=BETA,
& Y=Y,X=X,
& WE=WE,WD=WD,
& IFIXB=IFIXB,IFIXX=IFIXX,
& JOB=JOB,NDIGIT=NDIGIT,TAUFAC=TAUFAC,
& SSTOL=SSTOL,PARTOL=PARTOL,MAXIT=MAXIT,
& IPRINT=IPRINT,LUNERR=LUNERR,LUNRPT=LUNRPT,
& STPB=STPB,STPD=STPD,
& SCLB=SCLB,SCLD=SCLD,
& WORK=WORK,IWORK=IWORK,
& INFO=INFO)
END
SUBROUTINE FCN(N,M,NP,NQ,
& LDN,LDM,LDNP,
& BETA,XPLUSD,
& IFIXB,IFIXX,LDIFX,
& IDEVAL,F,FJACB,FJACD,
& ISTOP)
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; ODRPACK95 should select values
C closer to most recently used values if possible
C -1 means current BETA and X+DELTA are
C not acceptable; ODRPACK95 should stop
C Used modules
USE REAL_PRECISION
C Input arguments, not to be changed by this routine:
INTEGER I,IDEVAL,ISTOP,L,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
REAL (KIND=R8) BETA(NP),XPLUSD(LDN,M)
INTEGER IFIXB(NP),IFIXX(LDIFX,M)
C Output arguments:
REAL (KIND=R8) F(LDN,NQ),FJACB(LDN,LDNP,NQ),FJACD(LDN,LDM,NQ)
C Local variables
INTRINSIC EXP
C Do something with IFIXB and IFIXX to avoid warnings that they are not being
C used. This is simply not to worry users that the example program is failing.
IF (IFIXB(1) .GT. 0 .AND. IFIXX(1,1) .GT. 0 ) THEN
C Do nothing.
END IF
C Check for unacceptable values for this problem
IF (BETA(1) .LT. 0.0E0_R8) THEN
ISTOP = 1
RETURN
ELSE
ISTOP = 0
END IF
C Compute predicted values
IF (MOD(IDEVAL,10).GE.1) THEN
DO 110 L = 1,NQ
DO 100 I = 1,N
F(I,L) = BETA(1) +
& BETA(2)*(EXP(BETA(3)*XPLUSD(I,1)) - 1.0E0_R8)**2
100 CONTINUE
110 CONTINUE
END IF
C Compute derivatives with respect to BETA
IF (MOD(IDEVAL/10,10).GE.1) THEN
DO 210 L = 1,NQ
DO 200 I = 1,N
FJACB(I,1,L) = 1.0E0_R8
FJACB(I,2,L) = (EXP(BETA(3)*XPLUSD(I,1)) - 1.0E0_R8)**2
FJACB(I,3,L) = BETA(2)*2*
& (EXP(BETA(3)*XPLUSD(I,1)) - 1.0E0_R8)*
& EXP(BETA(3)*XPLUSD(I,1))*XPLUSD(I,1)
200 CONTINUE
210 CONTINUE
END IF
C Compute derivatives with respect to DELTA
IF (MOD(IDEVAL/100,10).GE.1) THEN
DO 310 L = 1,NQ
DO 300 I = 1,N
FJACD(I,1,L) = BETA(2)*2*
& (EXP(BETA(3)*XPLUSD(I,1)) - 1.0E0_R8)*
& EXP(BETA(3)*XPLUSD(I,1))*BETA(3)
300 CONTINUE
310 CONTINUE
END IF
RETURN
END
dataassim/math/optimization/odrpack95/drive2.f
+170
View File
@@ -0,0 +1,170 @@
PROGRAM SAMPLE
USE ODRPACK95
USE REAL_PRECISION
C ODRPACK95 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 (unused when model is implicit)
C ==> X Explanatory variable
C ==> WE Initial penalty parameter for implicit model
C ==> WD "Delta" weights
C ==> JOB Task to be performed
C ==> IPRINT Print control
C ==> LUNERR Logical unit for error reports
C ==> LUNRPT Logical unit for computation reports
C <==> WORK REAL (KIND=R8) work vector
C <== IWORK Integer work vector
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 LDWD,LDWE,LDX,LDY,LD2WD,LD2WE,
& LIWORK,LWORK,MAXM,MAXN,MAXNP,MAXNQ
PARAMETER (MAXM=5,MAXN=25,MAXNP=5,MAXNQ=2,
& LDY=MAXN,LDX=MAXN,
& LDWE=1,LD2WE=1,LDWD=1,LD2WD=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,LUNERR,LUNRPT,M,N,NP,NQ
INTEGER IWORK(:)
REAL (KIND=R8) BETA(MAXNP),
& WD(LDWD,LD2WD,MAXM),WE(LDWE,LD2WE,MAXNQ),
& WORK(:),X(LDX,MAXM),Y(LDY,MAXNQ)
EXTERNAL FCN
POINTER IWORK,WORK
C Allocate work arrays
ALLOCATE(IWORK(LIWORK),WORK(LWORK))
C Specify default values for DODR arguments
WE(1,1,1) = -1.0E0_R8
WD(1,1,1) = -1.0E0_R8
JOB = -1
IPRINT = -1
LUNERR = -1
LUNRPT = -1
C Set up ODRPACK95 report files
LUNERR = 9
LUNRPT = 9
OPEN (UNIT=9,FILE='REPORT2')
C Read problem data
OPEN (UNIT=5,FILE='DATA2')
READ (5,FMT=*) N,M,NP,NQ
READ (5,FMT=*) (BETA(I),I=1,NP)
DO 10 I=1,N
READ (5,FMT=*) (X(I,J),J=1,M)
10 CONTINUE
C Specify task: Implicit orthogonal distance regression
C With forward finite difference derivatives
C Covariance matrix constructed with recomputed derivatives
C DELTA initialized to zero
C Not a restart
JOB = 00001
C Compute solution
CALL ODR(FCN=FCN,
& N=N,M=M,NP=NP,NQ=NQ,
& BETA=BETA,
& Y=Y,X=X,
& WE=WE,WD=WD,
& JOB=JOB,
& IPRINT=IPRINT,LUNERR=LUNERR,LUNRPT=LUNRPT,
& WORK=WORK,IWORK=IWORK,
& INFO=INFO)
END
SUBROUTINE FCN(N,M,NP,NQ,
& LDN,LDM,LDNP,
& BETA,XPLUSD,
& IFIXB,IFIXX,LDIFX,
& IDEVAL,F,FJACB,FJACD,
& ISTOP)
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; ODRPACK95 should select values
C closer to most recently used values if possible
C -1 Means current BETA and X+DELTA are
C not acceptable; ODRPACK95 should stop
C Used Modules
USE REAL_PRECISION
C Input arguments, not to be changed by this routine:
INTEGER I,IDEVAL,ISTOP,L,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
REAL (KIND=R8) BETA(NP),XPLUSD(LDN,M)
INTEGER IFIXB(NP),IFIXX(LDIFX,M)
C Output arguments:
REAL (KIND=R8) F(LDN,NQ),FJACB(LDN,LDNP,NQ),FJACD(LDN,LDM,NQ)
C Do something with FJACD, FJACB, IFIXB and IFIXX to avoid warnings that they
C are not being used. This is simply not to worry users that the example
C program is failing.
IF (IFIXB(1) .GT. 0 .AND. IFIXX(1,1) .GT. 0
& .AND. FJACB(1,1,1) .GT. 0 .AND. FJACD(1,1,1) .GT. 0 ) THEN
C Do nothing.
END IF
C Check for unacceptable values for this problem
IF (BETA(1) .GT. 0.0E0_R8) THEN
ISTOP = 1
RETURN
ELSE
ISTOP = 0
END IF
C Compute predicted values
IF (MOD(IDEVAL,10).GE.1) THEN
DO 110 L = 1,NQ
DO 100 I = 1,N
F(I,L) = BETA(3)*(XPLUSD(I,1)-BETA(1))**2 +
& 2*BETA(4)*(XPLUSD(I,1)-BETA(1))*
& (XPLUSD(I,2)-BETA(2)) +
& BETA(5)*(XPLUSD(I,2)-BETA(2))**2 - 1.0E0_R8
100 CONTINUE
110 CONTINUE
END IF
RETURN
END
dataassim/math/optimization/odrpack95/drive3.f
+301
View File
@@ -0,0 +1,301 @@
PROGRAM SAMPLE
USE ODRPACK95
USE REAL_PRECISION
C ODRPACK95 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 ==> WE "Epsilon" weights
C ==> WD "Delta" weights
C ==> IFIXB Indicators for "fixing" parameters (BETA)
C ==> IFIXX Indicators for "fixing" explanatory variable (X)
C ==> JOB Task to be performed
C ==> NDIGIT Good digits in subroutine fcn 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 ==> SCLB Scale values for parameters BETA
C ==> SCLD Scale values for errors DELTA in explanatory variable
C <==> WORK REAL (KIND=R8) work vector
C <== IWORK Integer work vector
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=5,MAXN=100,MAXNP=25,MAXNQ=5,
& LDY=MAXN,LDX=MAXN,
& LDWE=MAXN,LD2WE=MAXNQ,LDWD=MAXN,LD2WD=1,
& LDIFX=MAXN,LDSCLD=1,LDSTPD=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(:)
REAL (KIND=R8) PARTOL,SSTOL,TAUFAC
REAL (KIND=R8) BETA(MAXNP),DELTA(:,:),
& SCLB(MAXNP),SCLD(LDSCLD,MAXM),
& STPB(MAXNP),STPD(LDSTPD,MAXM),
& WD(LDWD,LD2WD,MAXM),WE(LDWE,LD2WE,MAXNQ),
& WORK(:),X(LDX,MAXM),Y(LDY,MAXNQ)
EXTERNAL FCN
POINTER DELTA,IWORK,WORK
C Specify default values for DODRC arguments
WE(1,1,1) = -1.0E0_R8
WD(1,1,1) = -1.0E0_R8
IFIXB(1) = -1
IFIXX(1,1) = -1
JOB = -1
NDIGIT = -1
TAUFAC = -1.0E0_R8
SSTOL = -1.0E0_R8
PARTOL = -1.0E0_R8
MAXIT = -1
IPRINT = -1
LUNERR = -1
LUNRPT = -1
STPB(1) = -1.0E0_R8
STPD(1,1) = -1.0E0_R8
SCLB(1) = -1.0E0_R8
SCLD(1,1) = -1.0E0_R8
C Set up ODRPACK95 report files
LUNERR = 9
LUNRPT = 9
OPEN (UNIT=9,FILE='REPORT3')
C Read problem data
OPEN (UNIT=5,FILE='DATA3')
READ (5,FMT=*) N,M,NP,NQ
READ (5,FMT=*) (BETA(I),I=1,NP)
DO 10 I=1,N
READ (5,FMT=*) (X(I,J),J=1,M),(Y(I,L),L=1,NQ)
10 CONTINUE
C Allocate work arrays
ALLOCATE(DELTA(N,M),IWORK(LIWORK),WORK(LWORK))
C Specify task as explicit orthogonal distance regression
C With central difference derivatives
C Covariance matrix constructed with recomputed derivatives
C DELTA initialized by user
C Not a restart
C And indicate long initial report
C No iteration reports
C Long final report
JOB = 01010
IPRINT = 2002
C Initialize DELTA, and specify first decade of frequencies as fixed
DO 20 I=1,N
IF (X(I,1).LT.100.0E0_R8) THEN
DELTA(I,1) = 0.0E0_R8
IFIXX(I,1) = 0
ELSE IF (X(I,1).LE.150.0E0_R8) THEN
DELTA(I,1) = 0.0E0_R8
IFIXX(I,1) = 1
ELSE IF (X(I,1).LE.1000.0E0_R8) THEN
DELTA(I,1) = 25.0E0_R8
IFIXX(I,1) = 1
ELSE IF (X(I,1).LE.10000.0E0_R8) THEN
DELTA(I,1) = 560.0E0_R8
IFIXX(I,1) = 1
ELSE IF (X(I,1).LE.100000.0E0_R8) THEN
DELTA(I,1) = 9500.0E0_R8
IFIXX(I,1) = 1
ELSE
DELTA(I,1) = 144000.0E0_R8
IFIXX(I,1) = 1
END IF
20 CONTINUE
C Set weights
DO 30 I=1,N
IF (X(I,1).EQ.100.0E0_R8 .OR. X(I,1).EQ.150.0E0_R8) THEN
WE(I,1,1) = 0.0E0_R8
WE(I,1,2) = 0.0E0_R8
WE(I,2,1) = 0.0E0_R8
WE(I,2,2) = 0.0E0_R8
ELSE
WE(I,1,1) = 559.6E0_R8
WE(I,1,2) = -1634.0E0_R8
WE(I,2,1) = -1634.0E0_R8
WE(I,2,2) = 8397.0E0_R8
END IF
WD(I,1,1) = (1.0E-4_R8)/(X(I,1)**2)
30 CONTINUE
C Compute solution
CALL ODR(FCN=FCN,
& N=N,M=M,NP=NP,NQ=NQ,
& BETA=BETA,
& Y=Y,X=X,
& DELTA=DELTA,
& WE=WE,WD=WD,
& IFIXB=IFIXB,IFIXX=IFIXX,
& JOB=JOB,NDIGIT=NDIGIT,TAUFAC=TAUFAC,
& SSTOL=SSTOL,PARTOL=PARTOL,MAXIT=MAXIT,
& IPRINT=IPRINT,LUNERR=LUNERR,LUNRPT=LUNRPT,
& STPB=STPB,STPD=STPD,
& SCLB=SCLB,SCLD=SCLD,
& WORK=WORK,IWORK=IWORK,
& INFO=INFO)
END
SUBROUTINE FCN(N,M,NP,NQ,
& LDN,LDM,LDNP,
& BETA,XPLUSD,
& IFIXB,IFIXX,LDIFX,
& IDEVAL,F,FJACB,FJACD,
& ISTOP)
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; ODRPACK95 should select values
C closer to most recently used values if possible
C -1 Means current BETA and X+DELTA are
C not acceptable; ODRPACK95 should stop
C Used modules
USE REAL_PRECISION
C Input arguments, not to be changed by this routine:
INTEGER I,IDEVAL,ISTOP,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
REAL (KIND=R8) BETA(NP),XPLUSD(LDN,M)
INTEGER IFIXB(NP),IFIXX(LDIFX,M)
C Output arguments:
REAL (KIND=R8) F(LDN,NQ),FJACB(LDN,LDNP,NQ),FJACD(LDN,LDM,NQ)
C Local variables
REAL (KIND=R8) FREQ,PI,OMEGA,CTHETA,STHETA,THETA,PHI,R
INTRINSIC ATAN2,EXP,SQRT
C Do something with FJACD, FJACB, IFIXB and IFIXX to avoid warnings that they
C are not being used. This is simply not to worry users that the example
C program is failing.
IF (IFIXB(1) .GT. 0 .AND. IFIXX(1,1) .GT. 0
& .AND. FJACB(1,1,1) .GT. 0 .AND. FJACD(1,1,1) .GT. 0 ) THEN
C Do nothing.
END IF
C Check for unacceptable values for this problem
DO 10 I=1,N
IF (XPLUSD(I,1).LT.0.0E0_R8) THEN
ISTOP = 1
RETURN
END IF
10 CONTINUE
ISTOP = 0
PI = 3.141592653589793238462643383279E0_R8
THETA = PI*BETA(4)*0.5E0_R8
CTHETA = COS(THETA)
STHETA = SIN(THETA)
C Compute predicted values
IF (MOD(IDEVAL,10).GE.1) THEN
DO 100 I = 1,N
FREQ = XPLUSD(I,1)
OMEGA = (2.0E0_R8*PI*FREQ*EXP(-BETA(3)))**BETA(4)
PHI = ATAN2((OMEGA*STHETA),(1+OMEGA*CTHETA))
R = (BETA(1)-BETA(2)) *
& SQRT((1+OMEGA*CTHETA)**2+
& (OMEGA*STHETA)**2)**(-BETA(5))
F(I,1) = BETA(2) + R*COS(BETA(5)*PHI)
F(I,2) = R*SIN(BETA(5)*PHI)
100 CONTINUE
END IF
RETURN
END
dataassim/math/optimization/odrpack95/drive4.f
+151
View File
@@ -0,0 +1,151 @@
C This sample problem comes from Zwolak et al. 2001 (High Performance Computing
C Symposium, "Estimating rate constants in cell cycle models"). The call to
C ODRPACK95 is modified from the call the authors make to ODRPACK. This is
C done to illustrate the need for bounds. The authors could just have easily
C used the call statement here to solve their problem.
C
C Curious users are encouraged to remove the bounds in the call statement,
C run the code, and compare the results to the current call statement.
PROGRAM SAMPLE
USE REAL_PRECISION
USE ODRPACK95
IMPLICIT NONE
C INTEGER :: I
C REAL (KIND=R8) :: C, M, TOUT
INTERFACE
SUBROUTINE FCN(N,M,NP,NQ,LDN,LDM,LDNP,BETA,XPLUSD,IFIXB,
+ IFIXX,LDIFX,IDEVAL,F,FJACB,FJACD,ISTOP)
USE REAL_PRECISION
INTEGER, INTENT(IN) :: IDEVAL,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
INTEGER, INTENT(IN) :: IFIXB(NP),IFIXX(LDIFX,M)
REAL(KIND=R8), INTENT(IN) :: BETA(NP),XPLUSD(LDN,M)
INTEGER, INTENT(OUT) :: ISTOP
REAL(KIND=R8), INTENT(OUT) :: F(LDN,NQ),FJACB(LDN,LDNP,NQ),
+ FJACD(LDN,LDM,NQ)
END SUBROUTINE FCN
END INTERFACE
REAL(KIND=R8) :: BETA(3) = (/ 1.1E-0_R8, 3.3E+0_R8, 8.7_R8 /)
OPEN(9,FILE="REPORT4")
CALL ODR(
+ FCN,
+ N = 5, M = 1, NP = 3, NQ = 1,
+ BETA = BETA,
+ Y = RESHAPE((/ 55.0_R8, 45.0_R8, 40.0_R8, 30.0_R8, 20.0_R8 /),
+ (/5,1/)),
+ X = RESHAPE((/ 0.15_R8, 0.20_R8, 0.25_R8, 0.30_R8, 0.50_R8 /),
+ (/5,1/)),
+ LOWER = (/ 0.0_R8, 0.0_R8, 0.0_R8 /),
+ UPPER = (/ 1000.0_R8, 1000.0_R8, 1000.0_R8 /),
+ IPRINT = 2122,
+ LUNRPT = 9,
+ MAXIT = 20
+)
CLOSE(9)
C The following code will reproduce the plot in Figure 2 of Zwolak et
C al. 2001.
C DO I = 0, 100
C C = 0.05+(0.7-0.05)*I/100
C TOUT = 1440.0D0
C !CALL MPF(M,C,1.1D-10,3.3D-3,8.7D0,0.0D0,TOUT,C/2)
C CALL MPF(M,C,1.15395968E-02_R8, 2.61676386E-03_R8,
C + 9.23138811E+00_R8,0.0D0,TOUT,C/2)
C WRITE(*,*) C, TOUT
C END DO
END PROGRAM
SUBROUTINE FCN(N,M,NP,NQ,LDN,LDM,LDNP,BETA,XPLUSD,IFIXB,
+ IFIXX,LDIFX,IDEVAL,F,FJACB,FJACD,ISTOP)
USE REAL_PRECISION
IMPLICIT NONE
INTEGER, INTENT(IN) :: IDEVAL,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
INTEGER, INTENT(IN) :: IFIXB(NP),IFIXX(LDIFX,M)
REAL(KIND=R8), INTENT(IN) :: BETA(NP),XPLUSD(LDN,M)
INTEGER, INTENT(OUT) :: ISTOP
REAL(KIND=R8), INTENT(OUT) :: F(LDN,NQ),FJACB(LDN,LDNP,NQ),
+ FJACD(LDN,LDM,NQ)
! Local variables
REAL(KIND=R8) :: MOUT
INTEGER :: I
ISTOP = 0
FJACB(:,:,:) = 0.0E0_R8
FJACD(:,:,:) = 0.0E0_R8
IF ( MOD(IDEVAL,10).GE.1 ) THEN
DO I = 1, N
F(I,1) = 1440.0_R8
CALL MPF(MOUT,XPLUSD(I,1),BETA(1),BETA(2),BETA(3),0.0_R8,
+ F(I,1),XPLUSD(I,1)/2)
END DO
END IF
END SUBROUTINE FCN
C-------------------------------------------------------------------------------
C
C MPF
C
C If ROOT is not zero then returns value of time when M==ROOT in TOUT. Else,
C runs until TOUT and returns value in M. If PRINT_EVERY is non-zero then
C the solution is printed every PRINT_EVERY time units or every H (which ever
C is greater).
C
C This routine is not meant to be precise, it is only intended to be good
C enough for providing a working example of ODRPACK95 with bounds. 4th order
C Runge Kutta and linear interpolation are used for numerical integration and
C root finding, respectively.
C
C M - MPF
C C - Total Cyclin
C KWEE, K25, K25P - Model parameters (BETA(1:3))
C
SUBROUTINE MPF(M,C,KWEE,K25,K25P,PRINT_EVERY,TOUT,ROOT)
USE REAL_PRECISION
REAL (KIND=R8), INTENT(OUT) :: M
REAL (KIND=R8), INTENT(IN) :: C, KWEE, K25, K25P,
+ PRINT_EVERY, ROOT
REAL (KIND=R8), INTENT(INOUT) :: TOUT
! Local variables
REAL (KIND=R8), PARAMETER :: H = 1.0D-1
REAL (KIND=R8) :: LAST_PRINT, LAST_M, LAST_T, T
REAL (KIND=R8) :: K1, K2, K3, K4
INTERFACE
FUNCTION DMDT(M,C,KWEE,K25,K25P) RESULT(RES)
USE REAL_PRECISION
REAL (KIND=R8) :: M, C, KWEE, K25, K25P, RES
END FUNCTION
END INTERFACE
M = 0.0D0
T = 0.0D0
LAST_PRINT = 0.0D0
IF ( PRINT_EVERY .GT. 0.0D0 ) THEN
WRITE(*,*) T, M
END IF
DO WHILE ( T .LT. TOUT )
LAST_T = T
LAST_M = M
K1 = H*DMDT(M,C,KWEE,K25,K25P)
K2 = H*DMDT(M+K1/2,C,KWEE,K25,K25P)
K3 = H*DMDT(M+K2/2,C,KWEE,K25,K25P)
K4 = H*DMDT(M+K3,C,KWEE,K25,K25P)
M = M+(K1+2*K2+2*K3+K4)/6
T = T + H
IF ( T .GE. PRINT_EVERY+LAST_PRINT .AND.
+ PRINT_EVERY .GT. 0.0D0 )
+ THEN
WRITE(*,*) T, M
LAST_PRINT = T
END IF
IF ( ROOT .GT. 0.0D0 ) THEN
IF ( LAST_M .LE. ROOT .AND. ROOT .LT. M ) THEN
TOUT = (T-LAST_T)/(M-LAST_M)*(ROOT-LAST_M)+LAST_T
RETURN
END IF
END IF
END DO
END SUBROUTINE MPF
C Equation from Zwolak et al. 2001.
FUNCTION DMDT(M,C,KWEE,K25,K25P) RESULT(RES)
USE REAL_PRECISION
REAL (KIND=R8) :: M, C, KWEE, K25, K25P, RES
RES = KWEE*M+(K25+K25P*M**2)*(C-M)
END FUNCTION DMDT
dataassim/math/optimization/odrpack95/lpkbls.f
+2355
View File
File diff suppressed because it is too large Load Diff
dataassim/math/optimization/odrpack95/makefile.txt
+108
View File
@@ -0,0 +1,108 @@
# This makefile creates a library >> odrpack.a << comprised of both the single
# and double precision versions of ODRPACK. It also runs each of the test
# problems for both versions. Change S_SOURCE (D_SOURCE) and S_TESTS (D_TESTS)
# as approprite if only the double precision (single precision) version is to
# be installed.
# NB: This makefile creates a temporary subdirectory, >> ZodrpackZ <<, for
# splitting and compiling the individual subprograms in each of the
# release files. The makefile will fail if such a subdirectory already
# exists. The subdirectory is automatically removed upon completion.
# Note also that some systems need to invoke ranlib, while others do not:
# if your system lacks ranlib, simply comment out the ranlib invocation
# below. Also, compiler names and options, and/or names of data files may
# have to be modified for some systems.
.SUFFIXES: .f .o .a .out
F77 = f77 # specify compiler name as appropriate
F77OPT = -u -O # specify desired compiler options here
LIB = odrpack.a # specify ODRPACK library name
DIR = ZodrpackZ # specify temporary subdirectory name
L = # specify directory for library files
# Specify what files are to be installed, where
# D_SOURCE = double-precision non-test source files
# = d_odr.f d_lpkbls.f d_mprec.f
# S_SOURCE = single-precision non-test source files
# = s_odr.f s_lpkbls.f s_mprec.f
D_SOURCE = d_odr.f d_lpkbls.f d_mprec.f
S_SOURCE = s_odr.f s_lpkbls.f s_mprec.f
# Test installation...
tests: D_TESTS S_TESTS
D_TESTS: d_drive1.out d_drive2.out d_drive3.out d_test.out
S_TESTS: s_drive1.out s_drive2.out s_drive3.out s_test.out
# Create ODRPACK library...
$(LIB): $(D_SOURCE) $(S_SOURCE)
mkdir $(DIR)
cd $(DIR) ;\
for i in $? ;\
do fsplit ../$$i ;\
$(F77) -c $(F77OPT) *.f ;\
ar ruv ../$@ *.o ;\
rm *.f *.o ;\
done ;\
cd ..
rm -rf $(DIR)
ranlib $(LIB)
d_mprec.f: d_mprec0.f
true # Obtain d_mprec.f from d_mprec0.f by activating the statements
false # appropriate to your machine
s_mprec.f: s_mprec0.f
true # Obtain s_mprec.f from s_mprec0.f by activating the statements
false # appropriate to your machine
# Run double-precision test problems...
d_drive1.out: d_drive1.f $(LIB) data1.dat
cp data1.dat DATA1
$(F77) d_drive1.f $(LIB) $L; a.out
mv REPORT1 $@; rm -f DATA1 d_drive1.o a.out
d_drive2.out: d_drive2.f $(LIB) data2.dat
cp data2.dat DATA2
$(F77) d_drive2.f $(LIB) $L; a.out
mv REPORT2 $@; rm -f DATA2 d_drive2.o a.out
d_drive3.out: d_drive3.f $(LIB) data3.dat
cp data3.dat DATA3
$(F77) d_drive3.f $(LIB) $L; a.out
mv REPORT3 $@; rm -f DATA3 d_drive3.o a.out
d_test.out: d_test.f $(LIB)
$(F77) d_test.f $(LIB) $L; a.out
mv REPORT $@; cat SUMMARY >> $@; rm -f d_test.o a.out SUMMARY
# Run single-precision test problems...
s_drive1.out: s_drive1.f $(LIB) data1.dat
cp data1.dat DATA1
$(F77) s_drive1.f $(LIB) $L; a.out
mv REPORT1 $@; rm -f DATA1 s_drive1.o a.out
s_drive2.out: s_drive2.f $(LIB) data2.dat
cp data2.dat DATA2
$(F77) s_drive2.f $(LIB) $L; a.out
mv REPORT2 $@; rm -f DATA2 s_drive2.o a.out
s_drive3.out: s_drive3.f $(LIB) data3.dat
cp data3.dat DATA3
$(F77) s_drive3.f $(LIB) $L; a.out
mv REPORT3 $@; rm -f DATA3 s_drive3.o a.out
s_test.out: s_test.f $(LIB)
$(F77) s_test.f $(LIB) $L; a.out
mv REPORT $@; cat SUMMARY >> $@; rm -f s_test.o a.out SUMMARY
dataassim/math/optimization/odrpack95/odr.f
+12136
View File
File diff suppressed because it is too large Load Diff
dataassim/math/optimization/odrpack95/real_precision.f
+5
View File
@@ -0,0 +1,5 @@
C From HOMPACK90.
MODULE REAL_PRECISION
C This is for 64-bit arithmetic.
INTEGER, PARAMETER:: R8=SELECTED_REAL_KIND(13)
END MODULE REAL_PRECISION
dataassim/math/optimization/odrpack95/restart_example.f
+172
View File
@@ -0,0 +1,172 @@
C
C This example takes drive4.f and modifies it to stop ODRPACK95 and use the
C restart facility. Run diff to see what additions were made.
C
C This sample problem comes from Zwolak et al. 2001 (High Performance Computing
C Symposium, "Estimating rate constants in cell cycle models"). The call to
C ODRPACK95 is modified from the call the authors make to ODRPACK. This is
C done to illustrate the need for bounds. The authors could just have easily
C used the call statement here to solve their problem.
C
C Curious users are encouraged to remove the bounds in the call statement,
C run the code, and compare the results to the current call statement.
PROGRAM SAMPLE
USE REAL_PRECISION
USE ODRPACK95
IMPLICIT NONE
INTEGER :: I
REAL (KIND=R8) :: C, M, TOUT
INTERFACE
SUBROUTINE FCN(N,M,NP,NQ,LDN,LDM,LDNP,BETA,XPLUSD,IFIXB,
+ IFIXX,LDIFX,IDEVAL,F,FJACB,FJACD,ISTOP)
USE REAL_PRECISION
INTEGER, INTENT(IN) :: IDEVAL,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
INTEGER, INTENT(IN) :: IFIXB(NP),IFIXX(LDIFX,M)
REAL(KIND=R8), INTENT(IN) :: BETA(NP),XPLUSD(LDN,M)
INTEGER, INTENT(OUT) :: ISTOP
REAL(KIND=R8), INTENT(OUT) :: F(LDN,NQ),FJACB(LDN,LDNP,NQ),
+ FJACD(LDN,LDM,NQ)
END SUBROUTINE FCN
END INTERFACE
REAL(KIND=R8) :: BETA(3) = (/ 1.1E-0_R8, 3.3E+0_R8, 8.7_R8 /)
REAL(KIND=R8), POINTER :: WORK(:)
INTEGER, POINTER :: IWORK(:)
OPEN(9,FILE="REPORT_RESTART")
WORK => NULL()
IWORK => NULL()
CALL ODR(
+ FCN,
+ N = 5, M = 1, NP = 3, NQ = 1,
+ BETA = BETA,
+ Y = RESHAPE((/ 55.0_R8, 45.0_R8, 40.0_R8, 30.0_R8, 20.0_R8 /),
+ (/5,1/)),
+ X = RESHAPE((/ 0.15_R8, 0.20_R8, 0.25_R8, 0.30_R8, 0.50_R8 /),
+ (/5,1/)),
+ LOWER = (/ 0.0_R8, 0.0_R8, 0.0_R8 /),
+ IPRINT = 6666,
+ LUNRPT = 9,
+ MAXIT = 20,
+ WORK = WORK,
+ IWORK = IWORK
+)
WRITE(*,*) "Restarting ----------------------------------------"
CALL ODR(
+ FCN,
+ N = 5, M = 1, NP = 3, NQ = 1,
+ BETA = BETA,
+ Y = RESHAPE((/ 55.0_R8, 45.0_R8, 40.0_R8, 30.0_R8, 20.0_R8 /),
+ (/5,1/)),
+ X = RESHAPE((/ 0.15_R8, 0.20_R8, 0.25_R8, 0.30_R8, 0.50_R8 /),
+ (/5,1/)),
+ LOWER = (/ 0.0_R8, 0.0_R8, 0.0_R8 /),
+ IPRINT = 6666,
+ LUNRPT = 9,
+ MAXIT = 20,
+ WORK = WORK,
+ IWORK = IWORK,
+ JOB = 10000
+)
CLOSE(9)
C The following code will reproduce the plot in Figure 2 of Zwolak et
C al. 2001.
C DO I = 0, 100
C C = 0.05+(0.7-0.05)*I/100
C TOUT = 1440.0D0
C !CALL MPF(M,C,1.1D-10,3.3D-3,8.7D0,0.0D0,TOUT,C/2)
C CALL MPF(M,C,1.15395968E-02_R8, 2.61676386E-03_R8,
C + 9.23138811E+00_R8,0.0D0,TOUT,C/2)
C WRITE(*,*) C, TOUT
C END DO
END PROGRAM
SUBROUTINE FCN(N,M,NP,NQ,LDN,LDM,LDNP,BETA,XPLUSD,IFIXB,
+ IFIXX,LDIFX,IDEVAL,F,FJACB,FJACD,ISTOP)
USE REAL_PRECISION
IMPLICIT NONE
INTEGER, INTENT(IN) :: IDEVAL,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
INTEGER, INTENT(IN) :: IFIXB(NP),IFIXX(LDIFX,M)
REAL(KIND=R8), INTENT(IN) :: BETA(NP),XPLUSD(LDN,M)
INTEGER, INTENT(OUT) :: ISTOP
REAL(KIND=R8), INTENT(OUT) :: F(LDN,NQ),FJACB(LDN,LDNP,NQ),
+ FJACD(LDN,LDM,NQ)
! Local variables
REAL(KIND=R8) :: MOUT
INTEGER :: I
ISTOP = 0
FJACB(:,:,:) = 0.0E0_R8
FJACD(:,:,:) = 0.0E0_R8
IF ( MOD(IDEVAL,10).GE.1 ) THEN
DO I = 1, N
F(I,1) = 1440.0_R8
CALL MPF(MOUT,XPLUSD(I,1),BETA(1),BETA(2),BETA(3),0.0_R8,
+ F(I,1),XPLUSD(I,1)/2)
END DO
END IF
END SUBROUTINE FCN
C-------------------------------------------------------------------------------
C
C MPF
C
C If ROOT is not zero then returns value of time when M==ROOT in TOUT. Else,
C runs until TOUT and returns value in M. If PRINT_EVERY is non-zero then
C the solution is printed every PRINT_EVERY time units or every H (which ever
C is greater).
C
C This routine is not meant to be precise, it is only intended to be good
C enough for providing a working example of ODRPACK95 with bounds. 4th order
C Runge Kutta and linear interpolation are used for numerical integration and
C root finding, respectively.
C
C M - MPF
C C - Total Cyclin
C KWEE, K25, K25P - Model parameters (BETA(1:3))
C
SUBROUTINE MPF(M,C,KWEE,K25,K25P,PRINT_EVERY,TOUT,ROOT)
USE REAL_PRECISION
REAL (KIND=R8), INTENT(OUT) :: M
REAL (KIND=R8), INTENT(IN) :: C, KWEE, K25, K25P,
+ PRINT_EVERY, ROOT
REAL (KIND=R8), INTENT(INOUT) :: TOUT
! Local variables
REAL (KIND=R8), PARAMETER :: H = 1.0D-1
REAL (KIND=R8) :: LAST_PRINT, LAST_M, LAST_T, T
REAL (KIND=R8) :: K1, K2, K3, K4, DMDT
M = 0.0D0
T = 0.0D0
LAST_PRINT = 0
IF ( PRINT_EVERY .GT. 0.0D0 ) THEN
WRITE(*,*) T, M
END IF
DO WHILE ( T .LT. TOUT )
LAST_T = T
LAST_M = M
K1 = H*DMDT(M,C,KWEE,K25,K25P)
K2 = H*DMDT(M+K1/2,C,KWEE,K25,K25P)
K3 = H*DMDT(M+K2/2,C,KWEE,K25,K25P)
K4 = H*DMDT(M+K3,C,KWEE,K25,K25P)
M = M+(K1+2*K2+2*K3+K4)/6
T = T + H
IF ( T .GE. PRINT_EVERY+LAST_PRINT .AND.
+ PRINT_EVERY .GT. 0.0D0 )
+ THEN
WRITE(*,*) T, M
LAST_PRINT = LAST_PRINT + PRINT_EVERY
END IF
IF ( ROOT .GT. 0.0D0 ) THEN
IF ( LAST_M .LE. ROOT .AND. ROOT .LT. M ) THEN
TOUT = (T-LAST_T)/(M-LAST_M)*(ROOT-LAST_M)+LAST_T
RETURN
END IF
END IF
END DO
END SUBROUTINE MPF
C Equation from Zwolak et al. 2001.
FUNCTION DMDT(M,C,KWEE,K25,K25P) RESULT(RES)
USE REAL_PRECISION
REAL (KIND=R8) :: M, C, KWEE, K25, K25P, RES
RES = KWEE*M+(K25+K25P*M**2)*(C-M)
END FUNCTION DMDT
dataassim/math/optimization/odrpack95/simple_example.f90
+66
View File
@@ -0,0 +1,66 @@
PROGRAM ODRPACK95_EXAMPLE
USE ODRPACK95
USE REAL_PRECISION
REAL (KIND=R8), ALLOCATABLE :: BETA(:),L(:),U(:),X(:,:),Y(:,:)
INTEGER :: NP,N,M,NQ
INTERFACE
SUBROUTINE FCN(N,M,NP,NQ,LDN,LDM,LDNP,BETA,XPLUSD,IFIXB,IFIXX,LDIFX,&
IDEVAL,F,FJACB,FJACD,ISTOP)
USE REAL_PRECISION
INTEGER :: IDEVAL,ISTOP,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
REAL (KIND=R8) :: BETA(NP),F(LDN,NQ),FJACB(LDN,LDNP,NQ), &
FJACD(LDN,LDM,NQ),XPLUSD(LDN,M)
INTEGER :: IFIXB(NP),IFIXX(LDIFX,M)
END SUBROUTINE FCN
END INTERFACE
NP = 2
N = 4
M = 1
NQ = 1
ALLOCATE(BETA(NP),L(NP),U(NP),X(N,M),Y(N,NQ))
BETA(1:2) = (/ 2.0_R8, 0.5_R8 /)
L(1:2) = (/ 0.0_R8, 0.0_R8 /)
U(1:2) = (/ 10.0_R8, 0.9_R8 /)
X(1:4,1) = (/ 0.982_R8, 1.998_R8, 4.978_R8, 6.01_R8 /)
Y(1:4,1) = (/ 2.7_R8, 7.4_R8, 148.0_R8, 403.0_R8 /)
CALL ODR(FCN,N,M,NP,NQ,BETA,Y,X,LOWER=L,UPPER=U)
END PROGRAM ODRPACK95_EXAMPLE
SUBROUTINE FCN(N,M,NP,NQ,LDN,LDM,LDNP,BETA,XPLUSD,IFIXB,IFIXX,LDIFX,&
IDEVAL,F,FJACB,FJACD,ISTOP)
USE REAL_PRECISION
INTEGER :: IDEVAL,ISTOP,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ, I
REAL (KIND=R8) :: BETA(NP),F(LDN,NQ),FJACB(LDN,LDNP,NQ), &
FJACD(LDN,LDM,NQ),XPLUSD(LDN,M)
INTEGER :: IFIXB(NP),IFIXX(LDIFX,M)
ISTOP = 0
! Calculate model.
IF (MOD(IDEVAL,10).NE.0) THEN
DO I=1,N
F(I,1) = BETA(1)*EXP(BETA(2)*XPLUSD(I,1))
END DO
END IF
! Calculate model partials with respect to BETA.
IF (MOD(IDEVAL/10,10).NE.0) THEN
DO I=1,N
FJACB(I,1,1) = EXP(BETA(2)*XPLUSD(I,1))
FJACB(I,2,1) = BETA(1)*XPLUSD(I,1)*EXP(BETA(2)*XPLUSD(I,1))
END DO
END IF
! Calculate model partials with respect to DELTA.
IF (MOD(IDEVAL/100,10).NE.0) THEN
DO I=1,N
FJACD(I,1,1) = BETA(1)*BETA(2)*EXP(BETA(2)*XPLUSD(I,1))
END DO
END IF
END SUBROUTINE FCN
dataassim/math/optimization/odrpack95/test.f
+2742
View File
File diff suppressed because it is too large Load Diff
dataassim/math/optimization/odrpack95/tester.f
+241
View File
@@ -0,0 +1,241 @@
*TESTER
PROGRAM TESTER
C***BEGIN PROLOGUE TESTER
C***REFER TO ODR
C***ROUTINES CALLED ODR
C***DATE WRITTEN 20040322 (YYYYMMDD)
C***REVISION DATE 20040322 (YYYYMMDD)
C***PURPOSE EXCERCISE ERROR REPORTING OF THE F90 VERSION OF ODRPACK95
C***END PROLOGUE TESTER
C...USED MODULES
USE REAL_PRECISION
USE ODRPACK95
C...LOCAL SCALARS
INTEGER N, M, NQ, NP, INFO, LUN
C STAT
C...LOCAL ARRAYS
REAL (KIND=R8)
& BETA(:),Y(:,:),X(:,:),UPPER(2),LOWER(2)
C...ALLOCATABLE ARRAYS
ALLOCATABLE BETA,Y,X
C...EXTERNAL SUBPROGRAMS
EXTERNAL FCN
COMMON /BOUNDS/ UPPER,LOWER
C***FIRST EXECUTABLE STATEMENT TESTER
OPEN(UNIT=8,FILE="SUMMARY")
WRITE(8,*) "NO SUMMARY AVAILABLE"
CLOSE(8)
LUN = 9
OPEN(UNIT=LUN,FILE="REPORT")
C ERROR IN PROBLEM SIZE
N = 0
M = 0
NQ = 0
NP = 0
ALLOCATE(BETA(NP),Y(N,NQ),X(N,M))
Y(:,:) = 0.0_R8
X(:,:) = 0.0_R8
BETA(:) = 0.0_R8
CALL ODR(FCN,N,M,NP,NQ,BETA,Y,X,IPRINT=1,INFO=INFO,
& LUNRPT=LUN,LUNERR=LUN)
WRITE(LUN,*) "INFO = ", INFO
C ERROR IN JOB SPECIFICATION WITH WORK AND IWORK
N = 1
M = 1
NQ = 1
NP = 1
DEALLOCATE(BETA,Y,X)
ALLOCATE(BETA(NP),Y(N,NQ),X(N,M))
Y(:,:) = 0.0_R8
X(:,:) = 0.0_R8
BETA(:) = 0.0_R8
CALL ODR(FCN,N,M,NP,NQ,BETA,Y,X,IPRINT=1,INFO=INFO,JOB=10000,
& LUNRPT=LUN,LUNERR=LUN)
WRITE(LUN,*) "INFO = ", INFO
C ERROR IN JOB SPECIFICATION WITH DELTA
N = 1
M = 1
NQ = 1
NP = 1
DEALLOCATE(BETA,Y,X)
ALLOCATE(BETA(NP),Y(N,NQ),X(N,M))
Y(:,:) = 0.0_R8
X(:,:) = 0.0_R8
BETA(:) = 0.0_R8
CALL ODR(FCN,N,M,NP,NQ,BETA,Y,X,IPRINT=1,INFO=INFO,JOB=1000,
& LUNRPT=LUN,LUNERR=LUN)
WRITE(LUN,*) "INFO = ", INFO
C BOUNDS TOO SMALL FOR DERIVATIVE CHECKER WHEN DERIVATIVES DON'T AGREE.
N = 4
M = 1
NQ = 1
NP = 2
DEALLOCATE(BETA,Y,X)
ALLOCATE(BETA(NP),Y(N,NQ),X(N,M))
BETA(:) = (/ -200.0_R8, -5.0_R8 /)
UPPER(1:2) = (/ -200.0_R8, 0.0_R8 /)
LOWER(1:2) = (/ -200.000029802322_R8, -5.0_R8 /)
Y(:,1) = (/ 2.718281828459045_R8, 7.389056098930650_R8,
&148.4131591025766_R8, 403.4287934927353_R8 /)
X(:,1) = (/ 1.0_R8, 2.0_R8, 5.0_R8, 6.0_R8 /)
CALL ODR(FCN,N,M,NP,NQ,BETA,Y,X,IPRINT=1,INFO=INFO,JOB=0020,
& LUNRPT=LUN,LUNERR=LUN,LOWER=LOWER,UPPER=UPPER)
WRITE(LUN,*) "INFO = ", INFO
C ERROR IN ARRAY ALLOCATION
C The following code is intended to force memory allocation failure. An
C appropriate N for your machine must be chosen to ensure memory allocation
C will fail within ODRPACK95. A value of about 1/4 the total memory available
C to a process should do the trick. However, most modern operating systems and
C Fortran compilers will not likely deny ODRPACK95 memory before they fail for
C another reason. Therefore, the memory allocation checks in ODRPACK95 are not
C easy to provoke. An operating system may return successfull memory
C allocation but fail to guarantee the memory causing a segfault when some
C memory locations are accessed. A Fortran compiler or operating system may
C allow limited sized stacks during subroutine invocation causing the ODRPACK95
C call to fail before ODRPACK95 executes its first line.
C
C N = 032000000
C M = 1
C NQ = 1
C NP = 1
C DEALLOCATE(BETA,Y,X)
C ALLOCATE(BETA(NP),Y(N,NQ),X(N,M),STAT=STAT)
C IF (STAT.NE.0) THEN
C WRITE(0,*)
C & "SYSTEM ERROR: COULD NOT ALLOCATE MEMORY, TESTER ",
C & "FAILED TO RUN."
C STOP
C END IF
C Y(:,:) = 0.0_R8
C X(:,:) = 0.0_R8
C BETA(:) = 0.0_R8
C
C CALL ODR(FCN,N,M,NP,NQ,BETA,Y,X,IPRINT=1,INFO=INFO,
C & LUNRPT=LUN,LUNERR=LUN)
C
C WRITE(LUN,*) "INFO = ", INFO
CLOSE(LUN)
END PROGRAM
*FCN
SUBROUTINE FCN
& (N,M,NP,NQ,
& LDN,LDM,LDNP,
& BETA,XPLUSD,
& IFIXB,IFIXX,LDIFX,
& IDEVAL,F,FJACB,FJACD,
& ISTOP)
C***BEGIN PROLOGUE FCN
C***REFER TO ODR
C***ROUTINES CALLED (NONE)
C***DATE WRITTEN 20040322 (YYYYMMDD)
C***REVISION DATE 20040322 (YYYYMMDD)
C***PURPOSE DUMMY ROUTINE FOR ODRPACK95 ERROR EXERCISER
C***END PROLOGUE FCN
C...USED MODULES
USE REAL_PRECISION
C...SCALAR ARGUMENTS
INTEGER
& IDEVAL,ISTOP,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
C...ARRAY ARGUMENTS
REAL (KIND=R8)
& BETA(NP),F(LDN,NQ),FJACB(LDN,LDNP,NQ),FJACD(LDN,LDM,NQ),
& XPLUSD(LDN,M)
INTEGER
& IFIXB(NP),IFIXX(LDIFX,M)
C...ARRAYS IN COMMON
REAL (KIND=R8)
& LOWER(2),UPPER(2)
C...LOCAL SCALARS
INTEGER
& I
COMMON /BOUNDS/ UPPER,LOWER
C***FIRST EXECUTABLE STATEMENT
C Do something with FJACD, FJACB, IFIXB and IFIXX to avoid warnings that they
C are not being used. This is simply not to worry users that the example
C program is failing.
IF (IFIXB(1) .GT. 0 .AND. IFIXX(1,1) .GT. 0
& .AND. FJACB(1,1,1) .GT. 0 .AND. FJACD(1,1,1) .GT. 0 ) THEN
C Do nothing.
END IF
IF (ANY(LOWER(1:NP).GT.BETA(1:NP))) THEN
WRITE(0,*) "LOWER BOUNDS VIOLATED"
DO I=1,NP
IF (LOWER(I).GT.BETA(I)) THEN
WRITE(0,*) " IN THE ", I, " POSITION WITH ", BETA(I),
& "<", LOWER(I)
END IF
END DO
END IF
IF (ANY(UPPER(1:NP).LT.BETA(1:NP))) THEN
WRITE(0,*) "UPPER BOUNDS VIOLATED"
DO I=1,NP
IF (UPPER(I).LT.BETA(I)) THEN
WRITE(0,*) " IN THE ", I, " POSITION WITH ", BETA(I),
& ">", UPPER(I)
END IF
END DO
END IF
ISTOP = 0
IF (MOD(IDEVAL,10).NE.0) THEN
DO I=1,N
F(I,1) = BETA(1)*EXP(BETA(2)*XPLUSD(I,1))
END DO
END IF
IF (MOD(IDEVAL/10,10).NE.0) THEN
DO I=1,N
FJACB(I,1,1) = EXP(BETA(2)*XPLUSD(I,1))
FJACB(I,2,1) = BETA(1)*XPLUSD(I,1)*EXP(BETA(2)*
& XPLUSD(I,1))
END DO
END IF
IF (MOD(IDEVAL/100,10).NE.0) THEN
DO I=1,N
FJACD(I,1,1) = BETA(1)*BETA(2)*EXP(BETA(2)*XPLUSD(I,1))
END DO
END IF
END SUBROUTINE
dataassim/math/optimization/odrpack_old.f
+13610
View File
File diff suppressed because it is too large Load Diff
dataassim/math/optimization/powell.f
+2 -2
View File
@@ -4,7 +4,7 @@
implicit none
INTEGER iter,n,np,NMAX,ITMAX
double precision fret,ftol,p(np),xi(np,np),TINY,
& pmin(np),pmax(np)
& pmin(np),pmax(np),f1dim
PARAMETER (NMAX=1000,TINY=1.0d-25)
CU USES funkmin,linmin
INTEGER i,ibig,j
@@ -58,7 +58,7 @@ 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)
double precision fret,p(n),xi(n),TOL,pmin(n),pmax(n),f1dim
PARAMETER (TOL=1.0d-8)
CU USES brent,f1dim,mnbrak
INTEGER j,k,ierr
dataassim/math/optimization/qpso.f90
+291
View File
@@ -0,0 +1,291 @@
program qpso
implicit none
include "mpif.h"
integer maxiter, maxpop, maxparms
parameter (maxiter = 10000)
parameter (maxpop = 2048)
parameter (maxparms = 512)
integer i, j,k, npop, nparms, niter, gInx, nfunc(maxpop)
integer nfuncall(maxpop)
integer ntries, np, myid, ierr, start_iter
integer pft(maxparms)
double precision gbest(maxparms)
double precision mbest(maxparms)
double precision feval, beta_l, beta_u, beta
double precision betapro(maxparms), pupdate(maxparms)
double precision pbest(maxpop, maxparms)
double precision pbestall(maxpop, maxparms)
double precision f_x(maxpop), x(maxpop, maxparms)
double precision xall(maxpop, maxparms)
double precision f_pbest(maxpop), f_pbestall(maxpop), f_gbest
double precision gpar(maxiter,maxparms)
double precision gobj(maxiter)
double precision pmin(maxparms), pmax(maxparms)
double precision fi(maxparms), u(maxparms), v(maxparms)
logical isvalid, restart
character(len=4) popst
character(len=100) mymachine, dummy, parm_name(maxparms), case_name, thisfmt
character(len=100) parm_list, constraints, qpso_in(4)
!------- user-tunable QPSO algorithm parameters ----------------
open(unit = 8, file='qpso_input.txt')
do i = 1,100
read(8,*, end=5), qpso_in
if (trim(qpso_in(1)) == 'npop') read(qpso_in(3),*) npop
if (trim(qpso_in(1)) == 'niter') read(qpso_in(3),*) niter
if (trim(qpso_in(1)) == 'beta_l') read(qpso_in(3),*) beta_l
if (trim(qpso_in(1)) == 'beta_u') read(qpso_in(3),*) beta_u
if (trim(qpso_in(1)) == 'restart') read(qpso_in(3),*) restart
if (trim(qpso_in(1)) == 'machine') mymachine=trim(qpso_in(3))
if (trim(qpso_in(1)) == 'case') case_name=trim(qpso_in(3))
if (trim(qpso_in(1)) == 'parm_list') parm_list=trim(qpso_in(3))
if (trim(qpso_in(1)) == 'constraints') constraints=trim(qpso_in(3))
end do
5 continue
close(8)
print*, '# of particles: ', npop
print*, '# of iterations: ', niter
print*, 'beta_l: ', beta_l
print*, 'beta_u: ', beta_u
print*, 'Is a restart run:', restart
print*, 'Machine: ', mymachine
print*, 'Case: ', case_name
print*, 'Parameter file: ', parm_list
print*, 'Constraints dir: ', constraints
!---------------------------------------------------------------
call mpi_init(ierr)
call mpi_comm_size(mpi_comm_world, np, ierr)
call mpi_comm_rank(mpi_comm_world, myid, ierr)
!get parameter information from the parm_list file
if (myid .eq. 0) then
open(unit = 8, status='old', file = trim(parm_list))
nparms=0
do i=1,maxparms
read(8,*, end=10) parm_name(i), pft(i), pmin(i), pmax(i)
nparms = nparms+1
end do
end if
10 continue
if (myid .eq. 0) then
close(8)
print*, nparms, ' Parameters optimized'
end if
!broadcast parameter info to other procs
call mpi_bcast(nparms, 1, mpi_integer, 0, mpi_comm_world, ierr)
call mpi_bcast(pmin, maxparms, mpi_double, 0, mpi_comm_world, ierr)
call mpi_bcast(pmax, maxparms, mpi_double, 0, mpi_comm_world, ierr)
nfunc(:) = 0 !keep track of total function evaluations
x(:,:) = 0d0
f_x(:) = 0d0
f_pbest(:) = 0d0
if (restart .eqv. .false.) then
do i=myid+1,npop,np
!randomize starting locations
call init_random_seed
call random_number(u)
x(i,:) = pmin + (pmax-pmin) * u
f_x(i) = feval(x(i,:), nparms, i, mymachine, parm_list, constraints, &
case_name)
nfunc(i) = nfunc(i)+1
f_pbest(i) = f_x(i)
end do
call mpi_allreduce(x, xall, maxparms*maxpop, mpi_double, mpi_sum, &
mpi_comm_world, ierr)
call mpi_allreduce(f_pbest, f_pbestall, maxpop, mpi_double, mpi_sum, &
mpi_comm_world, ierr)
pbestall = xall
!initialize pbest and gbest
if (myid .eq. 0) then
gInx = 1
do i=2,npop
if (f_pbestall(i) .lt. f_pbestall(gInx)) gInx = i
end do
gbest = pbestall(gInx,:)
f_gbest = f_pbestall(gInx)
end if
call mpi_bcast(gbest, maxparms, mpi_double, 0, mpi_comm_world, ierr)
call mpi_bcast(f_gbest, 1, mpi_double, 0, mpi_comm_world, ierr)
start_iter = 1
else
!load restart information
if (myid .eq. 0) then
open(unit=8, file='./qpso_restart_' // trim(case_name) // '.txt')
read(8,*) start_iter
do j=1,npop
read(8,*) xall(j,1:nparms)
read(8,*) pbestall(j,1:nparms)
read(8,*) f_pbestall(j)
end do
read(8,*) gbest(1:nparms)
read(8,*) f_gbest
end if
xall=pbestall
call mpi_bcast(xall, maxparms*maxpop, mpi_double, 0, mpi_comm_world, ierr)
call mpi_bcast(pbestall, maxparms*maxpop, mpi_double, 0, mpi_comm_world, ierr)
call mpi_bcast(f_pbestall, maxpop, mpi_double, 0, mpi_comm_world, ierr)
call mpi_bcast(gbest, maxparms, mpi_double, 0, mpi_comm_world, ierr)
call mpi_bcast(f_gbest, 1, mpi_double, 0, mpi_comm_world, ierr)
end if
!QPSO algorithm
do i=start_iter,niter
if (myid .eq. 0) print*, 'Iteration', i
beta = beta_u - (beta_u-beta_l)*i/niter
!compute mean of best parameters (all procs)
do k=1, nparms
mbest(k) = sum(pbestall(1:npop,k))/npop
end do
!print*, mbest(1:nparms)
!MPI over population
x(:,:) = 0d0
pbest(:,:) = 0d0
f_pbest(:) = 0d0
do j = myid+1,npop,np
isvalid = .false.
ntries = 0
do while (isvalid .eqv. .false.)
call random_number(fi)
call random_number(u)
call random_number(v)
isvalid=.true.
do k=1,nparms
pupdate = fi(k)*pbestall(j,k) + (1-fi(k))*gbest(k)
betapro = beta * abs(mbest(k)-xall(j,k))
x(j,k) = pupdate(k)+((-1d0)**ceiling(0.5+v(k)))*betapro(k)*(-log(u(k)))
if (ntries .le. 1e5) then
if (x(j,k) .lt. pmin(k) .or. x(j,k) .gt. pmax(k)) isvalid=.false.
else
if (x(j,k) .lt. pmin(k)) x(j,k) = pmin(k)
if (x(j,k) .gt. pmax(k)) x(j,k) = pmax(k)
end if
end do
ntries = ntries+1
end do
!run the model to get the cost function
f_x(j) = feval(x(j,:),nparms, j, mymachine, parm_list, constraints, case_name)
nfunc(j) = nfunc(j)+1
if (f_x(j) .lt. f_pbestall(j)) then
pbest(j,:) = x(j,:)
f_pbest(j) = f_x(j)
else
pbest(j,:) = pbestall(j,:)
f_pbest(j) = f_pbestall(j)
end if
end do
call mpi_allreduce(pbest, pbestall, maxparms*maxpop, mpi_double, mpi_sum, &
mpi_comm_world, ierr)
call mpi_allreduce(x, xall, maxpop, mpi_double, mpi_sum, &
mpi_comm_world, ierr)
call mpi_allreduce(f_pbest, f_pbestall, maxpop, mpi_double, mpi_sum, &
mpi_comm_world, ierr)
!update overall best (all procs)
do j=1,npop
if (f_pbestall(j) .lt. f_gbest) then
gbest = pbestall(j,:)
f_gbest = f_pbestall(j)
end if
end do
!save info from this iteration
gpar(i,:) = gbest
gobj(i) = f_gbest
call mpi_allreduce(nfunc,nfuncall, maxpop, mpi_integer, mpi_sum, &
mpi_comm_world, ierr)
if (myid .eq. 0) then
open(unit=8, file='qpso_best_' // trim(case_name) // '.txt')
write(8,*), 'Iteration', i
write(8,*), 'Objective function:', gobj(i)
do k=1,nparms
write(8,'(A,1x,I2,1x,g13.6)') trim(parm_name(k)), pft(k), gpar(i,k)
end do
close(8)
if (i .eq. 1) then
open(unit=10, file='qpso_costfunc_' // trim(case_name) // '.txt')
else
open(unit=10, file='qpso_costfunc_' // trim(case_name) // '.txt', &
status='old', position='append', action='write')
end if
write(10,*) i, sum(nfuncall) , gobj(i)
close(10)
!write the restart file
write(popst, '(I4)') nparms
thisfmt = '(' // trim(popst) // '(g13.6,1x))'
open(unit=11, file = 'qpso_restart_' // trim(case_name) // '.txt')
write(11,'(I4)') i !current iteration number
do j=1,npop
write(11,fmt=trim(thisfmt)) xall(j,1:nparms) !current parameters for each population
write(11,fmt=trim(thisfmt)) pbestall(j,1:nparms) !best parameters for each population
write(11,'(g13.6)') f_pbestall(j) !best objective function for each population
end do
write(11,fmt=trim(thisfmt)) gbest(1:nparms) !overall best parameters
write(11,'(g13.6)') f_gbest !overall best objectivefunction
close(11)
end if
end do
call mpi_finalize(ierr)
end program qpso
!Function to evaluate the CLM/ALM model
double precision function feval(parms, nparms, thispop, mymachine, parm_list, &
constraints, case_name)
integer nparms, i, thispop
double precision parms(500), trueparms(4)
double precision mydata(1000), model(1000), sse(1000)
double precision temp(1000), par(1000)
character(len=6) thispopst
character(len=100) mymachine, parm_list, constraints, case_name, thisline
write(thispopst, '(I6)') 100000+thispop
!write the parameters to file
open(unit=9, file='./parm_data_files/parm_data_' // thispopst(2:6))
do i=1,nparms
write(9,*) parms(i)
end do
close(9)
!Call python workflow to set up and launch model simulation
call system('sleep ' // thispopst(2:6)) !do not start all at once
call system('python UQ_runens.py --ens_num ' // thispopst(2:6) // &
' --parm_list ' // trim(parm_list) // ' --parm_data ./parm_data_files/' // &
'parm_data_' // thispopst(2:6) // ' --constraints ' // trim(constraints) // &
' --machine ' // trim(mymachine) // ' --case ' // trim(case_name))
!get the sum of squared errors
open(unit=9, file='./ssedata/mysse_' // thispopst(2:6) // '.txt')
read(9,*) feval
close(9)
call system('sleep 20')
return
end function feval