*> \brief \b SSYTRS_AA_2STAGE
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SSYTRS_AA_2STAGE + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*      SUBROUTINE SSYTRS_AA_2STAGE( UPLO, N, NRHS, A, LDA, TB, LTB, IPIV,
*                                   IPIV2, B, LDB, INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          UPLO
*       INTEGER            N, NRHS, LDA, LTB, LDB, INFO
*       ..
*       .. Array Arguments ..
*       INTEGER            IPIV( * ), IPIV2( * )
*       REAL               A( LDA, * ), TB( * ), B( LDB, * )
*       ..
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SSYTRS_AA_2STAGE solves a system of linear equations A*X = B with a real
*> symmetric matrix A using the factorization A = U*T*U**T or
*> A = L*T*L**T computed by SSYTRF_AA_2STAGE.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] UPLO
*> \verbatim
*>          UPLO is CHARACTER*1
*>          Specifies whether the details of the factorization are stored
*>          as an upper or lower triangular matrix.
*>          = 'U':  Upper triangular, form is A = U*T*U**T;
*>          = 'L':  Lower triangular, form is A = L*T*L**T.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*>          NRHS is INTEGER
*>          The number of right hand sides, i.e., the number of columns
*>          of the matrix B.  NRHS >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*>          A is REAL array, dimension (LDA,N)
*>          Details of factors computed by SSYTRF_AA_2STAGE.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] TB
*> \verbatim
*>          TB is REAL array, dimension (LTB)
*>          Details of factors computed by SSYTRF_AA_2STAGE.
*> \endverbatim
*>
*> \param[in] LTB
*> \verbatim
*>          The size of the array TB. LTB >= 4*N.
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*>          IPIV is INTEGER array, dimension (N)
*>          Details of the interchanges as computed by
*>          SSYTRF_AA_2STAGE.
*> \endverbatim
*>
*> \param[in] IPIV2
*> \verbatim
*>          IPIV2 is INTEGER array, dimension (N)
*>          Details of the interchanges as computed by
*>          SSYTRF_AA_2STAGE.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*>          B is REAL array, dimension (LDB,NRHS)
*>          On entry, the right hand side matrix B.
*>          On exit, the solution matrix X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of the array B.  LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2017
*
*> \ingroup realSYcomputational
*
*  =====================================================================
      SUBROUTINE SSYTRS_AA_2STAGE( UPLO, N, NRHS, A, LDA, TB, LTB,
     $                             IPIV, IPIV2, B, LDB, INFO )
*
*  -- LAPACK computational routine (version 3.8.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2017
*
      IMPLICIT NONE
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            N, NRHS, LDA, LTB, LDB, INFO
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * ), IPIV2( * )
      REAL               A( LDA, * ), TB( * ), B( LDB, * )
*     ..
*
*  =====================================================================
*
      REAL               ONE
      PARAMETER          ( ONE = 1.0E+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            LDTB, NB
      LOGICAL            UPPER
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           SGBTRS, SLASWP, STRSM, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LTB.LT.( 4*N ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -11
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SSYTRS_AA_2STAGE', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 .OR. NRHS.EQ.0 )
     $   RETURN
*
*     Read NB and compute LDTB
*
      NB = INT( TB( 1 ) )
      LDTB = LTB/N
*
      IF( UPPER ) THEN
*
*        Solve A*X = B, where A = U*T*U**T.
*
         IF( N.GT.NB ) THEN
*
*           Pivot, P**T * B
*
            CALL SLASWP( NRHS, B, LDB, NB+1, N, IPIV, 1 )
*
*           Compute (U**T \P**T * B) -> B    [ (U**T \P**T * B) ]
*
            CALL STRSM( 'L', 'U', 'T', 'U', N-NB, NRHS, ONE, A(1, NB+1),
     $                 LDA, B(NB+1, 1), LDB)
*
         END IF
*
*        Compute T \ B -> B   [ T \ (U**T \P**T * B) ]
*
         CALL SGBTRS( 'N', N, NB, NB, NRHS, TB, LDTB, IPIV2, B, LDB,
     $               INFO)
         IF( N.GT.NB ) THEN
*
*           Compute (U \ B) -> B   [ U \ (T \ (U**T \P**T * B) ) ]
*
            CALL STRSM( 'L', 'U', 'N', 'U', N-NB, NRHS, ONE, A(1, NB+1),
     $                  LDA, B(NB+1, 1), LDB)
*
*           Pivot, P * B  [ P * (U \ (T \ (U**T \P**T * B) )) ]
*
            CALL SLASWP( NRHS, B, LDB, NB+1, N, IPIV, -1 )
*
         END IF
*
      ELSE
*
*        Solve A*X = B, where A = L*T*L**T.
*
         IF( N.GT.NB ) THEN
*
*           Pivot, P**T * B
*
            CALL SLASWP( NRHS, B, LDB, NB+1, N, IPIV, 1 )
*
*           Compute (L \P**T * B) -> B    [ (L \P**T * B) ]
*
            CALL STRSM( 'L', 'L', 'N', 'U', N-NB, NRHS, ONE, A(NB+1, 1),
     $                 LDA, B(NB+1, 1), LDB)
*
         END IF
*
*        Compute T \ B -> B   [ T \ (L \P**T * B) ]
*
         CALL SGBTRS( 'N', N, NB, NB, NRHS, TB, LDTB, IPIV2, B, LDB,
     $               INFO)
         IF( N.GT.NB ) THEN
*
*           Compute (L**T \ B) -> B   [ L**T \ (T \ (L \P**T * B) ) ]
*
            CALL STRSM( 'L', 'L', 'T', 'U', N-NB, NRHS, ONE, A(NB+1, 1),
     $                  LDA, B(NB+1, 1), LDB)
*
*           Pivot, P * B  [ P * (L**T \ (T \ (L \P**T * B) )) ]
*
            CALL SLASWP( NRHS, B, LDB, NB+1, N, IPIV, -1 )
*
         END IF
      END IF
*
      RETURN
*
*     End of SSYTRS_AA_2STAGE
*
      END


      subroutine pderhs(t)
************************************************************************
*
*   PDERHS -- RHS inner product for Burgers' equation with source
*
*      du/dt = -uscf*u*du/dx + visc^{-1}*g(u) + visc*d2u/dx2.
*
************************************************************************
      include "parameters.h"

      integer nnod,nelt
      common /mfe010/ nnod,nelt

      double precision visc,uscf,cg,usera
      common /mfe100/ visc,uscf,cg,usera(22)

      double precision u0,x0,u1,x1
      common /loc10/ u0(mnod),x0(mnod),u1(mnod),x1(mnod)

      double precision gu0,gx0,gu1,gx1
      common /loc12/ gu0(mnod),gx0(mnod),gu1(mnod),gx1(mnod)

      double precision l,n1,n2,du,dx
      common /loc30/ l(mnod),n1(mnod),n2(mnod) /loc31/ du(mnod),dx(mnod)

      double precision g5w,g5a0,g5a1
      common /g1d5/ g5w(5),g5a0(5),g5a1(5)

      integer j,k
      double precision t,c,g,u,gu,gua0,gua1

*     Source function
      g(u) = u**2 * (1.d0 - u)**6

      c = -uscf/6.d0
      do 10 j=1,nelt
       gx0(j) = ((c*du(j))*(2.d0*u0(j)+u1(j)))*n1(j)
       gu0(j) = ((c*du(j))*(2.d0*u0(j)+u1(j)))*n2(j)
       gx1(j) = ((c*du(j))*(2.d0*u1(j)+u0(j)))*n1(j)
       gu1(j) = ((c*du(j))*(2.d0*u1(j)+u0(j)))*n2(j)
   10 continue

      if (cg .gt. 0.0d0) then
        c = 256.d0*cg/(visc*uscf)
        do 20 j=1,nelt
*        Average of g(u)*alphas by 3 pt Gauss quadrature.
         gua0 = 0.d0
         gua1 = 0.d0
         do 21 k=1,5
          gu = g(uscf*(g5a0(k)*u0(j)+g5a1(k)*u1(j)))
          gua0 = gua0 + g5w(k)*g5a0(k)*gu
          gua1 = gua1 + g5w(k)*g5a1(k)*gu
   21    continue
         gx0(j) = gx0(j) + ((c*dx(j))*gua0)*n1(j)
         gu0(j) = gu0(j) + ((c*dx(j))*gua0)*n2(j)
         gx1(j) = gx1(j) + ((c*dx(j))*gua1)*n1(j)
         gu1(j) = gu1(j) + ((c*dx(j))*gua1)*n2(j)
   20   continue
      end if

      call lapl(1,visc)

      return
      end

      block data
************************************************************************
*
*   Quadrature formula:
*
*   G1D3 -- 3 point 1D Gaussian quadrature formula.  Fifth order
*   accurate.  The weights are g3w(.) and the corresponding quadrature
*   points are (g3a0(.), g3a1(.)) given as the isoparametric coordinates
*   (alpha_0, alpha_1) of the interval.
*
************************************************************************
      double precision g3w,g3a0,g3a1,g5w,g5a0,g5a1
      common /g1d3/ g3w(3),g3a0(3),g3a1(3)
      common /g1d5/ g5w(5),g5a0(5),g5a1(5)

      integer k

      data g3w/
     + 2.77777777777778d-1,4.44444444444444d-1,2.77777777777778d-1/
      data (g3a0(k),g3a1(k),k=1,3)/
     + 1.12701665379259d-1, 8.87298334620741d-1,
     + 5.00000000000000d-1, 5.00000000000000d-1,
     + 8.87298334620741d-1, 1.12701665379259d-1/

      data g5w/0.118463442528094d0,
     +         0.239314335249683d0,
     +         0.284444444444444d0,
     +         0.239314335249683d0,
     +         0.118463442528095d0/

      data (g5a0(k),g5a1(k),k=1,5)/
     +         0.046910077030668d0, 0.953089922969332d0,
     +         0.230765344947158d0, 0.769234655052841d0,
     +         0.5d0,               0.5d0,
     +         0.769234655052841d0, 0.230765344947158d0,
     +         0.953089922969332d0, 0.046910077030668d0/

      end


program Main
    use supermod
    implicit none
    character (len=100) :: filename
    double precision :: lam_FE, lam_ST, R_0, t_0
    double precision :: dm_Density, ejecta_Mass, ISM_Density, dist_SN, energy_SN
    double precision :: time, R_s, V_s, vel
    integer :: i

    dm_Density = 0.3 ! GeV cm^{-3}
    ejecta_Mass = 5. ! m_Sun
    ISM_Density = 3.73d-3 ! cm^{-3}
    dist_SN = 300. ! pc
    energy_SN = 8.d50 ! erg
    call supercaptn_init(dm_Density, ejecta_Mass, ISM_Density, dist_SN, energy_SN)

    filename = "VShock.dat"
    lam_FE = 0.
    lam_ST = 0.
    R_0 = 0.
    t_0 = 0.

    open(unit=9, file=filename, status="replace")
    call novaParameters(lam_FE, lam_ST, R_0, t_0)
    write(9, *) "lam_FE=", lam_FE, "lam_ST=", lam_ST, "R_0=", R_0, "t_0=", t_0
    write(9, *) "Time (s) R_shock (cm) V_shock (cm/s)"

    do i = 1, 61
        vel = 10**(dble(i-1)/10. + 8.) ! chris' notes test the range of velocities from 10^8 to 10^9 cm s^-1 for SI xSec
        ! time = dist_SN*3.08567758149d18/vel
        time = 3.154d7 * 10.**(dble(i-1)/10.)
        R_s = Rshock(time)
        V_s = Vshock(time)
        write(9, *) time, R_s, V_s
    end do
    close(9)

end program Main


      subroutine rtbist(x1,x2,rc1,rc2,rc3,rc4,rc5,rc6,rc7,
     1 rc8,lp,arc,brc,vrc,vap,vapp,ev,cdrc,r,rab,jrc,delta,
     2 gamma,alpha,alpha1,alpha2,alpha3,alpha4,ar)
c
c *************************************************************
c *  njtj
c *  Finds the value of gamma for the v"(0)=0 criteria.
c *  The method used is bisection.  This routine
c *  was taken from Numerical Recipes, page 247.
c *  njtj
c *************************************************************
c
c  njtj
c  ###  Cray conversions
c  ###    1)Comment out the implicit double precision.
c  ###    2)Switch double precision parameter
c  ###      to single precision parameter statement.
c  ###  Cray conversions
c  njtj
c
      implicit double precision (a-h,o-z)
c
      parameter (jmax=80,pfive=0.5D0,zero=0.D0,xacc=1.D-10)
Cray      parameter (jmax=80,pfive=0.5,zero=0.0,xacc=1.E-10)
c
      dimension r(jrc),rab(jrc),ar(jrc)
c
      call gamfnd(rc1,rc2,rc3,rc4,rc5,rc6,rc7,rc8,lp,
     1 arc,brc,vrc,vap,vapp,ev,cdrc,r,rab,jrc,delta,x1,
     2 alpha,alpha1,alpha2,alpha3,alpha4,f,ar)
      call gamfnd(rc1,rc2,rc3,rc4,rc5,rc6,rc7,rc8,lp,
     1 arc,brc,vrc,vap,vapp,ev,cdrc,r,rab,jrc,delta,x2,
     2 alpha,alpha1,alpha2,alpha3,alpha4,fmid,ar)
      if(f*fmid.ge.zero) then
        write(6,4000)
        call ext(840+lp)
      endif
      if(f.lt.zero)then
        gamma=x1
        dx=x2-x1
      else
        gamma=x2
        dx=x1-x2
      endif
      do 11 j=1,jmax
        dx=dx*pfive
        xmid=gamma+dx
        call gamfnd(rc1,rc2,rc3,rc4,rc5,rc6,rc7,rc8,lp,
     1   arc,brc,vrc,vap,vapp,ev,cdrc,r,rab,jrc,delta,
     2   xmid,alpha,alpha1,alpha2,alpha3,alpha4,fmid,ar)
        if(fmid.lt.zero)gamma=xmid
        if(abs(dx).lt.xacc .or. fmid.eq. zero) return
11    continue
      write(6,4001)
      call ext(850+lp)
 4000 format(' error in bisection method(rtbistk)',
     1 ' - root must be bracketed.',
     2 /,'a b o r t i n g   p r o g r a m')
 4001 format(' error in bisection method(rtbistk)',
     1 ' - too many bisections used',
     2 /,'a b o r t i n g   p r o g r a m')
      end


!    ...................................
!    From interaction to HFB fileds
!    ...................................
        subroutine HFB_FIELD_COMPLEX(zro,zkapa10,zkapa01,   &
     &  zakin,zgamma,zham,zdelta10,zdelta01,NLEV)
!      ..............................................................
        USE VAPHFB_PAR
        implicit real*8 (a-h,o-y)
        implicit complex*16 (z)

        DIMENSION zro(NLEV,NLEV)
        DIMENSION zkapa10(NLEV,NLEV)
        DIMENSION zkapa01(NLEV,NLEV)
        DIMENSION zakin(NLEV,NLEV)
        DIMENSION zgamma(NLEV,NLEV)
        DIMENSION zham(NLEV,NLEV)
        DIMENSION zdelta10(NLEV,NLEV)
        DIMENSION zdelta01(NLEV,NLEV)
!        DIMENSION V_ABCD(NLEV,NLEV,NLEV,NLEV)

!     ...................... initialization
      do ia=1,NLEV
      do ic=1,NLEV
            ZGamma(ia,ic)  =zzero
            zDelta10(ia,ic)=zzero
            zDelta01(ia,ic)=zzero
            zham(ia,ic)    =zzero
      enddo
      enddo

      do iabcd=1,H%iabcd_max
          ia = H%ka(iabcd)
          ib = H%kb(iabcd)
          ic = H%kc(iabcd)
          id = H%kd(iabcd)
          ZGamma(ia,ic)=ZGamma(ia,ic) + H%ME2BM(iabcd)*ZRO(id,ib)
          ZGamma(ib,ic)=ZGamma(ib,ic) - H%ME2BM(iabcd)*ZRO(id,ia)
!          if(abs(H%ME2BM(iabcd)).gt.1.d-6)  write(*,*) ia,ib,ic,id,H%ME2BM(iabcd)
       enddo ! iabcd
!  ................... single-particle h
       do ia=1,NLEV
         do ic=1,NLEV
            zham(ia,ic)=zGamma(ia,ic)+zakin(ia,ic)
      end do
        end do
        !Delta
      do iabcd=1,H%iabcd_max
          ia = H%ka(iabcd)
          ib = H%kb(iabcd)
          ic = H%kc(iabcd)
          id = H%kd(iabcd)
            zDelta10(ia,ib)=zDelta10(ia,ib)+0.5*H%ME2BM(iabcd)*zkapa10(ic,id)
            if(ia.ne.ib) &
     &      zDelta10(ib,ia)=zDelta10(ib,ia)-0.5*H%ME2BM(iabcd)*zkapa10(ic,id)

            zDelta01(ia,ib)=zDelta01(ia,ib)+0.5*H%ME2BM(iabcd)*zkapa01(ic,id)
            if(ia.ne.ib) &
     &      zDelta01(ib,ia)=zDelta01(ib,ia)-0.5*H%ME2BM(iabcd)*zkapa01(ic,id)

       enddo ! iabcd

        end subroutine


! Coarray 1D Heat Equation Solver Test: main
!
! Copyright (c) 2012-2014, Sourcery, Inc.
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!     * Redistributions of source code must retain the above copyright
!       notice, this list of conditions and the following disclaimer.
!     * Redistributions in binary form must reproduce the above copyright
!       notice, this list of conditions and the following disclaimer in the
!       documentation and/or other materials provided with the distribution.
!     * Neither the name of the Sourcery, Inc., nor the
!       names of its contributors may be used to endorse or promote products
!       derived from this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
! ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
! WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
! DISCLAIMED. IN NO EVENT SHALL SOURCERY, INC., BE LIABLE FOR ANY
! DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
! (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
! ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
! (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
!

program main
  use global_field_module, only : global_field
  implicit none
  type(global_field) :: T,laplacian_T,T_half
  real, parameter :: alpha=1.,dt=0.0001,final_time=1.,tolerance=1.E-3
  real :: time=0.
  call T%global_field_(internal_values=0.,boundary_values=[1.,0.],domain=[0.,1.],num_global_points=16384)
  call T_half%global_field_()
  do while(time<final_time)
    T_half = T + (.laplacian.T)*(alpha*dt/2.)
    T      = T + (.laplacian.T_half)*(alpha*dt)
    time = time + dt
  end do
  call laplacian_T%global_field_()
  laplacian_T = .laplacian.T
  if (any(laplacian_T%state()>tolerance)) error stop "Test failed."
  if (this_image()==1) print *,"Test passed."
end program


!! PBiCGStab related BLAS operations

!! 1D

!! s = r - alpha*v or  s = -alpha*v + r
!! r = s - omega*t
subroutine blas_avpy_1d(nxyz, ng, alpha, s, r, v)
implicit none
    integer, dimension(3) :: nxyz
    integer :: ng, i, ix
    real :: alpha
    real, dimension( 1-ng:nxyz(1)+ng ) :: s, r, v

    ix = nxyz(1)
    do i=1, ix
      s(i) = r(i) - alpha*v(i)
    end do
end subroutine blas_avpy_1d

!! x = x + alpha*y + omega*z
subroutine cg_xi_1d(nxyz, ng, x,  y, z, alpha, omega)
implicit none
    integer, dimension(3) :: nxyz
    integer :: ng, i, ix
    real :: alpha, omega
    real, dimension( 1-ng:nxyz(1)+ng ) :: x, y, z

    ix = nxyz(1)
    do i=1, ix
      x(i) = x(i) + alpha*y(i) + omega*z(i)
    end do
end subroutine cg_xi_1d

!!p = r + beta * ( p - omg * v )
subroutine cg_direct_1d(nxyz, ng, p, r, v, beta, omega)
implicit none
    integer, dimension(3) :: nxyz
    integer :: ng, i, ix
    real :: beta, omega
    real, dimension( 1-ng:nxyz(1)+ng ) :: p, r, v

    ix = nxyz(1)
    do i=1, ix
      p(i) = r(i) + beta * ( p(i) - omega*v(i) )
    end do
end subroutine cg_direct_1d

!! calcaluate v = Ax ,
!! A is stencil
subroutine cg_ax1d(nxyz, ng, v, x, A)
implicit none
    integer, dimension(3) :: nxyz
    integer ::  ng, i, ix
    real    ::  ndag_e, ndag_w, dd
    real, dimension(     1-ng:nxyz(1)+ng ) :: v, x
    real, dimension(1:3, 1-ng:nxyz(1)+ng ) :: A

    ix = nxyz(1)
    do i=1, ix
        ndag_e = A(1, i)
        ndag_w = A(2, i)
            dd = A(3, i)

        v(i) = ndag_e*x(i+1) + dd*x(i) + ndag_w*x(i-1);
    end do
end subroutine cg_ax1d

!! calcaluate the residual r = b - Ax ,
!! A is stencil
subroutine cg_rk1d(nxyz, ng, r, x, b, A)
implicit none
    integer, dimension(3) :: nxyz
    integer ::  ng, i, ix
    real    ::  ndag_e, ndag_w, dd, ax
    real, dimension(     1-ng:nxyz(1)+ng ) :: r, x, b
    real, dimension(1:3, 1-ng:nxyz(1)+ng ) :: A

    ix = nxyz(1)
    do i=1, ix
        ndag_e = A(1, i)
        ndag_w = A(2, i)
            dd = A(3, i)

        ax = ndag_e*x(i+1) + dd*x(i) + ndag_w*x(i-1);
        r(i) = b(i) - ax;
    end do
end subroutine cg_rk1d

!! 2D

!! s = r - alpha*v or  s = -alpha*v + r
!! r = s - omega*t
subroutine blas_avpy_2d(nxyz, ng, alpha, s, r, v)
implicit none
    integer, dimension(3) :: nxyz
    integer :: ng, i, j, ix, jy
    real :: alpha
    real, dimension( 1-ng:nxyz(1)+ng, 1-ng:nxyz(2)+ng ) :: s, r, v

    ix = nxyz(1)
    jy = nxyz(2)
    do j=1, jy
    do i=1, ix
      s(i,j) = r(i,j) - alpha*v(i,j)
    end do
    end do
end subroutine blas_avpy_2d

!! x = x + alpha*y + omega*z
subroutine cg_xi_2d(nxyz, ng, x,  y, z, alpha, omega)
implicit none
    integer, dimension(3) :: nxyz
    integer :: ng, i, j, ix, jy
    real :: alpha, omega
    real, dimension( 1-ng:nxyz(1)+ng, 1-ng:nxyz(2)+ng ) :: x, y, z

    ix = nxyz(1)
    jy = nxyz(2)
    do j=1, jy
    do i=1, ix
      x(i,j) = x(i,j) + alpha*y(i,j) + omega*z(i,j)
    end do
    end do
end subroutine cg_xi_2d

!!p = r + beta * ( p - omg * v )
subroutine cg_direct_2d(nxyz, ng, p, r, v, beta, omega)
implicit none
    integer, dimension(3) :: nxyz
    integer :: ng, i, j, ix, jy
    real :: beta, omega
    real, dimension( 1-ng:nxyz(1)+ng, 1-ng:nxyz(2)+ng ) :: p, r, v

    ix = nxyz(1)
    jy = nxyz(2)
    do j=1, jy
    do i=1, ix
      p(i,j) = r(i,j) + beta * ( p(i,j) - omega*v(i,j) )
    end do
    end do
end subroutine cg_direct_2d

subroutine cg_ax2d(nxyz, ng, v, x, A)
implicit none
    integer, dimension(3) :: nxyz
    integer ::  ng, i, j, ix, jy
    real    ::  ndag_e, ndag_w, ndag_n, ndag_s, dd
    real, dimension(     1-ng:nxyz(1)+ng, 1-ng:nxyz(2)+ng ) :: v, x
    real, dimension(1:5, 1-ng:nxyz(1)+ng, 1-ng:nxyz(2)+ng ) :: A

    ix = nxyz(1)
    jy = nxyz(2)
    do j=1, jy
    do i=1, ix
        ndag_e = A(1, i, j)
        ndag_w = A(2, i, j)
        ndag_n = A(3, i, j)
        ndag_s = A(4, i, j)
            dd = A(5, i, j)

        v(i,j) = ndag_e*x(i+1, j  ) &
               + ndag_w*x(i-1, j  ) &
               + ndag_n*x(i,   j+1) &
               + ndag_s*x(i,   j-1) &
               +     dd*x(i,   j  )
    end do
    end do
end subroutine cg_ax2d

subroutine cg_rk2d(nxyz, ng, r, x, b, A)
implicit none
    integer, dimension(3) :: nxyz
    integer ::  ng, i, j, ix, jy
    real    ::  ndag_e, ndag_w, ndag_n, ndag_s, dd, val
    real, dimension(     1-ng:nxyz(1)+ng, 1-ng:nxyz(2)+ng ) :: r, x, b
    real, dimension(1:5, 1-ng:nxyz(1)+ng, 1-ng:nxyz(2)+ng ) :: A

    ix = nxyz(1)
    jy = nxyz(2)
    do j=1, jy
    do i=1, ix
        ndag_e = A(1, i, j)
        ndag_w = A(2, i, j)
        ndag_n = A(3, i, j)
        ndag_s = A(4, i, j)
            dd = A(5, i, j)

           val = ndag_e*x(i+1, j  ) &
               + ndag_w*x(i-1, j  ) &
               + ndag_n*x(i,   j+1) &
               + ndag_s*x(i,   j-1) &
               +     dd*x(i,   j  )
        r(i, j) = b(i, j) - val
    end do
    end do
end subroutine cg_rk2d

!!
!! 3D
!!

!! s = r - alpha*v or  s = -alpha*v + r
!! r = s - omega*t
subroutine blas_avpy_3d(nxyz, ng, alpha, s, r, v)
implicit none
    integer, dimension(3) :: nxyz
    integer :: ng, i, j, k, ix, jy, kz
    real :: alpha
    real, dimension( 1-ng:nxyz(1)+ng, 1-ng:nxyz(2)+ng, 1-ng:nxyz(3)+ng ) :: s, r, v

    ix = nxyz(1)
    jy = nxyz(2)
    kz = nxyz(3)

!$OMP PARALLEL &
!$OMP FIRSTPRIVATE(ix, jy, kz)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
    do k=1, kz
    do j=1, jy
    do i=1, ix
      s(i,j,k) = r(i,j,k) - alpha*v(i,j,k)
    end do
    end do
    end do
!$OMP END DO
!$OMP END PARALLEL

end subroutine blas_avpy_3d

!! x = x + alpha*y + omega*z
subroutine cg_xi_3d(nxyz, ng, x,  y, z, alpha, omega)
implicit none
    integer, dimension(3) :: nxyz
    integer :: ng, i, j, k, ix, jy, kz
    real :: alpha, omega
    real, dimension( 1-ng:nxyz(1)+ng, 1-ng:nxyz(2)+ng, 1-ng:nxyz(3)+ng ) :: x, y, z

    ix = nxyz(1)
    jy = nxyz(2)
    kz = nxyz(3)
!$OMP PARALLEL &
!$OMP FIRSTPRIVATE(ix, jy, kz)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
    do k=1, kz
    do j=1, jy
    do i=1, ix
      x(i,j,k) = x(i,j,k) + alpha*y(i,j,k) + omega*z(i,j,k)
    end do
    end do
    end do
!$OMP END DO
!$OMP END PARALLEL

end subroutine cg_xi_3d

!!p = r + beta * ( p - omg * v )
subroutine cg_direct_3d(nxyz, ng, p, r, v, beta, omega)
implicit none
    integer, dimension(3) :: nxyz
    integer :: ng, i, j, k, ix, jy, kz
    real :: beta, omega
    real, dimension( 1-ng:nxyz(1)+ng, 1-ng:nxyz(2)+ng, 1-ng:nxyz(3)+ng ) :: p, r, v

    ix = nxyz(1)
    jy = nxyz(2)
    kz = nxyz(3)
!$OMP PARALLEL &
!$OMP FIRSTPRIVATE(ix, jy, kz)

!$OMP DO SCHEDULE(static) COLLAPSE(2)
    do k=1, kz
    do j=1, jy
    do i=1, ix
      p(i,j,k) = r(i,j,k) + beta * ( p(i,j,k) - omega*v(i,j,k) )
    end do
    end do
    end do
!$OMP END DO
!$OMP END PARALLEL

end subroutine cg_direct_3d

subroutine cg_ax3d(nxyz, ng, v, x, A)
implicit none
    integer, dimension(3) :: nxyz
    integer ::  ng, i, j, k, ix, jy, kz
    real    ::  ndag_e, ndag_w, ndag_n, ndag_s, ndag_t, ndag_b, dd, ss
    real, dimension(     1-ng:nxyz(1)+ng, 1-ng:nxyz(2)+ng, 1-ng:nxyz(3)+ng ) :: v, x
    real, dimension(1:7, 1-ng:nxyz(1)+ng, 1-ng:nxyz(2)+ng, 1-ng:nxyz(3)+ng ) :: A

    ix = nxyz(1)
    jy = nxyz(2)
    kz = nxyz(3)
!$OMP PARALLEL &
!$OMP PRIVATE(ndag_e, ndag_w, ndag_n, ndag_s, ndag_t, ndag_b, dd, ss) &
!$OMP FIRSTPRIVATE(ix, jy, kz)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
    do k=1, kz
    do j=1, jy
    do i=1, ix
        ndag_e = A(1, i, j, k)
        ndag_w = A(2, i, j, k)
        ndag_n = A(3, i, j, k)
        ndag_s = A(4, i, j, k)
        ndag_t = A(5, i, j, k)
        ndag_b = A(6, i, j, k)
            dd = A(7, i, j, k)

            ss = ndag_e*x(i+1, j,   k  ) &
               + ndag_w*x(i-1, j,   k  ) &
               + ndag_n*x(i,   j+1, k  ) &
               + ndag_s*x(i,   j-1, k  ) &
               + ndag_t*x(i,   j,   k+1) &
               + ndag_b*x(i,   j,   k-1)
        v(i,j,k) = ss + dd*x(i, j, k)
    end do
    end do
    end do
!$OMP END DO
!$OMP END PARALLEL

end subroutine cg_ax3d

subroutine cg_rk3d(nxyz, ng, r, x, b, A)
implicit none
    integer, dimension(3) :: nxyz
    integer ::  ng, i, j, k, ix, jy, kz
    real    ::  ndag_e, ndag_w, ndag_n, ndag_s, ndag_t, ndag_b, dd, ss
    real, dimension(     1-ng:nxyz(1)+ng, 1-ng:nxyz(2)+ng, 1-ng:nxyz(3)+ng ) :: r, x, b
    real, dimension(1:7, 1-ng:nxyz(1)+ng, 1-ng:nxyz(2)+ng, 1-ng:nxyz(3)+ng ) :: A

    ix = nxyz(1)
    jy = nxyz(2)
    kz = nxyz(3)
!$OMP PARALLEL &
!$OMP PRIVATE(ndag_e, ndag_w, ndag_n, ndag_s, ndag_t, ndag_b, dd, ss) &
!$OMP FIRSTPRIVATE(ix, jy, kz)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
    do k=1, kz
    do j=1, jy
    do i=1, ix
        ndag_e = A(1, i, j, k)
        ndag_w = A(2, i, j, k)
        ndag_n = A(3, i, j, k)
        ndag_s = A(4, i, j, k)
        ndag_t = A(5, i, j, k)
        ndag_b = A(6, i, j, k)
            dd = A(7, i, j, k)

            ss = ndag_e*x(i+1, j,   k  ) &
               + ndag_w*x(i-1, j,   k  ) &
               + ndag_n*x(i,   j+1, k  ) &
               + ndag_s*x(i,   j-1, k  ) &
               + ndag_t*x(i,   j,   k+1) &
               + ndag_b*x(i,   j,   k-1)

        r(i,j,k) = b(i,j,k) - ( ss + dd*x(i,j,k) )
    end do
    end do
    end do
!$OMP END DO
!$OMP END PARALLEL

end subroutine cg_rk3d


!*****************************************************************************************
!> author: Jacob Williams
!  date: 3/9/2015
!
!  Sample driver program for pikaia.
!  Based on the [xpikaia](http://www.hao.ucar.edu/modeling/pikaia/xpikaia.f) routine.

    program pikaia_test

    use pikaia_module, only: pikaia_class
    use,intrinsic :: iso_fortran_env, wp => real64

    implicit none

    integer,parameter :: n = 2  !! dimension of problem (number of optimization variables)

    integer                 :: seed,status
    real(wp),dimension(n)   :: x
    real(wp)                :: f
    integer                 :: iunit,istat
    real(wp),dimension(n)   :: xl,xu
    type(pikaia_class)      :: p
    logical                 :: header_written
    real                    :: tstart,tend

    character(len=*),parameter :: filename = 'pikaia_test.txt'

    seed = 999  ! specify the random seed

    !output file:
    open(newunit=iunit,file=filename,iostat=istat)
    if (istat/=0) stop 'error opening output file.'
    header_written = .false.

    !initial guess:
    write(output_unit,'(A)') ''
    write(output_unit,'(A)') ' TWOD Example'
    write(output_unit,'(A)') ''

    x = 0.0_wp
    xl = 0.0_wp
    xu = 1.0_wp

    !initialize the class:
    call p%init(n,xl,xu,twod,status,&
                iter_f              = report_iteration,&
                ngen                = 1000,&
                nd                  = 9,&
                ivrb                = 1,&    !0,1,2
                convergence_tol     = 1.0e-6_wp,&
                convergence_window  = 200,&
                iseed               = seed)

    !Now call pikaia:
    call cpu_time(tstart)
    call p%solve(x,f,status)
    call cpu_time(tend)

    !Print the results:
    write(output_unit,'(A)') ''
    write(output_unit,'(A,1X,*(I4))')    '  status: ',status
    write(output_unit,'(A,1X,*(F12.6))') '       x: ',x
    write(output_unit,'(A,1X,*(F12.6))') '       f: ',f
    write(output_unit,'(A)') ''
    write(output_unit,'(A,1X,F12.6,A)')  'run time: ',tend-tstart,' sec'
    write(output_unit,'(A)') ''

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

    !initial guess:
    write(output_unit,'(A)') ''
    write(output_unit,'(A)') ' ROSENBROCK Example'
    write(output_unit,'(A)') ''

    x  = 0.5_wp
    xl = 0.0_wp
    xu = 2.0_wp

    !initialize the class:
    call p%init(n,xl,xu,rosenbrock,status,&
                np                  = 500,&        !try a larger population for this one
                ngen                = 1000,&
                nd                  = 9,&
                convergence_tol     = 1.0e-10_wp,& !tighter tolerance also
                convergence_window  = 200,&
                iseed               = seed)

    !Now call pikaia:
    call cpu_time(tstart)
    call p%solve(x,f,status)
    call cpu_time(tend)

    !Print the results:
    write(output_unit,'(A)') ''
    write(output_unit,'(A,1X,*(I4))')    '  status: ',status
    write(output_unit,'(A,1X,*(F12.6))') '       x: ',x
    write(output_unit,'(A,1X,*(F12.6))') '       f: ',f
    write(output_unit,'(A)') ''
    write(output_unit,'(A,1X,F12.6,A)')  'run time: ',tend-tstart,' sec'
    write(output_unit,'(A)') ''

    close(iunit,iostat=istat)

    contains

        subroutine twod(me,x,f)

        !! Compute sample fitness function
        !! (a smooth 2-d landscape)

        implicit none

        !Input/output:
        class(pikaia_class),intent(inout) :: me
        real(wp),dimension(:),intent(in)  :: x
        real(wp),intent(out)              :: f

        !Constant
        real(wp),parameter  :: pi=acos(-1.0_wp)
        real(wp),parameter  :: sigma2=0.15_wp
        integer,parameter   :: nn = 9

        !Local
        real(wp) :: rr

        if (x(1)>1.0_wp .or. x(2)>1.0_wp) then
            write(output_unit,*) 'Error in function twod: invalid inputs.'
            write(output_unit,*) 'x(1)=',x(1),'>1.0'
            write(output_unit,*) 'x(2)=',x(2),'>1.0'
            stop
        else
            rr=sqrt( (0.5_wp-x(1))**2+ (0.5_wp-x(2))**2)
            f=cos(rr*nn*pi)**2 *exp(-rr**2/sigma2)
        end if

        end subroutine twod

        subroutine rosenbrock(me,x,f)

        !! Rosenbrock function for testing the algorithm.
        !! The minimum is at f(1,1) = 0.
        !!
        !!#Reference
        !!   * [Rosenbrock function](http://en.wikipedia.org/wiki/Rosenbrock_function)

        implicit none

        class(pikaia_class),intent(inout)   :: me
        real(wp),dimension(:), intent(in)   :: x
        real(wp),intent(out)                :: f

        real(wp),parameter :: one     = 1.0_wp
        real(wp),parameter :: hundred = 100.0_wp

        !the rosenbrock function:
        f = (one-x(1))**2 + hundred*(x(2)-x(1)**2)**2

        f = -f    !since pikaia maximizes

        end subroutine rosenbrock

        subroutine report_iteration(me,iter,x,f)

        !! A simple iteration reporting function.
        !! Writes `iter,x,f` to the output file.

        implicit none

        class(pikaia_class),intent(inout)  :: me
        integer,intent(in)                 :: iter
        real(wp),dimension(:),intent(in)   :: x
        real(wp),intent(in)                :: f

        character(len=10),dimension(n) :: xheader
        integer :: i

        !the first time it is called, also write a header:
        if (.not. header_written) then
            do i=1,n
                write(xheader(i),'(I10)') i
                xheader(i) = 'X'//trim(adjustl(xheader(i)))
                xheader(i) = repeat(' ',10-len_trim(xheader(i)))//xheader(i)
            end do
            write(iunit,'(A5,1X,*(A10,1X))') 'ITER',xheader,'F'
            header_written = .true.
        end if

        write(iunit,'(I5,1X,*(F10.6,1X))') iter,x,f

        end subroutine report_iteration

    end program pikaia_test
!*****************************************************************************************


    Program ztgsen_example

!     ZTGSEN Example Program Text

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

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_file_print_matrix_complex_gen_comp
      Use lapack_interfaces, Only: ztgsen
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: pl, pr
      Integer :: i, ifail, ijob, info, lda, ldb, ldq, ldz, liwork, lwork, m, n
      Logical :: wantq, wantz
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: a(:, :), alpha(:), b(:, :), beta(:), &
        q(:, :), work(:), z(:, :)
      Real (Kind=dp) :: dif(2)
      Integer, Allocatable :: iwork(:)
      Logical, Allocatable :: select(:)
      Character (1) :: clabs(1), rlabs(1)
!     .. Executable Statements ..
      Write (nout, *) 'ZTGSEN Example Program Results'
      Write (nout, *)
      Flush (nout)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      lda = n
      ldb = n
      ldq = n
      ldz = n
      liwork = (n*n)/2 + 2
      lwork = n*n
      Allocate (a(lda,n), alpha(n), b(ldb,n), beta(n), q(ldq,n), work(lwork), &
        z(ldz,n), iwork(liwork), select(n))

!     Read A, B, Q, Z and the logical array SELECT from data file

      Read (nin, *)(a(i,1:n), i=1, n)
      Read (nin, *)(b(i,1:n), i=1, n)
      Read (nin, *)(q(i,1:n), i=1, n)
      Read (nin, *)(z(i,1:n), i=1, n)

      Read (nin, *) select(1:n)

!     Set ijob, wantq and wantz
      ijob = 4
      wantq = .True.
      wantz = .True.

!     Reorder the Schur factors A and B and update the matrices
!     Q and Z

      Call ztgsen(ijob, wantq, wantz, select, n, a, lda, b, ldb, alpha, beta, &
        q, ldq, z, ldz, m, pl, pr, dif, work, lwork, iwork, liwork, info)

      If (info/=0) Then
        Write (nout, 100) info
        Write (nout, *)
        Flush (nout)
      End If

!     Print reordered generalized Schur form

!     ifail: behaviour on error exit
!             =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
      ifail = 0
      Call nagf_file_print_matrix_complex_gen_comp('General', ' ', n, n, a, &
        lda, 'Bracketed', 'F7.4', 'Reordered Schur matrix A', 'Integer', &
        rlabs, 'Integer', clabs, 80, 0, ifail)

      Write (nout, *)
      Flush (nout)

      ifail = 0
      Call nagf_file_print_matrix_complex_gen_comp('General', ' ', n, n, b, &
        ldb, 'Bracketed', 'F7.4', 'Reordered Schur matrix B', 'Integer', &
        rlabs, 'Integer', clabs, 80, 0, ifail)

!     Print deflating subspaces

      Write (nout, *)
      Flush (nout)

      ifail = 0
      Call nagf_file_print_matrix_complex_gen_comp('General', ' ', n, m, q, &
        ldq, 'Bracketed', 'F7.4', 'Basis of left deflating invariant subspace' &
        , 'Integer', rlabs, 'Integer', clabs, 80, 0, ifail)

      Write (nout, *)
      Flush (nout)

      ifail = 0
      Call nagf_file_print_matrix_complex_gen_comp('General', ' ', n, m, z, &
        ldz, 'Bracketed', 'F7.4', &
        'Basis of right deflating invariant subspace', 'Integer', rlabs, &
        'Integer', clabs, 80, 0, ifail)

!     Print norm estimates and F-norm upper bounds

      Write (nout, *)
      Write (nout, 110) 'Norm estimate of projection onto', &
        ' left  eigenspace for selected cluster', 1.0E0_dp/pl
      Write (nout, *)
      Write (nout, 110) 'Norm estimate of projection onto', &
        ' right eigenspace for selected cluster', 1.0E0_dp/pr
      Write (nout, *)
      Write (nout, 110) 'F-norm based upper bound on', ' Difu', dif(1)
      Write (nout, *)
      Write (nout, 110) 'F-norm based upper bound on', ' Difl', dif(2)

100   Format (' Reordering could not be completed. INFO = ', I3)
110   Format (1X, 2A, /, 1X, 1P, E10.2)
    End Program


Submodule ( statistical_data_mod ) statistical_variance_smod
!
  Use kind_parameters_mod
!
  Implicit None
!
Contains
!
  Module Procedure Statistical_Variance
!
     Real(KIND=rkind) :: mn
     If ( Size(this%data) .ne. 0 ) Then
        If ( Present ( mean ) ) Then
           mn = mean
        Else
           If ( this%Dmean ) Then
              mn = this%mean
           Else
              mn = Statistical_Mean ( this )
           End If
        End If
        variance = Sum ( (this%data-mn)**2 ) / Size ( this%data )
     Else
        variance = Huge ( variance )
     End If
     this%variance = variance
     this%Dvariance = .true.
!
  End Procedure Statistical_Variance
!
End Submodule statistical_variance_smod


!*==zlamtsqr.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b ZLAMTSQR
!
!  Definition:
!  ===========
!
!      SUBROUTINE ZLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T,
!     $                     LDT, C, LDC, WORK, LWORK, INFO )
!
!
!     .. Scalar Arguments ..
!      CHARACTER         SIDE, TRANS
!      INTEGER           INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC
!     ..
!     .. Array Arguments ..
!      COMPLEX*16        A( LDA, * ), WORK( * ), C(LDC, * ),
!     $                  T( LDT, * )
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!>      ZLAMTSQR overwrites the general complex M-by-N matrix C with
!>
!>
!>                 SIDE = 'L'     SIDE = 'R'
!> TRANS = 'N':      Q * C          C * Q
!> TRANS = 'C':      Q**H * C       C * Q**H
!>      where Q is a real orthogonal matrix defined as the product
!>      of blocked elementary reflectors computed by tall skinny
!>      QR factorization (ZLATSQR)
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] SIDE
!> \verbatim
!>          SIDE is CHARACTER*1
!>          = 'L': apply Q or Q**H from the Left;
!>          = 'R': apply Q or Q**H from the Right.
!> \endverbatim
!>
!> \param[in] TRANS
!> \verbatim
!>          TRANS is CHARACTER*1
!>          = 'N':  No transpose, apply Q;
!>          = 'C':  Conjugate Transpose, apply Q**H.
!> \endverbatim
!>
!> \param[in] M
!> \verbatim
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >=0.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The number of columns of the matrix C. M >= N >= 0.
!> \endverbatim
!>
!> \param[in] K
!> \verbatim
!>          K is INTEGER
!>          The number of elementary reflectors whose product defines
!>          the matrix Q.
!>          N >= K >= 0;
!>
!> \endverbatim
!>
!> \param[in] MB
!> \verbatim
!>          MB is INTEGER
!>          The block size to be used in the blocked QR.
!>          MB > N. (must be the same as DLATSQR)
!> \endverbatim
!>
!> \param[in] NB
!> \verbatim
!>          NB is INTEGER
!>          The column block size to be used in the blocked QR.
!>          N >= NB >= 1.
!> \endverbatim
!>
!> \param[in] A
!> \verbatim
!>          A is COMPLEX*16 array, dimension (LDA,K)
!>          The i-th column must contain the vector which defines the
!>          blockedelementary reflector H(i), for i = 1,2,...,k, as
!>          returned by DLATSQR in the first k columns of
!>          its array argument A.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.
!>          If SIDE = 'L', LDA >= max(1,M);
!>          if SIDE = 'R', LDA >= max(1,N).
!> \endverbatim
!>
!> \param[in] T
!> \verbatim
!>          T is COMPLEX*16 array, dimension
!>          ( N * Number of blocks(CEIL(M-K/MB-K)),
!>          The blocked upper triangular block reflectors stored in compact form
!>          as a sequence of upper triangular blocks.  See below
!>          for further details.
!> \endverbatim
!>
!> \param[in] LDT
!> \verbatim
!>          LDT is INTEGER
!>          The leading dimension of the array T.  LDT >= NB.
!> \endverbatim
!>
!> \param[in,out] C
!> \verbatim
!>          C is COMPLEX*16 array, dimension (LDC,N)
!>          On entry, the M-by-N matrix C.
!>          On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
!> \endverbatim
!>
!> \param[in] LDC
!> \verbatim
!>          LDC is INTEGER
!>          The leading dimension of the array C. LDC >= max(1,M).
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>         (workspace) COMPLEX*16 array, dimension (MAX(1,LWORK))
!>
!> \endverbatim
!> \param[in] LWORK
!> \verbatim
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
!>          If SIDE = 'L', LWORK >= max(1,N)*NB;
!>          if SIDE = 'R', LWORK >= max(1,MB)*NB.
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>
!> \endverbatim
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!> Tall-Skinny QR (TSQR) performs QR by a sequence of orthogonal transformations,
!> representing Q as a product of other orthogonal matrices
!>   Q = Q(1) * Q(2) * . . . * Q(k)
!> where each Q(i) zeros out subdiagonal entries of a block of MB rows of A:
!>   Q(1) zeros out the subdiagonal entries of rows 1:MB of A
!>   Q(2) zeros out the bottom MB-N rows of rows [1:N,MB+1:2*MB-N] of A
!>   Q(3) zeros out the bottom MB-N rows of rows [1:N,2*MB-N+1:3*MB-2*N] of A
!>   . . .
!>
!> Q(1) is computed by GEQRT, which represents Q(1) by Householder vectors
!> stored under the diagonal of rows 1:MB of A, and by upper triangular
!> block reflectors, stored in array T(1:LDT,1:N).
!> For more information see Further Details in GEQRT.
!>
!> Q(i) for i>1 is computed by TPQRT, which represents Q(i) by Householder vectors
!> stored in rows [(i-1)*(MB-N)+N+1:i*(MB-N)+N] of A, and by upper triangular
!> block reflectors, stored in array T(1:LDT,(i-1)*N+1:i*N).
!> The last Q(k) may use fewer rows.
!> For more information see Further Details in TPQRT.
!>
!> For more details of the overall algorithm, see the description of
!> Sequential TSQR in Section 2.2 of [1].
!>
!> [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations,”
!>     J. Demmel, L. Grigori, M. Hoemmen, J. Langou,
!>     SIAM J. Sci. Comput, vol. 34, no. 1, 2012
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE ZLAMTSQR(Side,Trans,M,N,K,Mb,Nb,A,Lda,T,Ldt,C,Ldc,Work,&
     &                    Lwork,Info)
      IMPLICIT NONE
!*--ZLAMTSQR200
!
!  -- LAPACK computational routine (version 3.7.1) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     June 2017
!
!     .. Scalar Arguments ..
      CHARACTER Side , Trans
      INTEGER Info , Lda , M , N , K , Mb , Nb , Ldt , Lwork , Ldc
!     ..
!     .. Array Arguments ..
      COMPLEX*16 A(Lda,*) , Work(*) , C(Ldc,*) , T(Ldt,*)
!     ..
!
! =====================================================================
!
!     ..
!     .. Local Scalars ..
      LOGICAL left , right , tran , notran , lquery
      INTEGER i , ii , kk , lw , ctr
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      EXTERNAL LSAME
!     .. External Subroutines ..
      EXTERNAL ZGEMQRT , ZTPMQRT , XERBLA
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      lquery = Lwork<0
      notran = LSAME(Trans,'N')
      tran = LSAME(Trans,'C')
      left = LSAME(Side,'L')
      right = LSAME(Side,'R')
      IF ( left ) THEN
         lw = N*Nb
      ELSE
         lw = M*Nb
      ENDIF
!
      Info = 0
      IF ( .NOT.left .AND. .NOT.right ) THEN
         Info = -1
      ELSEIF ( .NOT.tran .AND. .NOT.notran ) THEN
         Info = -2
      ELSEIF ( M<0 ) THEN
         Info = -3
      ELSEIF ( N<0 ) THEN
         Info = -4
      ELSEIF ( K<0 ) THEN
         Info = -5
      ELSEIF ( Lda<MAX(1,K) ) THEN
         Info = -9
      ELSEIF ( Ldt<MAX(1,Nb) ) THEN
         Info = -11
      ELSEIF ( Ldc<MAX(1,M) ) THEN
         Info = -13
      ELSEIF ( (Lwork<MAX(1,lw)) .AND. (.NOT.lquery) ) THEN
         Info = -15
      ENDIF
!
!     Determine the block size if it is tall skinny or short and wide
!
      IF ( Info==0 ) Work(1) = lw
!
      IF ( Info/=0 ) THEN
         CALL XERBLA('ZLAMTSQR',-Info)
         RETURN
      ELSEIF ( lquery ) THEN
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( MIN(M,N,K)==0 ) RETURN
!
      IF ( (Mb<=K) .OR. (Mb>=MAX(M,N,K)) ) THEN
         CALL ZGEMQRT(Side,Trans,M,N,K,Nb,A,Lda,T,Ldt,C,Ldc,Work,Info)
         RETURN
      ENDIF
!
      IF ( left .AND. notran ) THEN
!
!         Multiply Q to the last block of C
!
         kk = MOD((M-K),(Mb-K))
         ctr = (M-K)/(Mb-K)
         IF ( kk>0 ) THEN
            ii = M - kk + 1
            CALL ZTPMQRT('L','N',kk,N,K,0,Nb,A(ii,1),Lda,T(1,ctr*K+1),  &
     &                   Ldt,C(1,1),Ldc,C(ii,1),Ldc,Work,Info)
         ELSE
            ii = M + 1
         ENDIF
!
         DO i = ii - (Mb-K) , Mb + 1 , -(Mb-K)
!
!         Multiply Q to the current block of C (I:I+MB,1:N)
!
            ctr = ctr - 1
            CALL ZTPMQRT('L','N',Mb-K,N,K,0,Nb,A(i,1),Lda,T(1,ctr*K+1), &
     &                   Ldt,C(1,1),Ldc,C(i,1),Ldc,Work,Info)

         ENDDO
!
!         Multiply Q to the first block of C (1:MB,1:N)
!
         CALL ZGEMQRT('L','N',Mb,N,K,Nb,A(1,1),Lda,T,Ldt,C(1,1),Ldc,    &
     &                Work,Info)
!
      ELSEIF ( left .AND. tran ) THEN
!
!         Multiply Q to the first block of C
!
         kk = MOD((M-K),(Mb-K))
         ii = M - kk + 1
         ctr = 1
         CALL ZGEMQRT('L','C',Mb,N,K,Nb,A(1,1),Lda,T,Ldt,C(1,1),Ldc,    &
     &                Work,Info)
!
         DO i = Mb + 1 , ii - Mb + K , (Mb-K)
!
!         Multiply Q to the current block of C (I:I+MB,1:N)
!
            CALL ZTPMQRT('L','C',Mb-K,N,K,0,Nb,A(i,1),Lda,T(1,ctr*K+1), &
     &                   Ldt,C(1,1),Ldc,C(i,1),Ldc,Work,Info)
            ctr = ctr + 1
!
         ENDDO
!
!         Multiply Q to the last block of C
!
!
         IF ( ii<=M ) CALL ZTPMQRT('L','C',kk,N,K,0,Nb,A(ii,1),Lda,     &
     &                             T(1,ctr*K+1),Ldt,C(1,1),Ldc,C(ii,1), &
     &                             Ldc,Work,Info)
!
      ELSEIF ( right .AND. tran ) THEN
!
!         Multiply Q to the last block of C
!
         kk = MOD((N-K),(Mb-K))
         ctr = (N-K)/(Mb-K)
         IF ( kk>0 ) THEN
            ii = N - kk + 1
            CALL ZTPMQRT('R','C',M,kk,K,0,Nb,A(ii,1),Lda,T(1,ctr*K+1),  &
     &                   Ldt,C(1,1),Ldc,C(1,ii),Ldc,Work,Info)
         ELSE
            ii = N + 1
         ENDIF
!
         DO i = ii - (Mb-K) , Mb + 1 , -(Mb-K)
!
!         Multiply Q to the current block of C (1:M,I:I+MB)
!
            ctr = ctr - 1
            CALL ZTPMQRT('R','C',M,Mb-K,K,0,Nb,A(i,1),Lda,T(1,ctr*K+1), &
     &                   Ldt,C(1,1),Ldc,C(1,i),Ldc,Work,Info)

         ENDDO
!
!         Multiply Q to the first block of C (1:M,1:MB)
!
         CALL ZGEMQRT('R','C',M,Mb,K,Nb,A(1,1),Lda,T,Ldt,C(1,1),Ldc,    &
     &                Work,Info)
!
      ELSEIF ( right .AND. notran ) THEN
!
!         Multiply Q to the first block of C
!
         kk = MOD((N-K),(Mb-K))
         ii = N - kk + 1
         ctr = 1
         CALL ZGEMQRT('R','N',M,Mb,K,Nb,A(1,1),Lda,T,Ldt,C(1,1),Ldc,    &
     &                Work,Info)
!
         DO i = Mb + 1 , ii - Mb + K , (Mb-K)
!
!         Multiply Q to the current block of C (1:M,I:I+MB)
!
            CALL ZTPMQRT('R','N',M,Mb-K,K,0,Nb,A(i,1),Lda,T(1,ctr*K+1), &
     &                   Ldt,C(1,1),Ldc,C(1,i),Ldc,Work,Info)
            ctr = ctr + 1
!
         ENDDO
!
!         Multiply Q to the last block of C
!
!
         IF ( ii<=N ) CALL ZTPMQRT('R','N',M,kk,K,0,Nb,A(ii,1),Lda,     &
     &                             T(1,ctr*K+1),Ldt,C(1,1),Ldc,C(1,ii), &
     &                             Ldc,Work,Info)
!
      ENDIF
!
      Work(1) = lw
!
!     End of ZLAMTSQR
!
      END SUBROUTINE ZLAMTSQR