!
subroutine random_sin_lattice(key)
use Advertisement
implicit none
integer*4, intent(in) :: key
real*4 u
integer*4 i
real*8 step
complex*16 length
if (exc.gt.1.d00) length=(0.d00,1.d00)*rad*dsqrt(exc*exc-1.d00)/exc
if (exc.le.1.d00) length=rad*dsqrt(1.d00-exc*exc)/exc
step=pi/n_max
do i=1, n_max
 call random_seed()
 call random_number(u)
 nPole(i)=length*dsin(-pi/2.d00+step*(i-1+u))
end do
step=pi/l_max
do i=1, l_max
 call random_seed()
 call random_number(u)
 lPole(i)=length*dsin(-pi/2.d00+step*(i-1+u))
end do
if (key.eq.1) then
 do i=1, n_max
  nPole(i)=nPole(i)+(0.d00,1.d00)*length/1.d02
 end do
 do i=1, l_max
  lPole(i)=nPole(i)+(0.d00,1.d00)*length/1.d02
 end do
end if
End subroutine random_sin_lattice
!
subroutine double_line_lattice(factor, shift)
use Advertisement
implicit none
real*8, intent(in) :: factor, shift
integer*4 i, sgn
real*8 step
complex*16 length
if (exc.gt.1.d00) length=(0.d00,1.d00)*rad*dsqrt(exc*exc-1.d00)/exc
if (exc.le.1.d00) length=rad*dsqrt(1.d00-exc*exc)/exc
length=length*factor
if (n_max.eq.1) then
 nPole(1)=(0.d00, 0.d00); lPole(1)=(0.d00, 0.d00)
else
 step=2.d00/(n_max-1)
 do i=1, n_max/2, 2
  nPole(i)=length*(-1.d00+step*(i-1))+(0.d00,1.d00)*length*shift
  nPole(i+1)=length*(-1.d00+step*(i-1))-(0.d00,1.d00)*length*shift
 end do
 step=2.d00/(l_max-1)
 do i=1, l_max/2, 2
  lPole(i)=length*(-1.d00+step*(i-1))+(0.d00,1.d00)*length*shift
  lPole(i+1)=length*(-1.d00+step*(i-1))-(0.d00,1.d00)*length*shift
 end do
end if
End subroutine double_line_lattice
!
Subroutine Integrals_Writing
use Advertisement
implicit none
integer*4 i
complex*16 mi, mj, mk, ml
real*8 rnr, rnt, r, z, step, mass(3, 2000)
call Preparations
nPole(1)=Et
lPole(1)=Ef
m=m_max
call Normalization
step=2.d00*0.99999/(node_max-1)
n=n_max; l=l_max
DO i=1, node_max
 z=-0.99999d00+step*(i-1)
 r=rad/dsqrt(1.d00-exc*z**2)
 rnr=-r*r
 rnt=-(r**4)*z*dsqrt(1.d00-z*z)*exc/(rad**2)
  call Components(r, z, n_max, n_max, 3, nPole, n_M, n_N)
  call Components(r, z, l_max, l_max, 1, lPole, l_M, l_N)
   if (m.ne.0) then 
    mi=(rnr*(-n_M(2,n)*l_M(3,l)-n_M(3,n)*l_M(2,l))+ &
	 rnt*(n_M(1,n)*l_M(3,l)+n_M(3,n)*l_M(1,l)))
    ml=(rnr*(n_N(2,n)*l_N(3,l)+n_N(3,n)*l_N(2,l))+ &
	 rnt*(-n_N(1,n)*l_N(3,l)-n_N(3,n)*l_N(1,l)))
   end if
   mk=(rnr*(n_M(2,n)*l_N(3,l)-n_M(3,n)*l_N(2,l))+ &
	 rnt*(-n_M(1,n)*l_N(3,l)+n_M(3,n)*l_N(1,l)))
   mj=(rnr*(n_N(2,n)*l_M(3,l)-n_N(3,n)*l_M(2,l))+ &
	 rnt*(-n_N(1,n)*l_M(3,l)+n_N(3,n)*l_M(1,l)))
!   mass(1,i)=z; mass(2,i)=dreal(ml+r_i*mi); mass(3,i)=dimag(ml+r_i*mi)!
   mass(1,i)=z; mass(2,i)=dreal(mi+r_i*ml); mass(3,i)=dimag(ml+r_i*mi)!
!   mass(1,i)=z; mass(2,i)=dreal(mj+r_i*mk); mass(3,i)=dimag(ml+r_i*mi)!
!   mass(1,i)=z; mass(2,i)=dreal(mk+r_i*mj); mass(3,i)=dimag(ml+r_i*mi)!
END DO
do i=1, node_max
 write(06, *) mass(1, i), mass(2,i), mass(3,i)
end do
End Subroutine Integrals_Writing
!
Subroutine Inc_Field_Coeff(beta, tau, mm, nn, zet)
use Advertisement
implicit none
real*8, intent(in) :: zet
integer*4 tau, mm, nn, beta
real*8 pl(n_), tl(n_), alpha
complex*16 b, bb, A(2), e(2)
m=abs(mm); n_max=nn
alpha=((-1)**m)*dsqrt(.5d00); if (m.eq.0) alpha=1.d00
call Normalization
call nLegendre(nn, zet, dsqrt(1.d00-zet*zet), pl, tl)
if (beta.eq.1) then
  e(1)=(1.d00, 0.d00); e(2)=(0.d00, 1.d00)
end if
if (beta.eq.-1) then
  e(1)=(1.d00, 0.d00); e(2)=-(0.d00, 1.d00)
end if
e=e/dsqrt(2.d00)
pl(nn)=pl(nn)*nu(nn)*alpha; tl(nn)=tl(nn)*nu(nn)*alpha
if (mm.lt.0) then
  pl(nn)=pl(nn)*((-1)**mm)
  tl(nn)=tl(nn)*((-1)**mm)
end if
if (tau.eq.1) then
  A(1)=-(0.d00, 1.d00)*mm*pl(nn); A(2)=-tl(nn)
end if
if (tau.eq.2) then
  A(2)=-(0.d00, 1.d00)*mm*pl(nn); A(1)=tl(nn)
end if
b=4.d00*pi*((0.d00, 1.d00)**(nn-tau+1))
b=b*(e(1)*A(1)+e(2)*A(2))
bb=((-1)**mm)*((0.d00, 1.d00)**(nn-1))*(beta**(tau+1))*dsqrt(2.d00*pi*(2*nn+1))
print *, b, bb
End Subroutine Inc_Field_Coeff
!
Subroutine Plus_Minus_Right_Part
use Advertisement
implicit none
complex*16 i, a1, a2
complex*16 p, t, A(2), e(2)
real*8 alpha
i=4.d00*pi*((0.d00, 1.d00)**(m_min-1))/(0.d00, 2.d00)/dsqrt(2.d00)
do n=1, n_max
 n_M(1,n)=i*cdexp((0.d00, 1.d00)*z0*nPole(n))
end do
alpha=((-1)**m)*dsqrt(.5d00); if (m.eq.0) alpha=1.d00
Call Legendre((1.d00, 0.d00)*z0, p, t)
p=p*alpha; t=t*alpha
a1=Et*(m*p+t)+Ef*(m*p-t)
a2=Et*(m*p+t)+Ef*(-m*p+t)
do n=1, n_max
 n_M(2, n)=a1*n_M(1, n)
 n_N(3, n)=a2*n_M(1, n)
end do
p=((-1)**m)*p; t=((-1)**m)*t
a1=Et*(-m*p+t)+Ef*(-m*p-t)
a2=Et*(-m*p+t)+Ef*(m*p+t)
do n=1, n_max
 n_M(3, n)=a1*n_M(1, n)
 n_N(2, n)=a2*n_M(1, n)
end do
End Subroutine Plus_Minus_Right_Part
!
Subroutine TE_TM(fi, min, max, TE, TM)
use Advertisement
implicit none
real*8, intent(in) :: fi
integer*4, intent(in) :: min, max
complex*16, intent(out) :: TE(3), TM(3)
integer*4 k
real*8 c,s
complex*16 v(3)
TE=(0.d00,0.d00); TM=(0.d00,0.d00)
c=dcos(m*fi); s=dsin(m*fi)
do k=min, max
 TE(1)=TE(1)+(n_M(1,k)*l_M(3,k)+n_N(1,k)*l_N(2,k))*c
 TE(2)=TE(2)+(n_M(2,k)*l_M(3,k)+n_N(2,k)*l_N(2,k))*c
 TE(3)=TE(3)+(n_M(3,k)*l_M(3,k)-n_N(3,k)*l_N(2,k))*s
 TM(1)=TM(1)+(-n_M(1,k)*l_M(2,k)+n_N(1,k)*l_N(3,k))*s
 TM(2)=TM(2)+(-n_M(2,k)*l_M(2,k)+n_N(2,k)*l_N(3,k))*s
 TM(3)=TM(3)+(n_M(3,k)*l_M(2,k)+n_N(3,k)*l_N(3,k))*c
end do
End Subroutine TE_TM
!
Subroutine Field_Along_Line(altitude, azimut)
use Advertisement
implicit none
real*8, intent(in) :: altitude, azimut
real*8 er, zet, fi
rs=rad/dsqrt(1.d00-exc*altitude**2)
do n=1, 100
  er=rs*(-1.d00+(n-1)*(2.d00/99.d00))
  zet=-altitude; if (er.gt.0.d00) zet=altitude
  fi=azimut+pi; if (er.gt.0.d00) fi=azimut
  call Components(dabs(er), zet, 1, l_max, 1, lPole, n_M, n_N)
  call TE_TM(fi, 1, l_max, pe, pm)
  fTE(:,n)=fTE(:,n)+pe
  fTM(:,n)=fTM(:,n)+pm
end do
End Subroutine Field_Along_Line
!
Subroutine Form_Field
use Advertisement
implicit none
real*8 d, sigma_max, sigma, tau, dsigma, dtau, dz, z, er, zet
integer*4 i, j
d=rad*dsqrt(dabs(exc/(1.d00-exc)))
sigma_max=dsqrt(1.d00/dabs(exc))
dtau=1.9998d00/99.d00
dz=2.d00*rad/dsqrt(1-exc)/99.d00
dsigma=(sigma_max-1.d00)/99.5d00
if (exc.lt.0.d00) dsigma=sigma_max/99.5d00
do i=1, 100
  z=-rad/dsqrt(1.d00-exc)+(i-1)*dz
  if (z.lt.0.d00) then
    er=-z; zet=-1.d00
  end if
  if (z.gt.0.d00) then
    er=z; zet=1.d00
  end if
  call Components(er, zet, 1, l_max, 1, lPole, n_M, n_N)
  call TE_TM(0.d00, 1, l_max, pe, pm)
  pe=et*pe+ef*pm
  amps(101,i)=dsqrt(cdabs(pe(1))**2+ cdabs(pe(2))**2+cdabs(pe(3))**2)
end do
do i=1,100
  sigma=1.d00+dsigma/2.d00+(i-1)*dsigma
  if (exc.lt.0.d00) sigma=dsigma/2.d00+(i-1)*dsigma
  do j=1,100
    tau=-0.9999d00+(j-1)*dtau
	if (exc.gt.0.d00) er=d*dsqrt(sigma**2+tau**2-1.d00)
    if (exc.lt.0.d00) er=d*dsqrt(sigma**2-tau**2+1.d00)
	zet=sigma*tau*d/er
    call Components(er, zet, 1, l_max, 1, lPole, n_M, n_N)
    call TE_TM(0.d00, 1, l_max, pe, pm)
    pe=et*pe+ef*pm
    amps(i,j)=dsqrt(cdabs(pe(1))**2+ cdabs(pe(2))**2+cdabs(pe(3))**2)
  end do
end do
End Subroutine Form_Field
!
Subroutine Form_File
use Advertisement
implicit none
real*8 d, sigma_max, sigma, tau, dsigma, dtau, dz, z, er, zet
integer*4 i, j
d=rad*dsqrt(dabs(exc/(1.d00-exc)))
sigma_max=dsqrt(1.d00/dabs(exc))
dtau=1.9998d00/99.d00
dz=rad/dsqrt(1-exc)/99.d00
dsigma=(sigma_max-1.d00)/99.5d00; if (exc.lt.0.d00) dsigma=sigma_max/99.5d00
write (06,*) '====================================================='
write (06,*) '   i  ! j !   sigma     !     tau      !  amplitude'
write (06,*) '====================================================='
do i=1,100
  sigma=1.d00+dsigma/2.d00+(i-1)*dsigma
  if (exc.lt.0.d00) sigma=dsigma/2.d00+(i-1)*dsigma
  do j=1,100
    tau=-0.9999d00+dtau/2.d00+(j-1)*dtau 
    write (06, '(2x, i3,2x, i3, 2x, d12.5, 3x, d12.5, 3x, d12.5)') , i, j, sigma, tau, amps(i, j)
  end do
end do
do i=1, 100
  z=-rad/dsqrt(1.d00-exc)+(i-1)*dz
  if (exc.gt.0.d00) then
    if (z.lt.-d) then
      tau=-1.d00; sigma=z/d
    end if
    if (z.gt.-d.and.z.lt.d) then
      sigma=1.d00; tau=z/d
    end if
	if (z.gt.d) then
	  tau=1.d00; sigma=z/d
	end if
  else
    if (z.lt.0.d00) then
      tau=-1.d00; sigma=-z/d
    end if
    if (z.gt.0.d00) then
      tau=1.d00; sigma=z/d
    end if
  end if
  j=101
  write (06, '(2x, i3,2x, i3, 2x, d12.5, 3x, d12.5, 3x, d12.5)') j, i, sigma, tau, amps(101, i)
end do
End Subroutine Form_File
!
Subroutine Term(fi, num, E, H, evenness)
use Advertisement
implicit none
real*8, intent(in) :: fi
integer*4, intent(in) :: num, evenness
complex*16, intent(out), dimension(1:3) :: E, H
real*8 c, s
if (evenness.eq.1) then
 c=dcos(m*fi); s=-dsin(m*fi)
else
 s=dcos(m*fi); c=dsin(m*fi)
end if
if (num.le.n_max) then
 E(1)=n_M(1, num)*s; H(1)=n_N(1, num)*c 
 E(2)=n_M(2, num)*s; H(2)=n_N(2, num)*c
 E(3)=n_M(3, num)*c; H(3)=n_N(3, num)*s
else
 H(1)=n_M(1, num-n_max)*s; E(1)=n_N(1, num-n_max)*c 
 H(2)=n_M(2, num-n_max)*s; E(2)=n_N(2, num-n_max)*c
 H(3)=n_M(3, num-n_max)*c; E(3)=n_N(3, num-n_max)*s
end if
End Subroutine Term
!
Subroutine Norming_Matrix(n1, n2, l1, l2)
implicit none
integer*4, intent(in) :: n1, n2, l1, l2
real*8 max, mod
do i=n1, n2
   max=-1.d00
  do j=l1, l2
     mod=cdabs(MATRIX(i,j))
     if (mod.gt.max) max=mod
  end do
  j=1; nrm(i)=1.d00
  if (max.lt.1.d00) then
    do
       max=max*2.d00   
       if (max.le.1.d00) then
	     nrm(i)=nrm(i)/2.d00
	     j=j+1
       else 
	     Exit
	   end if 
    end do
   else
    do
       max=max/2.d00
       if (max/2.d00.ge.1.d00) then
	     nrm(i)=nrm(i)*2.d00
	     j=j+1
       else 
	     Exit
	   end if 
     end do
   end if
end do
do i=n1, n2
  do j=l1, l2
       MATRIX(i,j)=MATRIX(i,j)/nrm(i)
  end do
end do
End Subroutine Norming_Matrix
!
Subroutine Norming_Right_Part(n1, n2)
implicit none
integer*4, intent(in) :: n1, n2
do i=n1, n2
  r_p(i,1)=r_p(i,1)/nrm(i)
end do
End Subroutine Norming_Right_Part
!