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