180 lines
6.4 KiB
FortranFixed
180 lines
6.4 KiB
FortranFixed
subroutine NeuralNetRegres(idowhat,nx0,nobs0,nh0,xsamp0,
|
|
&ysamp0,yatxsamp0,rsq,w,bph,q,bend,xnew,ypred)
|
|
implicit none
|
|
include 'NeuralNetRegres.h'
|
|
!
|
|
!=============Inputs regardless of idowhat=========================
|
|
!idowhat: =1, fit the data and estimate the coefficients. Provide the
|
|
! initial guess for the coefficients or set bend to -9999
|
|
! =2, coefficients are already available, calculate y at xnew
|
|
!nx0: the number of independent (x) variables
|
|
!nobs0: the total number of samples
|
|
!nh0: the total number of hidden nodes to use. One hidden layer is
|
|
! assumed.
|
|
!============When idowhat=1========================================
|
|
! --------Inputs--------
|
|
!xsamp0: the values of the independent (x) variables
|
|
!ysamp0: the values of the dependent (y) variable. y is one dimension.
|
|
! --------Outputs-------
|
|
!w: the slope coefficient to time the normalized x in the activation function
|
|
!bph: the intercept coefficient in the activation function
|
|
!q: the coefficient to time the value of the activation function
|
|
!bend: the residual constant in the neural network regression
|
|
!yatxsamp0: the predicted y value at xsamp0
|
|
!rsq: R squared
|
|
!============When idowhat=2=========================================
|
|
! --------Inputs--------
|
|
!w: the slope coefficient to time the normalized x in the activation function
|
|
!bph: the intercept coefficient in the activation function
|
|
!q: the coefficient to time the value of the activation function
|
|
!bend: the residual constant in the neural network regression
|
|
!xnew: the new x point who y value is to be estimated (when idowhat=2)
|
|
! --------Outputs-------
|
|
!ypred: the predicted y value at xnew
|
|
!
|
|
integer idowhat,nx0,nobs0,nh0
|
|
double precision xsamp0(nobs0,nx0),ysamp0(nobs0),
|
|
& yatxsamp0(nobs0),rsq,w(nx0,nh0),bph(nh0),q(nh0),
|
|
& bend,xnew(nx0),ypred
|
|
!============Locals=========================================
|
|
integer i,j,ndim,ny,INFO,iderivative,iregrestype
|
|
!iregrestype=0, ordinary distance regression
|
|
double precision xnormk(nx0),xnormb(nx0),std,fmean,
|
|
& xmin,xmax,fatbeta,fatbeta0,fatbetacp,ftol,
|
|
& beta(nx0*nh0+2*nh0+1),betacp(nx0*nh0+2*nh0+1),rms,
|
|
& agrind,ran2,annfunc,weitx(1:nobs0,1:nx0),
|
|
& weity(1:nobs0),shortx(1:nobs0,1:nx0),
|
|
& shorty(1:nobs0),yv(nobs0),fn9999,tiny
|
|
parameter(ftol=1.0d-8,iderivative=1,iregrestype=0,
|
|
&fn9999=-9999.0d0,tiny=1.0d-8)
|
|
external funkmin_neural,f1dim_neural,FCN_neural
|
|
!
|
|
if(idowhat.eq.1)then
|
|
!Regression
|
|
nx=nx0
|
|
nobs=nobs0
|
|
nh=nh0
|
|
!xnormk: the slope of the linear transformation for xsamp0
|
|
!xnormb: the intercept of the linear transformation for xsamp0
|
|
!Transform xsamp to become bounded (-1,1) so that different independent variables
|
|
!are comparable in magnitude
|
|
!xmin ~ -1
|
|
!xmax ~ +1
|
|
do i=1,nobs
|
|
ysamp(i)=ysamp0(i)
|
|
weity(i)=1.0d0
|
|
do j=1,nx
|
|
weitx(i,j)=1.0d0
|
|
enddo
|
|
enddo
|
|
do i=1,nx
|
|
call stdmaxmeanmin(nobs,xsamp0(1:nobs,i:i),
|
|
& std,fmean,xmin,xmax)
|
|
if(xmax.eq.xmin)then
|
|
xnormk(i)=1.0d0
|
|
xnormb(i)=0.0d0
|
|
else
|
|
xnormk(i)=2.0d0/(xmax-xmin)
|
|
xnormb(i)=-(xmax+xmin)/(xmax-xmin)
|
|
endif
|
|
do j=1,nobs
|
|
xsamp(j,i)=xnormk(i)*xsamp0(j,i)+xnormb(i)
|
|
enddo
|
|
enddo
|
|
ndim=2*nh+nh*nx+1
|
|
do i=1,ndim
|
|
betamin(i)=-1.0d+20
|
|
betamax(i)=1.0d+20
|
|
enddo
|
|
if(dabs(bend-fn9999).lt.tiny)then
|
|
!no initial guess. Use the general guess
|
|
do i=1,ndim
|
|
beta(i)=(ran2()-0.5d0)*2.0d0
|
|
enddo
|
|
else
|
|
!initial guess provided. transform the guessed bph and w coefficients to correspond
|
|
!to the transformed x.
|
|
do i=1,nh0
|
|
do j=1,nx0
|
|
w(j,i)=w(j,i)/xnormk(j)
|
|
enddo
|
|
enddo
|
|
do i=1,nh0
|
|
do j=1,nx0
|
|
bph(i)=bph(i)-w(j,i)*xnormb(j)
|
|
enddo
|
|
enddo
|
|
call coeff_beta(2,nx,nh,beta,w(1:nx,1:nh),bph,q,bend)
|
|
endif
|
|
do i=1,ndim
|
|
betacp(i)=beta(i)
|
|
if(beta(i).lt.betamin(i).or.beta(i).gt.betamax(i))then
|
|
! write(*,*)'Inproper initial guess in NeuralNetRegres.f'
|
|
beta(i)=ran2()
|
|
endif
|
|
betacp(i)=beta(i)
|
|
enddo
|
|
call funkmin_neural(ndim,beta,fatbeta0)
|
|
INFO=iregrestype
|
|
ny=1
|
|
fatbeta=fatbeta0
|
|
90 call odr_leastsquare(ndim,FCN_neural,beta,nobs,
|
|
&xsamp(1:nobs,1:nx),nx,ysamp(1:nobs),ny,weitx(1:nobs,1:nx),
|
|
&weity(1:nobs),iderivative,shortx(1:nobs,1:nx),shorty(1:nobs),
|
|
&fatbeta,INFO)
|
|
call funkmin_neural(ndim,beta,fatbeta)
|
|
! if((fatbeta0-fatbeta).gt.ftol)then
|
|
! fatbeta0=fatbeta
|
|
! do i=1,ndim
|
|
! betacp(i)=beta(i)
|
|
! enddo
|
|
! goto 90
|
|
! endif
|
|
if(fatbeta.gt.fatbeta0)then
|
|
j=0
|
|
do i=1,ndim
|
|
beta(i)=betacp(i)
|
|
if(beta(i).lt.betamin(i).or.beta(i).gt.betamax(i))j=1
|
|
enddo
|
|
fatbeta=fatbeta0
|
|
if(j.ne.0)then
|
|
do i=1,ndim
|
|
beta(i)=(ran2()-0.5d0)*2.0d0
|
|
enddo
|
|
call funkmin_neural(ndim,beta,fatbeta)
|
|
endif
|
|
endif
|
|
100 fatbetacp=fatbeta
|
|
call nongradopt(ndim,funkmin_neural,f1dim_neural,
|
|
&beta,betamin,betamax,ftol,fatbeta)
|
|
! call RepeatCompassSearch(ndim,beta,fatbeta,
|
|
! &betamin,betamax,funkmin_neural,f1dim_neural,ftol)
|
|
! if(dabs(fatbetacp-fatbeta).gt.ftol)goto 100
|
|
call funkmin_neural(ndim,beta,fatbeta)
|
|
call coeff_beta(idowhat,nx,nh,beta,w(1:nx,1:nh),bph,q,bend)
|
|
!transform the estimated bph and w coefficients so that the original x
|
|
!values can be used directly.
|
|
do i=1,nh0
|
|
do j=1,nx0
|
|
bph(i)=bph(i)+w(j,i)*xnormb(j)
|
|
enddo
|
|
enddo
|
|
do i=1,nh0
|
|
do j=1,nx0
|
|
w(j,i)=w(j,i)*xnormk(j)
|
|
enddo
|
|
enddo
|
|
do i=1,nobs0
|
|
yatxsamp0(i)=annfunc(nx0,xsamp0(i:i,1:nx0),nh0,q,
|
|
& w(1:nx0,1:nh0),bph,bend)
|
|
enddo
|
|
call rsq_rms(ysamp0,yatxsamp0,nobs0,rsq,rms,agrind)
|
|
endif
|
|
if(idowhat.eq.2)then
|
|
!Predict y at x with the regression coefficients already estimated
|
|
ypred=annfunc(nx0,xnew,nh0,q,w(1:nx0,1:nh0),bph,bend)
|
|
endif
|
|
return
|
|
end
|
|
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
|