! **********************************************************************************
! *          ROUTINES FOR COMPUTING THE SPHERICAL VECTOR WAVE FUNCTIONS            *
! *    -----------------------------------------------------------------------     *
! *    Partial list of subroutines:                                                *
! *      MN,                  MN_infinit,      MN_DS,          MN_poles_COMP,      *
! *      MN_poles_COMP1,      MN_DS_COMP,      MN_DS_COMP1,    MN_poles_LAY,       *
! *      MN_DS_LAY,           MN_complete,     MN_infinit_complete,                *
! *      MN_infinit_reflection_complete,       MN_left_right,  MN_anisotrop,       *
! *      MN_m_anisotrop.                                                           *
! **********************************************************************************
subroutine MN (index, z, theta, m, Nrank, Nmax, MV, NV)
!-----------------------------------------------------------------------------------
! The routine computes the localized vector spherical wave functions (excepting    !
! the factor exp(j*m*phi)) for the azimuthal mode m.                               !
!                                                                                !
! Input parameters:                                                                !
! - index (integer) - if index = 1, the regular vector wave functions are          !
!   computed. If index = 3, the radiating vector wave functions are computed.      !
! - z (complex,) - z = k * r, where k is the wave number and r is the module of    !
!   the position vector.                                                           !
! - theta (real) - zenith angle.                                                   !
! - m (integer) - azimuthal mode.                                                  !
! - Nrank (integer) - maximum expansion order.                                     !
! - Nmax (integer) - specifies the dimension of the vectors.                       !
!   For m = 0, Nmax = Nrank, while for m > 0, Nmax = Nrank - |m| + 1.              !
!                                                                                !
! Output parameters:                                                               !
! - MV, NV (complex arrays) - vector spherical wave functions.                     !
!-----------------------------------------------------------------------------------
  use parameters
  use derived_parameters
  implicit none
  integer    :: index, m, Nrank, Nmax
  real(O)    :: theta
  complex(O) :: z, MV(3,Nmax), NV(3,Nmax)
!
  integer    :: k, n
  real(O)    :: nm, mr, nr, fp, ft, fl
  complex(O) :: zc
  real(O),allocatable    :: Pnm(:), dPnm(:), pinm(:), taunm(:)
  complex(O),allocatable :: jh(:), jhd(:)
!
  allocate (jh(0:Nrank), jhd(0:Nrank))
  allocate (Pnm(0:Nrank), dPnm(0:Nrank), pinm(0:Nrank), taunm(0:Nrank))
  zc = z
  if (abs(zc) < MachEps) zc = cmplx(MachEps,MachEps,O)
  if (index == 1) then
    call besel_j (zc, Nrank, jh, jhd)
  else if (index == 3) then
    call besel_h (zc, Nrank, jh, jhd)
  endif
  call leg_normalized (theta, abs(m), Nrank, Pnm, dPnm, pinm, taunm)
  mr = real(m,O)
  do k = 1, Nmax
    if (m == 0) then
      n = k
    else
      n = abs(m) + k - 1
    end if
    nr = real(n * (n + 1),O)
    nm = 1._O / sqrt(2._O * nr)
    fp = mr * pinm(n) * nm
    ft = taunm(n) * nm
    fl = nr * Pnm(n) * nm
    MV(1,k) =   zero
    MV(2,k) =   jh(n)  * im * fp
    MV(3,k) = - jh(n)  * ft
    NV(1,k) =   jh(n)  * fl / zc
    NV(2,k) =   jhd(n) * ft / zc
    NV(3,k) =   jhd(n) * im * fp / zc
  end do
  deallocate (jh, jhd)
  deallocate (Pnm, dPnm, pinm, taunm)
end subroutine MN
!***********************************************************************************
subroutine MN_infinit (theta, phi, m, Nrank, Nmax, Minf, Ninf)
!-----------------------------------------------------------------------------------
! The routine computes the localized vector spherical wave functions at infinity   !
! (excepting the factor exp(j*k*R)/(k*R)) for the azimuthal mode m.                !
!                                                                                !
! Input parameters:                                                                !
! - theta, phi (real variables) - polar angles.                                    !
! - m (integer) - azimuthal mode.                                                  !
! - Nrank (integer) - maximum expansion order.                                     !
! - Nmax (integer) - specifies the dimension of the vectors.                       !
!   For m = 0, Nmax = Nrank, while for m > 0, Nmax = Nrank - |m| + 1.              !
!                                                                                !
! Output parameters:                                                               !
! - Minf, Ninf (complex arrays) - vector spherical wave functions at infinity.     !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: m, Nrank, Nmax
  real(O)    :: theta, phi
  complex(O) :: Minf(3,Nmax), Ninf(3,Nmax)
!
  integer    :: k, n
  real(O)    :: arg, nm, mr
  complex(O) :: fact, factc, factt, factp
  real(O),allocatable :: Pnm(:), dPnm(:), pinm(:), taunm(:)
!
  allocate (Pnm(0:Nrank), dPnm(0:Nrank), pinm(0:Nrank), taunm(0:Nrank))
  call leg_normalized (theta, abs(m), Nrank, Pnm, dPnm, pinm, taunm)
  mr   = real(m,O)
  arg  = mr * phi
  fact = exp(im * arg)
  do k = 1, Nmax
    if (m == 0) then
      n = k
    else
      n = abs(m) + k - 1
    end if
    nm    = real(2 * n * (n + 1),O)
    nm    = 1._O / sqrt(nm)
    factc = fact  * (-im)**(n + 1) * nm
    factp = factc * mr * pinm(n)
    factt = factc * taunm(n)
    Minf(1,k) =   zero
    Minf(2,k) =   im * factp
    Minf(3,k) = - factt
    Ninf(1,k) =   zero
    Ninf(2,k) =   im * factt
    Ninf(3,k) = - factp
  end do
  deallocate (Pnm, dPnm, pinm, taunm)
end subroutine MN_infinit
!***********************************************************************************
subroutine MN_DS (index, k, r, theta, zRe, zIm, m, Nrank, MV, NV)
!-----------------------------------------------------------------------------------
! The routine computes the distributed vector spherical wave functions (excepting  !
! the factor exp(j*m*phi)) for the azimuthal mode m.                               !
!                                                                                !
! Input parameters:                                                                !
! - index (integer) - if index = 1, the regular vector wave functions are          !
!   computed. If index = 3, the radiating vector wave functions are computed.      !
! - k (complex) - wave number.                                                     !
! - r (real) - module of the position vector.                                      !
! - theta (real) - zenith angle.                                                   !
! - zRe, zIm (real arrays) - coordinates of distributed sources in the complex     !
!   plane.                                                                         !
! - m (integer) - azimuthal mode.                                                  !
! - Nrank (integer) - maximum expansion order or the number of distributed         !
!   sources.                                                                       !
!                                                                                !
! Output parameters:                                                               !
! - MV, NV (complex arrays) - distributed vector spherical wave functions.         !
!-----------------------------------------------------------------------------------
  use parameters
  use derived_parameters
  implicit none
  integer    :: index, m, Nrank
  real(O)    :: r, theta, zRe(Nrank), zIm(Nrank)
  complex(O) :: k, MV(3,Nrank), NV(3,Nrank)
!
  integer    :: p, n, Nbes
  real(O)    :: ro, z, nm, mr, nr, cth, sth, dz
  complex(O) :: RR, sint, cost, argJ, sinc, cosc, Pmm, pimm, taumm, fp, ft, fl,     &
                factp, factt, factl, roc, dzc
  complex(O),allocatable :: jh(:), jhd(:)
!
  if (m == 0) then
    n = 1
  else
    n = abs(m)
  end if
  Nbes = n + 1
  mr   = real(m,O)
  nr   = real(n * (n + 1),O)
  nm   = 1._O / sqrt(2._O * nr)
  allocate (jh(0:Nbes), jhd(0:Nbes))
  sth = sin(theta)
  cth = cos(theta)
  ro  = r * sth
  z   = r * cth
  roc = cmplx(ro,0.0,O)
  do p = 1, Nrank
    dz  = z - zRe(p)
    dzc = cmplx(dz,0.0,O)
    RR  = sqrt(roc * roc + (dzc - im * zIm(p))**2)
    if (abs(RR) < MachEps) RR = cmplx(MachEps,MachEps,O)
    sint = ro / RR
    cost = (dzc - im * zIm(p)) / RR
    argJ = k * RR
    if (index == 1) then
      call besel_j (argJ, Nbes, jh, jhd)
    else if (index == 3) then
      call besel_h (argJ, Nbes, jh, jhd)
    end if
    call P_mm (sint, cost, abs(m), Pmm)
    call pi_mm (sint, abs(m), pimm)
    call tau_mm (sint, cost, abs(m), taumm)
    sinc = sth * cost - cth * sint
    cosc = cth * cost + sth * sint
    fp   = im * mr * pimm * nm
    ft   = taumm * nm
    fl   = nr * Pmm * nm
    factp   =   jh(n)  * fp
    MV(1,p) =   factp  * sinc
    MV(2,p) =   factp  * cosc
    MV(3,p) = - jh(n)  * ft
    factl   =   jh(n)  * fl
    factt   =   jhd(n) * ft
    NV(1,p) =   (   factl * cosc + factt * sinc) / argJ
    NV(2,p) =   ( - factl * sinc + factt * cosc) / argJ
    NV(3,p) =   jhd(n) * fp / argJ
  end do
  deallocate (jh, jhd)
end subroutine MN_DS
!***********************************************************************************
subroutine MN_poles_COMP (index, kk, r, theta, m, Npart, zpart, Nrankp, Nmax, MV, NV)
!-----------------------------------------------------------------------------------
! The routine computes the localized vector spherical wave functions (excepting    !
! the factor exp(j*m*phi)) for a composite particle and the azimuthal mode m.      !
!                                                                                !
! Input parameters:                                                                !
! - index (integer) - if index = 1, the regular vector wave functions are          !
!   computed. If index = 3, the radiating vector wave functions are computed.      !
! - kk (complex) - wave number.                                                    !
! - r (real) - module of the position vector.                                      !
! - theta (real) - zenith  angle.                                                  !
! - m (integer) - azimuthal mode.                                                  !
! - Npart (integer) - number of homogeneous regions.                               !
! - zpart (real array) -  axial coordinates of the region origins.                 !
! - Nrankp (integer array) - maximum expansion orders of the regions.              !
! - Nmax (integer) - specifies the dimension of the vectors.                       !
!                                                                                !
! Output parameters:                                                               !
! - MV, NV (complex arrays) - vector spherical wave functions.                     !
!-----------------------------------------------------------------------------------
  use parameters
  use derived_parameters
  implicit none
  integer    :: index, m, Npart, Nmax, Nrankp(Npart)
  real(O)    :: r, theta, zpart(Npart)
  complex(O) :: kk, MV(3,Nmax), NV(3,Nmax)
!
  integer    :: k, n, p, Nstart, Nmaxp, Nbes
  real(O)    :: r1, theta1, sinc, cosc, nm, mr, nr, fp, ft, fl, cth
  complex(O) :: zz, nvr, nvtheta, nvphi, mvtheta
  real(O),allocatable    :: Pnm(:), dPnm(:), pinm(:), taunm(:)
  complex(O),allocatable :: jh(:), jhd(:)
!
  cth  = cos(theta)
  Nbes = 1
  do p = 1, Npart
    if (Nrankp(p) > Nbes) then
      Nbes = Nrankp(p)
    end if
  end do
  allocate (jh(0:Nbes), jhd(0:Nbes))
  allocate (Pnm(0:Nbes), dPnm(0:Nbes), pinm(0:Nbes), taunm(0:Nbes))
  mr = real(m,O)
  Nstart = 0
  do p = 1, Npart
    if (Nrankp(p) >= abs(m)) then
      if (m == 0) then
        Nmaxp = Nrankp(p)
      else
        Nmaxp = Nrankp(p) - abs(m) + 1
      end if
      r1 = sqrt(r**2 + zpart(p)**2 - 2._O * r * zpart(p) * cth)
      if (r1 < MachEps) r1 = MachEps
      theta1 = acos((r * cth - zpart(p)) / r1)
      zz    = kk * r1
      if (index == 1) then
        call besel_j (zz, Nrankp(p), jh, jhd)
      else if (index == 3) then
        call besel_h (zz, Nrankp(p), jh, jhd)
      end if
      call leg_normalized (theta1, abs(m), Nrankp(p), Pnm, dPnm, pinm, taunm)
      sinc = sin(theta - theta1)
      cosc = cos(theta - theta1)
      do k = 1, Nmaxp
        if (m == 0) then
          n = k
        else
          n = abs(m) + k - 1
        end if
        nr = real(n * (n + 1),O)
        nm = 1._O / sqrt(2._O * nr)
        fp = mr * pinm(n) * nm
        ft = taunm(n) * nm
        fl = nr * Pnm(n) * nm
        mvtheta = jh(n) * im * fp
        MV(1,Nstart+k) =    mvtheta * sinc
        MV(2,Nstart+k) =    mvtheta * cosc
        MV(3,Nstart+k) = - jh(n)   * ft
        nvr     = fl * jh(n) / zz
        nvtheta = jhd(n) * ft / zz
        nvphi   = jhd(n) * im * fp / zz
        NV(1,Nstart+k) =   nvr * cosc + nvtheta * sinc
        NV(2,Nstart+k) = - nvr * sinc + nvtheta * cosc
        NV(3,Nstart+k) =   nvphi
      end do
      Nstart = Nstart + Nmaxp
    endif
  end do
  deallocate (jh, jhd)
  deallocate (Pnm, dPnm, pinm, taunm)
end subroutine MN_poles_COMP
!***********************************************************************************
subroutine MN_poles_COMP1 (index, ipart, kk, r, theta, m, Npart, zpart, Nrankp,     &
           Nmax, MV, NV)
!-----------------------------------------------------------------------------------
! The routine computes the localized vector spherical wave functions (excepting    !
! the factor exp(j*m*phi)) for the homogeneous region ipart (which is a part of    !
! the composite particle) and the azimuthal mode m.                                !
!                                                                                !
! Input parameters:                                                                !
! - index (integer) - if index = 1, the regular vector wave functions are          !
!   computed. If index = 3, the radiating vector wave functions are computed.      !
! - ipart (integer) - index of the homogeneous region.                             !
! - kk (complex) - wave number.                                                    !
! - r (real) - module of the position vector.                                      !
! - theta (real) - zenith angle.                                                   !
! - m (integer) - azimuthal mode.                                                  !
! - Npart (integer) - number of homogeneous regions.                               !
! - zpart (real array) - axial coordinates of the region origins.                  !
! - Nrankp (integer array) - maximum expansion orders of the regions.              !
! - Nmax (integer) - specifies the dimension of the vectors.                       !
!                                                                                !
! Output parameters:                                                               !
! - MV, NV (complex arrays) - vector spherical wave functions.                     !
!-----------------------------------------------------------------------------------
  use parameters
  use derived_parameters
  implicit none
  integer    :: index, m, Npart, Nmax, Nrankp(Npart), ipart
  real(O)    :: r, theta, zpart(Npart)
  complex(O) :: kk, MV(3,Nmax), NV(3,Nmax)
!
  integer    :: k, n, p, Nstart, Nmaxp, Nbes
  real(O)    :: r1, theta1, sinc, cosc, nm, mr, nr, fp, ft, fl, cth
  complex(O) :: zz, nvr, nvtheta, nvphi, mvtheta
  real(O),allocatable    :: Pnm(:), dPnm(:), pinm(:), taunm(:)
  complex(O),allocatable :: jh(:), jhd(:)
!
  cth  = cos(theta)
  Nbes = 1
  do p = 1, Npart
    if (Nrankp(p) > Nbes) then
      Nbes = Nrankp(p)
    end if
  end do
  allocate (jh(0:Nbes), jhd(0:Nbes))
  allocate (Pnm(0:Nbes), dPnm(0:Nbes), pinm(0:Nbes), taunm(0:Nbes))
  mr = real(m,O)
  do k = 1, 3
    do p = 1, Nmax
      MV(k,p) = zero
      NV(k,p) = zero
    end do
  end do
  Nstart = 0
  do p = 1, Npart
    if (Nrankp(p) >= abs(m)) then
      if (m == 0) then
        Nmaxp = Nrankp(p)
      else
        Nmaxp = Nrankp(p) - abs(m) + 1
      end if
      if (p == ipart) then
        r1 = sqrt(r**2 + zpart(p)**2 - 2._O * r * zpart(p) * cth)
        if (r1 < MachEps) r1 = MachEps
        theta1 = acos((r * cth - zpart(p)) / r1)
        zz     = kk * r1
        if (index == 1) then
          call besel_j (zz, Nrankp(p), jh, jhd)
        else if (index == 3) then
          call besel_h (zz, Nrankp(p), jh, jhd)
        end if
        call leg_normalized (theta1, abs(m), Nrankp(p), Pnm, dPnm, pinm, taunm)
        sinc = sin(theta - theta1)
        cosc = cos(theta - theta1)
        do k = 1, Nmaxp
          if (m == 0) then
            n = k
          else
            n = abs(m) + k - 1
          end if
          nr = real(n * (n + 1),O)
          nm = 1._O / sqrt(2._O * nr)
          fp = mr * pinm(n) * nm
          ft = taunm(n) * nm
          fl = nr * Pnm(n) * nm
          mvtheta = jh(n) * im * fp
          MV(1,Nstart+k) =   mvtheta * sinc
          MV(2,Nstart+k) =   mvtheta * cosc
          MV(3,Nstart+k) = - jh(n)  * ft
          nvr     = fl * jh(n) / zz
          nvtheta = jhd(n) * ft / zz
          nvphi   = jhd(n) * im * fp / zz
          NV(1,Nstart+k) =   nvr * cosc + nvtheta * sinc
          NV(2,Nstart+k) = - nvr * sinc + nvtheta * cosc
          NV(3,Nstart+k) =   nvphi
        end do
      end if
      Nstart = Nstart + Nmaxp
    endif
  end do
  deallocate (jh, jhd)
  deallocate (Pnm, dPnm, pinm, taunm)
end subroutine MN_poles_COMP1
!***********************************************************************************
subroutine MN_DS_COMP (index, k, r, theta, Npart, Nrankpmax, Nrankp, zRe, zIm, m,   &
           Nrank, MV, NV)
!-----------------------------------------------------------------------------------
! The routine computes the distributed vector spherical wave functions (excepting  !
! the factor exp(j*m*phi)) for a composite particle and the azimuthal mode m.      !
!                                                                                !
! Input parameters:                                                                !
! - index (integer) - if index = 1, the regular vector wave functions are          !
!   computed. If index = 3, the radiating vector wave functions are computed.      !
! - k (complex) - wave number.                                                     !
! - r (real) - module of the position vector.                                      !
! - theta (real) - zenith angle.                                                   !
! - m (integer) - azimuthal mode.                                                  !
! - Npart (integer) - number of homogeneous regions.                               !
! - zRe, zIm (real array) - coordinates of the region origins in the complex       !
!   plane.                                                                         !
! - Nrankpmax (integer) - specifies the dimension of zRe and zIm.                  !
! - Nrankp (integer array) - maximum expansion orders of the homogeneous regions.  !
! - Nrank (integer) - specifies the dimension of the vectors.                      !
!                                                                                !
! Output parameters:                                                               !
! - MV, NV (complex arrays) - vector spherical wave functions.                     !
!-----------------------------------------------------------------------------------
  use parameters
  use derived_parameters
  implicit none
  integer    :: index, Npart, Nrankpmax, Nrankp(Npart), m, Nrank
  real(O)    :: r, theta, zRe(Npart,Nrankpmax), zIm(Npart,Nrankpmax)
  complex(O) :: k, MV(3,Nrank), NV(3,Nrank)
!
  integer    :: p, n, Nbes, Nstart, Nrankpl, ipart
  real(O)    :: ro, z, nm, mr, nr, sth, cth, dz
  complex(O) :: RR, sint, cost, argJ, sinc, cosc, Pmm, pimm, taumm, fp, ft, fl,     &
                factp, factt, factl, roc, dzc
  complex(O),allocatable :: jh(:), jhd(:)
!
  if (m == 0) then
    n = 1
  else
    n = abs(m)
  end if
  Nbes = n + 1
  mr   = real(m,O)
  nr   = real(n * (n + 1),O)
  nm   = 1._O / sqrt(2._O * nr)
  allocate (jh(0:Nbes), jhd(0:Nbes))
  sth = sin(theta)
  cth = cos(theta)
  ro  = r * sth
  z   = r * cth
  roc = cmplx(ro,0.0,O)
  Nstart = 0
  do ipart = 1, Npart
    Nrankpl = Nrankp(ipart)
    do p = 1, Nrankpl
      dz  = z - zRe(ipart,p)
      dzc = cmplx(dz,0.0,O)
      RR  = sqrt(roc * roc + (dzc - im * zIm(ipart,p))**2)
      if (abs(RR) < MachEps) RR = cmplx(MachEps,MachEps,O)
      sint = ro / RR
      cost = (dzc - im * zIm(ipart,p)) / RR
      argJ = k * RR
      if (index == 1) then
        call besel_j (argJ, Nbes, jh, jhd)
      else if (index == 3) then
        call besel_h (argJ, Nbes, jh, jhd)
      end if
      call P_mm (sint, cost, abs(m), Pmm)
      call pi_mm (sint, abs(m), pimm)
      call tau_mm (sint, cost, abs(m), taumm)
      sinc  = sth * cost - cth * sint
      cosc  = cth * cost + sth * sint
      fp    = im * mr * pimm * nm
      ft    = taumm * nm
      fl    = nr * Pmm * nm
      factp = jh(n) * fp
      MV(1,Nstart+p) =   factp * sinc
      MV(2,Nstart+p) =   factp * cosc
      MV(3,Nstart+p) = - jh(n) * ft
      factt = jhd(n) * ft
      factl = jh(n)  * fl
      NV(1,Nstart+p) = (  factl * cosc + factt * sinc) / argJ
      NV(2,Nstart+p) = (- factl * sinc + factt * cosc) / argJ
      NV(3,Nstart+p) = jhd(n) * fp / argJ
    end do
    Nstart = Nstart + Nrankpl
  end do
  deallocate (jh, jhd)
end subroutine MN_DS_COMP
!***********************************************************************************
subroutine MN_DS_COMP1 (index, ipart, k, r, theta, Npart, Nrankpmax, Nrankp, zRe,   &
           zIm, m, Nrank, MV, NV)
!-----------------------------------------------------------------------------------
! The routine computes the localized vector spherical wave functions (excepting    !
! the factor exp(j*m*phi)) for the homogeneous region ipart (which is a part of    !
! a composite paticle) and the azimuthal mode m.                                   !
!                                                                                !
! Input parameters:                                                                !
! - index (integer) - if index = 1, the regular vector wave functions are          !
!   computed. If index = 3, the radiating vector wave functions are computed.      !
! - ipart (integer) - index of the homogeneous region.                             !
! - k (complex) - wave number.                                                     !
! - r (real) - module of the position vector.                                      !
! - theta (real) - zenith angle.                                                   !
! - m (integer) - azimuthal mode.                                                  !
! - Npart (integer) - number of homogeneous regions.                               !
! - zRe, zIm (real array) - coordinates of the region origins in the complex       !
!   plane.                                                                         !
! - Nrankpmax (integer) - specifies the dimension of zRe and zIm.                  !
! - Nrankp (integer array) - maximum expansion orders of the homogeneous regions.  !
! - Nrank (integer) - specifies the dimension of the vectors.                      !
!                                                                                !
! Output parameters:                                                               !
! - MV, NV (complex arrays) - vector spherical wave functions.                     !
!-----------------------------------------------------------------------------------
  use parameters
  use derived_parameters
  implicit none
  integer    :: index, ipart, Npart, Nrankpmax, Nrankp(Npart), m, Nrank
  real(O)    :: r, theta, zRe(Npart,Nrankpmax), zIm(Npart,Nrankpmax)
  complex(O) :: k, MV(3,Nrank), NV(3,Nrank)
!
  integer    :: l, p, n, Nbes, Nstart, Nrankpl, iipart
  real(O)    :: ro, z, nm, mr, nr, sth, cth, dz
  complex(O) :: RR, sint, cost, argJ, sinc, cosc, Pmm, pimm, taumm, fp, ft, fl,     &
                factp, factl, factt, roc, dzc
  complex(O),allocatable :: jh(:), jhd(:)
!
  if (m == 0) then
    n = 1
  else
    n = abs(m)
  end if
  Nbes = n + 1
  mr   = real(m,O)
  nr   = real(n * (n + 1),O)
  nm   = 1._O / sqrt(2._O * nr)
  allocate (jh(0:Nbes), jhd(0:Nbes))
  do l = 1, 3
    do p = 1, Nrank
      MV(l,p) = zero
      NV(l,p) = zero
    end do
  end do
  sth = sin(theta)
  cth = cos(theta)
  ro  = r * sth
  z   = r * cth
  roc = cmplx(ro,0.0,O)
  Nstart = 0
  do iipart = 1, Npart
    Nrankpl = Nrankp(iipart)
    if (iipart == ipart) then
      do p = 1, Nrankpl
        dz  = z - zRe(ipart,p)
        dzc = cmplx(dz,0.0,O)
        RR  = sqrt(roc * roc + (dzc - im * zIm(ipart,p))**2)
        if (abs(RR) < MachEps) RR = cmplx(MachEps,MachEps,O)
        sint = ro / RR
        cost = (dzc - im * zIm(ipart,p)) / RR
        argJ = k * RR
        if (index == 1) then
          call besel_j (argJ, Nbes, jh, jhd)
        else if (index == 3) then
          call besel_h (argJ, Nbes, jh, jhd)
        end if
        call P_mm (sint, cost, abs(m), Pmm)
        call pi_mm (sint, abs(m), pimm)
        call tau_mm (sint, cost, abs(m), taumm)
        sinc  = sth * cost - cth * sint
        cosc  = cth * cost + sth * sint
        fp    = im * mr * pimm * nm
        ft    = taumm * nm
        fl    = nr * Pmm * nm
        factp = jh(n) * fp
        MV(1,Nstart+p) =   factp * sinc
        MV(2,Nstart+p) =   factp * cosc
        MV(3,Nstart+p) = - jh(n) * ft
        factt = jhd(n) * ft
        factl = jh(n)  * fl
        NV(1,Nstart+p) = (  factl * cosc + factt * sinc) / argJ
        NV(2,Nstart+p) = (- factl * sinc + factt * cosc) / argJ
        NV(3,Nstart+p) = jhd(n) * fp / argJ
      end do
    endif
    Nstart = Nstart + Nrankpl
  end do
  deallocate (jh, jhd)
end subroutine MN_DS_COMP1
!***********************************************************************************
subroutine MN_poles_LAY (index, kk, r, theta, m, ipart, Npart, Nrankp, Nmaxpmax,    &
           Nmaxp, zpart, MV, NV)
!-----------------------------------------------------------------------------------
! The routine computes the localized vector spherical wave functions (excepting    !
! the factor exp(j*m*phi)) for the layer ipart and the azimuthal mode m.           !
!                                                                                !
! Input Parameters:                                                                !
! - index (integer) - if index = 1, the regular vector wave functions are          !
!   computed. If index = 3, the radiating vector wave functions are computed.      !
! - kk (complex) - wave number.                                                    !
! - r (real) - module of the position vector.                                      !
! - theta (real) - zenith angle.                                                   !
! - m (integer) - azimuthal mode.                                                  !
! - ipart (integer) - index of the layer.                                          !
! - Npart (integer) - number of layers.                                            !
! - zpart (real array) - axial coordinates of the layer origins.                   !
! - Nrankp (integer array) - maximum expansion orders of the layers.               !
! - Nmaxp (integer array) - real dimensions of the vector functions corresponding  !
!   to a specific layer.                                                           !
! - Nmaxpmax (integer) - specifies the physical dimension of the vectors.          !
!                                                                                !
! Output parameters:                                                               !
! - MV, NV (complex arrays) - vector spherical wave functions.                     !
!-----------------------------------------------------------------------------------
  use parameters
  use derived_parameters
  implicit none
  integer    :: index, m, ipart, Npart, Nrankp(Npart), Nmaxpmax, Nmaxp(Npart)
  real(O)    :: r, theta, zpart(Npart)
  complex(O) :: kk, MV(3,Nmaxpmax), NV(3,Nmaxpmax)
!
  integer    :: l, k, n, p, Nbes
  real(O)    :: r1, theta1, sinc, cosc, nm, mr, nr, fp, ft, fl, cth
  complex(O) :: zz, nvr, nvtheta, nvphi, mvtheta
  real(O),allocatable    :: Pnm(:), dPnm(:), pinm(:), taunm(:)
  complex(O),allocatable :: jh(:), jhd(:)
!
  cth = cos(theta)
  do l = 1, 3
    do p = 1, Nmaxpmax
      MV(l,p) = zero
      NV(l,p) = zero
    end do
  end do
  Nbes = Nrankp(ipart)
  allocate (jh(0:Nbes), jhd(0:Nbes))
  allocate (Pnm(0:Nbes), dPnm(0:Nbes), pinm(0:Nbes), taunm(0:Nbes))
  mr = real(m,O)
  r1 = sqrt(r**2 + zpart(ipart)**2 - 2._O * r * zpart(ipart) * cth)
  if (r1 < MachEps) r1 = MachEps
  theta1 = acos((r * cth - zpart(ipart)) / r1)
  zz    = kk * r1
  if (index == 1) then
    call besel_j (zz, Nrankp(ipart), jh, jhd)
  else if (index == 3) then
    call besel_h (zz, Nrankp(ipart), jh, jhd)
  end if
  call leg_normalized (theta1, abs(m), Nrankp(ipart), Pnm, dPnm, pinm, taunm)
  sinc = sin(theta - theta1)
  cosc = cos(theta - theta1)
  do k = 1, Nmaxp(ipart)
    if (m == 0) then
      n = k
    else
      n = abs(m) + k - 1
    end if
    nr = real(n * (n + 1),O)
    nm = 1._O / sqrt(2._O * nr)
    fp = mr * pinm(n) * nm
    ft = taunm(n) * nm
    fl = nr * Pnm(n) * nm
    mvtheta = jh(n) * im * fp
    MV(1,k) =   mvtheta * sinc
    MV(2,k) =   mvtheta * cosc
    MV(3,k) = - jh(n)  * ft
    nvr     =   fl * jh(n) / zz
    nvtheta =   jhd(n) * ft / zz
    nvphi   =   jhd(n) * im * fp / zz
    NV(1,k) =   nvr * cosc + nvtheta * sinc
    NV(2,k) = - nvr * sinc + nvtheta * cosc
    NV(3,k) =   nvphi
  end do
  deallocate (jh, jhd)
  deallocate (Pnm, dPnm, pinm, taunm)
end subroutine MN_poles_LAY
!***********************************************************************************
subroutine MN_DS_LAY (index, k, r, theta, ipart, Npart, Nrankpmax, Nrankp,          &
           zRe, zIm, m, MV, NV)
!-----------------------------------------------------------------------------------
! The routine computes the distributed vector spherical wave functions (excepting  !
! the factor exp(j*m*phi)) for the layer ipart and the azimuthal mode m.           !
!                                                                                !
! Input parameters:                                                                !
! - index (integer) - if index = 1, the regular vector wave functions are          !
!   computed. If index = 3, the radiating vector wave functions are computed.      !
! - k (complex) - wave number.                                                     !
! - r (real) - module of the position vector.                                      !
! - theta (real) - zenith angle.                                                   !
! - m (integer) - azimuthal mode.                                                  !
! - ipart (integer) - index of the layer.                                          !
! - Npart (integer) - number of layers.                                            !
! - zRe, zIm (real array) - coordinates of the region origins in the complex       !
!   plane.                                                                         !
! - Nrankp (integer array) - maximum expansion orders of the layers.               !
! - Nrankpmax (integer) - specifies the physical dimension of the vectors.         !
!                                                                                !
! Output parameters:                                                               !
! - MV, NV (complex arrays) - vector spherical wave functions.                     !
!-----------------------------------------------------------------------------------
  use parameters
  use derived_parameters
  implicit none
  integer    :: index, ipart, Npart, Nrankpmax, Nrankp(Npart), m
  real(O)    :: r, theta
  real(O)    :: zRe(Npart,Nrankpmax), zIm(Npart,Nrankpmax)
  complex(O) :: k, MV(3,Nrankpmax), NV(3,Nrankpmax)
!
  integer    :: p, n, Nbes, Nrankpl, l
  real(O)    :: ro, z, nm, mr, nr, sth, cth, dz
  complex(O) :: Pmm, pimm, taumm, RR, sint, cost, argJ, sinc, cosc, fp, ft, fl,     &
                factp, factl, factt, roc, dzc
  complex(O),allocatable :: jh(:), jhd(:)
!
  if (m == 0) then
    n = 1
  else
    n = abs(m)
  end if
  Nbes = n + 1
  mr   = real(m,O)
  nr   = real(n * (n + 1),O)
  nm   = 1._O / sqrt(2._O * nr)
  allocate (jh(0:Nbes), jhd(0:Nbes))
  do l = 1, 3
    do p = 1, Nrankpmax
      MV(l,p) = zero
      NV(l,p) = zero
    end do
  end do
  sth = sin(theta)
  cth = cos(theta)
  ro  = r * sth
  z   = r * cth
  roc = cmplx(ro,0.0,O)
  Nrankpl = Nrankp(ipart)
  do p = 1, Nrankpl
    dz  = z - zRe(ipart,p)
    dzc = cmplx(dz,0.0,O)
    RR  = sqrt(roc * roc + (dzc - im * zIm(ipart,p))**2)
    if (abs(RR) < MachEps) RR = cmplx(MachEps,MachEps,O)
    sint = ro / RR
    cost = (dzc - im * zIm(ipart,p)) / RR
    argJ = k * RR
    if (index == 1) then
      call besel_j (argJ, Nbes, jh, jhd)
    else if (index == 3) then
      call besel_h (argJ, Nbes, jh, jhd)
    end if
    call P_mm (sint, cost, abs(m), Pmm)
    call pi_mm (sint, abs(m), pimm)
    call tau_mm (sint, cost, abs(m), taumm)
    sinc  = sth * cost - cth * sint
    cosc  = cth * cost + sth * sint
    fp    = im * mr * pimm * nm
    ft    = taumm * nm
    fl    = nr * Pmm * nm
    factp = jh(n) * fp
    MV(1,p) =   factp * sinc
    MV(2,p) =   factp * cosc
    MV(3,p) = - jh(n) * ft
    factt   = jhd(n) * ft
    factl   = jh(n) * fl
    NV(1,p) = (  factl * cosc + factt * sinc) / argJ
    NV(2,p) = (- factl * sinc + factt * cosc) / argJ
    NV(3,p) = jhd(n) * fp / argJ
  end do
  deallocate (jh, jhd)
end subroutine MN_DS_LAY
!***********************************************************************************
subroutine MN_complete (index, z, theta, phi, Mrank, Nrank, Nmax, plus, sym, MV, NV)
!-----------------------------------------------------------------------------------
! The routine computes the localized vector spherical wave functions for the       !
! azimuthal modes m = 0,1,...,Mrank.                                               !
!                                                                                !
! Input parameters:                                                                !
! - index (integer) - if index = 1, the regular vector wave functions are          !
!   computed. If index = 3, the radiating vector wave functions are computed.      !
! - z (complex) - z = k*r, where k is the wave number and r is the module of the   !
!   position vector.                                                               !
! - theta, phi (real variables) - polar angles.                                    !
! - Mrank (integer) - number of azimuthal modes.                                   !
! - Nrank (integer) - maximum expansion order.                                     !
! - Nmax (integer) - specifies the dimension of the vectors.                       !
! - plus (logical) -  if plus = true the vector functions are computed for the     !
!   azimuthal modes m = 0,+1,-1,...,+Mrank,-Mrank. If plus = false the vector      !
!   functions are computed for the azimuthal modes m = 0,-1,+1,...,-Mrank,+Mrank.  !
! - sym (logical) - if sym = true the azimuthal dependence exp(j*m*phi) is         !
!   omitted. If sym = false, this dependence is taken into account.                !
!                                                                                !
! Output parameters:                                                               !
! - MV, NV (complex arrays) - vector spherical wave functions.                     !
!-----------------------------------------------------------------------------------
  use parameters
  use derived_parameters
  implicit none
  integer    :: index, Mrank, Nrank, Nmax
  real(O)    :: theta, phi
  complex(O) :: z, MV(3,Nmax), NV(3,Nmax)
  logical    :: plus, sym
!
  integer    :: k, m, l, ml, N0, n
  real(O)    :: nr, nm, mlr, ft, fl, arg
  complex(O) :: zc, fact, factp, factt, factl
  real(O),allocatable    :: Pnm(:), dPnm(:), pinm(:), taunm(:)
  complex(O),allocatable :: jh(:), jhd(:)
!
  allocate (jh(0:Nrank), jhd(0:Nrank))
  allocate (Pnm(0:Nrank), dPnm(0:Nrank), pinm(0:Nrank), taunm(0:Nrank))
  zc = z
  if (abs(zc) < MachEps) zc = cmplx(MachEps,MachEps,O)
  if (index == 1) then
    call besel_j (zc, Nrank, jh, jhd)
  else if (index == 3) then
    call besel_h (zc, Nrank, jh, jhd)
  end if
  do m = 0, Mrank
    call leg_normalized (theta, m, Nrank, Pnm, dPnm, pinm, taunm)
    if (m == 0) then
      do k = 1, Nrank
        n  = k
        nr = real(n * (n + 1),O)
        nm = 1._O / sqrt(2._O * nr)
        ft = taunm(n) * nm
        fl = nr * Pnm(n) * nm
        MV(1,k) =   zero
        MV(2,k) =   zero
        MV(3,k) = - jh(n)  * ft
        NV(1,k) =   jh(n)  * fl / zc
        NV(2,k) =   jhd(n) * ft / zc
        NV(3,k) =   zero
      end do
    else
      N0 = Nrank + (m - 1) * (2 * Nrank - m + 2)
      ml = m
      if (.not. plus) ml = - m
      do l = 1, 2
        mlr = real(ml,O)
        if (sym) then
          fact = one
        else
          arg  = mlr * phi
          fact = exp(im * arg)
        end if
        do k = 1, Nrank - m + 1
          n     = m + k - 1
          nr    = real(n * (n + 1),O)
          nm    = 1._O / sqrt(2._O * nr)
          factp = im * mlr * pinm(n) * nm * fact
          factt = taunm(n) * nm * fact
          factl = nr * Pnm(n) * nm * fact
          MV(1,N0+k) =   zero
          MV(2,N0+k) =   jh(n)  * factp
          MV(3,N0+k) = - jh(n)  * factt
          NV(1,N0+k) =   jh(n)  * factl / zc
          NV(2,N0+k) =   jhd(n) * factt / zc
          NV(3,N0+k) =   jhd(n) * factp / zc
        end do
        N0 =   N0 + Nrank - m + 1
        ml = - ml
      end do
    end if
  end do
  deallocate (jh, jhd)
  deallocate (Pnm, dPnm, pinm, taunm)
end subroutine MN_complete
!***********************************************************************************
subroutine MN_infinit_complete (theta, phi, Mrank, Nrank, Nmax, plus, Minf, Ninf)
!-----------------------------------------------------------------------------------
! The routine computes the localized vector spherical wave functions at infinity   !
! (excepting the factor exp(j*k*R)/(k*R)) for the azimuthal modes                  !
!  m = 0,1,...,Mrank.                                                              !
!                                                                                !
! Input parameters:                                                                !
! - theta, phi (real variables) - polar angles.                                    !
! - Mrank (integer) - number of azimuthal modes.                                   !
! - Nrank (integer) - maximum expansion order.                                     !
! - Nmax (integer) - specifies the dimension of the vectors.                       !
! - plus (logical) - if plus = true the vector functiosn are computed for the      !
!   azimuthal modes m = 0,+1,-1,...,+Mrank,-Mrank. If plus = false, the vector     !
!   functions are computed for the azimuthal modes m = 0,-1,+1,...,-Mrank,+Mrank.  !
!                                                                                !
! Output parameters:                                                               !
! - Minf, Ninf (complex arrays) - vector spherical wave functions.                 !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: Mrank, Nrank, Nmax
  real(O)    :: theta, phi
  complex(O) :: Minf(3,Nmax), Ninf(3,Nmax)
  logical    :: plus
!
  integer    :: k, m, l, ml, N0, n
  real(O)    :: nm, mlr, arg
  complex(O) :: fact, factc, factt, factp
  real(O),allocatable :: Pnm(:), dPnm(:), pinm(:), taunm(:)
!
  allocate (Pnm(0:Nrank), dPnm(0:Nrank), pinm(0:Nrank), taunm(0:Nrank))
  do m = 0, Mrank
    call leg_normalized (theta, m, Nrank, Pnm, dPnm, pinm, taunm)
    if (m == 0) then
      do k = 1, Nrank
        n     = k
        nm    = real(2 * n * (n + 1),O)
        nm    = 1._O / sqrt(nm)
        factc = (-im)**(n + 1) * nm
        factt = factc * taunm(n)
        Minf(1,k) =   zero
        Minf(2,k) =   zero
        Minf(3,k) = - factt
        Ninf(1,k) =   zero
        Ninf(2,k) =   im * factt
        Ninf(3,k) =   zero
      end do
    else
      N0 = Nrank + (m - 1) * (2 * Nrank - m + 2)
      ml = m
      if (.not. plus) ml = - m
      do l = 1, 2
        mlr  = real(ml,O)
        arg  = mlr * phi
        fact = exp(im * arg)
        do k = 1, Nrank - m + 1
          n     = m + k - 1
          nm    = real(2 * n * (n + 1),O)
          nm    = 1._O / sqrt(nm)
          factc = fact * (-im)**(n + 1) * nm
          factp = factc * mlr * pinm(n)
          factt = factc * taunm(n)
          Minf(1,N0+k) =   zero
          Minf(2,N0+k) =   im * factp
          Minf(3,N0+k) = - factt
          Ninf(1,N0+k) =   zero
          Ninf(2,N0+k) =   im * factt
          Ninf(3,N0+k) = - factp
        end do
        N0 =   N0 + Nrank - m + 1
        ml = - ml
      end do
    end if
  end do
  deallocate (Pnm, dPnm, pinm, taunm)
end subroutine  MN_infinit_complete
!***********************************************************************************
subroutine MN_infinit_reflection_complete (wavenumber, z0, ind_ref, theta, phi,     &
           Mrank, Nrank, Nmax, Minf, Ninf)
!-----------------------------------------------------------------------------------
! The routine computes the reflected localized vector spherical wave functions     !
! at infinity (excepting the factor exp(j*k*R)/(k*R)) and the azimuthal modes      !
! m = 0,+1,-1,...,+Mrank,-Mrank.                                                   !
!                                                                                !
! Input parameters:                                                                !
! - wavenumber (real) - wave number in the ambient medium.                         !
! - z0 (real) - axial coordinate of the substrate.                                 !
! - ind_ref (complex) - relative refractive index of the substrate.                !
! - theta, phi (real variables) - polar angles.                                    !
! - Mrank (integer) - number of azimuthal modes.                                   !
! - Nrank (integer) - maximum expansion order.                                     !
! - Nmax (integer) - specifies the dimension of the vectors.                       !
!                                                                                !
! Output parameters:                                                               !
! - Minf, Ninf (complex arrays) - vector spherical wave functions.                 !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: Mrank, Nrank, Nmax, k, m, N0, ml, l, n
  real(O)    :: theta, theta0, phi, wavenumber, z0, arga, mlr, nm
  complex(O) :: ind_ref, Rpar, Rperp, Tpar, Tperp, cost, sint, cost0, fact,         &
                facta, factr, factc, factt, factp, arg, Minf(3,Nmax), Ninf(3,Nmax)
  real(O),allocatable :: Pnm(:), dPnm(:), pinm(:), taunm(:)
!
  allocate (Pnm(0:Nrank), dPnm(0:Nrank), pinm(0:Nrank), taunm(0:Nrank))
  theta0 = Pi - theta
  cost0 = cmplx(cos(theta0),0.0,O)
  call Fresnel_aer_sub (cost0, ind_ref, Rpar, Rperp, Tpar, Tperp, cost, sint)
  arg   = 2._O * cost0 * wavenumber * z0
  factr = exp(im * arg)
  do m = 0, Mrank
    call leg_normalized (theta0, m, Nrank, Pnm, dPnm, pinm, taunm)
    if (m == 0) then
      do k = 1, Nrank
        n     = k
        nm    = real(2 * n * (n + 1),O)
        nm    = 1._O / sqrt(nm)
        factc = factr * (-im)**(n + 1) * nm
        factt = factc * taunm(n)
        Minf(1,k) =   zero
        Minf(2,k) =   zero
        Minf(3,k) = - factt * Rperp
        Ninf(1,k) =   zero
        Ninf(2,k) =   im * factt * Rpar
        Ninf(3,k) =   zero
      end do
    else
      N0 = Nrank + (m - 1) * (2 * Nrank - m + 2)
      ml = m
      do l = 1, 2
        mlr   = real(ml,O)
        arga  = mlr * phi
        facta = exp(im * arga)
        fact  = facta * factr
        do k = 1, Nrank - m + 1
          n     = m + k - 1
          nm    = real(2 * n * (n + 1),O)
          nm    = 1._O / sqrt(nm)
          factc = fact * (-im)**(n + 1) * nm
          factp = factc * mlr * pinm(n)
          factt = factc * taunm(n)
          Minf(1,N0+k) =   zero
          Minf(2,N0+k) =   im * factp * Rpar
          Minf(3,N0+k) = - factt * Rperp
          Ninf(1,N0+k) =   zero
          Ninf(2,N0+k) =   im * factt * Rpar
          Ninf(3,N0+k) = - factp * Rperp
        end do
        N0 =   N0 + Nrank - m + 1
        ml = - ml
      end do
    end if
  end do
  deallocate (Pnm, dPnm, pinm, taunm)
end subroutine MN_infinit_reflection_complete
!***********************************************************************************
subroutine MN_left_right (Nmax, mvl, nvl, mvr, nvr, mv, nv)
  use parameters
  implicit none
  integer    :: Nmax, i, j
  complex(O) :: mvl(3,Nmax), nvl(3,Nmax), mvr(3,Nmax), nvr(3,Nmax), mv(3,Nmax),     &
                nv(3,Nmax)
!
  do i = 1, 3
    do j = 1, Nmax
      mv(i,j) = mvl(i,j) + nvl(i,j)
      nv(i,j) = mvr(i,j) - nvr(i,j)
    end do
  end do
end subroutine MN_left_right
!***********************************************************************************
subroutine MN_anisotrop (k1, ind_ref, ind_refZ, rBIG, thetaBIG, phiBIG, alphaP,    &
           betaP, gammaP, Mrank, Nrank, Nmax, Nbeta, Xe, Ye, Xh, Yh)
!-----------------------------------------------------------------------------------
! The routine computes the system of vector wave functions (vector quasispherical  !
! wave functions) for uniaxial anisotropic particles.                              !
!                                                                                !
! Input parameters:                                                                !
! - k1 (complex) - wave number.                                                    !
! - ind_ref, ind_refZ (complex variables) - relative refractive indices of the     !
!   uniaxial anisotropic particle.                                                 !
! - rBIG, thetaBIG, phiBIG (real avriables) - spherical coordinates of the         !
!   generic point in the particle coordinate system.                               !
! - alphaP, betaP, gammaP (real variables) - Euler angles specifying the           !
!   orientation of the principal coordinate system with respect to the particle    !
!   coordinate system.                                                             !
! - Mrank (integer) - number of azimuthal modes.                                   !
! - Nrank (integer) - maximum expansion order.                                     !
! - Nmax (integer) - specifies the dimension of the vectors.                       !
! - Nbeta (integer) - number of integration points.                                !
!                                                                                !
! Output parameters:                                                               !
! - Xe, Ye, Xh, Yh (complex arrays) - vector wave functions for the uniaxial       !
!   anisotropic particle.                                                          !
!-----------------------------------------------------------------------------------
  use parameters
  use derived_parameters
  implicit none
  integer    :: Mrank, Nrank, Nmax, Nbeta
  real(O)    :: rBIG, thetaBIG, phiBIG, alphaP, betaP, gammaP
  complex(O) :: k1, ind_ref, ind_refZ, Xe(3,Nmax), Ye(3,Nmax), Xh(3,Nmax), Yh(3,Nmax)
!
  integer    :: i, k, p, m, n, N0, ml, l
  real(O)    :: xBIG, yBIG, zBIG, x, y, z, r, theta, phi, abeta, bbeta, beta, fact, &
                Pi2, ct, st, cp, sp, cth, sth, cph, sph, cb, sb, nm, mr, mrp, mrm,  &
                arg, argp, argm, s, mlr, stcp, stsp, sthcph, sthsph, cthcph, cthsph
  complex(O) :: f1, f2, x1, x2, y1, y2, fcp, fsp, f1s, ex1, ex2, f12p, f12m, o1, o2,&
                s1, c1, s2, c2, ft, fp, fJ1, fJ2, fJ1p, fJ1m, fJ2p, fJ2m, Imx1,     &
                Imx2, ImCx1, ImCx2, ImSx1, ImSx2, Xe1, Xe2, Xe3, Ye1, Ye2, Ye3,     &
                Xh1, Xh2, Xh3, Yh1, Yh2, Yh3, ind_refZc, ind_ref2, ind_refZ2,       &
                k1rsth, k1rcth, Pi2im, Piimp, Piimm
  real(O),allocatable    :: Pnm(:), dPnm(:), pinm(:), taunm(:), xbeta(:), wbeta(:)
  complex(O),allocatable :: J1(:), J2(:)
!
  Pi2  = 2._O * Pi
  ct   = cos(thetaBIG)
  st   = sin(thetaBIG)
  cp   = cos(phiBIG)
  sp   = sin(phiBIG)
  stcp = st * cp
  stsp = st * sp
  xBIG = rBIG * stcp
  yBIG = rBIG * stsp
  zBIG = rBIG * ct
  call T_cartesian_global_local (xBIG, yBIG, zBIG, alphaP, betaP, gammaP, x, y, z)
  call T_cartesian_spherical (x, y, z, r, theta, phi)
  cth = cos(theta)
  sth = sin(theta)
  cph = cos(phi)
  sph = sin(phi)
  sthcph = sth * cph
  sthsph = sth * sph
  cthcph = cth * cph
  cthsph = cth * sph
  fcp = Pi2 * im * cph
  fsp = Pi2 * im * sph
  k1rsth = k1 * r * sth
  k1rcth = k1 * r * cth
  do i = 1, 3
    do k = 1, Nmax
      Xe(i,k) = zero
      Ye(i,k) = zero
      Xh(i,k) = zero
      Yh(i,k) = zero
    end do
  end do
  allocate (xbeta(Nbeta), wbeta(Nbeta))
  abeta = 0._O
  bbeta = Pi
  call Gauss_Legendre (abeta, bbeta, Nbeta, wbeta, xbeta)
  allocate (J1(0:Mrank+1), J2(0:Mrank+1))
  allocate (Pnm(0:Nrank), dPnm(0:Nrank), pinm(0:Nrank), taunm(0:Nrank))
  ind_refZc = ind_refZ
  if (abs(ind_refZc) < MachEps) ind_refZc = cmplx(MachEps,MachEps,O)
  ind_ref2  = ind_ref * ind_ref
  ind_refZ2 = ind_refZc * ind_refZc
  do p = 1, Nbeta
    beta = xbeta(p)
    cb   = cos(beta)
    sb   = sin(beta)
    f1   = (ind_refZ2 * cb**2 + ind_ref2 * sb**2) / ind_refZ2
    f2   = (ind_refZ2 - ind_ref2) * sb * cb / ind_refZ2
    f1s  = sqrt(f1)
    x1   = k1rsth * sb
    x2   = x1 / f1s
    y1   = k1rcth * cb
    y2   = y1 / f1s
    ex1  = exp(im * y1)
    ex2  = exp(im * y2)
    f12p =   f1 * cb + f2 * sb
    f12m = - f1 * sb + f2 * cb
    call bes_J (x1, Mrank + 1, J1)
    call bes_J (x2, Mrank + 1, J2)
    fact = - wbeta(p) * sb / 4._O / Pi
    do m = 0, Mrank
      if (m == 0) then
        call Leg_normalized (beta, m, Nrank, Pnm, dPnm, pinm, taunm)
        Imx1  = Pi2 * J1(0)
        Imx2  = Pi2 * J2(0)
        ImCx1 = fcp * J1(1)
        ImCx2 = fcp * J2(1)
        ImSx1 = fsp * J1(1)
        ImSx2 = fsp * J2(1)
        o1 = Imx1  * ex1
        o2 = Imx2  * ex2
        s1 = ImSx1 * ex1
        c1 = ImCx1 * ex1
        s2 = ImSx2 * ex2
        c2 = ImCx2 * ex2
        do k = 1, Nrank
          n   = k
          nm  = real(2 * n * (n + 1),O)
          nm  = 1._O / sqrt(nm)
          ft  = taunm(n) * nm * (-im)**(n + 1) * fact
          f1  = im * ft
          Xe1 = - f1 * s1
          Xe2 =   f1 * c1
          Xe3 =   zero
          Xe(1,k) = Xe(1,k) + Xe1
          Xe(2,k) = Xe(2,k) + Xe2
          Xe(3,k) = Xe(3,k) + Xe3
!
          f2  = f12p * ft
          Ye1 = f2   * c2
          Ye2 = f2   * s2
          Ye3 = f12m * ft * o2
          Ye(1,k) = Ye(1,k) + Ye1
          Ye(2,k) = Ye(2,k) + Ye2
          Ye(3,k) = Ye(3,k) + Ye3
!
          f1  =   ft * cb
          Xh1 =   f1 * c1
          Xh2 =   f1 * s1
          Xh3 = - ft * sb * o1
          Xh(1,k) = Xh(1,k) + Xh1
          Xh(2,k) = Xh(2,k) + Xh2
          Xh(3,k) = Xh(3,k) + Xh3
!
          f2  =   f1s * im * ft
          Yh1 = - f2 * s2
          Yh2 =   f2 * c2
          Yh3 =   zero
          Yh(1,k) = Yh(1,k) + Yh1
          Yh(2,k) = Yh(2,k) + Yh2
          Yh(3,k) = Yh(3,k) + Yh3
        end do
      else
        N0    = Nrank + (m - 1) * (2 * Nrank - m + 2)
        mr    = real(m,O)
        mrp   = real(m + 1,O)
        mrm   = real(m - 1,O)
        arg   = mr  * phi
        argp  = mrp * phi
        argm  = mrm * phi
        Pi2im = Pi2 * im**m
        Piimp = Pi  * im**(m + 1)
        Piimm = Pi  * im**(m - 1)
        call Leg_normalized (beta, m, Nrank, Pnm, dPnm, pinm, taunm)
        ml = m
        s  = 1._O
        do l = 1, 2
          mlr   = real(ml,O)
          f1    = exp(s * im * arg)
          fJ1   = f1 * J1(m)
          fJ2   = f1 * J2(m)
          f1    = exp(s * im * argp)
          fJ1p  = f1 * J1(m+1)
          fJ2p  = f1 * J2(m+1)
          f1    = exp(s * im * argm)
          fJ1m  = f1 * J1(m-1)
          fJ2m  = f1 * J2(m-1)
          f1    = Pi2im
          Imx1  = f1 * fJ1
          Imx2  = f1 * fJ2
          f1    = Piimp * fJ1p
          f2    = Piimm * fJ1m
          ImCx1 =   f1 + f2
          ImSx1 = - im * (s * f1 - s * f2)
          f1    = Piimp * fJ2p
          f2    = Piimm * fJ2m
          ImCx2 = f1 + f2
          ImSx2 = - im * (s * f1 - s * f2)
          o1 = Imx1  * ex1
          o2 = Imx2  * ex2
          s1 = ImSx1 * ex1
          c1 = ImCx1 * ex1
          s2 = ImSx2 * ex2
          c2 = ImCx2 * ex2
          do k = 1, Nrank - m + 1
            n   = m + k - 1
            nm  = real(2 * n * (n + 1),O)
            nm  = 1._O / sqrt(nm)
            fp  = mlr * pinm(n) * nm * (-im)**(n + 1) * fact
            ft  = taunm(n) * nm * (-im)**(n + 1) * fact
            f1  = im * ft
            f2  = f12p * fp
            Xe1 = - f1 * s1 + f2 * c2
            Xe2 =   f1 * c1 + f2 * s2
            Xe3 =   f12m * fp * o2
            Xe(1,k+N0) = Xe(1,k+N0) + Xe1
            Xe(2,k+N0) = Xe(2,k+N0) + Xe2
            Xe(3,k+N0) = Xe(3,k+N0) + Xe3
!
            f1  =   im * fp
            f2  =   f12p * ft
            Ye1 = - f1 * s1 + f2 * c2
            Ye2 =   f1 * c1 + f2 * s2
            Ye3 =   f12m * ft * o2
            Ye(1,k+N0) = Ye(1,k+N0) + Ye1
            Ye(2,k+N0) = Ye(2,k+N0) + Ye2
            Ye(3,k+N0) = Ye(3,k+N0) + Ye3
!
            f1  =   ft * cb
            f2  =   f1s * im * fp
            Xh1 =   f1 * c1 - f2 * s2
            Xh2 =   f1 * s1 + f2 * c2
            Xh3 = - ft * sb * o1
            Xh(1,k+N0) = Xh(1,k+N0) + Xh1
            Xh(2,k+N0) = Xh(2,k+N0) + Xh2
            Xh(3,k+N0) = Xh(3,k+N0) + Xh3
!
            f1  =   fp * cb
            f2  =   f1s * im * ft
            Yh1 =   f1 * c1 - f2 * s2
            Yh2 =   f1 * s1 + f2 * c2
            Yh3 = - fp * sb * o1
            Yh(1,k+N0) = Yh(1,k+N0) + Yh1
            Yh(2,k+N0) = Yh(2,k+N0) + Yh2
            Yh(3,k+N0) = Yh(3,k+N0) + Yh3
          end do
          N0 =   N0 + Nrank - m + 1
          ml = - m
          s  = - s
        end do
      end if
    end do
  end do
! --- pass to spherical coordinates ---
  do k = 1, Nmax
    Xe1 = Xe(1,k)
    Xe2 = Xe(2,k)
    Xe3 = Xe(3,k)
    Xe(1,k) =   Xe1 * sthcph + Xe2 * sthsph + Xe3 * cth
    Xe(2,k) =   Xe1 * cthcph + Xe2 * cthsph - Xe3 * sth
    Xe(3,k) = - Xe1 * sph    + Xe2 * cph
!
    Ye1 = Ye(1,k)
    Ye2 = Ye(2,k)
    Ye3 = Ye(3,k)
    Ye(1,k) =   Ye1 * sthcph + Ye2 * sthsph + Ye3 * cth
    Ye(2,k) =   Ye1 * cthcph + Ye2 * cthsph - Ye3 * sth
    Ye(3,k) = - Ye1 * sph    + Ye2 * cph
!
    Xh1 = Xh(1,k)
    Xh2 = Xh(2,k)
    Xh3 = Xh(3,k)
    Xh(1,k) =   Xh1 * sthcph + Xh2 * sthsph + Xh3 * cth
    Xh(2,k) =   Xh1 * cthcph + Xh2 * cthsph - Xh3 * sth
    Xh(3,k) = - Xh1 * sph    + Xh2 * cph
!
    Yh1 = Yh(1,k)
    Yh2 = Yh(2,k)
    Yh3 = Yh(3,k)
    Yh(1,k) =   Yh1 * sthcph + Yh2 * sthsph + Yh3 * cth
    Yh(2,k) =   Yh1 * cthcph + Yh2 * cthsph - Yh3 * sth
    Yh(3,k) = - Yh1 * sph    + Yh2 * cph
  end do
  deallocate (J1, J2, xbeta, wbeta)
  deallocate (Pnm, dPnm, pinm, taunm)
end subroutine MN_anisotrop
!***********************************************************************************
subroutine MN_m_anisotrop (k1, ind_ref, ind_refZ, rBIG, thetaBIG, phiBIG, alphaP,   &
           betaP, gammaP, m, Nrank, Nmax, Nbeta, Xe, Ye, Xh, Yh)

!-----------------------------------------------------------------------------------
! The routine computes the system of vector wave functions (vector quasispherical  !
! wave functions) for uniaxial anisotropic particles and the azimuthal mode m.     !
!                                                                                !
! Input parameters:                                                                !
! - k1 (complex) - wave number.                                                    !
! - ind_ref, ind_refZ (complex variables) - relative refractive indices of the     !
!   uniaxial anisotropic particle.                                                 !
! - rBIG, thetaBIG, phiBIG (real avriables) - spherical coordinates of the         !
!   generic point in the particle coordinate system.                               !
! - alphaP, betaP, gammaP (real variables) - Euler angles specifying the           !
!   orientation of the principal coordinate system with respect to the particle    !
!   coordinate system.                                                             !
! - m (integer) - azimuthal mode. m is postive or negative.                        !
! - Nrank (integer) - maximum expansion order.                                     !
! - Nmax (integer) - specifies the dimension of the vectors.                       !
! - Nbeta (integer) - number of integration points.                                !
!                                                                                !
! Output parameters:                                                               !
! - Xe, Ye, Xh, Yh (complex arrays) - vector wave functions for the uniaxial       !
!   anisotropic particle.                                                          !
!-----------------------------------------------------------------------------------
  use parameters
  use derived_parameters
  implicit none
  integer    :: m, Nrank, Nmax, Nbeta
  real(O)    :: rBIG, thetaBIG, phiBIG, alphaP, betaP, gammaP
  complex(O) :: k1, ind_ref, ind_refZ, Xe(3,Nmax), Ye(3,Nmax), Xh(3,Nmax), Yh(3,Nmax)
!
  integer    :: i, k, p, mabs, n
  real(O)    :: xBIG, yBIG, zBIG, x, y, z, r, theta, phi, abeta, bbeta, beta, fact, &
                Pi2, ct, st, cp, sp, cth, sth, cph, sph, cb, sb, nm, mr, mrp, mrm,  &
                arg, argp, argm, s, mlr, stcp, stsp, sthcph, sthsph, cthcph, cthsph
  complex(O) :: f1, f2, x1, x2, y1, y2, fcp, fsp, f1s, ex1, ex2, f12p, f12m, o1, o2,&
                s1, c1, s2, c2, ft, fp, fJ1, fJ2, fJ1p, fJ1m, fJ2p, fJ2m, Imx1,     &
                Imx2, ImCx1, ImCx2, ImSx1, ImSx2, Xe1, Xe2, Xe3, Ye1, Ye2, Ye3,     &
                Xh1, Xh2, Xh3, Yh1, Yh2, Yh3, ind_refZc, ind_ref2, ind_refZ2,       &
                k1rsth, k1rcth, Pi2im, Piimp, Piimm
  real(O),allocatable    :: Pnm(:), dPnm(:), pinm(:), taunm(:), xbeta(:), wbeta(:)
  complex(O),allocatable :: J1(:), J2(:)
!
  Pi2  = 2._O * Pi
  ct   = cos(thetaBIG)
  st   = sin(thetaBIG)
  cp   = cos(phiBIG)
  sp   = sin(phiBIG)
  stcp = st * cp
  stsp = st * sp
  xBIG = rBIG * stcp
  yBIG = rBIG * stsp
  zBIG = rBIG * ct
  call T_cartesian_global_local (xBIG, yBIG, zBIG, alphaP, betaP, gammaP, x, y, z)
  call T_cartesian_spherical (x, y, z, r, theta, phi)
  cth = cos(theta)
  sth = sin(theta)
  cph = cos(phi)
  sph = sin(phi)
  sthcph = sth * cph
  sthsph = sth * sph
  cthcph = cth * cph
  cthsph = cth * sph
  fcp = Pi2 * im * cph
  fsp = Pi2 * im * sph
  k1rsth = k1 * r * sth
  k1rcth = k1 * r * cth
  do i = 1, 3
    do k = 1, Nmax
      Xe(i,k) = zero
      Ye(i,k) = zero
      Xh(i,k) = zero
      Yh(i,k) = zero
    end do
  end do
  allocate (xbeta(Nbeta), wbeta(Nbeta))
  abeta = 0._O
  bbeta = Pi
  call Gauss_Legendre (abeta, bbeta, Nbeta, wbeta, xbeta)
  mabs  = abs(m)
  mr    = real(mabs,O)
  mrp   = real(mabs + 1,O)
  mrm   = real(mabs - 1,O)
  arg   = mr  * phi
  argp  = mrp * phi
  argm  = mrm * phi
  Pi2im = Pi2 * im**mabs
  Piimp = Pi  * im**(mabs + 1)
  Piimm = Pi  * im**(mabs - 1)
  allocate (J1(0:mabs+1), J2(0:mabs+1))
  allocate (Pnm(0:Nrank), dPnm(0:Nrank), pinm(0:Nrank), taunm(0:Nrank))
  ind_refZc = ind_refZ
  if (abs(ind_refZc) < MachEps) ind_refZc = cmplx(MachEps,MachEps,O)
  ind_ref2  = ind_ref * ind_ref
  ind_refZ2 = ind_refZc * ind_refZc
  do p = 1, Nbeta
    beta = xbeta(p)
    cb   = cos(beta)
    sb   = sin(beta)
    f1   = (ind_refZ2 * cb**2 + ind_ref2 * sb**2) / ind_refZ2
    f2   = (ind_refZ2 - ind_ref2) * sb * cb / ind_refZ2
    f1s  = sqrt(f1)
    x1   = k1rsth * sb
    x2   = x1 / f1s
    y1   = k1rcth * cb
    y2   = y1 / f1s
    ex1  = exp(im * y1)
    ex2  = exp(im * y2)
    f12p =   f1 * cb + f2 * sb
    f12m = - f1 * sb + f2 * cb
    call bes_J (x1, mabs + 1, J1)
    call bes_J (x2, mabs + 1, J2)
    fact = - wbeta(p) * sb / 4._O / Pi
    if (m == 0) then
      call Leg_normalized (beta, 0, Nrank, Pnm, dPnm, pinm, taunm)
      Imx1  = Pi2 * J1(0)
      Imx2  = Pi2 * J2(0)
      ImCx1 = fcp * J1(1)
      ImCx2 = fcp * J2(1)
      ImSx1 = fsp * J1(1)
      ImSx2 = fsp * J2(1)
      o1 = Imx1  * ex1
      o2 = Imx2  * ex2
      s1 = ImSx1 * ex1
      c1 = ImCx1 * ex1
      s2 = ImSx2 * ex2
      c2 = ImCx2 * ex2
      do k = 1, Nmax
        n   = k
        nm  = real(2 * n * (n + 1),O)
        nm  = 1._O / sqrt(nm)
        ft  = taunm(n) * nm * (-im)**(n + 1) * fact
        f1  = im * ft
        Xe1 = - f1 * s1
        Xe2 =   f1 * c1
        Xe3 =   zero
        Xe(1,k) = Xe(1,k) + Xe1
        Xe(2,k) = Xe(2,k) + Xe2
        Xe(3,k) = Xe(3,k) + Xe3
!
        f2  = f12p * ft
        Ye1 = f2   * c2
        Ye2 = f2   * s2
        Ye3 = f12m * ft * o2
        Ye(1,k) = Ye(1,k) + Ye1
        Ye(2,k) = Ye(2,k) + Ye2
        Ye(3,k) = Ye(3,k) + Ye3
!
        f1  =   ft * cb
        Xh1 =   f1 * c1
        Xh2 =   f1 * s1
        Xh3 = - ft * sb * o1
        Xh(1,k) = Xh(1,k) + Xh1
        Xh(2,k) = Xh(2,k) + Xh2
        Xh(3,k) = Xh(3,k) + Xh3
!
        f2  =   f1s * im * ft
        Yh1 = - f2 * s2
        Yh2 =   f2 * c2
        Yh3 =   zero
        Yh(1,k) = Yh(1,k) + Yh1
        Yh(2,k) = Yh(2,k) + Yh2
        Yh(3,k) = Yh(3,k) + Yh3
      end do
    else
      call Leg_normalized (beta, mabs, Nrank, Pnm, dPnm, pinm, taunm)
      if (m > 0) then
        s = 1._O
      else
        s = - 1._O
      end if
      mlr   = real(m,O)
      f1    = exp(s * im * arg)
      fJ1   = f1 * J1(mabs)
      fJ2   = f1 * J2(mabs)
      f1    = exp(s * im * argp)
      fJ1p  = f1 * J1(mabs+1)
      fJ2p  = f1 * J2(mabs+1)
      f1    = exp(s * im * argm)
      fJ1m  = f1 * J1(mabs-1)
      fJ2m  = f1 * J2(mabs-1)
      f1    = Pi2im
      Imx1  = f1 * fJ1
      Imx2  = f1 * fJ2
      f1    = Piimp * fJ1p
      f2    = Piimm * fJ1m
      ImCx1 =   f1 + f2
      ImSx1 = - im * (s * f1 - s * f2)
      f1    = Piimp * fJ2p
      f2    = Piimm * fJ2m
      ImCx2 = f1 + f2
      ImSx2 = - im * (s * f1 - s * f2)
      o1 = Imx1  * ex1
      o2 = Imx2  * ex2
      s1 = ImSx1 * ex1
      c1 = ImCx1 * ex1
      s2 = ImSx2 * ex2
      c2 = ImCx2 * ex2
      do k = 1, Nmax
        n   = mabs + k - 1
        nm  = real(2 * n * (n + 1),O)
        nm  = 1._O / sqrt(nm)
        fp  = mlr * pinm(n) * nm * (-im)**(n + 1) * fact
        ft  = taunm(n) * nm * (-im)**(n + 1) * fact
        f1  = im * ft
        f2  = f12p * fp
        Xe1 = - f1 * s1 + f2 * c2
        Xe2 =   f1 * c1 + f2 * s2
        Xe3 =   f12m * fp * o2
        Xe(1,k) = Xe(1,k) + Xe1
        Xe(2,k) = Xe(2,k) + Xe2
        Xe(3,k) = Xe(3,k) + Xe3
!
        f1  =   im * fp
        f2  =   f12p * ft
        Ye1 = - f1 * s1 + f2 * c2
        Ye2 =   f1 * c1 + f2 * s2
        Ye3 =   f12m * ft * o2
        Ye(1,k) = Ye(1,k) + Ye1
        Ye(2,k) = Ye(2,k) + Ye2
        Ye(3,k) = Ye(3,k) + Ye3
!
        f1  =   ft * cb
        f2  =   f1s * im * fp
        Xh1 =   f1 * c1 - f2 * s2
        Xh2 =   f1 * s1 + f2 * c2
        Xh3 = - ft * sb * o1
        Xh(1,k) = Xh(1,k) + Xh1
        Xh(2,k) = Xh(2,k) + Xh2
        Xh(3,k) = Xh(3,k) + Xh3
!
        f1  =   fp * cb
        f2  =   f1s * im * ft
        Yh1 =   f1 * c1 - f2 * s2
        Yh2 =   f1 * s1 + f2 * c2
        Yh3 = - fp * sb * o1
        Yh(1,k) = Yh(1,k) + Yh1
        Yh(2,k) = Yh(2,k) + Yh2
        Yh(3,k) = Yh(3,k) + Yh3
      end do
    end if
  end do
! --- pass to spherical coordinates ---
  do k = 1, Nmax
    Xe1 = Xe(1,k)
    Xe2 = Xe(2,k)
    Xe3 = Xe(3,k)
    Xe(1,k) =   Xe1 * sthcph + Xe2 * sthsph + Xe3 * cth
    Xe(2,k) =   Xe1 * cthcph + Xe2 * cthsph - Xe3 * sth
    Xe(3,k) = - Xe1 * sph    + Xe2 * cph
!
    Ye1 = Ye(1,k)
    Ye2 = Ye(2,k)
    Ye3 = Ye(3,k)
    Ye(1,k) =   Ye1 * sthcph + Ye2 * sthsph + Ye3 * cth
    Ye(2,k) =   Ye1 * cthcph + Ye2 * cthsph - Ye3 * sth
    Ye(3,k) = - Ye1 * sph    + Ye2 * cph
!
    Xh1 = Xh(1,k)
    Xh2 = Xh(2,k)
    Xh3 = Xh(3,k)
    Xh(1,k) =   Xh1 * sthcph + Xh2 * sthsph + Xh3 * cth
    Xh(2,k) =   Xh1 * cthcph + Xh2 * cthsph - Xh3 * sth
    Xh(3,k) = - Xh1 * sph    + Xh2 * cph
!
    Yh1 = Yh(1,k)
    Yh2 = Yh(2,k)
    Yh3 = Yh(3,k)
    Yh(1,k) =   Yh1 * sthcph + Yh2 * sthsph + Yh3 * cth
    Yh(2,k) =   Yh1 * cthcph + Yh2 * cthsph - Yh3 * sth
    Yh(3,k) = - Yh1 * sph    + Yh2 * cph
  end do
  deallocate (J1, J2, xbeta, wbeta)
  deallocate (Pnm, dPnm, pinm, taunm)
end subroutine MN_m_anisotrop


module eqcalc
  implicit none

  real, parameter   :: pi = 3.141592653589793238462643383279502884197

contains

!! Define kappa-shape profile
real function k(rho)  result(y)
  real, intent(in)  :: rho  !input
  y   = 1. !+ (rho**2.0) / 100.0
end function k

!! Define derivative of kappa-shape profile
real function dk(rho)  result(y)
  real, intent(in)  :: rho   !input
  y   = 0. !+ rho / 50.0
end function dk

!! Define heat deposition shape profile
real function exheat(rho)     result(y)
  real, intent(in)  :: rho !input
  y   = 1 - rho**2
end function exheat

!! int( rho*p(rho)*drho,rho)/rho
real function intexheat(rho)     result(y)
  real, intent(in)  :: rho !input
  y   = 0.5*(rho - 0.5*rho**3.0)
end function intexheat

!! Define the q-profile
real function qprof(rho,epsilon)     result(y)
  real, intent(in)  :: rho, epsilon !input
  y   = 10 * 2.1 * epsilon / (2 - 1.0*rho**2.0)
end function qprof

!! Define the viscosity profile
real function m(rho)     result(y)
  real, intent(in)  :: rho !input
  y   = 1
end function m

!! Define the derivative of the viscosity profile
real function dm(rho)    result(y)
  real, intent(in)  :: rho !input
  y   = 0
end function dm

!! Define the momentum input profile
real function f_m(rho)     result(y)
  real, intent(in)  :: rho !input
  real              :: a_div_sigma
  a_div_sigma   = 5.
  y   = exp( -0.5 * a_div_sigma**2.0 * rho**2.0)
end function f_m

!! Routine that calculates rho0 as a function of gamma
real function rho0(gamma,beta,drho,t_end) result(y)
  real, intent(in)  :: gamma, beta, drho, t_end
  real              :: rho
  real, dimension(2):: t_bucket, g_bucket
  integer           :: rho_idx

  !! Initialize from boundary conditions
  g_bucket(1)     =   0
  g_bucket(2)     =   -(gamma + gamma*beta*exheat(0.0))/(2*k(0.0))*drho
  t_bucket(1)     =   1
  t_bucket(2)     =   1
  rho_idx         =   3
  !! Loop through all nodes untill the temperature is negative
  do while (t_bucket(2) .gt. t_end)
    rho           = (rho_idx-1)*drho
    t_bucket(1)   = t_bucket(2)
    g_bucket(1)   = g_bucket(2)
    g_bucket(2)   = g_bucket(1) - 1/k(rho-drho) * ( gamma*t_bucket(1)**1.5 + &
                    gamma*beta*exheat(rho-drho) + dk(rho-drho)*g_bucket(1) + &
                    g_bucket(1)/(rho-drho))*drho
    t_bucket(2)   = t_bucket(1) + g_bucket(1)*drho
    rho_idx       = rho_idx + 1
  end do
  !! Return the final coordinate
  y             = rho
end function rho0

!! Routine that finds rho0(gamma_final)=1
real function gamma_final(beta,drho,t_end) result(y)
  real, intent(in)  :: beta, drho,t_end
  real, dimension(2):: gamma0, rhoarr

  !! Initialize two gamma guesses and calculate corresponding rho0
  gamma0        = (/ 1, 10 /)
  rhoarr(1)     = rho0(gamma0(1),beta,drho,t_end)
  rhoarr(2)     = rho0(gamma0(2),beta,drho,t_end)

  !! Go through Newton-Rhpason method to approximate root.
  do while (abs(rhoarr(2)-1) .gt. 1E-6)
    !! Abs as gamma > 0
    gamma0(1) = abs(gamma0(1) - (rhoarr(1) - 1) * (gamma0(2) - gamma0(1)) / (rhoarr(2) - rhoarr(1)))
    gamma0    = gamma0(2:1:-1)

    rhoarr(1)   = rho0(gamma0(2),beta,drho,t_end)
    rhoarr      = rhoarr(2:1:-1)
  end do
  ! Return final gamma
  y             = gamma0(2)
end function gamma_final

!! Returns t'(1)
real function dtdrhoa(gamma,beta,drho,t_end) result(y)
  real, intent(in)  :: gamma, beta, drho,t_end
  real              :: rho
  real, dimension(2):: t_bucket, g_bucket
  integer           :: rho_idx

  ! Initialize
  g_bucket(1)     =   0
  g_bucket(2)     =   -(gamma + beta*exheat(0.0))/(2*k(0.0))*drho
  t_bucket(1)     =   1
  t_bucket(2)     =   1
  rho_idx         =   3

  ! Loop over all nodes
  do while (t_bucket(2) .gt. t_end)
    rho           = (rho_idx-1)*drho
    t_bucket(1)   = t_bucket(2)
    g_bucket(1)   = g_bucket(2)
    g_bucket(2)   = g_bucket(1) - ( gamma*(t_bucket(1)**1.5 + &
                    beta*exheat(rho))/k(rho) + &
                    (1/rho + dk(rho)/k(rho))*g_bucket(1) )*drho
    t_bucket(2)   = t_bucket(1) + g_bucket(1)*drho
    rho_idx       = rho_idx + 1
  end do
  ! return final slope
  y = (t_bucket(2)-t_bucket(1))/drho
end function dtdrhoa

!! Routine that calculates p_edge as a function of beta_p
real function p_edge(betap,epsilon,drho,btheta_prof,bz_prof,n_nodes) result(y)
  real, intent(in)                    :: betap, epsilon, drho
  integer, intent(in)                 :: n_nodes
  real, dimension(n_nodes), intent(in):: btheta_prof, bz_prof
  real                                :: rho, dbtheta2drho, dbz2drho, dpdrho
  real, dimension(n_nodes)            :: p_prof
  integer                             :: rho_idx

  !! First two by hand
  p_prof(1)       = 1
  p_prof(2)       = 1

  !! Calculate the profile
  do rho_idx = 3, n_nodes
    rho             = (rho_idx-1)*drho
    dbtheta2drho    = (btheta_prof(rho_idx)**2.0 - btheta_prof(rho_idx-1)**2.0)/drho
    dbz2drho        = ( bz_prof(rho_idx)**2.0 - bz_prof(rho_idx-1)**2.0 ) / drho

    dpdrho          = -betap*(dbtheta2drho + dbz2drho/epsilon**2.0 + &
                      2.0*btheta_prof(rho_idx)**2.0/rho)
    p_prof(rho_idx) = p_prof(rho_idx-1) + dpdrho*drho
  end do
  !! return final pressure
  y             = p_prof(n_nodes)
end function p_edge

!! Routine that solves n_edge(betap) = 0 for betap
real function beta_p0(epsilon,drho,btheta_prof,bz_prof,n_nodes,p_inf) result(y)
  real, intent(in)        :: epsilon, drho, p_inf
  integer, intent(in)     :: n_nodes
  real, dimension(n_nodes), intent(in):: btheta_prof, bz_prof
  real, dimension(2)      :: betap_arr, p_edge_arr

  ! Make two guesses
  betap_arr     = (/ 1.0E-15, 1.0E-12  /)
  p_edge_arr(1) = p_edge(betap_arr(1),epsilon,drho,btheta_prof,bz_prof,n_nodes)
  p_edge_arr(2) = p_edge(betap_arr(2),epsilon,drho,btheta_prof,bz_prof,n_nodes)

  ! Newton Rhapson
  do while (abs(p_edge_arr(2)-p_inf) .gt. 1E-6)
    betap_arr(1)  = betap_arr(1) - ( p_edge_arr(1) - p_inf) * ( betap_arr(2) -&
                    betap_arr(1) ) / ( p_edge_arr(2) - p_edge_arr(1) + 1E-8 )
    betap_arr     = betap_arr(2:1:-1)

    p_edge_arr(1) = p_edge(betap_arr(2),epsilon,drho,btheta_prof,bz_prof,n_nodes)
    p_edge_arr    = p_edge_arr(2:1:-1)
  end do

  ! Return final beta
  y             =   betap_arr(2)
end function beta_p0

!! Routine that calculates v_end as a function of alpha
real function v_end(alpha,drho) result(y)
  real, intent(in)  :: alpha, drho
  real              :: rho, dhdrho
  real, dimension(:), allocatable :: v_arr, h_arr
  integer           :: rho_idx, n_nodes

  n_nodes = ceiling(1/drho)+1
  allocate ( v_arr(n_nodes) )
  allocate ( h_arr(n_nodes) )

  !! First two by hand
  h_arr(1)        = 0
  v_arr(1)        = 1
  h_arr(2)        = h_arr(1) - alpha*f_m(0.0)/2.0 * drho
  v_arr(2)        = v_arr(1) + h_arr(1) * drho

  !! Calculate the profile
  do rho_idx = 3, n_nodes
    rho             = (rho_idx-1)*drho
    dhdrho          = -( alpha*f_m(rho)/m(rho) + h_arr(rho_idx-1)/rho + dm(rho)/m(rho)*h_arr(rho_idx-1) )
    h_arr(rho_idx)  = h_arr(rho_idx-1) + dhdrho * drho
    v_arr(rho_idx)  = v_arr(rho_idx-1) + h_arr(rho_idx-1) * drho
  end do

  !! Return v_end
  y             = v_arr(n_nodes)
end function v_end

!! Routine that solves v_end(alpha) = val. for alpha
real function alpha_fin(drho,v_fin) result(y)
  real, intent(in)  :: drho, v_fin
  real, dimension(2):: alpha_arr, v_end_arr

  ! Make two guesses
  alpha_arr     = (/ 1.0E-1, 1.0E0  /)
  v_end_arr(1)  = v_end(alpha_arr(1),drho)
  v_end_arr(2)  = v_end(alpha_arr(2),drho)

  ! Newton Rhapson
  do while (abs(v_end_arr(2)-v_fin) .gt. 1E-6)
    alpha_arr(1)  = alpha_arr(1) - ( v_end_arr(1) - v_fin) * ( alpha_arr(2) -&
                    alpha_arr(1) ) / ( v_end_arr(2) - v_end_arr(1) )
    alpha_arr     = alpha_arr(2:1:-1)

    v_end_arr(1) = v_end(alpha_arr(2),drho)
    v_end_arr    = v_end_arr(2:1:-1)
  end do

  ! Return final beta
  y             =   alpha_arr(2)
end function alpha_fin

!! Calculates all profiles
subroutine all_profs(drho,n_nodes,t_prof,g_prof,beta,gamma,btheta_prof,p_prof,&
     betap,epsilon,bz_arr,rho_arr,b_flat,t_end,p_inf,alpha,v_arr,v_fin)
  real, intent(in)        :: drho, beta, gamma, epsilon, t_end, p_inf
  integer, intent(in)     :: n_nodes, b_flat
  real                    :: rho, betap, dbtheta2drho, dbz2drho, dpdrho, alpha, &
                             dhdrho, v_fin
  real, dimension(n_nodes):: t_prof, g_prof, btheta_prof, k_arr, &
                             p_prof, intexheat_arr, q_arr, rho_arr, bz_arr, &
                             v_arr, h_arr
  integer                 :: rho_idx

  !! Do first two steps by hand due to limits
  rho_idx         = 1
  t_prof(rho_idx) = 1
  g_prof(rho_idx) = 0
  rho_idx         = rho_idx + 1
  t_prof(rho_idx) = 1
  g_prof(rho_idx) = -(gamma + gamma*beta*exheat(0.0))/(2*k(0.0))*drho

  !! Loop over all nodes for t and t' profiles
  do rho_idx = 3, n_nodes
    rho             = (rho_idx-1)*drho
    g_prof(rho_idx) = g_prof(rho_idx-1) - 1/k(rho-drho) * ( gamma*t_prof(rho_idx-1)**1.5 + &
                      gamma*beta*exheat(rho-drho) + dk(rho-drho)*g_prof(rho_idx-1) + &
                      g_prof(rho_idx-1)/(rho-drho))*drho
    t_prof(rho_idx) = t_prof(rho_idx-1) + g_prof(rho_idx-1)*drho
  end do

  !! Calculate btheta profile
  !! Convert kappa and intexheat in array
  rho_idx         = 1
  do rho_idx = 1, n_nodes
    rho                   = (rho_idx-1)*drho
    rho_arr(rho_idx)      = rho
    k_arr(rho_idx)        = k(rho)
    intexheat_arr(rho_idx)= intexheat(rho)
    q_arr(rho_idx)        = qprof(rho, epsilon)
  end do
  btheta_prof   = (beta * gamma * intexheat_arr    + k_arr * g_prof          )/ &
                  (beta * gamma * intexheat(1.0)   + k(1.0)* g_prof(n_nodes) )

  !! Calculate the number density profile

  !! First two by hand
  p_prof(1)       = 1
  p_prof(2)       = 1

  !! make bz profile and adjust first few indices
  bz_arr          = q_arr * btheta_prof / rho_arr
  bz_arr(1)       = qprof(0.0,epsilon)    * ( btheta_prof(2) - btheta_prof(1) ) / drho
  bz_arr          = bz_arr*b_flat
  betap = beta_p0(epsilon,drho,btheta_prof,bz_arr,n_nodes,p_inf)

  !! The beginning is quite sensitive to noise, so we rewrite this as a linear slope

  !! Calculate the profile
  do rho_idx = 3, n_nodes
    rho             = (rho_idx-1)*drho
    dbtheta2drho    = (btheta_prof(rho_idx)**2.0 - btheta_prof(rho_idx-1)**2.0)/drho
    dbz2drho        = (bz_arr(rho_idx)**2.0  - bz_arr(rho_idx-1)**2.0)/drho
    dpdrho          = -betap*(dbtheta2drho  + dbz2drho/(epsilon**2.0) + &
                      2.0*btheta_prof(rho_idx)**2.0/rho)
    p_prof(rho_idx) = p_prof(rho_idx-1) + dpdrho*drho
  end do

  !! Calculate the velocity profile in the axial direction
  !! Find dimensionless constant alpha for given profile and v_end
  alpha = alpha_fin(drho,v_fin)

  !! Calculate profiles using forward Euler.
  !! First two by hand
  h_arr(1)        = 0
  v_arr(1)        = 1
  h_arr(2)        = h_arr(1) - alpha*f_m(0.0)/2.0 * drho
  v_arr(2)        = v_arr(1) + h_arr(1) * drho

  !! Calculate the profile
  do rho_idx = 3, n_nodes
    rho             = (rho_idx-1)*drho
    dhdrho          = -( alpha*f_m(rho)/m(rho) + h_arr(rho_idx-1)/rho + dm(rho)/m(rho)*h_arr(rho_idx-1) )
    h_arr(rho_idx)  = h_arr(rho_idx-1) + dhdrho * drho
    v_arr(rho_idx)  = v_arr(rho_idx-1) + h_arr(rho_idx-1) * drho
  end do

end subroutine all_profs

end module eqcalc

program eqcalc_2

  use eqcalc
  implicit none
  real              :: drho, beta, gamma,t1, betap, b_zval, t_end, p_inf
  real              :: eta0, a, Ip, kappa0, R0, T0, VL, mu0, epsilon, &
                       B1, p_tot, p0, eta_fac, ln_lambda, z_ion, mu_fac
  integer           :: b_flat
  real, dimension(:), allocatable  :: t_prof, g_prof, btheta_prof,rho_array, p_prof, bz_arr, rho_arr, v_arr
  real,dimension(:,:),allocatable  :: profile_j, profile_p, profile_ne, profile_f, profile_q, profile_t, profile_omega
  integer           :: n_nodes, write_idx
  real              :: v_fin, alpha, F0, mu_v, q0, F0_real, mu_v_real
  namelist /mackenbach_input/ ln_lambda, z_ion, drho, beta, t_end, p_inf, eta_fac, mu_fac, a, Ip, kappa0, R0, b_flat, v_fin, F0_real, mu_v_real, q0

  open(12,file='mackenbach_input')
  read(12,nml=mackenbach_input)
  write(*,nml=mackenbach_input)

  !! Declare main varibales
  !ln_lambda = 17.
  !z_ion   = 1.
  !drho    = 1E-5    ! step size in rho space
  !beta    = 0       ! fraction of non-ohmic heating
  !t_end   = 5e-2    ! Fraction of T0 at edge
  !p_inf   = 1e-3    ! Fraction of p0 at the edge
  gamma   = gamma_final(beta, drho, t_end) ! the value of dimless const. gamma
  t1      = abs(dtdrhoa(gamma,beta,drho,t_end)) ! t profile derivative at t1
  p_tot   = intexheat(1.0)

  !! Statement to check if t_profile gets ohmic heating (necessary for current constraint)
  IF ( beta .gt. abs( k(1.0)*t1/( gamma*p_tot ) ))  THEN
   write(*,*) 'Beta too large. Decrease beta.'
   stop
  end if

  !eta_fac = 100.
  !mu_fac  = 10.
!  eta0    = 28.05E-9 * (1.6022e-19)**1.5 * eta_fac ! Prefactor for spitzer conductivity
  eta0    = 1.03e-4 * z_ion * ln_lambda * (1.6022e-19)**1.5 * eta_fac
  !a       = 1.0       ! Minor radius
  !Ip      = 3E7       ! Total plasma current
  !kappa0  = 1E21      ! Heat diffusivity
  !R0      = 10.0      ! Major radius
  mu0     = 4*pi*1E-7 ! Vacuum permeability
  B1      = mu0*Ip/(2*pi*a) ! Strength of poloidal magnetic field at edge
  epsilon = a/R0      ! Minor over Major radius
  !b_flat  = 0         ! Parameter indiciting if the pressure will be calculated
                      ! consistently via the q profile (b_flat = 1),
                      ! or if one will assume a flat b_z profile (b_flat = 0).
  !v_fin   = 0.0       ! Edge value of velocity profile.
  F0      = mu_fac*F0_real    ! Total toroidal force (in Newtons/m3)
  mu_v    = mu_fac*mu_v_real      ! viscosity value at centre

  !! Allocate memory for profiles
  n_nodes = ceiling(1/drho)+1
  allocate ( t_prof(n_nodes) )
  allocate ( g_prof(n_nodes) )
  allocate ( btheta_prof(n_nodes) )
  allocate ( p_prof(n_nodes) )
  allocate ( rho_array(n_nodes) )
  allocate ( bz_arr(n_nodes) )
  allocate ( rho_arr(n_nodes) )
  allocate ( v_arr(n_nodes) )
  call all_profs(drho,n_nodes,t_prof,g_prof,beta,gamma,btheta_prof,p_prof,betap, &
                  epsilon,bz_arr,rho_arr,b_flat,t_end,p_inf,alpha,v_arr,v_fin)

  !! Calculate dimensionfull quantities
  T0 =  (eta0**0.4*gamma**0.4*Ip**0.8)/(a**0.8*kappa0**0.4*(2*pi)**0.8*(abs(beta*gamma*p_tot - k(1.0)*t1))**0.8)
  VL =  (2*2**0.2*eta0**0.4*gamma**0.4*kappa0**0.6*pi**1.2*R0*(abs(beta*gamma*p_tot - k(1.0)*t1))**0.2)/(a**0.8*Ip**0.2)
  p0 =  mu0*Ip**2.0/(8.0 * pi**2.0 * a**2.0 * betap )
  !q0      = 2.0     !! Centre value for q
  b_zval  = q0*B1*(btheta_prof(2) - btheta_prof(1))/epsilon/drho
            ! Value for const. magnetic field such that q(0) = q0

  !! Make to be written matrices
  allocate ( profile_j(2,n_nodes) )
  profile_j(1,:) = a*rho_arr
  profile_j(2,:) = VL*T0**(1.5)/(2.0*pi*R0*eta0)*t_prof**(1.5)

  allocate ( profile_p(2,n_nodes) )
  profile_p(1,:) = a*rho_arr
  profile_p(2,:) = p_prof*p0 + p_inf

  allocate ( profile_ne(2,n_nodes) )
  profile_ne(1,:) = a*rho_arr
  profile_ne(2,:) = p_prof/(2.0*t_prof) * p0/T0

  allocate ( profile_t(2,n_nodes) )
  profile_t(1,:) = a*rho_arr
  profile_t(2,:) = t_prof * T0 / (1.6022e-19) / 1e3

  allocate ( profile_f(2,n_nodes) )
  profile_f(1,:)  = a*rho_arr
  profile_f(2,:)  = B1*bz_arr/epsilon
  if ( b_flat  == 0 ) then
    profile_f(2,:) = (rho_arr+1)/(rho_arr+1) * b_zval
  end if

  allocate ( profile_q(2,n_nodes) )
  profile_q(1,:)  = a*rho_arr
  profile_q(2,:)  = rho_arr*bz_arr/(epsilon*R0*btheta_prof)
  if ( b_flat  == 0 ) then
    profile_q(2,:) = a*rho_arr*b_zval/(R0*btheta_prof*B1)
  end if

  allocate ( profile_omega(2,n_nodes) )
  profile_omega(1,:)  = a*rho_arr
  profile_omega(2,:)  = v_arr * ( F0 * a**2.0 /(mu_v * alpha) )
  print *, 'Core rotation (m/s) :', profile_omega(2,1)
  ! convert from m/s to krad/s
  profile_omega(2,:) = profile_omega(2,:) / R0 / 1e3

  !! Write output
  open (unit=1,file="profile_j",action="write",status="replace")
  do write_idx = 2, n_nodes-1
    write(1,*) profile_j(:,write_idx)
  end do
  close(unit=1)

  open (unit=2,file="profile_p",action="write",status="replace")
  do write_idx = 2, n_nodes-1
    write(2,*) profile_p(:,write_idx)
  end do
  close(unit=2)

  open (unit=3,file="profile_ne",action="write",status="replace")
  do write_idx = 2, n_nodes-1
    write(3,*) profile_ne(:,write_idx)
  end do
  close(unit=3)

  open (unit=4,file="profile_f",action="write",status="replace")
  do write_idx = 2, n_nodes-1
    write(4,*) profile_f(:,write_idx)
  end do
  close(unit=4)

  open (unit=5,file="profile_kappa",action="write",status="replace")
  do write_idx = 2, n_nodes-1
     write(5,*) a*rho_arr(write_idx), kappa0*k(rho_arr(write_idx))
  end do
  close(unit=5)

  open (unit=6,file="vloop",action="write",status="replace")
  write(6,*) VL
  close(unit=6)

  open (unit=7,file="profile_te",action="write",status="replace")
  do write_idx = 2, n_nodes-1
    write(7,*) profile_t(:,write_idx)
  end do
  close(unit=7)

  open (unit=8,file="profile_omega",action="write",status="replace")
  do write_idx = 2, n_nodes-1
    write(8,*) profile_omega(:,write_idx)
  end do
  close(unit=8)

  open (unit=9,file="profile_q",action="write",status="replace")
  do write_idx = 2, n_nodes-1
    write(9,*) profile_q(:,write_idx)
  end do
  close(unit=9)

  open (unit=10,file="profile_mu",action="write",status="replace")
  do write_idx = 2, n_nodes-1
     write(10,*) a*rho_arr(write_idx), mu_v*m(rho_arr(write_idx))
  end do
  close(unit=10)

  open (unit=11,file="profile_force",action="write",status="replace")
  do write_idx = 2, n_nodes-1
     write(11,*) a*rho_arr(write_idx), F0*f_m(rho_arr(write_idx))
  end do
  close(unit=11)

  deallocate(profile_j, profile_p, profile_ne, profile_f, profile_t,profile_omega)

  open (unit=13,file="Physical_params",action="write",status="replace")
  write(13,*) a
  write(13,*) R0
  write(13,*) T0
  write(13,*) mu_v
  write(13,*) mu0
  write(13,*) eta0
  write(13,*) p0
  write(13,*) VL
  write(13,*) ( F0 * a**2.0 /(mu_v * alpha) )
  write(13,*) b_zval

  close(unit=13)

  print *, "eta_fac = ", eta_fac
  print *, "kappat = ", kappa0/ 2.18122e+26
  print *, "amu = ", mu_v / 0.364831
  print *, "vloop = ", VL/2.18122e+06
  print *, "tcur = ", IP/795217.
  print *, "beam_v =", 1e5
  print *, "beam_rate = ", F0*8.595e21
  print *, "beam_dr = ", 0.2

  close(12)

end program eqcalc_2


    Program dggglm_example

!     DGGGLM Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use blas_interfaces, Only: dnrm2
      Use lapack_interfaces, Only: dggglm
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nb = 64, nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: rnorm
      Integer :: i, info, lda, ldb, lwork, m, n, p
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: a(:, :), b(:, :), d(:), work(:), x(:), &
        y(:)
!     .. Executable Statements ..
      Write (nout, *) 'DGGGLM Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) m, n, p
      lda = m
      ldb = m
      lwork = n + m + nb*(m+p)
      Allocate (a(lda,n), b(ldb,p), d(m), work(lwork), x(n), y(p))

!     Read A, B and D from data file

      Read (nin, *)(a(i,1:n), i=1, m)
      Read (nin, *)(b(i,1:p), i=1, m)
      Read (nin, *) d(1:m)

!     Solve the weighted least squares problem

!     minimize ||inv(B)*(d - A*x)|| (in the 2-norm)

      Call dggglm(m, n, p, a, lda, b, ldb, d, x, y, work, lwork, info)

!     Print least squares solution, x

      Write (nout, *) 'Weighted least squares solution'
      Write (nout, 100) x(1:n)

!     Print residual vector y = inv(B)*(d - A*x)

      Write (nout, *)
      Write (nout, *) 'Residual vector'
      Write (nout, 110) y(1:p)

!     Compute and print the square root of the residual sum of
!     squares

      rnorm = dnrm2(p, y, 1)

      Write (nout, *)
      Write (nout, *) 'Square root of the residual sum of squares'
      Write (nout, 110) rnorm

100   Format (1X, 7F11.4)
110   Format (3X, 1P, 7E11.2)
    End Program


   program wavedd

    use mpi

    implicit none

    integer :: error, nprocs, rank
    integer :: istatus(MPI_STATUS_SIZE)

    integer, parameter :: iprocs = 3, jprocs = 3
    integer, parameter :: isrc=14, jsrc=14
    real(8), parameter :: Lx=1000, Ly=1000, t=2
    real(8), parameter :: CFL=0.5, c=1
    real(8), parameter :: dx=0.1, dy=0.1

    integer :: i, j
    integer :: itable(-1:iprocs, -1:jprocs)
    integer :: irank, myranki, myrankj
    integer :: inext, jnext, iprev, jprev
    real(8), dimension(:,:), allocatable :: wn, wnm1, wnp1
    real(8), dimension(:), allocatable :: row1s, row2s, row1r, row2r
    integer :: isend1, isend2, jsend1, jsend2
    integer :: irecv1, irecv2, jrecv1, jrecv2
    integer :: ista, iend, jsta, jend
    real(8) :: tt
    integer, parameter :: nxlocal=Lx/dx, nylocal=Ly/dy
    integer, parameter :: nx=nxlocal+2, ny=nylocal+2
    real(8), parameter :: dt=CFL*dx/c
    ! MPI I/O
    ! integer(kind=MPI_OFFSET_KIND), parameter :: zero_off = 0
    ! integer, dimension(mpi_status_size) :: wstatus

    call mpi_init(error)
    call mpi_comm_size(MPI_COMM_WORLD,nprocs,error)
    call mpi_comm_rank(MPI_COMM_WORLD,rank,error)
    ! write(*,'("np = ",i2,2x,"id = ",i2)') nprocs,rank
    if (nprocs /= iprocs*jprocs) then
        write(*, *) 'ERROR, mpi_comm_size: ', nprocs
        stop
    endif

    ! Itable interface
    do j = -1, jprocs
        do i = -1, iprocs
            itable(i,j) = MPI_PROC_NULL
        enddo
    enddo
    irank = 0
    do i = 0, iprocs-1
        do j = 0, jprocs-1
            itable(i,j) = irank
            if (rank == irank) then
                myranki = i;
                myrankj = j
            endif
            irank = irank + 1
        enddo
    enddo
    jnext = itable(myranki, myrankj + 1)
    jprev = itable(myranki, myrankj - 1)
    inext = itable(myranki+1, myrankj)
    iprev = itable(myranki-1, myrankj)

    allocate(wn(nx,ny))
    allocate(wnp1(nx,ny))
    allocate(wnm1(nx,ny))
    allocate(row1s(ny))
    allocate(row2s(ny))
    allocate(row1r(ny))
    allocate(row2r(ny))

    ! Calculation of the wave equation
    wn=0
    wnp1=wn
    tt=0

    ! MPI I/O
    ! istart = myrank*nxlocal+1
    ! iend = (myrank + 1)*nxlocal
    ! create subarrays
    ! call mpi_type_create_subarray( 2, [iprocs*nxlocal,jprocs*nylocal], [iend-istart+1,jend-jstart+1], &
    !                           [istart,jstart], mpi_order_fortran, mpi_real, localarray, error )
    ! call mpi_type_commit( localarray, error )

do while (tt<t)
        if (myranki /= 0) then
            row1s=wnp1(2,:)
        endif
        if (myranki /= iprocs-1) then
            row2s=wnp1(nx-1,:)
        endif

        call mpi_isend(wnp1(:,ny-1), nx, MPI_REAL8, jnext, 1, MPI_COMM_WORLD, isend1, error)
        call mpi_isend(wnp1(:,2), nx, MPI_REAL8, jprev, 1, MPI_COMM_WORLD, isend2, error)
        call mpi_isend(row2s, ny, MPI_REAL8, inext, 1, MPI_COMM_WORLD, jsend1, error)
        call mpi_isend(row1s, ny, MPI_REAL8, iprev, 1, MPI_COMM_WORLD, jsend2, error)
        call mpi_irecv(wnp1(:,1), nx, MPI_REAL8, jprev, 1, MPI_COMM_WORLD, irecv1, error)
        call mpi_irecv(wnp1(:,ny), nx, MPI_REAL8, jnext, 1, MPI_COMM_WORLD, irecv2, error)
        call mpi_irecv(row1r, ny, MPI_REAL8, iprev, 1, MPI_COMM_WORLD, jrecv1, error)
        call mpi_irecv(row2r, ny, MPI_REAL8, inext, 1, MPI_COMM_WORLD, jrecv2, error)

        ista=3
        jsta=3
        iend=nx-2
        jend=ny-2
        if (myranki == 0) then
            ista=ista+1
        endif
        if (myranki == iprocs - 1) then
            iend=iend-1
        endif
        if (myrankj == 0) then
            jsta=jsta+1
        endif
        if (myrankj == jprocs - 1) then
            jend=jend-1
        endif
        wnm1=wn
        wn=wnp1
        do i=ista,iend
            do j=jsta,jend
                wnp1(i,j)=2*wn(i,j)-wnm1(i,j)+CFL*CFL*(wn(i+1,j)+wn(i,j+1)-4*wn(i,j)+wn(i-1,j)+wn(i,j-1))
                if (isrc == myranki*nxlocal+i-1 .and. jsrc == myrankj*nylocal+j-1) then
                    wnp1(i,j)=wnp1(i,j)+dt*dt*20*sin(30*3.14*tt/20)
                endif
            enddo
        enddo

        call mpi_wait(isend1, istatus, error)
        call mpi_wait(isend2, istatus, error)
        call mpi_wait(jsend1, istatus, error)
        call mpi_wait(jsend2, istatus, error)
        call mpi_wait(irecv1, istatus, error)
        call mpi_wait(irecv2, istatus, error)
        call mpi_wait(jrecv1, istatus, error)
        call mpi_wait(jrecv2, istatus, error)

        if (myranki /= 0) then
            wnp1(1,:) = row1r
        endif
        if (myranki /= iprocs-1) then
            wnp1(nx,:) = row2r
        endif

        ista=2
        jsta=2
        iend=nx-1
        jend=ny-1
        if (myranki == 0) then
            wn(ista,:)=0
            ista=ista+1
        endif
        if (myranki == iprocs - 1) then
            wn(iend,:)=0
            iend=iend-1
        endif
        if (myrankj == 0) then
            wn(:,jsta)=0
            jsta=jsta+1
        endif
        if (myrankj == jprocs - 1) then
            wn(:,jend)=0
            jend=jend-1
        endif

        wn(1,:)=wnp1(1,:)
        wn(nx,:)=wnp1(nx,:)
        wn(:,1)=wnp1(:,1)
        wn(:,ny)=wnp1(:,ny)

        i=ista
        do j=jsta,jend
            wnp1(i,j)=2*wn(i,j)-wnm1(i,j)+CFL*CFL*(wn(i+1,j)+wn(i,j+1)-4*wn(i,j)+wn(i-1,j)+wn(i,j-1))
            if (isrc == myranki*nxlocal+i-1 .and. jsrc == myrankj*nylocal+j-1) then
                wnp1(i,j)=wnp1(i,j)+dt*dt*20*sin(30*3.14*tt/20)
            endif
        enddo
        i=iend
        do j=jsta,jend
            wnp1(i,j)=2*wn(i,j)-wnm1(i,j)+CFL*CFL*(wn(i+1,j)+wn(i,j+1)-4*wn(i,j)+wn(i-1,j)+wn(i,j-1))
            if (isrc == myranki*nxlocal+i-1 .and. jsrc == myrankj*nylocal+j-1) then
                wnp1(i,j)=wnp1(i,j)+dt*dt*20*sin(30*3.14*tt/20)
            endif
        enddo
        j=jsta
        do i=ista,iend
            wnp1(i,j)=2*wn(i,j)-wnm1(i,j)+CFL*CFL*(wn(i+1,j)+wn(i,j+1)-4*wn(i,j)+wn(i-1,j)+wn(i,j-1))
            if (isrc == myranki*nxlocal+i-1 .and. jsrc == myrankj*nylocal+j-1) then
                wnp1(i,j)=wnp1(i,j)+dt*dt*20*sin(30*3.14*tt/20)
            endif
        enddo
        j=jend
        do i=ista,iend
            wnp1(i,j)=2*wn(i,j)-wnm1(i,j)+CFL*CFL*(wn(i+1,j)+wn(i,j+1)-4*wn(i,j)+wn(i-1,j)+wn(i,j-1))
            if (isrc == myranki*nxlocal+i-1 .and. jsrc == myrankj*nylocal+j-1) then
                wnp1(i,j)=wnp1(i,j)+dt*dt*20*sin(30*3.14*tt/20)
            endif
        enddo

        tt=tt+dt
    enddo

    ! MPI I/O
    ! write to file
    ! call mpi_file_open( mpi_comm_world, 'test.txt', IOR(MPI_mode_create,MPI_mode_wronly), &
    !              mpi_info_null, fileno, error )
    ! call mpi_file_set_view( fileno, zero_off, mpi_real, localarray, "native", mpi_info_null, error )
    ! call mpi_file_write_all( fileno, wn, (jend-jstart+1)*(iend-istart+1), MPI_real, wstatus, error )
    ! call mpi_file_close( fileno, error )

    ! Display and write the result
    !do irank=0, nprocs-1
    !    if (rank==irank) then
    !        write(*,*) "rank: ", rank
    !        write(*,*) wn(2:nx-1,2:ny-1)
    !
    !        open(unit = 1 , file = "wavedd.txt", position="append")
    !        write(1,*) wn(2:nx-1,2:ny-1)
    !        close(1)
    !    endif
    !    call mpi_barrier(MPI_COMM_WORLD, error)
    !enddo

    call mpi_finalize(error)
    end program wavedd