! module for backpropagation algorithm for multi-layer neural network
! see latex document in ../docs directory
! based on chapter 11 of "neural network design"
! the forward model and  backprop are in here
! the minimization algorithm is not in the module

module network
use precis; use utilmod
implicit none
integer, parameter :: max_layer=3
integer, dimension(:) :: ima(0:max_layer),ifuna(max_layer)
real(mrl), dimension(:) :: funcoa(max_layer)
integer :: current_layer,nl,ifun
real(mrl) :: funco

real(mrl), allocatable, target :: &
  a0(:), &
  w1(:,:),b1(:),a1(:),dadn1(:),dw1(:,:),db1(:),s1(:), &
  w2(:,:),b2(:),a2(:),dadn2(:),dw2(:,:),db2(:),s2(:), &
  w3(:,:),b3(:),a3(:),dadn3(:),dw3(:,:),db3(:),s3(:)

real(mrl), pointer :: w(:,:),wp(:,:),b(:),a(:),dadn(:),dw(:,:),db(:),s(:),am(:),sp(:)
real(mrl), allocatable :: p(:),t(:),pa(:,:),ta(:,:)
real(mrl), allocatable :: pb(:,:),tb(:,:),pc(:,:),tc(:,:) !new


contains

subroutine allocate_network


i=ima(0)
allocate(a0(i))
j=i
i=ima(1)
allocate(w1(i,j),b1(i),dw1(i,j),db1(i),a1(i),dadn1(i),s1(i))
nl=1
j=i
i=ima(2)
if (i>0) then
  nl=2
  allocate(w2(i,j),b2(i),dw2(i,j),db2(i),a2(i),dadn2(i),s2(i))
  j=i
  i=ima(3)
  if (i>0) then
    nl=3
    allocate(w3(i,j),b3(i),dw3(i,j),db3(i),a3(i),dadn3(i),s3(i))
  endif
endif
allocate(p(ima(0)),t(ima(nl))) 
print *,'layers allocated to nl=',nl
write (*,'("ima=",5i4)') ima
write (*,'("ifuna=",5i4)') ifuna
write (*,'("funcoa=",5f5.2)') funcoa 
end subroutine allocate_network

subroutine point_layer(m)
integer m
if (m.eq.1) then
  am=>a0
  a=>a1
  dadn=>dadn1
  s=>s1
  sp=>s2
  w=>w1
  dw=>dw1
  b=>b1
  db=>db1
  wp=>w2
  ifun=ifuna(1)
  funco=funcoa(1)
else if (m.eq.2) then
  am=>a1
  a=>a2
  dadn=>dadn2
  s=>s2
  sp=>s3
  w=>w2
  dw=>dw2
  b=>b2
  db=>db2
  wp=>w3
  ifun=ifuna(2)
  funco=funcoa(2)
else if (m.eq.3) then
  am=>a2
  a=>a3
  dadn=>dadn3
  s=>s3
  w=>w3
  dw=>dw3
  b=>b3
  db=>db3
  nullify(sp)
  nullify(wp)
  ifun=ifuna(3)
  funco=funcoa(3)
else
  print *,' m not in range, cannot repoint. m=',m,' ,nl=',nl
  stop
endif
current_layer=m
end subroutine point_layer

subroutine random_init_network(iseed)
integer :: iseed(1),isd
isd=iseed(1)
do m=1,nl
  call point_layer(m)
  do i=1,size(w,1)
  do j=1,size(w,2)
  isd=mod(isd*7141+54773,259200)
  w(i,j)=-.5+isd/259199.
  end do
  end do
  do i=1,size(b,1)
  isd=mod(isd*7141+54773,259200)
  b(i)=-.5+isd/259199.
  end do
  print *, "random numbers: ",w(1,1),b(1)
  dw=0._mrl
  db=0._mrl
enddo
end subroutine random_init_network

!subroutine random_init_network(iseed)
!this does not work with intel compiler
!integer :: iseed(1)
!if (iseed(1) > 0 ) then
!  call random_seed(put=iseed)
!else
!  call random_seed()
!endif
!print *,' initializing with random numbers using seed= ',iseed
!do m=1,nl
!  call point_layer(m)
!  call random_number(w)
!  call random_number(b)
!  print *, "random numbers: ",w(1,1),b(1)
!  dw=0._mrl
!  db=0._mrl
!enddo
!end subroutine random_init_network

subroutine half_init_network
do m=1,nl
  call point_layer(m)
  w=.5_mrl
  b=.5_mrl
  dw=0._mrl
  db=0._mrl
enddo
print *, ' this is a stupid way to initialize...stopping'
stop
end subroutine half_init_network

subroutine write_network(filename)
character(*) :: filename
open (unit=61,file=trim(filename),status='unknown')
do m=1,nl
  call point_layer(m)
  write (61,'(e15.8)') w,b
enddo
close (unit=61)
print *,' wrote network to ',trim(filename)
end subroutine write_network

subroutine read_network(filename)
character(*) filename
print *,' will read network from ',trim(filename)
open (unit=62,file=trim(filename),status='unknown')
do m=1,nl
  call point_layer(m)
  read (62,*) w,b
enddo
close (unit=62)
end subroutine read_network

subroutine forward_model(p)
real(mrl), optional :: p(:)
if (present(p)) a0=p
do m=1,nl
  call point_layer(m)
  call f( dadn, a, matmul(w,am)+b, funco, ifun)
enddo
end subroutine forward_model

subroutine backprop_sensitivities(t) 
real(mrl) t(:)
call point_layer(nl)
s=-2*dadn*(t-a)
do m=nl-1,1,-1
  call point_layer(m)
  s=dadn*matmul(sp,wp) 
enddo
end subroutine backprop_sensitivities

subroutine f(dadn,a,n,coef,ifun)
integer ifun
real(mrl) :: dadn(:),a(:),n(:),coef
select case(ifun)
case(1) ! linear transfer function
forall (i=1:size(n,1))
a(i)=n(i)*coef
dadn(i)=coef
end forall 
case(2) ! logsig transfer function
do i=1,size(n,1)
  a(i)=1./(1.+exp(-coef*n(i)))
  dadn(i)=coef*a(i)*(1-a(i))
enddo
case default
print *, 'cannot find a function for ',ifun,' ...stopping'
stop
endselect
end subroutine f

subroutine sen_test(epsilon,i,j,ntl,t)
integer i,j,ntl
real(mrl) epsilon,t(:),error,perr,derror
if (current_layer.ne.nl) then
  print *,' cannot do sen_test, stopping'
  stop
endif
error=dot_product(a-t,a-t) !error in forward model 
call point_layer(ntl)
perr=s(i)*am(j)*epsilon !back prop predicted error sensitivity
w(i,j)=w(i,j)+epsilon !do perturbation test of error sensitivity
call forward_model !run perturbed forward model
derror=dot_product(a-t,a-t)-error !calculated change in error
print *,' predicted change:',perr,'   actual change:',derror
print *,' w probably corrupted by sen_test, you should probably stop'
end subroutine sen_test

!new code
subroutine write_a_t(pp,tp,filename,ofile,comment)
character(*) :: filename,ofile,comment
!character*200 filename,ofile,comment
real(mrl) pp(:,:),tp(:,:)
integer lrec,i,idr
character(1000) aline

open (unit=85,file=trim(filename),status='unknown')
write (85,'("# ",a)') trim(comment)
write (85,'("# ",a,"had these comments")') trim(ofile)

open (unit=84,file=trim(ofile),status='old')
2 call read_input_target_file(84,p,t,aline,idr)
if (idr.ne.2) goto 3 
write (85,'(a)') trim(aline) ! copy comments from original file
goto 2
3 close (unit=84)

lrec=size(pp,2)
do i=1,lrec
  p=pp(:,i) 
  t=tp(:,i)
  call forward_model(p)
  write (85,'(30e17.8)') a,t
end do
close(unit=85)
print *,"Wrote ",trim(filename)," ",trim(comment)
end subroutine write_a_t 

function average_square_target(tp)
real(mrl) average_square_target,avg
real(mrl) tp(:,:)
integer lrec,i
avg=0._mrl
lrec=size(tp,2)
if (lrec==0) then
  average_square_target=0._mrl
  return
end if
do i=1,lrec
  avg=avg+dot_product(tp(:,i),tp(:,i))
end do
average_square_target=avg/lrec
return
end function average_square_target

function average_error(pp,tp)
real(mrl) average_error
real(mrl) avg,pp(:,:),tp(:,:)
integer lrec,i
avg=0._mrl
lrec=size(pp,2)
if (lrec==0) then
  average_error=0._mrl
  return
end if
do i=1,lrec
  p=pp(:,i) 
  t=tp(:,i)
  call forward_model(p)
  avg=avg+dot_product(a-t,a-t)
end do
average_error=avg/lrec
return
end function average_error

function count_records_in(filename)
integer count_records_in, idr
character(*) filename
character(1000) aline
count_records_in=0
open (unit=85,file=trim(filename),status='old',err=3)
2 call read_input_target_file(85,p,t,aline,idr)
if (idr>2) goto 3 
if (idr>1) goto 2
count_records_in=count_records_in+1
goto 2
3 close (unit=85)
  return
end function count_records_in 

subroutine file_to_arrays(filename,px,tx)
character(*) filename
character(1000) aline
real(mrl) :: px(:,:),tx(:,:) 
integer irec,idr
irec=0
open (unit=85,file=trim(filename),status='old')
2 call read_input_target_file(85,p,t,aline,idr)
if (idr>2) goto 3 
if (idr>1) goto 2
irec=irec+1
px(:,irec)=p
tx(:,irec)=t
goto 2
3 close (unit=85)
if (irec.ne.size(px,2)) then
  print *, "big problem in file_to_arrays with ",trim(filename)
  print *, "these should be the same: ",irec,size(px,2),size(tx,2)
  stop
end if
end subroutine file_to_arrays


end module network

