! **********************************************************************************
! *          ROUTINES FOR COMPUTING THE Q MATRIX AND THE INCIDENT MATRIX           *
! *                         AT AN INTEGRATION POINT                                *
! *    ------------------------------------------------------------------------    *
! *    Partial list of subroutines:                                                *
! *      matQ,        matQ_m,      matQ_COMP,     matQ_LAY,      matQ_LAY_a,       *
! *      matQ_LAY_b,  matQinc_m,   mvnv,          mvnv_m,        mvnvinc_m         *
! *    The routines for performing convergence tests are specified below.          *
! **********************************************************************************
subroutine matQ (NmaxC, NmaxL, chiral, perfectcond, ind_ref, fact, mv3, nv3,        &
           mv1, nv1, nuv, A, nap, map)
  use parameters
  implicit none
  integer    :: NmaxC, NmaxL, nap, map
  real(O)    :: nuv(3)
  complex(O) :: ind_ref, fact, mv1(3,NmaxC), nv1(3,NmaxC), mv3(3,NmaxL),            &
                nv3(3,NmaxL), A(2*nap,2*map)
  logical    :: chiral, perfectcond
!
  integer    :: i, j
  complex(O) :: mvl(3), nvl(3), mvc(3), nvc(3), v1, v2, mixt_product
!
  do i = 1, NmaxL
    mvl(1) = mv3(1,i)
    mvl(2) = mv3(2,i)
    mvl(3) = mv3(3,i)
    nvl(1) = nv3(1,i)
    nvl(2) = nv3(2,i)
    nvl(3) = nv3(3,i)
    do j = 1, NmaxC
      mvc(1) = mv1(1,j)
      mvc(2) = mv1(2,j)
      mvc(3) = mv1(3,j)
      nvc(1) = nv1(1,j)
      nvc(2) = nv1(2,j)
      nvc(3) = nv1(3,j)
      if (.not. chiral) then
        v1 = mixt_product (nuv, mvc, nvl)
        v2 = mixt_product (nuv, nvc, mvl)
        if (.not. perfectcond) then
          A(i,j) = A(i,j) + (v1 + ind_ref * v2) * fact
        else
          A(i,j) = A(i,j) + v2 * fact
        end if
      else
        v1 = mixt_product (nuv, mvc, nvl)
        v2 = mixt_product (nuv, mvc, mvl)
        A(i,j) = A(i,j) + (v1 + ind_ref * v2) * fact
      end if
      if (.not. chiral) then
        v1 = mixt_product (nuv, nvc, nvl)
        v2 = mixt_product (nuv, mvc, mvl)
        if (.not. perfectcond) then
          A(i,j+NmaxC) = A(i,j+NmaxC) + (v1 + ind_ref * v2) * fact
        else
          A(i,j+NmaxC) = A(i,j+NmaxC) + v2 * fact
        end if
      else
        v1 = mixt_product (nuv, nvc, nvl)
        v2 = mixt_product (nuv, nvc, mvl)
        A(i,j+NmaxC) = A(i,j+NmaxC) + (v1 - ind_ref * v2) * fact
      end if
      if (.not. chiral) then
        v1 = mixt_product (nuv, mvc, mvl)
        v2 = mixt_product (nuv, nvc, nvl)
        if (.not. perfectcond) then
          A(i+NmaxL,j) = A(i+NmaxL,j) + (v1 + ind_ref * v2) * fact
        else
          A(i+NmaxL,j) = A(i+NmaxL,j) + v2 * fact
        end if
      else
        v1 = mixt_product (nuv, mvc, mvl)
        v2 = mixt_product (nuv, mvc, nvl)
        A(i+NmaxL,j) = A(i+NmaxL,j) + (v1 + ind_ref * v2) * fact
      end if
      if (.not. chiral) then
        v1 = mixt_product (nuv, nvc, mvl)
        v2 = mixt_product (nuv, mvc, nvl)
        if (.not. perfectcond) then
          A(i+NmaxL,j+NmaxC) = A(i+NmaxL,j+NmaxC) + (v1 + ind_ref * v2) * fact
        else
          A(i+NmaxL,j+NmaxC) = A(i+NmaxL,j+NmaxC) + v2 * fact
        end if
      else
        v1 = mixt_product (nuv, nvc, mvl)
        v2 = mixt_product (nuv, nvc, nvl)
        A(i+NmaxL,j+NmaxC) = A(i+NmaxL,j+NmaxC) + (v1 - ind_ref * v2) * fact
      end if
    end do
  end do
end subroutine matQ
! **********************************************************************************
subroutine matQ_m (m, NmaxC, NmaxL, chiral, perfectcond, mirror, ind_ref, fact,     &
           mv3, nv3, mv1, nv1, nuv, A, nap, map)
  use parameters
  implicit none
  integer    :: m, NmaxC, NmaxL, nap, map
  real(O)    :: nuv(3)
  complex(O) :: ind_ref, fact, mv1(3,NmaxC), nv1(3,NmaxC), mv3(3,NmaxL),            &
                nv3(3,NmaxL), A(2*nap,2*map)
  logical    :: chiral, perfectcond, mirror
!
  integer    :: i, j, ni, nj
  real(O)    :: s
  complex(O) :: mvl(3), nvl(3), mvc(3), nvc(3), v1, v2, mixt_product
!
  do i = 1, NmaxL
    if (abs(m) == 0) then
      ni = i
    else
      ni = abs(m) + i - 1
    end if
    mvl(1) = mv3(1,i)
    mvl(2) = mv3(2,i)
    mvl(3) = mv3(3,i)
    nvl(1) = nv3(1,i)
    nvl(2) = nv3(2,i)
    nvl(3) = nv3(3,i)
    do j = 1, NmaxC
      if (abs(m) == 0) then
        nj = j
      else
        nj = abs(m) + j - 1
      end if
      mvc(1) = mv1(1,j)
      mvc(2) = mv1(2,j)
      mvc(3) = mv1(3,j)
      nvc(1) = nv1(1,j)
      nvc(2) = nv1(2,j)
      nvc(3) = nv1(3,j)
      s = (-1._O)**(ni + nj)
      if (.not. chiral) then
        v1 = mixt_product (nuv, mvc, nvl)
        v2 = mixt_product (nuv, nvc, mvl)
        if (.not. perfectcond) then
          A(i,j) = A(i,j) + (v1 + ind_ref * v2) * fact
          if (mirror) A(i,j) = A(i,j)+ s * (v1 + ind_ref * v2) * fact
        else
          A(i,j) = A(i,j) + v2 * fact
          if (mirror) A(i,j) = A(i,j) + s * v2 * fact
        end if
      else
        v1 = mixt_product (nuv, mvc, nvl)
        v2 = mixt_product (nuv, mvc, mvl)
        A(i,j) = A(i,j) + (v1 + ind_ref * v2) * fact
      end if
      if (.not. chiral) then
        if (m /= 0) then
          v1 = mixt_product (nuv, nvc, nvl)
          v2 = mixt_product (nuv, mvc, mvl)
          if (.not. perfectcond) then
            A(i,j+NmaxC) = A(i,j+NmaxC) + (v1 + ind_ref * v2) * fact
            if (mirror) A(i,j+NmaxC) = A(i,j+NmaxC) - s * (v1 + ind_ref * v2) * fact
          else
            A(i,j+NmaxC) = A(i,j+NmaxC) + v2 * fact
            if (mirror) A(i,j+NmaxC) = A(i,j+NmaxC) - s * v2 * fact
          end if
          v1 = mixt_product (nuv, mvc, mvl)
          v2 = mixt_product (nuv, nvc, nvl)
          if (.not. perfectcond) then
            A(i+NmaxL,j) = A(i+NmaxL,j) + (v1 + ind_ref * v2) * fact
            if (mirror) A(i+NmaxL,j) = A(i+NmaxL,j) - s * (v1 + ind_ref * v2) * fact
          else
            A(i+NmaxL,j) = A(i+NmaxL,j) + v2 * fact
            if (mirror) A(i+NmaxL,j) = A(i+NmaxL,j) - s * v2 * fact
          end if
        end if
      else
        v1 = mixt_product (nuv, nvc, nvl)
        v2 = mixt_product (nuv, nvc, mvl)
        A(i,j+NmaxC) = A(i,j+NmaxC) + (v1 - ind_ref * v2) * fact
        v1 = mixt_product (nuv, mvc, mvl)
        v2 = mixt_product (nuv, mvc, nvl)
        A(i+NmaxL,j) = A(i+NmaxL,j) + (v1 + ind_ref * v2) * fact
      end if
      if (.not. chiral) then
        v1 = mixt_product (nuv, nvc, mvl)
        v2 = mixt_product (nuv, mvc, nvl)
        if (.not. perfectcond) then
          A(i+NmaxL,j+NmaxC) = A(i+NmaxL,j+NmaxC) + (v1 + ind_ref * v2) * fact
          if (mirror) A(i+NmaxL,j+NmaxC) = A(i+NmaxL,j+NmaxC) +                     &
                                          s * (v1 + ind_ref * v2) * fact
        else
          A(i+NmaxL,j+NmaxC) = A(i+NmaxL,j+NmaxC) + v2 * fact
          if (mirror) A(i+NmaxL,j+NmaxC) = A(i+NmaxL,j+NmaxC) + s * v2 * fact
        end if
      else
        v1 = mixt_product (nuv, nvc, mvl)
        v2 = mixt_product (nuv, nvc, nvl)
        A(i+NmaxL,j+NmaxC) = A(i+NmaxL,j+NmaxC) + (v1 - ind_ref * v2) * fact
      end if
    end do
  end do
end subroutine matQ_m
! **********************************************************************************
subroutine matQ_COMP (m, NmaxC, NmaxL, ind_ref, fact, mv3, nv3, mv1, nv1, nuv,      &
           A, nap, map)
  use parameters
  implicit none
  integer    :: m, NmaxC, NmaxL, nap, map
  real(O)    :: nuv(3)
  complex(O) :: ind_ref, fact, mv1(3,NmaxC), nv1(3,NmaxC), mv3(3,NmaxL),            &
                nv3(3,NmaxL), A(2*nap,2*map)
!
  integer    :: i, j
  complex(O) :: mvl(3), nvl(3), mvc(3), nvc(3), v1, v2, mixt_product
!
  do i = 1, NmaxL
    mvl(1) = mv3(1,i)
    mvl(2) = mv3(2,i)
    mvl(3) = mv3(3,i)
    nvl(1) = nv3(1,i)
    nvl(2) = nv3(2,i)
    nvl(3) = nv3(3,i)
    do j = 1, NmaxC
      mvc(1) = mv1(1,j)
      mvc(2) = mv1(2,j)
      mvc(3) = mv1(3,j)
      nvc(1) = nv1(1,j)
      nvc(2) = nv1(2,j)
      nvc(3) = nv1(3,j)
      v1 = mixt_product (nuv, mvc, nvl)
      v2 = mixt_product (nuv, nvc, mvl)
      A(i,j) = A(i,j) + (v1 + ind_ref  *v2) * fact
      if (m /= 0) then
        v1 = mixt_product (nuv, nvc, nvl)
        v2 = mixt_product (nuv, mvc, mvl)
        A(i,j+NmaxC) = A(i,j+NmaxC) + (v1 + ind_ref * v2) * fact
        v1 = mixt_product (nuv, mvc, mvl)
        v2 = mixt_product (nuv, nvc, nvl)
        A(i+NmaxL,j) = A(i+NmaxL,j) + (v1 + ind_ref * v2) * fact
      end if
      v1 = mixt_product (nuv, nvc, mvl)
      v2 = mixt_product (nuv, mvc, nvl)
      A(i+NmaxL,j+NmaxC) = A(i+NmaxL,j+NmaxC) + (v1 + ind_ref * v2) * fact
    end do
  end do
end subroutine matQ_COMP
! **********************************************************************************
subroutine matQ_LAY (m, ipart, Npartlim, NmaxC, NmaxL, Nmax, index, fact, mv3, nv3, &
           mv2, nv2, mv1, nv1, nuv, a, nap, map, b, nbp, mbp)
  use parameters
  implicit none
  integer    :: m, ipart, Npartlim, NmaxC, NmaxL, Nmax, nap, map, nbp, mbp
  real(O)    :: nuv(3)
  complex(O) :: index, fact, mv1(3,Nmax), nv1(3,Nmax), mv2(3,Nmax),                 &
                nv2(3,Nmax), mv3(3,Nmax), nv3(3,Nmax), a(2*nap,2*map),              &
                b(2*nbp,2*mbp)
!
  integer    :: i, j
  complex(O) :: mvl(3), nvl(3), mvc(3), nvc(3), v1, v2, mixt_product
!
  do i = 1, NmaxL
    mvl(1) = mv3(1,i)
    mvl(2) = mv3(2,i)
    mvl(3) = mv3(3,i)
    nvl(1) = nv3(1,i)
    nvl(2) = nv3(2,i)
    nvl(3) = nv3(3,i)
    do j = 1, NmaxC
      mvc(1) = mv1(1,j)
      mvc(2) = mv1(2,j)
      mvc(3) = mv1(3,j)
      nvc(1) = nv1(1,j)
      nvc(2) = nv1(2,j)
      nvc(3) = nv1(3,j)
      v1 = mixt_product (nuv, mvc, nvl)
      v2 = mixt_product (nuv, nvc, mvl)
      a(i,j) = a(i,j) + (v1 + index * v2) * fact
      if (m /= 0) then
        v1 = mixt_product (nuv, nvc, nvl)
        v2 = mixt_product (nuv, mvc, mvl)
        a(i,j+NmaxC) = a(i,j+NmaxC) + (v1 + index * v2) * fact
        v1 = mixt_product (nuv, mvc, mvl)
        v2 = mixt_product (nuv, nvc, nvl)
        a(i+NmaxL,j) = a(i+NmaxL,j) + (v1 + index * v2) * fact
      end if
      v1 = mixt_product (nuv, nvc, mvl)
      v2 = mixt_product (nuv, mvc, nvl)
      a(i+NmaxL,j+NmaxC) = a(i+NmaxL,j+NmaxC) + (v1 + index * v2) * fact
    end do
    if (ipart < Npartlim) then
      do j = 1, NmaxC
        mvc(1) = mv2(1,j)
        mvc(2) = mv2(2,j)
        mvc(3) = mv2(3,j)
        nvc(1) = nv2(1,j)
        nvc(2) = nv2(2,j)
        nvc(3) = nv2(3,j)
        v1 = mixt_product (nuv, mvc, nvl)
        v2 = mixt_product (nuv, nvc, mvl)
        b(i,j) = b(i,j) + (v1 + index * v2) * fact
        if (m /= 0) then
          v1 = mixt_product (nuv, nvc, nvl)
          v2 = mixt_product (nuv, mvc, mvl)
          b(i,j+NmaxC) = b(i,j+NmaxC) + (v1 + index * v2) * fact
          v1 = mixt_product (nuv, mvc, mvl)
          v2 = mixt_product (nuv, nvc, nvl)
          b(i+NmaxL,j) = b(i+NmaxL,j) + (v1 + index * v2) * fact
        end if
        v1 = mixt_product (nuv, nvc, mvl)
        v2 = mixt_product (nuv, mvc, nvl)
        b(i+NmaxL,j+NmaxC) = b(i+NmaxL,j+NmaxC) + (v1 + index * v2) * fact
      end do
    end if
  end do
end subroutine matQ_LAY
! **********************************************************************************
subroutine matQ_LAY_a (m, NmaxC, NmaxL, Nmax, index, fact, mv3, nv3, mv1, nv1,      &
           nuv, a, nap, map)
  use parameters
  implicit none
  integer    :: m, NmaxC, NmaxL, Nmax, nap, map
  real(O)    :: nuv(3)
  complex(O) :: index, fact, mv1(3,Nmax), nv1(3,Nmax), mv3(3,Nmax), nv3(3,Nmax),    &
                a(2*nap,2*map)
!
  integer    :: i, j
  complex(O) :: mvl(3), nvl(3), mvc(3), nvc(3), v1, v2, mixt_product
!
  do i = 1, NmaxL
    mvl(1) = mv3(1,i)
    mvl(2) = mv3(2,i)
    mvl(3) = mv3(3,i)
    nvl(1) = nv3(1,i)
    nvl(2) = nv3(2,i)
    nvl(3) = nv3(3,i)
    do j = 1, NmaxC
      mvc(1) = mv1(1,j)
      mvc(2) = mv1(2,j)
      mvc(3) = mv1(3,j)
      nvc(1) = nv1(1,j)
      nvc(2) = nv1(2,j)
      nvc(3) = nv1(3,j)
      v1 = mixt_product (nuv, mvc, nvl)
      v2 = mixt_product (nuv, nvc, mvl)
      a(i,j) = a(i,j) + (v1 + index * v2) * fact
      if (m /= 0) then
        v1 = mixt_product (nuv, nvc, nvl)
        v2 = mixt_product (nuv, mvc, mvl)
        a(i,j+NmaxC) = a(i,j+NmaxC) + (v1 + index * v2) * fact
        v1 = mixt_product (nuv, mvc, mvl)
        v2 = mixt_product (nuv, nvc, nvl)
        a(i+NmaxL,j) = a(i+NmaxL,j) + (v1 + index * v2) * fact
      end if
      v1 = mixt_product (nuv, nvc, mvl)
      v2 = mixt_product (nuv, mvc, nvl)
      a(i+NmaxL,j+NmaxC) = a(i+NmaxL,j+NmaxC) + (v1 + index * v2) * fact
    end do
  end do
end subroutine matQ_LAY_a
! **********************************************************************************
subroutine matQ_LAY_b (m, ipart, Npartlim, NmaxC, NmaxL, Nmax, index, fact, mv3,    &
           nv3, mv2, nv2, nuv, b, nbp, mbp)
  use parameters
  implicit none
  integer    :: m, ipart, Npartlim, NmaxC, NmaxL, Nmax, nbp, mbp
  real(O)    :: nuv(3)
  complex(O) :: index, fact, mv2(3,Nmax), nv2(3,Nmax), mv3(3,Nmax), nv3(3,Nmax),    &
                b(2*nbp,2*mbp)
!
  integer    :: i, j
  complex(O) :: mvl(3), nvl(3), mvc(3), nvc(3), v1, v2, mixt_product
!
  do i = 1, NmaxL
    mvl(1) = mv3(1,i)
    mvl(2) = mv3(2,i)
    mvl(3) = mv3(3,i)
    nvl(1) = nv3(1,i)
    nvl(2) = nv3(2,i)
    nvl(3) = nv3(3,i)
    if (ipart < Npartlim) then
      do j = 1, NmaxC
        mvc(1) = mv2(1,j)
        mvc(2) = mv2(2,j)
        mvc(3) = mv2(3,j)
        nvc(1) = nv2(1,j)
        nvc(2) = nv2(2,j)
        nvc(3) = nv2(3,j)
        v1 = mixt_product (nuv, mvc, nvl)
        v2 = mixt_product (nuv, nvc, mvl)
        b(i,j) = b(i,j) + (v1 + index * v2) * fact
        if (m /= 0) then
          v1 = mixt_product (nuv, nvc, nvl)
          v2 = mixt_product (nuv, mvc, mvl)
          b(i,j+NmaxC) = b(i,j+NmaxC) + (v1 + index * v2) * fact
          v1 = mixt_product (nuv, mvc, mvl)
          v2 = mixt_product (nuv, nvc, nvl)
          b(i+NmaxL,j) = b(i+NmaxL,j) + (v1 + index * v2) * fact
        end if
        v1 = mixt_product (nuv, nvc, mvl)
        v2 = mixt_product (nuv, mvc, nvl)
        b(i+NmaxL,j+NmaxC) = b(i+NmaxL,j+NmaxC) + (v1 + index * v2) * fact
      end do
    end if
  end do
end subroutine matQ_LAY_b
!***********************************************************************************
subroutine matQinc_m (m, NmaxC, NmaxL, fact, mv3, nv3, mv1, nv1, nuv, A, nap, map)
  use parameters
  implicit none
  integer    :: m, NmaxL, NmaxC, nap, map
  real(O)    :: nuv(3)
  complex(O) :: fact, mv1(3,NmaxC), nv1(3,NmaxC), mv3(3,NmaxL), nv3(3,NmaxL),       &
                A(2*nap,2*map)
!
  integer    :: i, j
  complex(O) :: mvl(3), nvl(3), mvc(3), nvc(3), v1, v2, mixt_product
!
  do i = 1, NmaxL
    mvl(1) = mv3(1,i)
    mvl(2) = mv3(2,i)
    mvl(3) = mv3(3,i)
    nvl(1) = nv3(1,i)
    nvl(2) = nv3(2,i)
    nvl(3) = nv3(3,i)
    do j = 1, NmaxC
      mvc(1) = mv1(1,j)
      mvc(2) = mv1(2,j)
      mvc(3) = mv1(3,j)
      nvc(1) = nv1(1,j)
      nvc(2) = nv1(2,j)
      nvc(3) = nv1(3,j)
      v1 = mixt_product (nuv, mvc, nvl)
      v2 = mixt_product (nuv, nvc, mvl)
      A(i,j) = A(i,j) + (v1 + v2) * fact
      if (m /= 0) then
        v1 = mixt_product (nuv, nvc, nvl)
        v2 = mixt_product (nuv, mvc, mvl)
        A(i,j+NmaxC) = A(i,j+NmaxC) + (v1 + v2) * fact
        v1 = mixt_product (nuv, mvc, mvl)
        v2 = mixt_product (nuv, nvc, nvl)
        A(i+NmaxL,j) = A(i+NmaxL,j) + (v1 + v2) * fact
      end if
      v1 = mixt_product (nuv, nvc, mvl)
      v2 = mixt_product (nuv, mvc, nvl)
      A(i+NmaxL,j+NmaxC) = A(i+NmaxL,j+NmaxC) + (v1 + v2) * fact
    end do
  end do
end subroutine matQinc_m
! ***********************************************************************************
! *     THE FOLLOWING ROUTINES ARE IMPORTANT FOR THE SPEED AND FLEXIBILITY          *
! *     OF THE PROGRAMS. WE SACRIFICE THE SPEED IN FAVOUR OF THE FLEXIBILTY,        *
! *     CLARITY AND SIMPLICITY OF THE COMPUTER CODE. THE SPEED CAN BE INCREASED     *
! *     IF THE VECTOR SPHERICAL WAVE FUNCTIONS ARE EXPLICITELY COMPUTED.            *
! ***********************************************************************************
subroutine mvnv (index1, index2, chiral, zl, zc, zcl, zcr, theta, phi, Mrank,       &
           Nrank, Nmax, NmaxC, NmaxL, mv3, nv3, mv1, nv1)
  use parameters
  implicit none
  integer    :: index1, index2, Mrank, Nrank, Nmax, NmaxC, NmaxL
  real(O)    :: theta, phi
  complex(O) :: zc, zl, zcl, zcr, mv1(3,NmaxC), nv1(3,NmaxC), mv3(3,NmaxL),         &
                nv3(3,NmaxL)
  logical    :: chiral
!
  complex(O),allocatable :: mvl1(:,:), nvl1(:,:), mvr1(:,:), nvr1(:,:)
!
  if (chiral) allocate (mvl1(3,NmaxC), nvl1(3,NmaxC), mvr1(3,NmaxC), nvr1(3,NmaxC))
  if (index1 == 3 .and. index2 == 1) then
    call MN_complete (3, zl, theta, phi, Mrank, Nrank, Nmax,.false.,.false.,        &
         mv3, nv3)
    if (.not. chiral) then
      call MN_complete (1, zc, theta, phi, Mrank, Nrank, Nmax,.true.,.false.,       &
           mv1, nv1)
    else
      call MN_complete (1, zcl, theta, phi, Mrank, Nrank, Nmax,.true.,.false.,      &
           mvl1, nvl1)
      call MN_complete (1, zcr, theta, phi, Mrank, Nrank, Nmax,.true.,.false.,      &
           mvr1, nvr1)
      call MN_left_right (Nmax, mvl1, nvl1, mvr1, nvr1, mv1, nv1)
    end if
  else if (index1 == 3 .and. index2 == 3) then
    call MN_complete (3, zl, theta, phi, Mrank, Nrank, Nmax,.false.,.false.,        &
         mv3, nv3)
    call MN_complete (3, zc, theta, phi, Mrank, Nrank, Nmax,.true.,.false.,         &
         mv1, nv1)
  else if (index1 == 1 .and. index2 == 1) then
    call MN_complete (1, zl, theta, phi, Mrank, Nrank, Nmax,.false.,.false.,        &
         mv3, nv3)
    if (.not. chiral) then
      call MN_complete (1, zc, theta, phi, Mrank, Nrank, Nmax,.true.,.false.,       &
           mv1, nv1)
    else
      call MN_complete (1, zcl, theta, phi, Mrank, Nrank, Nmax,.true.,.false.,      &
           mvl1, nvl1)
      call MN_complete (1, zcr, theta, phi, Mrank, Nrank, Nmax,.true.,.false.,      &
           mvr1, nvr1)
      call MN_left_right (Nmax, mvl1, nvl1, mvr1, nvr1, mv1, nv1)
    end if
  else if (index1 == 1 .and. index2 == 3) then
    call MN_complete (1, zl, theta, phi, Mrank, Nrank, Nmax,.false.,.false.,        &
         mv3, nv3)
    call MN_complete (3, zc, theta, phi, Mrank, Nrank, Nmax,.true.,.false.,         &
         mv1, nv1)
  end if
  if(chiral) deallocate (mvl1, nvl1, mvr1, nvr1)
end subroutine mvnv
! **********************************************************************************
subroutine mvnv_m (index1, index2, chiral, DS, zl, zc, zcl, zcr, kc, ki, kil, kir,  &
           r, theta, m, Nrank, Nmax, NmaxC, NmaxL, zRe, zIm, mv3, nv3, mv1, nv1)
  use parameters
  implicit none
  integer    :: index1, index2, m, m_minus, Nrank, Nmax, NmaxC, NmaxL
  real(O)    :: zRe(Nrank), zIm(Nrank), r, theta
  complex(O) :: kc, ki, kil, kir, zc, zl, zcl, zcr, mv1(3,NmaxC), nv1(3,NmaxC),     &
                mv3(3,NmaxL), nv3(3,NmaxL)
  logical    :: DS, chiral
!
  complex(O),allocatable :: mvl1(:,:), nvl1(:,:), mvr1(:,:), nvr1(:,:)
!
  m_minus = - m
  if (chiral) allocate (mvl1(3,NmaxC), nvl1(3,NmaxC), mvr1(3,NmaxC), nvr1(3,NmaxC))
  if (.not. DS) then
    if (index1 == 3 .and. index2 == 1) then
      call MN (3, zl, theta, m_minus, Nrank, Nmax, mv3, nv3)
      if (.not. chiral) then
        call MN (1, zc, theta, m, Nrank, Nmax, mv1, nv1)
      else
        call MN (1, zcl, theta, m, Nrank, Nmax, mvl1, nvl1)
        call MN (1, zcr, theta, m, Nrank, Nmax, mvr1, nvr1)
        call MN_left_right (Nmax, mvl1, nvl1, mvr1, nvr1, mv1, nv1)
      end if
    else if (index1 == 3 .and. index2 == 3) then
      call MN (3, zl, theta, m_minus, Nrank, Nmax, mv3, nv3)
      call MN (3, zc, theta, m, Nrank, Nmax, mv1, nv1)
    else if (index1 == 1 .and. index2 == 1) then
      call MN (1, zl, theta, m_minus, Nrank, Nmax, mv3, nv3)
      if (.not. chiral) then
        call MN (1, zc, theta, m, Nrank, Nmax, mv1, nv1)
      else
        call MN (1, zcl, theta, m, Nrank, Nmax, mvl1, nvl1)
        call MN (1, zcr, theta, m, Nrank, Nmax, mvr1, nvr1)
        call MN_left_right (Nmax, mvl1, nvl1, mvr1, nvr1, mv1, nv1)
      end if
    else if (index1 == 1 .and. index2 == 3) then
      call MN (1, zl, theta, m_minus, Nrank, Nmax, mv3, nv3)
      call MN (3, zc, theta, m, Nrank, Nmax, mv1, nv1)
    end if
  else
    if (index1 == 3 .and. index2 == 1) then
      call MN_DS (3, kc, r, theta, zRe, zIm, m_minus, Nrank, mv3, nv3)
      if (.not. chiral) then
        call MN_DS (1, ki, r, theta, zRe, zIm, m, Nrank, mv1, nv1)
      else
        call MN_DS (1, kil, r, theta, zRe, zIm, m, Nrank, mvl1, nvl1)
        call MN_DS (1, kir, r, theta, zRe, zIm, m, Nrank, mvr1, nvr1)
        call MN_left_right (Nrank, mvl1, nvl1, mvr1, nvr1, mv1, nv1)
      end if
    else if (index1 == 1 .and. index2 == 1) then
      call MN (1, zl, theta, m_minus, Nrank, Nmax, mv3, nv3)
      if (.not. chiral) then
        call MN_DS (1, ki, r, theta, zRe, zIm, m, Nrank, mv1, nv1)
      else
        call MN_DS (1, kil, r, theta, zRe, zIm, m, Nrank, mvl1, nvl1)
        call MN_DS (1, kir, r, theta, zRe, zIm, m, Nrank, mvr1, nvr1)
        call MN_left_right (Nrank, mvl1, nvl1, mvr1, nvr1, mv1, nv1)
      end if
    end if
  end if
  if (chiral) deallocate (mvl1, nvl1, mvr1, nvr1)
end subroutine mvnv_m
!***********************************************************************************
subroutine mvnvinc_m (zl, kc, r, theta, m, Nrank, Nmax, zRe, zIm, mv3, nv3,        &
           mv1, nv1)
  use parameters
  implicit none
  integer    :: m, m_minus, Nrank, Nmax
  real(O)    :: zRe(Nrank), zIm(Nrank), r, theta
  complex(O) :: kc, zl, mv1(3,Nmax), nv1(3,Nmax), mv3(3,Nrank), nv3(3,Nrank)
!
  m_minus = - m
  call MN (1, zl, theta, m, Nrank, Nmax, mv1, nv1)
  call MN_DS (3, kc, r, theta, zRe, zIm, m_minus, Nrank, mv3, nv3)
end subroutine mvnvinc_m
! **********************************************************************************
! *      ROUTINES FOR PERFORMING CONVERGENCE TESTS USING MISHCHENKO'S PROCEDURE    *
! *    ------------------------------------------------------------------------    *
! *    Partial list of subroutines:                                                *
! *      estimateNrankMishchenko,           estimateNintMishchenko,                *
! *      CscatCextConvLS,                   CscatCextConvDS,                       *
! *      matQConv,                          matQincConv,                           *
! **********************************************************************************
recursive subroutine estimateNrankMishchenko (TypeGeom, k, ind_ref, Nsurf, surf,    &
           zRe, zIm, Nparam, mirror, perfectcond, DS, ComplexPlane, EpsZIm,         &
           x, delta, Ndgs, Nint, Nrank, NrankMax, Cscat1, Cext1)
  use parameters
  use derived_parameters
  implicit none
  integer    :: Nsurf, Nparam, TypeGeom, Nint, Nrank, Ndgs
  real(O)    :: k, surf(Nsurf), zRe(NrankPD), zIm(NrankPD), EpsZIm, x, delta,       &
                Cscat1, Cext1
  complex(O) :: ind_ref
  logical    :: mirror, perfectcond, DS, ComplexPlane
!
  integer    :: irank, i, NrankMin, NrankWis, NrankMax
  real(O)    :: Cext, Cscat, DeltaScat, DeltaExt, ErrScat, ErrExt, ErrMax
  logical    :: diverge, repeat
  integer,allocatable    :: Nintparam(:)
  real(O),allocatable    :: paramG(:,:), weightsG(:,:)
!
  delta = 1.e-3_O
  print "(/,2x, a, 1pe10.2, a)",                                                    &
 '- enter the accuracy of the T-matrix calculations as for instance', delta, ';'
  call read_real (delta)
  print "(/,2x,'- enter the estimated value of  Ndgs, where the number of integration ')"
  print "(  2x,'points for the Nrank convergence test is Nint = Ndgs * Nrank;         ')"
  call read_integer (Ndgs)
  NrankWis = int(x + 4.05_O * x**0.33_O)
  NrankMin = max(4,NrankWis)
  print "(/,2x, a, i3, a)",                                                         &
  'The estimate of the lower bound of Nrank from Wiscombe''s criterion is ',        &
  NrankMin, ';'
  print "(/,2x,'- enter the lower and upper bounds of Nrank;')"
  call read_integer2 (NrankMin, NrankMax)
  print "( )"
  print "(/,2x,'Convergence Test over Nrank')"
  print "(2x,'iteration',1x,'Nrank',3x,'Nint',6x,'EpsScat',8x,'EpsExt')"
  Cscat1  = 0._O
  Cext1   = 0._O
  diverge = .true.
  irank   = NrankMin - 1
  i = 0
  do while (diverge .and. irank < NrankMax)
    i     = i + 1
    irank = irank + 1
    Nrank = irank
    Nint  = Ndgs * Nrank
    allocate (paramG(Nparam,Nint), weightsG(Nparam,Nint), Nintparam(Nparam))
    call interpolation_listAXSYM (TypeGeom, Nsurf, surf, Nint, Nparam,              &
         Nintparam, paramG, weightsG, mirror)
    if (DS) then
      call check_MaxNrank (Nrank)
      call zDSAXSYM (TypeGeom, Nsurf, surf, Nrank, ComplexPlane, EpsZIm, zRe, zIm)
      call CscatCextConvDS (TypeGeom, k, ind_ref, Nsurf, surf, zRe, zIm, Nrank,     &
           Nint, Nparam, Nintparam, paramG, weightsG, perfectcond, Cscat, Cext)
    else
      call CscatCextConvLS (TypeGeom, k, ind_ref, Nsurf, surf, Nrank, Nint,         &
           Nparam, Nintparam, paramG, weightsG, mirror, perfectcond, Cscat, Cext)
    end if
    DeltaScat = abs(Cscat1 - Cscat)
    DeltaExt  = abs(Cext1  - Cext )
    Cscat1    = Cscat
    Cext1     = Cext
    print "(4x,i3,2(5x,i3),2(2x,1pe13.4))", i, Nrank, Nint, DeltaScat, DeltaExt
    if (abs(Cscat) > MachEps .and. abs(Cext) > MachEps) then
      ErrScat = DeltaScat / abs(Cscat)
      ErrExt  = DeltaExt  / abs(Cext)
      ErrMax  = max(ErrScat, ErrExt)
      if (ErrMax <= delta) diverge = .false.
    else
      exit
    end if
    deallocate (paramG, weightsG, Nintparam)
  end do
  print "( )"
  if (diverge) then
    print "(/,2x,'Convergence over Nrank is not achieved;')"
    print "(  2x,'- repeat the convergence test with new inputs ?:')"
    print "(  1x,'.true. - yes, .false. - no;')"
    call read_logical (repeat)
    if (repeat) then
      call estimateNrankMishchenko (TypeGeom, k, ind_ref, Nsurf, surf,              &
           zRe, zIm, Nparam, mirror, perfectcond, DS, ComplexPlane, EpsZIm,         &
           x, delta, Ndgs, Nint, Nrank, NrankMax, Cscat1, Cext1)
    end if
  end if
end subroutine estimateNrankMishchenko
! **********************************************************************************
recursive subroutine estimateNintMishchenko (TypeGeom, k, ind_ref, Nsurf, surf,     &
          zRe, zIm, Nparam, mirror, perfectcond, DS, x, delta, Ndgs, Nint, dNint,   &
          Nrank, NrankMax, Cscat1, Cext1)
  use parameters
  use derived_parameters
  implicit none
  integer    :: Nsurf, Nparam, TypeGeom, Nint, dNint, Nrank, NrankMax, Ndgs
  real(O)    :: k, surf(Nsurf), zRe(NrankPD), zIm(NrankPD), x, delta, Cscat1, Cext1
  complex(O) :: ind_ref
  logical    :: mirror, perfectcond, DS
!
  integer    :: iint, i, NintMax
  real(O)    :: Cext, Cscat, DeltaScat, DeltaExt, ErrScat, ErrExt
  logical    :: diverge, repeat
  integer,allocatable    :: Nintparam(:)
  real(O),allocatable    :: paramG(:,:), weightsG(:,:)
!
  print "(/,2x, a, i3, a)",                                                         &
 '- enter an integer value greater than ', Nint + 1, ' for the upper bound of Nint'
  print "(2x,'as for instance ',i4,';')", (Ndgs + 1) * NrankMax
  call read_integer (NintMax)
  print "( )"
  print "(/,2x,'Convergence Test over Nint')"
  print "(2x,'iteration',1x,'Nrank',3x,'Nint',6x,'EpsScat',8x,'EpsExt')"
  diverge = .true.
  iint    = Nint
  i = 0
  do while (diverge .and. iint < NintMax)
    i    = i + 1
    iint = iint + dNint
    Nint = iint
    allocate (paramG(Nparam,Nint), weightsG(Nparam,Nint), Nintparam(Nparam))
    call interpolation_listAXSYM (TypeGeom, Nsurf, surf, Nint, Nparam,              &
         Nintparam, paramG, weightsG, mirror)
    if (DS) then
      call CscatCextConvDS (TypeGeom, k, ind_ref, Nsurf, surf, zRe, zIm, Nrank,     &
           Nint, Nparam, Nintparam, paramG, weightsG, perfectcond, Cscat, Cext)
    else
      call CscatCextConvLS (TypeGeom, k, ind_ref, Nsurf, surf, Nrank, Nint,         &
           Nparam, Nintparam, paramG, weightsG, mirror, perfectcond, Cscat, Cext)
    end if
    DeltaScat = abs(Cscat1 - Cscat)
    DeltaExt  = abs(Cext1  - Cext )
    Cscat1    = Cscat
    Cext1     = Cext
    print "(4x,i3,2(5x,i3),2(2x,1pe13.4))", i, Nrank, Nint, DeltaScat, DeltaExt
    if (abs(Cscat) > MachEps .and. abs(Cext) > MachEps) then
      ErrScat = DeltaScat / abs(Cscat)
      ErrExt  = DeltaExt  / abs(Cext)
      if (ErrScat <= delta .and. ErrExt <= delta) diverge = .false.
    else
      exit
    end if
    deallocate (paramG, weightsG, Nintparam)
  end do
  print "( )"
  if (diverge) then
    print "(/,2x,'Convergence over Nint is not achieved;')"
    print "(2x,'- repeat the convergence test with new inputs ?:')"
    print "(1x,'.true. - yes, .false. - no;')"
    call read_logical (repeat)
    if (repeat) then
      call estimateNintMishchenko (TypeGeom, k, ind_ref, Nsurf, surf,               &
           zRe, zIm, Nparam, mirror, perfectcond, DS, x, delta, Ndgs, Nint,         &
           dNint, Nrank, NrankMax, Cscat1, Cext1)
    end if
  else
    print "(/,2x,'Nint and Nrank estimates:')"
    print "(  2x,'the estimated values of Nint and Nrank from Mishchenko''s convergence')"
    print "(  2x,'criterion are: Nint = ',i4,' and Nrank = ',i3,';')", Nint, Nrank
  end if
end subroutine estimateNintMishchenko
!***********************************************************************************
subroutine CscatCextConvLS  (TypeGeom, k, ind_ref, Nsurf, surf, Nrank, Nint,        &
           Nparam, Nintparam, paramG, weightsG, mirror, perfectcond, Cscat, Cext)
  use parameters
  use derived_parameters
  implicit none
  integer    :: Nrank, Nsurf, Nint, Nparam, Nintparam(Nparam), TypeGeom
  real(O)    :: k, surf(Nsurf), paramG(Nparam,Nint), weightsG(Nparam,Nint),         &
                Cscat, Cext
  complex(O) :: ind_ref
  logical    :: mirror, perfectcond
!
  integer    :: i, j, pint, iparam, Nintl, n
  real(O)    :: r, theta, phi, dA, param, pondere, nuv(3), ir, QA, QB,              &
                nm, nr, ft, fl
  complex(O) :: ki, zc, zl, factp, factm, f
  real(O),allocatable    :: Pnm(:), dPnm(:), pinm(:), taunm(:)
  complex(O),allocatable :: jb(:), jbd(:), jba(:), jbda(:), hb(:), hbd(:),          &
                            Q31A(:,:), Q31B(:,:), Q11A(:,:), Q11B(:,:),             &
                            mv1(:,:), nv1(:,:), mv3(:,:), nv3(:,:),                 &
                            mv1a(:,:), nv1a(:,:)
!
  allocate (Q31A(Nrank,Nrank), Q31B(Nrank,Nrank), Q11A(Nrank,Nrank),                &
            Q11B(Nrank,Nrank))
  allocate (mv1(3,Nrank), nv1(3,Nrank), mv3(3,Nrank), nv3(3,Nrank),                 &
            mv1a(3,Nrank), nv1a(3,Nrank))
  allocate (jb(0:Nrank), jbd(0:Nrank), jba(0:Nrank), jbda(0:Nrank),                 &
            hb(0:Nrank), hbd(0:Nrank))
  allocate (Pnm(0:Nrank), dPnm(0:Nrank), pinm(0:Nrank), taunm(0:Nrank))
  do i = 1, Nrank
    do j = 1, Nrank
      Q31A(i,j) = zero
      Q31B(i,j) = zero
      Q11A(i,j) = zero
      Q11B(i,j) = zero
    end do
  end do
  ki = k * ind_ref
  f  = im * 2._O * k * k
  do iparam = 1, Nparam
    Nintl = Nintparam(iparam)
    do pint = 1, Nintl
      param   = paramG(iparam,pint)
      pondere = weightsG(iparam,pint)
      call elem_geomAXSYM (TypeGeom, Nsurf, surf, param, iparam, r, theta, phi,     &
           dA, nuv)
      zc = ki * r
      if (abs(zc) < MachEps) zc = cmplx(MachEps,MachEps,O)
      zl = cmplx(k * r,0.0,O)
      if (abs(zl) < MachEps) zl = cmplx(MachEps,MachEps,O)
      call leg_normalized (theta, 0, Nrank, Pnm, dPnm, pinm, taunm)
      call besel_j (zc, Nrank, jb, jbd)
      call besel_j (zl, Nrank, jba, jbda)
      call besel_h (zl, Nrank, hb, hbd)
      do n = 1, Nrank
        nr = real(n * (n + 1),O)
        nm = 1._O / sqrt(2._O * nr)
        ft = taunm(n) * nm
        fl = nr * Pnm(n) * nm
        mv1(1,n)  =   zero
        mv1(2,n)  =   zero
        mv1(3,n)  = - jb(n) * ft
        nv1(1,n)  =   jb(n) * fl / zc
        nv1(2,n)  =   jbd(n) * ft/ zc
        nv1(3,n)  =   zero
        mv1a(1,n) =   zero
        mv1a(2,n) =   zero
        mv1a(3,n) = - jba(n)  * ft
        nv1a(1,n) =   jba(n)  * fl / zl
        nv1a(2,n) =   jbda(n) * ft / zl
        nv1a(3,n) =   zero
        mv3(1,n)  =   zero
        mv3(2,n)  =   zero
        mv3(3,n)  = - hb(n)  * ft
        nv3(1,n)  =   hb(n)  * fl / zl
        nv3(2,n)  =   hbd(n) * ft / zl
        nv3(3,n)  =   zero
      end do
      factm = - f * dA * pondere
      call matQConv (Nrank, perfectcond, mirror, ind_ref, factm,                     &
           mv3, nv3, mv1, nv1, nuv, Q31A, Q31B, Nrank, Nrank)
      factp = - factm
      call matQConv (Nrank, perfectcond, mirror, ind_ref, factp,                     &
           mv1a, nv1a, mv1, nv1, nuv, Q11A, Q11B, Nrank, Nrank)
    end do
  end do
  call LU_SYSTEM (Q31A, Nrank, Nrank, Q11A, Nrank, Nrank, Nrank)
  call LU_SYSTEM (Q31B, Nrank, Nrank, Q11B, Nrank, Nrank, Nrank)
  Cscat = 0._O
  Cext  = 0._O
  do n = 1, Nrank
    ir    = real(2 * n + 1,O)
    QA    = abs(Q11A(n,n))
    QB    = abs(Q11B(n,n))
    Cscat = Cscat + ir * (QA * QA + QB * QB)
    QA    = real(Q11A(n,n))
    QB    = real(Q11B(n,n))
    Cext  = Cext + ir * (QA + QB)
  end do
  deallocate (Q31A, Q31B, Q11A, Q11B)
  deallocate (mv1, nv1, mv3, nv3, mv1a, nv1a)
  deallocate (jb, jbd, jba, jbda, hb, hbd)
  deallocate (Pnm, dPnm, pinm, taunm)
end subroutine CscatCextConvLS
!***********************************************************************************
subroutine CscatCextConvDS (TypeGeom, k, ind_ref, Nsurf, surf, zRe, zIm, Nrank,     &
           Nint, Nparam, Nintparam, paramG, weightsG, perfectcond, Cscat, Cext)
  use parameters
  use derived_parameters
  implicit none
  integer    :: Nrank, Nsurf, Nint, Nparam, Nintparam(Nparam), TypeGeom
  real(O)    :: k, surf(Nsurf), paramG(Nparam,Nint), weightsG(Nparam,Nint),         &
                zRe(Nrank), zIm(Nrank), Cscat, Cext
  complex(O) :: ind_ref
  logical    :: perfectcond
!
  integer    :: i, j, pint, iparam, Nintl, n
  real(O)    :: r, theta, phi, dA, param, pondere, nuv(3), ir, QA, QB, ro, z, nm,   &
                nr, cth, sth, ftr, flr, dz
  complex(O) :: kc, ki, zl, factp, factm, f, RR, sint, cost, argJi, argJc,          &
                sinc, cosc, Pmm, taumm, ft, fl, factt, factl, roc, dzc
  real(O),allocatable    :: Pnm(:), dPnm(:), pinm(:), taunm(:)
  complex(O),allocatable :: jb(:), jbd(:), jba(:), jbda(:), hb(:), hbd(:),          &
                            Q31A(:,:), Q31B(:,:), Q11A(:,:), Q11B(:,:),             &
                            QincA(:,:), QincB(:,:), mv1(:,:), nv1(:,:),             &
                            mv3(:,:), nv3(:,:), mv1a(:,:), nv1a(:,:)
!
  allocate (Q31A(Nrank,Nrank), Q31B(Nrank,Nrank),  Q11A(Nrank,Nrank),               &
            Q11B(Nrank,Nrank), QincA(Nrank,Nrank), QincB(Nrank,Nrank))
  allocate (mv1(3,Nrank), nv1(3,Nrank), mv3(3,Nrank), nv3(3,Nrank),                 &
            mv1a(3,Nrank), nv1a(3,Nrank))
  allocate (jb(0:2), jbd(0:2), jba(0:Nrank), jbda(0:Nrank),                         &
            hb(0:2), hbd(0:2))
  allocate (Pnm(0:Nrank), dPnm(0:Nrank), pinm(0:Nrank), taunm(0:Nrank))
  kc = cmplx(k,0.0,O)
  do i = 1, Nrank
    do j = 1, Nrank
      Q31A(i,j)  = zero
      Q31B(i,j)  = zero
      Q11A(i,j)  = zero
      Q11B(i,j)  = zero
      QincA(i,j) = zero
      QincB(i,j) = zero
    end do
  end do
  ki = k * ind_ref
  f  = im * 2._O * k * k
  do iparam = 1, Nparam
    Nintl = Nintparam(iparam)
    do pint = 1, Nintl
      param   = paramG(iparam,pint)
      pondere = weightsG(iparam,pint)
      call elem_geomAXSYM (TypeGeom, Nsurf, surf, param, iparam, r, theta, phi,     &
           dA, nuv)
      zl = cmplx(k * r,0.0,O)
      if (abs(zl) < MachEps) zl = cmplx(MachEps,MachEps,O)
      call leg_normalized (theta, 0, Nrank, Pnm, dPnm, pinm, taunm)
      call besel_j (zl, Nrank, jba, jbda)
      sth = sin(theta)
      cth = cos(theta)
      ro  = r * sth
      z   = r * cth
      roc = cmplx(ro,0.0,O)
      do n = 1, Nrank
        dz    = z - zRe(n)
        dzc   = cmplx(dz,0.0,O)
        RR    = sqrt(roc * roc + (dzc - im * zIm(n))**2)
        if (abs(RR) < MachEps) RR = cmplx(MachEps,MachEps,O)
        sint  = ro / RR
        cost  = (dzc - im * zIm(n)) / RR
        argJi = ki * RR
        argJc = kc * RR
        call besel_j (argJi, 2, jb, jbd)
        call besel_h (argJc, 2, hb, hbd)
        Pmm   =   sqrt(3._O / 2._O) * cost
        taumm = - sqrt(3._O / 2._O) * sint
        sinc  = sth * cost - cth * sint
        cosc  = cth * cost + sth * sint
        ft    = 0.5_O * taumm
        fl    = Pmm
        mv1(1,n) =   zero
        mv1(2,n) =   zero
        mv1(3,n) = - jb(1)  * ft
        factl    =   jb(1)  * fl
        factt    =   jbd(1) * ft
        nv1(1,n) =   (   factl * cosc + factt * sinc) / argJi
        nv1(2,n) =   ( - factl * sinc + factt * cosc) / argJi
        nv1(3,n) =   zero
        mv3(1,n) =   zero
        mv3(2,n) =   zero
        mv3(3,n) = - hb(1)  * ft
        factl    =   hb(1)  * fl
        factt    =   hbd(1) * ft
        nv3(1,n) =   (   factl * cosc + factt * sinc) / argJc
        nv3(2,n) =   ( - factl * sinc + factt * cosc) / argJc
        nv3(3,n) =   zero
        nr  = real(n * (n + 1),O)
        nm  = 1._O / sqrt(2._O * nr)
        ftr = taunm(n) * nm
        flr = nr * Pnm(n) * nm
        mv1a(1,n) =   zero
        mv1a(2,n) =   zero
        mv1a(3,n) = - jba(n)  * ftr
        nv1a(1,n) =   jba(n)  * flr / zl
        nv1a(2,n) =   jbda(n) * ftr / zl
        nv1a(3,n) =   zero
      end do
      factm = - f * dA * pondere
      call matQConv (Nrank, perfectcond, .false., ind_ref, factm,                   &
           mv3, nv3, mv1, nv1, nuv, Q31A, Q31B, Nrank, Nrank)
      factp = - factm
      call matQConv (Nrank, perfectcond, .false., ind_ref, factp,                   &
           mv1a, nv1a, mv1, nv1, nuv, Q11A, Q11B, Nrank, Nrank)
      call matQincConv (Nrank, factp, mv3, nv3, mv1a, nv1a, nuv,                    &
           QincA, QincB, Nrank, Nrank)
    end do
  end do
  call LU_SYSTEM_DIRECT (Q31A, Nrank, Nrank, QincA, Nrank, Nrank, Nrank, Nrank)
  call LU_SYSTEM_DIRECT (Q31B, Nrank, Nrank, QincB, Nrank, Nrank, Nrank, Nrank)
  call product_matrices (Nrank, Nrank, Nrank, Q11A, Nrank, Nrank, QincA, Nrank,     &
       Nrank)
  call product_matrices (Nrank, Nrank, Nrank, Q11B, Nrank, Nrank, QincB, Nrank,     &
       Nrank)
  Cscat = 0._O
  Cext  = 0._O
  do i = 1, Nrank
    ir    = real(2 * i + 1,O)
    QA    = abs(Q11A(i,i))
    QB    = abs(Q11B(i,i))
    Cscat = Cscat + ir * (QA * QA + QB * QB)
    QA    = real(Q11A(i,i))
    QB    = real(Q11B(i,i))
    Cext  = Cext + ir * (QA + QB)
  end do
  deallocate (Q31A, Q31B, Q11A, Q11B, QincA, QincB)
  deallocate (mv1, nv1, mv3, nv3, mv1a, nv1a)
  deallocate (jb, jbd, jba, jbda, hb, hbd)
  deallocate (Pnm, dPnm, pinm, taunm)
end subroutine CscatCextConvDS
! **********************************************************************************
subroutine matQConv (Nrank, perfectcond, mirror, ind_ref, fact, mv3, nv3, mv1, nv1,  &
           nuv, QA, QB, nap, map)
  use parameters
  implicit none
  integer    :: Nrank, nap, map
  real(O)    :: nuv(3)
  complex(O) :: ind_ref, fact, mv1(3,Nrank), nv1(3,Nrank), mv3(3,Nrank),            &
                nv3(3,Nrank), QA(nap,map), QB(nap,map)
  logical    :: perfectcond, mirror
!
  integer    :: i, j, ni, nj
  real(O)    :: s
  complex(O) :: mvl(3), nvl(3), mvc(3), nvc(3), v1, v2, mixt_product
!
  do i = 1, Nrank
    ni = i
    mvl(1) = mv3(1,i)
    mvl(2) = mv3(2,i)
    mvl(3) = mv3(3,i)
    nvl(1) = nv3(1,i)
    nvl(2) = nv3(2,i)
    nvl(3) = nv3(3,i)
    do j = 1, Nrank
      nj = j
      mvc(1) = mv1(1,j)
      mvc(2) = mv1(2,j)
      mvc(3) = mv1(3,j)
      nvc(1) = nv1(1,j)
      nvc(2) = nv1(2,j)
      nvc(3) = nv1(3,j)
      s = (-1._O)**(ni + nj)
      v1 = mixt_product (nuv, mvc, nvl)
      v2 = mixt_product (nuv, nvc, mvl)
      if (.not. perfectcond) then
        QA(i,j) = QA(i,j) + (v1 + ind_ref * v2) * fact
        if (mirror) QA(i,j) = QA(i,j) + s * (v1 + ind_ref * v2) * fact
      else
        QA(i,j) = QA(i,j) + v2 * fact
        if (mirror) QA(i,j) = QA(i,j) + s * v2 * fact
      end if
      v1 = mixt_product (nuv, nvc, mvl)
      v2 = mixt_product (nuv, mvc, nvl)
      if (.not. perfectcond) then
        QB(i,j) = QB(i,j) + (v1 + ind_ref * v2) * fact
        if (mirror) QB(i,j) = QB(i,j) + s * (v1 + ind_ref * v2) * fact
      else
        QB(i,j) = QB(i,j) + v2 * fact
        if (mirror) QB(i,j) = QB(i,j) + s * v2 * fact
      end if
    end do
  end do
end subroutine matQConv
!***********************************************************************************
subroutine matQincConv (Nrank, fact, mv3, nv3, mv1, nv1, nuv, QA, QB, nap, map)
  use parameters
  implicit none
  integer    :: Nrank, nap, map
  real(O)    :: nuv(3)
  complex(O) :: fact, mv1(3,Nrank), nv1(3,Nrank), mv3(3,Nrank), nv3(3,Nrank),       &
                QA(nap,map), QB(nap,map)
!
  integer    :: i, j
  complex(O) :: mvl(3), nvl(3), mvc(3), nvc(3), v1, v2, mixt_product
!
  do i = 1, Nrank
    mvl(1) = mv3(1,i)
    mvl(2) = mv3(2,i)
    mvl(3) = mv3(3,i)
    nvl(1) = nv3(1,i)
    nvl(2) = nv3(2,i)
    nvl(3) = nv3(3,i)
    do j = 1, Nrank
      mvc(1) = mv1(1,j)
      mvc(2) = mv1(2,j)
      mvc(3) = mv1(3,j)
      nvc(1) = nv1(1,j)
      nvc(2) = nv1(2,j)
      nvc(3) = nv1(3,j)
      v1 = mixt_product (nuv, mvc, nvl)
      v2 = mixt_product (nuv, nvc, mvl)
      QA(i,j) = QA(i,j) + (v1 + v2) * fact
      v1 = mixt_product (nuv, nvc, mvl)
      v2 = mixt_product (nuv, mvc, nvl)
      QB(i,j) = QB(i,j) + (v1 + v2) * fact
    end do
  end do
end subroutine matQincConv


*     MB04UD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          MMAX, NMAX
      PARAMETER        ( MMAX = 20, NMAX = 20 )
      INTEGER          LDA, LDE, LDQ, LDZ
      PARAMETER        ( LDA = MMAX, LDE = MMAX, LDQ = MMAX,
     $                   LDZ = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( NMAX,MMAX ) )
*     PARAMETER        ( LDWORK = NMAX+MMAX )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INFO, J, M, N, RANKE
      CHARACTER*1      JOBQ, JOBZ
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), E(LDE,NMAX),
     $                 Q(LDQ,MMAX), Z(LDZ,NMAX)
      INTEGER          ISTAIR(MMAX)
*     .. External Subroutines ..
      EXTERNAL         MB04UD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) M, N, TOL
      IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) M
      ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,M )
         READ ( NIN, FMT = * ) ( ( E(I,J), J = 1,N ), I = 1,M )
         JOBQ = 'N'
         JOBZ = 'N'
*        Reduce E to column echelon form and compute Q'*A*Z.
         CALL MB04UD( JOBQ, JOBZ, M, N, A, LDA, E, LDE, Q, LDQ, Z, LDZ,
     $                RANKE, ISTAIR, TOL, DWORK, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99991 )
            DO 10 I = 1, M
               WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,N )
   10       CONTINUE
            WRITE ( NOUT, FMT = 99997 )
            DO 100 I = 1, M
               WRITE ( NOUT, FMT = 99996 ) ( E(I,J), J = 1,N )
  100       CONTINUE
            WRITE ( NOUT, FMT = 99995 ) RANKE
            WRITE ( NOUT, FMT = 99994 ) ( ISTAIR(I), I = 1,M )
         END IF
      END IF
      STOP
*
99999 FORMAT (' MB04UD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB04UD = ',I2)
99997 FORMAT (' The transformed matrix E is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' The computed rank of E = ',I2)
99994 FORMAT (/' ISTAIR is ',/20(1X,I5))
99993 FORMAT (/' M is out of range.',/' M = ',I5)
99992 FORMAT (/' N is out of range.',/' N = ',I5)
99991 FORMAT (' The transformed matrix A is ')
      END


submodule(flow_rate_t_interface) flow_rate_t_implementation
  !! Defined the flow_rate_t user-defined structure constructors and type-bound procedures
  implicit none
contains

  module procedure new_flow_rate_t
    use constants, only : p_amb

    REAL (dp):: mdtx, tx,gx,rx,px,cpx,pcrit,facx,term1,term2,pratio,cstar,ax,hx, p1, p2, dsigng

    p1=p
    p2=p_amb
    ax=area

    IF(p1>p2) THEN
        dsigng=1
        tx=t
        gx=g
        rx=rgas
        px=p
        cpx=cp
        hx=cp*t
        pratio=p1/p2
     else
        dsigng=-1
        tx=300d0
        gx=g
        rx=rgas
        px=p_amb
        cpx=cp
        hx=cp*300d0
        pratio=p2/p1
    end if

    pcrit=(2./(gx+1.))**(gx/(gx-1.))

    associate(choked_flow => (1./pratio)<pcrit)
      calculate_mdtx: &
      IF(choked_flow) then
        cstar=sqrt((1./gx)*((gx+1.)/2.)**((gx+1.)/(gx-1.))*rx*tx)
        mdtx=px*ax/cstar
      else
        facx=pratio**((gx-1.)/gx)
        term1=SQRT(gx*rx*tx/facx)
        term2=SQRT((facx-1.)/(gx-1.))
        mdtx=SQRT(2.)*px/pratio/rx/tx*facx*term1*term2*ax
      end if calculate_mdtx
    end associate

    new_flow_rate%mdotos_ = mdtx*dsigng ! exiting mass flow (could be negative "dsigng")
    associate(engyx => mdtx*hx)  ! reformulate based on enthalpy of the chamber
      new_flow_rate%edotos_ = engyx*dsigng ! exiting enthalpy
    end associate

  end procedure new_flow_rate_t

  module procedure edotos
    edotos = this%edotos_
  end procedure

  module procedure mdotos
    mdotos = this%mdotos_
  end procedure

end submodule flow_rate_t_implementation


      SUBROUTINE GRADEQ (N,MA,A,MB,B,LOW,IGH,CPERM,WK)
CSE
C
CPS        PURPOSE:
C
C             GRADES THE SUBMATRICES OF A AND B GIVEN BY STARTING INDEX
C             LOW AND ENDING INDEX IGH IN THE GENERALIZED EIGENVALUE
C             PROBLEM A*X = (LAMBDA)*B*X BY PERMUTING ROWS AND COLUMNS
C             SUCH THAT THE NORM OF THE I-TH ROW (COLUMN) OF THE A
C             SUBMATRIX DIVIDED BY THE NORM OF THE I-TH ROW (COLUMN)
C             OF THE B SUBMATRIX BECOMES SMALLER AS I INCREASES.
C
CPE
CAS           ***  ARGUMENT LIST  ***
C
C  INPUT PARAMETERS:
C
C  N - THE ORDER OF THE MATRICES A AND B;
C
C  MA - THE ROW (FIRST) DIMENSION OF THE ARRAY A AS SPECIFIED
C       IN THE CALLING PROGRAM;
C
C  A - A REAL TWO-DIMENSIONAL ARRAY WITH ROW DIMENSION MA AND COLUMN
C      DIMENSION AT LEAST N CONTAINING THE MATRIX A AS THE PROBLEM
C      IS DEFINED IN THE FUNCTION STATEMENT ABOVE;
C
C  MB - THE ROW (FIRST) DIMENSION OF THE ARRAY B AS SPECIFIED IN
C       THE CALLING PROGRAM;
C
C  B - A REAL TWO-DIMENSIONAL ARRAY WITH ROW DIMENSION MB AND COLUMN
C      DIMENSION AT LEAST N CONTAINING THE MATRIX B AS THE PROBLEM
C      IS DEFINED IN THE FUNCTION STATEMENT ABOVE;
C
C  LOW - THE INTEGER SPECIFYING THE BEGINNING INDEX OF THE SUBMATRICES
C        TO BE GRADED;
C
C  IGH - THE INTEGER SPECIFYING THE ENDING INDEX OF THE SUBMATRICES
C        TO BE GRADED;
C
C  WK - AN ARRAY OF ANY DIMENSION THAT MUST BE PROVIDED BY THE
C       USER FOR WORK SPACE. WK MUST CONTAIN AT LEAST 2*N LOCATIONS.
C       ONLY LOCATIONS LOW THROUGH IGH AND N+LOW THROUGH N+IGH
C       ARE REFERENCED.
C
C  OUTPUT PARAMETERS:
C
C  A - CONTAINS THE PERMUTED AND GRADED A MATRIX;
C
C  B - CONTAINS THE PERMUTED AND GRADED B MATRIX;
C
C  CPERM - THE REAL ARRAY OF DIMENSION AT LEAST N CONTAINING IN
C          ITS LOW THROUGH IGH LOCATIONS THE COLUMN PERMUTATIONS
C          APPLIED IN GRADING THE SUBMATRICES. THE OTHER LOCATIONS
C          ARE NOT REFERENCED;
C
C  WK - CONTAINS IN ITS LOW THROUGH IGH LOCATIONS THE ROW
C       PERMUTATIONS APPLIED IN GRADING THE SUBMATRICES.
C
CAE
C  REQUIRED SUBPROGRAMS - NONE
C
C  REQUIRED FUNCTIONS - ABS
C
C  REFERENCE - R.C. WARD, BALANCING THE GENERALIZED EIGENVALUE
C              PROBLEM, TECHNICAL REPORT ORNL/CSD-47, OAK RIDGE,
C              TENNESSEE, 1979.
C
C              [SAME TITLE] SIAM J. SCI. STAT. COMPUT., VOL 2,
C                           NO 2, JUNE 1981, PP 141-152.
C
C ****
C
      DIMENSION A(MA,N),B(MB,N),CPERM(N),WK(N,2)
      DOUBLE PRECISION A,B,CPERM,WK,SUMA,CMAX,RMAX,TEMP,SUMB
      IF (LOW .EQ. IGH) GO TO 505
      IGHM1 = IGH-1
C ****
C     COMPUTE COLUMN NORMS OF A / THOSE OF B
C ****
      DO 420 J=LOW,IGH
         SUMA = 0.D0
         SUMB = 0.D0
         DO 410 I=LOW,IGH
            SUMA = SUMA + DABS(A(I,J))
            SUMB = SUMB + DABS(B(I,J))
  410    CONTINUE
         IF (SUMB .EQ. 0.D0) GO TO 415
         WK(J,2) = SUMA / SUMB
         GO TO 420
  415    WK(J,2) = 1.D37
  420 CONTINUE
C ****
C     PERMUTE COLUMNS TO ORDER THEM BY DECREASING QUOTIENTS
C ****
      DO 450 J=LOW,IGHM1
         CMAX = WK(J,2)
         JM = J
         JP1 = J+1
         DO 430 K=JP1,IGH
            IF (CMAX .GE. WK(K,2)) GO TO 430
            JM = K
            CMAX = WK(K,2)
  430    CONTINUE
         CPERM(J) = JM
         IF (JM .EQ. J) GO TO 450
         TEMP = WK(J,2)
         WK(J,2) = WK(JM,2)
         WK(JM,2) = TEMP
         DO 440 I=1,IGH
            TEMP = B(I,J)
            B(I,J) = B(I,JM)
            B(I,JM) = TEMP
            TEMP = A(I,J)
            A(I,J) = A(I,JM)
            A(I,JM) = TEMP
  440    CONTINUE
  450 CONTINUE
      CPERM(IGH) = IGH
C ****
C     COMPUTE ROW NORMS OF A / THOSE OF B
C ****
      DO 470 I=LOW,IGH
         SUMA = 0.D0
         SUMB = 0.D0
         DO 460 J=LOW,IGH
            SUMA = SUMA + DABS(A(I,J))
            SUMB = SUMB + DABS(B(I,J))
  460    CONTINUE
         IF (SUMB .EQ. 0.D0) GO TO 465
         WK(I,2) = SUMA / SUMB
         GO TO 470
  465    WK(I,2) = 1.D37
  470 CONTINUE
C ****
C     PERMUTE ROWS TO ORDER THEM BY DECREASING QUOTIENTS
C ****
      DO 500 I=LOW,IGHM1
         RMAX = WK(I,2)
         IM = I
         IP1 = I+1
         DO 480 K=IP1,IGH
            IF (RMAX .GE. WK(K,2)) GO TO 480
            IM = K
            RMAX = WK(K,2)
  480    CONTINUE
         WK(I,1) = IM
         IF (IM .EQ. I) GO TO 500
         TEMP = WK(I,2)
         WK(I,2) = WK(IM,2)
         WK(IM,2) = TEMP
         DO 490 J=LOW,N
            TEMP = B(I,J)
            B(I,J) = B(IM,J)
            B(IM,J) = TEMP
            TEMP = A(I,J)
            A(I,J) = A(IM,J)
            A(IM,J) = TEMP
  490    CONTINUE
  500 CONTINUE
      WK(IGH,1) = IGH
  505 CONTINUE
C ****
C     EXIT GRADEQ
C ****
      RETURN
      END


*###[ ffzli2:
	subroutine ffzli2(zdilog,zlog,cx,lreal,ier)
***#[*comment:***********************************************************
*									*
*	Computes the dilogarithm (Li2, Sp) for any (complex) cx 	*
*	to a precision precc.  It assumes that cx is already in the	*
*	area |cx|<=1, Re(cx)<=1/2.  As it is available it also returns	*
*	log(1-cx) = zlog.						*
*									*
*	Input:	cx	(complex)					*
*		lreal	(logical) indicates whether only the real part  *
*				  is needed				*
*									*
*	Output:	zdilog	(complex) Li2(cx)				*
*		zlog	(complex) log(1-cx) = -Li1(cx)			*
*		ier	(integer) 0=OK,1=num,2=err			*
*									*
*	Calls:	log,zfflo1,(d/a)imag,real/dble				*
*									*
***#]*comment:***********************************************************
*  #[ declarations:
	implicit none
*
*	arguments
*
	integer ier
	logical lreal
	DOUBLE COMPLEX cx,zlog,zdilog
*
*	local variables
*
	DOUBLE PRECISION xprec,bdn02,bdn05,bdn10,bdn15,bdn20,
     +		xi,xr,xdilog,xlog,x,absc,xa,a,ffbnd
	DOUBLE COMPLEX cc,cz,cz2,zfflo1
	save xprec,bdn02,bdn05,bdn10,bdn15,bdn20
*
*	common blocks
*
	include 'ff.h'
*
*	statement function
*
	absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
*  #] declarations:
!$omp threadprivate(xprec,bdn02,bdn05,bdn10,bdn15,bdn20)

*  #[ initialisations:
	data xprec /-1./

	if ( xprec .ne. precc ) then
	    xprec = precc
	    bdn02 = ffbnd(1,2,bf)
	    bdn05 = ffbnd(1,5,bf)
	    bdn10 = ffbnd(1,10,bf)
	    bdn15 = ffbnd(1,15,bf)
	    bdn20 = ffbnd(1,19,bf)
*		we don't have bf(21) ...
	endif
*  #] initialisations:
*  #[ check input:
*	(throw out later)
	if ( ltest .and. absc(cx).gt.1.5 .or. DBLE(cx).gt..75 ) then
	    call fferr(30,ier)
	    print *,'cx = ',cx
	endif
*  #] check input:
*  #[ exceptional cases:
	xi  = DIMAG(cx)
	xr  = DBLE(cx)
	if ( xi .eq. 0) then
	    call ffxli2(xdilog,xlog,xr,ier)
	    zdilog = xdilog
	    zlog = xlog
	    return
	endif
	xa = abs(xi) + abs(xr)
	if ( xa .lt. precc ) then
	    zdilog = cx
	    zlog = -cx
	    return
	endif
*  #] exceptional cases:
*  #[ get log,dilog:
	if ( xa .lt. xloss**2 ) then
	    zlog = zfflo1(cx,ier)
	else
	    zlog = log(1-cx)
	endif
	cz = -zlog
	if ( absc(cz) .lt. xclog2 ) then
	    zdilog = cz
	else
	cz2 = cz*cz
	a = xa**2
	if ( lwarn .and. a .gt. bdn20 ) then
	    call ffwarn(61,ier,precc,abs(bf(20))*a**20)
	endif
	if ( a .gt. bdn15 ) then
	    zdilog = cz2*(DBLE(bf(16)) + cz2*(DBLE(bf(17))
     +		   + cz2*(DBLE(bf(18)) + cz2*(DBLE(bf(19))
     +		   + cz2*(DBLE(bf(20)))))))
	else
	    zdilog = 0
	endif
	if ( a .gt. bdn10 ) then
	    zdilog = cz2*(DBLE(bf(11)) + cz2*(DBLE(bf(12))
     +		   + cz2*(DBLE(bf(13)) + cz2*(DBLE(bf(14))
     +		   + cz2*(DBLE(bf(15)) + zdilog)))))
	endif
	if ( a .gt. bdn05 ) then
	    zdilog = cz2*(DBLE(bf(6)) + cz2*(DBLE(bf(7))
     +		   + cz2*(DBLE(bf(8)) + cz2*(DBLE(bf(9))
     +		   + cz2*(DBLE(bf(10)) + zdilog)))))
	endif
	if ( a .gt. bdn02 ) then
	    zdilog = cz2*(DBLE(bf(3)) + cz2*(DBLE(bf(4))
     +		   + cz2*(DBLE(bf(5)) + zdilog)))
	endif
*	watch the powers of z.
	zdilog = cz + cz2*(DBLE(bf(1)) + cz*(DBLE(bf(2)) + zdilog))
	endif
*  #] get log,dilog:
*  #[ check for numerical problems:
*
*	if we just need the real part the dominant term is xi^2/4
*
	if ( lreal .and. abs(DBLE(zdilog)) .lt. xloss*xi**2/4 ) then
*	    think of something more intelligent later ...
	    x = DBLE(zdilog)
	    if ( lwarn ) call ffwarn(151,ier,x,xi**2/4)
	endif
*  #] check for numerical problems:
*###] ffzli2:
	end
*###[ ffzzdl:
	subroutine ffzzdl(zdilog,ipi12,zlog,cx,ier)
***#[*comment:***************************************************
*								*
*	Computes the dilogarithm (Li2, Sp) for any (complex) cx *
*	to about 15 significant figures. This can be improved	*
*	by adding more of the bf's. For real cx > 1 an error is	*
*	generated as the imaginary part is undefined then.	*
*	For use in ffcdbd zlog = log(1-cx) is also calculated	*
*								*
*	Input:	cx	(complex)				*
*								*
*	Output:	zdilog	(complex) Li2(cx) mod factors pi^2/12	*
*		ipi12	(integer) these factors			*
*		zlog	(complex) log(1-cx)			*
*								*
*	Calls:	log,zfflo1,(d/a)imag,real/dble			*
*								*
***#]*comment:***************************************************
*  #[ declarations:
	implicit none
*
*	arguments
*
	integer ipi12,ier
	DOUBLE COMPLEX zdilog,zlog,cx
*
*	local variables
*
	integer jsgn
	DOUBLE PRECISION xprec,bdn02,bdn05,bdn10,bdn15,bdn20,
     +		xi,xr,s1,s2,xa,a,absc,ffbnd
	DOUBLE COMPLEX cfact,cx1,cy,cz,cz2,zfflo1,c
	save xprec,bdn02,bdn05,bdn10,bdn15,bdn20
*
*	common blocks
*
	include 'ff.h'
*
*	statement function
*
	absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
*  #] declarations:
!$omp threadprivate(xprec,bdn02,bdn05,bdn10,bdn15,bdn20)

*  #[ initialisations:
	data xprec /-1./

	if ( xprec .ne. precc ) then
	    xprec = precc
	    bdn02 = ffbnd(1,2,bf)
	    bdn05 = ffbnd(1,5,bf)
	    bdn10 = ffbnd(1,10,bf)
	    bdn15 = ffbnd(1,15,bf)
	    bdn20 = ffbnd(1,19,bf)
	endif
*  #] initialisations:
*  #[ debug:
*	if ( lwrite ) print *,'ffzzdl(',cx,')'
*  #] debug:
*  #[ exceptional cases:
	xi  = DIMAG(cx)
	xr  = DBLE(cx)
	if ( xi .eq. 0 ) then
	    if ( xr .gt. 1 ) call fferr(31,ier)
	    call ffzxdl(zdilog,ipi12,zlog,xr,1,ier)
	    return
	endif
	if ( abs(xi) .lt. xalog2 ) then
	    s1 = 0
	else
	    s1 = xi**2
	endif
	if ( abs(xr) .lt. xalog2 ) then
	    s2 = 0
	else
	    s2 = xr**2
	endif
	xa = sqrt(s1 + s2)
	if ( xa .lt. precc ) then
	    zdilog = cx
	    zlog = -cx
	    ipi12 = 0
	    return
	endif
*  #] exceptional cases:
*  #[ transform to |x|<1, Re(x) < 0.5:
	if ( xr .le. x05) then
	    if (xa .gt. 1) then
		if ( 1/xa .lt. xalogm ) then
		    cfact = 0
		elseif ( 1/xa .lt. xclogm ) then
		    cx1 = cx*DBLE(1/xa)
		    cfact = log(-cx1) + log(DBLE(xa))
		else
		    cfact = log(-cx)
		endif
		cy = - cfact**2/2
		ipi12 = -2
		if ( xa*xloss**2 .gt. 1) then
		    if ( 1/xa .lt. xclogm ) then
			cx1 = cx*DBLE(1/xa)
			cx1 = 1/cx1
			cx1 = cx1*DBLE(1/xa)
		    else
			cx1 = 1/cx
		    endif
		    cz = -zfflo1(cx1,ier)
		else
		    cz = -log(1-1/cx)
		endif
		zlog = log(1-cx)
		jsgn = -1
	    else
		cy = 0
		ipi12 = 0
		if ( xa .lt. xloss**2 ) then
		    zlog = zfflo1(cx,ier)
		else
		    zlog = log(1-cx)
		endif
		cz = -zlog
		jsgn = 1
	    endif
	else
	    if (xa .le. sqrt(2*xr)) then
		cz = -log(cx)
		if ( abs(xr-1) + abs(xi) .lt. xclogm ) then
		    if ( lwarn )
     +			call ffwarn(65,ier,abs(1-xr)+abs(xi),xclogm)
		    cy = 0
		else
		    zlog = log(1-cx)
		    cy = cz*zlog
		endif
		ipi12 = 2
		jsgn = -1
	    else
		if ( 1/xa .lt. xalogm ) then
		    cfact = 0
		elseif ( 1/xa .lt. xclogm ) then
		    cx1 = cx*DBLE(1/xa)
		    cfact = log(-cx1) + log(DBLE(xa))
		else
		    cfact = log(-cx)
		endif
		cy = - cfact**2/2
		ipi12 = -2
		if ( xa*xloss .gt. 1) then
		    if ( 1/xa .lt. xclogm ) then
			cx1 = cx*DBLE(1/xa)
			cx1 = 1/cx1
			cx1 = cx1*DBLE(1/xa)
		    else
			cx1 = 1/cx
		    endif
		    cz = -zfflo1(cx1,ier)
		else
		    cz = -log(1-1/cx)
		endif
		zlog = log(1-cx)
		jsgn = -1
	    endif
	endif
*  #] transform to |x|<1, Re(x) < 0.5:
*  #[ get dilog:
	if ( absc(cz) .lt. xclogm ) then
	    zdilog = cz
	else
	cz2 = cz*cz
	a = DBLE(cz)**2 + DIMAG(cz)**2
	if ( lwarn .and. a .gt. bdn20 ) then
	    call ffwarn(67,ier,precc,abs(bf(20))*a**20)
	endif
	if ( a .gt. bdn15 ) then
	    zdilog = cz2*(DBLE(bf(16)) + cz2*(DBLE(bf(17))
     +		   + cz2*(DBLE(bf(18)) + cz2*(DBLE(bf(19))
     +		   + cz2*(DBLE(bf(20)))))))
	else
	    zdilog = 0
	endif
	if ( a .gt. bdn10 ) then
	    zdilog = cz2*(DBLE(bf(11)) + cz2*(DBLE(bf(12))
     +		   + cz2*(DBLE(bf(13)) + cz2*(DBLE(bf(14))
     +		   + cz2*(DBLE(bf(15)) + zdilog)))))
	endif
	if ( a .gt. bdn05 ) then
	    zdilog = cz2*(DBLE(bf(6)) + cz2*(DBLE(bf(7))
     +		   + cz2*(DBLE(bf(8)) + cz2*(DBLE(bf(9))
     +		   + cz2*(DBLE(bf(10)) + zdilog)))))
	endif
	if ( a .gt. bdn02 ) then
	    zdilog = cz2*(DBLE(bf(3)) + cz2*(DBLE(bf(4))
     +		   + cz2*(DBLE(bf(5)) + zdilog)))
	endif
*	watch the powers of z.
	zdilog = cz + cz2*(DBLE(bf(1)) + cz*(DBLE(bf(2)) + zdilog))
	endif
	if(jsgn.eq.1)then
	    zdilog =  zdilog + cy
	else
	    zdilog = -zdilog + cy
	endif
*  #] get dilog:
*###] ffzzdl:
	end
*###[ zfflog:
	DOUBLE COMPLEX function zfflog(cx,ieps,cy,ier)
***#[*comment:***********************************************************
*									*
*	Calculate the complex logarithm of cx.  The following cases	*
*	are treted separately:						*
*		|cx| too small:		give warning and return 0	*
*					(for Absoft, Apollo DN300)	*
*		Im(cx) = 0, Re(cx) < 0:	take sign according to ieps	*
*									*
***#]*comment:***********************************************************
*  #[ declarations:
*
*	arguments
*
	implicit none
	integer ieps,ier
	DOUBLE COMPLEX cx,cy
*
*	local variables
*
	DOUBLE COMPLEX c,ctroep
	DOUBLE PRECISION absc,xa,xlog1p
*
*	common blocks, statement function
*
	include 'ff.h'
	absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
*  #] declarations:
*  #[ check input:
	if ( lwarn .and. absc(cx-1) .lt. xloss ) then
	    call ffwarn(128,ier,absc(cx-1),x1)
	endif
*  #] check input:
*  #[ calculations:
	xa = absc(cx)
	if ( xa .lt. xalogm ) then
	    if ( cx .ne. 0 ) call fferr(23,ier)
	    zfflog = 0
	elseif ( DBLE(cx) .lt. 0 .and. DIMAG(cx) .eq. 0 ) then
*     +		 abs(DIMAG(cx)) .lt. precc*abs(DBLE(cx)) ) then
	    xlog1p = log(-DBLE(cx))
*	    checked imaginary parts 19-May-1988
	    if ( abs(ieps) .eq. 1 ) then
		if ( ieps*DBLE(cy) .lt. 0 ) then
		    zfflog = DCMPLX(xlog1p,-pi)
		elseif ( ieps*DBLE(cy) .gt. 0 ) then
		    zfflog = DCMPLX(xlog1p,pi)
		else
		    call fferr(51,ier)
		    zfflog = DCMPLX(xlog1p,pi)
		endif
	    elseif ( ieps .ge. 2 .and. ieps .le. 3 ) then
		zfflog = DCMPLX(xlog1p,-pi)
	    elseif ( ieps .le. -2 .and. ieps .ge. -3 ) then
		zfflog = DCMPLX(xlog1p,pi)
	    else
		call fferr(51,ier)
		zfflog = DCMPLX(xlog1p,pi)
	    endif
	    if ( ltest .and. DIMAG(cx) .ne. 0 ) then
		if ( DIMAG(zfflog) .gt. 0 .neqv. DIMAG(cx) .gt. 0 )
     +		    call fferr(56,ier)
	    endif
	elseif ( xa .lt. xclogm .or. 1/xa .lt. xclogm ) then
	    ctroep = cx*DBLE(1/xa)
	    zfflog = log(ctroep) + DBLE(log(xa))
	else
*	    print *,'zfflog: neem log van ',cx
	    zfflog = log(cx)
	endif
*  #] calculations:
*###] zfflog:
	end
*###[ zfflo1:
	DOUBLE COMPLEX function zfflo1(cx,ier)
***#[*comment:***************************************************
*	calculates log(1-x) for |x|<.14 in a faster way to ~15	*
*	significant figures.					*
***#]*comment:***************************************************
*  #[ declarations:
	implicit none
	integer ier
	DOUBLE COMPLEX cx,c,zfflog
	DOUBLE PRECISION xprec,bdn01,bdn05,bdn10,bdn15,bdn19,
     +		absc,xa,ffbnd
	save xprec,bdn01,bdn05,bdn10,bdn15,bdn19
	include 'ff.h'
	absc(c) = abs(DBLE(c)) + abs(DIMAG(c))
*  #] declarations:
!$omp threadprivate(xprec,bdn01,bdn05,bdn10,bdn15,bdn19)

*  #[ initialisations:
	data xprec /-1./

	if ( precc .ne. xprec ) then
	    xprec = precc
*	    determine the boundaries for 1,5,10,15 terms
	    bdn01 = ffbnd(1,1,xninv)
	    bdn05 = ffbnd(1,5,xninv)
	    bdn10 = ffbnd(1,10,xninv)
	    bdn15 = ffbnd(1,15,xninv)
	    bdn19 = ffbnd(1,19,xninv)
	endif
*  #] initialisations:
*  #[ calculations:
	xa = absc(cx)
	if ( xa .gt. bdn19 ) then
	    if ( lwarn .and. xa .lt. xloss ) call ffwarn(63,ier,xa,x1)
	    c = cx-1
	    xa = absc(c)
	    if ( lwarn .and. xa .lt. xloss ) call ffwarn(133,ier,xa,x1)
	    zfflo1 = zfflog(1-cx,0,c0,ier)
	    return
	endif
	if ( xa .gt. bdn15 ) then
	    zfflo1 = cx*( DBLE(xninv(16)) + cx*( DBLE(xninv(17))
     +		   + cx*( DBLE(xninv(18)) + cx*( DBLE(xninv(19))
     +		   + cx*( DBLE(xninv(20)) )))))
	else
	    zfflo1 = 0
	endif
	if ( xa .gt. bdn10 ) then
	    zfflo1 = cx*( DBLE(xninv(11)) + cx*( DBLE(xninv(12))
     +		   + cx*( DBLE(xninv(13)) + cx*( DBLE(xninv(14))
     +		   + cx*( DBLE(xninv(15)) + zfflo1 )))))
	endif
	if ( xa .gt. bdn05 ) then
	    zfflo1 = cx*( DBLE(xninv(6)) + cx*( DBLE(xninv(7))
     +		   + cx*( DBLE(xninv(8)) + cx*( DBLE(xninv(9))
     +		   + cx*( DBLE(xninv(10)) + zfflo1 )))))
	endif
	if ( xa .gt. bdn01 ) then
	    zfflo1 = cx*( DBLE(xninv(2)) + cx*( DBLE(xninv(3))
     +		   + cx*( DBLE(xninv(4)) + cx*( DBLE(xninv(5))
     +		   + zfflo1 ))))
	endif
	zfflo1 = - cx*( DBLE(xninv(1)) + zfflo1 )
*  #] calculations:
*###] zfflo1:
	end
*###[ zfflo2:
	DOUBLE COMPLEX function zfflo2(x,ier)
***#[*comment:***************************************************
*	calculates log(1-x)+x for |x|<.14 in a faster way to	*
*	~15 significant figures.				*
***#]*comment:***************************************************
*  #[ declarations:
	implicit none
	integer ier,ier0
	DOUBLE COMPLEX x,d1,zfflo1,cc
	DOUBLE PRECISION bdn01,bdn05,bdn10,bdn15,bdn18,xprec,xa,xheck,
     +		ffbnd,absc
	save xprec,bdn01,bdn05,bdn10,bdn15,bdn18
	include 'ff.h'
	absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
*  #] declarations:
*  #[ initialisation:
	data xprec /-1./
!$omp threadprivate(xprec,bdn01,bdn05,bdn10,bdn15,bdn18)

	if ( xprec .ne. precc ) then
	    xprec = precx
	    precx = precc
*	    determine the boundaries for 1,5,10,15 terms
	    bdn01 = ffbnd(1,1,xninv(2))
	    bdn05 = ffbnd(1,5,xninv(2))
	    bdn10 = ffbnd(1,10,xninv(2))
	    bdn15 = ffbnd(1,15,xninv(2))
	    bdn18 = ffbnd(1,18,xninv(2))
	    precx = xprec
	    xprec = precc
	endif
*  #] initialisation:
*  #[ calculations:
	xa = absc(x)
	if ( xa .gt. bdn18 ) then
	    zfflo2 = zfflo1(x,ier) + x
	    if ( lwarn .and. absc(zfflo2).lt.xloss*abs(x) )
     +		call ffwarn(234,ier,absc(zfflo2),absc(x))
	    return
	endif
	if ( xa .gt. bdn15 ) then
	    zfflo2 = x*( DBLE(xninv(17)) + x*( DBLE(xninv(18)) +
     +		x*( DBLE(xninv(19)) + x*( DBLE(xninv(20)) ))))
	else
	    zfflo2 = 0
	endif
	if ( xa .gt. bdn10 ) then
	    zfflo2 = x*( DBLE(xninv(12)) + x*( DBLE(xninv(13)) +
     +		x*( DBLE(xninv(14)) + x*( DBLE(xninv(15)) +
     +		x*( DBLE(xninv(16)) + zfflo2 )))))
	endif
	if ( xa .gt. bdn05 ) then
	    zfflo2 = x*( DBLE(xninv(7)) + x*( DBLE(xninv(8)) +
     +		x*( DBLE(xninv(9)) +x*( DBLE(xninv(10)) +
     +		x*( DBLE(xninv(11)) + zfflo2 )))))
	endif
	if ( xa .gt. bdn01 ) then
	    zfflo2 = x*( DBLE(xninv(3)) + x*( DBLE(xninv(4)) +
     +		x*( DBLE(xninv(5)) + x*( DBLE(xninv(6)) + zfflo2 ))))
	endif
	zfflo2 = - x**2*( DBLE(xninv(2)) + zfflo2 )
*  #] calculations:
*  #[ check output:
	if ( ltest ) then
	    ier0 = ier
	    d1 = zfflo1(x,ier0) + x
	    xheck = absc(d1-zfflo2)
	    if ( xloss*abs(xheck) .gt. precc ) print *,'zfflo2: error:',
     +		' answer is not OK',d1,zfflo2,xheck
	endif
*  #] check output:
*###] zfflo2:
	end
*###[ zfflo3:
	DOUBLE COMPLEX function zfflo3(x,ier)
***#[*comment:***************************************************
*	calculates log(1-x)+x+x^2/2 for |x|<.14 in a faster 	*
*	way to ~15 significant figures.				*
***#]*comment:***************************************************
*  #[ declarations:
	implicit none
	integer ier,ier0
	DOUBLE COMPLEX x,d1,zfflo2,cc
	DOUBLE PRECISION bdn01,bdn05,bdn10,bdn15,xprec,xa,xheck,ffbnd,
     +		absc
	save xprec,bdn01,bdn05,bdn10,bdn15
	include 'ff.h'
	absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
*  #] declarations:
*  #[ initialisation:
	data xprec /-1./
!$omp threadprivate(xprec,bdn01,bdn05,bdn10,bdn15)

	if ( xprec .ne. precx ) then
	    xprec = precx
	    precx = precc
*	    determine the boundaries for 1,5,10,15 terms
	    bdn01 = ffbnd(1,1,xninv(3))
	    bdn05 = ffbnd(1,5,xninv(3))
	    bdn10 = ffbnd(1,10,xninv(3))
	    bdn15 = ffbnd(1,15,xninv(3))
	    precx = xprec
	    xprec = precc
	endif
*  #] initialisation:
*  #[ calculations:
	xa = absc(x)
	if ( xa .gt. bdn15 ) then
	    zfflo3 = zfflo2(x,ier) + x**2/2
	    if ( lwarn .and. absc(zfflo3).lt.xloss*absc(x**2)/2 )
     +		call ffwarn(235,ier,absc(zfflo3),absc(x**2/2))
	    return
	endif
	if ( xa .gt. bdn10 ) then
	    zfflo3 = x*( DBLE(xninv(13)) + x*( DBLE(xninv(14)) +
     +		x*( DBLE(xninv(15)) + x*( DBLE(xninv(16)) +
     +		x*( DBLE(xninv(17)) )))))
	else
	    zfflo3 = 0
	endif
	if ( xa .gt. bdn05 ) then
	    zfflo3 = x*( DBLE(xninv(8)) + x*( DBLE(xninv(9)) +
     +		x*( DBLE(xninv(10)) + x*( DBLE(xninv(11)) +
     +		x*( DBLE(xninv(12)) + zfflo3 )))))
	endif
	if ( xa .gt. bdn01 ) then
	    zfflo3 = x*( DBLE(xninv(4)) + x*( DBLE(xninv(5)) +
     +		x*( DBLE(xninv(6)) + x*( DBLE(xninv(7)) + zfflo3 ))))
	endif
	zfflo3 = - x**3*( DBLE(xninv(3)) + zfflo3 )
*  #] calculations:
*  #[ check output:
	if ( ltest ) then
	    ier0 = ier
	    d1 = zfflo2(x,ier0) + x**2/2
	    xheck = absc(d1-zfflo3)
	    if ( xloss*abs(xheck) .gt. precc ) print *,'zfflo3: error:',
     +		' answer is not OK',d1,zfflo3,xheck
	endif
*  #] check output:
*###] zfflo3:
	end
*###[ zff0li:
	DOUBLE COMPLEX function zff0li(r2)
***#[*comment:***********************************************************
*									*
*	computes complex value z such that  abs(z)**2 = r2 < 1		*
*	and Re(Li2(z))=0						*
*	written by P.Noguiero (Lisboa)					*									*
*									*
***#]*comment:***********************************************************
*  #[ declarations:
	implicit none
*
*	arguments
*
	DOUBLE PRECISION r2
*
*	local variables
*
	integer i
	DOUBLE PRECISION c1(30),c2(30),zr,zx
	save c1,c2
*
*	common blocks
*
*  #] declarations:
!$omp threadprivate(c1,c2)

*  #[ data:
*
	data c1(1) / 0.2500000000000000 /
	data c1(2) / -1.0416666666666667D-02 /
	data c1(3) / 1.2152777777777778D-03 /
	data c1(4) / -2.1959738756613757D-04 /
	data c1(5) / 4.9439553020282187D-05 /
	data c1(6) / -1.2675094665654561D-05 /
	data c1(7) / 3.5389820153701292D-06 /
	data c1(8) / -1.0493857656770419D-06 /
	data c1(9) / 3.2537695998679074D-07 /
	data c1(10) / -1.0442280388149559D-07 /
	data c1(11) / 3.4441733990714665D-08 /
	data c1(12) / -1.1615493272944038D-08 /
	data c1(13) / 3.9902649974583553D-09 /
	data c1(14) / -1.3922421108836989D-09 /
	data c1(15) / 4.9225507537640102D-10 /
	data c1(16) / -1.7605266995285916D-10 /
	data c1(17) / 6.3596990550536869D-11 /
	data c1(18) / -2.3176654407515461D-11 /
	data c1(19) / 8.5124040210417827D-12 /
	data c1(20) / -3.1483106624053104D-12 /
	data c1(21) / 1.1717062820424101D-12 /
	data c1(22) / -4.3854323145311313D-13 /
	data c1(23) / 1.6498013217746003D-13 /
	data c1(24) / -6.2356193829603354D-14 /
	data c1(25) / 2.3669242668432088D-14 /

	data c2(1) / 0.2500000000000000 /
	data c2(2) / 5.2083333333333333D-02 /
	data c2(3) / 6.4236111111111111D-03 /
	data c2(4) / 4.7484705687830688D-04 /
	data c2(5) / 1.4303971009700176D-05 /
	data c2(6) / -1.1031735071448613D-06 /
	data c2(7) / -1.6930087449913219D-07 /
	data c2(8) / -9.5437325895661167D-09 /
	data c2(9) / -1.1765492620111313D-10 /
	data c2(10) / 1.5727493777091249D-11 /
	data c2(11) / 6.7654901409698409D-13 /
	data c2(12) / -4.6807758765169774D-15 /
	data c2(13) / -2.4871711489610564D-15 /
	data c2(14) / -1.3622942781034796D-16 /
	data c2(15) / 3.8201988176071429D-17 /
	data c2(16) / -3.2258659308514033D-19 /
	data c2(17) / -4.5613496077409173D-19 /
	data c2(18) / 5.1177130568324641D-20 /
	data c2(19) / 5.4099028875697205D-22 /
	data c2(20) / -8.5181489051619174D-22 /
	data c2(21) / 9.6732395493921367D-23 /
	data c2(22) / 2.1141447009853665D-24 /
	data c2(23) / -1.8622848688015854D-24 /
	data c2(24) / 1.9077807703926496D-25 /
	data c2(25) / 8.0274683356039559E-27 /
*
*  #] data:
*  #[ work:
*
	if ( abs(r2).le.0.1d0)t h en
	    zx = 0
	    do i=10,1,-1
		zx = r2*(zx+c1(i))
	    enddo
	elseif ( abs(r2).le.0.5d0 ) then
	    zx = 0
	    do i=20,1,-1
		zx = r2*(zx+c1(i))
	    enddo
	elseif ( abs(r2).le.1.0d0 ) then
	    zr = 2*log(1 + r2/2)
	    zx = 0
	    do i=13,1,-1
		zx = zr*(zx+c2(i))
	    enddo
	else
	    print *,'zff0li: error: argumnet must <= 1, not ',r2
	    zx = 0
	endif

	zff0li = DCMPLX(zx,sqrt(r2-zx*zx))
*
*  #] work:
*###] zff0li:
	end


      FUNCTION QAS(H,XL,A,Z,PFISH,IFISH)
*
*-----------------------------------------------------------------------
*
* THIS ROUTINE COMPUTES THE ASYMPTOTIC PARTS OF THE PARTITION
* FUNCTIONS FOLLOWING
*  BASCHEK ET AL., ABH. HAMB. VIII, 26 (1966) IF IFISH = 0
*  FISCHEL AND SPARKS, AP. J. 164, 359 (1971) IF IFISH = 1
*         (APPROXIMATING THE ZETA FUNCTIONS BY INTEGRALS).
*
* Export version  1988-03-24  ********* Olof Morell *** Uppsala
*
* XL=QUANTUM NUMBER FOR THE FIRST LEVEL OF THE ASYMPTOTIC PART
* H=QUANTUM NUMBER OF THE CUT (FOR IFISH=0)
* A=DZ(FISCHEL AND SPARKS)=ALFA(BASCHEK ET AL.)
* PFISH=P(FISCHEL AND SPARKS), ONLY NECESSARY IF IFISH = 1
*
*-----------------------------------------------------------------------
*
      COMMON/UTPUT/ IREAD,IWRIT
*
* WHICH TYPE
*
      IF(IFISH.GT.0) GOTO 1
*
* BASCHEK ET AL.
*
      QAS=0.333333*(H*(H+1.)*(H+0.5)-XL*(XL+1.)*(XL+0.5)) +
     &                       A*(H-XL)+0.5*A*A*(H-XL)/(H*XL)
*
      RETURN
*
* FISCHEL AND SPARKS
*
    1 P=PFISH*Z
      IF(P.LE.XL) GOTO 2
*
* FISCHEL AND SPARKS, EQ. (26)
*
      P2=P*P
      P3=P2*P
      XLM1=XL-1.
      R2=XLM1*XLM1
      R3=R2*XLM1
      QAS=1.3333333*P3+0.5*P2+0.16666667*P+1.33333333*A*P-0.4*A*A/P-
     &    0.33333333*R3-0.5*R2-0.16666667*XLM1-A*XLM1+0.5*A*A/XL
*
      RETURN
*
* FISCHEL AND SPARKS, EQ. (27)
*
    2 AXL2=A/(XL*XL)
      QAS=P3*P/XL*(1.+AXL2*(0.33333333+0.1*AXL2))
*
      RETURN
      END


!  Check in_pack and in_unpack for integer and comlex types, with
!  alignment issues thrown in for good measure.

program main
  implicit none

  complex(kind=4) :: a4(5),b4(5),aa4(5),bb4(5)
  real(kind=4) :: r4(100)
  equivalence(a4(1),r4(1)),(b4(1),r4(12))

  complex(kind=8) :: a8(5),b8(5),aa8(5),bb8(5)
  real(kind=8) :: r8(100)
  equivalence(a8(1),r8(1)),(b8(1),r8(12))

  integer(kind=4) :: i4(5),ii4(5)
  integer(kind=8) :: i8(5),ii8(5)

  integer :: i

  a4 = (/(cmplx(i,-i,kind=4),i=1,5)/)
  b4 = (/(2*cmplx(i,-i,kind=4),i=1,5)/)
  call csub4(a4(5:1:-1),b4(5:1:-1),5)
  aa4 = (/(cmplx(5-i+1,i-5-1,kind=4),i=1,5)/)
  if (any(aa4 /= a4)) call abort
  bb4 = (/(2*cmplx(5-i+1,i-5-1,kind=4),i=1,5)/)
  if (any(bb4 /= b4)) call abort

  a8 = (/(cmplx(i,-i,kind=8),i=1,5)/)
  b8 = (/(2*cmplx(i,-i,kind=8),i=1,5)/)
  call csub8(a8(5:1:-1),b8(5:1:-1),5)
  aa8 = (/(cmplx(5-i+1,i-5-1,kind=8),i=1,5)/)
  if (any(aa8 /= a8)) call abort
  bb8 = (/(2*cmplx(5-i+1,i-5-1,kind=8),i=1,5)/)
  if (any(bb8 /= b8)) call abort

  i4 = (/(i, i=1,5)/)
  call isub4(i4(5:1:-1),5)
  ii4 = (/(5-i+1,i=1,5)/)
  if (any(ii4 /= i4)) call abort

  i8 = (/(i,i=1,5)/)
  call isub8(i8(5:1:-1),5)
  ii8 = (/(5-i+1,i=1,5)/)
  if (any(ii8 /= i8)) call abort

end program main

subroutine csub4(a,b,n)
  implicit none
  complex(kind=4), dimension(n) :: a,b
  complex(kind=4), dimension(n) :: aa, bb
  integer :: n, i
  aa = (/(cmplx(n-i+1,i-n-1,kind=4),i=1,n)/)
  if (any(aa /= a)) call abort
  bb = (/(2*cmplx(n-i+1,i-n-1,kind=4),i=1,5)/)
  if (any(bb /= b)) call abort
  a = (/(cmplx(i,-i,kind=4),i=1,5)/)
  b = (/(2*cmplx(i,-i,kind=4),i=1,5)/)
end subroutine csub4

subroutine csub8(a,b,n)
  implicit none
  complex(kind=8), dimension(n) :: a,b
  complex(kind=8), dimension(n) :: aa, bb
  integer :: n, i
  aa = (/(cmplx(n-i+1,i-n-1,kind=8),i=1,n)/)
  if (any(aa /= a)) call abort
  bb = (/(2*cmplx(n-i+1,i-n-1,kind=8),i=1,5)/)
  if (any(bb /= b)) call abort
  a = (/(cmplx(i,-i,kind=8),i=1,5)/)
  b = (/(2*cmplx(i,-i,kind=8),i=1,5)/)
end subroutine csub8

subroutine isub4(a,n)
  implicit none
  integer(kind=4), dimension(n) :: a
  integer(kind=4), dimension(n) :: aa
  integer :: n, i
  aa = (/(n-i+1,i=1,n)/)
  if (any(aa /= a)) call abort
  a = (/(i,i=1,5)/)
end subroutine isub4

subroutine isub8(a,n)
  implicit none
  integer(kind=8), dimension(n) :: a
  integer(kind=8), dimension(n) :: aa
  integer :: n, i
  aa = (/(n-i+1,i=1,n)/)
  if (any(aa /= a)) call abort
  a = (/(i,i=1,5)/)
end subroutine isub8


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! DOHFQR (Double Orthogonal Hessenberg Fast QR eigensolver)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine computes the eigenvalues and optionally eigenvectors
! of a real orthogonal upper hessenberg matrix.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  COMPZ           CHARACTER
!                    'N': do not compute eigenvectors
!                    'I': stores eigenvectors, initializing Z to the identity
!                    'V': stores eigenvectors, assume Z already initialized
!
!  N               INTEGER
!                    dimension of matrix
!
!  H               Real(8) array of dimension (N,N)
!                    orthogonal hessenberg matrix, assumed that H(ii,jj) = 0 for |ii-jj| > 0
!                    on exit contains a block diagonal matrix with blocks no greater than 2x2.
!
!  WORK            REAL(8) array of dimension (4*N)
!                    work space for eigensolver
!
! OUTPUT VARIABLES:
!
!  Z              REAL(8) array of dimension (N,N)
!                    if COMPZ = 'N' unused
!                    if COMPZ = 'I' stores eigenvectors, initializing to identity
!                    if COMPZ = 'V' stores eigenvectors, assume Z already initialized
!
!  ITS            INTEGER array of dimension (N-1)
!                    Contains the number of iterations per deflation
!
!  INFO           INTEGER
!                    INFO = 2 implies DOFFQR failed
!                    INFO = 1 implies DOHRFF failed
!                    INFO = 0 implies successful computation
!                    INFO = -1 implies COMPZ is invalid
!                    INFO = -2 implies N is invalid
!                    INFO = -3 implies H is invalid
!                    INFO = -4 implies Z is invalid
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine DOHFQR(COMPZ,N,H,Z,ITS,WORK,INFO)

  implicit none

  ! input variables
  character, intent(in) :: COMPZ
  integer, intent(in) :: N
  real(8), intent(inout) :: WORK(4*N)
  integer, intent(inout) :: ITS(N-1), INFO
  real(8), intent(inout) :: H(N,N), Z(N,N)

  ! compute variables
  integer :: ii,cpair
  real(8) :: c,s

  ! initialize INFO
  INFO = 0

  ! check COMPZ
  if ((COMPZ.NE.'N').AND.(COMPZ.NE.'I').AND.(COMPZ.NE.'V')) then
    INFO = -1
    ! print error in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"COMPZ must be 'N', 'I' or 'V'",INFO,INFO)
    end if
    return
  end if

  ! check N
  call IARNAN(N,INFO)
  if (INFO.NE.0) then
    ! print error in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"N is invalid",INFO,INFO)
    end if
    INFO = -2
    return
  end if
  call IARINF(N,INFO)
  if (INFO.NE.0) then
    ! print error in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"N is invalid",INFO,INFO)
    end if
    INFO = -2
    return
  end if
  if (N < 2) then
    INFO = -2
    ! print error in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"N must be at least 2",INFO,INFO)
    end if
    return
  end if

  ! check H
  call DARACH2(N,N,H,INFO)
  if (INFO.NE.0) then
    ! print error in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"H is invalid",INFO,INFO)
    end if
    INFO = -3
    return
  end if

  ! check Z
  if (COMPZ.EQ.'V') then
    call DARACH2(N,N,Z,INFO)
    if (INFO.NE.0) then
      ! print error in debug mode
      if (DEBUG) then
        call UARERR(__FILE__,__LINE__,"Z is invalid",INFO,INFO)
      end if
      INFO = -4
      return
    end if
  end if

  ! compress H
  call DOHRFF(N,H,WORK(1:(2*N)),WORK((2*N+1):(4*N)),INFO)
  if (INFO.NE.0) then
    ! print error in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"DOHRFF",INFO,INFO)
    end if
    INFO = 1
    return
  end if

  ! compute eigenvalues
  call DOFFQR(COMPZ,N,WORK(1:(2*N)),WORK((2*N+1):(4*N)),Z,ITS,INFO)
  if (INFO.NE.0) then
    ! print error in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"DOFFQR failed",INFO,INFO)
    end if
    INFO = 2
    return
  end if

  ! update H
  cpair = 0
  H = 0d0
  do ii=1,N
    c = WORK((2*N)+2*(ii-1)+1)
    s = WORK((2*N)+2*(ii-1)+2)
    if (abs(s).EQ.0d0) then
      H(ii,ii) = c
    else if (cpair.EQ.0) then
      H(ii,ii) = c
      H(ii,ii+1) = s
      H(ii+1,ii) = -s
      H(ii+1,ii+1) = c
      cpair = 1
    else
      cpair = 0
    end if
  end do

end subroutine DOHFQR


      subroutine wdpow(n,vr,vi,iv,dpow,ierr)
c!but
c     eleve les elements d'un vecteur complexe a une puissance reelle
c!liste d'appel
c     subroutine wdpow(n,vr,vi,iv,dpow,ierr)
c     integer n,iv,ierr
c     double precision vr(n*iv),vi(n*iw),dpow
c
c     n : nombre d'element du vecteur
c     vr : tableau contenant les parties reelles des elements du vecteur
c     vi : tableau contenant les parties imaginaires des elements du vecteur
c     iv : increment entre deux element consecutif du vecteur dans le
c          tableau v
c     dpow :  la puissance a la quelle doivent etre
c            eleves les elements du vecteur
c     ierr : indicateur d'erreur
c            ierr=0 si ok
c            ierr=1 si 0**0
c            ierr=2 si 0**k avec k<0
c!origine
c Serge Steer INRIA 1989
c!
c     Copyright INRIA
      integer n,iv,ierr
      double precision vr(*),vi(*),dpow,sr,si
c
      ierr=0
c
      if(dble(int(dpow)).ne.dpow) goto 01
c     puissance entieres
      call wipow(n,vr,vi,iv,int(dpow),ierr)
      return
c
 01   continue
c     puissance reelles
      ii=1
      do 20 i=1,n
         if(abs(vr(ii))+abs(vi(ii)).ne.0.0d+0) then
            call wlog(vr(ii),vi(ii),sr,si)
            sr=exp(sr*dpow)
            si=si*dpow
            vr(ii)=sr*cos(si)
            vi(ii)=sr*sin(si)
            ii=ii+iv
         else
            if(dpow.gt.0.0d+0) then
               vr(ii)=0.0d+0
               vi(ii)=0.0d+0
               ii=ii+iv
            else
               ierr=2
            endif
            return
         endif
 20   continue
c
      return
      end


FUNCTION bvn ( lower, upper, infin, correl ) RESULT(fn_val)

!     A function for computing bivariate normal probabilities.
!     Extracted from Alan Genz's package for multivariate normal integration.

!  Parameters

!     LOWER  REAL, array of lower integration limits.
!     UPPER  REAL, array of upper integration limits.
!     INFIN  INTEGER, array of integration limits flags:
!            if INFIN(I) = 0, Ith limits are (-infinity, UPPER(I)];
!            if INFIN(I) = 1, Ith limits are [LOWER(I), infinity);
!            if INFIN(I) = 2, Ith limits are [LOWER(I), UPPER(I)].
!     CORREL REAL, correlation coefficient.

IMPLICIT NONE
INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(12, 60)

REAL (dp), INTENT(IN) :: lower(:), upper(:), correl
INTEGER, INTENT(IN)   :: infin(:)
REAL (dp)             :: fn_val

REAL (dp), PARAMETER  :: zero = 0.0_dp, one = 1.0_dp

IF ( infin(1) == 2  .AND. infin(2) == 2 ) THEN
  fn_val =  bvnu ( lower(1), lower(2), correl )    &
            - bvnu ( upper(1), lower(2), correl )  &
            - bvnu ( lower(1), upper(2), correl )  &
            + bvnu ( upper(1), upper(2), correl )
ELSE IF ( infin(1) == 2  .AND. infin(2) == 1 ) THEN
  fn_val =  bvnu ( lower(1), lower(2), correl )  &
            - bvnu ( upper(1), lower(2), correl )
ELSE IF ( infin(1) == 1  .AND. infin(2) == 2 ) THEN
  fn_val =  bvnu ( lower(1), lower(2), correl )  &
            - bvnu ( lower(1), upper(2), correl )
ELSE IF ( infin(1) == 2  .AND. infin(2) == 0 ) THEN
  fn_val =  bvnu ( -upper(1), -upper(2), correl )  &
            - bvnu ( -lower(1), -upper(2), correl )
ELSE IF ( infin(1) == 0  .AND. infin(2) == 2 ) THEN
  fn_val =  bvnu ( -upper(1), -upper(2), correl )  &
            - bvnu ( -upper(1), -lower(2), correl )
ELSE IF ( infin(1) == 1  .AND. infin(2) == 0 ) THEN
  fn_val =  bvnu ( lower(1), -upper(2), -correl )
ELSE IF ( infin(1) == 0  .AND. infin(2) == 1 ) THEN
  fn_val =  bvnu ( -upper(1), lower(2), -correl )
ELSE IF ( infin(1) == 1  .AND. infin(2) == 1 ) THEN
  fn_val =  bvnu ( lower(1), lower(2), correl )
ELSE IF ( infin(1) == 0  .AND. infin(2) == 0 ) THEN
  fn_val =  bvnu ( -upper(1), -upper(2), correl )
END IF

RETURN

CONTAINS

FUNCTION bvnu( sh, sk, r ) RESULT(fn_val)

!     A function for computing bivariate normal probabilities.

!       Yihong Ge
!       Department of Computer Science and Electrical Engineering
!       Washington State University
!       Pullman, WA 99164-2752
!       Email : yge@eecs.wsu.edu
!     and
!       Alan Genz
!       Department of Mathematics
!       Washington State University
!       Pullman, WA 99164-3113
!       Email : alangenz@wsu.edu

! BVN - calculate the probability that X is larger than SH and Y is
!       larger than SK.

! Parameters

!   SH  REAL, integration limit
!   SK  REAL, integration limit
!   R   REAL, correlation coefficient
!   LG  INTEGER, number of Gauss Rule Points and Weights

REAL (dp), INTENT(IN) :: sh, sk, r
REAL (dp)             :: fn_val

! Local variables
INTEGER              :: i, lg, ng
REAL (dp), PARAMETER :: twopi = 6.283185307179586
REAL (dp)            :: as, a, b, c, d, rs, xs
REAL (dp)            :: bvn, sn, asr, h, k, bs, hs, hk
!     Gauss Legendre Points and Weights, N =  6
! DATA ( w(i,1), x(i,1), i = 1,3) /  &
! 0.1713244923791705D+00,-0.9324695142031522D+00,  &
! 0.3607615730481384D+00,-0.6612093864662647D+00,  &
! 0.4679139345726904D+00,-0.2386191860831970D+00/
!     Gauss Legendre Points and Weights, N = 12
! DATA ( w(i,2), x(i,2), i = 1,6) /  &
! 0.4717533638651177D-01,-0.9815606342467191D+00,  &
! 0.1069393259953183D+00,-0.9041172563704750D+00,  &
! 0.1600783285433464D+00,-0.7699026741943050D+00,  &
! 0.2031674267230659D+00,-0.5873179542866171D+00,  &
! 0.2334925365383547D+00,-0.3678314989981802D+00,  &
! 0.2491470458134029D+00,-0.1252334085114692D+00/
!     Gauss Legendre Points and Weights, N = 20
! DATA ( w(i,3), x(i,3), i = 1,10) /  &
! 0.1761400713915212D-01,-0.9931285991850949D+00,  &
! 0.4060142980038694D-01,-0.9639719272779138D+00,  &
! 0.6267204833410906D-01,-0.9122344282513259D+00,  &
! 0.8327674157670475D-01,-0.8391169718222188D+00,  &
! 0.1019301198172404D+00,-0.7463319064601508D+00,  &
! 0.1181945319615184D+00,-0.6360536807265150D+00,  &
! 0.1316886384491766D+00,-0.5108670019508271D+00,  &
! 0.1420961093183821D+00,-0.3737060887154196D+00,  &
! 0.1491729864726037D+00,-0.2277858511416451D+00,  &
! 0.1527533871307259D+00,-0.7652652113349733D-01/
REAL (dp), PARAMETER :: w(10,3) = RESHAPE( (/      &
      0.1713244923791705D+00, 0.3607615730481384D+00, 0.4679139345726904D+00, &
        0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,                  &
      0.4717533638651177D-01, 0.1069393259953183D+00, 0.1600783285433464D+00, &
      0.2031674267230659D+00, 0.2334925365383547D+00, 0.2491470458134029D+00, &
       0.0D0, 0.0D0, 0.0D0, 0.0D0,                        &
      0.1761400713915212D-01, 0.4060142980038694D-01, 0.6267204833410906D-01, &
      0.8327674157670475D-01, 0.1019301198172404D+00, 0.1181945319615184D+00, &
      0.1316886384491766D+00, 0.1420961093183821D+00, 0.1491729864726037D+00, &
      0.1527533871307259D+00 /), (/ 10, 3 /) )
REAL (dp), PARAMETER :: x(10,3) = RESHAPE( (/      &
      -0.9324695142031522D+00, -0.6612093864662647D+00,   &
      -0.2386191860831970D+00,  0.0D0, 0.0D0, 0.0D0,      &
       0.0D0, 0.0D0, 0.0D0, 0.0D0,                        &
      -0.9815606342467191D+00, -0.9041172563704750D+00,   &
      -0.7699026741943050D+00, -0.5873179542866171D+00,   &
      -0.3678314989981802D+00, -0.1252334085114692D+00,   &
       0.0D0, 0.0D0, 0.0D0, 0.0D0,                        &
      -0.9931285991850949D+00, -0.9639719272779138D+00,   &
      -0.9122344282513259D+00, -0.8391169718222188D+00,   &
      -0.7463319064601508D+00, -0.6360536807265150D+00,   &
      -0.5108670019508271D+00, -0.3737060887154196D+00,   &
      -0.2277858511416451D+00, -0.7652652113349733D-01 /), (/ 10, 3 /) )

IF ( ABS(r) < 0.3 ) THEN
  ng = 1
  lg = 3
ELSE IF ( ABS(r) < 0.75 ) THEN
  ng = 2
  lg = 6
ELSE
  ng = 3
  lg = 10
END IF
h = sh
k = sk
hk = h*k
bvn = zero
IF ( ABS(r) < 0.925 ) THEN
  hs = ( h*h + k*k )/2
  asr = ASIN(r)
  DO  i = 1, lg
    sn = SIN(asr*( x(i,ng)+1 )/2)
    bvn = bvn + w(i,ng)*EXP( ( sn*hk - hs )/(one - sn*sn ) )
    sn = SIN(asr*(-x(i,ng)+1 )/2)
    bvn = bvn + w(i,ng)*EXP( ( sn*hk - hs )/(one - sn*sn ) )
  END DO
  bvn = bvn*asr/(2*twopi) + phi(-h)*phi(-k)
ELSE
  IF ( r < zero ) THEN
    k = -k
    hk = -hk
  END IF
  IF ( ABS(r) < one ) THEN
    as = ( one - r )*( one + r )
    a = SQRT(as)
    bs = ( h - k )**2
    c = ( 4. - hk )/8
    d = ( 12. - hk )/16.
    bvn = a*EXP( -(bs/as + hk)/2. )  &
    *( one - c*(bs - as)*(one - d*bs/5.)/3. + c*d*as*as/5. )
    IF ( hk > -160. ) THEN
      b = SQRT(bs)
      bvn = bvn - EXP(-hk/2)*SQRT(twopi)*phi(-b/a)*b  &
                      *( one - c*bs*( one - d*bs/5. )/3. )
    END IF
    a = a/2
    DO i = 1, lg
      xs = ( a*(x(i,ng) + one) )**2
      rs = SQRT( one - xs )
      bvn = bvn + a*w(i,ng)*( EXP( -bs/(2*xs) - hk/(1+rs) )/rs  &
                - EXP( -(bs/xs+hk)/2. )*( one + c*xs*( one + d*xs ) ) )
      xs = as*(-x(i,ng) + one)**2/4.
      rs = SQRT( 1 - xs )
      bvn = bvn + a*w(i,ng)*EXP( -(bs/xs + hk)/2 )  &
                * ( EXP( -hk*(one - rs)/(2*(one + rs)) )/rs - &
                       ( one + c*xs*( one + d*xs ) ) )
    END DO
    bvn = -bvn/twopi
  END IF
  IF ( r > 0 ) bvn =  bvn + phi( -MAX( h, k ) )
  IF ( r < 0 ) bvn = -bvn + MAX( zero, phi(-h) - phi(-k) )
END IF
fn_val = bvn

RETURN
END FUNCTION bvnu

SUBROUTINE normp(z, p, q, pdf)

! Normal distribution probabilities accurate to 1.e-15.
! Z = no. of standard deviations from the mean.
! P, Q = probabilities to the left & right of Z.   P + Q = 1.
! PDF = the probability density.

! Based upon algorithm 5666 for the error function, from:
! Hart, J.F. et al, 'Computer Approximations', Wiley 1968

! Programmer: Alan Miller

! Latest revision of Fortran 77 version - 30 March 1986
! Latest revision of Fortran 90 version - 12 August 1997

IMPLICIT NONE
REAL (dp), INTENT(IN)            :: z
REAL (dp), INTENT(OUT), OPTIONAL :: p, q, pdf

! Local variables
REAL (dp), PARAMETER :: p0 = 220.2068679123761D0, p1 = 221.2135961699311D0,  &
                        p2 = 112.0792914978709D0, p3 = 33.91286607838300D0,  &
                        p4 = 6.373962203531650D0, p5 = .7003830644436881D0,  &
                        p6 = .3526249659989109D-01,  &
                        q0 = 440.4137358247522D0, q1 = 793.8265125199484D0,  &
                        q2 = 637.3336333788311D0, q3 = 296.5642487796737D0,  &
                        q4 = 86.78073220294608D0, q5 = 16.06417757920695D0,  &
                        q6 = 1.755667163182642D0, q7 = .8838834764831844D-1, &
                        cutoff = 7.071D0, root2pi = 2.506628274631001D0
REAL (dp)            :: zabs, expntl, pp, qq, ppdf

zabs = ABS(z)

! |Z| > 37.

IF (zabs > 37.d0) THEN
  IF (PRESENT(pdf)) pdf = zero
  IF (z > zero) THEN
    IF (PRESENT(p)) p = one
    IF (PRESENT(q)) q = zero
  ELSE
    IF (PRESENT(p)) p = zero
    IF (PRESENT(q)) q = one
  END IF
  RETURN
END IF

! |Z| <= 37.

expntl = EXP(-0.5D0*zabs**2)
ppdf = expntl/root2pi
IF (PRESENT(pdf)) pdf = ppdf

! |Z| < CUTOFF = 10/sqrt(2).

IF (zabs < cutoff) THEN
  pp = expntl*((((((p6*zabs + p5)*zabs + p4)*zabs + p3)*zabs + p2)*zabs     &
                   + p1)*zabs + p0) / (((((((q7*zabs + q6)*zabs + q5)*zabs &
                   + q4)*zabs + q3)*zabs + q2)*zabs + q1)*zabs +q0)

! |Z| >= CUTOFF.

ELSE
  pp = ppdf/(zabs + one/(zabs + 2.d0/(zabs + 3.d0/(zabs + 4.d0/(zabs + 0.65D0)))))
END IF

IF (z < zero) THEN
  qq = one - pp
ELSE
  qq = pp
  pp = one - qq
END IF

IF (PRESENT(p)) p = pp
IF (PRESENT(q)) q = qq

RETURN
END SUBROUTINE normp

FUNCTION phi(z) RESULT(p)
REAL (dp), INTENT(IN) :: z
REAL (dp)             :: p

CALL normp(z, p)

RETURN
END FUNCTION phi

END FUNCTION bvn


        implicit real *8 (a-h,o-z)
        complex *16 z,j1,ima,ztest(10000),jtest(10000),jtest2(10000)
        real *8 rtest(10000),thetatest(10000),jtestr(10000),
     1      jtesti(10000)
        data ima/(0.0d0,1.0d0)/

        call prini(6,13)

        ntimes=1

        ntest=1000
        OPEN(UNIT=66,FILE="../mathematica/r1test.txt",
     1      FORM="FORMATTED",STATUS="OLD",ACTION="READ")
        do i=1,ntest
           read(66,*) rtest(i)
        enddo
        close(66)

        OPEN(UNIT=66,FILE="../mathematica/theta1test.txt",
     1      FORM="FORMATTED",STATUS="OLD",ACTION="READ")
        do i=1,ntest
           read(66,*) thetatest(i)
        enddo
        close(66)

        OPEN(UNIT=66,FILE="../mathematica/j1testr.txt",
     1      FORM="FORMATTED",STATUS="OLD",ACTION="READ")
        do i=1,ntest
           read(66,*) jtestr(i)
        enddo
        close(66)

        OPEN(UNIT=66,FILE="../mathematica/j1testi.txt",
     1      FORM="FORMATTED",STATUS="OLD",ACTION="READ")
        do i=1,ntest
           read(66,*) jtesti(i)
        enddo
        close(66)

        do i=1,ntest
           ztest(i)=rtest(i)*exp(ima*thetatest(i))
c           ztest(i)=rtest(i)
        enddo

        do i=1,ntest
           jtest(i)=jtestr(i)+ima*jtesti(i)
        enddo

        ifexpon=0
        do i=1,ntest
           call abram1(ztest(i),jtest2(i),ifexpon)
        enddo

        dmax=0
        imax=0
        do i=1,ntest
           dd=abs((jtest(i)-jtest2(i))/jtest(i))
           if (dd .gt. 1d-14) then
              print *, dd, ztest(i)
           endif
           if (dmax .lt. dd) then
              dmax=dd
              imax=i
           endif
        enddo

        print *, 'maximum relative error = ', dmax
        print *, 'occured at ', ztest(imax), imax
        print *, 'done with testing'

cccc        z=2.0d1*ima+5.0d1
cccc        call abram1(z,j1,ifexpon)
cccc        print *, j1

        stop
        end


!-----------------------------------------------------------------------
!Module accuracy defines precision and some constants
!-----------------------------------------------------------------------
module accuracy_module
   implicit none
   integer, parameter, public :: rdp = kind(1.d0)
   ! constants
   real(rdp), parameter :: pi=3.141592653589793238462643383279502884197_rdp
end module accuracy_module

!-----------------------------------------------------------------------
!Module typedefs_module contains abstract derived type and extended type definitions.
! Note that a reserved word "class" in Fortran is used to describe
! some polymorphic variable  whose data type may vary at run time.
!-----------------------------------------------------------------------
module typedefs_module
   use accuracy_module
   implicit none

   private ! all
   public :: TPoint, TShape, TCircle, TRectangle, TSquare ! public only these defined derived types

   ! abstract derived type
   type, abstract :: TShape
      real(rdp) :: area
      character(len=:),allocatable :: name
   contains
      ! deferred method i.e. abstract method =  must be overridden in extended type
      procedure(calculate_area), deferred,pass :: calculate_area
   end type TShape
   ! just declaration of the abstract method/procedure for TShape type
   abstract interface
      function  calculate_area(this)
         use accuracy_module
         import TShape !imports TShape type from host scoping unit and makes it accessible here
         implicit none
         class(TShape) :: this
         real(rdp) :: calculate_area

      end function calculate_area
   end interface

   ! auxiliary derived type
   type TPoint
      real(rdp) :: x,y
   end type TPoint

   ! extended derived type
   type, extends(TShape) :: TCircle
      real(rdp) :: radius
      real(rdp), private :: diameter
      type(TPoint) :: centre
   contains
      procedure, pass :: calculate_area => calculate_circle_area
      procedure, pass :: get_circle_diameter
      final :: finalize_circle
   end type TCircle

   ! extended derived type
   type, extends(TShape) :: TRectangle
      type(TPoint) :: A,B,C,D
   contains
      procedure, pass :: calculate_area => calculate_rectangle_area
      final :: finalize_rectangle
   end type TRectangle

   ! extended derived type
   type, extends(TRectangle) :: TSquare
   contains
      procedure, pass :: calculate_area => calculate_square_area
      final :: finalize_square
   end type TSquare

 contains

   ! finalization subroutines for each type
   ! They called recursively, i.e. finalize_rectangle
   ! will be called after finalize_square subroutine
   subroutine finalize_circle(x)
      type(TCircle), intent(inout) :: x
      write(*,*) "Deleting TCircle object"
   end subroutine finalize_circle

   subroutine finalize_rectangle(x)
      type(TRectangle), intent(inout) :: x
      write(*,*) "Deleting also TRectangle object"
   end subroutine finalize_rectangle

   subroutine finalize_square(x)
      type(TSquare), intent(inout) :: x
      write(*,*) "Deleting TSquare object"
   end subroutine finalize_square

   function calculate_circle_area(this)
      implicit none
      class(TCircle) :: this
      real(rdp) :: calculate_circle_area
      this%area = pi * this%radius**2
      calculate_circle_area = this%area
   end function calculate_circle_area

   function calculate_rectangle_area(this)
      implicit none
      class(TRectangle) :: this
      real(rdp) :: calculate_rectangle_area
      ! here could be more code
      this%area = 1
      calculate_rectangle_area = this%area
   end function calculate_rectangle_area

   function calculate_square_area(this)
      implicit none
      class(TSquare) :: this
      real(rdp) :: calculate_square_area
      ! here could be more code
      this%area = 1
      calculate_square_area = this%area
   end function calculate_square_area

   function  get_circle_diameter(this)
      implicit none
      class(TCircle) :: this
      real(rdp) :: get_circle_diameter
      this % diameter = 2.0_rdp * this % radius
      get_circle_diameter = this % diameter
   end function get_circle_diameter

end module typedefs_module

!-----------------------------------------------------------------------
!Main program
!-----------------------------------------------------------------------
program    rosetta_class
   use accuracy_module
   use typedefs_module
   implicit none

   ! we need this subroutine in order to show the finalization
   call test_types()

 contains

   subroutine test_types()
      implicit none
      ! declare object of type TPoint
      type(TPoint), target :: point
      ! declare object of type TCircle
      type(TCircle),target :: circle
      ! declare object of type TSquare
      type(TSquare),target :: square

      ! declare pointers
      class(TPoint), pointer :: ppo
      class(TCircle), pointer :: pci
      class(TSquare), pointer :: psq

      !constructor
      point = TPoint(5.d0,5.d0)
      ppo => point
      write(*,*) "x=",point%x,"y=",point%y

      pci => circle

      pci % radius = 1
      write(*,*) pci % radius
      ! write(*,*) pci % diameter !No,it is a PRIVATE component
      write(*,*) pci % get_circle_diameter()
      write(*,*) pci % calculate_area()
      write(*,*) pci % area

      psq => square

      write(*,*) psq % area
      write(*,*) psq % calculate_area()
      write(*,*) psq % area
   end subroutine test_types

end program rosetta_class


! Initialize the random number generator using current time,
! so a new sequence of random numbers is generated each
! execution time.

! Taken from http://gcc.gnu.org/onlinedocs/gfortran/RANDOM_005fSEED.html

SUBROUTINE init_random_seed()
    INTEGER :: i, n, clock
    INTEGER, DIMENSION(:), ALLOCATABLE :: seed

    CALL RANDOM_SEED(size = n)
    ALLOCATE(seed(n))

    CALL SYSTEM_CLOCK(COUNT=clock)

    seed = clock + 37 * (/ (i - 1, i = 1, n) /)
    CALL RANDOM_SEED(PUT = seed)

    print *, "Using random seed = ", seed
    print *, " "

    DEALLOCATE(seed)
END SUBROUTINE


! { dg-do run }
! { dg-options "-fno-range-check" }
! { dg-require-effective-target fortran_real_16 }
! { dg-require-effective-target fortran_integer_16 }
! { dg-skip-if "" { "powerpc*le-*-*" } { "*" } { "" } }
! PR47293 NAN not correctly read
character(len=200) :: str
real(16) :: r
integer(16) :: k2
integer(16), parameter :: quietnan = 170099645085600953110659059745250344960
r = 1.0
str = 'NAN' ; read(str,*) r
k2 = transfer(r,k2)
k2 = iand(k2, z'fff80000000000000000000000000000')
if (k2.ne.quietnan) call abort
end


program test_abs
use lfortran_intrinsic_math, only: abs
implicit none
real :: x
x = abs(1.5)
if (x < 0) error stop
x = abs(-1.5)
if (x < 0) error stop
end program