      implicit real *8 (a-h,o-z)
      parameter (nd = 1)
      parameter (nt = 3)
      real *8 ztarg(3,nt),sources(3,10)
      complex *16 charge(nd,10),pot(nd,nt),grad(nd,3,nt)
      complex *16 hess(nd,6,nt)
      complex *16 dipvec(nd,3,10)
      complex *16 zk,v1,v2,zfd
      complex *16 zfd1,zfd2,zfd3
c
c
      zk  = dcmplx(1.1d0,0.4d0)
c
      sources(1,1) = 0.1d0
      sources(2,1) = -0.2d0
      sources(3,1) = 0.3d0
      dipvec(1,1,1) = dcmplx(1.1d0,0.3d0)
      dipvec(1,2,1) = dcmplx(-2.2d0,0.2d0)
      dipvec(1,3,1) = dcmplx(3.3d0,0.1d0)
cc      dipvec(1,1,1) = 0
cc      dipvec(1,2,1) = 0
cc      dipvec(1,3,1) = 0
      charge(1,1) = dcmplx(1.3d0,0.11d0)
      sources(1,2) = -0.13d0
      sources(2,2) = 0.2d0
      sources(3,2) = -0.25d0
      dipvec(1,1,2) = dcmplx(-2.13d0,0.1d0)
      dipvec(1,2,2) = dcmplx(1.2d0,0.3d0)
      dipvec(1,3,2) = dcmplx(-3.25d0,0.2d0)
cc      dipvec(1,1,2) = 0
cc      dipvec(1,2,2) = 0
cc      dipvec(1,3,2) = 0
      charge(1,2) = dcmplx(2.3d0,0.21d0)
      ns = 2
      ztarg(1,1) = 1.0d0
      ztarg(2,1) = 1.3d0
      ztarg(3,1) = 1.4d0
c
c     pick component in which to do finite difference
c
c
      icomp = 3

      hh = 1.0d-5
      ztarg(1,2) = 1.0d0
      ztarg(2,2) = 1.3d0
      ztarg(3,2) = 1.4d0
      ztarg(1,3) = 1.0d0
      ztarg(2,3) = 1.3d0
      ztarg(3,3) = 1.4d0
      ztarg(icomp,2) = ztarg(icomp,2) + hh
      ztarg(icomp,3) = ztarg(icomp,3) - hh
c
c
      write(6,*) ' directc  tests -------------------------------'
c
      call setzero(pot,grad,hess,nd,nt)
      call h3ddirectcp(nd,zk,sources,charge,ns,ztarg,nt,
     1            pot,thresh)
      write(6,*) ' dir cp '
      do i = 1,nt
         write(6,*)pot(1,i)
      enddo
      zfd =  (pot(1,2) - pot(1,3))/(2*hh)
      write(6,*) ' FD deriv ', zfd
c
      call setzero(pot,grad,hess,nd,nt)
      call h3ddirectcg(nd,zk,sources,charge,ns,ztarg,nt,
     1            pot,grad,thresh)
      write(6,*) ' dir cp '
      do i = 1,nt
         write(6,*)pot(1,i)
      enddo
      write(6,*) ' analytic grad ', grad(1,icomp,1)
      egrad = abs( grad(1,icomp,1)- zfd)/abs(grad(1,icomp,1))
      write(6,*) ' egrad  ', egrad
      v1 = grad(1,1,2)
      v2 = grad(1,1,3)
      zfd1 = (v1-v2)/(2*hh)
      v1 = grad(1,2,2)
      v2 = grad(1,2,3)
      zfd2 = (v1-v2)/(2*hh)
      v1 = grad(1,3,2)
      v2 = grad(1,3,3)
      zfd3 = (v1-v2)/(2*hh)
      write(6,*) ' FD deriv of p_x ', zfd1
      write(6,*) ' FD deriv of p_y ', zfd2
      write(6,*) ' FD deriv of p_z ', zfd3
c
      call setzero(pot,grad,hess,nd,nt)
      call h3ddirectch(nd,zk,sources,charge,ns,ztarg,nt,
     1            pot,grad,hess,thresh)
      write(6,*) ' dir cp '
      do i = 1,nt
         write(6,*)pot(1,i)
      enddo
      write(6,*) ' analytic grad ', grad(1,icomp,1)
      egrad = abs( grad(1,icomp,1)- zfd)/abs(grad(1,icomp,1))
      write(6,*) ' egrad  ', egrad
      if (icomp.eq.1) then
         write(6,*) ' dir pxx ', hess(1,1,1)
         write(6,*) ' dir pxy ', hess(1,4,1)
         write(6,*) ' dir pxz ', hess(1,5,1)
         exx = abs( hess(1,1,1)- zfd1)/abs(hess(1,1,1))
         exy = abs( hess(1,4,1)- zfd2)/abs(hess(1,4,1))
         exz = abs( hess(1,5,1)- zfd3)/abs(hess(1,5,1))
         write(6,*) ' exx  ', exx
         write(6,*) ' exy  ', exy
         write(6,*) ' exz  ', exz
      else if (icomp.eq.2) then
         write(6,*) ' dir pxy ', hess(1,4,1)
         write(6,*) ' dir pyy ', hess(1,2,1)
         write(6,*) ' dir pyz ', hess(1,6,1)
         exy = abs( hess(1,4,1)- zfd1)/abs(hess(1,4,1))
         eyy = abs( hess(1,2,1)- zfd2)/abs(hess(1,2,1))
         eyz = abs( hess(1,6,1)- zfd3)/abs(hess(1,6,1))
         write(6,*) ' exy  ', exy
         write(6,*) ' eyy  ', eyy
         write(6,*) ' eyz  ', eyz
      else if (icomp.eq.3) then
         write(6,*) ' dir pxz ', hess(1,4,1)
         write(6,*) ' dir pyz ', hess(1,6,1)
         write(6,*) ' dir pzz ', hess(1,3,1)
         exz = abs( hess(1,5,1)- zfd1)/abs(hess(1,5,1))
         eyz = abs( hess(1,6,1)- zfd2)/abs(hess(1,6,1))
         ezz = abs( hess(1,3,1)- zfd3)/abs(hess(1,3,1))
         write(6,*) ' exz  ', exz
         write(6,*) ' eyz  ', eyz
         write(6,*) ' ezz  ', ezz
      endif
c
c
      write(6,*) ' directd  tests -------------------------------'
c
      call setzero(pot,grad,hess,nd,nt)
      call h3ddirectdp(nd,zk,sources,
     1            dipvec,ns,ztarg,nt,pot,thresh)
      write(6,*) ' dir cp '
      do i = 1,nt
         write(6,*)pot(1,i)
      enddo
      zfd =  (pot(1,2) - pot(1,3))/(2*hh)
      write(6,*) ' FD deriv ', zfd
      call setzero(pot,grad,hess,nd,nt)
      call h3ddirectdg(nd,zk,sources,
     1            dipvec,ns,ztarg,nt,pot,grad,thresh)
      write(6,*) ' dir cp '
      do i = 1,nt
         write(6,*)pot(1,i)
      enddo
      write(6,*) ' analytic grad ', grad(1,icomp,1)
      egrad = abs( grad(1,icomp,1)- zfd)/abs(grad(1,icomp,1))
      write(6,*) ' egrad  ', egrad
      v1 = grad(1,1,2)
      v2 = grad(1,1,3)
      zfd1 = (v1-v2)/(2*hh)
      v1 = grad(1,2,2)
      v2 = grad(1,2,3)
      zfd2 = (v1-v2)/(2*hh)
      v1 = grad(1,3,2)
      v2 = grad(1,3,3)
      zfd3 = (v1-v2)/(2*hh)
      write(6,*) ' FD x deriv of p_x ', zfd1
      write(6,*) ' FD x deriv of p_y ', zfd2
      write(6,*) ' FD x deriv of p_z ', zfd3
c
      call setzero(pot,grad,hess,nd,nt)
      call h3ddirectdh(nd,zk,sources,
     1            dipvec,ns,ztarg,nt,pot,grad,hess,thresh)
      write(6,*) ' dir cp '
      do i = 1,nt
         write(6,*)pot(1,i)
      enddo
      write(6,*) ' analytic grad ', grad(1,icomp,1)
      egrad = abs( grad(1,icomp,1)- zfd)/abs(grad(1,icomp,1))
      write(6,*) ' egrad  ', egrad
      if (icomp.eq.1) then
         write(6,*) ' dir pxx ', hess(1,1,1)
         write(6,*) ' dir pxy ', hess(1,4,1)
         write(6,*) ' dir pxz ', hess(1,5,1)
         exx = abs( hess(1,1,1)- zfd1)/abs(hess(1,1,1))
         exy = abs( hess(1,4,1)- zfd2)/abs(hess(1,4,1))
         exz = abs( hess(1,5,1)- zfd3)/abs(hess(1,5,1))
         write(6,*) ' exx  ', exx
         write(6,*) ' exy  ', exy
         write(6,*) ' exz  ', exz
      else if (icomp.eq.2) then
         write(6,*) ' dir pxy ', hess(1,4,1)
         write(6,*) ' dir pyy ', hess(1,2,1)
         write(6,*) ' dir pyz ', hess(1,6,1)
         exy = abs( hess(1,4,1)- zfd1)/abs(hess(1,4,1))
         eyy = abs( hess(1,2,1)- zfd2)/abs(hess(1,2,1))
         eyz = abs( hess(1,6,1)- zfd3)/abs(hess(1,6,1))
         write(6,*) ' exy  ', exy
         write(6,*) ' eyy  ', eyy
         write(6,*) ' eyz  ', eyz
      else if (icomp.eq.3) then
         write(6,*) ' dir pxz ', hess(1,4,1)
         write(6,*) ' dir pyz ', hess(1,6,1)
         write(6,*) ' dir pzz ', hess(1,3,1)
         exz = abs( hess(1,5,1)- zfd1)/abs(hess(1,5,1))
         eyz = abs( hess(1,6,1)- zfd2)/abs(hess(1,6,1))
         ezz = abs( hess(1,3,1)- zfd3)/abs(hess(1,3,1))
         write(6,*) ' exz  ', exz
         write(6,*) ' eyz  ', eyz
         write(6,*) ' ezz  ', ezz
      endif

c
      write(6,*) ' directcd  tests -------------------------------'
c
      call setzero(pot,grad,hess,nd,nt)
      call h3ddirectcdp(nd,zk,sources,charge,
     1            dipvec,ns,ztarg,nt,pot,thresh)
      write(6,*) ' dir cp '
      do i = 1,nt
         write(6,*)pot(1,i)
      enddo
      zfd =  (pot(1,2) - pot(1,3))/(2*hh)
      write(6,*) ' FD deriv ', zfd
      call setzero(pot,grad,hess,nd,nt)
      call h3ddirectcdg(nd,zk,sources,charge,
     1            dipvec,ns,ztarg,nt,pot,grad,thresh)
      write(6,*) ' dir cp '
      do i = 1,nt
         write(6,*)pot(1,i)
      enddo
      write(6,*) ' analytic grad ', grad(1,icomp,1)
      egrad = abs( grad(1,icomp,1)- zfd)/abs(grad(1,icomp,1))
      write(6,*) ' egrad  ', egrad
      v1 = grad(1,1,2)
      v2 = grad(1,1,3)
      zfd1 = (v1-v2)/(2*hh)
      v1 = grad(1,2,2)
      v2 = grad(1,2,3)
      zfd2 = (v1-v2)/(2*hh)
      v1 = grad(1,3,2)
      v2 = grad(1,3,3)
      zfd3 = (v1-v2)/(2*hh)
      write(6,*) ' FD deriv of p_x ', zfd1
      write(6,*) ' FD deriv of p_y ', zfd2
      write(6,*) ' FD deriv of p_z ', zfd3

c
      call setzero(pot,grad,hess,nd,nt)
      call h3ddirectcdh(nd,zk,sources,charge,
     1            dipvec,ns,ztarg,nt,pot,grad,hess,thresh)
      write(6,*) ' dir cp '
      do i = 1,nt
         write(6,*)pot(1,i)
      enddo
      write(6,*) ' analytic grad ', grad(1,icomp,1)
      egrad = abs( grad(1,icomp,1)- zfd)/abs(grad(1,icomp,1))
      write(6,*) ' egrad  ', egrad
      if (icomp.eq.1) then
         write(6,*) ' dir pxx ', hess(1,1,1)
         write(6,*) ' dir pxy ', hess(1,4,1)
         write(6,*) ' dir pxz ', hess(1,5,1)
         exx = abs( hess(1,1,1)- zfd1)/abs(hess(1,1,1))
         exy = abs( hess(1,4,1)- zfd2)/abs(hess(1,4,1))
         exz = abs( hess(1,5,1)- zfd3)/abs(hess(1,5,1))
         write(6,*) ' exx  ', exx
         write(6,*) ' exy  ', exy
         write(6,*) ' exz  ', exz
      else if (icomp.eq.2) then
         write(6,*) ' dir pxy ', hess(1,4,1)
         write(6,*) ' dir pyy ', hess(1,2,1)
         write(6,*) ' dir pyz ', hess(1,6,1)
         exy = abs( hess(1,4,1)- zfd1)/abs(hess(1,4,1))
         eyy = abs( hess(1,2,1)- zfd2)/abs(hess(1,2,1))
         eyz = abs( hess(1,6,1)- zfd3)/abs(hess(1,6,1))
         write(6,*) ' exy  ', exy
         write(6,*) ' eyy  ', eyy
         write(6,*) ' eyz  ', eyz
      else if (icomp.eq.3) then
         write(6,*) ' dir pxz ', hess(1,4,1)
         write(6,*) ' dir pyz ', hess(1,6,1)
         write(6,*) ' dir pzz ', hess(1,3,1)
         exz = abs( hess(1,5,1)- zfd1)/abs(hess(1,5,1))
         eyz = abs( hess(1,6,1)- zfd2)/abs(hess(1,6,1))
         ezz = abs( hess(1,3,1)- zfd3)/abs(hess(1,3,1))
         write(6,*) ' exz  ', exz
         write(6,*) ' eyz  ', eyz
         write(6,*) ' ezz  ', ezz
      endif

      end

      subroutine setzero(pot,grad,hess,nd,nt)
      implicit real *8 (a-h,o-z)
      complex *16 pot(nd,nt),grad(nd,3,nt)
      complex *16 hess(nd,6,nt)

      do ii=1,nd
      do jj=1,nt
         pot(ii,jj) = 0.0d0
         grad(ii,1,jj) = 0.0d0
         grad(ii,2,jj) = 0.0d0
         grad(ii,3,jj) = 0.0d0
         hess(ii,1,jj) = 0.0d0
         hess(ii,2,jj) = 0.0d0
         hess(ii,3,jj) = 0.0d0
         hess(ii,4,jj) = 0.0d0
         hess(ii,5,jj) = 0.0d0
         hess(ii,6,jj) = 0.0d0
      enddo
      enddo
      return
      end


module mod_ECRad_raytrace_initialize
    use f90_kind
    use mod_ECRad_types,       only: spl_type_2d
    implicit none
    ! Two interfaces to allow interpolation of Te and ne using both single rhop values and vectors of rhop values
    type(spl_type_2d)                       :: Psi_spline

    public :: init_raytrace, dealloc_raytrace

    private :: get_psi_ax, &
               eval_Psi, &
               read_topfile, &
               read_Te_ne_matrix, &
               make_topfile, &
               setup_plasma_params, &
               read_3D_vessel_file, &
               read_input_lists

    contains

  subroutine get_psi_ax(R, z, i_ax, j_ax, R_ax, z_ax)
  ! Interpolates
    use f90_kind
    use mod_ECRad_types,       only: output_level
    use nr_mod,                    only: powell ! Minimizer -> Psi_ax has to be a minimum
    use mod_ECRad_interpol,    only: rect_spline
    implicit none
    real(rkind), dimension(:), intent(in)  :: R, z
    integer(ikind)           , intent(in)  :: i_ax, j_ax
    real(rkind),               intent(out) :: R_ax
    real(rkind),               intent(out) :: z_ax
    real(rkind), dimension(2)              :: p
    real(rkind), dimension(2,2)            :: xi
    real(rkind)                            :: ftol, psi_out, dx, dy
    integer(ikind)                         :: iter
    p(1) = R(i_ax)
    p(2) = z(j_ax)
    call rect_spline(Psi_spline, p(1), p(2), psi_out, dfdx=dx, dfdy=dy)
    xi(:,1) = dx
    xi(:,2) = dy
    ftol = 1.d-6
    call powell(p,xi,ftol,iter, psi_out, eval_Psi)
    R_ax = p(1)
    z_ax = p(2)
    !if(output_level) print*, "Magnetic axis position and rhop on axis",  p(1), p(2), sqrt((eval_Psi(p) - psi_ax)/(psi_sep - psi_ax))
    if(output_level) print*, "Magnetic axis position and rhop on axis",  p(1), p(2), sqrt(eval_Psi(p))
  end subroutine get_psi_ax

  function eval_Psi(R)
    use f90_kind
    use mod_ECRad_interpol,    only: rect_spline
    implicit none
    real(rkind), dimension(:), intent(in)   :: R
    real(rkind)                             :: eval_Psi
    call rect_spline(Psi_spline, R(1), R(2), eval_Psi)
  end function eval_Psi

  subroutine read_topfile(plasma_params, R, z, rhop, Br, Bt, Bz, itime)
      use f90_kind
      use mod_ECRad_types,       only: plasma_params_type, data_folder, output_level
      use mod_ECRad_interpol,    only: make_rect_spline, deallocate_rect_spline
      implicit none
      type(plasma_params_type) , intent(inout) :: plasma_params
      real(rkind), dimension(:), allocatable, intent(out) :: R, z
      real(rkind), dimension(:,:), allocatable, intent(out) ::  Br, Bt, Bz
      real(rkind), dimension(:,:), allocatable, intent(out) ::  rhop
      integer(ikind), intent(in), optional                  :: itime
      character(250) :: filename
      integer(ikind) :: i, j, i_ax, j_ax
      real(rkind) :: radin, radout, pf_sxp, pf_mag
      character(70) :: line
      if(present(itime)) then
        write(filename, fmt = "(A7I5.5)") "topfile",  itime
        filename = trim(data_folder) // trim(filename)
      else
        filename =  trim(data_folder) // "topfile"
      end if
      open(70,status='unknown',file=filename)
      read(70,'(A)') line
      read(70,*) plasma_params%m, plasma_params%n
      if(output_level) print*, "Dimensions of external data: ", plasma_params%m, plasma_params%n
      allocate(R(plasma_params%m), z(plasma_params%n), Br(plasma_params%m,plasma_params%n), &
               Bt(plasma_params%m,plasma_params%n), Bz(plasma_params%m,plasma_params%n), &
               rhop(plasma_params%m, plasma_params%n))
      read(70,'(A)') line
      read(70,*) radin,radout, pf_sxp
      if(abs(pf_sxp -1.e0) > 1.e-6) then
        print*, "The Psi provided to ECRad MUST be normalized such that rhop = Sqrt(PSI)"
        print*, "Hence, psi at the separatrix must be 1"
        print*, "Psi at the separatrix provided is", pf_sxp
        call abort()
      end if
! ... Grid: X-coordinates
      read(70,'(A)') line  ;  read(70,fmt=*)(R(i),i=1,plasma_params%m)

! ... Grid: Z-coordinates
      read(70,'(A)') line  ;  read(70,fmt=*)(z(j),j=1,plasma_params%n)

! ... Magnetic field: B_X, B_Y (toroidal), B_z (vertical)
      read(70,'(A)') line  ;  read(70,fmt=*)((Br(i,j),i=1,plasma_params%m),j=1,plasma_params%n)
      read(70,'(A)') line  ;  read(70,fmt=*)((Bt(i,j),i=1,plasma_params%m),j=1,plasma_params%n)
      read(70,'(A)') line  ;  read(70,fmt=*)((Bz(i,j),i=1,plasma_params%m),j=1,plasma_params%n)

!     Poloidal flux: psi
      read(70,'(A)') line  ;  read(70,fmt=*)((rhop(i,j),i=1,plasma_params%m),j=1,plasma_params%n)

      close(70)
!      if(pf_sxp < rhop(plasma_params%m/2, plasma_params%n/2)) then
!         sgn = -1.e0_rkind
!         pf_sxp = pf_sxp * sgn
!      else
!         sgn = 1.e0_rkind
!      endif
      pf_mag = 1.d99
      i_ax = -1
      do j = 1, plasma_params%n
        if(pf_mag > minval(rhop(:,j))) then
          pf_mag = minval(rhop(:,j))
          i_ax = minloc(rhop(:,j), dim = 1)
          j_ax = j
        end if
      end do
      if(i_ax == -1) then
        print*, "Could not find magnetic axis in read_topfile in mod_raytrace_initialize.f90"
        print*, "Check if psi matrix dimensions correct: R, z", plasma_params%m, plasma_params%n
        stop "Input error - check topfile"
      end if
      if(output_level) print*, "Retrieving magn axis"
     ! ECRad wants normalized psi for which rhop = sqrt(Psi)!!!
      call make_rect_spline(Psi_spline, int(plasma_params%m, 4), int(plasma_params%n, 4), R, z, rhop)
      call get_psi_ax(R, z, i_ax, j_ax, plasma_params%R_ax, plasma_params%z_ax)
      rhop = sqrt(rhop) ! - pf_mag)/(pf_sxp - pf_mag)
      if(any(rhop /= rhop) .or. minval(rhop) < 0.d0) then
        print*, "critical error when reading topfile, NAN or negative value in normalized Psi found"
        print*, rhop
        stop "sub read topfile in mod_raytrace_intialize"
      end if
      call deallocate_rect_spline(Psi_spline)
  end subroutine read_topfile

  subroutine read_Te_ne_matrix(plasma_params, R, z, Te, ne)
      use f90_kind
      use mod_ECRad_types,       only: plasma_params_type, data_folder, min_density, max_Te, min_Te
      implicit none
      type(plasma_params_type) , intent(inout) :: plasma_params
      real(rkind), dimension(:), allocatable, intent(in) :: R, z
      real(rkind), dimension(:,:), allocatable, intent(out) ::  Te, ne
      real(rkind), dimension(size(R))                       :: R_check
      real(rkind), dimension(size(z))                       :: z_check
      character(250) :: filename
      integer(ikind) :: m_check, n_check, i,j
      character(70) :: line
      filename =  trim(data_folder) // "Te_ne_matfile"
      open(71,status='unknown',file=filename)
      read(71,'(A)') line
      read(71,*) m_check, n_check
      if(m_check /= plasma_params%m .or. n_check /= plasma_params%n) then
        print*, "Te and ne grid input is enabled"
        print*, "The Te and ne grid exact same dimension as the magnetic field and flux matrix"
        print*, "dimensions of flux matrix", plasma_params%m, plasma_params%n
        print*, "dimensions of Te/ne matrix", m_check, n_check
        stop "Input Error! Check input and run again"
      end if
      allocate(Te(plasma_params%m,plasma_params%n), &
               ne(plasma_params%m,plasma_params%n))
! ... Grid: X-coordinates
      read(71,'(A)') line  ;  read(71,fmt=*)(R_check(i),i=1,plasma_params%m)
      if(.not. all(R == R_check)) then
        print*, "Te and ne grid input is enabled"
        print*, "R grid of Te/ne is not identical to R grid of flux matrix"
        stop "Input Error! Check input and run again"
      end if
! ... Grid: Z-coordinates
      read(71,'(A)') line  ;  read(71,fmt=*)(z_check(j),j=1,plasma_params%n)
      if(.not. all(z ==z_check)) then
        print*, "Te and ne grid input is enabled"
        print*, "z grid of Te/ne is not identical to z grid of flux matrix"
        stop
      end if
! ... Te
      read(71,'(A)') line  ;  read(71,fmt=*)((Te(i,j),i=1,plasma_params%m),j=1,plasma_params%n)
      if(any(Te > max_Te) .or. any(Te < 0) .or. all(Te < min_Te)) then
        print*, "Te and ne grid input is enabled"
        if(any(Te > max_Te)) then
          print*, "Encoutered Te >", max_Te
          print*, "Largest Te", maxval(Te)
        else if(any(Te < 0.d0)) then
          print*, "Encoutered  negative values for Te"
          print*, "Negative Te", minval(Te)
        else if(all(Te < min_Te)) then
          print*, "All Te smaller than the minium Te: ", min_Te
        end if
        stop "Input Error! Check input and run again"
      end if
! ... ne
      read(71,'(A)') line  ;  read(71,fmt=*)((ne(i,j),i=1,plasma_params%m),j=1,plasma_params%n)
      if( all(ne < min_density)) then
        print*, "Te and ne grid input is enabled"
        print*, "All density points are smaller than:", min_density
        stop "Input Error! Check input and run again"
      end if
  end subroutine read_Te_ne_matrix

  subroutine read_3D_vessel_file(plasma_params)
  use f90_kind
    use mod_ECRad_types,       only: Vessel_bd_filename, plasma_params_type
    implicit none
    type(plasma_params_type), intent(inout) :: plasma_params
    integer(ikind) :: i, j
    character(200) :: dummy1, dummy2, dummy3, dummy4, dummy5, dummy6, dummy7, dummy8
    open(87, file=Vessel_bd_filename)
    read(87,*) dummy1
    read(87,*) plasma_params%Use_3D_vessel%n_phi, plasma_params%Use_3D_vessel%n_contour, &
               dummy1, dummy2, dummy3, dummy4, dummy5, dummy6, dummy7, dummy8
    allocate(plasma_params%Use_3D_vessel%vessel_data_R(plasma_params%Use_3D_vessel%n_contour, &
                                                     plasma_params%Use_3D_vessel%n_phi), &
             plasma_params%Use_3D_vessel%vessel_data_z(plasma_params%Use_3D_vessel%n_contour, &
                                                     plasma_params%Use_3D_vessel%n_phi), &
             plasma_params%Use_3D_vessel%phi(plasma_params%Use_3D_vessel%n_phi))
    do j = 1, plasma_params%Use_3D_vessel%n_phi
      read(87,*) plasma_params%Use_3D_vessel%phi(j)
      do i = 1, plasma_params%Use_3D_vessel%n_contour
        read(87,*) plasma_params%Use_3D_vessel%vessel_data_R(i,j), &
                   plasma_params%Use_3D_vessel%vessel_data_z(i,j), &
                   dummy1
      end do
    end do
    close(87)
    if(plasma_params%Use_3D_vessel%n_phi == 1) then
      plasma_params%Use_3D_vessel%phi_max = 361.d0 !
    else
      plasma_params%Use_3D_vessel%phi_max = maxval(plasma_params%Use_3D_vessel%phi) ! Necessary to use symmetry
    end if
  end subroutine read_3D_vessel_file

  subroutine make_topfile(R, z, rhop, Br, Bt, Bz, itime)
    use f90_kind
    use mod_ECRad_types,       only: data_folder
    implicit none
    real(rkind), dimension(:), allocatable, intent(in) :: R, z
    real(rkind), dimension(:,:), allocatable, intent(in) ::  Br, Bt, Bz
    real(rkind), dimension(:,:), allocatable, intent(in) ::  rhop
    integer(ikind), intent(in), optional                  ::  itime
    character(250) :: filename
    integer(ikind) :: i,j
    if(present(itime)) then
      write(filename, fmt = "(A7I5.5)") "topfile",  itime
      filename = trim(data_folder) // trim(filename)
    else
      filename =  trim(data_folder) // "topfile"
    end if
    open(70,status='unknown',file=filename)
    write(70,'(A)') "Number of radial and vertical grid points"
    write(70,*) size(R), size(z)
    write(70,'(A)') "Inside and Outside radius and psi_sep"
    write(70,*) R(1), R(size(R)), 1.0 ! since we use psi = rhop**2
! ... Grid: X-coordinates
    write(70,'(A)') "Radial grid coordinates"
    write(70,fmt=*)(R(i),i=1,size(R))

! ... Grid: Z-coordinates
    write(70,'(A)') "Vertical grid coordinates"
    write(70,fmt=*)(z(j),j=1,size(z))

! ... Magnetic field: B_X, B_Y (toroidal), B_z (vertical)
    write(70,'(A)') "B_r values"  ;  write(70,fmt=*)((Br(i,j),i=1,size(R)),j=1,size(z))
    write(70,'(A)') "B_t values"  ;  write(70,fmt=*)((Bt(i,j),i=1,size(R)),j=1,size(z))
    write(70,'(A)') "B_z values"  ;  write(70,fmt=*)((Bz(i,j),i=1,size(R)),j=1,size(z))

!     Poloidal flux: psi
    write(70,'(A)') "psi values"  ;  write(70,fmt=*)((rhop(i,j)**2,i=1,size(R)),j=1,size(z))
    close(70)
  end subroutine make_topfile

  subroutine setup_plasma_params(plasma_params, R_in, z_in, rhop_in, B_r_in, &
                                 B_t_in, B_z_in, R_ax, z_ax, T_e_mat_in, n_e_mat_in)
    use f90_kind
#ifdef NAG
    use mod_ECRad_types,        only: double_check_splines, plasma_params_type, h_x_glob, h_check, &
                                          stand_alone, vessel_bd_filename, use_3D, working_dir
#else
    use mod_ECRad_types,        only: plasma_params_type, h_x_glob, h_check, &
                                          stand_alone, vessel_bd_filename, use_3D, working_dir
#endif
    use mod_ECRad_interpol,     only: make_rect_spline, make_1d_spline, rect_spline
    use constants,                  only: pi
    use quadrature,                 only: cdgqf
#ifdef NAG
    USE nag_spline_2d,              only: nag_spline_2d_interp, &
    									                    nag_error, nag_set_error, nag_spline_2d_eval
    USE nag_spline_1d,              only: nag_spline_1d_interp
    USE nag_error_handling
#endif
    use ripple3d,                   only: init_ripple!, validate_ripple_grad
#ifdef USE_3D
    use magconfig,                only: MConf_Setup_Config, MConf_Load_MagConfig, mcClone
#endif
#ifdef OMP
    use omp_lib,                    only: omp_get_max_threads
#endif
    implicit none
    type(plasma_params_type), intent(inout)     :: plasma_params
	  real(rkind), dimension(:), intent(in), optional :: R_in, z_in
    real(rkind), dimension(:,:), intent(in), optional :: rhop_in, B_r_in, B_t_in, B_z_in, T_e_mat_in, n_e_mat_in
    real(rkind), intent(in), optional                 :: R_ax, z_ax
    real(rkind), dimension(:,:), allocatable    :: B_r, B_t, B_z, T_e_mat, n_e_mat
    integer(ikind), dimension(:), allocatable   :: R_index_lower, z_index_lower, R_index_upper, z_index_upper
    real(rkind)                                 :: B_last, B_vac_R0
    integer(ikind)                              :: i, m
    integer(ikind)                              :: loaded
    character(1)  :: sep
    character(200)                              :: filename
    integer(ikind)                              :: num_threads
    allocate( plasma_params%Int_weights(plasma_params%int_step_cnt),plasma_params%Int_absz(plasma_params%int_step_cnt))
    if(plasma_params%on_the_fly_raytracing) then
      call cdgqf( int(plasma_params%int_step_cnt,kind=4), int(1,kind=4), 0.d0, 0.d0, plasma_params%Int_weights, plasma_params%Int_absz)
    else
      do i = 1, plasma_params%int_step_cnt
        plasma_params%Int_absz(i) = real(i ,8) / real(plasma_params%int_step_cnt, 8) ! spans the points in a way so that there is no overlap
                                                                                ! Int_absz(1) > 0.d0
      end do
    end if
    if(.not. plasma_params%Te_ne_mat .and. stand_alone) then
#ifdef NAG
      if(double_check_splines .and. output_level) then
        call nag_spline_1d_interp(plasma_params%rhop_vec_ne, plasma_params%n_e_prof, plasma_params%ne_spline_nag)
        call nag_spline_1d_interp(plasma_params%rhop_vec_Te, plasma_params%T_e_prof, plasma_params%Te_spline_nag)
      end if
#endif
      if(plasma_params%prof_log_flag) then
        call make_1d_spline( plasma_params%ne_spline, int(size(plasma_params%rhop_vec_ne),4), plasma_params%rhop_vec_ne, log(plasma_params%n_e_prof * 1.d-19))
        call make_1d_spline( plasma_params%Te_spline, int(size(plasma_params%rhop_vec_Te),4), plasma_params%rhop_vec_Te, log(plasma_params%T_e_prof))
      else
        call make_1d_spline( plasma_params%ne_spline, int(size(plasma_params%rhop_vec_ne),4), plasma_params%rhop_vec_ne, plasma_params%n_e_prof)
        call make_1d_spline( plasma_params%Te_spline, int(size(plasma_params%rhop_vec_Te),4), plasma_params%rhop_vec_Te, plasma_params%T_e_prof)
      end if
    end if
#ifdef USE_3D
    if(use_3D) then
        plasma_params%Scenario%work_dir = working_dir
        call read_3D_vessel_file(plasma_params)
        call MConf_Setup_Config(plasma_params%Scenario)
        call MConf_Load_MagConfig(loaded, plasma_params%Scenario%mConfAddr)
        if(loaded /= 1) then
            print*, "Failed to load equilibrium"
            print*, "Please check that", plasma_params%Scenario%name_config, " exists!"
            print*, "MConf error code", loaded
            call abort()
        end if
#ifdef OMP
      !$omp parallel
      num_threads = omp_get_max_threads()
      !$omp end parallel
#else
      num_threads = 1
#endif
      allocate(plasma_params%mconf_addresses(num_threads))
      plasma_params%mconf_addresses(1) = plasma_params%Scenario%mConfAddr
#ifdef OMP
      do i = 2, num_threads
        plasma_params%mconf_addresses(i) = mcClone(plasma_params%mconf_addresses(1))
      end do
#endif
      return
    end if
#endif
    ! Equilibrium/Magnetic field splines are set up in the following
    if(.not. present(R_in)) then
      call read_topfile(plasma_params, plasma_params%R, plasma_params%z, plasma_params%rhop, B_r, B_t, B_z)
      if(plasma_params%Te_ne_mat) then
        call read_Te_ne_matrix(plasma_params, plasma_params%R, plasma_params%z, T_e_mat, n_e_mat)
      end if
    else
      plasma_params%m = size(R_in)
      plasma_params%n = size(z_in)
      allocate(plasma_params%R(plasma_params%m), &
               plasma_params%z(plasma_params%n), &
               plasma_params%rhop(plasma_params%m,plasma_params%n), &
               B_r(plasma_params%m,plasma_params%n), &
               B_t(plasma_params%m,plasma_params%n), &
               B_z(plasma_params%m,plasma_params%n))
      if(present(T_e_mat_in)) then
        allocate(T_e_mat(plasma_params%m,plasma_params%n), &
                 n_e_mat(plasma_params%m,plasma_params%n))
      end if
      plasma_params%R=R_in
      plasma_params%z=z_in
      do i =1, plasma_params%m
        plasma_params%rhop(i,:)=rhop_in(i,:)
        B_r(i,:) = B_r_in(i,:)
        B_t(i,:) = B_t_in(i,:)
        B_z(i,:) = B_z_in(i,:)
        if(present(T_e_mat_in)) then
          T_e_mat(i,:) = T_e_mat_in(i,:)
          n_e_mat(i,:) = n_e_mat_in(i,:)
        end if
      end do
      plasma_params%R_ax = R_ax
      plasma_params%z_ax = z_ax
    end if
    ! No information on where the profiles start to be good go with the default value
    if(plasma_params%Te_ne_mat) plasma_params%rhop_max = plasma_params%rhop_entry !
    h_check = h_x_glob * (1.d0 + 1.e-5)
    plasma_params%R_min = plasma_params%R(1)
    plasma_params%R_max = plasma_params%R(plasma_params%m)
    plasma_params%z_min = plasma_params%z(1)
    plasma_params%z_max = plasma_params%z(plasma_params%n)
    plasma_params%R_step = (plasma_params%R_max - plasma_params%R_min) / real(plasma_params%m - 1,8)
    plasma_params%z_step = (plasma_params%z_max - plasma_params%z_min) / real(plasma_params%n - 1,8)
    call make_rect_spline(plasma_params%rhop_spline, int(plasma_params%m, 4), int(plasma_params%n, 4), plasma_params%R, plasma_params%z, plasma_params%rhop)
    call make_rect_spline(plasma_params%B_r_spline, int(plasma_params%m, 4), int(plasma_params%n, 4), plasma_params%R, plasma_params%z, B_r)
    call make_rect_spline(plasma_params%B_t_spline, int(plasma_params%m, 4), int(plasma_params%n, 4), plasma_params%R, plasma_params%z, B_t)
    call make_rect_spline(plasma_params%B_z_spline, int(plasma_params%m, 4), int(plasma_params%n, 4), plasma_params%R, plasma_params%z, B_z)
    if(plasma_params%Te_ne_mat) then
      call make_rect_spline(plasma_params%T_e_spline_2D, int(plasma_params%m, 4), int(plasma_params%n, 4), plasma_params%R, plasma_params%z, log(T_e_mat))
      ! Warning: ne is scaled down to avoid numerical problems!
      call make_rect_spline(plasma_params%n_e_spline_2D, int(plasma_params%m, 4), int(plasma_params%n, 4), plasma_params%R, plasma_params%z, log(n_e_mat * 1.e-19))
#ifdef NAG
      if(double_check_splines .and. output_level) then
        call nag_spline_2d_interp(plasma_params%R, plasma_params%z, log(T_e), plasma_params%Te_spline_nag_2D)
        call nag_spline_2d_interp(plasma_params%R, plasma_params%z, log(n_e * 1.e-19), plasma_params%ne_spline_nag_2D)
      end if
#endif
    end if
#ifdef NAG
    if(output_level .and. double_check_splines) then
      call nag_spline_2d_interp(plasma_params%R, plasma_params%z, plasma_params%rhop, plasma_params%rhop_spline_nag)
      if(eq_from_shotfile) then
        call nag_spline_2d_eval(plasma_params%rhop_spline_nag, plasma_params%R_sep, plasma_params%z_sep, rhop_X)
        print*,"Position of X point and rho pol value from spline", plasma_params%R_sep, plasma_params%z_sep, rhop_X
      end if
      call nag_spline_2d_interp(plasma_params%R, plasma_params%z, B_r, plasma_params%B_r_spline_nag)
      call nag_spline_2d_interp(plasma_params%R, plasma_params%z, B_t, plasma_params%B_t_spline_nag)!_cor
      call nag_spline_2d_interp(plasma_params%R, plasma_params%z, B_z, plasma_params%B_z_spline_nag)
    end if
#endif
    plasma_params%B_ax = 0.d0
    call rect_spline(plasma_params%B_r_spline, plasma_params%R_ax,plasma_params%z_ax,B_last)
    plasma_params%B_ax = plasma_params%B_ax + B_last**2
    call rect_spline(plasma_params%B_t_spline,plasma_params%R_ax,plasma_params%z_ax,B_last)
    plasma_params%B_ax = plasma_params%B_ax + B_last**2
    call rect_spline(plasma_params%B_z_spline,plasma_params%R_ax,plasma_params%z_ax,B_last)
    plasma_params%B_ax = plasma_params%B_ax + B_last**2
    plasma_params%B_ax = Sqrt(plasma_params%B_ax)
    do i = 0, plasma_params%m - 1
      if(abs(B_t(plasma_params%m - i, int(plasma_params%n/2))) > 1.d-1) then
        m = plasma_params%m - i
        exit
      end if
    end do
    B_vac_R0 = B_t(m, int(plasma_params%n/2)) ! Outer most point of Bt with Bt > 0 -> pure vacuum
    B_vac_R0 = B_vac_R0 * plasma_params%R(plasma_params%m) / plasma_params%R_ax
    if(plasma_params%w_ripple) call init_ripple(plasma_params%R_ax, B_vac_R0)
    allocate(R_index_lower(plasma_params%n), z_index_lower(plasma_params%m), R_index_upper(plasma_params%n), z_index_upper(plasma_params%m))
    R_index_lower(:) = 1
    z_index_lower(:) = 1
    R_index_upper(:) = plasma_params%m
    z_index_upper(:) = plasma_params%n
    deallocate(B_r, B_z, B_t, R_index_lower,z_index_lower,R_index_upper,z_index_upper)!, B_t
    if(plasma_params%Te_ne_mat) deallocate(T_e_mat, n_e_mat)
    if(stand_alone) then
      ! Load the polygon describing the vessel wall
      open(66, file = vessel_bd_filename)
      read(66, "(I7.7)") plasma_params%m_vessel_bd
      allocate(plasma_params%vessel_poly%x(plasma_params%m_vessel_bd), plasma_params%vessel_poly%y(plasma_params%m_vessel_bd))
      do i = 1, plasma_params%m_vessel_bd
        read(66,"(E19.12E2A1E19.12E2)") plasma_params%vessel_poly%x(i), sep,  plasma_params%vessel_poly%y(i)
      end do
      close(66)
     end if
  end subroutine setup_plasma_params

  subroutine read_input_lists(plasma_params)
  ! Read the input data n_e, T_e and wall file
    use mod_ECRad_types,       only: plasma_params_type, n_e_filename, T_e_filename, &
                                     min_density, min_Te, max_Te, output_level
    use f90_kind
    use constants, only               : pi
    implicit none
    type(plasma_params_type), intent(inout)           :: plasma_params
    integer(ikind)                                    :: i
    character(1)                                      :: sep
    real(rkind)                                       :: rhop_max_Te, rhop_max_ne, last_rhop
    if(.not. plasma_params%Te_ne_mat) then
      open(66, file = n_e_filename)
      read(66, "(I7.7)") plasma_params%m_n_e_prof
      allocate(plasma_params%rhop_vec_ne(plasma_params%m_n_e_prof), &
               plasma_params%n_e_prof(plasma_params%m_n_e_prof))
      rhop_max_ne = -1.d0
      do i = 1, plasma_params%m_n_e_prof
        read(66,"(E19.12E2A1E19.12E2)") plasma_params%rhop_vec_ne(i), sep, plasma_params%n_e_prof(i)
        if(i > 1) then
          if(last_rhop > plasma_params%rhop_vec_ne(i)) then
            print*, "Error while reading the density profile from file"
            print*, "The rho poloidal has to be strictly increasing!"
            print*, "Current line", i + 1
            print*, "Rho pol from previous line and rho_pol from last line", last_rhop, plasma_params%rhop_vec_ne(i)
            call abort()
          end if
        end if
        last_rhop = plasma_params%rhop_vec_ne(i)
      end do
      if( all(plasma_params%n_e_prof < min_density)) then
        print*, "Error while reading the density profile from file"
        print*, "Not a single point in the density profile is larger than",  min_density
        print*, "The density profile must be given in m^-3"
        print*, "Plasmas with densities below",  min_density, " are not supported at the moment"
        call abort()
      end if
      close(66)
      open(66, file = T_e_filename)
      read(66, "(I7.7)") plasma_params%m_T_e_prof
      allocate(plasma_params%rhop_vec_Te(plasma_params%m_T_e_prof), &
               plasma_params%T_e_prof(plasma_params%m_T_e_prof))
      do i = 1, plasma_params%m_T_e_prof
        read(66,"(E19.12E2A1E19.12E2)") plasma_params%rhop_vec_Te(i), sep, plasma_params%T_e_prof(i)
        if(i > 1) then
          if(last_rhop > plasma_params%rhop_vec_Te(i)) then
            print*, "Error while reading the temperature profile from file"
            print*, "The rho poloidal has to be strictly increasing!"
            print*, "Current line", i + 1
            print*, "Rho pol from previous line and rho_pol from last line", last_rhop, plasma_params%rhop_vec_Te(i)
            call abort()
          end if
        end if
        last_rhop = plasma_params%rhop_vec_Te(i)
      end do
      if( all(plasma_params%T_e_prof < min_Te)) then
        print*, "Error while reading the temperature profile from file"
        print*, "Not a single point in the temperature profile is larger than", min_Te
        print*, "The temperature profile must be given in eV"
        print*, "Plasmas with electron temperatures below",  min_Te, " are not supported at the moment"
        call abort()
      end if
      if( any(plasma_params%T_e_prof > max_Te)) then
        print*, "Error while reading the temperature profile from file"
        print*, "A point of temperature profile is larger than", max_Te, " < ", maxval(plasma_params%T_e_prof)
        print*, "The temperature profile must be given in eV"
        print*, "Plasmas with electron temperatures higher than",  max_Te, " are not supported at the moment"
        call abort()
      end if
      rhop_max_Te = maxval(plasma_params%rhop_vec_Te, dim = 1)
      rhop_max_ne = maxval(plasma_params%rhop_vec_ne, dim = 1)
      plasma_params%rhop_max = min(rhop_max_te, rhop_max_ne)
      if(output_level) print*, "Largest rhopol in profiles", plasma_params%rhop_max
      if(plasma_params%rhop_exit > plasma_params%rhop_max-plasma_params%delta_rhop_exit) then
        plasma_params%rhop_exit = plasma_params%rhop_max-plasma_params%delta_rhop_exit
      end if
      close(66)
      if(plasma_params%m_T_e_prof < 40 .or. plasma_params%m_n_e_prof < 40) then
        print*, "points for density and Te profile:", plasma_params%m_T_e_prof
        stop "both density and temperature profile have to have MORE than 40 points"
      end if
    end if
  end subroutine read_input_lists

  subroutine init_raytrace(plasma_params, R, z, rhop, Br, Bt, Bz, R_ax, z_ax, T_e_mat, n_e_mat)
    use f90_kind
    use mod_ECRad_types,       only: plasma_params_type, stand_alone, use_3D, eq_mode
    Use constants                , only : pi
    implicit none
    type(plasma_params_type), intent(inout)           :: plasma_params
    real(rkind), dimension(:), intent(in), optional   :: R, z
    real(rkind), dimension(:,:), intent(in), optional :: rhop, Br, Bt, Bz, T_e_mat, n_e_mat
    real(rkind), intent(in), optional                 :: R_ax, z_ax
    if(eq_mode == "2D") then
      plasma_params%Te_ne_mat = .true.
    end if
    if(stand_alone) then
      if(.not. plasma_params%Te_ne_mat) call read_input_lists(plasma_params)
      call setup_plasma_params(plasma_params)
    else
      if(present(T_e_mat)) then
        call setup_plasma_params(plasma_params, R, z, rhop, Br, Bt, Bz, R_ax, z_ax, T_e_mat, n_e_mat)
      else
        call setup_plasma_params(plasma_params, R, z, rhop, Br, Bt, Bz, R_ax, z_ax)
      end if
    end if
  end subroutine init_raytrace

  subroutine dealloc_raytrace(plasma_params)
  use f90_kind
#ifdef NAG
  use mod_ECRad_types,       only: plasma_params_type, stand_alone, double_check_splines, &
                                   Use_3D, ray_init
  USE nag_lib_support,           only : nag_deallocate
#else
  use mod_ECRad_types,       only: plasma_params_type, stand_alone, Use_3D, ray_init
#endif
  use mod_ECRad_interpol,       only: deallocate_rect_spline, deallocate_1d_spline
  implicit none
  type(plasma_params_type), intent(inout)                    :: plasma_params
  ! Need to do this first since we can have this allocated but not anything else
  if(.not. use_3D) then
    if(allocated(plasma_params%vessel_poly%x)) deallocate(plasma_params%vessel_poly%x, plasma_params%vessel_poly%y)
  end if
    if(.not. (allocated(plasma_params%R) .or. allocated(plasma_params%Use_3D_vessel%vessel_data_R))) return
    if(stand_alone) then
      deallocate(plasma_params%n_e_prof, plasma_params%rhop_vec_ne)
      deallocate(plasma_params%T_e_prof, plasma_params%rhop_vec_Te)
#ifdef NAG
      if(output_level .and. double_check_splines) then
        call nag_deallocate(plasma_params%ne_spline_nag)
        call nag_deallocate(plasma_params%Te_spline_nag)
      end if
#endif
    else
      call deallocate_1d_spline(plasma_params%Te_spline)
      call deallocate_1d_spline(plasma_params%ne_spline)
    end if
    deallocate(plasma_params%Int_absz, plasma_params%Int_weights)
    deallocate(plasma_params%R, plasma_params%z, plasma_params%rhop)
    call deallocate_rect_spline(plasma_params%rhop_spline)
    call deallocate_rect_spline(plasma_params%B_R_spline)
    call deallocate_rect_spline(plasma_params%B_t_spline)
    call deallocate_rect_spline(plasma_params%B_z_spline)
    if(plasma_params%Te_ne_mat) then
      call deallocate_rect_spline(plasma_params%T_e_spline_2D)
      call deallocate_rect_spline(plasma_params%n_e_spline_2d)
    end if
#ifdef NAG
    if(output_level .and. double_check_splines) then
      call nag_deallocate(plasma_params%rhop_spline_nag)
      call nag_deallocate(plasma_params%B_R_spline_nag)
      call nag_deallocate(plasma_params%B_t_spline_nag)
      call nag_deallocate(plasma_params%B_z_spline_nag)
    end if
    if(plasma_params%Te_ne_mat .and. output_level .and. double_check_splines) then
      call nag_deallocate(plasma_params%ne_spline_nag_2D)
      call nag_deallocate(plasma_params%Te_spline_nag_2D)
    end if
#endif
  if(Use_3D) deallocate(plasma_params%Use_3D_vessel%vessel_data_R, &
                        plasma_params%Use_3D_vessel%vessel_data_z, &
                        plasma_params%Use_3D_vessel%phi)
  ray_init = .false.
  end subroutine dealloc_raytrace

end module mod_ECRad_raytrace_initialize


! =============================================================================
!     This module is the 3D version and contains all ellipsoid operations.
!     Reference:
!       Dritschel, D., Reinaud, J., & McKiver, W. (2004).
!       The quasi-geostrophic ellipsoidal vortex model.
!       Journal of Fluid Mechanics, 505, 201-223.
!       doi:10.1017/S0022112004008377
! =============================================================================
module parcel_ellipsoid
    use constants, only : fpi   &
                        , fpi4  &
                        , f34   &
                        , zero  &
                        , two   &
                        , three &
                        , five  &
                        , seven
    use parameters, only : max_num_parcels
    use jacobi
    implicit none

    double precision, parameter :: rho = dsqrt(two / five)
    double precision, parameter :: f3pi4 = three * fpi4
    double precision, parameter :: f5pi4 = five * fpi4
    double precision, parameter :: f7pi4 = seven * fpi4
    double precision, parameter :: costheta(4) = dcos((/fpi4, f3pi4, f5pi4, f7pi4/))
    double precision, parameter :: sintheta(4) = dsin((/fpi4, f3pi4, f5pi4, f7pi4/))

    double precision, allocatable :: Vetas(:, :), Vtaus(:, :)

    private :: rho, f3pi4, f5pi4, f7pi4, costheta, sintheta, get_upper_triangular, Vetas, Vtaus

    contains

        subroutine parcel_ellipsoid_allocate
            allocate(Vetas(3, max_num_parcels))
            allocate(Vtaus(3, max_num_parcels))
        end subroutine parcel_ellipsoid_allocate

        subroutine parcel_ellipsoid_deallocate
            deallocate(Vetas)
            deallocate(Vtaus)
        end subroutine parcel_ellipsoid_deallocate

        ! Obtain the parcel shape matrix.
        ! @param[in] B = (B11, B12, B13, B22, B23)
        ! @param[in] volume of the parcel
        ! @returns the upper trinagular matrix
        function get_upper_triangular(B, volume) result(U)
            double precision, intent(in) :: B(5)
            double precision, intent(in) :: volume
            double precision             :: U(3, 3)

            U(1, 1) = B(1)
            U(1, 2) = B(2)
            U(1, 3) = B(3)
            U(2, 2) = B(4)
            U(2, 3) = B(5)
            U(3, 3) = get_B33(B, volume)
        end function get_upper_triangular

        ! Obtain all eigenvalues sorted in descending order
        ! @param[in] B = (B11, B12, B13, B22, B23)
        ! @param[in] volume of the parcel
        ! @returns all eigenvalues (sorted in descending order)
        function get_eigenvalues(B, volume) result(D)
            double precision, intent(in) :: B(5)
            double precision, intent(in) :: volume
            double precision             :: U(3, 3)
            double precision             :: D(3)

            U = get_upper_triangular(B, volume)

            call jacobi_eigenvalues(U, D)

#ifndef NDEBUG
            ! check if any eigenvalue is less or equal zero
            if (minval(D) <= zero) then
                print *, "Invalid parcel shape."
                stop
            endif
#endif
        end function get_eigenvalues

        function get_determinant(B, volume) result(detB)
            double precision, intent(in) :: B(5)
            double precision, intent(in) :: volume
            double precision             :: detB, B33

            B33 = get_B33(B, volume)

            detB = B(1) * (B(4) * B33 - B(5) ** 2)    &
                 - B(2) * (B(2) * B33 - B(3) * B(5))  &
                 + B(3) * (B(2) * B(5) - B(3) * B(4))
        end function get_determinant

        ! Obtain the normalized eigenvectors.
        ! The eigenvector V(:, j) belongs to the j-th
        ! eigenvalue.
        ! @param[in] B = (B11, B12, B13, B22, B23)
        ! @param[in] volume of the parcel
        ! @returns the eigenvectors
        function get_eigenvectors(B, volume) result(V)
            double precision, intent(in) :: B(5)
            double precision, intent(in) :: volume
            double precision             :: U(3, 3), D(3), V(3, 3)

            U = get_upper_triangular(B, volume)

            call jacobi_diagonalise(U, D, V)

#ifndef NDEBUG
            ! check if any eigenvalue is less or equal zero
            if (minval(D) <= zero) then
                print *, "Invalid parcel shape."
                stop
            endif
#endif
        end function get_eigenvectors

        ! Compute the eigenvalue decomposition B = V^T * D * V
        ! where D has the eigenvalues on its diagonal
        ! and V contains the eigenvectors in its columns.
        ! The eigenvector V(:, j) belongs to the j-th
        ! eigenvalue.
        ! @param[in] B = (B11, B12, B13, B22, B23)
        ! @param[in] volume of the parcel
        ! @param[out] D eigenvalues (sorted in descending order)
        ! @param[out] V eigenvectors
        subroutine diagonalise(B, volume, D, V)
            double precision, intent(in)  :: B(5)
            double precision, intent(in)  :: volume
            double precision, intent(out) :: D(3), V(3, 3)
            double precision              :: U(3, 3)

            U = get_upper_triangular(B, volume)

            call jacobi_diagonalise(U, D, V)

#ifndef NDEBUG
            ! check if any eigenvalue is less or equal zero
            if (minval(D) <= zero) then
                print *, "Invalid parcel shape."
                stop
            endif
#endif
        end subroutine diagonalise

        ! Obtain the B33 matrix element
        ! @param[in] B = (B11, B12, B13, B22, B23)
        ! @param[in] volume of the parcel
        ! @returns B33
        function get_B33(B, volume) result(B33)
            double precision, intent(in) :: B(5)
            double precision, intent(in) :: volume
            double precision             :: abc
            double precision             :: B33

            abc = get_abc(volume)

            if (dabs(B(1) * B(4) - B(2) ** 2) <= epsilon(abc)) then
                print *, "Error in get_B33: Division by small number!"
                stop
            endif

            B33 = (abc ** 2 - B(3) * (B(2) * B(5) - B(3) * B(4)) &
                            + B(1) * B(5) ** 2                   &
                            - B(2) * B(3) * B(5))                &
                / (B(1) * B(4) - B(2) ** 2)

        end function get_B33

        ! Obtain the product of the semi-minor and semi-major axis.
        ! @param[in] volume of the parcel
        ! @returns abc = 3 * volume / (4 * pi)
        pure elemental function get_abc(volume) result(abc)
            double precision, intent(in) :: volume
            double precision             :: abc

            abc = f34 * volume * fpi
        end function get_abc

        ! Obtain the aspect ratio a/c of the parcel(s).
        ! @param[in] D eigenvalues sorted in descending order
        ! @param[in] volume of the parcel(s)
        ! @returns a/c
        pure function get_aspect_ratio(D) result(lam)
            double precision, intent(in) :: D(3)
            double precision             :: lam

            lam = dsqrt(D(1) / D(3))
        end function get_aspect_ratio

        ! Obtain the ellipse support points for par2grid and grid2par
        ! @param[in] position vector of the parcel
        ! @param[in] volume of the parcel
        ! @param[in] B matrix elements of the parcel
        ! @returns the parcel support points
        function get_ellipsoid_points(position, volume, B, n, l_reuse) result(points)
            double precision,  intent(in) :: position(3)
            double precision,  intent(in) :: volume
            double precision,  intent(in) :: B(5)        ! B11, B12, B13, B22, B23
            integer, optional, intent(in) :: n
            logical, optional, intent(in) :: l_reuse
            double precision              :: Veta(3), Vtau(3), D(3), V(3, 3)
            integer                       :: j
            double precision              :: points(3, 4)

            if (present(l_reuse)) then
                if (l_reuse) then
                    Veta = Vetas(:, n)
                    Vtau = Vtaus(:, n)
                else
                    call diagonalise(B, volume, D, V)
                    Veta = dsqrt(dabs(D(1) - D(3))) * rho * V(:, 1)
                    Vtau = dsqrt(dabs(D(2) - D(3))) * rho * V(:, 2)

                    Vetas(:, n) = Veta
                    Vtaus(:, n) = Vtau
                endif
            else
                ! (/a2, b2, c2/) with a >= b >= c
                ! D = (/a2, b2, c2/)
                call diagonalise(B, volume, D, V)

                Veta = dsqrt(dabs(D(1) - D(3))) * rho * V(:, 1)
                Vtau = dsqrt(dabs(D(2) - D(3))) * rho * V(:, 2)

                Vetas(:, n) = Veta
                Vtaus(:, n) = Vtau
            endif

            do j = 1, 4
                ! support point in the reference frame of the ellipsoid
                ! theta = j * pi / 2 - pi / 4 (j = 1, 2, 3, 4)
                ! x_j = eta * rho * cos(theta_j)
                ! y_j = tau * rho * sin(theta_j)

                ! suppport point in the global reference frame
                points(:, j) = position           &
                             + Veta * costheta(j) &
                             + Vtau * sintheta(j)
            enddo
        end function get_ellipsoid_points

        function get_angles(B, volume) result(angles)
            double precision, intent(in) :: B(5)
            double precision, intent(in) :: volume
            double precision             :: evec(3, 3)
            double precision             :: angles(2) ! (/azimuth, polar/)

            evec = get_eigenvectors(B, volume)

            ! azimuthal angle
            angles(1) = datan2(evec(2, 1), evec(1, 1))

            ! polar angle
            angles(2) = dasin(evec(3, 3))

        end function get_angles

end module parcel_ellipsoid


  function initializeQintsData () result(errorFlag)

! ======================================================================
!
! Sets up data used by the "qints" function (described below):
!      Parabolic interpolation of tabulated cross sections.
!      For lq = 1-4 and 15-19, use a parabola in log(sigma) vs. log(E)
!      for energies (x) less than the 2nd point.
!
!    Called by: BINEL ISOBAR SIGMAT8
!
!    CEM95 written by S. G. Mashnik
!    Edited by A. J. Sierk,  LANL  T-2  February, 1996.
!    Modified for new cross section tables, June, 1997 (AJS)
!    Edited by A. J. Sierk, LANL T-16, October, 2003.
!    Modified to define once an array of a, b, c coefficients
!      to speed up code.  AJS  February, 2005.
!    Edited by AJS, LANL T-2, December, 2011.
!
! ======================================================================

    use, intrinsic:: iso_fortran_env, only: int32, real64
    use standardDCMParams, only: zro, one

    implicit none
    integer(int32) :: errorFlag

    integer(int32) :: ij, lpha0, lpmax0, lq0
    real(real64) :: a, b, c, delta, deltaa, deltab, deltac, fact, phi1, &
         & phi2, phi3, psi1, psi2, psi3
    logical ilog1

! ======================================================================

    errorFlag = sDCMDataSetup

    do lq0 = 1,28

       ! Determine proper value for "ilog1"
       ilog1 = .false.
       lpmax0 = 31
       if (lq0 <= 4) then
          ilog1 = .true.
          lpmax0 = 30
       elseif (lq0 > 14 .and. lq0 <= 19) then
          ilog1 = .true.
       elseif (lq0 == 20 .or. lq0 == 21 .or. lq0 == 28) then
          ilog1 = .true.
       elseif (lq0 >= 23 .and. lq0 <= 27) then
          ilog1 = .true.
       endif

       ij = iiQints(lq0)
       do lpha0 = 2,lpmax0-1
          phi1 = sigma(lpha0-1,lq0)
          psi1 = argus(lpha0-1,ij)
          phi2 = sigma(lpha0,lq0)
          psi2 = argus(lpha0,ij)
          phi3 = sigma(lpha0+1,lq0)
          psi3 = argus(lpha0+1,ij)
          if (ilog1 .and. lpha0 == 2) then
             phi1 = log(sigma(lpha0-1,lq0))
             psi1 = log(max(argus(lpha0-1,ij), 1.d-6))
             phi2 = log(sigma(lpha0,lq0))
             psi2 = log(argus(lpha0,ij))
             phi3 = log(sigma(lpha0+1,lq0))
             psi3 = log(argus(lpha0+1,ij))
          endif
          a = psi2 - psi3
          b = psi3 - psi1
          c = psi1 - psi2
          delta = a*psi1**2 + b*psi2**2 + c*psi3**2
          deltaa = phi1*a + phi2*b + phi3*c
          deltab = (phi2 - phi3)*psi1**2 + (phi3 - phi1)*psi2**2 + &
               & (phi1 - phi2)*psi3**2
          deltac = (psi2*phi3 - psi3*phi2)*psi1**2 + &
               & (psi3*phi1 - psi1*phi3)*psi2**2 + &
               & (psi1*phi2 - psi2*phi1)*psi3**2
          fact = zro
          if (delta.ne.zro) fact = one/delta

          ! Initialize "qints" data (aa, bb, cc)
          aa(lpha0,lq0) = deltaa*fact
          bb(lpha0,lq0) = deltab*fact
          cc(lpha0,lq0) = deltac*fact
       end do
    end do

    return

! ======================================================================
  end function initializeQintsData


      SUBROUTINE MB4DPZ( JOB, N, THRESH, A, LDA, DE, LDDE, C, LDC, VW,
     $                   LDVW, ILO, LSCALE, RSCALE, DWORK, IWARN, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To balance the 2*N-by-2*N complex skew-Hamiltonian/Hamiltonian
C     pencil aS - bH, with
C
C           (  A  D  )         (  C  V  )
C       S = (        ) and H = (        ),  A, C N-by-N,             (1)
C           (  E  A' )         (  W -C' )
C
C     where D and E are skew-Hermitian, V and W are Hermitian matrices,
C     and ' denotes conjugate transpose. This involves, first, permuting
C     aS - bH by a symplectic equivalence transformation to isolate
C     eigenvalues in the first 1:ILO-1 elements on the diagonal of A
C     and C; and second, applying a diagonal equivalence transformation
C     to make the pairs of rows and columns ILO:N and N+ILO:2*N as close
C     in 1-norm as possible. Both steps are optional. Balancing may
C     reduce the 1-norms of the matrices S and H.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Specifies the operations to be performed on S and H:
C             = 'N':  none:  simply set ILO = 1, LSCALE(I) = 1.0 and
C                     RSCALE(I) = 1.0 for i = 1,...,N.
C             = 'P':  permute only;
C             = 'S':  scale only;
C             = 'B':  both permute and scale.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of matrices A, D, E, C, V, and W.  N >= 0.
C
C     THRESH  (input) DOUBLE PRECISION
C             If JOB = 'S' or JOB = 'B', and THRESH >= 0, threshold
C             value for magnitude of the elements to be considered in
C             the scaling process: elements with magnitude less than or
C             equal to THRESH*MXNORM are ignored for scaling, where
C             MXNORM is the maximum of the 1-norms of the original
C             submatrices S(s,s) and H(s,s), with s = [ILO:N,N+ILO:2*N].
C             If THRESH < 0, the subroutine finds the scaling factors
C             for which some conditions, detailed below, are fulfilled.
C             A sequence of increasing strictly positive threshold
C             values is used.
C             If THRESH = -1, the condition is that
C                max( norm(H(s,s),1)/norm(S(s,s),1),
C                     norm(S(s,s),1)/norm(H(s,s),1) )                (1)
C             has the smallest value, for the threshold values used,
C             where S(s,s) and H(s,s) are the scaled submatrices.
C             If THRESH = -2, the norm ratio reduction (1) is tried, but
C             the subroutine may return IWARN = 1 and reset the scaling
C             factors to 1, if this seems suitable. See the description
C             of the argument IWARN and FURTHER COMMENTS.
C             If THRESH = -3, the condition is that
C                norm(H(s,s),1)*norm(S(s,s),1)                       (2)
C             has the smallest value for the scaled submatrices.
C             If THRESH = -4, the norm reduction in (2) is tried, but
C             the subroutine may return IWARN = 1 and reset the scaling
C             factors to 1, as for THRESH = -2 above.
C             If THRESH = -VALUE, with VALUE >= 10, the condition
C             numbers of the left and right scaling transformations will
C             be bounded by VALUE, i.e., the ratios between the largest
C             and smallest entries in [LSCALE(ILO:N); RSCALE(ILO:N)]
C             will be at most VALUE. VALUE should be a power of 10.
C             If JOB = 'N' or JOB = 'P', the value of THRESH is
C             irrelevant.
C
C     A       (input/output) COMPLEX*16 array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix A.
C             On exit, the leading N-by-N part of this array contains
C             the matrix A of the balanced skew-Hamiltonian matrix S.
C             In particular, the strictly lower triangular part of the
C             first ILO-1 columns of A is zero.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,N).
C
C     DE      (input/output) COMPLEX*16 array, dimension (LDDE, N+1)
C             On entry, the leading N-by-N lower triangular part of
C             this array must contain the lower triangular part of the
C             skew-Hermitian matrix E, and the N-by-N upper triangular
C             part of the submatrix in the columns 2 to N+1 of this
C             array must contain the upper triangular part of the
C             skew-Hermitian matrix D. The real parts of the entries on
C             the diagonal and the first superdiagonal of this array
C             should be zero.
C             On exit, the leading N-by-N lower triangular part of this
C             array contains the lower triangular part of the balanced
C             matrix E, and the N-by-N upper triangular part of the
C             submatrix in the columns 2 to N+1 of this array contains
C             the upper triangular part of the balanced matrix D.
C             In particular, the lower triangular part of the first
C             ILO-1 columns of DE is zero.
C
C     LDDE    INTEGER
C             The leading dimension of the array DE.  LDDE >= MAX(1, N).
C
C     C       (input/output) COMPLEX*16 array, dimension (LDC, N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix C.
C             On exit, the leading N-by-N part of this array contains
C             the matrix C of the balanced Hamiltonian matrix H.
C             In particular, the strictly lower triangular part of the
C             first ILO-1 columns of C is zero.
C
C     LDC     INTEGER
C             The leading dimension of the array C.  LDC >= MAX(1, N).
C
C     VW      (input/output) COMPLEX*16 array, dimension (LDVW, N+1)
C             On entry, the leading N-by-N lower triangular part of
C             this array must contain the lower triangular part of the
C             Hermitian matrix W, and the N-by-N upper triangular
C             part of the submatrix in the columns 2 to N+1 of this
C             array must contain the upper triangular part of the
C             Hermitian matrix V. The imaginary parts of the entries on
C             the diagonal and the first superdiagonal of this array
C             should be zero.
C             On exit, the leading N-by-N lower triangular part of this
C             array contains the lower triangular part of the balanced
C             matrix W, and the N-by-N upper triangular part of the
C             submatrix in the columns 2 to N+1 of this array contains
C             the upper triangular part of the balanced matrix V. In
C             particular, the lower triangular part of the first ILO-1
C             columns of VW is zero.
C
C     LDVW    INTEGER
C             The leading dimension of the array VW.  LDVW >= MAX(1, N).
C
C     ILO     (output) INTEGER
C             ILO-1 is the number of deflated eigenvalues in the
C             balanced skew-Hamiltonian/Hamiltonian matrix pencil.
C             ILO is set to 1 if JOB = 'N' or JOB = 'S'.
C
C     LSCALE  (output) DOUBLE PRECISION array, dimension (N)
C             Details of the permutations of S and H and scaling applied
C             to A, D, C, and V from the left. For j = 1,...,ILO-1 let
C             P(j) = LSCALE(j). If P(j) <= N, then rows and columns P(j)
C             and P(j)+N are interchanged with rows and columns j and
C             j+N, respectively. If P(j) > N, then row and column P(j)-N
C             are interchanged with row and column j+N by a generalized
C             symplectic permutation. For j = ILO,...,N the j-th element
C             of LSCALE contains the factor of the scaling applied to
C             row j of the matrices A, D, C, and V.
C
C     RSCALE  (output) DOUBLE PRECISION array, dimension (N)
C             Details of the permutations of S and H and scaling applied
C             to A, E, C, and W from the right. For j = 1,...,ILO-1 let
C             P(j) = RSCALE(j). If P(j) <= N, then rows and columns P(j)
C             and P(j)+N are interchanged with rows and columns j and
C             j+N, respectively. If P(j) > N, then row and column P(j)-N
C             are interchanged with row and column j+N by a generalized
C             symplectic permutation. For j = ILO,...,N the j-th element
C             of RSCALE contains the factor of the scaling applied to
C             column j of the matrices A, E, C, and W.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK) where
C             LDWORK = 0,   if  JOB = 'N' or JOB = 'P', or N = 0;
C             LDWORK = 6*N, if (JOB = 'S' or JOB = 'B') and THRESH >= 0;
C             LDWORK = 8*N, if (JOB = 'S' or JOB = 'B') and THRESH <  0.
C             On exit, if JOB = 'S' or JOB = 'B', DWORK(1) and DWORK(2)
C             contain the initial 1-norms of S(s,s) and H(s,s), and
C             DWORK(3) and DWORK(4) contain their final 1-norms,
C             respectively. Moreover, DWORK(5) contains the THRESH value
C             used (irrelevant if IWARN = 1 or ILO = N).
C
C     Warning Indicator
C
C     IWARN   INTEGER
C             = 0:  no warning;
C             = 1:  scaling has been requested, for THRESH = -2 or
C                   THRESH = -4, but it most probably would not improve
C                   the accuracy of the computed solution for a related
C                   eigenproblem (since maximum norm increased
C                   significantly compared to the original pencil
C                   matrices and (very) high and/or small scaling
C                   factors occurred). The returned scaling factors have
C                   been reset to 1, but information about permutations,
C                   if requested, has been preserved.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit.
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     Balancing consists of applying a (symplectic) equivalence
C     transformation to isolate eigenvalues and/or to make the 1-norms
C     of each pair of rows and columns indexed by s of S and H nearly
C     equal. If THRESH < 0, a search is performed to find those scaling
C     factors giving the smallest norm ratio or product defined above
C     (see the description of the parameter THRESH).
C
C     Assuming JOB = 'S', let Dl and Dr be diagonal matrices containing
C     the vectors LSCALE and RSCALE, respectively. The returned matrices
C     are obtained using the equivalence transformation
C
C       ( Dl  0 ) ( A  D  ) ( Dr  0 )   ( Dl  0 ) ( C  V  ) ( Dr  0 )
C       (       ) (       ) (       ),  (       ) (       ) (       ).
C       ( 0  Dr ) ( E  A' ) ( 0  Dl )   ( 0  Dr ) ( W -C' ) ( 0  Dl )
C
C     For THRESH = 0, the routine returns essentially the same results
C     as the LAPACK subroutine ZGGBAL [1]. Setting THRESH < 0, usually
C     gives better results than ZGGBAL for badly scaled matrix pencils.
C
C     REFERENCES
C
C     [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J.,
C         Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A.,
C         Ostrouchov, S., and Sorensen, D.
C         LAPACK Users' Guide: Second Edition.
C         SIAM, Philadelphia, 1995.
C
C     [2] Benner, P.
C         Symplectic balancing of Hamiltonian matrices.
C         SIAM J. Sci. Comput., 22 (5), pp. 1885-1904, 2001.
C
C     NUMERICAL ASPECTS
C
C     The transformations used preserve the skew-Hamiltonian/Hamiltonian
C     structure and do not introduce significant rounding errors.
C     No rounding errors appear if JOB = 'P'. If T is the global
C     transformation matrix applied to the right, then J'*T*J is the
C     global transformation matrix applied to the left, where
C     J = [ 0 I; -I 0 ], with blocks of order N.
C
C     FURTHER COMMENTS
C
C     If THRESH = -2, the increase of the maximum norm of the scaled
C     submatrices, compared to the maximum norm of the initial
C     submatrices, is bounded by MXGAIN = 100.
C     If THRESH = -2, or THRESH = -4, the maximum condition number of
C     the scaling transformations is bounded by MXCOND = 1/SQRT(EPS),
C     where EPS is the machine precision (see LAPACK Library routine
C     DLAMCH).
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Dec. 2015.
C
C     REVISIONS
C
C     V. Sima, Jan. 2016, Jan. 2017, Feb. 2017.
C
C     KEYWORDS
C
C     Balancing, eigenvalue, equivalence transformation, matrix algebra,
C     matrix operations, symplectic equivalence transformation.
C
C  *********************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   HALF, ONE, TEN, TWO, ZERO
      PARAMETER          ( HALF = 0.5D+0, ONE  = 1.0D+0, TEN = 1.0D+1,
     $                     TWO  = 2.0D+0, ZERO = 0.0D+0 )
      DOUBLE PRECISION   MXGAIN, SCLFAC
      PARAMETER          ( MXGAIN = 1.0D+2, SCLFAC = 1.0D+1 )
      CHARACTER          LOW, NSKEW, NTRAN, SKEW, UPP
      PARAMETER          ( LOW   = 'Lower',       NSKEW = 'Not Skew',
     $                     NTRAN = 'No transpose', SKEW = 'Skew',
     $                     UPP   = 'Upper' )
      COMPLEX*16         CZERO
      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ) )
C     .. Scalar Arguments ..
      CHARACTER          JOB
      INTEGER            ILO, INFO, IWARN, LDA, LDC, LDDE, LDVW, N
      DOUBLE PRECISION   THRESH
C     .. Array Arguments ..
      DOUBLE PRECISION   DWORK(*), LSCALE(*), RSCALE(*)
      COMPLEX*16         A(LDA,*), C(LDC,*), DE(LDDE,*), VW(LDVW,*)
C     .. Local Scalars ..
      LOGICAL            EVNORM, LOOP, LPERM, LSCAL, STORMN
      INTEGER            I, ICAB, ILOOLD, IR, IRAB, IT, ITER, ITH, J,
     $                   JC, K, KOUNT, KS, KW1, KW2, KW3, KW4, KW5, KW6,
     $                   KW7, LRAB, LSFMAX, LSFMIN, NR, NRP2
      DOUBLE PRECISION   AB, ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2,
     $                   COEF5, COR, DENOM, EPS, EW, GAMMA, GAP, MINPRO,
     $                   MINRAT, MN, MX, MXCOND, MXNORM, MXS, NH, NH0,
     $                   NHS, NS, NS0, NSS, PGAMMA, PROD, RAB, RATIO,
     $                   SFMAX, SFMIN, SUM, T, TA, TC, TD, TE, TH, TH0,
     $                   THS, TV, TW
C     .. Local Arrays ..
      DOUBLE PRECISION   DUM(1)
C     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            IDAMAX, IZAMAX
      DOUBLE PRECISION   DDOT, DLAMCH, MA02IZ
      EXTERNAL           DDOT, DLAMCH, IDAMAX, IZAMAX, LSAME, MA02IZ
C     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DSCAL, MA02NZ, XERBLA, ZDSCAL,
     $                   ZSWAP
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, DCONJG, DIMAG, INT, LOG10, MAX, MIN,
     $                   SIGN, SQRT
C
C     .. Executable Statements ..
C
C     Test the input parameters.
C
      INFO  = 0
      IWARN = 0
      LPERM = LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' )
      LSCAL = LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' )
C
      IF( .NOT.LPERM .AND. .NOT.LSCAL .AND. .NOT.LSAME( JOB, 'N' ) )
     $   THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA .LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDDE.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDC .LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( LDVW.LT.MAX( 1, N ) ) THEN
         INFO = -11
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB4DPZ', -INFO )
         RETURN
      END IF
C
      ILO = 1
C
C     Quick return if possible.
C
      IF( N.EQ.0 )
     $   RETURN
      IF( ( .NOT.LPERM .AND. .NOT.LSCAL ) .OR. N.EQ.1 ) THEN
         DUM(1) = ONE
         CALL DCOPY( N, DUM, 0, LSCALE, 1 )
         CALL DCOPY( N, DUM, 0, RSCALE, 1 )
         IF( N.EQ.1 .AND. LSCAL ) THEN
            NS0 = MA02IZ( 'skew-Hamiltonian', '1-norm', N, A, LDA, DE,
     $                     LDDE, DWORK )
            NH0 = MA02IZ( 'Hamiltonian', '1-norm', N, C, LDC, VW, LDVW,
     $                     DWORK )
            DWORK(1) = NS0
            DWORK(2) = NH0
            DWORK(3) = NS0
            DWORK(4) = NH0
            DWORK(5) = THRESH
         END IF
         RETURN
      END IF
C
      IF( LPERM ) THEN
C
C        Permute the matrices S and H to isolate the eigenvalues.
C
         ILOOLD = 0
C        WHILE ( ILO.NE.ILOOLD )
   10    CONTINUE
         IF( ILO.NE.ILOOLD ) THEN
            ILOOLD = ILO
C
C           Scan columns ILO .. N.
C
            I = ILO
C           WHILE ( I.LE.N .AND. ILO.EQ.ILOOLD )
   20       CONTINUE
            IF( I.LE.N .AND. ILO.EQ.ILOOLD ) THEN
               DO 30  J = ILO, I-1
                  IF( A(J,I).NE.CZERO .OR. C(J,I).NE.CZERO ) THEN
                     I = I + 1
                     GOTO 20
                  END IF
   30          CONTINUE
               DO 40  J = I+1, N
                  IF( A(J,I).NE.CZERO .OR. C(J,I).NE.CZERO ) THEN
                     I = I + 1
                     GOTO 20
                  END IF
   40          CONTINUE
               DO 50  J = ILO, I-1
                  IF( DE(I,J).NE.CZERO .OR. VW(I,J).NE.CZERO ) THEN
                     I = I + 1
                     GOTO 20
                  END IF
   50          CONTINUE
               IF( DIMAG( DE(I,I) ).NE.ZERO ) THEN
                  I = I + 1
                  GOTO 20
               END IF
               IF( DBLE( VW(I,I) ).NE.ZERO ) THEN
                  I = I + 1
                  GOTO 20
               END IF
               DO 60  J = I+1, N
                  IF( DE(J,I).NE.CZERO .OR. VW(J,I).NE.CZERO ) THEN
                     I = I + 1
                     GOTO 20
                  END IF
   60          CONTINUE
C
C              Exchange columns/rows ILO <-> I.
C
               LSCALE(ILO) = I
               RSCALE(ILO) = I
C
               IF( ILO.NE.I ) THEN
C
                  CALL ZSWAP( N, A(1,ILO), 1, A(1,I), 1 )
                  CALL ZSWAP( N-ILO+1, A(ILO,ILO), LDA, A(I,ILO), LDA )
C
                  CALL MA02NZ( LOW, NTRAN, SKEW, N, ILO, I, DE, LDDE )
                  CALL MA02NZ( UPP, NTRAN, SKEW, N, ILO, I, DE(1,2),
     $                         LDDE )
C
                  CALL ZSWAP( N, C(1,ILO), 1, C(1,I), 1 )
                  CALL ZSWAP( N-ILO+1, C(ILO,ILO), LDC, C(I,ILO), LDC )
C
                  CALL MA02NZ( LOW, NTRAN, NSKEW, N, ILO, I, VW, LDVW )
                  CALL MA02NZ( UPP, NTRAN, NSKEW, N, ILO, I, VW(1,2),
     $                         LDVW )
               END IF
               ILO = ILO + 1
            END IF
C           END WHILE 20
C
C           Scan columns N+ILO .. 2*N.
C
            I = ILO
C           WHILE ( I.LE.N .AND. ILO.EQ.ILOOLD )
   70       CONTINUE
            IF( I.LE.N .AND. ILO.EQ.ILOOLD ) THEN
               DO 80  J = ILO, I-1
                  IF( A(I,J).NE.CZERO .OR. C(I,J).NE.CZERO ) THEN
                     I = I + 1
                     GOTO 70
                  END IF
   80          CONTINUE
               DO 90  J = I+1, N
                  IF( A(I,J).NE.CZERO .OR. C(I,J).NE.CZERO ) THEN
                     I = I + 1
                     GOTO 70
                  END IF
   90          CONTINUE
               DO 100  J = ILO, I-1
                  IF( DE(J,I+1).NE.CZERO .OR. VW(J,I+1).NE.CZERO ) THEN
                     I = I + 1
                     GOTO 70
                  END IF
  100          CONTINUE
               IF( DIMAG( DE(I,I+1) ).NE.ZERO ) THEN
                  I = I + 1
                  GOTO 70
               END IF
               IF( DBLE( VW(I,I+1) ).NE.ZERO ) THEN
                  I = I + 1
                  GOTO 70
               END IF
               DO 110  J = I+1, N
                  IF( DE(I,J+1).NE.CZERO .OR. VW(I,J+1).NE.CZERO ) THEN
                     I = I + 1
                     GOTO 70
                  END IF
  110          CONTINUE
C
C              Exchange columns/rows I <-> I+N with a symplectic
C              generalized permutation.
C
               LSCALE(ILO) = N + I
               RSCALE(ILO) = N + I
C
               CALL ZSWAP( I-ILO, A(I,ILO), LDA, DE(I,ILO), LDDE )
               CALL ZDSCAL( I-ILO, -ONE, A(I,ILO), LDA )
               IF( N.GT.I ) THEN
                  CALL ZSWAP( N-I, A(I,I+1), LDA, DE(I+1,I), 1 )
                  DO 120 J = I+1, N
                     A( I,J) = DCONJG( A(I,J) )
                     DE(J,I) = DCMPLX( -DBLE( DE(J,I) ),
     $                                 DIMAG( DE(J,I) ) )
  120             CONTINUE
               END IF
               CALL ZSWAP( I-1, A(1,I), 1, DE(1,I+1), 1 )
               CALL ZDSCAL( I-1, -ONE, A(1,I), 1 )
               IF( N.GT.I ) THEN
                  CALL ZSWAP( N-I, A(I+1,I), 1, DE(I,I+2), LDDE )
                  DO 130 J = I+1, N
                     A( J,I)   = DCONJG( A(J,I) )
                     DE(I,J+1) = DCMPLX( -DBLE( DE(I,J+1) ),
     $                                   DIMAG( DE(I,J+1) ) )
  130             CONTINUE
               END IF
               A(I,I)    = DCONJG( A(I,I) )
               T         =  DE(I,I)
               DE(I,I)   = -DE(I,I+1)
               DE(I,I+1) = -T
C
               CALL ZSWAP( I-ILO, C(I,ILO), LDC, VW(I,ILO), LDVW )
               CALL ZDSCAL( I-ILO, -ONE, C(I,ILO), LDC )
               IF( N.GT.I ) THEN
                  CALL ZSWAP( N-I, C(I,I+1), LDC, VW(I+1,I), 1 )
                  DO 140 J = I+1, N
                     VW(J,I) = DCONJG( VW(J,I) )
                     C( I,J) = DCMPLX( -DBLE( C(I,J) ),
     $                                 DIMAG( C(I,J) ) )
  140             CONTINUE
               END IF
               CALL ZSWAP( I-1, C(1,I), 1, VW(1,I+1), 1 )
               CALL ZDSCAL( I-1, -ONE, C(1,I), 1 )
               IF( N.GT.I ) THEN
                  CALL ZSWAP( N-I, C(I+1,I), 1, VW(I,I+2), LDVW )
                  DO 150 J = I+1, N
                     VW(I,J+1) = DCONJG( VW(I,J+1) )
                     C( J,I)   = DCMPLX( -DBLE( C(J,I) ),
     $                                   DIMAG( C(J,I) ) )
  150             CONTINUE
               END IF
               C(I,I)    = -DCONJG( C(I,I) )
               T         =  VW(I,I)
               VW(I,I)   = -VW(I,I+1)
               VW(I,I+1) = -T
C
C              Exchange columns/rows ILO <-> I.
C
               IF( ILO.NE.I ) THEN
C
                  CALL ZSWAP( N, A(1,ILO), 1, A(1,I), 1 )
                  CALL ZSWAP( N-ILO+1, A(ILO,ILO), LDA, A(I,ILO), LDA )
C
                  CALL MA02NZ( LOW, NTRAN, SKEW, N, ILO, I, DE, LDDE )
                  CALL MA02NZ( UPP, NTRAN, SKEW, N, ILO, I, DE(1,2),
     $                         LDDE )
C
                  CALL ZSWAP( N, C(1,ILO), 1, C(1,I), 1 )
                  CALL ZSWAP( N-ILO+1, C(ILO,ILO), LDC, C(I,ILO), LDC )
C
                  CALL MA02NZ( LOW, NTRAN, NSKEW, N, ILO, I, VW, LDVW )
                  CALL MA02NZ( UPP, NTRAN, NSKEW, N, ILO, I, VW(1,2),
     $                         LDVW )
               END IF
               ILO = ILO + 1
            END IF
C           END WHILE 70
            GOTO 10
         END IF
C        END WHILE 10
C
         DO 160 I = ILO, N
            LSCALE( I ) = ONE
            RSCALE( I ) = ONE
  160    CONTINUE
         IF( .NOT.LSCAL )
     $      RETURN
      END IF
C
      NR = N - ILO + 1
C
C     Compute initial 1-norms and return if ILO = N.
C
      NS0 = MA02IZ( 'skew-Hamiltonian', '1-norm', NR, A(ILO,ILO), LDA,
     $               DE(ILO,ILO), LDDE, DWORK )
      NH0 = MA02IZ( 'Hamiltonian', '1-norm', NR, C(ILO,ILO), LDC,
     $               VW(ILO,ILO), LDVW, DWORK )
C
      IF( ILO.EQ.N ) THEN
         DWORK(1) = NS0
         DWORK(2) = NH0
         DWORK(3) = NS0
         DWORK(4) = NH0
         DWORK(5) = THRESH
         RETURN
      END IF
C
C     Balance the submatrices in rows ILO to N.
C
C     Initialize balancing and allocate work storage.
C
      KW1 = N
      KW2 = KW1 + N
      KW3 = KW2 + N
      KW4 = KW3 + N
      KW5 = KW4 + N
      DUM(1) = ZERO
C
C     Prepare for scaling.
C
      SFMIN  = DLAMCH( 'Safe minimum' )
      SFMAX  = ONE / SFMIN
      BASL   = LOG10( SCLFAC )
      LSFMIN = INT( LOG10( SFMIN ) / BASL + ONE )
      LSFMAX = INT( LOG10( SFMAX ) / BASL )
      MXNORM = MAX( NS0, NH0 )
      LOOP   = THRESH.LT.ZERO
C
      IF( LOOP ) THEN
C
C        Compute relative threshold.
C
         NS  = NS0
         NSS = NS0
         NH  = NH0
         NHS = NH0
C
         ITH = THRESH
         MXS = MXNORM
         MX  = ZERO
         MN  = SFMAX
         IF( ITH.GE.-2 ) THEN
            IF( NS.LT.NH ) THEN
               RATIO = MIN( NH/NS, SFMAX )
            ELSE
               RATIO = MIN( NS/NH, SFMAX )
            END IF
            MINRAT = RATIO
         ELSE IF( ITH.LE.-10 ) THEN
            MXCOND = -THRESH
         ELSE
            DENOM  = MAX( ONE, MXNORM )
            PROD   = ( NS/DENOM )*( NH/DENOM )
            MINPRO = PROD
         END IF
         STORMN = .FALSE.
         EVNORM = .FALSE.
C
C        Find maximum order of magnitude of the differences in sizes of
C        the nonzero entries, not considering diag(A) and diag(C).
C
         DO 180 J = ILO, N
            DO 170 I = ILO, N
               IF( I.NE.J ) THEN
                  AB = ABS( A(I,J) )
                  IF( AB.NE.ZERO )
     $               MN = MIN( MN, AB )
                  MX = MAX( MX, AB )
               END IF
  170       CONTINUE
  180    CONTINUE
C
         DO 200 J = ILO, N
            DO 190 I = ILO, N
               AB = ABS( DE(I,J) )
               IF( AB.NE.ZERO )
     $            MN = MIN( MN, AB )
               MX = MAX( MX, AB )
               AB = ABS( DE(I,J+1) )
               IF( AB.NE.ZERO )
     $            MN = MIN( MN, AB )
               MX = MAX( MX, AB )
  190       CONTINUE
  200    CONTINUE
C
         DO 220 J = ILO, N
            DO 210 I = ILO, N
               IF( I.NE.J ) THEN
                  AB = ABS( C(I,J) )
                  IF( AB.NE.ZERO )
     $               MN = MIN( MN, AB )
                  MX = MAX( MX, AB )
               END IF
  210       CONTINUE
  220    CONTINUE
C
         DO 240 J = ILO, N
            DO 230 I = ILO, N
               AB = ABS( VW(I,J) )
               IF( AB.NE.ZERO )
     $            MN = MIN( MN, AB )
               MX = MAX( MX, AB )
               AB = ABS( VW(I,J+1) )
               IF( AB.NE.ZERO )
     $            MN = MIN( MN, AB )
               MX = MAX( MX, AB )
  230       CONTINUE
  240    CONTINUE
C
         IF( MX*SFMIN.LE.MN ) THEN
            GAP = MX/MN
         ELSE
            GAP = SFMAX
         END IF
         EPS  = DLAMCH( 'Precision' )
         ITER = MIN( INT( LOG10( GAP ) ), -INT( LOG10( EPS ) ) ) + 1
         TH   = MAX( MN, MX*EPS )/MAX( MXNORM, SFMIN )
         THS  = TH
         KW6  = KW5 + N + ILO
         KW7  = KW6 + N
         CALL DCOPY( NR, LSCALE(ILO), 1, DWORK(KW6), 1 )
         CALL DCOPY( NR, RSCALE(ILO), 1, DWORK(KW7), 1 )
C
C        Set the maximum condition number of the transformations.
C
         IF( ITH.GT.-10 )
     $      MXCOND = ONE/SQRT( EPS )
      ELSE
         TH     = MXNORM*THRESH
         ITER   = 1
         EVNORM = .TRUE.
      END IF
      TH0 = TH
C
      COEF  = HALF / DBLE( 2*NR )
      COEF2 = COEF*COEF
      COEF5 = HALF*COEF2
      NRP2  = NR + 2
      BETA  = ZERO
C
C     If THRESH < 0, use a loop to reduce the norm ratio.
C
      DO 490 K = 1, ITER
C
C        Compute right side vector in resulting linear equations.
C
         CALL DCOPY( 6*N, DUM, 0, DWORK, 1 )
         CALL DCOPY(  NR, DUM, 0, LSCALE(ILO), 1 )
         CALL DCOPY(  NR, DUM, 0, RSCALE(ILO), 1 )
         DO 260 I = ILO, N
            DO 250 J = ILO, N
               TA = ABS( A(I,J) )
               TC = ABS( C(I,J) )
               IF( J.GT.I ) THEN
                  TD = ABS( DE(I,J+1) )
                  TE = ABS( DE(J,I) )
                  TV = ABS( VW(I,J+1) )
                  TW = ABS( VW(J,I) )
               ELSE
                  TD = ABS( DE(J,I+1) )
                  TE = ABS( DE(I,J) )
                  TV = ABS( VW(J,I+1) )
                  TW = ABS( VW(I,J) )
               END IF
               IF( TA.GT.TH ) THEN
                  TA = LOG10( TA ) / BASL
               ELSE
                  TA = ZERO
               END IF
               IF( TC.GT.TH ) THEN
                  TC = LOG10( TC ) / BASL
               ELSE
                  TC = ZERO
               END IF
               IF( TD.GT.TH ) THEN
                  TD = LOG10( TD ) / BASL
               ELSE
                  TD = ZERO
               END IF
               IF( TE.GT.TH ) THEN
                  TE = LOG10( TE ) / BASL
               ELSE
                  TE = ZERO
               END IF
               IF( TV.GT.TH ) THEN
                  TV = LOG10( TV ) / BASL
               ELSE
                  TV = ZERO
               END IF
               IF( TW.GT.TH ) THEN
                  TW = LOG10( TW ) / BASL
               ELSE
                  TW = ZERO
               END IF
               DWORK(I+KW4) = DWORK(I+KW4) - TA - TC - TD - TV
               DWORK(J+KW5) = DWORK(J+KW5) - TA - TC - TE - TW
  250       CONTINUE
  260    CONTINUE
C
         IT = 1
C
C        Start generalized conjugate gradient iteration.
C
  270    CONTINUE
C
         GAMMA = ( DDOT( NR, DWORK(ILO+KW4), 1, DWORK(ILO+KW4), 1 ) +
     $             DDOT( NR, DWORK(ILO+KW5), 1, DWORK(ILO+KW5), 1 ) )*
     $           TWO
C
         EW = ZERO
         DO 280 I = ILO, N
            EW = EW + DWORK(I+KW4) + DWORK(I+KW5)
  280    CONTINUE
C
         GAMMA = COEF*GAMMA - TWO*COEF2*EW**2
         IF( GAMMA.EQ.ZERO )
     $      GO TO 350
         IF( IT.NE.1 )
     $      BETA = GAMMA / PGAMMA
         T = -TWO*COEF5*EW
C
         CALL DSCAL( NR, BETA, DWORK(ILO), 1 )
         CALL DSCAL( NR, BETA, DWORK(ILO+KW1), 1 )
C
         CALL DAXPY( NR, COEF, DWORK(ILO+KW4), 1, DWORK(ILO+KW1), 1 )
         CALL DAXPY( NR, COEF, DWORK(ILO+KW5), 1, DWORK(ILO), 1 )
C
         DO 290 J = ILO, N
            DWORK(J)     = DWORK(J)     + T
            DWORK(J+KW1) = DWORK(J+KW1) + T
  290    CONTINUE
C
C        Apply matrix to vector.
C
         DO 310 I = ILO, N
            KOUNT = 0
            SUM   = ZERO
            DO 300 J = ILO, N
               KS = KOUNT
               IF( A(I,J).NE.CZERO )
     $            KOUNT = KOUNT + 1
               IF( C(I,J).NE.CZERO )
     $            KOUNT = KOUNT + 1
               SUM = SUM + DBLE( KOUNT - KS )*DWORK(J)
C
               KS  = KOUNT
               IF( J.GE.I ) THEN
                  IF( DE(I,J+1).NE.CZERO )
     $               KOUNT = KOUNT + 1
                  IF( VW(I,J+1).NE.CZERO )
     $               KOUNT = KOUNT + 1
               ELSE
                  IF( DE(J,I+1).NE.CZERO )
     $               KOUNT = KOUNT + 1
                  IF( VW(J,I+1).NE.CZERO )
     $               KOUNT = KOUNT + 1
               END IF
               SUM = SUM + DBLE( KOUNT - KS )*DWORK(J+KW1)
  300       CONTINUE
            DWORK(I+KW2) = DBLE( KOUNT )*DWORK(I+KW1) + SUM
  310    CONTINUE
C
         DO 330 J = ILO, N
            KOUNT = 0
            SUM   = ZERO
            DO 320 I = ILO, N
               KS = KOUNT
               IF( A(I,J).NE.CZERO )
     $            KOUNT = KOUNT + 1
               IF( C(I,J).NE.CZERO )
     $            KOUNT = KOUNT + 1
               SUM = SUM + DBLE( KOUNT - KS )*DWORK(I+KW1)
C
               KS  = KOUNT
               IF( J.GE.I ) THEN
                  IF( DE(J,I).NE.CZERO )
     $               KOUNT = KOUNT + 1
                  IF( VW(J,I).NE.CZERO )
     $               KOUNT = KOUNT + 1
               ELSE
                  IF( DE(I,J).NE.CZERO )
     $               KOUNT = KOUNT + 1
                  IF( VW(I,J).NE.CZERO )
     $               KOUNT = KOUNT + 1
               END IF
               SUM = SUM + DBLE( KOUNT - KS )*DWORK(I)
  320       CONTINUE
            DWORK(J+KW3) = DBLE( KOUNT )*DWORK(J) + SUM
  330    CONTINUE
C
         SUM = ( DDOT( NR, DWORK(ILO+KW1), 1, DWORK(ILO+KW2), 1 ) +
     $           DDOT( NR, DWORK(ILO),     1, DWORK(ILO+KW3), 1 ) )*TWO
         ALPHA = GAMMA / SUM
C
C        Determine correction to current iteration.
C
         CMAX = ZERO
         DO 340 I = ILO, N
            COR = ALPHA*DWORK(I+KW1)
            IF( ABS( COR ).GT.CMAX )
     $         CMAX = ABS( COR )
            LSCALE(I) = LSCALE(I) + COR
            COR = ALPHA*DWORK(I)
            IF( ABS( COR ).GT.CMAX )
     $         CMAX = ABS( COR )
            RSCALE(I) = RSCALE(I) + COR
  340    CONTINUE
C
         IF( CMAX.GE.HALF ) THEN
C
            CALL DAXPY( N, -ALPHA, DWORK(ILO+KW2), 1, DWORK(ILO+KW4), 1)
            CALL DAXPY( N, -ALPHA, DWORK(ILO+KW3), 1, DWORK(ILO+KW5), 1)
C
            PGAMMA = GAMMA
            IT = IT + 1
            IF( IT.LE.NRP2 )
     $         GO TO 270
         END IF
C
C        End generalized conjugate gradient iteration.
C
  350    CONTINUE
C
C        Compute diagonal scaling matrices.
C
         DO 360 I = ILO, N
            IRAB = IZAMAX( NR, A(I,ILO), LDA )
            RAB  = ABS( A(I,ILO+IRAB-1) )
            IRAB = IZAMAX( NR, C(I,ILO), LDC )
            RAB  = MAX( RAB, ABS( C(I,ILO+IRAB-1) ) )
            IRAB = IZAMAX( I, DE(1,I+1), 1 )
            RAB  = MAX( RAB, ABS( DE(IRAB,I+1) ) )
            IF( N.GT.I ) THEN
               IRAB = IZAMAX( N-I, DE(I,I+2), LDDE )
               RAB  = MAX( RAB, ABS( DE(I,I+IRAB+1) ) )
            END IF
            IRAB = IZAMAX( I, VW(1,I+1), 1 )
            RAB  = MAX( RAB, ABS( VW(IRAB,I+1) ) )
            IF( N.GT.I ) THEN
               IRAB = IZAMAX( N-I, VW(I,I+2), LDVW )
               RAB  = MAX( RAB, ABS( VW(I,I+IRAB+1) ) )
            END IF
C
            LRAB = INT( LOG10( RAB+SFMIN ) / BASL + ONE )
            IR   = LSCALE(I) + SIGN( HALF, LSCALE(I) )
            IR   = MIN( MAX( IR, LSFMIN ), LSFMAX, LSFMAX-LRAB )
            LSCALE(I) = SCLFAC**IR
C
            ICAB = IZAMAX( N, A(1,I), 1 )
            CAB  = ABS( A(ICAB,I) )
            ICAB = IZAMAX( N, C(1,I), 1 )
            CAB  = MAX( CAB, ABS( C(ICAB,I) ) )
            ICAB = IZAMAX( I, DE(I,1), LDDE )
            CAB  = MAX( CAB, ABS( DE(I,ICAB) ) )
            IF( N.GT.I ) THEN
               ICAB = IZAMAX( N-I, DE(I+1,I), 1 )
               CAB  = MAX( CAB, ABS( DE(I+ICAB,I) ) )
            END IF
            ICAB = IZAMAX( I, VW(I,1), LDVW )
            CAB  = MAX( CAB, ABS( VW(I,ICAB) ) )
            IF( N.GT.I ) THEN
               ICAB = IZAMAX( N-I, VW(I+1,I), 1 )
               CAB  = MAX( CAB, ABS( VW(I+ICAB,I) ) )
            END IF
C
            LRAB = INT( LOG10( CAB+SFMIN ) / BASL + ONE )
            JC = RSCALE(I) + SIGN( HALF, RSCALE(I) )
            JC = MIN( MAX( JC, LSFMIN ), LSFMAX, LSFMAX-LRAB )
            RSCALE(I) = SCLFAC**JC
  360    CONTINUE
C
         DO 370 I = ILO, N
            IF( LSCALE(I).NE.ONE .OR. RSCALE(I).NE.ONE )
     $         GO TO 380
  370    CONTINUE
C
C        Finish the procedure for all scaling factors equal to 1.
C
         NSS = NS0
         NHS = NH0
         THS = TH0
         GO TO 550
C
  380    CONTINUE
C
         IF( LOOP ) THEN
            IF( ITH.LE.-10 ) THEN
C
C              Compute the reciprocal condition number of the left and
C              right transformations. Continue the loop if it is too
C              small.
C
               IR = IDAMAX( NR, LSCALE(ILO), 1 )
               JC = IDAMAX( NR, RSCALE(ILO), 1 )
               T  = MAX( LSCALE(ILO+IR-1), RSCALE(ILO+JC-1) )
               MN = T
               DO 390 I = ILO, N
                  IF( LSCALE(I).LT.MN )
     $               MN = LSCALE(I)
  390          CONTINUE
               DO 400 I = ILO, N
                  IF( RSCALE(I).LT.MN )
     $               MN = RSCALE(I)
  400          CONTINUE
               T = MN/T
               IF( T.LT.ONE/MXCOND ) THEN
                  TH = TH*TEN
                  GO TO 490
               ELSE
                  THS    = TH
                  EVNORM = .TRUE.
                  GO TO 520
               END IF
            END IF
C
C           Compute the 1-norms of the scaled submatrices,
C           without actually scaling them.
C
            NS = ZERO
            DO 420 J = ILO, N
               T = ZERO
               DO 410 I = ILO, N
                  T = T + ABS( A(I,J) )*LSCALE(I)*RSCALE(J)
                  IF( I.LT.J ) THEN
                     T = T + ABS( DE(J,I) )*RSCALE(I)*RSCALE(J)
                  ELSE
                     T = T + ABS( DE(I,J) )*RSCALE(I)*RSCALE(J)
                  END IF
  410          CONTINUE
               IF( T.GT.NS )
     $            NS = T
  420       CONTINUE
C
            DO 440 J = ILO, N
               T = ZERO
               DO 430 I = ILO, N
                  T = T + ABS( A(J,I) )*LSCALE(J)*RSCALE(I)
                  IF( I.LE.J ) THEN
                     T = T + ABS( DE(I,J+1) )*LSCALE(I)*LSCALE(J)
                  ELSE
                     T = T + ABS( DE(J,I+1) )*LSCALE(I)*LSCALE(J)
                  END IF
  430          CONTINUE
               IF( T.GT.NS )
     $            NS = T
  440       CONTINUE
C
            NH = ZERO
            DO 460 J = ILO, N
               T = ZERO
               DO 450 I = ILO, N
                  T = T + ABS( C(I,J) )*LSCALE(I)*RSCALE(J)
                  IF( I.LT.J ) THEN
                     T = T + ABS( VW(J,I) )*RSCALE(I)*RSCALE(J)
                  ELSE
                     T = T + ABS( VW(I,J) )*RSCALE(I)*RSCALE(J)
                  END IF
  450          CONTINUE
               IF( T.GT.NH )
     $            NH = T
  460       CONTINUE
C
            DO 480 J = ILO, N
               T = ZERO
               DO 470 I = ILO, N
                  T = T + ABS( C(J,I) )*LSCALE(J)*RSCALE(I)
                  IF( I.LE.J ) THEN
                     T = T + ABS( VW(I,J+1) )*LSCALE(I)*LSCALE(J)
                  ELSE
                     T = T + ABS( VW(J,I+1) )*LSCALE(I)*LSCALE(J)
                  END IF
  470          CONTINUE
               IF( T.GT.NH )
     $            NH = T
  480       CONTINUE
C
            IF( ITH.GE.-4 .AND. ITH.LT.-2 ) THEN
               PROD = ( NS/DENOM )*( NH/DENOM )
               IF( MINPRO.GT.PROD ) THEN
                  MINPRO = PROD
                  STORMN = .TRUE.
                  CALL DCOPY( NR, LSCALE(ILO), 1, DWORK(KW6), 1 )
                  CALL DCOPY( NR, RSCALE(ILO), 1, DWORK(KW7), 1 )
                  NSS = NS
                  NHS = NH
                  THS = TH
               END IF
            ELSE IF( ITH.GE.-2 ) THEN
               IF( NS.LT.NH ) THEN
                  RATIO = MIN( NH/NS, SFMAX )
               ELSE
                  RATIO = MIN( NS/NH, SFMAX )
               END IF
               IF( MINRAT.GT.RATIO ) THEN
                  MINRAT = RATIO
                  STORMN = .TRUE.
                  CALL DCOPY( NR, LSCALE(ILO), 1, DWORK(KW6), 1 )
                  CALL DCOPY( NR, RSCALE(ILO), 1, DWORK(KW7), 1 )
                  MXS = MAX( NS, NH )
                  NSS = NS
                  NHS = NH
                  THS = TH
               END IF
            END IF
            TH = TH*TEN
         END IF
  490 CONTINUE
C
C     Prepare for scaling.
C
      IF( LOOP ) THEN
         IF( ITH.LE.-10 ) THEN
C
C           Could not find enough well conditioned transformations
C           for THRESH <= -10. Set scaling factors to 1 and return.
C
            DUM(1) = ONE
            CALL DCOPY( NR, DUM(1), 0, LSCALE(ILO), 1 )
            CALL DCOPY( NR, DUM(1), 0, RSCALE(ILO), 1 )
            IWARN = 1
            GO TO 550
         END IF
C
C        Check if scaling might reduce the accuracy when solving related
C        eigenproblems, and set the scaling factors to 1 in this case,
C        if THRESH = -2 or THRESH = -4.
C
         IF( ( MXNORM.LT.MXS .AND. MXNORM.LT.MXS/MXGAIN .AND. ITH.EQ.-2)
     $         .OR. ITH.EQ.-4 ) THEN
            IR = IDAMAX( NR, DWORK(KW6), 1 )
            JC = IDAMAX( NR, DWORK(KW7), 1 )
            T  = MAX( DWORK(KW6+IR-1), DWORK(KW7+JC-1) )
            MN = T
            DO 500 I = KW6, KW6+NR-1
               IF( DWORK(I).LT.MN )
     $            MN = DWORK(I)
  500       CONTINUE
            DO 510 I = KW7, KW7+NR-1
               IF( DWORK(I).LT.MN )
     $            MN = DWORK(I)
  510       CONTINUE
            T = MN/T
            IF( T.LT.ONE/MXCOND ) THEN
               DUM(1) = ONE
               CALL DCOPY( NR, DUM(1), 0, LSCALE(ILO), 1 )
               CALL DCOPY( NR, DUM(1), 0, RSCALE(ILO), 1 )
               IWARN = 1
               NSS = NS0
               NHS = NH0
               THS = TH0
               GO TO 550
            END IF
         END IF
         IF( STORMN ) THEN
            CALL DCOPY( NR, DWORK(KW6), 1, LSCALE(ILO), 1 )
            CALL DCOPY( NR, DWORK(KW7), 1, RSCALE(ILO), 1 )
         ELSE
            NSS = NS
            NHS = NH
            THS = TH
         END IF
      END IF
C
  520 CONTINUE
C
C     Row scaling.
C
      DO 530 I = ILO, N
         CALL ZDSCAL(    NR, LSCALE(I), A(I,ILO),  LDA  )
         CALL ZDSCAL(    NR, LSCALE(I), C(I,ILO),  LDC  )
         CALL ZDSCAL(     I, LSCALE(I), DE(1,I+1), 1    )
         CALL ZDSCAL( N-I+1, LSCALE(I), DE(I,I+1), LDDE )
         CALL ZDSCAL(     I, LSCALE(I), VW(1,I+1), 1    )
         CALL ZDSCAL( N-I+1, LSCALE(I), VW(I,I+1), LDVW )
  530 CONTINUE
C
C     Column scaling.
C
      DO 540 J = ILO, N
         CALL ZDSCAL(     N, RSCALE(J), A(1,J),  1    )
         CALL ZDSCAL(     N, RSCALE(J), C(1,J),  1    )
         CALL ZDSCAL(     J, RSCALE(J), DE(J,1), LDDE )
         CALL ZDSCAL( N-J+1, RSCALE(J), DE(J,J), 1    )
         CALL ZDSCAL(     J, RSCALE(J), VW(J,1), LDVW )
         CALL ZDSCAL( N-J+1, RSCALE(J), VW(J,J), 1    )
  540 CONTINUE
C
C     Set DWORK(1:5).
C
  550 CONTINUE
      IF( EVNORM ) THEN
         NSS = MA02IZ( 'skew-Hamiltonian', '1-norm', NR, A(ILO,ILO),
     $                  LDA, DE(ILO,ILO), LDDE, DWORK )
         NHS = MA02IZ( 'Hamiltonian', '1-norm', NR, C(ILO,ILO), LDC,
     $                 VW(ILO,ILO), LDVW, DWORK )
      END IF
C
      DWORK(1) = NS0
      DWORK(2) = NH0
      DWORK(3) = NSS
      DWORK(4) = NHS
      IF( LOOP ) THEN
         DWORK(5) = THS/MAX( MXNORM, SFMIN )
      ELSE
         DWORK(5) = THRESH
      END IF
C
      RETURN
C *** Last line of MB4DPZ ***
      END


! { dg-do run }
! Test derived type constructors for derived types containing arrays.
! PR16919
program der_array_1
  implicit none
  integer n
  integer m
  ! The 4 components here test known shape array, unknown shape array,
  ! multi-dimensional arrays and array pointers
  type t
    integer :: a(2)
    integer :: b(2)
    integer, dimension(2, 3) :: c
    integer, pointer, dimension(:) :: p
  end type
  type(t) :: v
  integer, dimension(2, 3) :: d
  integer, dimension(:), pointer :: e
  integer, dimension(2) :: f

  m = 2
  f = (/3, 4/)
  d = reshape ((/5, 6, 7, 8, 9, 10/), (/2, 3/));
  allocate (e(2))

  v = t((/1, 2/), reshape (f, (/m/)), d, e);
  if (any (v%a .ne. (/1, 2/)) .or. any (v%b .ne. (/3, 4/)) &
      .or. any (v%c .ne. d) .or. .not. associated (v%p, e)) &
    STOP 1

  deallocate(e)
end program