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/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)