subroutine screenz (t,d,z1,z2,a1,a2,ymass,aion,zion,nion,scfac, dscfacdt)
  use network, only: nspec
  !$acc routine seq
  implicit none

  integer nion
  double precision t, d, z1, z2, a1, a2
  double precision, dimension(nspec) :: ymass, aion, zion
  double precision scfac
  double precision dscfacdt

  ! this subroutine calculates screening factors for nuclear reaction
  ! rates in the weak, intermediate , and strong regimes given the
  ! temperature (t--degk), the density (d--g/cc), the atomic numbers
  ! and weights of the elements in the reaction channel with the
  ! largest coulomb barrier (z1,z2,a1,a2), and the mean plasma
  ! parameters calculated in main and passed over in common aver:
  ! (mean atomic number--zbar, mean square of the atomic
  ! number--z2bar, mean atomic weight--abar, and total number of moles
  ! of nuclei per gram--ytot1).  the unscreened rate is to be
  ! multiplied by the dimensionless the treatment is based on
  ! graboske, dewit, grossman, and cooper ap j. 181,457 (1973) for
  ! weak screening and on alastuey and jancovici, ap.j. 226, 1034,
  ! 1978, with plasma parameters from itoh, totsuji, setsuo, and
  ! dewitt, ap.j. 234, 1079,1979, for strong screening (rkw
  ! modification).

  !.... last revision 15 nov 1982

  double precision x13, x14, x53, x512
  parameter (x13=1.d+0/3.d+0, &
             x14=1.d+0/4.d+0, &
             x53=5.d+0/3.d+0, &
             x512=5.d+0/12.d+0)

  double precision abar, zbar, ytot1, z2bar, theta

  integer iy

  double precision qlam0, ztilda, qlam0z, gamp, taufac
  double precision dqlam0dt, dqlam0zdt, dgampdt, dtaufacdt
  double precision zhat, zhat2, gamef, tau12, alph12
  double precision dgamefdt, dtau12dt, dalph12dt
  double precision h12w, h12, c, h12fac
  double precision dh12wdt, dh12dt, dcdt

  ! calculate averages for screening routine
  ! nb  y = x/a with x the mass fraction
  ! zi and ai are the nuclear chage and atomic mass number
  ! respectively

  ! this part came in through a common block in Kepler -- do it
  ! directly here
  abar=0.d0
  zbar=0.d0
  ytot1=0.d0
  z2bar=0.d0

  do iy = 1, nion
     ytot1 = ytot1 + ymass(iy)
     z2bar = z2bar + zion(iy)**2*ymass(iy)
     abar = abar + aion(iy)*ymass(iy)
     zbar = zbar + zion(iy)*ymass(iy)
  enddo

  z2bar=z2bar/ytot1
  abar=abar/ytot1
  zbar=zbar/ytot1

  ! resume original Kepler screen...
  theta=1.d0
  ytot1=1.d0/abar

  !.... calculate average plasma parameters
  !....
  if ((z1*z2) > 0.d0) then

     qlam0=1.88d+8*sqrt(d/(abar*t**3))
     dqlam0dt=-1.5d+0*qlam0 / t

     ztilda=sqrt(z2bar+zbar*theta)

     qlam0z=qlam0*ztilda
     dqlam0zdt=ztilda*dqlam0dt

     gamp=2.27493d+5*(d*zbar*ytot1)**x13/t
     dgampdt=-gamp/t

     taufac=4.248719d+3/t**x13
     dtaufacdt=-x13*taufac/t

     !.... calculate screening factor
     !.... approx. for strong screening only good for alpha .lt. 1.6

     zhat=(z1+z2)**x53-z1**x53-z2**x53
     zhat2=(z1+z2)**x512-z1**x512-z2**x512

     gamef=2.d0**x13*gamp*z1*z2/(z1+z2)**x13
     dgamefdt=gamef*dgampdt/gamp

     tau12=taufac*(z1**2*z2**2*a1*a2/(a1+a2))**x13
     dtau12dt=tau12*dtaufacdt/taufac

     alph12=3.d0*gamef/tau12
     dalph12dt=alph12*(dgamefdt/gamef - dtau12dt/tau12)

     !....
     !.... limit alph12 to 1.6 to prevent unphysical behavior
     !.... (h dec. as rho inc.) at high rho.  this should really
     !.... be replaced by a pycnonuclear reaction rate formula.
     !....
     if (alph12 > 1.6d0) then

        alph12=1.6d0
        dalph12dt=0.0d0

        gamef=1.6d0*tau12/3.d0
        dgamefdt=gamef*dtau12dt/tau12

        gamp=gamef*(z1+z2)**x13/(2.d0**x13*z1*z2)
        dgampdt=gamp*dgamefdt/gamef

     endif

     h12w=z1*z2*qlam0z
     dh12wdt=h12w*dqlam0zdt/qlam0z

     h12=h12w
     dh12dt=dh12wdt

     if (gamef > 0.3d0) then

        c=0.896434d0*gamp*zhat-3.44740d0*gamp**x14*zhat2- &
             0.5551d0*(log(gamp)+x53*log(z1*z2/(z1+z2)))-2.996d0

        dcdt=0.896434d0*dgampdt*zhat- &
             3.44740d0*x14*gamp**(x14-1.0d0)*zhat2*dgampdt- &
             0.5551d0*dgampdt/gamp

        h12=c-(tau12/3.d0)*(5.d0*alph12**3/32.d0-0.014d0*alph12**4 &
             -0.0128d0*alph12**5)-gamef*(0.0055d0*alph12**4 &
             -0.0098d0*alph12**5+0.0048d0*alph12**6)

        dh12dt=dcdt - ((dtau12dt*alph12**3 + 3.0d0*tau12*alph12**2* &
             dalph12dt)*(5.d0/32.d0 - 0.014d0*alph12 - &
             0.0128d0*alph12**2) + tau12*alph12**3*dalph12dt*(-0.014d0 &
             - 2.d0*0.0128d0*alph12))/3.d0 -(dgamefdt*alph12**4 + 4.d0 &
             *gamef*alph12**3*dalph12dt)*(0.0055d0 - 0.0098d0*alph12 - &
             0.0048d0*alph12**2) - gamef*alph12**4*dalph12dt*(-0.0098d0 &
             + 2.d0*0.0048d0*alph12)

        h12fac=0.77d0

        h12=log(max(1.d+0-0.0562d+0*alph12**3,h12fac))+h12
        if (1.d+0-0.0562d+0*alph12**3 .gt. h12fac) then
           dh12dt=(-3.d0*0.0562d0*alph12**2*dalph12dt)/ &
             (1.d0-0.0562d0*alph12**3) + dh12dt
        endif

        if(gamef <= 0.8d0) then

           h12=h12w*((0.8d0-gamef)/0.5d0)+h12*((gamef-0.3d0)/0.5d0)
           dh12dt=((dh12wdt*(0.8d0-gamef) - h12w*dgamefdt + dh12dt* &
                (gamef-0.3d0) + h12*dgamefdt)/0.5d0)
        endif
     endif

     if (h12.gt.300.d0) then
        h12=300.d0
        dh12dt=0.d0
     endif

     if (h12.lt.0.d0) then
        h12=0.d0
        dh12dt=0.d0
     endif

     scfac=exp(h12)
     dscfacdt=scfac*dh12dt

  else
     scfac=1.d0
     dscfacdt=0.d0
  endif

  return

end subroutine screenz


!=================== SUBROUTINE DERIVE ===================================

subroutine derive2csh (Nx, Ny, Nh, nu, time, omegak, omegak_new, dt_omegak_old, dt_omegak_new)
implicit none
include "fftw3.f"
integer (kind = 4) Nx, Ny, Nh, i, j
real (kind = 8) time, kx, ky, nu, Lx, Ly
real (kind = 8) ux(Nx,Ny), uy (Nx,Ny)
real (kind = 8) domega_dx(Nx,Ny), domega_dy(Nx,Ny)
real (kind = 8) ux_domega_dx(Nx,Ny),uy_domega_dy(Nx,Ny)
complex (kind=8) NLkx(Nh,Ny),NLky(Nh,Ny), NLk(Nh,Ny)
complex (kind=8) omegak(Nh,Ny), omegak_new(Nh,Ny), psik(Nh,Ny), ukx(Nh,Ny), uky(Nh,Ny)
complex (kind=8) i_kx_omegak(Nh,Ny),i_ky_omegak(Nh,Ny)
complex (kind=8) omegak_dum(Nh,Ny),psik_dum(Nh,Ny),ukx_dum(Nh,Ny),uky_dum(Nh,Ny)
complex (kind=8) dt_omegak_new(Nh, Ny),  dt_omegak_old(Nh, Ny)
real (kind=8), parameter :: pi = 3.1428

integer (kind=8) plan_forward, plan_backward

Lx = 2.0d0*pi
Ly = 2.0d0*pi

do i = 1, Nh
  do j = 1, Ny
  omegak_dum(i,j) = omegak(i,j)
  enddo
enddo

do i = 1,Nh
  kx = 2.0d0*pi*dfloat(i-1)/Lx
  do j = 1,Ny/2
    ky = 2.0d0*pi*dfloat(j-1)/Ly
      if (i == 1 .and. j == 1) then
      psik(i,j) = (0.0d0,0.0d0)
      ukx(i,j) = (0.0d0,0.0d0)
      uky(i,j) = (0.0d0,0.0d0)
      else
      psik(i,j) = omegak(i,j)/(kx*kx+ky*ky)
      ukx(i,j) = + (0.0d0,1.0d0) * ky * psik(i,j)
      uky(i,j) = - (0.0d0,1.0d0) * kx * psik(i,j)
      endif
    psik_dum(i,j) = psik(i,j)
    omegak_dum(i,j) = omegak(i,j)
    ukx_dum(i,j) = ukx(i,j)
    uky_dum(i,j) = uky(i,j)
  enddo
  do j = Ny/2+1,Ny
    ky = 2.0d0*pi*(dfloat(j-1)-Ny)/Ly
    psik(i,j) = omegak(i,j)/(kx*kx+ky*ky)
    ukx(i,j) = + (0.0d0,1.0d0) * ky * psik(i,j)
    uky(i,j) = - (0.0d0,1.0d0) * kx * psik(i,j)
    psik_dum(i,j) = psik(i,j)
    omegak_dum(i,j) = omegak(i,j)
    ukx_dum(i,j) = ukx(i,j)
    uky_dum(i,j) = uky(i,j)
  enddo
enddo

do i = 1,Nh
  kx = 2.0d0*pi*dfloat(i-1)/Lx
  do j = 1,Ny/2
    ky = 2.0d0*pi*dfloat(j-1)/Ly
    i_kx_omegak(i,j) = (0.0d0,1.0d0) * kx * omegak(i,j)
    i_ky_omegak(i,j) = (0.0d0,1.0d0) * ky * omegak(i,j)
  enddo
  do j = Ny/2+1,Ny
    ky = 2.0d0*pi*(dfloat(j-1)-Ny)/Ly
    i_kx_omegak(i,j) = (0.0d0,1.0d0) * kx * omegak(i,j)
    i_ky_omegak(i,j) = (0.0d0,1.0d0) * ky * omegak(i,j)
  enddo
enddo

  call dfftw_plan_dft_c2r_2d_ (plan_backward, Nx, Ny, ukx_dum, ux, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_backward)
  call dfftw_destroy_plan_ (plan_backward)

  call dfftw_plan_dft_c2r_2d_ (plan_backward, Nx, Ny, uky_dum, uy, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_backward)
  call dfftw_destroy_plan_ (plan_backward)

  call dfftw_plan_dft_c2r_2d_ (plan_backward, Nx, Ny, i_kx_omegak, domega_dx, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_backward)
  call dfftw_destroy_plan_ (plan_backward)

  call dfftw_plan_dft_c2r_2d_ (plan_backward, Nx, Ny, i_ky_omegak, domega_dy, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_backward)
  call dfftw_destroy_plan_ (plan_backward)

do i = 1,Nx
  do j = 1,Ny
    ux(i,j) = ux(i,j)/(dfloat(Nx)*dfloat(Ny))
    uy(i,j) = uy(i,j)/(dfloat(Nx)*dfloat(Ny))
    domega_dx(i,j) = domega_dx(i,j)/(dfloat(Nx)*dfloat(Ny))
    domega_dy(i,j) = domega_dy(i,j)/(dfloat(Nx)*dfloat(Ny))
    ux_domega_dx(i,j) = ux(i,j) * domega_dx(i,j)
    uy_domega_dy(i,j) = uy(i,j) * domega_dy(i,j)
  enddo
enddo

  call dfftw_plan_dft_r2c_2d_ (plan_forward, Nx, Ny, ux_domega_dx, NLkx, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_forward)
  call dfftw_destroy_plan_ (plan_forward)

  call dfftw_plan_dft_r2c_2d_ (plan_forward, Nx, Ny, uy_domega_dy, NLky, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_forward)
  call dfftw_destroy_plan_ (plan_forward)

! De-Aliazing Technique - 2/3 Truncation...
do i = 1,Nh
  kx = 2.0d0*pi*dfloat(i-1)/Lx
  do j = 1,Ny/2
    ky = 2.0d0*pi*dfloat(j-1)/Ly
    if ( dsqrt(kx*kx + ky*ky) .ge. (dfloat(Nx+Ny)/2.0)/3.0 ) then
    NLkx(i,j) = 0.0d0
    NLky(i,j) = 0.0d0
    endif
  enddo
  do j = Ny/2+1,Ny
    ky = 2.0d0*pi*(dfloat(j-1)-Ny)/Ly
    if ( dsqrt(kx*kx + ky*ky) .ge. (dfloat(Nx+Ny)/2.0)/3.0 ) then
    NLkx(i,j) = 0.0d0
    NLky(i,j) = 0.0d0
    endif
  enddo
enddo

do i = 1,Nh
  kx = 2.0d0*pi*dfloat(i-1)/Lx
  do j = 1,Ny/2
    ky = 2.0d0*pi*dfloat(j-1)/Ly
    NLk(i,j) = NLkx(i,j) + NLky(i,j)
    NLk(i,j) = NLk(i,j) + nu * (kx*kx + ky*ky) * omegak(i,j)
  enddo
  do j = Ny/2+1,Ny
    ky = 2.0d0*pi*(dfloat(j-1)-Ny)/Ly
    NLk(i,j) = NLkx(i,j) + NLky(i,j)
    NLk(i,j) = NLk(i,j) + nu * (kx*kx + ky*ky) * omegak(i,j)
  enddo
enddo

do i = 1,Nh
  do j = 1,Ny
    dt_omegak_new(i,j) = -NLk(i,j)
  enddo
enddo

return

end subroutine derive2csh


submodule (maptran) sphere

implicit none (type, external)

contains

module procedure lookAtSpheroid
!! lookAtSpheroid: Calculates line-of-sight intersection with Earth (or other ellipsoid) surface from above surface / orbit
!!
!! ## Inputs
!! * lat0, lon0: latitude and longitude of starting point
!! * h0: altitude of starting point in meters
!! * az: azimuth angle of line-of-sight, clockwise from North
!! * tilt: tilt angle of line-of-sight with respect to local vertical (nadir = 0)
!!
!! ## Outputs
!! * lat, lon: latitude and longitude where the line-of-sight intersects with the Earth ellipsoid
!! * d: slant range in meters from the starting point to the intersect point
!!
!!  Values will be NaN if the line of sight does not intersect.
!!  Algorithm based on:
!!  https://medium.com/@stephenhartzell/satellite-line-of-sight-intersection-with-earth-d786b4a6a9b6 Stephen Hartzell

type(Ellipsoid) :: ell
real :: a,b,c,east,north,up,u,v,w,x,y,z, el, val, radical, magnitude
logical :: d
real :: nan

nan = ieee_value(0., ieee_quiet_nan)

ell = wgs84Ellipsoid
if (present(spheroid)) ell = spheroid

d=.true.
if (present(deg)) d = deg

 a = ell%SemimajorAxis
 b = a
 c = ell%SemiminorAxis

if (d) then
  el = tilt - 90
else
  el = tilt - pi / 2
endif

call aer2enu(az, el, 1., east, north, up, deg=d) ! fixed 1 km slant range
call enu2uvw(east,north,up, lat0,lon0, u,v,w, deg=d)
call geodetic2ecef(lat0,lon0,h0, x,y,z, spheroid=ell, deg=d)

val = -a**2 * b**2 * w * z - a**2 * c**2 * v * y - b**2 * c**2 * u * x

radical = a**2 * b**2 * w**2 + a**2 * c**2 * v**2 - a**2 * v**2 * z**2 + 2 * a**2 * v * w * y * z - &
          a**2 * w**2 * y**2 + b**2 * c**2 * u**2 - b**2 * u**2 * z**2 + 2 * b**2 * u * w * x * z - &
          b**2 * w**2 * x**2 - c**2 * u**2 * y**2 + 2 * c**2 * u * v * x * y - c**2 * v**2 * x**2

magnitude = a**2 * b**2 * w**2 + a**2 * c**2 * v**2 + b**2 * c**2 * u**2

!> Return nan if radical < 0 or d < 0 because LOS vector does not point towards Earth
if (radical > 0) then
  srange = (val - a * b * c * sqrt(radical)) / magnitude
else
  srange = nan
endif

if (srange < 0) srange = nan

call ecef2geodetic(x+srange*u, y+srange*v, z+srange*w, lat, lon, spheroid=ell, deg=d)

end procedure lookAtSpheroid

end submodule sphere


      Module Subroutines

      Use MQC_Algebra
      Use MQC_Gaussian

      Contains

!======================================================================================================
!
!     SUBROUTINE BIORTHOG
!
      Subroutine Biorthsub(IOut,IPrint,NBasis,NElectrons,Multiplicity,Overlap_Matrix, &
        MO_Coeff,Biorthog_Orbs,Biorthog_Overlap)
!
!     This subroutine performs biorthogonalization of
!     unrestricted orbitals
!
!     Variable Declarations...
!
      Implicit None
      Integer::IOut,NBasis,NElectrons,Multiplicity,NAlpha,NBeta,NOccA, &
        NOccB,NVirtA,NVirtB,ND,NSingA,NSingB,I,Ind,NVirtP,IPrint
      Real::Thresh=0.1d0
      Type(MQC_MO_Coefficients)::MO_Coeff,Biorthog_Orbs
      Real,Dimension(:),Allocatable::A_SVals,Biorthog_Overlap
      Real,Dimension(:,:),Intent(In)::Overlap_Matrix
      Real,Dimension(:,:),Allocatable::A_UVecs,A_VVecs, &
        MO_Overlap

      NAlpha = (NElectrons + (Multiplicity-1))/2
      NBeta = NElectrons-NAlpha
      NOccA = NAlpha
      NOccB = NBeta
      NVirtA = NBasis-NAlpha
      NVirtB = NBasis-NBeta
!
!     Allocate arrays in which to collect results
!
      Allocate(Biorthog_Overlap(NBasis))
      Call MQC_Gaussian_Fill_MO_Coefficients(NBasis,MO_Coeff%Alpha, &
        MO_Coeff%Beta,Biorthog_Orbs)
!
!     Do SVD on occupied alpha and beta orbitals and then rotate MO coefficients
!
      Write(*,*) 'Occupied Alpha - Occupied Beta'
      Allocate(MO_Overlap(NOccA,NOccB))
      MO_Overlap = MatMul(MatMul(Transpose(Biorthog_Orbs%Alpha(:,1:NOccA)),Overlap_Matrix), &
        Biorthog_Orbs%Beta(:,1:NOccB))
      If(IPrint.ge.1) Call Print_Matrix(IOut,MO_Overlap,' MO Overlap')
      Call MQC_Matrix_SVD(MO_Overlap,A_UVecs,A_VVecs,A_SVals)
      If(IPrint.ge.1) then
        Call Print_Matrix(IOut,A_UVecs,'U Vectors')
        Call Print_Matrix(IOut,A_VVecs,'V Vectors')
      EndIf
      Call Print_Vector(IOut,A_SVals,'Singular Values')
      Biorthog_Orbs%Alpha(:,1:NOccA) = MatMul(Biorthog_Orbs%Alpha(:,1:NOccA),A_UVecs)
      Biorthog_Orbs%Beta(:,1:NOccB) = MatMul(Biorthog_Orbs%Beta(:,1:NOccB),Transpose(A_VVecs))
      Biorthog_Overlap(1:Size(A_SVals,1)) = A_SVals
      If(IPrint.ge.1) then
        Call Print_Matrix(IOut,Biorthog_Orbs%Alpha(:,1:NOccA),'Biorthogonalized Alpha Orbitals')
        Call Print_Matrix(IOut,Biorthog_Orbs%Beta(:,1:NOccB),'Biorthogonalized Beta Orbitals')
      EndIf
      ND = 0
      Do I = 1, Min(NOccA,NOccB)
        If(A_SVals(I).ge.Thresh) ND = ND + 1
      EndDo
!     Gaussian code has this always set so we never have singly occupied beta
      ND = NBeta
      NSingA = NAlpha - ND
      NSingB = NBeta - ND
!
!     Do SVD on left-over alpha occupieds and beta virtals and then rotate MO coefficients
!
      If(NSingA.gt.0) then
        Write(*,*) 'Singly Occupied Alpha - Virtual Beta'
        Deallocate(MO_Overlap,A_SVals,A_VVecs,A_UVecs)
        Allocate(MO_Overlap(NSingA,NVirtB))
        MO_Overlap = MatMul(MatMul(Transpose(Biorthog_Orbs%Alpha(:,ND+1:ND+NSingA)),Overlap_Matrix), &
          Biorthog_Orbs%Beta(:,NOccB+1:NBasis))
        If(IPrint.ge.1) Call Print_Matrix(IOut,MO_Overlap,' MO Overlap')
        Call MQC_Matrix_SVD(MO_Overlap,A_UVecs,A_VVecs,A_SVals)
        If(IPrint.ge.1) then
          Call Print_Matrix(IOut,A_UVecs,'U Vectors')
          Call Print_Matrix(IOut,A_VVecs,'V Vectors')
        EndIf
        Call Print_Vector(IOut,A_SVals,'Singular Values')
        Biorthog_Orbs%Alpha(:,ND+1:ND+NSingA) = MatMul(Biorthog_Orbs%Alpha(:,ND+1:ND+NSingA),A_UVecs)
        Biorthog_Orbs%Beta(:,NOccB+1:NOccB+NVirtB) = MatMul(Biorthog_Orbs%Beta(:,NOccB+1:NOccB+NVirtB),Transpose(A_VVecs))
        Biorthog_Overlap(ND+1:ND+NSingA) = A_SVals
        If(IPrint.ge.1) then
          Call Print_Matrix(IOut,Biorthog_Orbs%Alpha(:,ND+1:ND+NSingA),'Biorthogonalized Alpha Orbitals')
          Call Print_Matrix(IOut,Biorthog_Orbs%Beta(:,NOccB+1:NOccB+NVirtB),'Biorthogonalized Beta Orbitals')
        EndIf
      EndIf
!
!     Do SVD on left-over beta occupieds and alpha virtals and then rotate MO coefficients
!
      If(NSingB.gt.0) then
        Write(*,*) 'Singly Occupied Beta - Virtual Alpha'
        Deallocate(MO_Overlap,A_SVals,A_VVecs,A_UVecs)
        Allocate(MO_Overlap(NVirtA,NSingB))
        MO_Overlap = MatMul(MatMul(Transpose(Biorthog_Orbs%Alpha(:,NOccA+1:NBasis)),Overlap_Matrix), &
          Biorthog_Orbs%Beta(:,ND+1:ND+NSingB))
        If(IPrint.ge.1) Call Print_Matrix(IOut,MO_Overlap,' MO Overlap')
        Call MQC_Matrix_SVD(MO_Overlap,A_UVecs,A_VVecs,A_SVals)
        If(IPrint.ge.1) then
          Call Print_Matrix(IOut,A_UVecs,'U Vectors')
          Call Print_Matrix(IOut,A_VVecs,'V Vectors')
        EndIf
        Call Print_Vector(IOut,A_SVals,'Singular Values')
        Biorthog_Orbs%Alpha(:,NOccA+1:NOccA+NVirtA) = MatMul(Biorthog_Orbs%Alpha(:,NOccA+1:NOccA+NVirtA),A_UVecs)
        Biorthog_Orbs%Beta(:,ND+1:ND+NSingB) = MatMul(Biorthog_Orbs%Beta(:,ND+1:ND+NSingB),Transpose(A_VVecs))
        Biorthog_Overlap(ND+NSingA+1:ND+NSingA+NSingB) = A_SVals
        If(IPrint.ge.1) then
          Call Print_Matrix(IOut,Biorthog_Orbs%Alpha(:,ND+1:ND+NSingA),'Biorthogonalized Alpha Orbitals')
          Call Print_Matrix(IOut,Biorthog_Orbs%Beta(:,NOccB+1:NOccB+NVirtB),'Biorthogonalized Beta Orbitals')
        EndIf
      EndIf
!
!     Do SVD on alpha and beta virtal orbitals and then rotate MO coefficients
!
      Ind = ND + NSingA + NSingB
      NVirtP = NBasis - Ind
      If(NVirtP.gt.0) then
        Write(*,*) 'Virtual Alpha - Virtual Beta'
        Deallocate(MO_Overlap,A_SVals,A_VVecs,A_UVecs)
        Allocate(MO_Overlap(NVirtP,NVirtP))
        MO_Overlap = MatMul(MatMul(Transpose(Biorthog_Orbs%Alpha(:,Ind+1:Ind+NVirtP)),Overlap_Matrix), &
          Biorthog_Orbs%Beta(:,Ind+1:Ind+NVirtP))
        If(IPrint.ge.1) Call Print_Matrix(IOut,MO_Overlap,' MO Overlap')
        Call MQC_Matrix_SVD(MO_Overlap,A_UVecs,A_VVecs,A_SVals)
        If(IPrint.ge.1) then
          Call Print_Matrix(IOut,A_UVecs,'U Vectors')
          Call Print_Matrix(IOut,A_VVecs,'V Vectors')
        EndIf
        Call Print_Vector(IOut,A_SVals,'Singular Values')
        Biorthog_Orbs%Alpha(:,NOccA+1:NOccA+NVirtA) = MatMul(Biorthog_Orbs%Alpha(:,Ind+1:Ind+NVirtP),A_UVecs)
        Biorthog_Orbs%Beta(:,Ind+1:Ind+NVirtP) = MatMul(Biorthog_Orbs%Beta(:,Ind+1:Ind+NVirtP),Transpose(A_VVecs))
        Biorthog_Overlap(Ind+1:Ind+NVirtP) = A_SVals
        If(IPrint.ge.1) then
          Call Print_Matrix(IOut,Biorthog_Orbs%Alpha(:,Ind+1:Ind+NVirtP),'Biorthogonalized Alpha Orbitals')
          Call Print_Matrix(IOut,Biorthog_Orbs%Beta(:,Ind+1:Ind+NVirtP),'Biorthogonalized Beta Orbitals')
        EndIf
      EndIf
!
      If(IPrint.ge.1) then
        Call Print_Matrix(IOut,Biorthog_Orbs%Alpha,'Biorthogonalized Alpha Orbitals')
        Call Print_Matrix(IOut,Biorthog_Orbs%Beta,'Biorthogonalized Beta Orbitals')
        Call Print_Vector(IOut,Biorthog_Overlap,'Biorthogonal Overlap')
      EndIf
!
 999  End Subroutine Biorthsub
!
!======================================================================================================
!
!     SUBROUTINE JADE
!
      Subroutine Jade(IOut,IPrint,NDets,AMat,BMat,Vecs,AVals,BVals)
!
!     This subroutine performs joint approiximate diagonalization of two
!     matrices based on Jacobi rotations method
!
!     Variable Declarations...
!
      Implicit None
      Integer::IOut,IPrint,NDets,I,J
      Real::Thresh=1.0d-12,Zero=0.0d0,One=1.0d0,TOn,TOff,Theta,JFac
      Logical::Converged
      Real,Dimension(:),Allocatable::RowI,RowJ,Temp
      Real,Dimension(:,:),Intent(In)::AMat,BMat
      Real,Dimension(:,:),Allocatable::Vecs,AVals,BVals,Mp,Mq
      Real,Dimension(2,2)::GMat
!
      Allocate(Vecs(NDets,NDets),AVals(NDets,NDets),BVals(NDets,NDets), &
        Mp(NDets,2),Mq(NDets,2),RowI(NDets*2),RowJ(NDets*2),Temp(NDets))
!
      AVals = AMat
      BVals = BMat
      Vecs = Zero
      ForAll(I=1:NDets) Vecs(I,I) = One
      Converged = .False.
      Do While (.not.Converged.and.NDets.gt.1)
        Do I = 1,NDets-1
          Do J = I+1,NDets
            GMat(1,1) = BVals(I,I)-BVals(J,J)
            GMat(1,2) = AVals(I,I)-AVals(J,J)
            GMat(2,1) = BVals(I,J)+BVals(J,I)
            GMat(2,2) = AVals(I,J)+AVals(J,I)
            GMat = MatMul(GMat,Transpose(GMat))
            If(IPrint.ge.2) Call Print_Matrix(IOut,GMat,'G Matrix')
            TOn = GMat(1,1)-GMat(2,2)
            TOff = GMat(1,2)+GMat(2,1)
            Theta = 0.5*ATan2(TOff,TOn+Sqrt(TOn*TOn+TOff*TOff))
            If(IPrint.ge.2) Write(IOut,*)'TOn:',TOn,' TOff:',TOff,' Theta:',Theta
            If(Abs(Sin(Theta)).gt.Thresh) then
              Mp(:,1) = BVals(:,I)
              Mp(:,2) = AVals(:,I)
              Mq(:,1) = BVals(:,J)
              Mq(:,2) = AVals(:,J)
            If(IPrint.ge.2) Call Print_Matrix(IOut,Mp,'Mp Matrix')
            If(IPrint.ge.2) Call Print_Matrix(IOut,Mq,'Mq Matrix')
              BVals(:,I) = Cos(Theta)*Mp(:,1)+Sin(Theta)*Mq(:,1)
              BVals(:,J) = Cos(Theta)*Mq(:,1)-Sin(Theta)*Mp(:,1)
              AVals(:,I) = Cos(Theta)*Mp(:,2)+Sin(Theta)*Mq(:,2)
              AVals(:,J) = Cos(Theta)*Mq(:,2)-Sin(Theta)*Mp(:,2)
              RowI(1:NDets) = BVals(I,:)
              RowI(NDets+1:NDets*2) = AVals(I,:)
              RowJ(1:NDets) = BVals(J,:)
              RowJ(NDets+1:NDets*2) = AVals(J,:)
              BVals(I,:) = Cos(Theta)*RowI(1:NDets)+Sin(Theta)*RowJ(1:NDets)
              AVals(I,:) = Cos(Theta)*RowI(NDets+1:NDets*2)+Sin(Theta)*RowJ(NDets+1:NDets*2)
              BVals(J,:) = Cos(Theta)*RowJ(1:NDets)-Sin(Theta)*RowI(1:NDets)
              AVals(J,:) = Cos(Theta)*RowJ(NDets+1:NDets*2)-Sin(Theta)*RowI(NDets+1:NDets*2)
              If(IPrint.ge.2) then
                Call Print_Matrix(IOut,AVals,'A Vals')
                Call Print_Matrix(IOut,BVals,'B Vals')
              EndIf
              Temp = Vecs(:,I)
              Vecs(:,I) = Cos(Theta)*Vecs(:,I)+Sin(Theta)*Vecs(:,J)
              Vecs(:,J) = Cos(Theta)*Vecs(:,J)-Sin(Theta)*Temp
              If(IPrint.ge.2) Call Print_Matrix(IOut,Vecs,'Vecs')
            Else
              Converged = .True.
            EndIf
          EndDo
        EndDo
      EndDo
      JFac = Zero
      Do I = 1, NDets
        Do J = 1, NDets
          If (I.ne.J) then
            JFac = JFac + AVals(I,J)**2 + BVals(I,J)**2
          EndIf
        EndDo
      EndDo
      Write(IOut,*) 'Joint Diagonalization Ended, Sim Factor:',0.5*Sqrt(JFac)

 999  End Subroutine Jade
!
!======================================================================================================
!
      End Module Subroutines


      SUBROUTINE MB04BD( JOB, COMPQ1, COMPQ2, N, A, LDA, DE, LDDE, C1,
     $                   LDC1, VW, LDVW, Q1, LDQ1, Q2, LDQ2, B, LDB, F,
     $                   LDF, C2, LDC2, ALPHAR, ALPHAI, BETA, IWORK,
     $                   LIWORK, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the eigenvalues of a real N-by-N skew-Hamiltonian/
C     Hamiltonian pencil aS - bH with
C
C           (  A  D  )         (  C  V  )
C       S = (        ) and H = (        ).                           (1)
C           (  E  A' )         (  W -C' )
C
C     Optionally, if JOB = 'T', decompositions of S and H will be
C     computed via orthogonal transformations Q1 and Q2 as follows:
C
C                       (  Aout  Dout  )
C       Q1' S J Q1 J' = (              ),
C                       (   0    Aout' )
C
C                       (  Bout  Fout  )
C       J' Q2' J S Q2 = (              ) =: T,                       (2)
C                       (   0    Bout' )
C
C                  (  C1out  Vout  )            (  0  I  )
C       Q1' H Q2 = (               ), where J = (        )
C                  (  0     C2out' )            ( -I  0  )
C
C     and Aout, Bout, C1out are upper triangular, C2out is upper quasi-
C     triangular and Dout and Fout are skew-symmetric. The notation M'
C     denotes the transpose of the matrix M.
C     Optionally, if COMPQ1 = 'I' or COMPQ1 = 'U', then the orthogonal
C     transformation matrix Q1 will be computed.
C     Optionally, if COMPQ2 = 'I' or COMPQ2 = 'U', then the orthogonal
C     transformation matrix Q2 will be computed.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Specifies the computation to be performed, as follows:
C             = 'E': compute the eigenvalues only; S and H will not
C                    necessarily be transformed as in (2).
C             = 'T': put S and H into the forms in (2) and return the
C                    eigenvalues in ALPHAR, ALPHAI and BETA.
C
C     COMPQ1  CHARACTER*1
C             Specifies whether to compute the orthogonal transformation
C             matrix Q1, as follows:
C             = 'N':  Q1 is not computed;
C             = 'I':  the array Q1 is initialized internally to the unit
C                     matrix, and the orthogonal matrix Q1 is returned;
C             = 'U':  the array Q1 contains an orthogonal matrix Q on
C                     entry, and the product Q*Q1 is returned, where Q1
C                     is the product of the orthogonal transformations
C                     that are applied to the pencil aS - bH to reduce
C                     S and H to the forms in (2), for COMPQ1 = 'I'.
C
C     COMPQ2  CHARACTER*1
C             Specifies whether to compute the orthogonal transformation
C             matrix Q2, as follows:
C             = 'N':  Q2 is not computed;
C             = 'I':  on exit, the array Q2 contains the orthogonal
C                     matrix Q2;
C             = 'U':  on exit, the array Q2 contains the matrix product
C                     J*Q*J'*Q2, where Q2 is the product of the
C                     orthogonal transformations that are applied to
C                     the pencil aS - bH to reduce S and H to the forms
C                     in (2), for COMPQ2 = 'I'.
C                     Setting COMPQ2 <> 'N' assumes COMPQ2 = COMPQ1.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the pencil aS - bH.  N >= 0, even.
C
C     A       (input/output) DOUBLE PRECISION array, dimension
C                            (LDA, N/2)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the matrix A.
C             On exit, if JOB = 'T', the leading N/2-by-N/2 part of this
C             array contains the matrix Aout; otherwise, it contains the
C             upper triangular matrix A obtained just before the
C             application of the periodic QZ algorithm.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1, N/2).
C
C     DE      (input/output) DOUBLE PRECISION array, dimension
C                            (LDDE, N/2+1)
C             On entry, the leading N/2-by-N/2 strictly lower triangular
C             part of this array must contain the strictly lower
C             triangular part of the skew-symmetric matrix E, and the
C             N/2-by-N/2 strictly upper triangular part of the submatrix
C             in the columns 2 to N/2+1 of this array must contain the
C             strictly upper triangular part of the skew-symmetric
C             matrix D.
C             The entries on the diagonal and the first superdiagonal of
C             this array need not be set, but are assumed to be zero.
C             On exit, if JOB = 'T', the leading N/2-by-N/2 strictly
C             upper triangular part of the submatrix in the columns 2 to
C             N/2+1 of this array contains the strictly upper triangular
C             part of the skew-symmetric matrix Dout.
C             If JOB = 'E', the leading N/2-by-N/2 strictly upper
C             triangular part of the submatrix in the columns 2 to N/2+1
C             of this array contains the strictly upper triangular part
C             of the skew-symmetric matrix D just before the application
C             of the periodic QZ algorithm. The remaining entries are
C             meaningless.
C
C     LDDE    INTEGER
C             The leading dimension of the array DE.
C             LDDE >= MAX(1, N/2).
C
C     C1      (input/output) DOUBLE PRECISION array, dimension
C                            (LDC1, N/2)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the matrix C1 = C.
C             On exit, if JOB = 'T', the leading N/2-by-N/2 part of this
C             array contains the matrix C1out; otherwise, it contains
C             the upper triangular matrix C1 obtained just before the
C             application of the periodic QZ algorithm.
C
C     LDC1    INTEGER
C             The leading dimension of the array C1.
C             LDC1 >= MAX(1, N/2).
C
C     VW      (input/output) DOUBLE PRECISION array, dimension
C                            (LDVW, N/2+1)
C             On entry, the leading N/2-by-N/2 lower triangular part of
C             this array must contain the lower triangular part of the
C             symmetric matrix W, and the N/2-by-N/2 upper triangular
C             part of the submatrix in the columns 2 to N/2+1 of this
C             array must contain the upper triangular part of the
C             symmetric matrix V.
C             On exit, if JOB = 'T', the N/2-by-N/2 part in the columns
C             2 to N/2+1 of this array contains the matrix Vout.
C             If JOB = 'E', the N/2-by-N/2 part in the columns 2 to
C             N/2+1 of this array contains the matrix V just before the
C             application of the periodic QZ algorithm.
C
C     LDVW    INTEGER
C             The leading dimension of the array VW.
C             LDVW >= MAX(1, N/2).
C
C     Q1      (input/output) DOUBLE PRECISION array, dimension (LDQ1, N)
C             On entry, if COMPQ1 = 'U', then the leading N-by-N part of
C             this array must contain a given matrix Q, and on exit,
C             the leading N-by-N part of this array contains the product
C             of the input matrix Q and the transformation matrix Q1
C             used to transform the matrices S and H.
C             On exit, if COMPQ1 = 'I', then the leading N-by-N part of
C             this array contains the orthogonal transformation matrix
C             Q1.
C             If COMPQ1 = 'N', this array is not referenced.
C
C     LDQ1    INTEGER
C             The leading dimension of the array Q1.
C             LDQ1 >= 1,         if COMPQ1 = 'N';
C             LDQ1 >= MAX(1, N), if COMPQ1 = 'I' or COMPQ1 = 'U'.
C
C     Q2      (output) DOUBLE PRECISION array, dimension (LDQ2, N)
C             On exit, if COMPQ2 = 'U', then the leading N-by-N part of
C             this array contains the product of the matrix J*Q*J' and
C             the transformation matrix Q2 used to transform the
C             matrices S and H.
C             On exit, if COMPQ2 = 'I', then the leading N-by-N part of
C             this array contains the orthogonal transformation matrix
C             Q2.
C             If COMPQ2 = 'N', this array is not referenced.
C
C     LDQ2    INTEGER
C             The leading dimension of the array Q2.
C             LDQ2 >= 1,         if COMPQ2 = 'N';
C             LDQ2 >= MAX(1, N), if COMPQ2 = 'I' or COMPQ2 = 'U'.
C
C     B       (output) DOUBLE PRECISION array, dimension (LDB, N/2)
C             On exit, if JOB = 'T', the leading N/2-by-N/2 part of this
C             array contains the matrix Bout; otherwise, it contains the
C             upper triangular matrix B obtained just before the
C             application of the periodic QZ algorithm.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= MAX(1, N/2).
C
C     F       (output) DOUBLE PRECISION array, dimension (LDF, N/2)
C             On exit, if JOB = 'T', the leading N/2-by-N/2 strictly
C             upper triangular part of this array contains the strictly
C             upper triangular part of the skew-symmetric matrix Fout.
C             If JOB = 'E', the leading N/2-by-N/2 strictly upper
C             triangular part of this array contains the strictly upper
C             triangular part of the skew-symmetric matrix F just before
C             the application of the periodic QZ algorithm.
C             The entries on the leading N/2-by-N/2 lower triangular
C             part of this array are not referenced.
C
C     LDF     INTEGER
C             The leading dimension of the array F.  LDF >= MAX(1, N/2).
C
C     C2      (output) DOUBLE PRECISION array, dimension (LDC2, N/2)
C             On exit, if JOB = 'T', the leading N/2-by-N/2 part of this
C             array contains the matrix C2out; otherwise, it contains
C             the upper Hessenberg matrix C2 obtained just before the
C             application of the periodic QZ algorithm.
C
C     LDC2    INTEGER
C             The leading dimension of the array C2.
C             LDC2 >= MAX(1, N/2).
C
C     ALPHAR  (output) DOUBLE PRECISION array, dimension (N/2)
C             The real parts of each scalar alpha defining an eigenvalue
C             of the pencil aS - bH.
C
C     ALPHAI  (output) DOUBLE PRECISION array, dimension (N/2)
C             The imaginary parts of each scalar alpha defining an
C             eigenvalue of the pencil aS - bH.
C             If ALPHAI(j) is zero, then the j-th eigenvalue is real.
C
C     BETA    (output) DOUBLE PRECISION array, dimension (N/2)
C             The scalars beta that define the eigenvalues of the pencil
C             aS - bH.
C             Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
C             beta = BETA(j) represent the j-th eigenvalue of the pencil
C             aS - bH, in the form lambda = alpha/beta. Since lambda may
C             overflow, the ratios should not, in general, be computed.
C             Due to the skew-Hamiltonian/Hamiltonian structure of the
C             pencil, for every eigenvalue lambda, -lambda is also an
C             eigenvalue, and thus it has only to be saved once in
C             ALPHAR, ALPHAI and BETA.
C             Specifically, only eigenvalues with imaginary parts
C             greater than or equal to zero are stored; their conjugate
C             eigenvalues are not stored. If imaginary parts are zero
C             (i.e., for real eigenvalues), only positive eigenvalues
C             are stored. The remaining eigenvalues have opposite signs.
C             As a consequence, pairs of complex eigenvalues, stored in
C             consecutive locations, are not complex conjugate.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (LIWORK)
C             On exit, if INFO = 3, IWORK(1) contains the number of
C             (pairs of) possibly inaccurate eigenvalues, q <= N/2, and
C             IWORK(2), ..., IWORK(q+1) indicate their indices.
C             Specifically, a positive value is an index of a real or
C             purely imaginary eigenvalue, corresponding to a 1-by-1
C             block, while the absolute value of a negative entry in
C             IWORK is an index to the first eigenvalue in a pair of
C             consecutively stored eigenvalues, corresponding to a
C             2-by-2 block. A 2-by-2 block may have two complex, two
C             real, two purely imaginary, or one real and one purely
C             imaginary eigenvalue.
C             For i = q+2, ..., 2*q+1, IWORK(i) contains a pointer to
C             the starting location in DWORK of the i-th quadruple of
C             1-by-1 blocks, if IWORK(i-q) > 0, or 2-by-2 blocks,
C             if IWORK(i-q) < 0, defining unreliable eigenvalues.
C             IWORK(2*q+2) contains the number of the 1-by-1 blocks, and
C             IWORK(2*q+3) contains the number of the 2-by-2 blocks,
C             corresponding to unreliable eigenvalues. IWORK(2*q+4)
C             contains the total number t of the 2-by-2 blocks.
C             If INFO = 0, then q = 0, therefore IWORK(1) = 0.
C
C     LIWORK  INTEGER
C             The dimension of the array IWORK.  LIWORK >= N+12.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0 or INFO = 3, DWORK(1) returns the
C             optimal LDWORK, and DWORK(2), ..., DWORK(5) contain the
C             Frobenius norms of the factors of the formal matrix
C             product used by the algorithm. In addition, DWORK(6), ...,
C             DWORK(5+4*s) contain the s quadruple values corresponding
C             to the 1-by-1 blocks. Their eigenvalues are real or purely
C             imaginary. Such an eigenvalue is obtained from
C             -i*sqrt(a1*a3/a2/a4), but always taking a positive sign,
C             where a1, ..., a4 are the corresponding quadruple values.
C             Moreover, DWORK(6+4*s), ..., DWORK(5+4*s+16*t) contain the
C             t groups of quadruple 2-by-2 matrices corresponding to the
C             2-by-2 blocks. Their eigenvalue pairs are either complex,
C             or placed on the real and imaginary axes. Such an
C             eigenvalue pair is obtained as -1i*sqrt(ev), but taking
C             positive imaginary parts, where ev are the eigenvalues of
C             the product A1*inv(A2)*A3*inv(A4), where A1, ..., A4
C             define the corresponding 2-by-2 matrix quadruple.
C             On exit, if INFO = -27, DWORK(1) returns the minimum value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK.
C             If JOB = 'E' and COMPQ1 = 'N' and COMPQ2 = 'N',
C                LDWORK >= N**2 + MAX(L,36);
C             if JOB = 'T' or COMPQ1 <> 'N' or COMPQ2 <> 'N',
C                LDWORK >= 2*N**2 + MAX(L,36);
C             where
C                L = 4*N + 4, if N/2 is even, and
C                L = 4*N,     if N/2 is odd.
C             For good performance LDWORK should generally be larger.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0: succesful exit;
C             < 0: if INFO = -i, the i-th argument had an illegal value;
C             = 1: problem during computation of the eigenvalues;
C             = 2: periodic QZ algorithm did not converge in the SLICOT
C                  Library subroutine MB03BD;
C             = 3: some eigenvalues might be inaccurate, and details can
C                  be found in IWORK and DWORK. This is a warning.
C
C     METHOD
C
C     The algorithm uses Givens rotations and Householder reflections to
C     annihilate elements in S, T, and H such that A, B, and C1 are
C     upper triangular and C2 is upper Hessenberg. Finally, the periodic
C     QZ algorithm is applied to transform C2 to upper quasi-triangular
C     form while A, B, and C1 stay in upper triangular form.
C     See also page 27 in [1] for more details.
C
C     REFERENCES
C
C     [1] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H.
C         Numerical Solution of Real Skew-Hamiltonian/Hamiltonian
C         Eigenproblems.
C         Tech. Rep., Technical University Chemnitz, Germany,
C         Nov. 2007.
C
C     NUMERICAL ASPECTS
C                                                               3
C     The algorithm is numerically backward stable and needs O(N ) real
C     floating point operations.
C
C     CONTRIBUTOR
C
C     Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet
C     Chemnitz, October 16, 2008.
C
C     REVISIONS
C
C     V. Sima, Oct. 2009 (SLICOT version of the routine DHAUTR).
C     V. Sima, Nov. 2010, Feb. 2011, Oct. 2011.
C     M. Voigt, Jan. 2012, July 2014.
C     V. Sima, Oct. 2012, Jan. 2013, Feb. 2013, July 2013, Aug. 2014,
C     Sep. 2016, Nov. 2016, Jan. 2017, Apr. 2018, Mar. 2019, Mar. 2020,
C     Apr. 2020.
C
C     KEYWORDS
C
C     periodic QZ algorithm, upper (quasi-)triangular matrix,
C     skew-Hamiltonian/Hamiltonian pencil.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, HALF, ONE, TWO, FIVE
      PARAMETER          ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0,
     $                     TWO  = 2.0D+0, FIVE = 5.0D+0 )
C
C     .. Scalar Arguments ..
      CHARACTER          COMPQ1, COMPQ2, JOB
      INTEGER            INFO, LDA, LDB, LDC1, LDC2, LDDE, LDF, LDQ1,
     $                   LDQ2, LDVW, LDWORK, LIWORK, N
C
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
     $                   B( LDB, * ), BETA( * ), C1( LDC1, * ),
     $                   C2( LDC2, * ), DE( LDDE, * ), DWORK( * ),
     $                   F( LDF, * ), Q1( LDQ1, * ), Q2( LDQ2, * ),
     $                   VW( LDVW, * )
C
C     .. Local Scalars ..
      LOGICAL            LCMPQ1, LCMPQ2, LINIQ1, LINIQ2, LTRI, LUPDQ1,
     $                   LUPDQ2, UNREL
      CHARACTER*16       CMPQ, CMPSC
      INTEGER            EMAX, EMIN, I, I11, I22, I2X2, IMAT, IW, IWARN,
     $                   IWRK, J, K, L, M, MJ1, MJ2, MJ3, MK1, MK2, MK3,
     $                   MM, NBETA0, NINF, OPTDW, P
      DOUBLE PRECISION   BASE, CO, MU, NU, SI, TEMP, TMP1, TMP2
      COMPLEX*16         EIG
C
C     .. Local Arrays ..
      INTEGER            IDUM( 1 )
      DOUBLE PRECISION   DUM( 4 )
C
C     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            MA02OD
      DOUBLE PRECISION   DDOT, DLAMCH, DLANTR, DLAPY2
      EXTERNAL           DDOT, DLAMCH, DLANTR, DLAPY2, LSAME, MA02OD
C
C     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DGEMM, DLACPY, DLARF, DLARFG,
     $                   DLARTG, DLASET, DROT, DSYMV, DSYR2, MA02AD,
     $                   MA02PD, MB01LD, MB01MD, MB01ND, MB03BD, XERBLA
C
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, DCMPLX, DIMAG, INT, MAX, MIN, MOD,
     $                   SQRT
C
C     .. Executable Statements ..
C
C     Decode the input arguments.
C
      M  = N/2
      MM = M*M
      LTRI   = LSAME( JOB,    'T' )
      LINIQ1 = LSAME( COMPQ1, 'I' )
      LINIQ2 = LSAME( COMPQ2, 'I' )
      LUPDQ1 = LSAME( COMPQ1, 'U' )
      LUPDQ2 = LSAME( COMPQ2, 'U' )
      LCMPQ1 = LUPDQ1 .OR. LINIQ1
      LCMPQ2 = LUPDQ2 .OR. LINIQ2
C
C     Test the input arguments.
C
      INFO = 0
      IF( .NOT.( LSAME( JOB, 'E' ) .OR. LTRI ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( LSAME( COMPQ1, 'N' ) .OR. LCMPQ1 ) ) THEN
         INFO = -2
      ELSE IF( .NOT.( LSAME( COMPQ2, 'N' ) .OR. LCMPQ2 ) ) THEN
         INFO = -3
      ELSE IF( ( LINIQ2 .AND. .NOT.LINIQ1 ) .OR.
     $         ( LUPDQ2 .AND. .NOT.LUPDQ1 ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN
         INFO = -4
      ELSE IF(  LDA.LT.MAX( 1, M ) ) THEN
         INFO = -6
      ELSE IF( LDDE.LT.MAX( 1, M ) ) THEN
         INFO = -8
      ELSE IF( LDC1.LT.MAX( 1, M ) ) THEN
         INFO = -10
      ELSE IF( LDVW.LT.MAX( 1, M ) ) THEN
         INFO = -12
      ELSE IF( LDQ1.LT.1 .OR. ( LCMPQ1 .AND. LDQ1.LT.N ) ) THEN
         INFO = -14
      ELSE IF( LDQ2.LT.1 .OR. ( LCMPQ2 .AND. LDQ2.LT.N ) ) THEN
         INFO = -16
      ELSE IF(  LDB.LT.MAX( 1, M ) ) THEN
         INFO = -18
      ELSE IF(  LDF.LT.MAX( 1, M ) ) THEN
         INFO = -20
      ELSE IF( LDC2.LT.MAX( 1, M ) ) THEN
         INFO = -22
      ELSE IF( LIWORK.LT.N+12 ) THEN
         INFO = -27
      ELSE
         IF( MOD( M, 2 ).EQ.0 ) THEN
            I = MAX( 4*N, 32 ) + 4
         ELSE
            I = MAX( 4*N, 36 )
         END IF
         IF( LTRI .OR. LCMPQ1 .OR. LCMPQ2 ) THEN
            OPTDW = 8*MM + I
         ELSE
            OPTDW = 4*MM + I
         END IF
         IF( LDWORK.LT.OPTDW )
     $      INFO = -29
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB04BD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 ) THEN
         IWORK( 1 ) = 0
         DWORK( 1 ) = FIVE
         DWORK( 2 ) = ZERO
         DWORK( 3 ) = ZERO
         DWORK( 4 ) = ZERO
         DWORK( 5 ) = ZERO
         RETURN
      END IF
C
C     Determine machine constants.
C
      BASE = DLAMCH( 'Base' )
      EMIN = INT( DLAMCH( 'Minimum Exponent' ) )
      EMAX = INT( DLAMCH( 'Largest Exponent' ) )
C
C     Find half of the number of infinite eigenvalues if S is diagonal.
C     Otherwise, find a lower bound of this number.
C
      NINF = 0
      IF( M.EQ.1 ) THEN
         TEMP = ZERO
      ELSE
         TEMP = DLANTR( 'Max', 'Lower', 'No-diag', M-1, M-1, DE( 2, 1 ),
     $                  LDDE, DWORK ) +
     $          DLANTR( 'Max', 'Upper', 'No-diag', M-1, M-1, DE( 1, 2 ),
     $                  LDDE, DWORK )
      END IF
      IF( TEMP.EQ.ZERO ) THEN
         IF( M.EQ.1 ) THEN
            IF( A( 1, 1 ).EQ.ZERO )
     $         NINF = 1
         ELSE
            IF( DLANTR( 'Max', 'Lower', 'No-diag', M-1, M-1, A( 2, 1 ),
     $                                   LDA, DWORK ).EQ.ZERO .AND.
     $          DLANTR( 'Max', 'Upper', 'No-diag', M-1, M-1, A( 1, 2 ),
     $                                   LDA, DWORK ).EQ.ZERO ) THEN
               DO 10 J = 1, M
                  IF( A( J, J ).EQ.ZERO )
     $               NINF = NINF + 1
   10          CONTINUE
            ELSE
               CALL MA02PD( M, M, A, LDA, I, J )
               NINF = MAX( I, J )
            END IF
         END IF
      ELSE
C
C        Incrementing NINF below is due to even multiplicity of
C        eigenvalues for real skew-Hamiltonian matrices.
C
         NINF = MA02OD( 'Skew', M, A, LDA, DE, LDDE )
         IF( MOD( NINF, 2 ).GT.0 )
     $      NINF = NINF + 1
         NINF = NINF/2
      END IF
C
C     STEP 1: Reduce S to skew-Hamiltonian triangular form.
C
      IF( LINIQ1 )
     $   CALL DLASET( 'Full', N, N, ZERO, ONE, Q1, LDQ1 )
C
      DUM( 1 ) = ZERO
C
      DO 20 K = 1, M - 1
C
C        Generate elementary reflector H(k) = I - nu * v * v' to
C        annihilate E(k+2:m,k).
C
         MK2  = MIN( K+2, M )
         MK3  = MK2 + 1
         TMP1 = DE( K+1, K )
         CALL DLARFG( M-K, TMP1, DE( MK2, K ), 1, NU )
         IF( NU.NE.ZERO ) THEN
            DE( K+1, K ) = ONE
C
C           Apply H(k) from both sides to E(k+1:m,k+1:m).
C           Compute  x := nu * E(k+1:m,k+1:m) * v.
C
            CALL MB01MD( 'Lower', M-K, NU, DE( K+1, K+1 ), LDDE,
     $                   DE( K+1, K ), 1, ZERO, DWORK, 1 )
C
C           Compute  w := x - 1/2 * nu * (x'*v) * v in x.
C
            MU = -HALF*NU*DDOT( M-K, DWORK, 1, DE( K+1, K ), 1 )
            CALL DAXPY( M-K, MU, DE( K+1, K ), 1, DWORK, 1 )
C
C           Apply the transformation as a skew-symmetric rank-2 update:
C                E := E + v * w' - w * v'.
C
            CALL MB01ND( 'Lower', M-K, ONE, DE( K+1, K ), 1, DWORK, 1,
     $                   DE( K+1, K+1 ), LDDE )
C
C           Apply H(k) to W(k+1:m,1:k) from the left (and implicitly to
C           W(1:k,k+1:m) from the right).
C
            CALL DLARF( 'Left', M-K, K, DE( K+1, K ), 1, NU,
     $                  VW( K+1, 1 ), LDVW, DWORK )
C
C           Apply H(k) from both sides to W(k+1:m,k+1:m).
C           Compute  x := nu * W(k+1:m,k+1:m) * v.
C
            CALL DSYMV( 'Lower', M-K, NU, VW( K+1, K+1 ), LDVW,
     $                  DE( K+1, K ), 1, ZERO, DWORK, 1 )
C
C           Compute  w := x - 1/2 * nu * (x'*v) * v.
C
            MU = -HALF*NU*DDOT( M-K, DWORK, 1, DE( K+1, K ), 1 )
            CALL DAXPY( M-K, MU, DE( K+1, K ), 1, DWORK, 1 )
C
C           Apply the transformation as a rank-2 update:
C                W := W - v * w' - w * v'.
C
            CALL DSYR2( 'Lower', M-K, -ONE, DE( K+1, K ), 1, DWORK, 1,
     $                  VW( K+1, K+1 ), LDVW )
C
C           Apply H(k) from the right hand side to A(1:m,k+1:m) and
C           C1(1:m,k+1:m).
C
            CALL DLARF( 'Right', M, M-K, DE( K+1, K ), 1, NU,
     $                  A( 1, K+1 ), LDA, DWORK )
            CALL DLARF( 'Right', M, M-K, DE( K+1, K ), 1, NU,
     $                  C1( 1, K+1 ), LDC1, DWORK )
C
            IF( LCMPQ1 ) THEN
C
C              Apply H(k) from the right hand side to Q1(1:n,m+k+1:n).
C
               CALL DLARF( 'Right', N, M-K, DE( K+1, K ), 1, NU,
     $                     Q1( 1, M+K+1 ), LDQ1, DWORK )
            END IF
            DE( K+1, K ) = TMP1
         END IF
C
C        Determine a Givens rotation to annihilate E(k+1,k) from the
C        left.
C
         TMP2 = A( K+1, K )
         CALL DLARTG( TMP2, DE( K+1, K ), CO, SI, A( K+1, K ) )
C
C        Update A, E and D.
C
         CALL DROT( M-K-1, DE( MK2, K+1 ), 1, A( K+1, MK2 ), LDA, CO,
     $              SI )
         CALL DROT( K, A( 1, K+1 ), 1, DE( 1, K+2 ), 1, CO, SI )
         CALL DROT( M-K-1, DE( K+1, MK3 ), LDDE, A( MK2, K+1 ), 1, CO,
     $              SI )
C
C        Update C1, W and V.
C
         CALL DROT( K, VW( K+1, 1 ), LDVW, C1( K+1, 1 ), LDC1, CO, -SI )
         CALL DROT( M-K-1, VW( MK2, K+1 ), 1, C1( K+1, MK2 ), LDC1, CO,
     $              -SI )
         CALL DROT( K, C1( 1, K+1 ), 1, VW( 1, K+2 ), 1, CO, SI )
         CALL DROT( M-K-1, VW( K+1, MK3 ), LDVW, C1( MK2, K+1 ), 1, CO,
     $              -SI )
C
C        Fix the diagonal part.
C
         TMP1 = C1( K+1, K+1 )
         TMP2 = VW( K+1, K+2 )
         C1( K+1, K+1 ) = ( CO - SI )*( CO + SI )*TMP1 +
     $                    CO*SI*( VW( K+1, K+1 ) + TMP2 )
         TMP1 = TWO*CO*SI*TMP1
         VW( K+1, K+2 ) = CO**2*TMP2 - SI**2*VW( K+1, K+1 ) - TMP1
         VW( K+1, K+1 ) = CO**2*VW( K+1, K+1 ) - SI**2*TMP2 - TMP1
C
         IF( LCMPQ1 ) THEN
C
C           Update Q1.
C
            CALL DROT( N, Q1( 1, K+1 ), 1, Q1( 1, M+K+1 ), 1, CO, SI )
         END IF
C
C        Generate elementary reflector P(k) to annihilate A(k+1:m,k).
C
         TMP1 = A( K, K )
         CALL DLARFG( M-K+1, TMP1, A( K+1, K ), 1, NU )
         IF( NU.NE.ZERO ) THEN
            A( K, K ) = ONE
C
C           Apply P(k) from the left hand side to A(k:m,k+1:m).
C
            CALL DLARF( 'Left', M-K+1, M-K, A( K, K ), 1, NU,
     $                  A( K, K+1 ), LDA, DWORK )
C
C           Apply P(k) to D(1:k-1,k:m) from the right (and implicitly
C           to D(k:m,1:k-1) from the left).
C
            CALL DLARF( 'Right', K-1, M-K+1, A( K, K ), 1, NU,
     $                  DE( 1, K+1 ), LDDE, DWORK )
C
C           Apply P(k) from both sides to D(k:m,k:m).
C           Compute  x := nu * D(k:m,k:m) * v.
C
            CALL MB01MD( 'Upper', M-K+1, NU, DE( K, K+1 ), LDDE,
     $                   A( K, K ), 1, ZERO, DWORK, 1 )
C
C           Compute  w := x - 1/2 * nu * (x'*v) * v in x.
C
            MU = -HALF*NU*DDOT( M-K+1, DWORK, 1, A( K, K ), 1 )
            CALL DAXPY( M-K+1, MU, A( K, K ), 1, DWORK, 1 )
C
C           Apply the transformation as a skew-symmetric rank-2 update:
C                D := D + v * w' - w * v'.
C
            CALL MB01ND( 'Upper', M-K+1, ONE, A( K, K ), 1, DWORK, 1,
     $                   DE( K, K+1 ), LDDE )
C
C           Apply P(k) from the left hand side to C1(k:m,1:m).
C
            CALL DLARF( 'Left', M-K+1, M, A( K, K ), 1, NU, C1( K, 1 ),
     $                  LDC1, DWORK )
C
C           Apply P(k) to V(1:k-1,k:m) from the right (and implicitly
C           to V(k:m,1:k-1) from the left).
C
            CALL DLARF( 'Right', K-1, M-K+1, A( K, K ), 1, NU,
     $                  VW( 1, K+1 ), LDVW, DWORK )
C
C           Apply P(k) from both sides to V(k:m,k:m).
C           Compute  x := nu * V(k:m,k:m) * v.
C
            CALL DSYMV( 'Upper', M-K+1, NU, VW( K, K+1 ), LDVW,
     $                  A( K, K ), 1, ZERO, DWORK, 1 )
C
C           Compute  w := x - 1/2 * nu * (x'*v) * v.
C
            MU = -HALF*NU*DDOT( M-K+1, DWORK, 1, A( K, K ), 1 )
            CALL DAXPY( M-K+1, MU, A( K, K ), 1, DWORK, 1 )
C
C           Apply the transformation as a rank-2 update:
C                V := V - v * w' - w * v'.
C
            CALL DSYR2( 'Upper', M-K+1, -ONE, A( K, K ), 1, DWORK, 1,
     $                  VW( K, K+1 ), LDVW )
C
            IF( LCMPQ1 ) THEN
C
C              Apply P(k) from the right hand side to Q1(1:n,k:m).
C
               CALL DLARF( 'Right', N, M-K+1, A( K, K ), 1, NU,
     $                     Q1( 1, K ), LDQ1, DWORK )
            END IF
            A( K, K ) = TMP1
         END IF
C
C        Set A(k+1:m,k) to zero in order to be able to apply MB03BD.
C
         CALL DCOPY( M-K, DUM, 0, A( K+1, K ), 1 )
   20 CONTINUE
C
C     The following operations do not preserve the Hamiltonian structure
C     of H. -C1 is copied to C2. The lower triangular part of W(1:m,1:m)
C     and its transpose are stored in DWORK. Then, the transpose of the
C     upper triangular part of V(1:m,1:m) is saved in the lower
C     triangular part of VW(1:m,2:m+1).
C
      CALL DLACPY( 'Full', M, M, A, LDA, B, LDB )
      CALL DLACPY( 'Upper', M, M, DE( 1, 2 ), LDDE, F, LDF )
C
      DO 40 J = 1, M
         DO 30 I = 1, M
            C2( I, J ) = -C1( I, J )
   30    CONTINUE
   40 CONTINUE
C
      CALL DLACPY( 'Lower', M, M, VW, LDVW, DWORK, M )
      CALL MA02AD( 'Lower', M, M, VW, LDVW, DWORK, M )
C
      CALL MA02AD( 'Upper', M, M, VW( 1, 2 ), LDVW, VW( 1, 2 ), LDVW )
C
      IF ( LCMPQ2 ) THEN
         CALL DLACPY( 'Full', M, M, Q1( M+1, M+1 ), LDQ1, Q2, LDQ2 )
C
         DO 60 J = 1, M
            DO 50 I = M + 1, N
               Q2( I, J ) = -Q1( I-M, J+M )
   50       CONTINUE
   60    CONTINUE
C
         DO 80 J = M + 1, N
            DO 70 I = 1, M
               Q2( I, J ) = -Q1( I+M, J-M )
   70       CONTINUE
   80    CONTINUE
C
         CALL DLACPY( 'Full', M, M, Q1, LDQ1, Q2( M+1, M+1 ), LDQ2 )
      END IF
C
C     STEP 2: Eliminations in H.
C
      DO 130 K = 1, M
         MK1 = MIN( K+1, M )
C
C        I. Annihilate W(k:m-1,k).
C
         DO 90 J = K, M - 1
            MJ3  = MIN( J+3, M+1 )
C
C           Determine a Givens rotation to annihilate W(j,k) from the
C           left.
C
            CALL DLARTG( DWORK( ( K-1 )*M+J+1 ), DWORK( ( K-1 )*M+J ),
     $                   CO, SI, TMP1 )
C
C           Update C2 and W.
C
            CALL DROT( M, C2( 1, J+1 ), 1, C2( 1, J ), 1, CO, SI )
            DWORK( ( K-1 )*M+J+1 ) = TMP1
            DWORK( ( K-1 )*M+J )   = ZERO
            CALL DROT( M-K, DWORK( K*M+J+1 ), M, DWORK( K*M+J ), M, CO,
     $                 SI )
C
C           Update A.
C
            CALL DROT( J, A( 1, J+1 ), 1, A( 1, J ), 1, CO, SI )
            TMP1          = -SI*A( J+1, J+1 )
            A( J+1, J+1 ) =  CO*A( J+1, J+1 )
C
            IF( LCMPQ1 ) THEN
C
C              Update Q1.
C
               CALL DROT( N, Q1( 1, M+J+1 ), 1, Q1( 1, M+J ), 1, CO, SI
     $                     )
            END IF
C
C           Determine a Givens rotation to annihilate A(j+1,j) from the
C           left.
C
            CALL DLARTG( A( J, J ), TMP1, CO, SI, TMP2 )
C
C           Update A and D.
C
            A( J, J ) = TMP2
            CALL DROT( M-J, A( J, J+1 ), LDA, A( J+1, J+1 ), LDA, CO, SI
     $                  )
            CALL DROT( J-1, DE( 1, J+1 ), 1, DE( 1, J+2 ), 1, CO, SI )
            CALL DROT( M-J-1, DE( J, MJ3 ), LDDE, DE( J+1, MJ3 ), LDDE,
     $                 CO, SI )
C
C           Update C1 and V.
C
            CALL DROT( M-K+1, C1( J, K ), LDC1, C1( J+1, K ), LDC1, CO,
     $                 SI )
            CALL DROT( M, VW( J, 2 ), LDVW, VW( J+1, 2 ), LDVW, CO, SI )
C
            IF( LCMPQ1 ) THEN
C
C              Update Q1.
C
               CALL DROT( N, Q1( 1, J ), 1, Q1( 1, J+1 ), 1, CO, SI )
            END IF
   90    CONTINUE
C
C        II. Annihilate W(m,k).
C
C        Determine a Givens rotation to annihilate W(m,k) from the left.
C
         CALL DLARTG( C1( M, K ), DWORK( M*K ), CO, SI, TMP1 )
C
C        Update C1 and W.
C
         C1( M, K )   = TMP1
         DWORK( M*K ) = ZERO
         CALL DROT( M-K, C1( M, MK1 ), LDC1, DWORK( M*MK1 ), M, CO, SI )
         CALL DROT( M, VW( M, 2 ), LDVW, C2( 1, M ), 1, CO, SI )
C
C        Update A and D.
C
         CALL DROT( M-1, A( 1, M ), 1, DE( 1, M+1 ), 1, CO, SI )
C
         IF( LCMPQ1 ) THEN
C
C           Update Q1.
C
            CALL DROT( N, Q1( 1, M ), 1, Q1( 1, N ), 1, CO, SI )
         END IF
C
C        III. Annihilate C1(k+1:m,k).
C
         DO 100 J = M, K + 1, -1
            MJ2  = MIN( J+2, M+1 )
C
C           Determine a Givens rotation to annihilate C1(j,k) from the
C           left.
C
            CALL DLARTG( C1( J-1, K ), C1( J, K ), CO, SI, TMP1 )
C
C           Update C1 and V.
C
            C1( J-1, K ) = TMP1
            C1( J, K )   = ZERO
            CALL DROT( M-K, C1( J-1, MK1 ), LDC1, C1( J, MK1 ), LDC1,
     $                 CO, SI )
            CALL DROT( M, VW( J-1, 2 ), LDVW, VW( J, 2 ), LDVW , CO, SI
     $                  )
C
C           Update A and D.
C
            TMP1          = -SI*A( J-1, J-1 )
            A( J-1, J-1 ) =  CO*A( J-1, J-1 )
            CALL DROT( M-J+1, A( J-1, J ), LDA, A( J, J ), LDA, CO, SI )
            CALL DROT( J-2, DE( 1, J ), 1, DE( 1, J+1 ), 1, CO, SI )
            CALL DROT( M-J, DE( J-1, MJ2 ), LDDE, DE( J, MJ2 ), LDDE,
     $                 CO, SI )
C
            IF( LCMPQ1 ) THEN
C
C              Update Q1.
C
               CALL DROT( N, Q1( 1, J-1 ), 1, Q1( 1, J ), 1, CO, SI )
            END IF
C
C           Determine a Givens rotation to annihilate A(j,j-1) from the
C           right.
C
            CALL DLARTG( A( J, J ), TMP1, CO, SI, TMP2 )
C
C           Update A.
C
            A( J, J ) = TMP2
            CALL DROT( J-1, A( 1, J ), 1, A( 1, J-1 ), 1, CO, SI )
C
C           Update C2 and W.
C
            CALL DROT( M, C2( 1, J ), 1, C2( 1, J-1 ), 1, CO, SI )
            CALL DROT( M-K+1, DWORK( ( K-1 )*M+J ), M,
     $                 DWORK( ( K-1)*M+J-1 ), M, CO, SI )
C
            IF( LCMPQ1 ) THEN
C
C              Update Q1.
C
               CALL DROT( N, Q1( 1, M+J ), 1, Q1( 1, M+J-1 ), 1, CO, SI
     $                     )
            END IF
  100    CONTINUE
C
C        IV. Annihilate W(k,k+1:m-1).
C
         DO 110 J = K + 1, M - 1
            MJ2  = MIN( J+2, M )
C
C           Determine a Givens rotation to annihilate W(k,j) from the
C           right.
C
            CALL DLARTG( DWORK( J*M+K ), DWORK( ( J-1 )*M+K ), CO,
     $                   SI, TMP1 )
C
C           Update C1 and W.
C
            CALL DROT( M, C1( 1, J+1 ), 1, C1( 1, J ), 1, CO, SI )
            DWORK( ( J-1 )*M+K ) = ZERO
            DWORK( J*M+K )       = TMP1
            CALL DROT( M-K, DWORK( J*M+MK1 ), 1, DWORK( ( J-1 )*M+K+1 ),
     $                 1, CO, SI )
C
C           Update B.
C
            CALL DROT( J, B( 1, J+1 ), 1, B( 1, J ), 1, CO, SI )
            TMP1          = -SI*B( J+1, J+1 )
            B( J+1, J+1 ) =  CO*B( J+1, J+1 )
C
            IF( LCMPQ2 ) THEN
C
C              Update Q2.
C
               CALL DROT( N, Q2( 1, J+1 ), 1, Q2( 1, J ), 1, CO, SI )
            END IF
C
C           Determine a Givens rotation to annihilate B(j+1,j) from the
C           left.
C
            CALL DLARTG( B( J, J ), TMP1, CO, SI, TMP2 )
C
C           Update B and F.
C
            B( J, J ) = TMP2
            CALL DROT( M-J, B( J, J+1 ), LDB, B( J+1, J+1 ), LDB, CO, SI
     $                  )
            CALL DROT( J-1, F( 1, J ), 1, F( 1, J+1 ), 1, CO, SI )
            CALL DROT( M-J-1, F( J, MJ2 ), LDF, F( J+1, MJ2 ), LDF, CO,
     $                 SI )
C
C           Update C2 and V.
C
            CALL DROT( M-K+1, C2( J, K ), LDC2, C2( J+1, K ), LDC2, CO,
     $                 SI )
            CALL DROT( M, VW( 1, J+1 ), 1, VW( 1, J+2 ), 1, CO, SI )
C
            IF( LCMPQ2 ) THEN
C
C              Update Q2.
C
               CALL DROT( N, Q2( 1, M+J ), 1, Q2( 1, M+J+1 ), 1, CO, SI
     $                     )
            END IF
  110    CONTINUE
C
C        V. Annihilate W(k,m).
C
         IF( K.LT.M ) THEN
C
C           Determine a Givens rotation to annihilate W(k,m) from the
C           right.
C
            CALL DLARTG( C2( M, K ), DWORK( ( M-1 )*M+K ), CO, SI, TMP1
     $                    )
C
C           Update C1, C2, W and V.
C
            CALL DROT( M, VW( 1, M+1 ), 1, C1( 1, M ), 1, CO, SI )
            C2( M, K )           = TMP1
            DWORK( ( M-1 )*M+K ) = ZERO
            CALL DROT( M-K, C2( M, K+1 ), LDC2, DWORK( ( M-1 )*M+K+1 ),
     $                 1, CO, SI )
C
C           Update B and F.
C
            CALL DROT( M-1, F( 1, M ), 1, B( 1, M ), 1, CO, SI )
C
            IF( LCMPQ2 ) THEN
C
C               Update Q2.
C
                CALL DROT( N, Q2( 1, N ), 1, Q2( 1, M ), 1, CO, SI )
            END IF
         ELSE
C
C           Determine a Givens rotation to annihilate W(m,m) from the
C           left.
C
            CALL DLARTG( C1( M, M ), DWORK( MM ), CO, SI, TMP1 )
C
C           Update C1, C2, W and V.
C
            C1( M, M )  = TMP1
            DWORK( MM ) = ZERO
            CALL DROT( M, VW( M, 2 ), LDVW, C2( 1, M ), 1, CO, SI )
C
C           Update A and D.
C
            CALL DROT( M-1, A( 1, M ), 1, DE( 1, M+1 ), 1, CO, SI )
C
            IF( LCMPQ1 ) THEN
C
C              Update Q1.
C
               CALL DROT( N, Q1( 1, M ), 1, Q1( 1, N ), 1, CO, SI )
            END IF
         END IF
C
C        VI. Annihilate C2(k+2:m,k).
C
         DO 120 J = M, K + 2, -1
            MJ1 = MIN( J+1, M )
C
C           Determine a Givens rotation to annihilate C2(j,k) from the
C           left.
C
            CALL DLARTG( C2( J-1, K ), C2( J, K ), CO, SI, TMP1 )
C
C           Update C2 and V.
C
            C2( J-1, K ) = TMP1
            C2( J, K )   = ZERO
            CALL DROT( M-K, C2( J-1, MK1 ), LDC2, C2( J, MK1 ), LDC2,
     $                 CO, SI )
            CALL DROT( M, VW( 1, J ), 1, VW( 1, J+1 ), 1, CO, SI )
C
C           Update B and F.
C
            CALL DROT( M-J+1, B( J-1, J ), LDB, B( J, J ), LDB, CO, SI )
            TMP1          = -SI*B( J-1, J-1 )
            B( J-1, J-1 ) =  CO*B( J-1, J-1 )
            CALL DROT( J-2, F( 1, J-1 ), 1, F( 1, J ), 1, CO, SI )
            CALL DROT( M-J, F( J-1, MJ1 ), LDF, F( J, MJ1 ), LDF, CO, SI
     $                  )
C
            IF( LCMPQ2 ) THEN
C
C              Update Q2.
C
               CALL DROT( N, Q2( 1, M+J-1 ), 1, Q2( 1, M+J ), 1, CO, SI
     $                     )
            END IF
C
C           Determine a Givens rotation to annihilate B(j,j-1) from the
C           right.
C
            CALL DLARTG( B( J, J ), TMP1, CO, SI, TMP2 )
            B( J, J ) = TMP2
C
C           Update B.
C
            CALL DROT( J-1, B( 1, J ), 1, B( 1, J-1 ), 1, CO, SI )
C
C           Update C1 and W.
C
            CALL DROT( M, C1( 1, J ), 1, C1( 1, J-1 ), 1, CO, SI )
            CALL DROT( M-K+1, DWORK( ( J-1 )*M+K ), 1,
     $                 DWORK( ( J-2 )*M+K ), 1, CO, SI )
C
            IF( LCMPQ2 ) THEN
C
C              Update Q2.
C
               CALL DROT( N, Q2( 1, J ), 1, Q2( 1, J-1 ), 1, CO, SI )
            END IF
  120    CONTINUE
  130 CONTINUE
C
C                     (  A1  D1  )      (  B1  F1  )      (  C11  V1  )
C     Now we have S = (          ), T = (          ), H = (           ),
C                     (   0  A1' )      (   0  B1' )      (   0  C21' )
C
C     where A1, B1, and C11 are upper triangular, C21 is upper
C     Hessenberg, and D1 and F1 are skew-symmetric.
C
C     STEP 3: Apply the periodic QZ algorithm to the generalized matrix
C
C                           -1       -1
C             product C21 A1   C11 B1   in order to make C21 upper
C             quasi-triangular.
C
C     Determine the mode of computations.
C
      IF( LTRI .OR. LCMPQ1 .OR. LCMPQ2 ) THEN
         CMPQ = 'Initialize'
         IMAT = 4*MM + 1
         IWRK = 8*MM + 1
      ELSE
         CMPQ = 'No Computation'
         IMAT = 1
         IWRK = 4*MM + 1
      END IF
C
      IF( LTRI ) THEN
         CMPSC = 'Schur Form'
      ELSE
         CMPSC = 'Eigenvalues Only'
      END IF
C
C     Save matrices in the form that is required by MB03BD.
C
      CALL DLACPY( 'Full', M, M, C2, LDC2, DWORK( IMAT ),      M )
      CALL DLACPY( 'Full', M, M, A,  LDA,  DWORK( IMAT+MM ),   M )
      CALL DLACPY( 'Full', M, M, C1, LDC1, DWORK( IMAT+2*MM ), M )
      CALL DLACPY( 'Full', M, M, B,  LDB,  DWORK( IMAT+3*MM ), M )
      IWORK( 1 ) =  1
      IWORK( 2 ) = -1
      IWORK( 3 ) =  1
      IWORK( 4 ) = -1
C
C     Apply periodic QZ algorithm.
C     Workspace:    need   IWRK + MAX( N, 32 ) + 3.
C
      CALL MB03BD( CMPSC, 'Careful', CMPQ, IDUM, 4, M, 1, 1, M, IWORK,
     $             DWORK( IMAT ), M, M, DWORK, M, M, ALPHAR, ALPHAI,
     $             BETA, IWORK( 5 ), IWORK( M+5 ), LIWORK-( M+4 ),
     $             DWORK( IWRK ), LDWORK-IWRK+1, IWARN, INFO )
C
      IF( IWARN.GT.0 .AND. IWARN.LT.M ) THEN
         INFO = 1
         RETURN
      ELSE IF( IWARN.EQ.M+1 ) THEN
         INFO = 3
      ELSE IF( INFO.GT.0 ) THEN
         INFO = 2
         RETURN
      END IF
      OPTDW  = MAX( OPTDW, INT( DWORK( IWRK ) ) + IWRK - 1 )
      NBETA0 = 0
      I11    = 0
      I22    = 0
      I2X2   = 0
C
C     Compute the eigenvalues with nonnegative imaginary parts of the
C     pencil aS - bH. Also, count the number of 2-by-2 diagonal blocks,
C     I2X2, and the number of 1-by-1 and 2-by-2 blocks with unreliable
C     eigenvalues, I11 and I22, respectively.
C
      I = 1
C     WHILE( I.LE.M ) DO
  140 CONTINUE
      IF( I.LE.M ) THEN
         IF( NINF.GT.0 ) THEN
            IF( BETA( I ).EQ.ZERO )
     $         NBETA0 = NBETA0 + 1
         END IF
         IF( IWORK( I+4 ).GE.2*EMIN .AND. IWORK( I+4 ).LE.2*EMAX ) THEN
C
C           B = SQRT(BASE**IWORK(i+4)) is between underflow and overflow
C           threshold, BETA(i) is divided by B.
C
            BETA( I ) = BETA( I )/BASE**( HALF*IWORK( I+4 ) )
            IF( BETA( I ).NE.ZERO ) THEN
               IF( IWORK( M+I+5 ).LT.0 ) THEN
                  I22 = I22 + 1
               ELSE IF( IWORK( M+I+5 ).GT.0 ) THEN
                  I11 = I11 + 1
               END IF
               EIG = SQRT( DCMPLX( ALPHAR( I ), ALPHAI( I ) ) )
               ALPHAR( I ) = DIMAG( EIG )
               ALPHAI( I ) = DBLE(  EIG )
               IF( ALPHAR( I ).LT.ZERO )
     $             ALPHAR( I ) = -ALPHAR( I )
               IF( ALPHAI( I ).LT.ZERO )
     $             ALPHAI( I ) = -ALPHAI( I )
               IF( ALPHAR( I ).NE.ZERO .AND. ALPHAI( I ).NE.ZERO ) THEN
                  ALPHAR( I+1 ) = -ALPHAR( I )
                  ALPHAI( I+1 ) =  ALPHAI( I )
                  BETA(   I+1 ) =  BETA(   I )
                  I2X2 = I2X2 + 1
                  I    = I    + 1
               END IF
            END IF
         ELSE IF( IWORK( I+4 ).LT.2*EMIN ) THEN
C
C           Set to zero the numerator part of the eigenvalue.
C
            ALPHAR( I ) = ZERO
            ALPHAI( I ) = ZERO
            I11 = I11 + 1
         ELSE
C
C           Set an infinite eigenvalue.
C
            IF( NINF.GT.0 )
     $         NBETA0 = NBETA0 + 1
            BETA( I ) = ZERO
            I11 = I11 + 1
         END IF
         I = I + 1
         GO TO 140
      END IF
C     END WHILE 140
C
      IWORK( 1 ) = I11 + I22
C
C     Set to infinity the largest eigenvalues, if necessary.
C
      L = 0
      IF( NINF.GT.0 ) THEN
         DO 160  J = 1, NINF - NBETA0
            TMP1 = ZERO
            TMP2 = ONE
            P    = 1
            DO 150 I = 1, M
               IF( BETA( I ).GT.ZERO ) THEN
                  TEMP = DLAPY2( ALPHAR( I ), ALPHAI( I ) )
                  IF( TEMP.GT.TMP1 .AND. TMP2.GE.BETA( I ) ) THEN
                     TMP1 = TEMP
                     TMP2 = BETA( I )
                     P    = I
                  END IF
               END IF
  150       CONTINUE
            L = L + 1
            BETA( P ) = ZERO
  160    CONTINUE
C
         IF( L.EQ.IWORK( 1 ) ) THEN
C
C           All unreliable eigenvalues found have been set to infinity.
C
            INFO = 0
            I11  = 0
            I22  = 0
            IWORK( 1 ) = 0
         END IF
      END IF
C
C     Save the norms of the factors.
C
      CALL DCOPY( 4, DWORK( IWRK+1 ), 1, DUM, 1 )
C
C     Save the quadruples of the 1-by-1 and 2-by-2 diagonal blocks.
C     All 1-by-1 diagonal blocks come first.
C     Save also information about blocks with possible loss of accuracy.
C
C     Workspace:  IWRK+w-1, where w = 4 if M = 1, or w = 4*N, otherwise.
C
      K  = IWRK
      IW = IWORK( 1 )
      I  = 1
      J  = 1
      L  = 4*( M - 2*I2X2 ) + K
C
C     WHILE( I.LE.N ) DO
      UNREL = .FALSE.
  170 CONTINUE
      IF( I.LE.M ) THEN
         IF( J.LE.IW )
     $      UNREL = I.EQ.ABS( IWORK( M+I+5 ) )
         IF( ALPHAR( I ).NE.ZERO .AND. BETA( I ).NE.ZERO .AND.
     $       ALPHAI( I ).NE.ZERO ) THEN
            IF( UNREL ) THEN
               J = J + 1
               IWORK( J )    = IWORK( M+I+5 )
               IWORK( IW+J ) = L - IWRK + 1
               UNREL = .FALSE.
            END IF
            CALL DLACPY( 'Full', 2, 2, DWORK( IMAT+(M+1)*(I-1) ), M,
     $                   DWORK( L ), 2 )
            CALL DLACPY( 'Full', 2, 2, DWORK( IMAT+(M+1)*(I-1)+MM ), M,
     $                   DWORK( L+4 ), 2 )
            CALL DLACPY( 'Full', 2, 2, DWORK( IMAT+(M+1)*(I-1)+2*MM ),
     $                   M, DWORK( L+8 ), 2 )
            CALL DLACPY( 'Full', 2, 2, DWORK( IMAT+(M+1)*(I-1)+3*MM ),
     $                   M, DWORK( L+12 ), 2 )
            L = L + 16
            I = I + 2
         ELSE
            IF ( UNREL ) THEN
               J = J + 1
               IWORK( J )    = I
               IWORK( IW+J ) = K - IWRK + 1
               UNREL = .FALSE.
            END IF
            CALL DCOPY( 4, DWORK( IMAT+(M+1)*(I-1) ), MM, DWORK( K ),
     $                  1 )
            K = K + 4
            I = I + 1
         END IF
         GO TO 170
      END IF
C     END WHILE 170
C
      IWORK( 2*IW+2 ) = I11
      IWORK( 2*IW+3 ) = I22
      IWORK( 2*IW+4 ) = I2X2
C
      IF( LTRI ) THEN
C
C        Update C1 and C2.
C
         CALL DLACPY( 'Upper', M, M, DWORK( IMAT+2*MM ), M, C1, LDC1 )
         CALL DLACPY( 'Full',  M, M, DWORK( IMAT ), M, C2, LDC2 )
C
C        Update V.
C
         CALL DGEMM( 'Transpose', 'No Transpose', M, M, M, ONE,
     $               DWORK( 2*MM+1 ), M, VW( 1, 2 ), LDVW, ZERO,
     $               DWORK( IMAT ), M )
         CALL DGEMM( 'No Transpose', 'No Transpose', M, M, M, ONE,
     $               DWORK( IMAT ), M, DWORK, M, ZERO, VW( 1, 2 ),
     $               LDVW )
C
C        Update A.
C
         CALL DLACPY( 'Upper', M, M, DWORK( IMAT+MM ), M, A, LDA )
C
C        Skew-symmetric update of D.
C
         CALL MB01LD( 'Upper', 'Transpose', M, M, ZERO, ONE, DE( 1, 2 ),
     $                LDDE, DWORK( 2*MM+1 ), M, DE( 1, 2 ), LDDE,
     $                DWORK( IMAT ), LDWORK-IMAT+1, IW )
C
C        Update B.
C
         CALL DLACPY( 'Upper', M, M, DWORK( IMAT+3*MM ), M, B, LDB )
C
C        Skew-symmetric update of F.
C
         CALL MB01LD( 'Upper', 'Transpose', M, M, ZERO, ONE, F, LDF,
     $                DWORK, M, F, LDF, DWORK( IMAT ), LDWORK-IMAT+1,
     $                IW )
C
         IF( LCMPQ1 ) THEN
C
C           Update Q1.
C
            CALL DGEMM( 'No Transpose', 'No Transpose', N, M, M, ONE,
     $                  Q1, LDQ1, DWORK( 2*MM+1 ), M, ZERO,
     $                  DWORK( IMAT ), N )
            CALL DLACPY( 'Full', N, M, DWORK( IMAT ), N, Q1, LDQ1 )
            CALL DGEMM( 'No Transpose', 'No Transpose', N, M, M, ONE,
     $                  Q1( 1, M+1 ), LDQ1, DWORK( MM+1 ), M, ZERO,
     $                  DWORK( IMAT ), N )
            CALL DLACPY( 'Full', N, M, DWORK( IMAT ), N, Q1( 1, M+1 ),
     $                   LDQ1 )
         END IF
C
         IF( LCMPQ2 ) THEN
C
C           Update Q2.
C
            CALL DGEMM( 'No Transpose', 'No Transpose', N, M, M, ONE,
     $                  Q2, LDQ2, DWORK( 3*MM+1 ), M, ZERO,
     $                  DWORK( IMAT ), N )
            CALL DLACPY( 'Full', N, M, DWORK( IMAT ), N, Q2, LDQ2 )
            CALL DGEMM( 'No Transpose', 'No Transpose', N, M, M, ONE,
     $                  Q2( 1, M+1 ), LDQ2, DWORK, M, ZERO,
     $                  DWORK( IMAT ), N )
            CALL DLACPY( 'Full', N, M, DWORK( IMAT ), N, Q2( 1, M+1 ),
     $                   LDQ2 )
         END IF
      END IF
C
C     Move the norms, and the quadruples of 1-by-1 and 2-by-2 blocks
C     in front.
C
      K = 4*( M - 2*I2X2 ) + 16*I2X2
      CALL DCOPY( K, DWORK( IWRK ), 1, DWORK( 6 ), 1 )
      CALL DCOPY( 4, DUM, 1, DWORK( 2 ), 1 )
C
      DWORK( 1 ) = OPTDW
      RETURN
C *** Last line of MB04BD ***
      END


program demo_linewidth
!(LICENSE:PD)
   use M_DRAW,    only : prefsize, vinit, ortho2, clear, getkey
   use M_DRAW,    only : move2, draw2, vexit, color, linewidth
   implicit none
   integer :: i
   integer :: ipaws
   real    :: x,y,r,a,b,theta
   ! The Archimedean spiral is the locus of points corresponding
   ! to the locations over time of a point moving away from a
   ! fixed point with a constant speed along a line which rotates
   ! with constant angular velocity.
   !    r=a+b*theta
   ! Changing the parameter A will turn the spiral,
   ! while b controls the distance between successive turnings.
   call prefsize(401,401)
   call vinit(' ') ! start graphics using device $M_DRAW_DEVICE
   call ortho2(-150.0,150.0,-150.0,150.0)
   call clear()
   call move2(0.0,0.0)
   call color(2)
   a=0.0
   b=2.0
   do i=0,360*10,5
      theta=d2r(i)
      r=a+b*theta
      call polar_to_cartesian(r,theta,x,y)
      call linewidth(i/5/3)
      call draw2(x,y)
   enddo
   ipaws=getkey()
   call vexit()
contains
subroutine polar_to_cartesian(radius,inclination,x,y)
implicit none
character(len=*),parameter::ident_21="@(#)M_units::polar_to_cartesian(3f): convert polar coordinates to cartesian coordinates"
real,intent(in) :: radius,inclination
real,intent(out)  :: x,y
   if(radius.eq.0)then
      x=0.0
      y=0.0
   else
      x=radius*cos(inclination)
      y=radius*sin(inclination)
   endif
end subroutine polar_to_cartesian
elemental doubleprecision function d2r(idegrees)

character(len=*),parameter::ident_8="@(#)M_units::d2r(3f): Convert degrees to radians"

doubleprecision,parameter :: RADIAN=57.2957795131d0 ! degrees
integer,intent(in) :: idegrees                      ! input degrees to convert to radians
   d2r=dble(idegrees)/RADIAN                      ! do the unit conversion
end function d2r
end program demo_linewidth


#UNLESS<ord><gen>#!> @ingroup is_sorted_#ORD_NAME#
#IF<ord><gen>#!> @ingroup is_sorted
!>
!> @brief
!> Check if a vector of #<data><full># values is sorted by #<ord><docRef># order.
!>
!> @details
!> Check if a vector of #<data><full># values is sorted by #<ord><docRef># order. Returns a logical value indicating if the vector is sorted.
!>
!> @result  sorted
!> Indicates if the vector is sorted.
!>
!> | Value | Meaning                  |
!> |:-----:|:------------------------ |
!> | true  | The vector is sorted     |
!> | false | The vector is not sorted |
!>

!> @param x
!> The vector to be checked for being sorted.
!>
#IF<ord><gen>#!> @param #<ord><var>#
#IF<ord><gen>#!> A logical function which describes the ordering used. The function must take two #<data><full># arguments and return true if and only if the first argument must proceed the second argument in the order.
#IF<ord><gen>#!>
!> @note
!> Empty and single value vectors are considered sorted.
!>
#IF<ord><gen>#!> @warning
#IF<ord><gen>#!> The argument types and counts of #<ord><var># are not checked within this function.
#IF<ord><gen>#!>
!> @author Arin R. Bratt
!> @date 10/07/2014
#IF<ord><gen>THEN<>ELSE<pure >ENDIF#function is_sorted#ord##data#(x#<ord><arg>#) result(sorted)

  ! Result
  logical :: sorted

  ! Arguments
  #<data><full>#, intent(in) :: x(:)
  #IF<ord><gen>#procedure(logical) :: #<ord><var>#

  ! Variables
  integer :: i

  ! This structure avoides checking empty or single value vectors, which are always considered sorted.
  do i = 2,size(x,1)
     if (#ORD<x(i - 1)><x(i)>#) then
        sorted = .false.
        return
     end if
  end do
  sorted = .true.
end function is_sorted#ord##data#


!***********************************************************************
!                                                                      *
      REAL(KIND(0.0D0)) FUNCTION RINT_CF_Hamil (K,I,J,RJ)
!                                                                      *
!     The value of RINT_CF is an approximation to:                     *
!          k    k+1                                                    *
!     I ( r  / Rj * ( P (r)*P (r) + Q (r)*Q (r)); 0 to infinity)       *
!          <    >     I     J       I     J                            *
!                                                                      *
!                                                                      *
!     where   I ( G(r) ; Range )  denotes  the  integral  of G(r) over *
!     range.                                                           *
!                                                                      *
!     Call(s) to: [LIB92]: QUAD.                                       *
!                                                                      *
!     Written by G. Gaigalas and D. Kato                               *
!                                        NIFS, Japan, September 2013   *
!     The last modification made by G. Gaigalas       June      2018   *
!                                                                      *
!***********************************************************************
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY: DOUBLE
      USE CONS_C,          ONLY: ZERO
      USE grid_C
      USE tatb_C,          ONLY: MTP, TA
      USE wave_C
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE quad_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER, INTENT(IN)      :: I, J, K
      REAL(DOUBLE), INTENT(IN) :: RJ
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: L
      REAL(DOUBLE) :: RESULT
!-----------------------------------------------
!
!     Tabulate integrand as required for SUBROUTINE QUAD
      MTP = MIN (MF(I),MF(J))
!
!     Value at first tabulation point is arbitrary
      TA(1) = ZERO
      DO L = 2,MTP
!
!        if r < Rj
         IF (R(L) < RJ) THEN
            TA(L) = (R(L)**K)/(RJ**(K+1))*                             &
                    (PF(L,I)*PF(L,J)+QF(L,I)*QF(L,J))*RP(L)
         ELSE
           TA(L) = (RJ**K)/(R(L)**(K+1))*                              &
                    (PF(L,I)*PF(L,J)+QF(L,I)*QF(L,J))*RP(L)
         END IF
      END DO
!
!     Perform integration
      CALL QUAD (RESULT)
      RINT_CF_Hamil = RESULT
!
      RETURN
      END FUNCTION RINT_CF_Hamil


! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!
! Tests F2003 defined I/O (unformatted write)
! This example is based on example from the Fortran 2003 Handbook (page 336)

module rational_stuff
  type rational
    integer n, d
    real :: rat_rslt=0.0
  end type

  interface write (unformatted)
    module procedure write_rational_value
  end interface write (unformatted)
  interface read (unformatted)
    module procedure read_rational_value
  end interface read (unformatted)

 contains
  subroutine write_rational_value(dtv, unit, iostat, iomsg)

  class(rational), intent(inout) :: dtv
  integer, intent(in) :: unit
  integer, intent(out) :: iostat
  character(len=*), intent(inout) :: iomsg
  real rat

     if (dtv%d .ne. 0) then
       dtv%rat_rslt = real(dtv%n)/real(dtv%d)
       write(unit), dtv%n, dtv%d, dtv%rat_rslt
     endif
  end subroutine

  subroutine read_rational_value(dtv, unit, iostat, iomsg)

  class(rational), intent(inout) :: dtv
  integer, intent(in) :: unit
  integer, intent(out) :: iostat
  character(len=*), intent(inout) :: iomsg

  end subroutine
end module

  use rational_stuff
  type(rational) x, y
  logical rslt(3), expect(3)
  x = rational(2,3)
  open(10, file='io13.output', status='replace', form='unformatted')
  write(10) , x
  close(10)
  open(10, file='io13.output', status='old', form='unformatted')
  read(10), y%n, y%d, y%rat_rslt
  close(10)

  !print *, x%n, x%d, x%rat_rslt
  !print *, y%n, y%d, y%rat_rslt

  expect = .true.
  rslt(1) = x%n .eq. y%n
  rslt(2) = x%d .eq. y%d
  rslt(3) = x%rat_rslt .eq. y%rat_rslt

  call check(rslt, expect, 3)
  end


subroutine g()
integer :: x, i
x = 1
do i = 1, 10
    x = x*i
end do
end subroutine

subroutine h()
integer :: x, i
x = 1
do i = 1, 10
    x = i*x
end do
end subroutine


module EVTS_GDROMO
! Description:
!    Contains event functions for the GDromo formulation in double precision.
!
! Author:
!    Davide Amato
!    Space Dynamics Group - Technical University of Madrid
!    d.amato@upm.es
!
! ==============================================================================

use KINDS, only: ik,dk,qk

contains

subroutine DGDROMO_EVT(neq,phi,z,ng,roots)
! Description:
!    Finds roots to stop the integration for the GDromo formulation.
!
! ==============================================================================

! MODULES
use AUXILIARIES, only: JD_next,JD_stop
use CONSTANTS,   only: TU,secsPerDay
use SETTINGS,    only: flag_time_GDr

! VARIABLES
implicit none
! Arguments IN
integer(ik),intent(in)   ::  neq
integer(ik),intent(in)   ::  ng
real(dk),intent(in)      ::  phi
real(dk),intent(in)      ::  z(1:neq)
! Arguments OUT
real(dk),intent(out)     ::  roots(1:ng)

! Locals
real(dk)  ::  zeta
real(dk)  ::  t         ! Current time [-]

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

! Get time
zeta  = z(1)*sinh(phi) + z(2)*cosh(phi)
if ( flag_time_GDr == 0_ik ) then
	! Physical time
    t = z(8)
elseif  ( flag_time_GDr == 1_ik ) then
    ! Constant time element
    t = z(8) + z(3)**1.5_dk*(zeta - phi)
elseif  ( flag_time_GDr == 2_ik ) then
    ! Linear time element
    t = z(8) + z(3)**1.5_dk*zeta
end if

! ==============================================================================
! 01. Next timestep
! ==============================================================================

roots(1) = t - JD_next*secsPerDay*TU

! ==============================================================================
! 02. Stop integration
! ==============================================================================

roots(2) = t - JD_stop*secsPerDay*TU

end subroutine DGDROMO_EVT

end module EVTS_GDROMO


      SUBROUTINE perturbation_gaussian
      USE global
      IMPLICIT NONE
      REAL*8  ::X1(1,NX)
      INTEGER :: IC
!
!---------------------------------------------------------------------
!
      XC = aint(0.5*NX)      ! Center of the system lenght
!--------- HOT Electron density perturbation ------------------------------
      DO IC = 1, NX
         X1(1,IC)=(IC -XC)*DX/L0EH;  ! Argument of gaussion purturbation
      END DO
!
         DO 121 IC = 3, NXP2
         NEH(1,IC) = N0EH + DNEH*N0EH*exp(0-X1(1,IC-2)**2)
  121    CONTINUE
! ---- Boundary condition -------
      NEH(1,1)      = NEH(1,NXP1)
      NEH(1,2)      = NEH(1,NXP2)
      NEH(1,NXP3)   = NEH(1,3)
      NEH(1,NXP4)   = NEH(1,4)
!
      NEH(2,:) = NEH(1,:)
!--------- COLD Electron density perturbation ------------------------------
      DO IC = 1, NX
         X1(1,IC)=(IC -XC)*DX/L0EC;  ! Argument of gaussion purturbation
      END DO
!
         DO 11 IC = 3, NXP2
         NEC(1,IC) = N0EC + DNEC*N0EC*exp(0-X1(1,IC-2)**2)
   11    CONTINUE
! ---- Boundary condition -------
      NEC(1,1)      = NEC(1,NXP1)
      NEC(1,2)      = NEC(1,NXP2)
      NEC(1,NXP3)   = NEC(1,3)
      NEC(1,NXP4)   = NEC(1,4)
!
      NEC(2,:) = NEC(1,:)
! -------------- Ion density perturbation ----------------------------
      DO IC = 1, NX
         X1(1,IC)=(IC -XC)*DX/L0I;  ! Argument of gaussion purturbation
      END DO
!
         DO 191 IC = 3, NXP2
         NI(1,IC) = N0I + DNI*N0I*exp(0-X1(1,IC-2)**2)
  191   CONTINUE
! ---- Boundary condition -------
      NI(1,1)      = NI(1,NXP1)
      NI(1,2)      = NI(1,NXP2)
      NI(1,NXP3)   = NI(1,3)
      NI(1,NXP4)   = NI(1,4)
!
      NI(2,:) = NI(1,:)
! --------- Velocity perutrubation -----------------------------------
      DO IC = 1, NX
         X1(1,IC)=(IC -XC)*DX/L0V;  ! Argument of gaussion purturbation
      END DO
!
           DO 13 IC = 3, NXP2
                 VX(1,IC) = VX0 +  DNV*exp(0-X1(1,IC-2)**2)
                 VX(2,IC) = VX(1,IC)
   13      CONTINUE
! ---- Boundary condition -------
      VX(1,1)      = VX(1,NXP1)
      VX(1,2)      = VX(1,NXP2)
      VX(1,NXP3)   = VX(1,3)
      VX(1,NXP4)   = VX(1,4)
!
! ------- Calculating "Phi" form the initial purturbation -------------
          DO 553 IC = 3, NXP2
          PH(1,IC+1) =  2*PH(1,IC) - PH(1,IC-1) - DX*DX*(NI(1,IC) - NEH(1,IC)- NEC(1,IC))
  553     CONTINUE
! ---- Boundary condition -------
      PH(1,1)      = PH(1,NXP1)
      PH(1,2)      = PH(1,NXP2)
      PH(1,NXP3)   = PH(1,3)
      PH(1,NXP4)   = PH(1,4)
!
      PH(2,:) = PH(1,:)
!
      END SUBROUTINE perturbation_gaussian


!!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!! 2018.03.07: fortran lib for python
!!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!!==============================================================================
!!==============================================================================
    SUBROUTINE coupling_prediction(N,L,S,St1,dS,M,C_inv,W2,H02,cost2)
    IMPLICIT NONE
    !! W here = W in python code (the same order: from j--> i: W(i,j))
    INTEGER,PARAMETER ::  nloop=1000
    INTEGER :: N,L,i,iloop,stop_iteration,n_iter,i0

    REAL (KIND=8) :: H_av
    REAL (KIND=8) :: S(L,N),St1(L,N),dS(L,N),W(N),H0(nloop),cost(0:nloop),H(L)
    REAL (KIND=8) :: HS_av(N),C_inv(N,N),M(N),W1(nloop,N),W2(N,N),H02(N),cost2(N)

   !f2py intent(in) :: S,St1,dS,M,C_inv
   !f2py intent(hide), depend(S) :: L=shape(S,0),N=shape(S,1)
   !f2py intent(out) :: W2,H02,cost2

    DO i0=1,N
    H(1:L)=St1(1:L,i0) ; iloop=1 ; cost(0)=100. ; stop_iteration=0
    !!--------------------------------------------------------------
    DO WHILE ((iloop<=nloop).and.(stop_iteration==0))
        H_av=sum(H(1:L))/L

        DO i=1,N
        HS_av(i)=sum((H(1:L)-H_av)*dS(1:L,i))/L
        END DO

        W(:)=matmul(HS_av(:),C_inv(:,:))
        H0(iloop)=H_av - sum(W(:)*M(:))

        H(1:L)=matmul(S(1:L,:),W(:))+H0(iloop)

        cost(iloop)=sum((St1(1:L,i0)-tanh(H(1:L)))**2)/L
        !WRITE(*,*)iloop,cost(iloop)

        IF (cost(iloop)>=cost(iloop-1)) THEN
         stop_iteration=1
        END IF

        H(:)=St1(:,i0)*H(:)/tanh(H(:))
        W1(iloop,:)=W(:)

        iloop=iloop+1
    END DO
    !!--------------------------------------------------------------
    n_iter=iloop-2

    W2(i0,:)=W1(n_iter,:)
    cost2(i0)=cost(n_iter)
    H02(i0)=H0(n_iter)

    !WRITE(*,*)i0,cost2(i0)
    END DO

    END SUBROUTINE
!!==============================================================================
!!==============================================================================
    SUBROUTINE update_hidden_ens(N1,N2,L0,W,H0,S,S_out,nens)
    IMPLICIT NONE
    !! W here = W.T in python code
    INTEGER :: N1,N2,t,i,L0,L01,nens
    REAL (KIND=8) :: W(N2,N2),H0(N2),S(L0,N2),S_out(L0,N1:N2)
    REAL (KIND=8) :: H11(N1:N2),P11(N1:N2),H12(N2),P1,P2,rdn_S(L0,N1:N2)

    !f2py intent(in) :: N1,W,H0,S,nens
    !f2py intent(hide), depend(S) :: L0=shape(S,0),N2=shape(W,0)
    !f2py intent(out) :: S_out

    L01=L0/nens
    CALL random_number(rdn_S)

    DO t=1,L0
        IF (mod(t,L01) > 1) THEN  !! t = 2, .., L01-1
            H11(N1:N2)=H0(N1:N2)+matmul(S(t-1,:),W(:,N1:N2))
            P11(N1:N2)=1/(1+exp(-2*H11(N1:N2)))

            DO i=N1,N2
                S(t,i)=1.0
                H12(:)=H0(:)+matmul(S(t,:),W(:,:))
                P1=P11(i)/product(1+exp(-2*S(t+1,:)*H12(:)))
                P2=(1-P11(i))/product(1+exp(-2*S(t+1,:)*(H12(:)-2.*W(i,:))))
                S(t,i) = sign(1.d+00,(P1/(P1+P2)-rdn_S(t,i)))
            END DO
        END IF
    END DO

    !DO t=1,L0
    !    IF (mod(t,L01) > 1) THEN  !! t = 2, .., L01-1
    !        H11(N1:N2)=H0(N1:N2)+matmul(S(t-1,:),W(:,N1:N2))
    !        P11(N1:N2)=1/(1+exp(-2*H11(N1:N2)))

     !       DO i=N1,N2
     !           S(t,i)=1.0
     !           H12(:)=H0(:)+matmul(S(t,:),W(:,:))
     !           P1=P11(i)/product(1+exp(-2*S(t+1,:)*H12(:)))
     !           P2=(1-P11(i))/product(1+exp(-2*S(t+1,:)*(H12(:)-2.*W(i,:))))
     !           S(t,i) = sign(1.d+00,(P1/(P1+P2)-rdn_S(t,i)))
      !      END DO
      !  ELSE

        !IF (mod(t,L01) == 0) THEN  !! t = L01
        !    H11(N1:N2)=H0(N1:N2)+matmul(S(t-1,:),W(:,N1:N2))
        !    P11(N1:N2)=1/(1+exp(-2*H11(N1:N2)))
        !    S(t,N1:N2) = sign(1.d+00,(P11(N1:N2)-rdn_S(t,N1:N2)))
        !ELSE  !! t=1,L01+1,...
        !    DO i=N1,N2
        !        S(t,i)=1.0
        !        H12(:)=H0(:)+matmul(S(t,:),W(:,:))
        !        P1=1/product(1+exp(-2*S(t+1,:)*H12(:)))
        !        P2=1/product(1+exp(-2*S(t+1,:)*(H12(:)-2.*W(i,:))))
        !        S(t,i) = sign(1.d+00,(P1/(P1+P2)-rdn_S(t,i)))
        !    END DO
        !END IF
        !END IF

    !END DO

    S_out(:,N1:N2)=S(:,N1:N2)

    END SUBROUTINE
!!==============================================================================
   SUBROUTINE update_hidden(N1,N2,L,W,H0,S,S_out)
   IMPLICIT NONE
   !! W here = W.T in python code

   INTEGER :: N1,N2,t,L,i
   REAL (KIND=8) :: W(N2,N2),H0(N2),S(L,N2),S_out(L,N1:N2)
   REAL (KIND=8) :: H11(N1:N2),P11(N1:N2),H12(N2),P1,P2,rdn_S(L,N1:N2)

   !f2py intent(in) :: N1,W,H0,S
   !f2py intent(hide), depend(S) :: L=shape(S,0),N2=shape(W,0)
   !f2py intent(out) :: S_out

   CALL random_number(rdn_S)

   DO t=2,L-1

      H11(N1:N2)=H0(N1:N2)+matmul(S(t-1,:),W(:,N1:N2))
      P11(N1:N2)=1/(1+exp(-2*H11(N1:N2)))

      DO i=N1,N2
         S(t,i)=1.0
         H12(:)=H0(:)+matmul(S(t,:),W(:,:))
         P1=P11(i)/product(1+exp(-2*S(t+1,:)*H12(:)))
         P2=(1-P11(i))/product(1+exp(-2*S(t+1,:)*(H12(:)-2.*W(i,:))))

         S(t,i) = sign(1.d+00,(P1/(P1+P2)-rdn_S(t,i)))

      END DO

   END DO

   S_out(:,N1:N2)=S(:,N1:N2)

   END SUBROUTINE


      REAL             FUNCTION SCNRM2( N, X, INCX)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1998-05-11 SCNRM2  Krogh   Minor changes for conversion to C.
c>> 1998-05-07 SCNRM2  Krogh   Adapted new algorithm from SNRM2
c>> ....
C>> 1985-10-02 SCNRM2 Lawson  Initial code.
C
C     EUCLIDEAN NORM OF THE COMPLEX N-VECTOR STORED IN X() WITH STORAGE
C     INCREMENT INCX .
C     IF    N .LE. 0 RETURN WITH RESULT = 0.
C     IF N .GE. 1 THEN INCX MUST BE .GE. 1
C
C           C.L.LAWSON, 1978 JAN 08
C
C New algorithm avoids underflow as well as overflow, and avoids divides
c as much as possible.  F. Krogh, August 29, 1996.
c
c ************************* Variable Definitions ***********************
c
c Let b be the base for floating point, b**E be the smallest integer
c power of b that overflows, b**e be the smallest integer power of b
c that does not underflow, and d be the number of base b digits in a
c a floating point number.  The descriptions below use b, e, E, and d.
c
c ABIG = b ** ((E+5) / 4)).    This is used as a factor to get the
c   final answer when combining SUMX from big XA, with SUM.
c ASMALL = b ** ((e+d-E+5) / 4)).    This is used as a factor to get the
c   final answer when combining SUMX from small XA, with SUM.
c DBIG = b ** (2*((E+5)/4)).  This is used as a factor to get the
c   final answer when only SUMX formed from big XA's is needed.
c DSMALL = b ** (2*((e+d-E+5)/4)).  This is used as a factor to get the
c   final answer when only SUMX formed from big XA's is needed.
c FBIG = b ** (-2*((E+5)/4)).  This is used as a multiplier when
c   accumulating SUMX for big XA.
c FSMALL = b ** (-2*((e+d-E+5)/4)).  This is used as a multiplier when
c   accumulating SUMX for small XA.
c I      Temporary index.
c ID     Number of base I1MACH(10) digits in Floating point number.
c IEMN   The minimum floating point exponent.
c IEMX   The maximum floating point exponent.
c INCX   Input, the increment (>0) between elements of X.
c N      Input, the number of elements in X.
c NN     N * INCX = last index processed.
c SUM    Place where sum of XA**2 is accumlated.
c SUMX   Place where scaled sum of XA**2 is accumlated.  In first loop
c   this is for XA**2 that would likely underflow, and in second loop
c   this is for XA**2 that would likely overflow.
c TBIG = b ** ((E - d - 1) / 2).  If XA > TBIG, number is "big".  Note
c   that for such XA's, (FBIG * XA) ** 2 should not underflow and the
c   accumlation overflows only if the final result would.
c TSMALL = b ** ((e+1) / 2).  If XA <= TSMALL, number is "small".  Note
c   that for such XA's, (FSMALL * XA)**2 should not underflow and the
c   accumlation should not overlflow.
c X      Input, we are getting the L2 norm of X.
c XA     Contains base of floating point numbers when getting saved
c   parameters.  Later contains abs(X(I)).
C     ------------------------------------------------------------------
c--S replaces "?": ?NRM2
C     ------------------------------------------------------------------
      integer N, INCX
      complex             X(*)
      external I1MACH
      integer I, ID, IEMN, IEMX, I1MACH, NN
      real             SUM, SUMX, XA, XB
      real             ABIG,ASMALL,DBIG,DSMALL,FBIG,FSMALL,TBIG,TSMALL
      save ABIG,ASMALL,DBIG,DSMALL,FBIG,FSMALL,TBIG,TSMALL
c Values of these saved parameters for D.P. IEEE arithmetic are:
c   ABIG= .2315841784746324E+78     DBIG= .5363123171977043E+155
c   FBIG= .1864585182800050E-154    TBIG= .9989595361011182E+146
c ASMALL= .4887898181599363E-149  DSMALL= .2389154863368240E-298
c FSMALL= .4185580496821357E+299  TSMALL= .2983336292480080E-153
c Values of these saved parameters for S.P. IEEE arithmetic are:
c   ABIG= .8589935E+10      DBIG= .7378698E+20
c   FBIG= .1355253E-19      TBIG= .2251800E+16
c ASMALL= .1387779E-16    DSMALL= .1925930E-33
c FSMALL= .5192297E+34    TSMALL= .2168404E-18
c
      data ABIG / 0.E0 /
C     ------------------------------------------------------------------
c
c
      if (ABIG .eq. 0.E0) then
         IEMX = I1MACH(13)
         IEMN = I1MACH(12)
         ID = I1MACH(11)
         XA = real(I1MACH(10))
         ABIG = XA ** ((IEMX+5)/4)
         DBIG = ABIG ** 2
         FBIG = 1.E0 / DBIG
         TBIG = XA ** ((IEMX - ID - 1) / 2)
         ASMALL = XA ** ((IEMN + ID - IEMX + 5) / 4)
         DSMALL = ASMALL ** 2
         FSMALL = 1.E0 / DSMALL
         TSMALL = XA ** ((IEMN + 1) / 2)
      end if
      SUM = 0.E0
      if (N .gt. 0) then
         NN = N * INCX
         SUMX = 0.E0
c                      Loop when no big number yet encountered.
         do 100 I = 1, NN, INCX
            XA = abs(real(X(I)))
            XB = abs(aimag(X(I)))
            if (XA + XB .lt. TSMALL) then
               SUMX = SUMX + (FSMALL * XA)**2 + (FSMALL * XB)**2
            else
               if (XA .gt. TBIG) go to 200
               SUM = SUM + XA**2 + XB**2
            end if
  100    continue
         if (SUM .ne. 0.E0) then
            if (SUMX .ge. 1.E0) then
               if (SUM .lt. 1.E0) then
                  SUM = ASMALL * sqrt(FSMALL*SUM + DSMALL*SUMX)
                  go to 400
               end if
            end if
            SUM = sqrt(SUM)
         else
            SUM = DSMALL * sqrt(SUMX)
         end if
         go to 400
c
  200    SUMX = 0.E0
c                      Loop when we have at least one big number.
         do 300 I = I, NN, INCX
            XA = abs(real(X(I)))
            XB = abs(aimag(X(I)))
            if (XA + XB .gt. TSMALL) then
               if (XA + XB .gt. TBIG) then
                  SUMX = SUMX + (FBIG * XA)**2 + (FBIG * XB)**2
               else
                  SUM = SUM + XA**2 + XB**2
               end if
            end if
  300    continue
         if ((SUMX .le. 1.E10) .and. (SUM .ge. 1.E-10)) then
            SUM = ABIG * sqrt(FBIG*SUM + DBIG*SUMX)
         else
            SUM = DBIG * sqrt(SUMX)
         end if
      end if
  400 continue
      SCNRM2 = SUM
      return
      end


      SUBROUTINE FRACCART(RA,RB,RX11,RY11)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!  converts fractional to cartesian cooridates
!!!!  NB This routine automatically shifts the cartessians to have their origin at
!!!!  the cell centre
!!!!  K.Travis 06/05/12 Univ. of Sheffield
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      USE header_file
      IMPLICIT NONE

      REAL(kind = double) :: RAT,RBT,RA,RB,RX11,RY11

      RAT = RA - 0.5D0
      RBT = RB - 0.5D0
      RX11 = RAT*EFC(1,1) + RBT*EFC(1,2)
      RY11 = RAT*EFC(2,1) + RBT*EFC(2,2)

      END SUBROUTINE