神经网络的算法程序

!t-学习速率     r-动量项 nx-循环次数  p-样本数

!ec-最小误差 pd-学习为0，验证为1

integer rs,cs,ys,p,q,l1,l2,l3,l4,l5,l6,l7,l8,l9,l10,pdx

real*8 a(100000)

LOGICAL look

open(6,file='lwl.txt',status='old')

INQUIRE(FILE='out.txt',EXIST=look)

IF(look)THEN

OPEN(8,FILE='out.txt',STATUS='OLD')

CLOSE(8,STATUS='DELETE')

end if

OPEN(8,FILE='out.txt',STATUS='NEW')

read(6,*)rs,cs,ys,p,t,r,nx,ec

q=0

l1=2*rs*ys+1+ys

l2=l1+2*cs*ys+cs

l3=l2+rs*p

l4=l3+cs*p

l5=l4+rs*p+p

l6=l5+cs*p

l7=l6+ys*p+p

l8=l7+cs*p

l9=l8+p

l10=l9+p*cs

l11=l10+p*ys

l12=l11+cs*p

l13=l12+cs

l14=l13+cs

l15=l14+cs

l16=l15+cs

write(8,*)l1,l2,l3,l4,l5,l6,l7,l8,l9,l10

call input1(rs,cs,ys,a(1),a(l1))

call input2(rs,cs,p,a(l2),a(l3))

call input22(rs,cs,p,a(l2),a(l3),a(l4),a(l5),a(l12),a(l13),a(l14),a(l15))

do 5 i=1,nx

q=q+1

write(8,'(a)')'q='

write(8,*)q

do 10 j=1,p

call sup1(rs,cs,ys,j,p,a(1),a(l1),a(l4),a(l6),a(l7))

call sup2(cs,ys,j,p,a(l5),a(l7),a(l6),a(l1),a(l8),a(l9),a(l10))

10 continue    

call sup3(rs,cs,ys,p,t,r,a(l4),a(l6),a(l1),a(1),a(l9),a(l10))

do 30 j=1,p

call sup1(rs,cs,ys,j,p,a(1),a(l1),a(l4),a(l6),a(l7))

30 continue

call fgyh(cs,p,a(l7),a(l12),a(l13),a(l14),a(l15),a(l11))

call pde(cs,p,ec,a(l3),a(l11),pdx)

if(pdx.eq.1)then

write(8,'(a)')'the calculate is end'

write(8,*)q

end if

5 continue

write(8,'(A)')'n=10000 end'

end

!权值初始化 

subroutine input1(rs,cs,ys,v,w)

integer rs,cs,ys

real*8 v(rs+1,ys,2),w(ys+1,cs,2) 

do 5 j=1,ys

do 15 i=0,rs

v(i,j,1)=0.1

15 continue

5 continue

do 25 n=1,cs

do 35 m=0,ys

w(m,n,1)=0.1

35 continue

25 continue

return

end

!输入训练样本

subroutine input2(rs,cs,p,x,d)

  integer rs,cs,p

real*8 x(rs,p),d(cs,p)

do 10 m=1,p

read(6,*)(x(i,m),i=1,rs)

10 continue

do 20 n=1,p

read(6,*)(d(i,n),i=1,cs)

20 continue

return

end

!归一化数据处理

subroutine input22(rs,cs,p,x,d,x1,d1,ax,ai,adx,adi)

integer rs,cs,p

real*8 x(rs,p),d(cs,p),x1(rs+1,p),d1(cs,p),ax(cs),ai(cs),adx(cs),adi(cs)

do 10 i=1,rs

ai(i)=100d0

ax(i)=0d0 

do 20 j=1,p

a=x(i,j)

if(a.ge.ax(i))ax(i)=a

if(a.le.ai(i))ai(i)=a

20 continue

do 30 j=1,p

x1(i,j)=(x(i,j)-ai(i))/(ax(i)-ai(i))

30 continue

10 continue

write(8,*)((x1(i,j),i=1,rs),j=1,p)

do 50 i=1,cs

ai(i)=100d0

ax(i)=0d0 

do 60 j=1,p

a=d(i,j)

if(a.ge.ax(i))ax(i)=a

if(a.le.ai(i))ai(i)=a

60 continue

adi(i)=-(ax(i)-ai(i))/18

adx(i)=-adi(i)

do 70 j=1,p

d1(i,j)=(d(i,j)-ai(i)-adi(i))/(ax(i)+adx(i)-ai(i)-adi(i))

70 continue

50 continue

write(8,*)((d1(i,j),i=1,cs),j=1,p)

do 80 j=1,p

x1(0,j)=-1.0

80 continue

return

end

!计算各层输出

subroutine sup1(rs,cs,ys,j,p,v,w,x1,y,o)

integer rs,cs,ys,p

real netk,netj

real*8 v(rs+1,ys,2),w(ys+1,cs,2),x1(rs+1,p)

real*8 y(ys+1,p),o(cs,p)

y(0,j)=-1

do 10 i=1,ys

netj=0.0

do 15 m=0,rs

netj=netj+v(m,i,1)*x1(m,j)

15 continue

!write(8,*)netj

y(i,j)=1/(1+exp(-netj))

10 continue

do 20 k=1,cs

netk=0.0

do 25 n=0,ys

netk=netk+w(n,k,1)*y(n,j)

25 continue

!write(8,*)netk

o(k,j)=1/(1+exp(-netk))

20 continue

return

end

!计算各层误差信号

subroutine sup2(cs,ys,j,p,d1,o,y,w,e,wx1,wx2)

integer cs,ys,p

real*8  o(cs,p),d1(cs,p),y(ys+1,p),w(ys+1,cs,2),e(p),wx1(cs,p),wx2(ys,p)

ex=0.0

do 10 i=1,cs

ex=ex+(d1(i,j)-o(i,j))**2

10 continue

e(j)=sqrt(ex)

do 20 m=1,cs

wx1(m,j)=(d1(m,j)-o(m,j))*(1-o(m,j))*o(m,j)

20 continue

do 30 n=1,ys

wx3=0.0

do 40 l=1,cs

wx3=wx3+wx1(l,j)*w(n,l,1)

40 continue

wx2(n,j)=wx3*(1-y(n,j))*y(n,j)

30 continue

return

end

!权值修正

subroutine sup3(rs,cs,ys,p,t,r,x1,y,w,v,wx1,wx2)

integer rs,cs,ys,p

real wz,vz

real*8 v(rs+1,ys,2),w(ys+1,cs,2),x1(rs+1,p),y(ys+1,p),wx1(cs,p),wx2(ys,p)

do 10 k=1,cs

do 20 l=0,ys

wz=0.0

do 50 j=1,p

wz=t*wx1(k,j)*y(l,j)+wz

50 continue

w(l,k,2)=wz+r*w(l,k,2)

w(l,k,1)=w(l,k,1)+w(l,k,2)

20 continue

10 continue

do 30 m=1,ys

do 40 n=0,rs

do 60 j=1,p

vz=vz+t*wx2(m,j)*x1(n,j)

60 continue

v(n,m,2)=vz+r*v(n,m,2)

v(n,m,1)=v(n,m,1)+v(n,m,2)

40 continue

30 continue

return

end 

!反归一化处理

subroutine fgyh(cs,p,o,ax,ai,adx,adi,ds)

integer cs,p

real*8 ax(cs),ai(cs),adx(cs),adi(cs),o(cs,p),ds(cs,p)

do 10 i=1,cs

do 20 j=1,p

ds(i,j)=o(i,j)*(ax(i)+adx(i)-ai(i)-adi(i))+(ai(i)+adi(i))

20 continue

10 continue

return

end

!计算误差值

subroutine pde(cs,p,ec,d,ds,pdx)

integer cs,p,pdx

real ec,ax

real*8 epx(cs,p),d(cs,p),ds(cs,p)

pdx=1

do 5 j=1,p

do 10 i=1,cs

epx(i,j)=(d(i,j)-ds(i,j))/d(i,j)

ax=epx(i,j)

if(ax.lt.ec)then

goto 10

else

pdx=pdx+1

end if

10 continue

5 continue

write(8,*)'pdx=',pdx

write(8,*)((epx(i,j),i=1,cs),j=1,p)

return

end