        module symtrd_mod
        implicit none
        contains
        subroutine assert(isok,msg,ival)
        implicit none
        logical, intent(in) :: isok
        character*(*), intent(in) :: msg
        integer, intent(in) :: ival

        if (.not.isok) then
                write(*,*) msg,ival
                stop 'stop in assertion '
        endif
        return
        end subroutine assert
        subroutine symtrd_factor( m,n, A, B,C,
     &                                 L, D, ipiv, U, info )
        implicit none
        integer, parameter :: r8 = kind(1.0d0)

        integer, intent(in) :: m,n
        real(kind=r8), dimension(m,m,n), intent(in) :: A,B,C
        real(kind=r8), dimension(m,m,n), intent(inout) :: L,D,U
        integer, dimension(m,n), intent(inout) :: ipiv
        integer, intent(inout) :: info
!
!
! factor symmetric block tridiagonal matrix
!
! [A1, C1         ]   [ I             ]   [ D1, U1         ]
! [B2, A2, C2     ] = [ L2, I         ] * [     D2, U2     ]
! [    B3, A3, C3 ]   [     L3, I     ]   [         D3, U3 ]
! [        B4, A4 ]   [         L4, I ]   [             D4 ]
!
!
        logical, parameter :: use_gemm = .true.
        integer, parameter :: idebug = 1

        real(kind=r8), dimension(m,m) :: Dkm1,Dk,Lk,Ukm1
        integer, dimension(m) :: ipivkm1, ipivk
        integer :: k, linfo
        integer :: ld1,ld2,ld3

        integer :: mm,nn,kk, nrhs
        real(kind=r8) :: alpha, beta

!
!  Overall algorithm
!  D1 = A1
!  for k=2:n,
!      Lk = B(k) / D(k-1),
!      or D(k-1)'\B(k)' -> Lk'
!
!      Uk = Ck
!      Dk = Ak - Lk*U(k-1)
!  end

        info = 0

!  -------
!  D1 = A1
!  -------
        k = 1
        Dk(1:m,1:m) = A(1:m,1:m,k)

        if (idebug.ge.2) then
                write(*,*) 'k,Dk ',k,Dk
        endif

        ld1 = size(Dk,1)
        call dgetrf(m,m,Dk,ld1,ipivk,linfo)
        if (linfo.ne.0) then

          if (idebug.ge.1) then
            write(*,*) 'symtrd_factor: dgetrf(D1) linfo=',linfo
          endif

          info = -1
          return
        endif

        D(1:m,1:m,k) = Dk(1:m,1:m)
        ipiv(1:m,k) = ipivk(1:m)

!      ------------
!      Uk = Ck
!      ------------
        U(1:m,1:m,1:n) = C(1:m,1:m,1:n)

!      ---------
!      Main loop
!      ---------

        do k=2,n
!      ------------------
!      D(k-1)'\Bk' -> Lk'
!      ------------------
         Dkm1(1:m,1:m) = D(1:m,1:m,k-1)
         ipivkm1(1:m) = ipiv(1:m,k-1)

         Lk(1:m,1:m) = transpose(B(1:m,1:m,k))
         nrhs = m
         ld1 = size(Dkm1,1)
         ld2 = size(Lk,1)
         call dgetrs( 'T', m,nrhs, Dkm1, ld1, ipivkm1, Lk,ld2,linfo)
         if (linfo.ne.0) then

          if (idebug.ge.1) then
            write(*,*) 'symtrd_factor: dgetrs, k,linfo ',k,linfo
          endif

           linfo = -k
           return
          endif

          L(1:m,1:m,k) = transpose(Lk(1:m,1:m))
          Lk(1:m,1:m) =  L(1:m,1:m,k)

          if (idebug.ge.2) then
            write(*,*) 'k,Lk ',k,Lk
          endif
!      -------------------
!      Dk = Ak - Lk*U(k-1)
!      -------------------
          Dk(1:m,1:m) = A(1:m,1:m,k)
          Ukm1(1:m,1:m) = U(1:m,1:m,k-1)

          if (use_gemm) then
             mm = m
             nn = m
             kk = m
             alpha = -1.0d0
             beta = 1.0d0
             ld1 = size(Lk,1)
             ld2 = size(Ukm1,1)
             ld3 = size(Dk,1)
             call dgemm( 'N', 'N', mm,nn,kk,
     &            alpha, Lk,ld1,  Ukm1, ld2,
     &            beta,  Dk,ld3 )
          else
            Dk(1:m,1:m) = Dk(1:m,1:m) -
     &                    matmul(Lk(1:m,1:m),Ukm1(1:m,1:m))
          endif

          if (idebug.ge.2) then
                  write(*,*) 'k, Dk ',k,Dk
          endif

          ld1 = size(Dk,1)
          call dgetrf(m,m,Dk,ld1,ipivk,linfo)
          if (linfo.ne.0) then

            if (idebug.ge.1) then
              write(*,*) 'symtrd_factor: dgetrf(Dk), k,linfo ',k,linfo
            endif

            info = -k
            return
          endif
          D(1:m,1:m,k) = Dk(1:m,1:m)
          ipiv(1:m,k) = ipivk(1:m)

          enddo

          return
          end subroutine symtrd_factor

        subroutine symtrd_solve( m,n,nrhs, L, D, ipiv, U,
     &           Brhs_inout, info )
        implicit none
        integer, parameter :: r8 = kind(1.0d0)

        integer, intent(in) :: m,n,nrhs

        real(kind=r8), dimension(m,m,n),target,intent(in) :: L, D, U
        integer, dimension(m,n), target, intent(in) :: ipiv

        real(kind=r8), dimension(m,n,nrhs), intent(inout) :: Brhs_inout
        integer, intent(inout) :: info

!   note Brhs_inout has dimension(m,n,nrhs)
!   but  internally, we use Brhs with dimension (m,nrhs,n)
!   for better efficiency

!
!
! factor of symmetric block tridiagonal matrix
!
! [A1, B2'        ]   [ I             ]   [ D1, U1         ]
! [B2, A2, B3'    ] = [ L2, I         ] * [     D2, U2     ]
! [    B3, A3, B4']   [     L3, I     ]   [         D3, U3 ]
! [        B4, A4 ]   [         L4, I ]   [             D4 ]
!
!
        integer, parameter :: idebug = 1
        logical, parameter :: use_gemm = .true.

        integer :: linfo, k
        integer :: mm,nn,kk
        real(kind=r8) :: alpha, beta

        real(kind=r8), dimension(m,nrhs,n),target :: Brhs

        real(kind=r8), dimension(:,:,:), pointer :: Y,X
        real(kind=r8), dimension(:,:), pointer :: yk,ykm1,xk,xkp1
        real(kind=r8), dimension(:,:), pointer :: Dk,Uk,Lk
        integer, dimension(:), pointer :: ipivk

        integer :: ld1,ld2,ld3

! Overall algorithm related to LU factorization
!  L * (U * x) =  b
!  (1) solve L*y = b,   (2) solve U * x = y
!
        do k=1,n
          Brhs(1:m,1:nrhs,k) = Brhs_inout(1:m,k,1:nrhs)
        enddo

!  --------------------------
!  Solve L y = b
!  y1 = b1
!  for k=2:n
!      yk = bk - Lk * y(k-1)
!  end
!  --------------------------
        info = 0

        Y => Brhs(1:m,1:nrhs, 1:n)
        X => Brhs(1:m,1:nrhs, 1:n)

        do k=2,n

          ykm1 => Y(1:m,1:nrhs,k-1)
          yk => Y(1:m,1:nrhs,k)
          Lk => L(1:m,1:m,k)

          if (use_gemm) then
                  mm = m
                  nn = nrhs
                  kk = m
                  alpha = -1.0d0
                  beta = 1.0d0
                  ld1 = size(Lk,1)
                  ld2 = size(ykm1,1)
                  ld3 = size(yk,1)
                  call dgemm('N','N', mm,nn,kk,
     &               alpha, Lk, ld1, ykm1, ld2,
     &               beta,  yk, ld3 )

          else
             yk(1:m,1:nrhs) = yk(1:m,1:nrhs) -
     &            matmul(Lk(1:m,1:m),ykm1(1:m,1:nrhs))
          endif

        enddo

!    -------------------------------------
!   Solve U x = y
!
!    xn = Dn \ yn
!    for k=(n-1) downto 1
!          xk = Dk \ (yk - Uk * x(k+1) )
!    end
!    -------------------------------------

        k = n

        xk => Y(1:m,1:nrhs,k)
        Dk => D(1:m,1:m,k)
        ipivk => ipiv(1:m,k)

        ld1 = size(Dk,1)
        ld2 = size(xk,1)
        call dgetrs('N',m,nrhs,Dk,ld1,ipivk,  xk,ld2,linfo)
        if (linfo.ne.0) then
          if (idebug.ge.1) then
            write(*,*) 'symtrd_solve: dgetrs, k,linfo ',k,linfo
          endif

          info = -k
          return
        endif

        do k=n-1,1,-1
!          -----------------------------
!          xk = Dk \ (yk - Uk * x(k+1) )
!          -----------------------------

           yk => Y(1:m,1:nrhs,k)
           xk => yk
           xkp1 => X(1:m,1:nrhs,k+1)
           Uk => U(1:m,1:m,k)

           if (use_gemm) then
             mm = m
             nn = nrhs
             kk = m
             alpha = -1.0d0
             beta  = 1.0d0
             ld1 = size(Uk,1)
             ld2 = size(xkp1,1)
             ld3 = size(xk,1)
             call dgemm('N','N', mm,nn,kk,
     &         alpha, Uk,ld1, xkp1, ld2,
     &         beta,  xk, ld3 )
           else
             xk(1:m,1:nrhs) = xk(1:m,1:nrhs) -
     &                      matmul(Uk(1:m,1:m), xkp1(1:m,1:nrhs))
           endif

           Dk => D(1:m,1:m,k)
           ipivk => ipiv(1:m,k)

           ld1 = size(Dk,1)
           ld2 = size(xk,1)
           call dgetrs('N',m,nrhs,Dk,ld1,ipivk,  xk,ld2,linfo)
           if (linfo.ne.0) then
             if (idebug.ge.1) then
               write(*,*) 'symtrd_solve: dgetrs, k,linfo ',k,linfo
             endif

             info = -k
             return
           endif

         enddo

         do k=1,n
           Brhs_inout(1:m,k,1:nrhs) = Brhs(1:m,1:nrhs,k)
         enddo

         return
         end subroutine symtrd_solve

        subroutine symtrd_matmul(m,n,nrhs, A, B,C,  X, Y )
        implicit none
        integer, parameter :: r8 = kind(1.0d0)
        integer, intent(in) :: m,n,nrhs

        real(kind=r8), target, dimension(m,m,n), intent(in) ::  A,B,C
        real(kind=r8), target, dimension(m,n,nrhs), intent(in) :: X
        real(kind=r8), target, dimension(m,n,nrhs), intent(inout) :: Y

        integer :: k

        real(kind=r8), dimension(:,:), pointer :: Ak, Bk, Ck
        real(kind=r8), dimension(:,:), pointer :: yk, xkm1,xk,xkp1

        logical, parameter :: use_gemm = .true.
        integer :: mm,nn,kk, ld1,ld2,ld3
        real(kind=r8) :: alpha,beta
!       ---------
!       form Y
!
!       block diagonal part
!       Y(k) = A(k) * x(k)
!       ---------

        k = 2
        xk => X(1:m,k,1:nrhs)

        do k=1,n

          Ak => A(1:m,1:m,k)
          xk => X(1:m,k,1:nrhs)
          yk => Y(1:m,k,1:nrhs)

          if (use_gemm) then
            mm = m
            nn = nrhs
            kk = m
            alpha = 1.0d0
            beta = 0.0d0
            ld1 = size(Ak,1)
            ld2 = size(xk,1)
            ld3 = size(yk,1)
            call dgemm('N','N',mm,nn,kk,
     &          alpha, Ak,ld1, xk, ld2, beta, yk, ld3 )
          else
            yk(1:m,1:nrhs) = matmul(Ak(1:m,1:m), xk(1:m,1:nrhs))
          endif

!       -----------------------
!       Y(k) = Y(k) + B(k) * x(k-1)  ,  k=2:n
!       -----------------------
        if ((2.le.k).and.(k.le.n)) then

           Bk => B(1:m,1:m,k)
           xkm1 => X(1:m,k-1,1:nrhs)

           if (use_gemm) then
              mm = m
              nn = nrhs
              kk = m
              alpha = 1.0d0
              beta = 1.0d0
              ld1 = size(Bk,1)
              ld2 = size(xkm1,1)
              ld3 = size(yk,1)
              call dgemm('N','N', mm,nn,kk,
     &          alpha, Bk,ld1, xkm1, ld2, beta, yk, ld3 )
           else
              yk(1:m,1:nrhs) = yk(1:m,1:nrhs) +
     &               matmul( Bk(1:m,1:m),xkm1(1:m,1:nrhs))
           endif
          endif

!       -------------------------------------
!       Y(k) = Y(k) + C(k)*x(k+1), k=1:(n-1)
!       -------------------------------------
          if ((1.le.k).and.(k.le.(n-1)) ) then

            Ck => C(1:m,1:m,k)
            xkp1 => X(1:m,k+1,1:nrhs)

            if (use_gemm) then
              mm = m
              nn = nrhs
              kk = m
              alpha = 1.0d0
              beta = 1.0d0
              ld1 = size(Ck,1)
              ld2 = size(xkp1,1)
              ld3 = size(yk,1)
              call dgemm('N','N',mm,nn,kk,
     &            alpha, Ck,ld1, xkp1, ld2,
     &            beta,  yk, ld3 )
            else
              yk(1:m,1:nrhs) = yk(1:m,1:nrhs) +
     &                   matmul( Ck(1:m,1:m), xkp1(1:m,1:nrhs) )
            endif
          endif

          enddo

        return
        end subroutine symtrd_matmul
        subroutine test_symtrd(m,n,nrhs )
        implicit none
        integer, parameter :: r8 = kind(1.0d0)

        integer, parameter :: idebug = 1
        integer, intent(in) :: m,n,nrhs

!       ------------------------------------------------
!       simple driver to test symtrd_factor/symtrd_solve
!       ------------------------------------------------
        real(kind=r8), dimension(m,m,n) :: A,B,C,L,D,U
        real(kind=r8), dimension(m,n,nrhs) :: X,Brhs,Resid,Xsolve

        integer, dimension(m,n) :: ipiv

        integer :: i,j,k, info

        real(kind=r8),dimension(m,m) :: Ak, Bkp1,Ck

        real(kind=r8) :: t1,t2,abserr,maxerr
!       ----------------
!       generate problem
!       ----------------
        write(*,*) 'test_symtrd: m,n,nrhs ',m,n,nrhs

        call cpu_time(t1)
        call random_number(A)
        call random_number(B)
        call random_number(C)
        call random_number(X)

! ---------------------
! make matrix symmetric
! ---------------------

        do k=1,n-1
           Bkp1(1:m,1:m) = B(1:m,1:m,k+1)
           Ck(1:m,1:m) = transpose(Bkp1(1:m,1:m))
           C(1:m,1:m,k) = Ck(1:m,1:m)
        enddo

        do k=1,n
           Ak(1:m,1:m) = A(1:m,1:m,k)
           A(1:m,1:m,k) = Ak(1:m,1:m) + transpose(Ak(1:m,1:m))
        enddo
        call cpu_time(t2)
        write(*,*) 'time to form A,B,X ', t2-t1

        call cpu_time(t1)
        call symtrd_matmul( m,n,nrhs, A,B,C,  X, Brhs )
        call cpu_time(t2)
        write(*,*) 'time to form Brhs ', t2-t1

!       ---------------------
!       perform factorization
!       ---------------------
        info = 0
        call cpu_time(t1)
        call symtrd_factor( m,n,A,B,C,
     &                      L,D,ipiv, U, info)
        call cpu_time(t2)
        if (info.ne.0) then
                write(*,*) 'symtrd_factor return info ',info
        endif

        write(*,*) 'symtrd_factor took ', t2-t1,' sec '

!       -------------
!       perform solve
!       -------------
        Xsolve(1:m,1:n,1:nrhs) = Brhs(1:m,1:n,1:nrhs)
        info = 0
        call cpu_time(t1)
        call  symtrd_solve( m,n,nrhs, L,D,ipiv,U, Xsolve,info)
        call cpu_time(t2)

        if (info.ne.0) then
                write(*,*) 'symtrd_solve return info ',info
        endif

        write(*,*) 'symtrd_solve took ', t2-t1,' sec '

!       ----------------------
!       difference in solution
!       ----------------------
        maxerr = 0.0d0
        do k=1,nrhs
        do j=1,n
        do i=1,m
           abserr = ( abs( X(i,j,k) - Xsolve(i,j,k) ) )
           if (abserr .gt. maxerr) then
              maxerr =  abserr

              if (idebug.ge.2) then
                  write(*,*) 'i,j,k ',i,j,k,' X,Xsolve,abserr ',
     &              X(i,j,k),Xsolve(i,j,k),abserr
              endif
           endif
        enddo
        enddo
        enddo

        write(*,*) 'difference in solution ',  maxerr

        call symtrd_matmul( m,n,nrhs, A,B,C, Xsolve, Resid)
        maxerr = 0.0d0
        do k=1,nrhs
        do j=1,n
        do i=1,m
          abserr = ( abs( Resid(i,j,k) - Brhs(i,j,k) ))
          if (abserr .gt. maxerr) then
             maxerr = abserr

             if (idebug.ge.2) then
               write(*,*) 'i,j,k ',i,j,k,' Resid,Brhs,abserr ',
     &                   Resid(i,j,k),Brhs(i,j,k),abserr
             endif
          endif
        enddo
        enddo
        enddo

        write(*,*) 'difference in residual ', maxerr

        return
        end subroutine test_symtrd
        end module symtrd_mod


    subroutine eqcte(tem,sal,pr,bc,ak1,ak2,akb,akc)
!   -----------------------------------------------
    implicit none
    double precision tem,sal,pr,bc,ak1,ak2,akb,akc,ak0
    double precision pratm,tcel,rt,dv1,dk1,arg,dv2,dk2,dvb,dkb
!   this subroutine returns the equilibrium constants in mol/m3
!   for the dissociation of h2co3 (ak1), hco3 (ak2) and h3bo3 (akb)
!   as a function of temperature (tem) in kelvin, salinity (sal)
!   in per mil and pressure (pr) in bar. it also returns
!   henrys law constant bc for co2,(weiss (1974) for co2 solubility
!   in water, in zeebe & wolf-gladrow -co2 in seawater: equilibrium,
!   kinetics, isotopes-) in mol/m3/pal, and the
!   saturation product (akc) for calcite at pr=0 in mol/m3*mol/m3.

    ak0=-60.2409+9345.17/tem+23.3585*dlog(tem/100) &
        +sal*(0.023517-0.00023656*tem+0.0047036*(tem*tem/10000))
    ak0=dexp(ak0)*1.e+3
    bc=280.e-6*ak0
    ak1=290.9097-14554.21/tem-45.0575*dlog(tem) &
        +dsqrt(sal)*(0.0221+34.02/tem)
    ak1=dexp(ak1)*1.e+3
    ak2=207.6548-11843.79/tem-33.6485*dlog(tem) &
        +dsqrt(sal)*(0.9805-92.65/tem)-0.03294*sal
    ak2=dexp(ak2)*1.e+3
    akb=148.0248-8966.90/tem-24.4344*dlog(tem) &
        +dsqrt(sal)*(0.5998-75.25/tem)-0.01767*sal
    akb=dexp(akb)*1.e+3
    akc=303.1308-13348.09/tem-48.7537*dlog(tem) &
        +dsqrt(sal)*(1.6233-118.64/tem)-0.06999*sal
    akc=dexp(akc)*1.e+6
    if(pr.ge.1.)then
        pratm=pr/1.013
        tcel=tem-273.15
        rt=82.056*tem
        dv1=-(25.50+0.151*(sal-34.8)-0.1271*tcel)
        dk1=-1.e-3*(3.08+0.578*(sal-34.8)-0.0877*tcel)
        arg=-dv1*pratm/rt+0.5*dk1*pratm*pratm/rt
        ak1=ak1*dexp(arg)
        dv2=-(15.82-0.321*(sal-34.8)+0.0219*tcel)
        dk2=-1.e-3*(-1.13+0.314*(sal-34.8)+0.1475*tcel)
        arg=-dv2*pratm/rt+0.5*dk2*pratm*pratm/rt
        ak2=ak2*dexp(arg)
        dvb=-(29.48-0.295*(sal-34.8)-0.1622*tcel+0.002608*tcel*tcel)
        dkb=-1.e-3*(2.84-0.354*(sal-34.8))
        arg=-dvb*pratm/rt+0.5*dkb*pratm*pratm/rt
        akb=akb*dexp(arg)
    endif
    return
    end


program test_nucchem
    use exceptions_lib
	use nucchem_def
	use nucchem_lib

	integer :: j, ierr, ncharged
	integer, dimension(2) :: indx, Z, A, N, charged_ids
	real(dp), dimension(2) :: X, Yion
	character(len=iso_name_length), dimension(2) :: names
	real(dp) :: Xsum
	type(composition_info_type) :: comp
    type(assertion) :: initialization=assertion(scope='main', &
    &   message='nucchem is uninitialized')

    call nucchem_init('../../data',ierr)
    call initialization% assert(ierr==0)

	! check the composition average
	Z = [26,28]
	A = 56
    N = A-Z

    indx = [(get_nuclide_index_from_ZN(Z(j),N(j)),j=1,2)]
	names = nuclib% name(indx)

	X = 0.5
	call compute_composition_moments(2,indx,X,comp,Xsum,  &
	& ncharged, charged_ids, Yion,  &
	& renormalize_mass_fractions = .FALSE., &
	& abunds_are_mass_fractions=.true., exclude_neutrons=.FALSE.)

	write (*,'(/,a,/,18("="))') 'composition moments'
	write (*,'(a10,f8.3)')'<A> = ',comp% A
	write (*,'(a10,f8.3)')'<Z> = ',comp% Z
	write (*,'(a10,f8.3)')'<Z2> = ',comp% Z2
	write (*,'(a10,f8.3)')'Ye = ',comp% Ye
	write (*,'(a10,f8.3)')'<Q> = ',comp% Q

	call nucchem_shutdown
end program test_nucchem


      SUBROUTINE SB03OT( DISCR, LTRANS, N, S, LDS, R, LDR, SCALE, DWORK,
     $                   INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To solve for X = op(U)'*op(U) either the stable non-negative
C     definite continuous-time Lyapunov equation
C                                   2
C        op(S)'*X + X*op(S) = -scale *op(R)'*op(R)                   (1)
C
C     or the convergent non-negative definite discrete-time Lyapunov
C     equation
C                                   2
C        op(S)'*X*op(S) - X = -scale *op(R)'*op(R)                   (2)
C
C     where op(K) = K or K' (i.e., the transpose of the matrix K), S is
C     an N-by-N block upper triangular matrix with one-by-one or
C     two-by-two blocks on the diagonal, R is an N-by-N upper triangular
C     matrix, and scale is an output scale factor, set less than or
C     equal to 1 to avoid overflow in X.
C
C     In the case of equation (1) the matrix S must be stable (that
C     is, all the eigenvalues of S must have negative real parts),
C     and for equation (2) the matrix S must be convergent (that is,
C     all the eigenvalues of S must lie inside the unit circle).
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DISCR   LOGICAL
C             Specifies the type of Lyapunov equation to be solved as
C             follows:
C             = .TRUE. :  Equation (2), discrete-time case;
C             = .FALSE.:  Equation (1), continuous-time case.
C
C     LTRANS  LOGICAL
C             Specifies the form of op(K) to be used, as follows:
C             = .FALSE.:  op(K) = K    (No transpose);
C             = .TRUE. :  op(K) = K**T (Transpose).
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices S and R.  N >= 0.
C
C     S       (input) DOUBLE PRECISION array of dimension (LDS,N)
C             The leading N-by-N upper Hessenberg part of this array
C             must contain the block upper triangular matrix.
C             The elements below the upper Hessenberg part of the array
C             S are not referenced. The 2-by-2 blocks must only
C             correspond to complex conjugate pairs of eigenvalues (not
C             to real eigenvalues).
C
C     LDS     INTEGER
C             The leading dimension of array S.  LDS >= MAX(1,N).
C
C     R       (input/output) DOUBLE PRECISION array of dimension (LDR,N)
C             On entry, the leading N-by-N upper triangular part of this
C             array must contain the upper triangular matrix R.
C             On exit, the leading N-by-N upper triangular part of this
C             array contains the upper triangular matrix U.
C             The strict lower triangle of R is not referenced.
C
C     LDR     INTEGER
C             The leading dimension of array R.  LDR >= MAX(1,N).
C
C     SCALE   (output) DOUBLE PRECISION
C             The scale factor, scale, set less than or equal to 1 to
C             prevent the solution overflowing.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (4*N)
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  if the Lyapunov equation is (nearly) singular
C                   (warning indicator);
C                   if DISCR = .FALSE., this means that while the
C                   matrix S has computed eigenvalues with negative real
C                   parts, it is only just stable in the sense that
C                   small perturbations in S can make one or more of the
C                   eigenvalues have a non-negative real part;
C                   if DISCR = .TRUE., this means that while the
C                   matrix S has computed eigenvalues inside the unit
C                   circle, it is nevertheless only just convergent, in
C                   the sense that small perturbations in S can make one
C                   or more of the eigenvalues lie outside the unit
C                   circle;
C                   perturbed values were used to solve the equation
C                   (but the matrix S is unchanged);
C             = 2:  if the matrix S is not stable (that is, one or more
C                   of the eigenvalues of S has a non-negative real
C                   part), if DISCR = .FALSE., or not convergent (that
C                   is, one or more of the eigenvalues of S lies outside
C                   the unit circle), if DISCR = .TRUE.;
C             = 3:  if the matrix S has two or more consecutive non-zero
C                   elements on the first sub-diagonal, so that there is
C                   a block larger than 2-by-2 on the diagonal;
C             = 4:  if the matrix S has a 2-by-2 diagonal block with
C                   real eigenvalues instead of a complex conjugate
C                   pair.
C
C     METHOD
C
C     The method used by the routine is based on a variant of the
C     Bartels and Stewart backward substitution method [1], that finds
C     the Cholesky factor op(U) directly without first finding X and
C     without the need to form the normal matrix op(R)'*op(R) [2].
C
C     The continuous-time Lyapunov equation in the canonical form
C                                                        2
C       op(S)'*op(U)'*op(U) + op(U)'*op(U)*op(S) = -scale *op(R)'*op(R),
C
C     or the discrete-time Lyapunov equation in the canonical form
C                                                        2
C       op(S)'*op(U)'*op(U)*op(S) - op(U)'*op(U) = -scale *op(R)'*op(R),
C
C     where U and R are upper triangular, is solved for U.
C
C     REFERENCES
C
C     [1] Bartels, R.H. and Stewart, G.W.
C         Solution of the matrix equation  A'X + XB = C.
C         Comm. A.C.M., 15, pp. 820-826, 1972.
C
C     [2] Hammarling, S.J.
C         Numerical solution of the stable, non-negative definite
C         Lyapunov equation.
C         IMA J. Num. Anal., 2, pp. 303-325, 1982.
C
C     NUMERICAL ASPECTS
C                               3
C     The algorithm requires 0(N ) operations and is backward stable.
C
C     FURTHER COMMENTS
C
C     The Lyapunov equation may be very ill-conditioned. In particular
C     if S is only just stable (or convergent) then the Lyapunov
C     equation will be ill-conditioned. "Large" elements in U relative
C     to those of S and R, or a "small" value for scale, is a symptom
C     of ill-conditioning. A condition estimate can be computed using
C     SLICOT Library routine SB03MD.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, May 1997.
C     Supersedes Release 2.0 routine SB03CZ by Sven Hammarling,
C     NAG Ltd, United Kingdom, Oct. 1986.
C     Partly based on SB03CZ and PLYAP1 by A. Varga, University of
C     Bochum, May 1992.
C
C     REVISIONS
C
C     Dec. 1997, April 1998, May 1999, Feb. 2004.
C
C     KEYWORDS
C
C     Lyapunov equation, orthogonal transformation, real Schur form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE, TWO
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
C     .. Scalar Arguments ..
      LOGICAL           DISCR, LTRANS
      INTEGER           INFO, LDR, LDS, N
      DOUBLE PRECISION  SCALE
C     .. Array Arguments ..
      DOUBLE PRECISION  DWORK(*), R(LDR,*), S(LDS,*)
C     .. Local Scalars ..
      LOGICAL           CONT, TBYT
      INTEGER           INFOM, ISGN, J, J1, J2, J3, K, K1, K2, K3,
     $                  KOUNT, KSIZE
      DOUBLE PRECISION  ABSSKK, ALPHA, BIGNUM, D1, D2, DR, EPS, SCALOC,
     $                  SMIN, SMLNUM, SUM, T1, T2, T3, T4, TAU1, TAU2,
     $                  TEMP, V1, V2, V3, V4
C     .. Local Arrays ..
      DOUBLE PRECISION  A(2,2), B(2,2), U(2,2)
C     .. External Functions ..
      DOUBLE PRECISION  DLAMCH, DLANHS
      EXTERNAL          DLAMCH, DLANHS
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DCOPY, DLABAD, DLARFG, DSCAL, DSWAP,
     $                  DTRMM, DTRMV, MB04ND, MB04OD, SB03OR, SB03OY,
     $                  XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, MAX, SIGN, SQRT
C     .. Executable Statements ..
C
      INFO = 0
C
C     Test the input scalar arguments.
C
      IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDS.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDR.LT.MAX( 1, N ) ) THEN
         INFO = -7
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'SB03OT', -INFO )
         RETURN
      END IF
C
      SCALE = ONE
C
C     Quick return if possible.
C
      IF (N.EQ.0)
     $   RETURN
C
C     Set constants to control overflow.
C
      EPS = DLAMCH( 'P' )
      SMLNUM = DLAMCH( 'S' )
      BIGNUM = ONE / SMLNUM
      CALL DLABAD( SMLNUM, BIGNUM )
      SMLNUM = SMLNUM*DBLE( N*N ) / EPS
      BIGNUM = ONE / SMLNUM
C
      SMIN = MAX( SMLNUM, EPS*DLANHS( 'Max', N, S, LDS, DWORK ) )
      INFOM = 0
C
C     Start the solution. Most of the comments refer to notation and
C     equations in sections 5 and 10 of the second reference above.
C
C     Determine whether or not the current block is two-by-two.
C     K gives the position of the start of the current block and
C     TBYT is true if the block is two-by-two.
C
      CONT = .NOT.DISCR
      ISGN = 1
      IF ( .NOT.LTRANS ) THEN
C
C        Case op(M) = M.
C
         KOUNT = 1
C
   10    CONTINUE
C        WHILE( KOUNT.LE.N )LOOP
         IF ( KOUNT.LE.N ) THEN
            K = KOUNT
            IF ( KOUNT.GE.N ) THEN
               TBYT  = .FALSE.
               KOUNT = KOUNT + 1
            ELSE IF ( S(K+1,K).EQ.ZERO ) THEN
               TBYT  = .FALSE.
               KOUNT = KOUNT + 1
            ELSE
               TBYT = .TRUE.
               IF ( (K+1).LT.N ) THEN
                  IF ( S(K+2,K+1).NE.ZERO ) THEN
                     INFO = 3
                     RETURN
                  END IF
               END IF
               KOUNT = KOUNT + 2
            END IF
            IF ( TBYT ) THEN
C
C              Solve the two-by-two Lyapunov equation (6.1) or (10.19),
C              using the routine SB03OY.
C
               B(1,1) = S(K,K)
               B(2,1) = S(K+1,K)
               B(1,2) = S(K,K+1)
               B(2,2) = S(K+1,K+1)
               U(1,1) = R(K,K)
               U(1,2) = R(K,K+1)
               U(2,2) = R(K+1,K+1)
C
               CALL SB03OY( DISCR, LTRANS, ISGN, B, 2, U, 2, A, 2,
     $                      SCALOC, INFO )
               IF ( INFO.GT.1 )
     $            RETURN
               INFOM = MAX( INFO, INFOM )
               IF( SCALOC.NE.ONE ) THEN
C
                  DO 20 J = 1, N
                     CALL DSCAL( J, SCALOC, R(1,J), 1 )
   20             CONTINUE
C
                  SCALE = SCALE*SCALOC
               END IF
               R(K,K)     = U(1,1)
               R(K,K+1)   = U(1,2)
               R(K+1,K+1) = U(2,2)
C
C              If we are not at the end of S then set up and solve
C              equation (6.2) or (10.20).
C
C              Note that  SB03OY  returns  ( u11*s11*inv( u11 ) ) in  B
C              and returns scaled alpha in  A.  ksize is the order of
C              the remainder of  S.  k1, k2 and k3  point to the start
C              of vectors in  DWORK.
C
               IF ( KOUNT.LE.N ) THEN
                  KSIZE = N - K - 1
                  K1 = KSIZE + 1
                  K2 = KSIZE + K1
                  K3 = KSIZE + K2
C
C                 Form the right-hand side of (6.2) or (10.20), the
C                 first column in DWORK( 1 ) ,..., DWORK( n - k - 1 )
C                 the second in DWORK( n - k ) ,...,
C                 DWORK( 2*( n - k - 1 ) ).
C
                  CALL DCOPY( KSIZE, R(K,K+2), LDR, DWORK, 1 )
                  CALL DCOPY( KSIZE, R(K+1,K+2), LDR, DWORK(K1), 1 )
                  CALL DTRMM( 'Right', 'Upper', 'No transpose',
     $                        'Non-unit', KSIZE, 2, -ONE, A, 2, DWORK,
     $                        KSIZE )
                  IF ( CONT ) THEN
                     CALL DAXPY( KSIZE, -R(K,K), S(K,K+2), LDS, DWORK,
     $                           1 )
                     CALL DAXPY( KSIZE, -R(K,K+1), S(K+1,K+2), LDS,
     $                           DWORK, 1)
                     CALL DAXPY( KSIZE, -R(K+1,K+1), S(K+1,K+2), LDS,
     $                           DWORK(K1), 1 )
                  ELSE
                     CALL DAXPY( KSIZE, -R(K,K)*B(1,1), S(K,K+2), LDS,
     $                           DWORK, 1 )
                     CALL DAXPY( KSIZE, -( R(K,K+1)*B(1,1) + R(K+1,K+1)
     $                           *B(2,1) ), S(K+1,K+2), LDS, DWORK, 1 )
                     CALL DAXPY( KSIZE, -R(K,K)*B(1,2), S(K,K+2), LDS,
     $                           DWORK(K1), 1 )
                     CALL DAXPY( KSIZE, -( R(K,K+1)*B(1,2) + R(K+1,K+1)
     $                           *B(2,2) ), S(K+1,K+2), LDS, DWORK(K1),
     $                           1 )
                  END IF
C
C                 SB03OR  solves the Sylvester equations. The solution
C                 is overwritten on DWORK.
C
                  CALL SB03OR( DISCR, LTRANS, KSIZE, 2, S(K+2,K+2), LDS,
     $                         B, 2, DWORK, KSIZE, SCALOC, INFO )
                  INFOM = MAX( INFO, INFOM )
                  IF( SCALOC.NE.ONE ) THEN
C
                     DO 30 J = 1, N
                        CALL DSCAL( J, SCALOC, R(1,J), 1 )
   30                CONTINUE
C
                     SCALE = SCALE*SCALOC
                  END IF
C
C                 Copy the solution into the next  2*( n - k - 1 )
C                 elements of  DWORK.
C
                  CALL DCOPY( 2*KSIZE, DWORK, 1, DWORK(K2), 1 )
C
C                 Now form the matrix  Rhat  of equation (6.4) or
C                 (10.22). Note that (10.22) is incorrect, so here we
C                 implement a corrected version of (10.22).
C
                  IF ( CONT ) THEN
C
C                    Swap the two rows of R with DWORK.
C
                     CALL DSWAP( KSIZE, DWORK, 1, R(K,K+2), LDR )
                     CALL DSWAP( KSIZE, DWORK(K1), 1, R(K+1,K+2), LDR )
C
C                    1st column:
C
                     CALL DAXPY( KSIZE, -A(1,1), DWORK(K2), 1, DWORK,
     $                           1 )
                     CALL DAXPY( KSIZE, -A(1,2), DWORK(K3), 1, DWORK,
     $                           1 )
C
C                    2nd column:
C
                     CALL DAXPY( KSIZE, -A(2,2), DWORK(K3), 1,
     $                           DWORK(K1), 1 )
                  ELSE
C
C                    Form  v = S1'*u + s*u11', overwriting  v  on DWORK.
C
C                    Compute  S1'*u,  first multiplying by the
C                    triangular part of  S1.
C
                     CALL DTRMM( 'Left', 'Upper', 'Transpose',
     $                           'Non-unit', KSIZE, 2, ONE, S(K+2,K+2),
     $                           LDS, DWORK, KSIZE )
C
C                    Then multiply by the subdiagonal of  S1  and add in
C                    to the above result.
C
                     J1 = K1
                     J2 = K + 2
C
                     DO 40 J = 1, KSIZE-1
                        IF ( S(J2+1,J2).NE.ZERO ) THEN
                           DWORK(J)  = S(J2+1,J2)*DWORK(K2+J) + DWORK(J)
                           DWORK(J1) = S(J2+1,J2)*DWORK(K3+J) +
     $                                 DWORK(J1)
                        END IF
                        J1 = J1 + 1
                        J2 = J2 + 1
   40                CONTINUE
C
C                    Add in s*u11'.
C
                     CALL DAXPY( KSIZE, R(K,K), S(K,K+2), LDS, DWORK,
     $                           1 )
                     CALL DAXPY( KSIZE, R(K,K+1), S(K+1,K+2), LDS,
     $                           DWORK, 1 )
                     CALL DAXPY( KSIZE, R(K+1,K+1), S(K+1,K+2), LDS,
     $                           DWORK(K1), 1 )
C
C                    Next recover r from R, swapping r with u.
C
                     CALL DSWAP( KSIZE, DWORK(K2), 1, R(K,K+2), LDR )
                     CALL DSWAP( KSIZE, DWORK(K3), 1, R(K+1,K+2), LDR )
C
C                    Now we perform the QR factorization.
C
C                    ( a ) = Q*( t ),
C                    ( b )
C
C                    and form
C
C                    ( p' ) = Q'*( r' ).
C                    ( y' )      ( v' )
C
C                    y  is then the correct vector to use in (10.22).
C                    Note that  a  is upper triangular and that  t  and
C                    p  are not required.
C
                     CALL DLARFG( 3, A(1,1), B(1,1), 1, TAU1 )
                     V1  = B(1,1)
                     T1  = TAU1*V1
                     V2  = B(2,1)
                     T2  = TAU1*V2
                     SUM = A(1,2) + V1*B(1,2) + V2*B(2,2)
                     B(1,2) = B(1,2) - SUM*T1
                     B(2,2) = B(2,2) - SUM*T2
                     CALL DLARFG( 3, A(2,2), B(1,2), 1, TAU2 )
                     V3 = B(1,2)
                     T3 = TAU2*V3
                     V4 = B(2,2)
                     T4 = TAU2*V4
                     J1 = K1
                     J2 = K2
                     J3 = K3
C
                     DO 50 J = 1, KSIZE
                        SUM = DWORK(J2) + V1*DWORK(J) + V2*DWORK(J1)
                        D1  = DWORK(J)  - SUM*T1
                        D2  = DWORK(J1) - SUM*T2
                        SUM = DWORK(J3) + V3*D1 + V4*D2
                        DWORK(J)  =  D1 - SUM*T3
                        DWORK(J1) =  D2 - SUM*T4
                        J1 = J1 + 1
                        J2 = J2 + 1
                        J3 = J3 + 1
   50                CONTINUE
C
                  END IF
C
C                 Now update  R1  to give  Rhat.
C
                  CALL DCOPY( KSIZE, DWORK, 1, DWORK(K2), 1 )
                  CALL DCOPY( KSIZE, DWORK(K1), 1, DWORK(K3), 1 )
                  CALL DCOPY( KSIZE, DWORK(K3), 1, DWORK(2), 2 )
                  CALL DCOPY( KSIZE, DWORK(K2), 1, DWORK(1), 2 )
                  CALL MB04OD( 'Full', KSIZE, 0, 2, R(K+2,K+2), LDR,
     $                         DWORK, 2, DWORK, 1, DWORK, 1, DWORK(K2),
     $                         DWORK(K3) )
               END IF
            ELSE
C
C              1-by-1 block.
C
C              Make sure S is stable or convergent and find u11 in
C              equation (5.13) or (10.15).
C
               IF ( DISCR ) THEN
                  ABSSKK = ABS( S(K,K) )
                  IF ( ( ABSSKK - ONE ).GE.ZERO ) THEN
                     INFO = 2
                     RETURN
                  END IF
                  TEMP = SQRT( ( ONE - ABSSKK )*( ONE + ABSSKK ) )
               ELSE
                  IF ( S(K,K).GE.ZERO ) THEN
                     INFO = 2
                     RETURN
                  END IF
                  TEMP = SQRT( ABS( TWO*S(K,K) ) )
               END IF
C
               SCALOC = ONE
               IF( TEMP.LT.SMIN ) THEN
                  TEMP  = SMIN
                  INFOM = 1
               END IF
               DR = ABS( R(K,K) )
               IF( TEMP.LT.ONE .AND. DR.GT.ONE ) THEN
                  IF( DR.GT.BIGNUM*TEMP )
     $               SCALOC = ONE / DR
               END IF
               ALPHA = SIGN( TEMP, R(K,K) )
               R(K,K) = R(K,K)/ALPHA
               IF( SCALOC.NE.ONE ) THEN
C
                  DO 60 J = 1, N
                     CALL DSCAL( J, SCALOC, R(1,J), 1 )
   60             CONTINUE
C
                  SCALE = SCALE*SCALOC
               END IF
C
C              If we are not at the end of  S  then set up and solve
C              equation (5.14) or (10.16).  ksize is the order of the
C              remainder of  S.  k1 and k2 point to the start of vectors
C              in  DWORK.
C
               IF ( KOUNT.LE.N ) THEN
                  KSIZE = N - K
                  K1 = KSIZE + 1
                  K2 = KSIZE + K1
C
C                 Form the right-hand side in DWORK( 1 ),...,
C                 DWORK( n - k ).
C
                  CALL DCOPY( KSIZE, R(K,K+1), LDR, DWORK, 1 )
                  CALL DSCAL( KSIZE, -ALPHA, DWORK, 1 )
                  IF ( CONT ) THEN
                     CALL DAXPY( KSIZE, -R(K,K), S(K,K+1), LDS, DWORK,
     $                          1 )
                  ELSE
                     CALL DAXPY( KSIZE, -S(K,K)*R(K,K), S(K,K+1), LDS,
     $                          DWORK, 1 )
                  END IF
C
C                 SB03OR solves the Sylvester equations. The solution is
C                 overwritten on  DWORK.
C
                  CALL SB03OR( DISCR, LTRANS, KSIZE, 1, S(K+1,K+1), LDS,
     $                         S(K,K), 1, DWORK, KSIZE, SCALOC, INFO )
                  INFOM = MAX( INFO, INFOM )
                  IF( SCALOC.NE.ONE ) THEN
C
                     DO 70 J = 1, N
                        CALL DSCAL( J, SCALOC, R(1,J), 1 )
   70                CONTINUE
C
                     SCALE = SCALE*SCALOC
                  END IF
C
C                 Copy the solution into the next  ( n - k ) elements
C                 of  DWORK,  copy the solution back into  R  and copy
C                 the row of  R  back into  DWORK.
C
                  CALL DCOPY( KSIZE, DWORK, 1, DWORK(K1), 1 )
                  CALL DSWAP( KSIZE, DWORK, 1, R(K,K+1), LDR )
C
C                 Now form the matrix  Rhat  of equation (5.15) or
C                 (10.17), first computing  y  in  DWORK,  and then
C                 updating  R1.
C
                  IF ( CONT ) THEN
                     CALL DAXPY( KSIZE, -ALPHA, DWORK(K1), 1, DWORK, 1 )
                  ELSE
C
C                    First form  lambda( 1 )*r  and then add in
C                    alpha*u11*s.
C
                     CALL DSCAL( KSIZE, -S(K,K), DWORK, 1 )
                     CALL DAXPY( KSIZE, ALPHA*R(K,K), S(K,K+1), LDS,
     $                           DWORK, 1 )
C
C                    Now form  alpha*S1'*u,  first multiplying by the
C                    sub-diagonal of  S1  and then the triangular part
C                    of  S1,  and add the result in DWORK.
C
                     J1 = K + 1
C
                     DO 80 J = 1, KSIZE-1
                        IF ( S(J1+1,J1).NE.ZERO ) DWORK(J)
     $                         = ALPHA*S(J1+1,J1)*DWORK(K1+J) + DWORK(J)
                        J1 = J1 + 1
   80                CONTINUE
C
                     CALL DTRMV( 'Upper', 'Transpose', 'Non-unit',
     $                           KSIZE, S(K+1,K+1), LDS, DWORK(K1), 1 )
                     CALL DAXPY( KSIZE, ALPHA, DWORK(K1), 1, DWORK, 1 )
                  END IF
                  CALL MB04OD( 'Full', KSIZE, 0, 1, R(K+1,K+1), LDR,
     $                         DWORK, 1, DWORK, 1, DWORK, 1, DWORK(K2),
     $                         DWORK(K1) )
               END IF
            END IF
            GO TO 10
         END IF
C        END WHILE 10
C
      ELSE
C
C        Case op(M) = M'.
C
         KOUNT = N
C
   90    CONTINUE
C        WHILE( KOUNT.GE.1 )LOOP
         IF ( KOUNT.GE.1 ) THEN
            K = KOUNT
            IF ( KOUNT.EQ.1 ) THEN
               TBYT  = .FALSE.
               KOUNT = KOUNT - 1
            ELSE IF ( S(K,K-1).EQ.ZERO ) THEN
               TBYT  = .FALSE.
               KOUNT = KOUNT - 1
            ELSE
               TBYT = .TRUE.
               K = K - 1
               IF ( K.GT.1 ) THEN
                  IF ( S(K,K-1).NE.ZERO ) THEN
                     INFO = 3
                     RETURN
                  END IF
               END IF
               KOUNT = KOUNT - 2
            END IF
            IF ( TBYT ) THEN
C
C              Solve the two-by-two Lyapunov equation corresponding to
C              (6.1) or (10.19), using the routine SB03OY.
C
               B(1,1) = S(K,K)
               B(2,1) = S(K+1,K)
               B(1,2) = S(K,K+1)
               B(2,2) = S(K+1,K+1)
               U(1,1) = R(K,K)
               U(1,2) = R(K,K+1)
               U(2,2) = R(K+1,K+1)
C
               CALL SB03OY( DISCR, LTRANS, ISGN, B, 2, U, 2, A, 2,
     $                      SCALOC, INFO )
               IF ( INFO.GT.1 )
     $            RETURN
               INFOM = MAX( INFO, INFOM )
               IF( SCALOC.NE.ONE ) THEN
C
                  DO 100 J = 1, N
                     CALL DSCAL( J, SCALOC, R(1,J), 1 )
  100             CONTINUE
C
                  SCALE = SCALE*SCALOC
               END IF
               R(K,K)     = U(1,1)
               R(K,K+1)   = U(1,2)
               R(K+1,K+1) = U(2,2)
C
C              If we are not at the front of S then set up and solve
C              equation corresponding to (6.2) or (10.20).
C
C              Note that  SB03OY  returns  ( inv( u11 )*s11*u11 ) in  B
C              and returns scaled alpha, alpha = inv( u11 )*r11, in  A.
C              ksize is the order of the remainder leading part of  S.
C              k1, k2 and k3 point to the start of vectors in  DWORK.
C
               IF ( KOUNT.GE.1 ) THEN
                  KSIZE = K - 1
                  K1 = KSIZE + 1
                  K2 = KSIZE + K1
                  K3 = KSIZE + K2
C
C                 Form the right-hand side of equations corresponding to
C                 (6.2) or (10.20), the first column in DWORK( 1 ) ,...,
C                 DWORK( k - 1 ) the second in DWORK( k ) ,...,
C                 DWORK( 2*( k - 1 ) ).
C
                  CALL DCOPY( KSIZE, R(1,K), 1, DWORK, 1 )
                  CALL DCOPY( KSIZE, R(1,K+1), 1, DWORK(K1), 1 )
                  CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-unit',
     $                        KSIZE, 2, -ONE, A, 2, DWORK, KSIZE )
                  IF ( CONT ) THEN
                     CALL DAXPY( KSIZE, -R(K,K), S(1,K), 1, DWORK, 1 )
                     CALL DAXPY( KSIZE, -R(K,K+1), S(1,K), 1, DWORK(K1),
     $                           1 )
                     CALL DAXPY( KSIZE, -R(K+1,K+1), S(1,K+1), 1,
     $                           DWORK(K1), 1 )
                  ELSE
                     CALL DAXPY( KSIZE, -( R(K,K)*B(1,1) + R(K,K+1)
     $                           *B(1,2) ), S(1,K), 1, DWORK, 1 )
                     CALL DAXPY( KSIZE, -R(K+1,K+1)*B(1,2), S(1,K+1), 1,
     $                           DWORK, 1 )
                     CALL DAXPY( KSIZE, -( R(K,K)*B(2,1) + R(K,K+1)
     $                           *B(2,2) ), S(1,K), 1, DWORK(K1), 1 )
                     CALL DAXPY( KSIZE, -R(K+1,K+1)*B(2,2), S(1,K+1), 1,
     $                           DWORK(K1), 1 )
                  END IF
C
C                 SB03OR  solves the Sylvester equations. The solution
C                 is overwritten on DWORK.
C
                  CALL SB03OR( DISCR, LTRANS, KSIZE, 2, S, LDS, B, 2,
     $                         DWORK, KSIZE, SCALOC, INFO )
                  INFOM = MAX( INFO, INFOM )
                  IF( SCALOC.NE.ONE ) THEN
C
                     DO 110 J = 1, N
                        CALL DSCAL( J, SCALOC, R(1,J), 1 )
  110                CONTINUE
C
                     SCALE = SCALE*SCALOC
                  END IF
C
C                 Copy the solution into the next  2*( k - 1 ) elements
C                 of  DWORK.
C
                  CALL DCOPY( 2*KSIZE, DWORK, 1, DWORK(K2), 1 )
C
C                 Now form the matrix  Rhat  of equation corresponding
C                 to (6.4) or (10.22) (corrected version).
C
                  IF ( CONT ) THEN
C
C                    Swap the two columns of R with DWORK.
C
                     CALL DSWAP( KSIZE, DWORK, 1, R(1,K), 1 )
                     CALL DSWAP( KSIZE, DWORK(K1), 1, R(1,K+1), 1 )
C
C                    1st column:
C
                     CALL DAXPY( KSIZE, -A(1,1), DWORK(K2), 1, DWORK,
     $                           1 )
C
C                    2nd column:
C
                     CALL DAXPY( KSIZE, -A(1,2), DWORK(K2), 1,
     $                           DWORK(K1), 1 )
                     CALL DAXPY( KSIZE, -A(2,2), DWORK(K3), 1,
     $                           DWORK(K1), 1 )
                  ELSE
C
C                    Form  v = S1*u + s*u11, overwriting  v  on DWORK.
C
C                    Compute  S1*u,  first multiplying by the triangular
C                    part of  S1.
C
                     CALL DTRMM( 'Left', 'Upper', 'No transpose',
     $                           'Non-unit', KSIZE, 2, ONE, S, LDS,
     $                           DWORK, KSIZE )
C
C                    Then multiply by the subdiagonal of  S1  and add in
C                    to the above result.
C
                     J1 = K1
C
                     DO 120 J = 2, KSIZE
                        J1 = J1 + 1
                        IF ( S(J,J-1).NE.ZERO ) THEN
                           DWORK(J)  = S(J,J-1)*DWORK(K2+J-2) + DWORK(J)
                           DWORK(J1) = S(J,J-1)*DWORK(K3+J-2) +
     $                                 DWORK(J1)
                        END IF
  120                CONTINUE
C
C                    Add in s*u11.
C
                     CALL DAXPY( KSIZE, R(K,K), S(1,K), 1, DWORK, 1 )
                     CALL DAXPY( KSIZE, R(K,K+1), S(1,K), 1, DWORK(K1),
     $                           1 )
                     CALL DAXPY( KSIZE, R(K+1,K+1), S(1,K+1), 1,
     $                           DWORK(K1), 1 )
C
C                    Next recover r from R, swapping r with u.
C
                     CALL DSWAP( KSIZE, DWORK(K2), 1, R(1,K), 1 )
                     CALL DSWAP( KSIZE, DWORK(K3), 1, R(1,K+1), 1 )
C
C                    Now we perform the QL factorization.
C
C                    ( a' ) = Q*( t ),
C                    ( b' )
C
C                    and form
C
C                    ( p' ) = Q'*( r' ).
C                    ( y' )      ( v' )
C
C                    y  is then the correct vector to use in the
C                    relation corresponding to (10.22).
C                    Note that  a  is upper triangular and that  t  and
C                    p  are not required.
C
                     CALL DLARFG( 3, A(2,2), B(2,1), 2, TAU1 )
                     V1  = B(2,1)
                     T1  = TAU1*V1
                     V2  = B(2,2)
                     T2  = TAU1*V2
                     SUM = A(1,2) + V1*B(1,1) + V2*B(1,2)
                     B(1,1) = B(1,1) - SUM*T1
                     B(1,2) = B(1,2) - SUM*T2
                     CALL DLARFG( 3, A(1,1), B(1,1), 2, TAU2 )
                     V3 = B(1,1)
                     T3 = TAU2*V3
                     V4 = B(1,2)
                     T4 = TAU2*V4
                     J1 = K1
                     J2 = K2
                     J3 = K3
C
                     DO 130 J = 1, KSIZE
                        SUM = DWORK(J3) + V1*DWORK(J) + V2*DWORK(J1)
                        D1  = DWORK(J)  - SUM*T1
                        D2  = DWORK(J1) - SUM*T2
                        SUM = DWORK(J2) + V3*D1 + V4*D2
                        DWORK(J)  =  D1 - SUM*T3
                        DWORK(J1) =  D2 - SUM*T4
                        J1 = J1 + 1
                        J2 = J2 + 1
                        J3 = J3 + 1
  130                CONTINUE
C
                  END IF
C
C                 Now update  R1  to give  Rhat.
C
                  CALL MB04ND( 'Full', KSIZE, 0, 2, R, LDR, DWORK,
     $                         KSIZE, DWORK, 1, DWORK, 1, DWORK(K2),
     $                         DWORK(K3) )
               END IF
            ELSE
C
C              1-by-1 block.
C
C              Make sure S is stable or convergent and find u11 in
C              equation corresponding to (5.13) or (10.15).
C
               IF ( DISCR ) THEN
                  ABSSKK = ABS( S(K,K) )
                  IF ( ( ABSSKK - ONE ).GE.ZERO ) THEN
                     INFO = 2
                     RETURN
                  END IF
                  TEMP = SQRT( ( ONE - ABSSKK )*( ONE + ABSSKK ) )
               ELSE
                  IF ( S(K,K).GE.ZERO ) THEN
                     INFO = 2
                     RETURN
                  END IF
                  TEMP = SQRT( ABS( TWO*S(K,K) ) )
               END IF
C
               SCALOC = ONE
               IF( TEMP.LT.SMIN ) THEN
                  TEMP  = SMIN
                  INFOM = 1
               END IF
               DR = ABS( R(K,K) )
               IF( TEMP.LT.ONE .AND. DR.GT.ONE ) THEN
                  IF( DR.GT.BIGNUM*TEMP )
     $               SCALOC = ONE / DR
               END IF
               ALPHA = SIGN( TEMP, R(K,K) )
               R(K,K) = R(K,K)/ALPHA
               IF( SCALOC.NE.ONE ) THEN
C
                  DO 140 J = 1, N
                     CALL DSCAL( J, SCALOC, R(1,J), 1 )
  140             CONTINUE
C
                  SCALE = SCALE*SCALOC
               END IF
C
C              If we are not at the front of  S  then set up and solve
C              equation corresponding to (5.14) or (10.16).  ksize is
C              the order of the remainder leading part of  S.  k1 and k2
C              point to the start of vectors in  DWORK.
C
               IF ( KOUNT.GE.1 ) THEN
                  KSIZE = K - 1
                  K1 = KSIZE + 1
                  K2 = KSIZE + K1
C
C                 Form the right-hand side in DWORK( 1 ),...,
C                 DWORK( k - 1 ).
C
                  CALL DCOPY( KSIZE, R(1,K), 1, DWORK, 1 )
                  CALL DSCAL( KSIZE, -ALPHA, DWORK, 1 )
                  IF ( CONT ) THEN
                     CALL DAXPY( KSIZE, -R(K,K), S(1,K), 1, DWORK, 1 )
                  ELSE
                     CALL DAXPY( KSIZE, -S(K,K)*R(K,K), S(1,K), 1,
     $                          DWORK, 1 )
                  END IF
C
C                 SB03OR solves the Sylvester equations. The solution is
C                 overwritten on  DWORK.
C
                  CALL SB03OR( DISCR, LTRANS, KSIZE, 1, S, LDS, S(K,K),
     $                         1, DWORK, KSIZE, SCALOC, INFO )
                  INFOM = MAX( INFO, INFOM )
                  IF( SCALOC.NE.ONE ) THEN
C
                     DO 150 J = 1, N
                        CALL DSCAL( J, SCALOC, R(1,J), 1 )
  150                CONTINUE
C
                     SCALE = SCALE*SCALOC
                  END IF
C
C                 Copy the solution into the next  ( k - 1 ) elements
C                 of  DWORK,  copy the solution back into  R  and copy
C                 the column of  R  back into  DWORK.
C
                  CALL DCOPY( KSIZE, DWORK, 1, DWORK(K1), 1 )
                  CALL DSWAP( KSIZE, DWORK, 1, R(1,K), 1 )
C
C                 Now form the matrix  Rhat  of equation corresponding
C                 to (5.15) or (10.17), first computing  y  in  DWORK,
C                 and then updating  R1.
C
                  IF ( CONT ) THEN
                     CALL DAXPY( KSIZE, -ALPHA, DWORK(K1), 1, DWORK, 1 )
                  ELSE
C
C                    First form  lambda( 1 )*r  and then add in
C                    alpha*u11*s.
C
                     CALL DSCAL( KSIZE, -S(K,K), DWORK, 1 )
                     CALL DAXPY( KSIZE, ALPHA*R(K,K), S(1,K), 1, DWORK,
     $                           1 )
C
C                    Now form  alpha*S1*u,  first multiplying by the
C                    sub-diagonal of  S1  and then the triangular part
C                    of  S1,  and add the result in DWORK.
C
                     DO 160 J = 2, KSIZE
                        IF ( S(J,J-1).NE.ZERO ) DWORK(J)
     $                         = ALPHA*S(J,J-1)*DWORK(K1+J-2) + DWORK(J)
  160                CONTINUE
C
                     CALL DTRMV( 'Upper', 'No transpose', 'Non-unit',
     $                           KSIZE, S, LDS, DWORK(K1), 1 )
                     CALL DAXPY( KSIZE, ALPHA, DWORK(K1), 1, DWORK, 1 )
                  END IF
                  CALL MB04ND( 'Full', KSIZE, 0, 1, R, LDR, DWORK,
     $                         KSIZE, DWORK, 1, DWORK, 1, DWORK(K2),
     $                         DWORK(K1) )
               END IF
            END IF
            GO TO 90
         END IF
C        END WHILE 90
C
      END IF
      INFO = INFOM
      RETURN
C *** Last line of SB03OT ***
      END


!234567890
      double precision function ei(x,err)
      implicit none
      double precision x,err
      double precision gamma
      parameter (gamma=0.57721566490153286060606512090082402431042d0)
      double precision eisum,xfact,xterm,xtermold
      integer ii

      if (abs(x).lt.gamma*err) then
        ei=gamma+log(abs(x))
      elseif (abs(x).lt.abs(log(err))) then
        eisum=0.d0
        xfact=1.d0
        ii=0
 100    continue
          ii=ii+1
          xfact=xfact*x/dble(ii)
          xterm=xfact/dble(ii)
          eisum=eisum+xterm
          if (abs(xterm).lt.eisum*err) goto 200
          if (abs(xterm).lt.gamma*err) goto 200
        goto 100
 200    continue
        ei=eisum+gamma+log(abs(x))
      else
        eisum=1.d0
        xterm=1.d0
        ii=0
 300    continue
          ii=ii+1
          xtermold=xterm
          xterm=xterm*ii/x
          if (xterm.lt.err) goto 400
          if (xterm.lt.xtermold) then
            eisum=eisum+xterm
          else
            eisum=eisum-xtermold
            goto 400
          endif
        goto 300
 400    continue
        ei=exp(x)*eisum/x
      endif

      return
      end


      subroutine ksales (a1,a2,a3,f1,f2,f3,alim,alpha)
      implicit double precision (a-h,o-z)
c
c          routine to estimate the next one-dimensional
c          step size alpha, based on the slopes of the
c          previous two trial points.
c
c          author   - Gregory A. Wrenn
c          location - Lockheed Engineering and Sciences Co.
c                     144 Research Drive
c                     Hampton, Va. 23666
c
c          last modification - 21 April 1989
c
      alpha = 0.0
      alpmin = 2.0 * a3 - a2
      alpmax = 3.0 * a3
c
      if (abs(a2 - a1) .lt. 1.0e-08) go to 10
      x1 = a2
      y1 = (f2 - f1) / (a2 - a1)
c
      if (abs(a3 - a2) .lt. 1.0e-08) go to 10
      x2 = a3
      y2 = (f3 - f2) / (a3 - a2)
c
      a = (y2 - y1) / (x2 - x1)
      b = y1 - a * x1
c
      if (abs(a) .ge. 1.0e-08) alpha = -b / a
   10 continue
      if (alpha .le. 0.0   ) alpha = alpmax
      if (alpha .lt. alpmin) alpha = alpmin
      if (alpha .gt. alpmax) alpha = alpmax
      if (alim .gt. 0.0 .and. alpha .ge. alim) alpha = 0.5 * (a3 + alim)
c
      return
      end


      double complex function qlcLi2omx3(z1,z2,z3,ieps1,ieps2,ieps3)
C     Calculate Li[2](1-(z1+ieps1)*(z2+ieps2)*(z3+ieps3))
C     Using +cLi2(1-z1*z2*z3)
C --- for |z1*z2*z3|<1
C     and   -cLi2(1-1/(z1*z2*z3))-1/2*(ln(z1)+ln(z2)+ln(z3))^2
C---- for |z1*z2*z3|>1
      implicit none
      include 'qlconstants.f'
      double precision ieps1,ieps2,ieps3,ieps
      double complex arg,lnarg,lnomarg,prod,denspence,z1,z2,z3,cln
      logical qlzero
      arg=z1*z2*z3
      if (qlzero(dimag(arg))) ieps=
     .sign(one,dreal(z2*z3)*ieps1+dreal(z1*z3)*ieps2+dreal(z1*z2)*ieps3)

      if (abs(arg) .le. 1d0) then
         if (arg .eq. 0d0 .or. arg .eq. 1d0) then
            prod=0d0
         else
            lnarg=cln(z1,ieps1)+cln(z2,ieps2)+cln(z3,ieps3)
            lnomarg=cln(cone-arg,0d0)
            prod = lnarg*lnomarg
         endif
         qlcLi2omx3=dcmplx(pisqo6)-denspence(dcmplx(arg),ieps)-prod
      elseif (abs(arg) .gt. 1d0) then
         arg=1d0/(z1*z2*z3)
         lnarg=-cln(z1,ieps1)-cln(z2,ieps2)-cln(z3,ieps3)
         lnomarg=cln(cone-arg,0d0)
         qlcLi2omx3=-dcmplx(pisqo6)+denspence(dcmplx(arg),ieps)
     .   +lnarg*lnomarg-0.5d0*lnarg**2
      endif
      return
      end


SUBROUTINE rod_km(km,ea,length)
!
! This subroutine forms the stiffness matrix of a 1-d "rod" element.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::ea,length
 REAL(iwp),INTENT(OUT)::km(:,:)
 REAL(iwp)::one=1.0_iwp
 km(1,1)=one
 km(2,2)=one
 km(1,2)=-one
 km(2,1)=-one
 km=km*ea/length
RETURN
END SUBROUTINE rod_km


!-------------------------------------------------------------------------------
! uses sequential neural network as a CNN on MNIST dataset, which contains many
! flattened 28x28x1 grayscale pictures of handwritten digits
!
! CSV version of datset downloaded from:
! https://www.kaggle.com/oddrationale/mnist-in-csv
!
! train dimensions:
!   60000 images (rows),
!   785 variables (column 1 = label, other 784 columns are the 28x28 pixels)
!
! test dimensions:
!   10000 images (rows),
!   785 variables (column 1 = label, other 784 columns are the 28x28 pixels)
!
! labels in range [0,9], representing which digit is depicted,
! pixels in range [0, 255], where 0 = black and 255 = white
!-------------------------------------------------------------------------------
! compile: make mnist
! run:     ./mnist
!-------------------------------------------------------------------------------

program main
    use net_helper_procedures
    use sequential_neural_net
    implicit none

    class(SeqNN), pointer     :: snn
    real(kind=8), allocatable :: image(:,:,:), train_images(:,:,:,:), &
                                 test_images(:,:,:,:), train(:,:), test(:,:), &
                                 train_x(:,:), train_y(:), &
                                 test_x(:,:), test_y(:), &
                                 train_y_onehot(:,:), test_y_onehot(:,:)
    integer                   :: train_rows, test_rows, variables, classes, &
                                 pixels, row, i
    real(kind=8)              :: accuracy

    train_rows = 60000
    test_rows = 10000
    variables = 785
    pixels = variables - 1
    classes = 10

    !===========================================================================
    !===========================================================================
    ! data processing
    !===========================================================================
    !===========================================================================

    !---------------------------------------------------------------------------
    ! read train data

    print *, '----------------------'
    print *, 'processing train data:'

    allocate(train(train_rows, variables))

    open(unit=1, form='formatted', file='mnist-in-csv/mnist_train.csv')
    read(unit=1, fmt=*) ! skip header line

    do row = 1, train_rows
        read(unit=1, fmt=*) train(row,:)
    end do

    close(unit=1)

    !---------------------------------------------------------------------------
    ! split train data, one hot encode labels

    ! separate train labels and pixels
    train_x = train(:,2:) / 255 ! scale pixels to [0,1]
    train_y = train(:,1)

    call one_hot_encode_special(train_y, classes, train_y_onehot)

    deallocate(train, train_y)

    !---------------------------------------------------------------------------
    ! reshape train examples from dimension 1x784 to 28x28x1

    allocate(train_images(28,28,1,train_rows))

    do i = 1, train_rows
        ! 28x28x1 array filled column-major order
        image = reshape(train_x(i,:), [28,28,1])

        ! transpose gives "expected" row-major order
        image(:,:,1) = transpose(image(:,:,1))

        train_images(:,:,:,i) = image
    end do

    deallocate(train_x)

    print *, 'done'
    print *, '----------------------'

    !---------------------------------------------------------------------------
    ! read test data

    print *, '----------------------'
    print *, 'processing test data:'

    allocate(test(test_rows, variables))

    open(unit=2, form='formatted', file='mnist-in-csv/mnist_test.csv')
    read(unit=2, fmt=*) ! skip header line

    do row = 1, test_rows
        read(unit=2, fmt=*) test(row,:)
    end do

    close(unit=2)

    !---------------------------------------------------------------------------
    ! split test data, one hot encode labels

    ! separate test labels and pixels
    test_x = test(:,2:) / 255 ! scale to [0,1]
    test_y = test(:,1)

    call one_hot_encode_special(test_y, classes, test_y_onehot)

    deallocate(test, test_y)

    !---------------------------------------------------------------------------
    ! reshape test examples from dimension 1x784 to 28x28x1

    allocate(test_images(28,28,1,test_rows))

    do i = 1, test_rows
        ! 28x28x1 array filled column-major order
        image = reshape(test_x(i,:), [28,28,1])

        ! transpose gives "expected" row-major order
        image(:,:,1) = transpose(image(:,:,1))

        test_images(:,:,:,i) = image
    end do

    deallocate(test_x, image)

    print *, 'done'
    print *, '----------------------'

    !===========================================================================
    !===========================================================================
    ! network usage
    !===========================================================================
    !===========================================================================

    !---------------------------------------------------------------------------
    ! create network

    snn => create_snn()

    call snn%snn_add_conv_layer(input_dims  = [28,28,1],&
                                kernels     = 32, &
                                kernel_dims = [3,3], &
                                stride      = [1,1], &
                                activ       = 'relu', &
                                padding     = 'valid')

    call snn%snn_add_conv_layer(kernels     = 64, &
                                kernel_dims = [3,3], &
                                stride      = [1,1], &
                                activ       = 'relu', &
                                padding     = 'valid')

    call snn%snn_add_pool_layer(kernel_dims = [2,2], &
                                stride      = [2,2], &
                                pool        = 'max', &
                                padding     = 'valid')

    call snn%snn_add_dropout_layer(drop_rate = 0.1)
    call snn%snn_add_dense_layer(out_nodes   = 128, &
                                 activ       = 'relu')

    call snn%snn_add_dropout_layer(drop_rate = 0.1)
    call snn%snn_add_dense_layer(out_nodes   = classes, &
                                 activ       = 'softmax')

    call snn%snn_summary()

    !---------------------------------------------------------------------------
    ! train network

    call snn%snn_fit(conv_input    = train_images, &
                     target_labels = train_y_onehot, &
                     batch_size    = 128, &
                     epochs        = 5, &
                     learn_rate    = 0.1, &
                     loss          = 'cross_entropy', &
                     verbose       = 2, &
                     avg_deltas    = .true.)

    !---------------------------------------------------------------------------
    ! check network accuracy on test data

    accuracy = snn%snn_one_hot_accuracy(conv_input    = test_images, &
                                        target_labels = test_y_onehot, &
                                        verbose       = 2)
    print *, '----------------------'
    print *, 'testing accuracy:', accuracy
    print *, '----------------------'

    !---------------------------------------------------------------------------
    ! store first conv layer kernels and biases to file to visualize;
    ! biases are repeated to fill array, so we only select one

    ! overwrite file (if it exists), start first row
    call write_array_2D(snn%cnn%first_hid%k(:,:,1,1), &
                            'output-data/first_layer_weights.csv', .false.)
    call write_array_2D(snn%cnn%first_hid%b(1:1,1:1,1), &
                            'output-data/first_layer_biases.csv', .false.)

    do i = 2, 32
        ! append remaining rows
        call write_array_2D(snn%cnn%first_hid%k(:,:,1,i), &
                            'output-data/first_layer_weights.csv', .true.)
        call write_array_2D(snn%cnn%first_hid%b(1:1,1:1,i), &
                            'output-data/first_layer_biases.csv', .true.)
    end do

    !---------------------------------------------------------------------------

    deallocate(train_images, train_y_onehot, test_images, test_y_onehot)
    call deallocate_snn(snn)
end program


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Spherepack                            *
!     *                                                               *
!     *       A Package of Fortran Subroutines and Programs           *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
submodule(scalar_analysis_routines) scalar_analysis_gaussian_grid

contains

    ! Purpose:
    !
    ! Performs the spherical harmonic analysis on
    ! a gaussian grid on the array(s) in g and returns the coefficients
    ! in array(s) a, b. the necessary legendre polynomials are computed
    ! as needed in this version.
    !
    !     subroutine shagc(nlat, nlon, isym, nt, g, idg, jdg, a, b, mdab, ndab, &
    !                      wshagc, ierror)
    !
    !     subroutine shagc performs the spherical harmonic analysis
    !     on the array g and stores the result in the arrays a and b.
    !     the analysis is performed on a gaussian grid in colatitude
    !     and an equally spaced grid in longitude.  the associated
    !     legendre functions are recomputed rather than stored as they
    !     are in subroutine shags.  the analysis is described below
    !     at output parameters a, b.
    !
    !     input parameters
    !
    !     nlat   the number of points in the gaussian colatitude grid on the
    !            full sphere. these lie in the interval (0, pi) and are compu
    !            in radians in theta(1), ..., theta(nlat) by subroutine compute_gaussian_latitudes_and_weights.
    !            if nlat is odd the equator will be included as the grid poi
    !            theta((nlat + 1)/2).  if nlat is even the equator will be
    !            excluded as a grid point and will lie half way between
    !            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
    !            note: on the half sphere, the number of grid points in the
    !            colatitudinal direction is nlat/2 if nlat is even or
    !            (nlat + 1)/2 if nlat is odd.
    !
    !     nlon   the number of distinct londitude points.  nlon determines
    !            the grid increment in longitude as 2*pi/nlon. for example
    !            nlon = 72 for a five degree grid. nlon must be greater
    !            than or equal to 4. the efficiency of the computation is
    !            improved when nlon is a product of small prime numbers.
    !
    !     isym   = 0  no symmetries exist about the equator. the analysis
    !                 is performed on the entire sphere.  i.e. on the
    !                 array g(i, j) for i=1, ..., nlat and j=1, ..., nlon.
    !                 (see description of g below)
    !
    !            = 1  g is antisymmetric about the equator. the analysis
    !                 is performed on the northern hemisphere only.  i.e.
    !                 if nlat is odd the analysis is performed on the
    !                 array g(i, j) for i=1, ..., (nlat + 1)/2 and j=1, ..., nlon.
    !                 if nlat is even the analysis is performed on the
    !                 array g(i, j) for i=1, ..., nlat/2 and j=1, ..., nlon.
    !
    !
    !            = 2  g is symmetric about the equator. the analysis is
    !                 performed on the northern hemisphere only.  i.e.
    !                 if nlat is odd the analysis is performed on the
    !                 array g(i, j) for i=1, ..., (nlat + 1)/2 and j=1, ..., nlon.
    !                 if nlat is even the analysis is performed on the
    !                 array g(i, j) for i=1, ..., nlat/2 and j=1, ..., nlon.
    !
    !     nt     the number of analyses.  in the program that calls shagc,
    !            the arrays g, a and b can be three dimensional in which
    !            case multiple analyses will be performed.  the third
    !            index is the analysis index which assumes the values
    !            k=1, ..., nt.  for a single analysis set nt=1. the
    !            discription of the remaining parameters is simplified
    !            by assuming that nt=1 or that the arrays g, a and b
    !            have only two dimensions.
    !
    !     g      a two or three dimensional array (see input parameter
    !            nt) that contains the discrete function to be analyzed.
    !            g(i, j) contains the value of the function at the gaussian
    !            point theta(i) and longitude point phi(j) = (j-1)*2*pi/nlon
    !            the index ranges are defined above at the input parameter
    !            isym.
    !
    !     idg    the first dimension of the array g as it appears in the
    !            program that calls shagc. if isym equals zero then idg
    !            must be at least nlat.  if isym is nonzero then idg must
    !            be at least nlat/2 if nlat is even or at least (nlat + 1)/2
    !            if nlat is odd.
    !
    !     jdg    the second dimension of the array g as it appears in the
    !            program that calls shagc. jdg must be at least nlon.
    !
    !     mdab   the first dimension of the arrays a and b as it appears
    !            in the program that calls shagc. mdab must be at least
    !            min((nlon+2)/2, nlat) if nlon is even or at least
    !            min((nlon + 1)/2, nlat) if nlon is odd
    !
    !     ndab   the second dimension of the arrays a and b as it appears
    !            in the program that calls shaec. ndab must be at least nlat
    !
    !     wshagc an array which must be initialized by subroutine shagci.
    !            once initialized, wshagc can be used repeatedly by shagc.
    !            as long as nlat and nlon remain unchanged.  wshagc must
    !            not be altered between calls of shagc.
    !
    !     lshagc the dimension of the array wshagc as it appears in the
    !            program that calls shagc. define
    !
    !               l1 = min(nlat, (nlon+2)/2) if nlon is even or
    !               l1 = min(nlat, (nlon + 1)/2) if nlon is odd
    !
    !            and
    !
    !               l2 = nlat/2        if nlat is even or
    !               l2 = (nlat + 1)/2    if nlat is odd
    !
    !            then lshagc must be at least
    !
    !                  nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15
    !
    !     output parameters
    !
    !     a, b    both a, b are two or three dimensional arrays (see input
    !            parameter nt) that contain the spherical harmonic
    !            coefficients in the representation of g(i, j) given in the
    !            discription of subroutine shagc. for isym=0, a(m, n) and
    !            b(m, n) are given by the equations listed below. symmetric
    !            versions are used when isym is greater than zero.
    !
    !     definitions
    !
    !     1. the normalized associated legendre functions
    !
    !     pbar(m, n, theta) = sqrt((2*n+1)*factorial(n-m)/(2*factorial(n+m)))
    !                       *sin(theta)**m/(2**n*factorial(n)) times the
    !                       (n+m)th derivative of (x**2-1)**n with respect
    !                       to x=cos(theta).
    !
    !     2. the fourier transform of g(i, j).
    !
    !     c(m, i)          = 2/nlon times the sum from j=1 to j=nlon of
    !                       g(i, j)*cos((m-1)*(j-1)*2*pi/nlon)
    !                       (the first and last terms in this sum
    !                       are divided by 2)
    !
    !     s(m, i)          = 2/nlon times the sum from j=2 to j=nlon of
    !                       g(i, j)*sin((m-1)*(j-1)*2*pi/nlon)
    !
    !
    !     3. the gaussian points and weights on the sphere
    !        (computed by subroutine compute_gaussian_latitudes_and_weights).
    !
    !        theta(1), ..., theta(nlat) (gaussian pts in radians)
    !        wts(1), ..., wts(nlat) (corresponding gaussian weights)
    !
    !     4. the maximum (plus one) longitudinal wave number
    !
    !            mmax = min(nlat, (nlon+2)/2) if nlon is even or
    !            mmax = min(nlat, (nlon + 1)/2) if nlon is odd.
    !
    !
    !     then for m=0, ..., mmax-1 and n=m, ..., nlat-1 the arrays a, b
    !     are given by
    !
    !     a(m+1, n+1)     =  the sum from i=1 to i=nlat of
    !                       c(m+1, i)*wts(i)*pbar(m, n, theta(i))
    !
    !     b(m+1, n+1)      = the sum from i=1 to nlat of
    !                       s(m+1, i)*wts(i)*pbar(m, n, theta(i))
    !
    !     ierror = 0  no errors
    !            = 1  error in the specification of nlat
    !            = 2  error in the specification of nlon
    !            = 3  error in the specification of isym
    !            = 4  error in the specification of nt
    !            = 5  error in the specification of idg
    !            = 6  error in the specification of jdg
    !            = 7  error in the specification of mdab
    !            = 8  error in the specification of ndab
    !            = 9  error in the specification of lshagc
    !
    module subroutine shagc(nlat, nlon, isym, nt, g, idg, jdg, a, b, mdab, ndab, &
        wshagc, ierror)

        ! Dummy arguments
        integer(ip), intent(in)   :: nlat
        integer(ip), intent(in)   :: nlon
        integer(ip), intent(in)   :: isym
        integer(ip), intent(in)   :: nt
        real(wp),    intent(in)   :: g(idg, jdg, nt)
        integer(ip), intent(in)   :: idg
        integer(ip), intent(in)   :: jdg
        real(wp),    intent(out)  :: a(mdab, ndab, nt)
        real(wp),    intent(out)  :: b(mdab, ndab, nt)
        integer(ip), intent(in)   :: mdab
        integer(ip), intent(in)   :: ndab
        real(wp),    intent(in)   :: wshagc(:)
        integer(ip), intent(out)  :: ierror

        ! Local variables
        integer(ip) :: ntrunc, lat, late
        integer(ip) :: required_wavetable_size
        type(SpherepackUtility) :: util

        ! Check input arguments
        required_wavetable_size = util%get_lshagc(nlat, nlon)

        call util%check_scalar_transform_inputs(isym, idg, jdg, &
            mdab, ndab, nlat, nlon, nt, required_wavetable_size, &
            wshagc, ierror)

        ! Check error flag
        if (ierror /= 0) return

        ! Set upper limit on m for spherical harmonic basis
        ntrunc = min((nlon + 2)/2, nlat)

        ! Set gaussian point nearest equator pointer
        late = (nlat + mod(nlat, 2))/2

        ! Set number of grid points for analysis/synthesis
        select case (isym)
            case (0)
                lat = nlat
            case default
                lat = late
        end select

        block
            integer(ip) :: iwts, ifft
            real(wp)    :: pmn(nlat, late, 3), g_work(lat, nlon, nt)

            ! Starting address for gaussian wts in shigc and fft values
            iwts = 1
            ifft = nlat+2*nlat*late+3*(ntrunc*(ntrunc-1)/2+(nlat-ntrunc)*(ntrunc-1))+1

            call shagc_lower_utility_routine(nlat, nlon, ntrunc, lat, isym, &
                g, idg, jdg, nt, a, b, mdab, ndab, wshagc, wshagc(iwts:), &
                wshagc(ifft:), late, pmn, g_work)
        end block

    end subroutine shagc

    ! Purpose:
    !
    ! This subroutine must be called before calling shagc with
    ! fixed nlat, nlon. it precomputes quantites such as the gaussian
    ! points and weights, m=0, m=1 legendre polynomials, recursion
    ! recursion coefficients.
    !
    !
    !     subroutine shagci(nlat, nlon, wshagc, lshagc, dwork, ldwork, ierror)
    !
    !     subroutine shagci initializes the array wshagc which can then
    !     be used repeatedly by subroutines shagc. it precomputes
    !     and stores in wshagc quantities such as gaussian weights,
    !     legendre polynomial coefficients, and fft trigonometric tables.
    !
    !     input parameters
    !
    !     nlat   the number of points in the gaussian colatitude grid on the
    !            full sphere. these lie in the interval (0, pi) and are compu
    !            in radians in theta(1), ..., theta(nlat) by subroutine compute_gaussian_latitudes_and_weights.
    !            if nlat is odd the equator will be included as the grid poi
    !            theta((nlat + 1)/2).  if nlat is even the equator will be
    !            excluded as a grid point and will lie half way between
    !            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
    !            note: on the half sphere, the number of grid points in the
    !            colatitudinal direction is nlat/2 if nlat is even or
    !            (nlat + 1)/2 if nlat is odd.
    !
    !     nlon   the number of distinct londitude points.  nlon determines
    !            the grid increment in longitude as 2*pi/nlon. for example
    !            nlon = 72 for a five degree grid. nlon must be greater
    !            than or equal to 4. the efficiency of the computation is
    !            improved when nlon is a product of small prime numbers.
    !
    !     wshagc an array which must be initialized by subroutine shagci.
    !            once initialized, wshagc can be used repeatedly by shagc
    !            as long as nlat and nlon remain unchanged.  wshagc must
    !            not be altered between calls of shagc.
    !
    !     lshagc the dimension of the array wshagc as it appears in the
    !            program that calls shagc. define
    !
    !               l1 = min(nlat, (nlon+2)/2) if nlon is even or
    !               l1 = min(nlat, (nlon + 1)/2) if nlon is odd
    !
    !            and
    !
    !               l2 = nlat/2        if nlat is even or
    !               l2 = (nlat + 1)/2    if nlat is odd
    !
    !            then lshagc must be at least
    !
    !                  nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15
    !
    !     output parameter
    !
    !     wshagc an array which must be initialized before calling shagc or
    !            once initialized, wshagc can be used repeatedly by shagc or
    !            as long as nlat and nlon remain unchanged.  wshagc must not
    !            altered between calls of shagc.
    !
    !     ierror = 0  no errors
    !            = 1  error in the specification of nlat
    !            = 2  error in the specification of nlon
    !            = 3  error in the specification of lshagc
    !            = 5  failure in compute_gaussian_latitudes_and_weights to compute gaussian points
    !                 (due to failure in eigenvalue routine)
    !
    module subroutine shagci(nlat, nlon, wshagc, ierror)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        real(wp),    intent(out) :: wshagc(:)
        integer(ip), intent(out) :: ierror

        ! Local variables
        integer(ip) :: ntrunc, n1, n2
        integer(ip) :: late, ldwork

        associate (lshagc => size(wshagc))

            ! set triangular truncation limit for spherical harmonic basis
            ntrunc = min((nlon+2)/2, nlat)

            ! set equator or nearest point (if excluded) pointer
            late = (nlat+mod(nlat, 2))/2
            n1 = ntrunc
            n2 = late

            ! Check calling arguments
            if (nlat < 3) then
                ierror = 1
            else if (nlon < 4) then
                ierror = 2
            else if (lshagc < nlat*(2*n2+3*n1-2)+3*n1*(1-n1)/2+nlon+15) then
                ierror = 3
            else
                ierror = 0
            end if

            ! Check error flag
            if (ierror /= 0) return

            ! Set required workspace size
            ldwork = nlat * (nlat + 4)

            block
                integer(ip) :: i1, i2, i3, i4, i5, i6, i7
                integer(ip) :: idth, idwts, iw
                real(wp)    :: dwork(ldwork)

                ! Set pointers
                i1 = 1
                i2 = i1+nlat
                i3 = i2+nlat*late
                i4 = i3+nlat*late
                i5 = i4+ntrunc*(ntrunc-1)/2 +(nlat-ntrunc)*(ntrunc-1)
                i6 = i5+ntrunc*(ntrunc-1)/2 +(nlat-ntrunc)*(ntrunc-1)
                i7 = i6+ntrunc*(ntrunc-1)/2 +(nlat-ntrunc)*(ntrunc-1)

                ! Set indices in temp work for real gaussian wts and pts
                idth = 1
                idwts = idth + nlat
                iw = idwts + nlat

                call shagci_lower_utility_routine(nlat, nlon, ntrunc, late, &
                    wshagc(i1:), wshagc(i2:), wshagc(i3:), &
                    wshagc(i4:), wshagc(i5:), wshagc(i6:), wshagc(i7:), dwork(idth:), &
                    dwork(idwts:), dwork(iw:), ierror)
            end block

            ! Address error flag from lower routine
            if (ierror /= 0) ierror = 5

        end associate

    end subroutine shagci

    subroutine shagc_lower_utility_routine(nlat, nlon, l, lat, mode, gs, idg, jdg, nt, a, b, mdab, &
        ndab, w, wts, wfft, late, pmn, g)

        real(wp) :: a
        real(wp) :: b
        real(wp) :: g
        real(wp) :: gs
        integer(ip) :: i
        integer(ip) :: idg
        integer(ip) :: is
        integer(ip) :: j
        integer(ip) :: jdg
        integer(ip) :: k
        integer(ip) :: km
        integer(ip) :: l
        integer(ip) :: lat
        integer(ip) :: late
        integer(ip) :: lm1
        integer(ip) :: lp1
        integer(ip) :: m
        integer(ip) :: mdab
        integer(ip) :: mode
        integer(ip) :: mp1
        integer(ip) :: mp2
        integer(ip) :: ms
        integer(ip) :: ndab
        integer(ip) :: nl2
        integer(ip) :: nlat
        integer(ip) :: nlon
        integer(ip) :: np1
        integer(ip) :: ns
        integer(ip) :: nt
        real(wp) :: pmn
        real(wp) :: sfn
        real(wp) :: t1
        real(wp) :: t2
        real(wp) :: w
        real(wp) :: wfft
        real(wp) :: wts
        dimension gs(idg, jdg, nt), a(mdab, ndab, nt), &
            b(mdab, ndab, nt), g(lat, nlon, nt)
        dimension w(*), wts(nlat), wfft(*), pmn(nlat, late, 3)

        type(SpherepackUtility) :: util

        !     set gs array internally in shagc_lower_utility_routine
        do k=1, nt
            do j=1, nlon
                do i=1, lat
                    g(i, j, k) = gs(i, j, k)
                end do
            end do
        end do
        !     do fourier transform
        do k=1, nt
            call util%hfft%forward(lat, nlon, g(1, 1, k), lat, wfft)
        end do
        !     scale result
        sfn = 2.0/real(nlon)
        do k=1, nt
            do j=1, nlon
                do i=1, lat
                    g(i, j, k) = sfn*g(i, j, k)
                end do
            end do
        end do
        !     compute using gaussian quadrature
        !     a(n, m) = s (ga(theta, m)*pnm(theta)*sin(theta)*dtheta)
        !     b(n, m) = s (gb(theta, m)*pnm(theta)*sin(theta)*dtheta)
        !     here ga, gb are the cos(phi), sin(phi) coefficients of
        !     the fourier expansion of g(theta, phi) in phi.  as a result
        !     of the above fourier transform they are stored in array
        !     g as follows:
        !     for each theta(i) and k= l-1
        !     ga(0), ga(1), gb(1), ga(2), gb(2), ..., ga(k-1), gb(k-1), ga(k)
        !     correspond to (in the case nlon=l+l-2)
        !     g(i, 1), g(i, 2), g(i, 3), g(i, 4), g(i, 5), ..., g(i, 2l-4), g(i, 2l-3), g(i, 2l-
        !     initialize coefficients to zero
        do k=1, nt
            do np1=1, nlat
                do mp1=1, l
                    a(mp1, np1, k) = ZERO
                    b(mp1, np1, k) = ZERO
                end do
            end do
        end do

        ! Set m+1 limit on b(m+1) calculation
        if (nlon == 2*l-2) then
            lm1 = l-1
        else
            lm1 = l
        end if

        select case (mode)
            case (0)
                ! For full sphere (mode=0) and even/odd reduction:
                ! overwrite g(i) with (g(i)+g(nlat-i+1))*wts(i)
                ! overwrite g(nlat-i+1) with (g(i)-g(nlat-i+1))*wts(i)
                nl2 = nlat/2
                do k=1, nt
                    do j=1, nlon
                        do i=1, nl2
                            is = nlat-i+1
                            t1 = g(i, j, k)
                            t2 = g(is, j, k)
                            g(i, j, k) = wts(i)*(t1+t2)
                            g(is, j, k) = wts(i)*(t1-t2)
                        end do
                        !  Adjust equator if necessary(nlat odd)
                        if (mod(nlat, 2)/=0) g(late, j, k) = wts(late)*g(late, j, k)
                    end do
                end do
                !     set m = 0 coefficients first
                m = 0
                call util%compute_legendre_polys_for_gaussian_grids(mode, l, nlat, m, w, pmn, km)
                do k=1, nt
                    do i=1, late
                        is = nlat-i+1
                        do np1=1, nlat, 2
                            !     n even
                            a(1, np1, k) = a(1, np1, k)+g(i, 1, k)*pmn(np1, i, km)
                        end do
                        do np1=2, nlat, 2
                            !     n odd
                            a(1, np1, k) = a(1, np1, k)+g(is, 1, k)*pmn(np1, i, km)
                        end do
                    end do
                end do
                !     compute coefficients for which b(m, n) is available
                do mp1=2, lm1
                    m = mp1-1
                    mp2 = m+2
                    !     compute pmn for all i and n=m, ..., l-1
                    call util%compute_legendre_polys_for_gaussian_grids(mode, l, nlat, m, w, pmn, km)
                    do k=1, nt
                        do i=1, late
                            is = nlat-i+1
                            !     n-m even
                            do np1=mp1, nlat, 2
                                a(mp1, np1, k) = a(mp1, np1, k)+g(i, 2*m, k)*pmn(np1, i, km)
                                b(mp1, np1, k) = b(mp1, np1, k)+g(i, 2*m+1, k)*pmn(np1, i, km)
                            end do
                            !     n-m odd
                            do np1=mp2, nlat, 2
                                a(mp1, np1, k) = a(mp1, np1, k)+g(is, 2*m, k)*pmn(np1, i, km)
                                b(mp1, np1, k) = b(mp1, np1, k)+g(is, 2*m+1, k)*pmn(np1, i, km)
                            end do
                        end do
                    end do
                end do
                if (nlon == 2*l-2) then
                    ! Compute a(l, np1) coefficients only
                    m = l-1
                    call util%compute_legendre_polys_for_gaussian_grids(mode, l, nlat, m, w, pmn, km)
                    do k=1, nt
                        do i=1, late
                            is = nlat-i+1
                            !     n-m even
                            do np1=l, nlat, 2
                                a(l, np1, k) = a(l, np1, k) + HALF * g(i, nlon, k)*pmn(np1, i, km)
                            end do
                            lp1 = l+1
                            !     n-m odd
                            do np1=lp1, nlat, 2
                                a(l, np1, k) = a(l, np1, k) + HALF * g(is, nlon, k)*pmn(np1, i, km)
                            end do
                        end do
                    end do
                end if
            case default
                !     half sphere
                !     overwrite g(i) with wts(i)*(g(i)+g(i)) for i=1, ..., nlate/2
                nl2 = nlat/2
                do  k=1, nt
                    do j=1, nlon
                        do i=1, nl2
                            g(i, j, k) = wts(i)*(g(i, j, k)+g(i, j, k))
                        end do
                        !     adjust equator separately if a grid point
                        if (nl2<late) g(late, j, k) = wts(late)*g(late, j, k)
                    end do
                end do
                !     set m = 0 coefficients first
                m = 0
                call util%compute_legendre_polys_for_gaussian_grids(mode, l, nlat, m, w, pmn, km)
                ms = 1
                if (mode == 1) ms = 2
                do k=1, nt
                    do i=1, late
                        do np1=ms, nlat, 2
                            a(1, np1, k) = a(1, np1, k)+g(i, 1, k)*pmn(np1, i, km)
                        end do
                    end do
                end do
                !     compute coefficients for which b(m, n) is available
                do mp1=2, lm1
                    m = mp1-1
                    ms = mp1
                    if (mode == 1) ms = mp1+1
                    !     compute pmn for all i and n=m, ..., nlat-1
                    call util%compute_legendre_polys_for_gaussian_grids(mode, l, nlat, m, w, pmn, km)
                    do  k=1, nt
                        do  i=1, late
                            do np1=ms, nlat, 2
                                a(mp1, np1, k) = a(mp1, np1, k)+g(i, 2*m, k)*pmn(np1, i, km)
                                b(mp1, np1, k) = b(mp1, np1, k)+g(i, 2*m+1, k)*pmn(np1, i, km)
                            end do
                        end do
                    end do
                end do
                if (nlon == 2*l-2) then
                    ! Compute coefficient a(l, np1) only
                    m = l-1
                    call util%compute_legendre_polys_for_gaussian_grids(mode, l, nlat, m, w, pmn, km)

                    select case (mode)
                        case (1)
                            ns = l+1
                        case default
                            ns = l
                    end select

                    do k=1, nt
                        do i=1, late
                            do np1 = ns, nlat, 2
                                a(l, np1, k) = a(l, np1, k) + HALF * g(i, nlon, k) * pmn(np1, i, km)
                            end do
                        end do
                    end do
                end if
        end select

    end subroutine shagc_lower_utility_routine

    subroutine shagci_lower_utility_routine(nlat, nlon, l, late, wts, p0n, p1n, abel, bbel, cbel, &
        wfft, dtheta, dwts, work, ier)

        ! Dummy arguments
        real(wp) :: abel
        real(wp) :: bbel
        real(wp) :: cbel
        integer(ip) :: i
        integer(ip) :: ier
        integer(ip) :: imn
        integer(ip) :: l
        integer(ip) :: late
        integer(ip) :: m
        integer(ip) :: mlim
        integer(ip) :: n
        integer(ip) :: nlat
        integer(ip) :: nlon
        integer(ip) :: np1
        real(wp) :: p0n
        real(wp) :: p1n
        real(wp) :: wfft
        real(wp) :: wts
        dimension wts(nlat), p0n(nlat, late), p1n(nlat, late), abel(*), bbel(*), &
            cbel(*), wfft(*)
        real(wp) :: pb, dtheta(nlat), dwts(nlat), work(*)

        ! Local variables
        type(SpherepackUtility) :: util

        !     compute the nlat  gaussian points and weights, the
        !     m=0, 1 legendre polys for gaussian points and all n,
        !     and the legendre recursion coefficients
        !     define index function used in storing
        !     arrays for recursion coefficients (functions of (m, n))
        !     the index function indx(m, n) is defined so that
        !     the pairs (m, n) map to [1, 2, ..., indx(l-1, l-1)] with no
        !     "holes" as m varies from 2 to n and n varies from 2 to l-1.
        !     (m=0, 1 are set from p0n, p1n for all n)
        !
        ! Define for 2<=n<=l-1
        !indx(m, n) = imn = (n-1)*(n-2)/2+m-1
        !
        ! Define index function for l<=n<=nlat
        !imndx(m, n) = l*(l-1)/2+(n-l-1)*(l-1)+m-1

        ! Preset quantites for fourier transform
        call util%hfft%initialize(nlon, wfft)

        call compute_gaussian_latitudes_and_weights(nlat, dtheta, dwts, ier)

        ! Check error flag
        if (ier /= 0) return

        ! Store gaussian weights single precision to save computation
        ! in inner loops in analysis
        wts(1:nlat) = dwts(1:nlat)

        ! Initialize p0n, p1n using real dnlfk, dnlft
        p0n(1:nlat, 1:late) = ZERO
        p1n(1:nlat, 1:late) = ZERO

        ! Compute m=n=0 legendre polynomials for all theta(i)
        np1 = 1
        n = 0
        m = 0
        call util%compute_fourier_coefficients(m, n, work)
        do i=1, late
            call util%compute_legendre_polys_from_fourier_coeff(m, n, dtheta(i), work, pb)
            p0n(1, i) = pb
        end do

        ! Compute p0n, p1n for all theta(i) when n>0
        do np1=2, nlat
            n = np1-1
            m = 0
            call util%compute_fourier_coefficients(m, n, work)
            do i=1, late
                call util%compute_legendre_polys_from_fourier_coeff(m, n, dtheta(i), work, pb)
                p0n(np1, i) = pb
            end do
            ! Compute m=1 legendre polynomials for all n and theta(i)
            m = 1
            call util%compute_fourier_coefficients(m, n, work)
            do i=1, late
                call util%compute_legendre_polys_from_fourier_coeff(m, n, dtheta(i), work, pb)
                p1n(np1, i) = pb
            end do
        end do

        ! Compute and store swarztrauber recursion coefficients
        ! for 2 <= m <= n and 2 <= n <= nlat in abel, bbel, cbel
        do n=2, nlat
            mlim = min(n, l)
            do m=2, mlim
                if (l <= n) then
                    imn = l*(l-1)/2+(n-l-1)*(l-1)+m-1
                else
                    imn = (n-1)*(n-2)/2+m-1
                end if
                abel(imn)=sqrt(real((2*n+1)*(m+n-2)*(m+n-3))/ &
                    real(((2*n-3)*(m+n-1)*(m+n))))
                bbel(imn)=sqrt(real((2*n+1)*(n-m-1)*(n-m))/ &
                    real(((2*n-3)*(m+n-1)*(m+n))))
                cbel(imn)=sqrt(real((n-m+1)*(n-m+2))/ &
                    real(((n+m-1)*(n+m))))
            end do
        end do

    end subroutine shagci_lower_utility_routine

end submodule scalar_analysis_gaussian_grid