subroutine funkmin_neural(ndim,beta,fvalue) implicit none include 'NeuralNetRegres.h' integer ndim double precision beta(ndim),fvalue !(in) ndim: the dimension of the parameter vector !(in) beta: the parameters !(out) fvalue: the value of the cost function at beta !----------------------------------------------------- integer i,j,k,idowhat double precision w(maxnx,maxnh),bph(maxnh),q(maxnh), &bend,annfunc,ypred ! ! check to see if parameters are out of bounds if(betamin(1).lt.betamax(1))then do i=1,ndim if(beta(i).lt.betamin(i).or. & beta(i).gt.betamax(i))then ! parameter out of bound fvalue=1.0d+100 return endif enddo endif idowhat=1 call coeff_beta(idowhat,nx,nh,beta,w(1:nx,1:nh),bph,q,bend) fvalue=0.0d0 do i=1,nobs ypred=annfunc(nx,xsamp(i:i,1:nx),nh,q,w(1:nx,1:nh),bph,bend) fvalue=fvalue+(ysamp(i)-ypred)*(ysamp(i)-ypred) enddo return end subroutine funkmin_neural !$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ double precision function f1dim_neural(x) implicit none double precision x CU USES funkmin_neural INTEGER j !(((((((((((((((((((((((((((((((((((((((((((((((((((( integer NMAX,ncom parameter(NMAX=1000) double precision pcom(NMAX),xicom(NMAX) COMMON /f1com/ pcom,xicom,ncom save /f1com/ !)))))))))))))))))))))))))))))))))))))))))))))))))))) double precision xt(NMAX) !----------------------------------------------------- do 11 j=1,ncom xt(j)=pcom(j)+x*xicom(j) 11 continue call funkmin_neural(ncom,xt,f1dim_neural) return END !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& SUBROUTINE FCN_neural(N,M,NP,NQ, + LDN,LDM,LDNP, + BETA,XPLUSD, + IFIXB,IFIXX,LDIFX, + IDEVAL,F,FJACB,FJACD, + ISTOP) implicit none C SUBROUTINE ARGUMENTS C ==> N NUMBER OF OBSERVATIONS C ==> M NUMBER OF COLUMNS IN EXPLANATORY VARIABLE C ==> NP NUMBER OF PARAMETERS C ==> NQ NUMBER OF RESPONSES PER OBSERVATION C ==> LDN LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING N C ==> LDM LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING M C ==> LDNP LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING NP C ==> BETA CURRENT VALUES OF PARAMETERS C ==> XPLUSD CURRENT VALUE OF EXPLANATORY VARIABLE, I.E., X + DELTA C ==> IFIXB INDICATORS FOR "FIXING" PARAMETERS (BETA) C ==> IFIXX INDICATORS FOR "FIXING" EXPLANATORY VARIABLE (X) C ==> LDIFX LEADING DIMENSION OF ARRAY IFIXX C ==> IDEVAL INDICATOR FOR SELECTING COMPUTATION TO BE PERFORMED C <== F PREDICTED FUNCTION VALUES C <== FJACB JACOBIAN WITH RESPECT TO BETA C <== FJACD JACOBIAN WITH RESPECT TO ERRORS DELTA C <== ISTOP STOPPING CONDITION, WHERE C 0 MEANS CURRENT BETA AND X+DELTA WERE C ACCEPTABLE AND VALUES WERE COMPUTED SUCCESSFULLY C 1 MEANS CURRENT BETA AND X+DELTA ARE C NOT ACCEPTABLE; ODRPACK SHOULD SELECT VALUES C CLOSER TO MOST RECENTLY USED VALUES IF POSSIBLE C -1 MEANS CURRENT BETA AND X+DELTA ARE C NOT ACCEPTABLE; ODRPACK SHOULD STOP C INPUT ARGUMENTS, NOT TO BE CHANGED BY THIS ROUTINE: INTEGER II,IDEVAL,ISTOP,L,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ DOUBLE PRECISION BETA(NP),XPLUSD(LDN,M) INTEGER IFIXB(NP),IFIXX(LDIFX,M) C OUTPUT ARGUMENTS: DOUBLE PRECISION F(LDN,NQ),FJACB(LDN,LDNP,NQ),FJACD(LDN,LDM,NQ) ! integer k,i,j,s,t,ierr,idowhat include 'NeuralNetRegres.h' double precision w(maxnx,maxnh),bph(maxnh), & q(maxnh),bend,xnew(maxnx),annfunc, & derBETA(NP),derw(maxnx,maxnh),derbph(maxnh), & derq(maxnh),derbend C CHECK FOR UNACCEPTABLE VALUES FOR THIS PROBLEM c do I=1,NP if(BETA(I).lt.betamin(I).or.BETA(I).gt.betamax(I))then ISTOP = 1 RETURN endif enddo idowhat=1 call coeff_beta(idowhat,nx,nh,BETA, & w(1:nx,1:nh),bph,q,bend) !---------------- find the ann function values-------------------------- IF (MOD(IDEVAL,10).GE.1) THEN DO 110 L = 1,NQ DO 100 I = 1,N do k=1,M xnew(k)=XPLUSD(I,k) enddo F(I,L)=annfunc(nx,xnew,nh,q,w(1:nx,1:nh),bph,bend) 100 CONTINUE 110 CONTINUE END IF !---------------------------------------------------------------------- C COMPUTE DERIVATIVES WITH RESPECT TO BETA IF (MOD(IDEVAL/10,10).GE.1) THEN idowhat=2 DO 200 I = 1,N do k=1,M xnew(k)=XPLUSD(I,k) enddo call derannfunc(nx,xnew,nh,q,w(1:nx,1:nh), & bph,bend,derq,derw(1:nx,1:nh),derbph,derbend) call coeff_beta(idowhat,nx,nh,derBETA, & derw(1:nx,1:nh),derbph,derq,derbend) DO 210 L = 1,NQ do k=1,NP FJACB(I,k,L)=derBETA(k) enddo 210 CONTINUE 200 CONTINUE END IF RETURN END ! !$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$