# include "define.inc"

module ran
   ! <doc>
   !  A wrapper module for random number generator.
   !  Thie module provides real function ranf
   !  using intrinsic random_number/random_seed or
   !  Mersenne Twister 19937 (see mt19937.f90).
   !  Note that instrinsic function appears to use
   !  and integer vector seed of length 2, but this
   !  is implementation dependent.  If there is ever
   !  a system that uses seed integer vector of
   !  different length, an error message will print.
   ! </doc>

   implicit none

   private

   public :: ranf
   public :: get_rnd_seed_length, get_rnd_seed, init_ranf

contains

!-------------------------------------------------------------------
   function ranf(seed)

      ! <doc>
      !  returns a uniform deviate in [0., 1.)
      !  The generator is initialized with the given seed if exists,
      !  otherwise uses the default seed.
      ! </doc>

# if RANDOM == _RANMT_
      use mt19937, only: sgrnd, grnd
# endif
      integer, intent(in), optional :: seed
      real :: ranf
# if RANDOM == _RANMT_
      if (present(seed)) call sgrnd(seed)
      ranf = grnd()
# else
      integer :: l
      integer, allocatable :: seed_in(:)
      if (present(seed)) then
         call random_seed(size=l)
         allocate (seed_in(l))
         seed_in(:) = seed
         call random_seed(put=seed_in)
         deallocate (seed_in)
      end if
      call random_number(ranf)
# endif

   end function ranf
!-------------------------------------------------------------------
   function get_rnd_seed_length() result(l)
      ! <doc>
      !  get_rnd_seed_length gets the length of the integer vector for
      !      the random number generator seed
      ! </doc>
      integer :: l
# if RANDOM == _RANMT_
      l = 1
# else
      call random_seed(size=l)
# endif

   end function get_rnd_seed_length
!-------------------------------------------------------------------
   subroutine get_rnd_seed(seed)
      ! <doc>
      !  get_rnd_seed  random number seed integer vector
      ! </doc>
      integer, dimension(:), intent(out) :: seed
# if RANDOM == _RANMT_
      !NOTE: If MT is generator, more codding needs to be done to
      !      extract seed, so this should be run using only randomize
      seed = 0
# else
      call random_seed(get=seed)
# endif

   end subroutine get_rnd_seed
!-------------------------------------------------------------------
   subroutine init_ranf(randomize, init_seed, mult)
# if RANDOM == _RANMT_
      use mt19937, only: sgrnd, grnd
# endif
      ! <doc>
      !  init_ranf seeds the choosen random number generator.
      !  if randomize=T, a random seed based on the date and time is used.
      !  Otherwise, it sets the seed using init_seed
      !  In either case, it outputs the initial seed in init_seed
      ! </doc>
      implicit none
      logical, intent(in) :: randomize
      integer, intent(inout), dimension(:) :: init_seed
      integer, optional, intent(in) :: mult
      integer :: lmult = 1, clock
# if RANDOM == _RANMT_
      if (present(mult)) then
         lmult = mult
      end if

      if (randomize) then
         call system_clock(COUNT=clock)
         init_seed(1) = clock * lmult
         call sgrnd(init_seed(1))
      else
         call sgrnd(init_seed(1) * lmult)
      end if
# else
      integer :: i, n

      if (present(mult)) then
         lmult = mult
      end if

      if (randomize) then
         call random_seed(size=n)
         call system_clock(count=clock)

         init_seed = clock + 37 * lmult * (/(i - 1, i=1, n)/)
         call random_seed(put=init_seed)
      else
         call random_seed(put=init_seed * lmult)
      end if
# endif

   end subroutine init_ranf
end module ran


! RUN: bbc -emit-fir %s -o - | FileCheck %s
! RUN: %flang_fc1 -emit-fir %s -o - | FileCheck %s

! Test abs intrinsic for various types (int, float, complex)

! CHECK-LABEL: func @_QPabs_testi
! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<i32>{{.*}}, %[[VAL_1:.*]]: !fir.ref<i32>
subroutine abs_testi(a, b)
! CHECK:  %[[VAL_2:.*]] = fir.load %[[VAL_0]] : !fir.ref<i32>
! CHECK:  %[[VAL_3:.*]] = arith.constant 31 : i32
! CHECK:  %[[VAL_4:.*]] = arith.shrsi %[[VAL_2]], %[[VAL_3]] : i32
! CHECK:  %[[VAL_5:.*]] = arith.xori %[[VAL_2]], %[[VAL_4]] : i32
! CHECK:  %[[VAL_6:.*]] = arith.subi %[[VAL_5]], %[[VAL_4]] : i32
! CHECK:  fir.store %[[VAL_6]] to %[[VAL_1]] : !fir.ref<i32>
! CHECK:  return
  integer :: a, b
  b = abs(a)
end subroutine

! CHECK-LABEL: func @_QPabs_testi16
! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<i128>{{.*}}, %[[VAL_1:.*]]: !fir.ref<i128>
subroutine abs_testi16(a, b)
! CHECK:  %[[VAL_2:.*]] = fir.load %[[VAL_0]] : !fir.ref<i128>
! CHECK:  %[[VAL_3:.*]] = arith.constant 127 : i128
! CHECK:  %[[VAL_4:.*]] = arith.shrsi %[[VAL_2]], %[[VAL_3]] : i128
! CHECK:  %[[VAL_5:.*]] = arith.xori %[[VAL_2]], %[[VAL_4]] : i128
! CHECK:  %[[VAL_6:.*]] = arith.subi %[[VAL_5]], %[[VAL_4]] : i128
! CHECK:  fir.store %[[VAL_6]] to %[[VAL_1]] : !fir.ref<i128>
! CHECK:  return
  integer(kind=16) :: a, b
  b = abs(a)
end subroutine

! CHECK-LABEL: func @_QPabs_testh(
! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<f16>{{.*}}, %[[VAL_1:.*]]: !fir.ref<f16>{{.*}}) {
subroutine abs_testh(a, b)
! CHECK: %[[VAL_2:.*]] = fir.load %[[VAL_0]] : !fir.ref<f16>
! CHECK: %[[VAL_2_1:.*]] = fir.convert %[[VAL_2]] : (f16) -> f32
! CHECK: %[[VAL_3:.*]] = fir.call @llvm.fabs.f32(%[[VAL_2_1]]) : (f32) -> f32
! CHECK: %[[VAL_3_1:.*]] = fir.convert %[[VAL_3]] : (f32) -> f16
! CHECK: fir.store %[[VAL_3_1]] to %[[VAL_1]] : !fir.ref<f16>
! CHECK: return
  real(kind=2) :: a, b
  b = abs(a)
end subroutine

! CHECK-LABEL: func @_QPabs_testb(
! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<bf16>{{.*}}, %[[VAL_1:.*]]: !fir.ref<bf16>{{.*}}) {
subroutine abs_testb(a, b)
! CHECK: %[[VAL_2:.*]] = fir.load %[[VAL_0]] : !fir.ref<bf16>
! CHECK: %[[VAL_2_1:.*]] = fir.convert %[[VAL_2]] : (bf16) -> f32
! CHECK: %[[VAL_3:.*]] = fir.call @llvm.fabs.f32(%[[VAL_2_1]]) : (f32) -> f32
! CHECK: %[[VAL_3_1:.*]] = fir.convert %[[VAL_3]] : (f32) -> bf16
! CHECK: fir.store %[[VAL_3_1]] to %[[VAL_1]] : !fir.ref<bf16>
! CHECK: return
  real(kind=3) :: a, b
  b = abs(a)
end subroutine

! CHECK-LABEL: func @_QPabs_testr(
! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<f32>{{.*}}, %[[VAL_1:.*]]: !fir.ref<f32>{{.*}}) {
subroutine abs_testr(a, b)
! CHECK: %[[VAL_2:.*]] = fir.load %[[VAL_0]] : !fir.ref<f32>
! CHECK: %[[VAL_3:.*]] = fir.call @llvm.fabs.f32(%[[VAL_2]]) : (f32) -> f32
! CHECK: fir.store %[[VAL_3]] to %[[VAL_1]] : !fir.ref<f32>
! CHECK: return
  real :: a, b
  b = abs(a)
end subroutine

! CHECK-LABEL: func @_QPabs_testd(
! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<f64>{{.*}}, %[[VAL_1:.*]]: !fir.ref<f64>{{.*}}) {
subroutine abs_testd(a, b)
! CHECK: %[[VAL_2:.*]] = fir.load %[[VAL_0]] : !fir.ref<f64>
! CHECK: %[[VAL_3:.*]] = fir.call @llvm.fabs.f64(%[[VAL_2]]) : (f64) -> f64
! CHECK: fir.store %[[VAL_3]] to %[[VAL_1]] : !fir.ref<f64>
! CHECK: return
  real(kind=8) :: a, b
  b = abs(a)
end subroutine

! CHECK-LABEL: func @_QPabs_testzr(
! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<!fir.complex<4>>{{.*}}, %[[VAL_1:.*]]: !fir.ref<f32>{{.*}}) {
subroutine abs_testzr(a, b)
! CHECK:  %[[VAL_2:.*]] = fir.load %[[VAL_0]] : !fir.ref<!fir.complex<4>>
! CHECK:  %[[VAL_3:.*]] = fir.extract_value %[[VAL_2]], [0 : index] : (!fir.complex<4>) -> f32
! CHECK:  %[[VAL_4:.*]] = fir.extract_value %[[VAL_2]], [1 : index] : (!fir.complex<4>) -> f32
! CHECK:  %[[VAL_5:.*]] = fir.call @__mth_i_hypot(%[[VAL_3]], %[[VAL_4]]) : (f32, f32) -> f32
! CHECK:  fir.store %[[VAL_5]] to %[[VAL_1]] : !fir.ref<f32>
! CHECK:  return
  complex :: a
  real :: b
  b = abs(a)
end subroutine abs_testzr

! CHECK-LABEL: func @_QPabs_testzd(
! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<!fir.complex<8>>{{.*}}, %[[VAL_1:.*]]: !fir.ref<f64>{{.*}}) {
subroutine abs_testzd(a, b)
! CHECK:  %[[VAL_2:.*]] = fir.load %[[VAL_0]] : !fir.ref<!fir.complex<8>>
! CHECK:  %[[VAL_3:.*]] = fir.extract_value %[[VAL_2]], [0 : index] : (!fir.complex<8>) -> f64
! CHECK:  %[[VAL_4:.*]] = fir.extract_value %[[VAL_2]], [1 : index] : (!fir.complex<8>) -> f64
! CHECK:  %[[VAL_5:.*]] = fir.call @__mth_i_dhypot(%[[VAL_3]], %[[VAL_4]]) : (f64, f64) -> f64
! CHECK:  fir.store %[[VAL_5]] to %[[VAL_1]] : !fir.ref<f64>
! CHECK:  return
  complex(kind=8) :: a
  real(kind=8) :: b
  b = abs(a)
end subroutine abs_testzd


PROGRAM F020

    ! Copyright 2021 Melwyn Francis Carlo

    IMPLICIT NONE

    CHARACTER, DIMENSION(500) :: N_STR

    INTEGER :: SUM_OF_DIGITS = 0

    CHARACTER (LEN=3) :: TEMP_PRODUCT

    CHARACTER, DIMENSION(500,500) :: PRODUCTS_ARRAY

    INTEGER :: STR_LENGTH = 1

    INTEGER :: I, J, K, K1, K2, K3, TEMP_SUM

    N_STR(1) = '1'

    DO I = 2, 100

        DO J = STR_LENGTH, 1, -1

            WRITE(TEMP_PRODUCT, '(I0.3)') I * (IACHAR(N_STR(J)) - IACHAR('0'))

            DO K1 = 1, J
                PRODUCTS_ARRAY(J, K1) = '0'
            END DO

            DO K2 = (J + 1), (J + 3)
                PRODUCTS_ARRAY(J, K2) = TEMP_PRODUCT(K2-J:K2-J)
            END DO

            DO K3 = (J + 4), (STR_LENGTH + 3)
                PRODUCTS_ARRAY(J, K3) = '0'
            END DO

        END DO

        N_STR = '0'

        DO K = (STR_LENGTH + 3 - 1), 2, -1

            TEMP_SUM = 0
            DO J = 1, STR_LENGTH
                TEMP_SUM = TEMP_SUM + IACHAR(PRODUCTS_ARRAY(J, K+1)) - IACHAR('0')
            END DO
            TEMP_SUM = TEMP_SUM + IACHAR(N_STR(K)) - IACHAR('0')

            N_STR(K)   = ACHAR(MOD(TEMP_SUM, 10) + IACHAR('0'))
            N_STR(K-1) = ACHAR(FLOOR(REAL(TEMP_SUM) / 10.0) + IACHAR('0'))

        END DO

        STR_LENGTH = STR_LENGTH + 2

    END DO

    DO I = 1, STR_LENGTH
        SUM_OF_DIGITS = SUM_OF_DIGITS + IACHAR(N_STR(I)) - IACHAR('0')
    END DO

    PRINT ('(I0)'), SUM_OF_DIGITS

END PROGRAM F020


C     The two array are overlapped ?

      PROGRAM ALIAS
      REAL A(10000)
      M = 50
      CALL FOO(A,M)
      END

      SUBROUTINE FOO(X,N)
      REAL X(N,N)
      L = 20
      DO I=1,L
         DO J =1,L
            CALL TOTO(X(I,J),X(2*I,2*J),L)
         ENDDO
      ENDDO
      END

      SUBROUTINE TOTO(V1,V2,L)
      REAL V1(L,L),V2(L,L)

      DO I=1,L
         DO J =1,L
            V1(2*I-J,J+I)=I+J
         ENDDO
      ENDDO
      END


c     ====================================================================
      subroutine interfsmr(plmofz,
     >                     eta,rm,lmax,ndlm,mofj,lofj,clm,
     >                     xgs,wgs,ngauss_mad,ngaussr_mad,rdif,dqintl)
c     ====================================================================
c
c     ********************************************************************
c     integrate gaussian from 0 to  xi0
c     to get( error function)  divid by r to get
c     potential from gaussian adistance rdif from origin on z-axis
c     integrate over cos(theta) at a distance rm from origin to get dqintl
c     ********************************************************************
c
      implicit none
c
      integer lmax
c
      integer ndlm
      integer lofj(ndlm)
      integer mofj(ndlm)
      integer l
      integer m
      integer n
      integer j
      integer iz
      integer ngauss_mad
      integer ngaussr_mad
c
      real*8 clm(ndlm)
      real*8 plmofz(ndlm)
      real*8 fnpi
      real*8 rm
c
      real*8 xgs(ngauss_mad)
      real*8 wgs(ngauss_mad)
c
      real*8 dqintl(0:lmax)
      real*8 rssq
      real*8 eta
      real*8 xi
      real*8 xisq
      real*8 xi0
      real*8 arg
      real*8 sum
      real*8 zero
      real*8 half
      real*8 one
      real*8 rho2
      real*8 z
      real*8 rdif
      real*8 pi
      real*8 twopi
      real*8 two
      real*8 xg(ngaussr_mad),wg(ngaussr_mad)
      parameter (zero=0.0d0)
      parameter (half=0.5d0)
      parameter (one=1.0d0)
      parameter (two=2.0d0)
c    -------------------------------------------------------------------
      pi=fnpi()
      twopi=two*pi
      call zeroout(dqintl(0),lmax+1)
      xi0 = sqrt(eta)*half
!      call gauleg(zero,xi0,xg,wg,ngaussr_mad)
      call gauss_legendre_points(zero,xi0,xg,wg,ngaussr_mad)
c         loop over cos(theta)
      do iz=1,ngauss_mad
        z=xgs(iz)
            rho2=one-z*z
c           actual x*x+y*y
            rho2=rm*rm*rho2
c           distance from sphere to gaussian center at z=rdif
c           actual z determined by cos(theta) and rm
            rssq=(rdif-rm*z)**2+rho2
c           calculate potential at this distance
            sum=zero
            do n=1,ngaussr_mad
              xi=xg(n)
              xisq = xi * xi
              arg = - rssq*xisq
              sum = sum+exp(arg)*wg(n)
            enddo
c           potential for negative gaussian
c Don't divide by r because the integral was rescaled from (0,r*xi0)
c to (0,xi0) thus missing a factor of r.
            sum=-sum*two/sqrt(pi)
	    sum=wgs(iz)*sum*twopi
c     get legendre polynomials on z=cos(theta) grid
! meis: changed to normalized associated Legendre functions
        call plm_normalized(lmax,z,plmofz)
c    -------------------------------------------------------------------
c     loop over L
        do j=1,ndlm
          m=mofj(j)
c       only m=0 contributes
          if(m.eq.0)then
            l=lofj(j)
c           potential for negative gaussian plus delta funtion
            dqintl(l) = dqintl(l)+clm(j)*plmofz(j)*sum
          endif
        enddo
      enddo
      return
c
      end


      SUBROUTINE IB01CD( JOBX0, COMUSE, JOB, N, M, L, NSMP, A, LDA, B,
     $                   LDB, C, LDC, D, LDD, U, LDU, Y, LDY, X0, V,
     $                   LDV, TOL, IWORK, DWORK, LDWORK, IWARN, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To estimate the initial state and, optionally, the system matrices
C     B  and  D  of a linear time-invariant (LTI) discrete-time system,
C     given the system matrices  (A,B,C,D),  or (when  B  and  D  are
C     estimated) only the matrix pair  (A,C),  and the input and output
C     trajectories of the system. The model structure is :
C
C           x(k+1) = Ax(k) + Bu(k),   k >= 0,
C           y(k)   = Cx(k) + Du(k),
C
C     where  x(k)  is the  n-dimensional state vector (at time k),
C            u(k)  is the  m-dimensional input vector,
C            y(k)  is the  l-dimensional output vector,
C     and  A, B, C, and D  are real matrices of appropriate dimensions.
C     The input-output data can internally be processed sequentially.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOBX0   CHARACTER*1
C             Specifies whether or not the initial state should be
C             computed, as follows:
C             = 'X':  compute the initial state x(0);
C             = 'N':  do not compute the initial state (possibly,
C                     because x(0) is known to be zero).
C
C     COMUSE  CHARACTER*1
C             Specifies whether the system matrices B and D should be
C             computed or used, as follows:
C             = 'C':  compute the system matrices B and D, as specified
C                     by JOB;
C             = 'U':  use the system matrices B and D, as specified by
C                     JOB;
C             = 'N':  do not compute/use the matrices B and D.
C             If  JOBX0 = 'N'  and  COMUSE <> 'N',  then  x(0)  is set
C             to zero.
C             If  JOBX0 = 'N'  and  COMUSE =  'N',  then  x(0)  is
C             neither computed nor set to zero.
C
C     JOB     CHARACTER*1
C             If  COMUSE = 'C'  or  'U',  specifies which of the system
C             matrices  B and D  should be computed or used, as follows:
C             = 'B':  compute/use the matrix B only (D is known to be
C                     zero);
C             = 'D':  compute/use the matrices B and D.
C             The value of  JOB  is irrelevant if  COMUSE = 'N'  or if
C             JOBX0 = 'N'  and  COMUSE = 'U'.
C             The combinations of options, the data used, and the
C             returned results, are given in the table below, where
C             '*'  denotes an irrelevant value.
C
C              JOBX0   COMUSE    JOB     Data used    Returned results
C             ----------------------------------------------------------
C                X       C        B       A,C,u,y          x,B
C                X       C        D       A,C,u,y          x,B,D
C                N       C        B       A,C,u,y          x=0,B
C                N       C        D       A,C,u,y          x=0,B,D
C             ----------------------------------------------------------
C                X       U        B      A,B,C,u,y            x
C                X       U        D      A,B,C,D,u,y          x
C                N       U        *          -               x=0
C             ----------------------------------------------------------
C                X       N        *        A,C,y              x
C                N       N        *          -                -
C             ----------------------------------------------------------
C
C             For  JOBX0 = 'N'  and  COMUSE = 'N',  the routine just
C             sets  DWORK(1)  to 2 and  DWORK(2)  to 1, and returns
C             (see the parameter DWORK).
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the system.  N >= 0.
C
C     M       (input) INTEGER
C             The number of system inputs.  M >= 0.
C
C     L       (input) INTEGER
C             The number of system outputs.  L > 0.
C
C     NSMP    (input) INTEGER
C             The number of rows of matrices  U  and  Y  (number of
C             samples,  t).
C             NSMP >= 0,            if  JOBX0 = 'N'  and  COMUSE <> 'C';
C             NSMP >= N,            if  JOBX0 = 'X'  and  COMUSE <> 'C';
C             NSMP >= N*M + a + e,  if  COMUSE = 'C',
C             where   a = 0,  if  JOBX0 = 'N';
C                     a = N,  if  JOBX0 = 'X';
C                     e = 0,  if  JOBX0 = 'X'  and  JOB = 'B';
C                     e = 1,  if  JOBX0 = 'N'  and  JOB = 'B';
C                     e = M,  if  JOB   = 'D'.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             If  JOBX0 = 'X'  or  COMUSE = 'C',  the leading N-by-N
C             part of this array must contain the system state matrix A.
C             If  N = 0,  or  JOBX0 = 'N'  and  COMUSE <> 'C',  this
C             array is not referenced.
C
C     LDA     INTEGER
C             The leading dimension of the array A.
C             LDA >= MAX(1,N),  if  JOBX0 = 'X'  or   COMUSE =  'C';
C             LDA >= 1,         if  JOBX0 = 'N'  and  COMUSE <> 'C'.
C
C     B       (input or output) DOUBLE PRECISION array, dimension
C             (LDB,M)
C             If  JOBX0 = 'X'  and  COMUSE = 'U',  B  is an input
C             parameter and, on entry, the leading N-by-M part of this
C             array must contain the system input matrix  B.
C             If  COMUSE = 'C',  B  is an output parameter and, on exit,
C             if  INFO = 0,  the leading N-by-M part of this array
C             contains the estimated system input matrix  B.
C             If  min(N,M) = 0,  or  JOBX0 = 'N'  and  COMUSE = 'U',
C             or  COMUSE = 'N',  this array is not referenced.
C
C     LDB     INTEGER
C             The leading dimension of the array B.
C             LDB >= MAX(1,N),  if  M > 0,  COMUSE = 'U',  JOBX0 = 'X',
C                               or  M > 0,  COMUSE = 'C';
C             LDB >= 1,         if  min(N,M) = 0,  or  COMUSE = 'N',
C                               or  JOBX0  = 'N'  and  COMUSE = 'U'.
C
C     C       (input) DOUBLE PRECISION array, dimension (LDC,N)
C             If  JOBX0 = 'X'  or  COMUSE = 'C',  the leading L-by-N
C             part of this array must contain the system output
C             matrix  C.
C             If  N = 0,  or  JOBX0 = 'N'  and  COMUSE <> 'C',  this
C             array is not referenced.
C
C     LDC     INTEGER
C             The leading dimension of the array C.
C             LDC >= L,  if  N > 0, and  JOBX0 = 'X'  or  COMUSE = 'C';
C             LDC >= 1,  if  N = 0, or  JOBX0 = 'N'  and  COMUSE <> 'C'.
C
C     D       (input or output) DOUBLE PRECISION array, dimension
C             (LDD,M)
C             If  JOBX0 = 'X',  COMUSE = 'U',  and  JOB = 'D',  D  is an
C             input parameter and, on entry, the leading L-by-M part of
C             this array must contain the system input-output matrix  D.
C             If  COMUSE = 'C'  and  JOB = 'D',  D  is an output
C             parameter and, on exit, if  INFO = 0,  the leading
C             L-by-M part of this array contains the estimated system
C             input-output matrix  D.
C             If  M = 0,  or  JOBX0 = 'N'  and  COMUSE = 'U',  or
C             COMUSE = 'N',  or  JOB = 'B',  this array is not
C             referenced.
C
C     LDD     INTEGER
C             The leading dimension of the array D.
C             LDD >= L,  if  M > 0,   JOBX0 = 'X',  COMUSE = 'U',  and
C                                                   JOB = 'D',  or
C                        if  M > 0,  COMUSE = 'C',  and  JOB = 'D';
C             LDD >= 1,  if  M = 0,  or  JOBX0 = 'N'  and  COMUSE = 'U',
C                        or  COMUSE = 'N',  or  JOB = 'B'.
C
C     U       (input or input/output) DOUBLE PRECISION array, dimension
C             (LDU,M)
C             On entry, if  COMUSE = 'C',  or  JOBX0 = 'X'  and
C             COMUSE = 'U',  the leading NSMP-by-M part of this array
C             must contain the t-by-m input-data sequence matrix  U,
C             U = [u_1 u_2 ... u_m].  Column  j  of  U  contains the
C             NSMP  values of the j-th input component for consecutive
C             time increments.
C             On exit, if  COMUSE = 'C'  and  JOB = 'D',  the leading
C             NSMP-by-M part of this array contains details of the
C             QR factorization of the t-by-m matrix  U,  possibly
C             computed sequentially (see METHOD).
C             If  COMUSE = 'C'  and  JOB = 'B',  or  COMUSE = 'U',  this
C             array is unchanged on exit.
C             If  M = 0,  or  JOBX0 = 'N'  and  COMUSE = 'U',  or
C             COMUSE = 'N',  this array is not referenced.
C
C     LDU     INTEGER
C             The leading dimension of the array U.
C             LDU >= MAX(1,NSMP),  if  M > 0    and  COMUSE = 'C'  or
C                                  JOBX0 = 'X'  and  COMUSE = 'U;
C             LDU >= 1,            if  M = 0,   or   COMUSE = 'N',  or
C                                  JOBX0 = 'N'  and  COMUSE = 'U'.
C
C     Y       (input) DOUBLE PRECISION array, dimension (LDY,L)
C             On entry, if  JOBX0 = 'X'  or  COMUSE = 'C',  the leading
C             NSMP-by-L part of this array must contain the t-by-l
C             output-data sequence matrix  Y,  Y = [y_1 y_2 ... y_l].
C             Column  j  of  Y  contains the  NSMP  values of the j-th
C             output component for consecutive time increments.
C             If  JOBX0 = 'N'  and  COMUSE <> 'C',  this array is not
C             referenced.
C
C     LDY     INTEGER
C             The leading dimension of the array Y.
C             LDY >= MAX(1,NSMP),  if  JOBX0 = 'X'  or   COMUSE = 'C;
C             LDY >= 1,            if  JOBX0 = 'N'  and  COMUSE <> 'C'.
C
C     X0      (output) DOUBLE PRECISION array, dimension (N)
C             If  INFO = 0  and  JOBX0 = 'X',  this array contains the
C             estimated initial state of the system,  x(0).
C             If  JOBX0 = 'N'  and  COMUSE = 'C',  this array is used as
C             workspace and finally it is set to zero.
C             If  JOBX0 = 'N'  and  COMUSE = 'U',  then  x(0)  is set to
C             zero without any calculations.
C             If  JOBX0 = 'N'  and  COMUSE = 'N',  this array is not
C             referenced.
C
C     V       (output) DOUBLE PRECISION array, dimension (LDV,N)
C             On exit, if  INFO = 0  or 2,  JOBX0 = 'X'  or
C             COMUSE = 'C',  the leading N-by-N part of this array
C             contains the orthogonal matrix V of a real Schur
C             factorization of the matrix  A.
C             If  JOBX0 = 'N'  and  COMUSE <> 'C',  this array is not
C             referenced.
C
C     LDV     INTEGER
C             The leading dimension of the array V.
C             LDV >= MAX(1,N),  if  JOBX0 = 'X'  or   COMUSE =  'C;
C             LDV >= 1,         if  JOBX0 = 'N'  and  COMUSE <> 'C'.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The tolerance to be used for estimating the rank of
C             matrices. If the user sets  TOL > 0,  then the given value
C             of  TOL  is used as a lower bound for the reciprocal
C             condition number;  a matrix whose estimated condition
C             number is less than  1/TOL  is considered to be of full
C             rank.  If the user sets  TOL <= 0,  then  EPS  is used
C             instead, where  EPS  is the relative machine precision
C             (see LAPACK Library routine DLAMCH).  TOL <= 1.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (LIWORK), where
C             LIWORK >= 0,          if  JOBX0 = 'N'  and  COMUSE <> 'C';
C             LIWORK >= N,          if  JOBX0 = 'X'  and  COMUSE <> 'C';
C             LIWORK >= N*M + a,        if COMUSE = 'C' and JOB = 'B',
C             LIWORK >= max(N*M + a,M), if COMUSE = 'C' and JOB = 'D',
C             with  a = 0,  if  JOBX0 = 'N';
C                   a = N,  if  JOBX0 = 'X'.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if  INFO = 0,  DWORK(1) returns the optimal value
C             of LDWORK;  DWORK(2)  contains the reciprocal condition
C             number of the triangular factor of the QR factorization of
C             the matrix  W2,  if  COMUSE = 'C',  or of the matrix
C             Gamma,  if  COMUSE = 'U'  (see METHOD); if  JOBX0 = 'N'
C             and  COMUSE <> 'C',  DWORK(2)  is set to one;
C             if  COMUSE = 'C',  M > 0,  and  JOB = 'D',   DWORK(3)
C             contains the reciprocal condition number of the triangular
C             factor of the QR factorization of  U;  denoting
C                g = 2,  if  JOBX0  = 'X'  and  COMUSE <> 'C'  or
C                            COMUSE = 'C'  and  M = 0  or   JOB = 'B',
C                g = 3,  if  COMUSE = 'C'  and  M > 0  and  JOB = 'D',
C             then  DWORK(i), i = g+1:g+N*N,
C                   DWORK(j), j = g+1+N*N:g+N*N+L*N,  and
C                   DWORK(k), k = g+1+N*N+L*N:g+N*N+L*N+N*M,
C             contain the transformed system matrices  At, Ct, and Bt,
C             respectively, corresponding to the real Schur form of the
C             given system state matrix  A,  i.e.,
C                At = V'*A*V,  Bt = V'*B,  Ct = C*V.
C             The matrices  At, Ct, Bt  are not computed if  JOBX0 = 'N'
C             and  COMUSE <> 'C'.
C             On exit, if  INFO = -26,  DWORK(1)  returns the minimum
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= 2,  if  JOBX0 = 'N'  and  COMUSE <> 'C',  or
C                           if  max( N, M ) = 0.
C             Otherwise,
C             LDWORK >= LDW1 + N*( N + M + L ) +
C                              max( 5*N, LDW1, min( LDW2, LDW3 ) ),
C             where, if  COMUSE = 'C',  then
C             LDW1 = 2,          if  M = 0  or   JOB = 'B',
C             LDW1 = 3,          if  M > 0  and  JOB = 'D',
C             LDWa = t*L*(r + 1) + max( N + max( d, f ), 6*r ),
C             LDW2 = LDWa,       if  M = 0  or  JOB = 'B',
C             LDW2 = max( LDWa, t*L*(r + 1) + 2*M*M + 6*M ),
C                                if  M > 0  and JOB = 'D',
C             LDWb = (b + r)*(r + 1) +
C                     max( q*(r + 1) + N*N*M + c + max( d, f ), 6*r ),
C             LDW3 = LDWb,       if  M = 0  or  JOB = 'B',
C             LDW3 = max( LDWb, (b + r)*(r + 1) + 2*M*M + 6*M ),
C                                if  M > 0  and JOB = 'D',
C                r = N*M + a,
C                a = 0,                  if  JOBX0 = 'N',
C                a = N,                  if  JOBX0 = 'X';
C                b = 0,                  if  JOB   = 'B',
C                b = L*M,                if  JOB   = 'D';
C                c = 0,                  if  JOBX0 = 'N',
C                c = L*N,                if  JOBX0 = 'X';
C                d = 0,                  if  JOBX0 = 'N',
C                d = 2*N*N + N,          if  JOBX0 = 'X';
C                f = 2*r,                if  JOB   = 'B'   or  M = 0,
C                f = M + max( 2*r, M ),  if  JOB   = 'D'  and  M > 0;
C                q = b + r*L;
C             and, if  JOBX0 = 'X'  and  COMUSE <> 'C',  then
C             LDW1 = 2,
C             LDW2 = t*L*(N + 1) + 2*N + max( 2*N*N, 4*N ),
C             LDW3 = N*(N + 1) + 2*N + max( q*(N + 1) + 2*N*N + L*N,
C                                           4*N ),
C                q = N*L.
C             For good performance,  LDWORK  should be larger.
C             If  LDWORK >= LDW2,  or if  COMUSE = 'C'  and
C                 LDWORK >= t*L*(r + 1) + (b + r)*(r + 1) + N*N*M + c +
C                           max( d, f ),
C             then standard QR factorizations of the matrices  U  and/or
C             W2,  if  COMUSE = 'C',  or of the matrix  Gamma,  if
C             JOBX0 = 'X'  and  COMUSE <> 'C'  (see METHOD), are used.
C             Otherwise, the QR factorizations are computed sequentially
C             by performing  NCYCLE  cycles, each cycle (except possibly
C             the last one) processing  s < t  samples, where  s  is
C             chosen by equating  LDWORK  to the first term of  LDWb,
C             if  COMUSE = 'C',  or of  LDW3,  if  COMUSE <> 'C',  for
C             q  replaced by  s*L.  (s  is larger than or equal to the
C             minimum value of  NSMP.)  The computational effort may
C             increase and the accuracy may slightly decrease with the
C             decrease of  s.  Recommended value is  LDWORK = LDW2,
C             assuming a large enough cache size, to also accommodate
C             A,  (B,)  C,  (D,)  U,  and  Y.
C
C     Warning Indicator
C
C     IWARN   INTEGER
C             = 0:  no warning;
C             = 4:  the least squares problem to be solved has a
C                   rank-deficient coefficient matrix;
C             = 6:  the matrix  A  is unstable;  the estimated  x(0)
C                   and/or  B and D  could be inaccurate.
C             NOTE: the value 4 of  IWARN  has no significance for the
C                   identification problem.
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 QR algorithm failed to compute all the
C                   eigenvalues of the matrix A (see LAPACK Library
C                   routine DGEES); the locations  DWORK(i),  for
C                   i = g+1:g+N*N,  contain the partially converged
C                   Schur form;
C             = 2:  the singular value decomposition (SVD) algorithm did
C                   not converge.
C
C     METHOD
C
C     Matrix  A  is initially reduced to a real Schur form, A = V*At*V',
C     and the given system matrices are transformed accordingly. For the
C     reduced system, an extension and refinement of the method in [1,2]
C     is used. Specifically, for  JOBX0 = 'X',  COMUSE = 'C',  and
C     JOB = 'D',  denoting
C
C           X = [ vec(D')' vec(B)' x0' ]',
C
C     where  vec(M)  is the vector obtained by stacking the columns of
C     the matrix  M,  then  X  is the least squares solution of the
C     system  S*X = vec(Y),  with the matrix  S = [ diag(U)  W ],
C     defined by
C
C           ( U         |     | ... |     |     | ... |     |         )
C           (   U       |  11 | ... |  n1 |  12 | ... |  nm |         )
C       S = (     :     | y   | ... | y   | y   | ... | y   | P*Gamma ),
C           (       :   |     | ... |     |     | ... |     |         )
C           (         U |     | ... |     |     | ... |     |         )
C                                                                     ij
C     diag(U)  having  L  block rows and columns.  In this formula,  y
C     are the outputs of the system for zero initial state computed
C     using the following model, for j = 1:m, and for i = 1:n,
C            ij          ij                    ij
C           x  (k+1) = Ax  (k) + e_i u_j(k),  x  (0) = 0,
C
C            ij          ij
C           y  (k)   = Cx  (k),
C
C     where  e_i  is the i-th n-dimensional unit vector,  Gamma  is
C     given by
C
C                (     C     )
C                (    C*A    )
C        Gamma = (   C*A^2   ),
C                (     :     )
C                ( C*A^(t-1) )
C
C     and  P  is a permutation matrix that groups together the rows of
C     Gamma  depending on the same row of  C,  namely
C     [ c_j;  c_j*A;  c_j*A^2; ...  c_j*A^(t-1) ],  for j = 1:L.
C     The first block column,  diag(U),  is not explicitly constructed,
C     but its structure is exploited. The last block column is evaluated
C     using powers of A with exponents 2^k. No interchanges are applied.
C     A special QR decomposition of the matrix  S  is computed. Let
C     U = q*[ r' 0 ]'  be the QR decomposition of  U,  if  M > 0,  where
C     r  is  M-by-M.   Then,  diag(q')  is applied to  W  and  vec(Y).
C     The block-rows of  S  and  vec(Y)  are implicitly permuted so that
C     matrix  S  becomes
C
C        ( diag(r)  W1 )
C        (    0     W2 ),
C
C     where  W1  has L*M rows. Then, the QR decomposition of  W2 is
C     computed (sequentially, if  M > 0) and used to obtain  B  and  x0.
C     The intermediate results and the QR decomposition of  U  are
C     needed to find  D.  If a triangular factor is too ill conditioned,
C     then singular value decomposition (SVD) is employed. SVD is not
C     generally needed if the input sequence is sufficiently
C     persistently exciting and  NSMP  is large enough.
C     If the matrix  W  cannot be stored in the workspace (i.e.,
C     LDWORK < LDW2),  the QR decompositions of  W2  and  U  are
C     computed sequentially.
C     For  JOBX0 = 'N'  and  COMUSE = 'C',  or  JOB = 'B',  a simpler
C     problem is solved efficiently.
C
C     For  JOBX0 = 'X'  and  COMUSE <> 'C',  a simpler method is used.
C     Specifically, the output y0(k) of the system for zero initial
C     state is computed for k = 0, 1, ...,  t-1 using the given model.
C     Then the following least squares problem is solved for x(0)
C
C                         (   y(0) - y0(0)   )
C                         (   y(1) - y0(1)   )
C        Gamma * x(0)  =  (        :         ).
C                         (        :         )
C                         ( y(t-1) - y0(t-1) )
C
C     The coefficient matrix  Gamma  is evaluated using powers of A with
C     exponents 2^k. The QR decomposition of this matrix is computed.
C     If its triangular factor  R  is too ill conditioned, then singular
C     value decomposition of  R  is used.
C     If the coefficient matrix cannot be stored in the workspace (i.e.,
C     LDWORK < LDW2),  the QR decomposition is computed sequentially.
C
C
C     REFERENCES
C
C     [1] Verhaegen M., and Varga, A.
C         Some Experience with the MOESP Class of Subspace Model
C         Identification Methods in Identifying the BO105 Helicopter.
C         Report TR R165-94, DLR Oberpfaffenhofen, 1994.
C
C     [2] Sima, V., and Varga, A.
C         RASP-IDENT : Subspace Model Identification Programs.
C         Deutsche Forschungsanstalt fur Luft- und Raumfahrt e. V.,
C         Report TR R888-94, DLR Oberpfaffenhofen, Oct. 1994.
C
C     NUMERICAL ASPECTS
C
C     The implemented method is numerically stable.
C
C     FURTHER COMMENTS
C
C     The algorithm for computing the system matrices  B  and  D  is
C     less efficient than the MOESP or N4SID algorithms implemented in
C     SLICOT Library routines IB01BD/IB01PD, because a large least
C     squares problem has to be solved, but the accuracy is better, as
C     the computed matrices  B  and  D  are fitted to the input and
C     output trajectories. However, if matrix  A  is unstable, the
C     computed matrices  B  and  D  could be inaccurate.
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Identification methods; least squares solutions; multivariable
C     systems; QR decomposition; singular value decomposition.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO, THREE
      PARAMETER          ( ZERO  = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
     $                     THREE = 3.0D0 )
C     .. Scalar Arguments ..
      DOUBLE PRECISION   TOL
      INTEGER            INFO, IWARN, L, LDA, LDB, LDC, LDD, LDU, LDV,
     $                   LDWORK, LDY, M, N, NSMP
      CHARACTER          COMUSE, JOB, JOBX0
C     .. Array Arguments ..
      DOUBLE PRECISION   A(LDA, *), B(LDB, *), C(LDC, *), D(LDD, *),
     $                   DWORK(*),  U(LDU, *), V(LDV, *), X0(*),
     $                   Y(LDY, *)
      INTEGER            IWORK(*)
C     .. Local Scalars ..
      DOUBLE PRECISION   RCOND, RCONDU
      INTEGER            I, IA, IB, IC, IERR, IQ, ISIZE, ITAU, IWARNL,
     $                   IWI, IWR, JWORK, LDW, LDW2, LDW3, LM, LN,
     $                   MAXWRK, MINSMP, MINWLS, MINWRK, MTMP, N2M,
     $                   NCOL, NCP1, NM, NN, NSMPL
      LOGICAL            COMPBD, USEBD, MAXDIA, MAXDIM, WITHB, WITHD,
     $                   WITHX0
      CHARACTER          JOBD
C     .. Local Arrays ..
      DOUBLE PRECISION   DUM(1)
C     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      DOUBLE PRECISION   DLAMCH, DLAPY2
      EXTERNAL           DLAMCH, DLAPY2, ILAENV, LSAME
C     .. External Subroutines ..
      EXTERNAL           DCOPY, DGEMM, DGEMV, DLACPY, IB01QD, IB01RD,
     $                   TB01WD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          INT, MAX, MIN
C     .. Executable Statements ..
C
C     Check the input parameters.
C
      WITHX0 = LSAME( JOBX0,  'X' )
      COMPBD = LSAME( COMUSE, 'C' )
      USEBD  = LSAME( COMUSE, 'U' )
      WITHD  = LSAME( JOB,    'D' )
      WITHB  = LSAME( JOB,    'B' )   .OR. WITHD
      MAXDIM = ( WITHX0 .AND. USEBD ) .OR. COMPBD
      MAXDIA = WITHX0 .OR. COMPBD
C
      IWARN = 0
      INFO  = 0
      LDW   = MAX( 1, N )
      LM    = L*M
      LN    = L*N
      NN    = N*N
      NM    = N*M
      N2M   = N*NM
      IF( COMPBD ) THEN
         NCOL = NM
         IF( WITHX0 )
     $      NCOL = NCOL + N
         MINSMP = NCOL
         IF( WITHD ) THEN
            MINSMP = MINSMP + M
            IQ     = MINSMP
         ELSE IF ( .NOT.WITHX0 ) THEN
            IQ     = MINSMP
            MINSMP = MINSMP + 1
         ELSE
            IQ     = MINSMP
         END IF
      ELSE
         NCOL = N
         IF( WITHX0 ) THEN
            MINSMP = N
         ELSE
            MINSMP = 0
         END IF
         IQ = MINSMP
      END IF
C
      IF( .NOT.( WITHX0 .OR. LSAME( JOBX0, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( COMPBD .OR. USEBD .OR. LSAME( COMUSE, 'N' ) ) )
     $      THEN
         INFO = -2
      ELSE IF( .NOT.WITHB ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( M.LT.0 ) THEN
         INFO = -5
      ELSE IF( L.LE.0 ) THEN
         INFO = -6
      ELSE IF( NSMP.LT.MINSMP ) THEN
         INFO = -7
      ELSE IF( LDA.LT.1 .OR. ( MAXDIA .AND. LDA.LT.LDW ) ) THEN
         INFO = -9
      ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. MAXDIM .AND. LDB.LT.LDW ) )
     $      THEN
         INFO = -11
      ELSE IF( LDC.LT.1 .OR. ( N.GT.0 .AND. MAXDIA .AND. LDC.LT.L ) )
     $      THEN
         INFO = -13
      ELSE IF( LDD.LT.1 .OR. ( M.GT.0 .AND. MAXDIM .AND. WITHD .AND.
     $         LDD.LT.L ) ) THEN
         INFO = -15
      ELSE IF( LDU.LT.1 .OR. ( M.GT.0 .AND. MAXDIM .AND. LDU.LT.NSMP ) )
     $      THEN
         INFO = -17
      ELSE IF( LDY.LT.1 .OR. ( MAXDIA .AND. LDY.LT.NSMP ) ) THEN
         INFO = -19
      ELSE IF( LDV.LT.1 .OR. ( MAXDIA .AND. LDV.LT.LDW ) ) THEN
         INFO = -22
      ELSE IF( TOL.GT.ONE ) THEN
         INFO = -23
      END IF
C
C     Compute workspace.
C      (Note: Comments in the code beginning "Workspace:" describe the
C       minimal amount of workspace needed at that point in the code,
C       as well as the preferred amount for good performance.
C       NB refers to the optimal block size for the immediately
C       following subroutine, as returned by ILAENV.)
C
      IF ( .NOT.MAXDIA .OR. MAX( N, M ).EQ.0 ) THEN
         MINWRK = 2
      ELSE
         NSMPL = NSMP*L
         IQ    = IQ*L
         NCP1  = NCOL + 1
         ISIZE = NSMPL*NCP1
         IF ( COMPBD ) THEN
            IF ( N.GT.0 .AND. WITHX0 ) THEN
               IC = 2*NN + N
            ELSE
               IC = 0
            END IF
         ELSE
            IC = 2*NN
         END IF
         MINWLS = NCOL*NCP1
         IF ( COMPBD ) THEN
            IF ( WITHD )
     $         MINWLS = MINWLS + LM*NCP1
            IF ( M.GT.0 .AND. WITHD ) THEN
               IA = M + MAX( 2*NCOL, M )
            ELSE
               IA = 2*NCOL
            END IF
            ITAU = N2M + MAX( IC, IA )
            IF ( WITHX0 )
     $         ITAU = ITAU + LN
            LDW2 = ISIZE  + MAX( N + MAX( IC, IA ), 6*NCOL )
            LDW3 = MINWLS + MAX( IQ*NCP1 + ITAU, 6*NCOL )
            IF ( M.GT.0 .AND. WITHD ) THEN
               LDW2 = MAX( LDW2, ISIZE  + 2*M*M + 6*M )
               LDW3 = MAX( LDW3, MINWLS + 2*M*M + 6*M )
               IA   = 3
            ELSE
               IA = 2
            END IF
         ELSE
            ITAU = IC + LN
            LDW2 = ISIZE  + 2*N + MAX( IC, 4*N )
            LDW3 = MINWLS + 2*N + MAX( IQ*NCP1 + ITAU, 4*N )
            IA   = 2
         END IF
         MINWRK = IA + NN + NM + LN + MAX( 5*N, IA, MIN( LDW2, LDW3 ) )
C
         IF ( INFO.EQ.0 .AND. LDWORK.GE.MINWRK ) THEN
            MAXWRK = MAX( 5*N, IA )
            IF ( COMPBD ) THEN
               IF ( M.GT.0 .AND. WITHD ) THEN
                  MAXWRK = MAX( MAXWRK, ISIZE + N + M +
     $                          MAX( M*ILAENV( 1, 'DGEQRF', ' ', NSMP,
     $                                         M, -1, -1 ),
     $                               NCOL + NCOL*ILAENV( 1, 'DGEQRF',
     $                                   ' ', NSMP-M, NCOL, -1, -1 ) ) )
                  MAXWRK = MAX( MAXWRK, ISIZE + N + M +
     $                          MAX( NCP1*ILAENV( 1, 'DORMQR', 'LT',
     $                                            NSMP, NCP1, M, -1 ),
     $                               NCOL + ILAENV( 1, 'DORMQR', 'LT',
     $                                         NSMP-M, 1, NCOL, -1 ) ) )
               ELSE
                  MAXWRK = MAX( MAXWRK, ISIZE + N + NCOL +
     $                                  MAX( NCOL*ILAENV( 1, 'DGEQRF',
     $                                       ' ', NSMPL, NCOL, -1, -1 ),
     $                                       ILAENV( 1, 'DORMQR', 'LT',
     $                                          NSMPL, 1, NCOL, -1 ) ) )
               END IF
            ELSE
               MAXWRK = MAX( MAXWRK, ISIZE + 2*N +
     $                               MAX( N*ILAENV( 1, 'DGEQRF', ' ',
     $                                              NSMPL, N, -1, -1 ),
     $                                    ILAENV( 1, 'DORMQR', 'LT',
     $                                            NSMPL, 1, N, -1 ) ) )
            END IF
            MAXWRK = IA + NN + NM + LN + MAXWRK
            MAXWRK = MAX( MAXWRK, MINWRK )
         END IF
      END IF
C
      IF ( INFO.EQ.0 .AND. LDWORK.LT.MINWRK ) THEN
         INFO = -26
         DWORK(1) = MINWRK
      END IF
C
C     Return if there are illegal arguments.
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'IB01CD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( .NOT.MAXDIA .OR. MAX( N, M ).EQ.0 ) THEN
         DWORK(2) = ONE
         IF ( COMPBD .AND. M.GT.0 .AND. WITHD ) THEN
            DWORK(1) = THREE
            DWORK(3) = ONE
         ELSE
            DWORK(1) = TWO
         END IF
         IF ( N.GT.0 .AND. USEBD ) THEN
            DUM(1) = ZERO
            CALL DCOPY( N, DUM, 0, X0, 1 )
         END IF
         RETURN
      END IF
C
C     Compute the Schur factorization of  A  and transform the other
C     given system matrices accordingly.
C     Workspace:  need   g + N*N + L*N + N*M + 5*N,  where
C                        g = 2,  if  M = 0, COMUSE = 'C', or  JOB = 'B',
C                        g = 3,  if  M > 0, COMUSE = 'C', and JOB = 'D',
C                        g = 2,  if  JOBX0 = 'X'  and  COMUSE <> 'C';
C                 prefer larger.
C
      IA = IA + 1
      IC = IA + NN
      IB = IC + LN
      CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IA), LDW )
      CALL DLACPY( 'Full', L, N, C, LDC, DWORK(IC), L )
C
      IF ( USEBD ) THEN
         MTMP = M
         CALL DLACPY( 'Full', N, M, B, LDB, DWORK(IB), LDW )
      ELSE
         MTMP = 0
      END IF
      IWR   = IB  + NM
      IWI   = IWR + N
      JWORK = IWI + N
C
      CALL TB01WD( N, MTMP, L, DWORK(IA), LDW, DWORK(IB), LDW,
     $             DWORK(IC), L, V, LDV, DWORK(IWR), DWORK(IWI),
     $             DWORK(JWORK), LDWORK-JWORK+1, IERR )
      IF( IERR.GT.0 ) THEN
         INFO = 1
         RETURN
      END IF
      MAXWRK = MAX( MAXWRK, INT( DWORK( JWORK ) ) + JWORK - 1 )
C
      DO 10 I = IWR, IWI - 1
         IF( DLAPY2( DWORK(I), DWORK(I+N) ).GE.ONE )
     $      IWARN = 6
   10 CONTINUE
C
      JWORK = IWR
C
C     Estimate  x(0)  and/or the system matrices  B and D.
C     Workspace: need   g + N*N + L*N + N*M +
C                           max( g, min( LDW2, LDW3 ) ) (see LDWORK);
C                prefer larger.
C
      IF ( COMPBD ) THEN
         CALL IB01QD( JOBX0, JOB, N, M, L, NSMP, DWORK(IA), LDW,
     $                DWORK(IC), L, U, LDU, Y, LDY, X0, DWORK(IB), LDW,
     $                D, LDD, TOL, IWORK, DWORK(JWORK), LDWORK-JWORK+1,
     $                IWARNL, INFO )
C
         IF( INFO.EQ.0 ) THEN
            IF ( M.GT.0 .AND. WITHD )
     $         RCONDU = DWORK(JWORK+2)
C
C           Compute the system input matrix  B  corresponding to the
C           original system.
C
            CALL DGEMM( 'NoTranspose', 'NoTranspose', N, M, N, ONE,
     $                  V, LDV, DWORK(IB), LDW, ZERO, B, LDB )
         END IF
      ELSE
         IF ( WITHD ) THEN
            JOBD = 'N'
         ELSE
            JOBD = 'Z'
         END IF
C
         CALL IB01RD( JOBD, N, MTMP, L, NSMP, DWORK(IA), LDW, DWORK(IB),
     $                LDW, DWORK(IC), L, D, LDD, U, LDU, Y, LDY, X0,
     $                TOL, IWORK, DWORK(JWORK), LDWORK-JWORK+1, IWARNL,
     $                INFO )
      END IF
      IWARN = MAX( IWARN, IWARNL )
C
      IF( INFO.EQ.0 ) THEN
         RCOND  = DWORK(JWORK+1)
         MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 )
         IF( WITHX0 ) THEN
C
C           Transform the initial state estimate to obtain the initial
C           state corresponding to the original system.
C           Workspace: need g + N*N + L*N + N*M + N.
C
            CALL DGEMV( 'NoTranspose', N, N, ONE, V, LDV, X0, 1, ZERO,
     $                  DWORK(JWORK), 1 )
            CALL DCOPY( N, DWORK(JWORK), 1, X0, 1 )
         END IF
C
         DWORK(1) = MAXWRK
         DWORK(2) = RCOND
         IF ( COMPBD .AND. M.GT.0 .AND. WITHD )
     $      DWORK(3) = RCONDU
      END IF
      RETURN
C
C *** End of IB01CD ***
      END


*> \brief \b ZGGGLM
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGGGLM + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE ZGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK,
*                          INFO )
*
*       .. Scalar Arguments ..
*       INTEGER            INFO, LDA, LDB, LWORK, M, N, P
*       ..
*       .. Array Arguments ..
*       COMPLEX*16         A( LDA, * ), B( LDB, * ), D( * ), WORK( * ),
*      $                   X( * ), Y( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> ZGGGLM solves a general Gauss-Markov linear model (GLM) problem:
*>
*>         minimize || y ||_2   subject to   d = A*x + B*y
*>             x
*>
*> where A is an N-by-M matrix, B is an N-by-P matrix, and d is a
*> given N-vector. It is assumed that M <= N <= M+P, and
*>
*>            rank(A) = M    and    rank( A B ) = N.
*>
*> Under these assumptions, the constrained equation is always
*> consistent, and there is a unique solution x and a minimal 2-norm
*> solution y, which is obtained using a generalized QR factorization
*> of the matrices (A, B) given by
*>
*>    A = Q*(R),   B = Q*T*Z.
*>          (0)
*>
*> In particular, if matrix B is square nonsingular, then the problem
*> GLM is equivalent to the following weighted linear least squares
*> problem
*>
*>              minimize || inv(B)*(d-A*x) ||_2
*>                  x
*>
*> where inv(B) denotes the inverse of B.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of rows of the matrices A and B.  N >= 0.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of columns of the matrix A.  0 <= M <= N.
*> \endverbatim
*>
*> \param[in] P
*> \verbatim
*>          P is INTEGER
*>          The number of columns of the matrix B.  P >= N-M.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is COMPLEX*16 array, dimension (LDA,M)
*>          On entry, the N-by-M matrix A.
*>          On exit, the upper triangular part of the array A contains
*>          the M-by-M upper triangular matrix R.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*>          B is COMPLEX*16 array, dimension (LDB,P)
*>          On entry, the N-by-P matrix B.
*>          On exit, if N <= P, the upper triangle of the subarray
*>          B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;
*>          if N > P, the elements on and above the (N-P)th subdiagonal
*>          contain the N-by-P upper trapezoidal matrix T.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] D
*> \verbatim
*>          D is COMPLEX*16 array, dimension (N)
*>          On entry, D is the left hand side of the GLM equation.
*>          On exit, D is destroyed.
*> \endverbatim
*>
*> \param[out] X
*> \verbatim
*>          X is COMPLEX*16 array, dimension (M)
*> \endverbatim
*>
*> \param[out] Y
*> \verbatim
*>          Y is COMPLEX*16 array, dimension (P)
*>
*>          On exit, X and Y are the solutions of the GLM problem.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*>          LWORK is INTEGER
*>          The dimension of the array WORK. LWORK >= max(1,N+M+P).
*>          For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB,
*>          where NB is an upper bound for the optimal blocksizes for
*>          ZGEQRF, ZGERQF, ZUNMQR and ZUNMRQ.
*>
*>          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.
*>          = 1:  the upper triangular factor R associated with A in the
*>                generalized QR factorization of the pair (A, B) is
*>                singular, so that rank(A) < M; the least squares
*>                solution could not be computed.
*>          = 2:  the bottom (N-M) by (N-M) part of the upper trapezoidal
*>                factor T associated with B in the generalized QR
*>                factorization of the pair (A, B) is singular, so that
*>                rank( A B ) < N; the least squares solution could not
*>                be computed.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2015
*
*> \ingroup complex16OTHEReigen
*
*  =====================================================================
      SUBROUTINE ZGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK,
     $                   INFO )
*
*  -- LAPACK driver routine (version 3.6.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2015
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB, LWORK, M, N, P
*     ..
*     .. Array Arguments ..
      COMPLEX*16         A( LDA, * ), B( LDB, * ), D( * ), WORK( * ),
     $                   X( * ), Y( * )
*     ..
*
*  ===================================================================
*
*     .. Parameters ..
      COMPLEX*16         CZERO, CONE
      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ),
     $                   CONE = ( 1.0D+0, 0.0D+0 ) )
*     ..
*     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            I, LOPT, LWKMIN, LWKOPT, NB, NB1, NB2, NB3,
     $                   NB4, NP
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA, ZCOPY, ZGEMV, ZGGQRF, ZTRTRS, ZUNMQR,
     $                   ZUNMRQ
*     ..
*     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          INT, MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters
*
      INFO = 0
      NP = MIN( N, P )
      LQUERY = ( LWORK.EQ.-1 )
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( M.LT.0 .OR. M.GT.N ) THEN
         INFO = -2
      ELSE IF( P.LT.0 .OR. P.LT.N-M ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -7
      END IF
*
*     Calculate workspace
*
      IF( INFO.EQ.0) THEN
         IF( N.EQ.0 ) THEN
            LWKMIN = 1
            LWKOPT = 1
         ELSE
            NB1 = ILAENV( 1, 'ZGEQRF', ' ', N, M, -1, -1 )
            NB2 = ILAENV( 1, 'ZGERQF', ' ', N, M, -1, -1 )
            NB3 = ILAENV( 1, 'ZUNMQR', ' ', N, M, P, -1 )
            NB4 = ILAENV( 1, 'ZUNMRQ', ' ', N, M, P, -1 )
            NB = MAX( NB1, NB2, NB3, NB4 )
            LWKMIN = M + N + P
            LWKOPT = M + NP + MAX( N, P )*NB
         END IF
         WORK( 1 ) = LWKOPT
*
         IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
            INFO = -12
         END IF
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZGGGLM', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
*     Compute the GQR factorization of matrices A and B:
*
*          Q**H*A = ( R11 ) M,    Q**H*B*Z**H = ( T11   T12 ) M
*                   (  0  ) N-M                 (  0    T22 ) N-M
*                      M                         M+P-N  N-M
*
*     where R11 and T22 are upper triangular, and Q and Z are
*     unitary.
*
      CALL ZGGQRF( N, M, P, A, LDA, WORK, B, LDB, WORK( M+1 ),
     $             WORK( M+NP+1 ), LWORK-M-NP, INFO )
      LOPT = WORK( M+NP+1 )
*
*     Update left-hand-side vector d = Q**H*d = ( d1 ) M
*                                               ( d2 ) N-M
*
      CALL ZUNMQR( 'Left', 'Conjugate transpose', N, 1, M, A, LDA, WORK,
     $             D, MAX( 1, N ), WORK( M+NP+1 ), LWORK-M-NP, INFO )
      LOPT = MAX( LOPT, INT( WORK( M+NP+1 ) ) )
*
*     Solve T22*y2 = d2 for y2
*
      IF( N.GT.M ) THEN
         CALL ZTRTRS( 'Upper', 'No transpose', 'Non unit', N-M, 1,
     $                B( M+1, M+P-N+1 ), LDB, D( M+1 ), N-M, INFO )
*
         IF( INFO.GT.0 ) THEN
            INFO = 1
            RETURN
         END IF
*
         CALL ZCOPY( N-M, D( M+1 ), 1, Y( M+P-N+1 ), 1 )
      END IF
*
*     Set y1 = 0
*
      DO 10 I = 1, M + P - N
         Y( I ) = CZERO
   10 CONTINUE
*
*     Update d1 = d1 - T12*y2
*
      CALL ZGEMV( 'No transpose', M, N-M, -CONE, B( 1, M+P-N+1 ), LDB,
     $            Y( M+P-N+1 ), 1, CONE, D, 1 )
*
*     Solve triangular system: R11*x = d1
*
      IF( M.GT.0 ) THEN
         CALL ZTRTRS( 'Upper', 'No Transpose', 'Non unit', M, 1, A, LDA,
     $                D, M, INFO )
*
         IF( INFO.GT.0 ) THEN
            INFO = 2
            RETURN
         END IF
*
*        Copy D to X
*
         CALL ZCOPY( M, D, 1, X, 1 )
      END IF
*
*     Backward transformation y = Z**H *y
*
      CALL ZUNMRQ( 'Left', 'Conjugate transpose', P, 1, NP,
     $             B( MAX( 1, N-P+1 ), 1 ), LDB, WORK( M+1 ), Y,
     $             MAX( 1, P ), WORK( M+NP+1 ), LWORK-M-NP, INFO )
      WORK( 1 ) = M + NP + MAX( LOPT, INT( WORK( M+NP+1 ) ) )
*
      RETURN
*
*     End of ZGGGLM
*
      END


!
! Copyright (C) 2001-2007 Quantum ESPRESSO group
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
!-----------------------------------------------------------------------
subroutine deriv_drhoc (ngl, gl, omega, tpiba2, mesh, r, rab, rhoc, drhocg)
  !-----------------------------------------------------------------------
  USE kinds
  USE constants, ONLY : pi, fpi
  implicit none
  !
  !    first the dummy variables
  !

  integer :: ngl, mesh
  ! input: the number of g shell
  ! input: the number of radial mesh points

  real(DP), intent(in) :: gl (ngl), r (mesh), rab (mesh), rhoc (mesh), &
                          omega, tpiba2
  real(DP), intent(out) :: drhocg (ngl)
  ! input: the number of G shells
  ! input: the radial mesh
  ! input: the derivative of the radial mesh
  ! input: the radial core charge
  ! input: the volume of the unit cell
  ! input: 2 times pi / alat
  ! output: fourier transform of d Rho_c/dG
  !
  !     here the local variables
  !
  real(DP) :: gx, rhocg1
  ! the modulus of g for a given shell
  ! the fourier transform
  real(DP), allocatable :: aux (:)
  ! auxiliary memory for integration

  integer :: ir, igl, igl0
  ! counter on radial mesh points
  ! counter on g shells
  ! lower limit for loop on ngl

  !
  ! G=0 term
  !
  if (gl (1) < 1.0d-8) then
     drhocg (1) = 0.0d0
     igl0 = 2
  else
     igl0 = 1
  endif
  !
  ! G <> 0 term
  !
  allocate (aux( mesh))
  do igl = igl0, ngl
     gx = sqrt (gl (igl) * tpiba2)
     do ir = 1, mesh
        aux (ir) = r (ir) * rhoc (ir) * (r (ir) * cos (gx * r (ir) ) &
             / gx - sin (gx * r (ir) ) / gx**2)
     enddo
     call simpson (mesh, aux, rab, rhocg1)
     drhocg (igl) = fpi / omega * rhocg1
  enddo
  deallocate (aux)

  return
end subroutine deriv_drhoc


!########################################################
!     Program  : PAMMPT
!     TYPE     : Main program
!     PURPOSE  : Solve the PAM using DMFT away from half-filling
! with modified itertive perturbation scheme (MPT)
!     AUTHORS  : Adriano Amaricci
!########################################################
module COMMON
  USE BROYDEN
  USE COMMON_VARS
  implicit none
  !Put here vars in common with the BROYDN function
  real(8)                :: xmu0,n,n0
  complex(8),allocatable :: sigma(:),fg(:),fg0(:),gamma(:)
  complex(8),allocatable :: sigmap(:),fgp(:),fg0p(:)
  real(8),allocatable    :: wr(:)
end module COMMON

function funcv(x)
  USE COMMON
  USE DMFT_IPT
  implicit none
  real(8),dimension(:),intent(in)  ::  x
  real(8),dimension(size(x))       ::  funcv
  real(8)                          ::  zn0
  xmu0=x(1)
  fg0 = one/(cmplx(wr,eps) + xmu0 - ed0 - gamma -U*(n-0.5d0))
  n0=sum(fermi(wr,beta)*aimag(fg0))/sum(aimag(fg0))
  funcv(1)=n-n0
  write(*,"(3(f13.9))")n,n0,xmu0
end function funcv

program pammpt
  USE DMFT_IPT
  USE COMMON
  USE IOTOOLS
  implicit none
  integer                :: i,iloop
  real(8)                :: x(1)
  logical                :: check,converged
  complex(8)             :: zeta,alpha
  real(8)                :: np,gzero,gmu,ntot,shift
  complex(8),allocatable :: sold(:)

  call read_input("inputIPT.in")

  allocate(fg(1:L),sigma(1:L),fg0(1:L),gamma(1:L))
  allocate(fgp(1:L),fg0p(1:L),sigmap(1:L))
  allocate(sold(1:L))
  allocate(wr(1:L))
  ! wm  = pi/beta*real(2*arange(1,L)-1,8)
  ! tau = linspace(0.d0,beta,L+1,mesh=dtau)
  gmu=xmu  ; gzero=0.d0
  if((ed0-ep0) > 0.d0)gzero=0.5*(ep0+ed0+sqrt((ep0-ed0)**2 + 4*Vpd**2))
  if((ed0-ep0) < 0.d0)gzero=0.5*(ep0+ed0-sqrt((ep0-ed0)**2 + 4*Vpd**2))
  if((ed0-ep0) /=0.d0)xmu=gmu+gzero !true ED chemical potential
  write(*,*)'shift mu to (from) = ',xmu,'(',gmu,')'
  write(*,*)'shift is           = ',gzero

  wr = linspace(-wmax,wmax,L,mesh=fmesh)
  sigma=zero  ; xmu0=xmu ; D=2.d0*ts
  iloop=0 ; converged=.false. ; sold=sigma
  do while (.not.converged)
     iloop=iloop+1
     write(*,"(A,i5)")"DMFT-loop",iloop

     do i=1,L
        alpha     = cmplx(wr(i),eps)  +xmu -ed0 - sigma(i)
        sigmap(i) = Vpd**2/alpha
        zeta      = cmplx(wr(i),eps)  +xmu -ep0 - sigmap(i)
        fgp(i)    = gfbether(wr(i),zeta,D)
        fg(i)     = one/alpha + Vpd**2/alpha**2*fgp(i)
     enddo
     n  = sum(fermi(wr,beta)*aimag(fg))/sum(aimag(fg))
     np = 2.d0*sum(aimag(fgp(:))*fermi(wr(:),beta))/sum(aimag(fgp(:)))
     ntot = np+2.d0*n

     !Get the hybridization functions: \Gamma(w+xmu)
     gamma= cmplx(wr,eps) + xmu - ed0 - sigma - one/fg

     !Fix the xmu0 w/ condition n0=n
     x(1)=xmu
     call broydn(x,check)       !this changes n0,xmu0
     xmu0=x(1)

     sigma= solve_mpt_sopt(fg0,wr,n,n0,xmu0)
     sigma=weight*sigma + (1.d0-weight)*sold
     sold=sigma
     converged=check_convergence(sigma,eps_error,Nsuccess,Nloop)
     call splot("ndVSiloop.ipt",iloop,2.d0*n,append=TT)
     call splot("npVSiloop.ipt",iloop,np,append=TT)
     call splot("ntotVSiloop.ipt",iloop,ntot,append=TT)
  enddo
  call splot("nd.np.ntot.ipt",n,np,ntot,append=TT)
  call splot("DOS.ipt",wr,-aimag(fg)/pi,-aimag(fgp)/pi,append=printf)
  call splot("Sigma_realw.ipt",wr,sigma,append=printf)
  call splot("Sigmap_realw.ipt",wr,sigmap,append=printf)
  call splot("G_realw.ipt",wr,fg,append=printf)
  call splot("Gp_realw.ipt",wr,fgp,append=printf)

  !   Lk=(Nx+1)**2
  !   call pam_getenergy_spt(Lk)

  ! contains
  !   !+-------------------------------------------------------------------+
  !   !PROGRAM  :
  !   !TYPE     : Subroutine
  !   !PURPOSE  :
  !   !COMMENT  :
  !   !+-------------------------------------------------------------------+
  !   subroutine pam_getenergy_spt(Lk)
  !     integer   :: Lk,Lm
  !     real(8)   :: nd,np,docc,Etot,Ekin,Epot,Ehyb,Eepsi,Emu,nk(Lk),npk(Lk)
  !     real(8)   :: epsi,de
  !     complex(8),allocatable :: gf(:),sf(:),gff(:)
  !     complex(8),allocatable :: gp(:),sp(:),gpp(:)
  !     real(8),allocatable    :: gtau(:),gptau(:)
  !     complex(8) :: gamma,alpha

  !     Lm=int(L*beta/pi);if(beta<1)Lm=L;if(Lm<L)Lm=L
  !     Lm=2**14
  !     allocate(gf(Lm),sf(Lm),gtau(0:L),gff(L))
  !     allocate(gp(Lm),sp(Lm),gptau(0:L),gpp(L))

  !     call getGmats(wr,fg,gf,beta)
  !     call getGmats(wr,fgp,gp,beta)
  !     call getGmats(wr,sigma,sf,beta)
  !     call getGmats(wr,sigmap,sp,beta)
  !     call splot("Giw.ipt",(/(pi/beta*dble(2*i-1),i=1,Lm)/),gf)
  !     call splot("Gpiw.ipt",(/(pi/beta*dble(2*i-1),i=1,Lm)/),gp)

  !     call cfft_iw2tau(gf,gtau,beta)
  !     call cfft_iw2tau(gp,gptau,beta)
  !     call splot("Gtau.ipt",(/(dble(i)*beta/dble(L),i=0,L)/),gtau(0:L))
  !     call splot("Gptau.ipt",(/(dble(i)*beta/dble(L),i=0,L)/),gptau(0:L))

  !     nd=-2.d0*gtau(L)
  !     np=-2.d0*gptau(L)

  !     !Energy && k-dispersed quantities
  !     Ekin=0.d0
  !     de=2.d0*D/dble(Lk)
  !     do ik=1,Lk
  !        epsi=-D + de*dble(ik)
  !        do i=1,L
  !           w=pi/beta*dble(2*i-1)
  !           gamma=xi*w+xmu-ed0-sf(i)
  !           alpha=xi*w+xmu-ep0-epsi
  !           gff(i)=one/(gamma - vpd**2/alpha)
  !           gpp(i)=one/(alpha-sp(i))
  !        enddo
  !        call cfft_iw2tau(gff,gtau,beta)
  !        call cfft_iw2tau(gpp,gptau,beta)
  !        nk(ik)=-gtau(L)
  !        npk(ik)=-gptau(L)
  !        Ekin=Ekin + nk(ik)*epsi/dble(Lk)
  !     enddo

  !     Epot=dot_product(conjg(sf(:)),gf(:))
  !     Ehyb=4.d0*dot_product(conjg(sp(:)),gp(:))

  !     Ehyb=2.d0*Ehyb/beta
  !     Epot=2.d0*Epot/beta

  !     docc=0.5*nd  - 0.25d0
  !     if(u>=1.d-2)docc = Epot/U + 0.5*nd - 0.25d0

  !     Eepsi=ed0*(nd-1.d0) + ep0*(np-1.d0)
  !     Emu=-xmu*(ntot-2.d0)

  !     Etot=Ekin+Epot+Ehyb+Eepsi+Emu

  !     write(*,"(A,f13.9)")"docc   =",docc
  !     write(*,"(A,f13.9)")"nd     =",nd
  !     write(*,"(A,f13.9)")"np     =",np
  !     write(*,"(A,f13.9)")"ntot   =",np+nd
  !     write(*,"(A,f13.9)")"Etot   =",Etot
  !     write(*,"(A,f13.9)")"Ekin   =",Ekin
  !     write(*,"(A,f13.9)")"Epot   =",Epot
  !     write(*,"(A,f13.9)")"Ehyb   =",Ehyb
  !     write(*,"(A,f13.9)")"Eepsi  =",Eepsi
  !     write(*,"(A,f13.9)")"Emu    =",Emu

  !     call splot("nkVSepsik.ipt",(/(-D + de*dble(ik),ik=1,Lk )/),nk(1:Lk),npk(1:Lk))
  !     call splot("EtotVS"//trim(extension),xout,Ekin+Epot,append=TT)
  !     call splot("EkinVS"//trim(extension),xout,Ekin,append=TT)
  !     call splot("EpotVS"//trim(extension),xout,Epot,append=TT)
  !     call splot("EhybVS"//trim(extension),xout,Ehyb,append=TT)
  !     call splot("EmuVS"//trim(extension),xout,Emu,append=TT)
  !     call splot("EepsiVS"//trim(extension),xout,Eepsi,append=TT)
  !     call splot("doccVS"//trim(extension),xout,docc,append=TT)
  !     deallocate(gf,sf,gtau,gff)
  !     deallocate(gp,sp,gptau,gpp)
  !   end subroutine pam_getenergy_spt
  !   !*******************************************************************
  !   !*******************************************************************
  !   !*******************************************************************

end program pammpt


************************************************************************
*
*     Function ERF                                     Called by: LOGLK
*
*     Calculate the Error Function using the approximation given in
*     Section 7.1.26 of Abramowitz and Stegun (1964).  The error in the
*     approximation is less than 1.5E-7.
*
*     local vars
*     ----------
*     A1       constant used in approximation
*     A2       constant used in approximation
*     A3       constant used in approximation
*     A4       constant used in approximation
*     A5       constant used in approximation
*     P        constant used in approximation
*     T        quantity used in approximation
*
************************************************************************
      DOUBLE PRECISION FUNCTION ERF(X)
*
*     subroutine argument
*
      DOUBLE PRECISION X
*
*     local vars
*
      DOUBLE PRECISION A1,A2,A3,A4,A5,P,T
      PARAMETER (A1=0.254829592D0,A2=-0.284496736D0,A3=1.421413741D0)
      PARAMETER (A4=-1.453152027D0,A5=1.061405429D0,P=0.3275911D0)
*
*     Approximation is valid for X > 0.0.  If X is negative obtain
*     approximation using symmetry relation: Erf(-X) = -Erf(X).
*
      IF (X.GE.0.D0) THEN
         T=1.D0/(1.D0+P*X)
         ERF=1.D0-((T*(A1+T*(A2+T*(A3+T*(A4+T*A5)))))*DEXP(-(X**2)))
      ELSE
         T=1.D0/(1.D0+P*DABS(X))
         ERF=-(1.D0-((T*(A1+T*(A2+T*(A3+T*(A4+T*A5)))))*DEXP(-(X**2))))
      ENDIF

      RETURN
      END


		parameter(itime = 10000,delta=0.02)
		parameter(xposeq = 0.0, val=1.000)

		x = 0.00
		vel  = 1.00
                F= -val*(x-xposeq)
                m=1.00

                !write(16,*) 0,x
                !write(18,*) 0,vel
                H = 0.5 *(vel**2) + 0.5 * val *(x**2)
                !write(20,*) x,vel
                write(24,*) 0,H

		do ixx = 1, itime

		vel = vel + (0.5*(F/m)*delta)
                x=x + (vel*delta)
                F = -val*(x-xposeq)
                vel = vel + (0.5*(F/m)*delta)

		!write(16,*) ixx*delta,x
                !write(18,*) ixx*delta,vel
                H = 0.5 *(vel**2) + 0.5 * val *(x**2)
                !write(20,*) x,vel
                write(24,*) ixx*delta,H

		end do

		stop
		end


      SUBROUTINE MINV (A, N, D, L, M)
C
C* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C	VICAR SUBROUTINE                                               MINV
C       ----------------                                               ---
C	General routine for inverting an array calculating its determinant
C	Fortran format of call:
C
C	CALL MINV (A, N, D, L, M)
C
C	Parameters:-
C
C	A   (input/output)  REAL N by N Input Matrix.
C                           Returned as output the resulting inverse.
C       N   (input)         order of matrix A.
C       D   (output)        resultant determinant.  D=0 if A is singular.
C       L   (input)         work vector of length N.
C       M   (input)         work vector of length N.
C
C       Inverts a matrix and calculates its determinant using
C       MATH77 (from LINPACK) routines SGEFA, SGED and SGEI.
C
C   REVISION HISTORY
C
C      07-03-95   CRI  Removed LIB_LOCAL as per FR85780
C      14-04-94   CRI  MSTP S/W Conversion (VICAR Porting)
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      REAL A(N,N), L(N), M(N), D, DET(2)
      INTEGER N

      PARAMETER ( RMIN_PAR = -37 )  ! VALID MAGNITUDES FOR REAL*4 ARE ROUGHLY
      PARAMETER ( RMAX_PAR =  37 )  ! 1.E-37 TO 1.E+37.

C==================================================================

C..GET THE LU DECOMPOSITION OF MATRIX A.

      CALL SGEFA( A,N,N, L, INFO )

      IF ( INFO .NE. 0 )  THEN
         D = 0.0                   ! A IS SINGULAR.

      ELSE

C..IF NOT SINGULAR, THEN INVERT AND CALCULATE DETERMINANT.

         CALL SGED (A,N,N,L,DET)	! DETERMINANT
         CALL SGEI (A,N,N,L,M)		! INVERSE

         IF ( DET(2) .GT. RMAX_PAR )  THEN
            CALL QPRINT( ' DETERMINANT TOO LARGE IN SUB MINV' )
            DET(2) = RMAX_PAR
         END IF

         IF ( DET(2) .LT. RMIN_PAR )  THEN
            D = 0.0

         ELSE
            D = DET(1)*10.0**DET(2)

         END IF

      END IF

      RETURN
      END


C-----------------------------------------------------------------------
      SUBROUTINE SPVAR(I,M,Q,QVAR)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:    SPVAR       COMPUTE VARIANCE BY TOTAL WAVENUMBER
C   PRGMMR: IREDELL          ORG: W/NMC23     DATE: 92-10-31
C
C ABSTRACT: COMPUTES THE VARIANCES BY TOTAL WAVENUMBER
C           OF A SCALAR FIELD IN SPECTRAL SPACE.
C
C PROGRAM HISTORY LOG:
C   91-10-31  MARK IREDELL
C
C USAGE:    CALL SPVAR(I,M,Q,QVAR)
C
C   INPUT ARGUMENT LIST:
C     I        - INTEGER SPECTRAL DOMAIN SHAPE
C                (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL)
C     M        - INTEGER SPECTRAL TRUNCATION
C     Q        - REAL ((M+1)*((I+1)*M+2)) SCALAR FIELD
C
C   OUTPUT ARGUMENT LIST:
C     QVAR     - REAL (0:(I+1)*M) VARIANCES
C
C ATTRIBUTES:
C   LANGUAGE: CRAY FORTRAN
C
C$$$
      REAL Q((M+1)*((I+1)*M+2))
      REAL QVAR(0:(I+1)*M)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      L=0
      DO N=0,M
        KS=L*(2*M+(I-1)*(L-1))+2*N
        QVAR(N)=0.5*Q(KS+1)**2
      ENDDO
      DO N=M+1,(I+1)*M
        QVAR(N)=0.
      ENDDO
      DO N=0,(I+1)*M
        DO L=MAX(1,N-M),MIN(N,M)
          KS=L*(2*M+(I-1)*(L-1))+2*N
          QVAR(N)=QVAR(N)+Q(KS+1)**2+Q(KS+2)**2
        ENDDO
      ENDDO
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      RETURN
      END


      SUBROUTINE IB01RD( JOB, N, M, L, NSMP, A, LDA, B, LDB, C, LDC, D,
     $                   LDD, U, LDU, Y, LDY, X0, TOL, IWORK, DWORK,
     $                   LDWORK, IWARN, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To estimate the initial state of a linear time-invariant (LTI)
C     discrete-time system, given the system matrices  (A,B,C,D)  and
C     the input and output trajectories of the system. The model
C     structure is :
C
C           x(k+1) = Ax(k) + Bu(k),   k >= 0,
C           y(k)   = Cx(k) + Du(k),
C
C     where  x(k)  is the  n-dimensional state vector (at time k),
C            u(k)  is the  m-dimensional input vector,
C            y(k)  is the  l-dimensional output vector,
C     and  A, B, C, and D  are real matrices of appropriate dimensions.
C     Matrix  A  is assumed to be in a real Schur form.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Specifies whether or not the matrix D is zero, as follows:
C             = 'Z':  the matrix  D  is zero;
C             = 'N':  the matrix  D  is not zero.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the system.  N >= 0.
C
C     M       (input) INTEGER
C             The number of system inputs.  M >= 0.
C
C     L       (input) INTEGER
C             The number of system outputs.  L > 0.
C
C     NSMP    (input) INTEGER
C             The number of rows of matrices  U  and  Y  (number of
C             samples used,  t).  NSMP >= N.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N part of this array must contain the
C             system state matrix  A  in a real Schur form.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,N).
C
C     B       (input) DOUBLE PRECISION array, dimension (LDB,M)
C             The leading N-by-M part of this array must contain the
C             system input matrix  B  (corresponding to the real Schur
C             form of  A).
C             If  N = 0  or  M = 0,  this array is not referenced.
C
C     LDB     INTEGER
C             The leading dimension of the array B.
C             LDB >= N,  if  N > 0  and  M > 0;
C             LDB >= 1,  if  N = 0  or   M = 0.
C
C     C       (input) DOUBLE PRECISION array, dimension (LDC,N)
C             The leading L-by-N part of this array must contain the
C             system output matrix  C  (corresponding to the real Schur
C             form of  A).
C
C     LDC     INTEGER
C             The leading dimension of the array C.  LDC >= L.
C
C     D       (input) DOUBLE PRECISION array, dimension (LDD,M)
C             The leading L-by-M part of this array must contain the
C             system input-output matrix.
C             If  M = 0  or  JOB = 'Z',  this array is not referenced.
C
C     LDD     INTEGER
C             The leading dimension of the array D.
C             LDD >= L,  if  M > 0  and  JOB = 'N';
C             LDD >= 1,  if  M = 0  or   JOB = 'Z'.
C
C     U       (input) DOUBLE PRECISION array, dimension (LDU,M)
C             If  M > 0,  the leading NSMP-by-M part of this array must
C             contain the t-by-m input-data sequence matrix  U,
C             U = [u_1 u_2 ... u_m].  Column  j  of  U  contains the
C             NSMP  values of the j-th input component for consecutive
C             time increments.
C             If M = 0, this array is not referenced.
C
C     LDU     INTEGER
C             The leading dimension of the array U.
C             LDU >= MAX(1,NSMP),  if M > 0;
C             LDU >= 1,            if M = 0.
C
C     Y       (input) DOUBLE PRECISION array, dimension (LDY,L)
C             The leading NSMP-by-L part of this array must contain the
C             t-by-l output-data sequence matrix  Y,
C             Y = [y_1 y_2 ... y_l].  Column  j  of  Y  contains the
C             NSMP  values of the j-th output component for consecutive
C             time increments.
C
C     LDY     INTEGER
C             The leading dimension of the array Y.  LDY >= MAX(1,NSMP).
C
C     X0      (output) DOUBLE PRECISION array, dimension (N)
C             The estimated initial state of the system,  x(0).
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The tolerance to be used for estimating the rank of
C             matrices. If the user sets  TOL > 0,  then the given value
C             of  TOL  is used as a lower bound for the reciprocal
C             condition number;  a matrix whose estimated condition
C             number is less than  1/TOL  is considered to be of full
C             rank.  If the user sets  TOL <= 0,  then  EPS  is used
C             instead, where  EPS  is the relative machine precision
C             (see LAPACK Library routine DLAMCH).  TOL <= 1.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (N)
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if  INFO = 0,  DWORK(1) returns the optimal value
C             of LDWORK and  DWORK(2)  contains the reciprocal condition
C             number of the triangular factor of the QR factorization of
C             the matrix  Gamma  (see METHOD).
C             On exit, if  INFO = -22,  DWORK(1)  returns the minimum
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= max( 2, min( LDW1, LDW2 ) ),  where
C             LDW1 = t*L*(N + 1) + 2*N + max( 2*N*N, 4*N ),
C             LDW2 =   N*(N + 1) + 2*N +
C                      max( q*(N + 1) + 2*N*N + L*N, 4*N ),
C                q = N*L.
C             For good performance,  LDWORK  should be larger.
C             If  LDWORK >= LDW1,  then standard QR factorization of
C             the matrix  Gamma  (see METHOD) is used. Otherwise, the
C             QR factorization is computed sequentially by performing
C             NCYCLE  cycles, each cycle (except possibly the last one)
C             processing  s  samples, where  s  is chosen by equating
C             LDWORK  to  LDW2,  for  q  replaced by  s*L.
C             The computational effort may increase and the accuracy may
C             decrease with the decrease of  s.  Recommended value is
C             LDRWRK = LDW1,  assuming a large enough cache size, to
C             also accommodate  A, B, C, D, U,  and  Y.
C
C     Warning Indicator
C
C     IWARN   INTEGER
C             = 0:  no warning;
C             = 4:  the least squares problem to be solved has a
C                   rank-deficient coefficient matrix.
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             = 2:  the singular value decomposition (SVD) algorithm did
C                   not converge.
C
C     METHOD
C
C     An extension and refinement of the method in [1] is used.
C     Specifically, the output y0(k) of the system for zero initial
C     state is computed for k = 0, 1, ...,  t-1 using the given model.
C     Then the following least squares problem is solved for x(0)
C
C                         (     C     )            (   y(0) - y0(0)   )
C                         (    C*A    )            (   y(1) - y0(1)   )
C        Gamma * x(0)  =  (     :     ) * x(0)  =  (        :         ).
C                         (     :     )            (        :         )
C                         ( C*A^(t-1) )            ( y(t-1) - y0(t-1) )
C
C     The coefficient matrix  Gamma  is evaluated using powers of A with
C     exponents 2^k. The QR decomposition of this matrix is computed.
C     If its triangular factor  R  is too ill conditioned, then singular
C     value decomposition of  R  is used.
C
C     If the coefficient matrix cannot be stored in the workspace (i.e.,
C     LDWORK < LDW1),  the QR decomposition is computed sequentially.
C
C     REFERENCES
C
C     [1] Verhaegen M., and Varga, A.
C         Some Experience with the MOESP Class of Subspace Model
C         Identification Methods in Identifying the BO105 Helicopter.
C         Report TR R165-94, DLR Oberpfaffenhofen, 1994.
C
C     NUMERICAL ASPECTS
C
C     The implemented method is numerically stable.
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Apr. 2000.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004.
C
C     KEYWORDS
C
C     Identification methods; least squares solutions; multivariable
C     systems; QR decomposition; singular value decomposition.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO, THREE
      PARAMETER          ( ZERO  = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
     $                     THREE = 3.0D0 )
C     IBLOCK is a threshold value for switching to a block algorithm
C     for  U  (to avoid row by row passing through  U).
      INTEGER            IBLOCK
      PARAMETER          ( IBLOCK = 16384 )
C     .. Scalar Arguments ..
      DOUBLE PRECISION   TOL
      INTEGER            INFO, IWARN, L, LDA, LDB, LDC, LDD, LDU,
     $                   LDWORK, LDY, M, N, NSMP
      CHARACTER          JOB
C     .. Array Arguments ..
      DOUBLE PRECISION   A(LDA, *), B(LDB, *), C(LDC, *), D(LDD, *),
     $                   DWORK(*),  U(LDU, *), X0(*), Y(LDY, *)
      INTEGER            IWORK(*)
C     .. Local Scalars ..
      DOUBLE PRECISION   RCOND, TOLL
      INTEGER            I2, IA, IAS, IC, ICYCLE, IE, IERR, IEXPON,
     $                   IG, INIGAM, INIH, INIR, INIT, IQ, IREM, IRHS,
     $                   ISIZE, ISV, ITAU, IU, IUPNT, IUT, IUTRAN, IX,
     $                   IXINIT, IY, IYPNT, J, JWORK, K, LDDW, LDR,
     $                   LDW1, LDW2, MAXWRK, MINSMP, MINWLS, MINWRK, NC,
     $                   NCP1, NCYCLE, NN, NOBS, NRBL, NROW, NSMPL, RANK
      LOGICAL            BLOCK, FIRST, NCYC, POWER2, SWITCH, WITHD
C     .. Local Arrays ..
      DOUBLE PRECISION   DUM(1)
C     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH, ILAENV, LSAME
C     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DGELSS, DGEMV, DGEQRF, DLACPY,
     $                   DLASET, DORMQR, DTRCON, DTRMM, DTRMV, DTRSV,
     $                   MA02AD, MB01TD, MB04OD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          DBLE, INT, LOG, MAX, MIN, MOD
C     .. Executable Statements ..
C
C     Check the input parameters.
C
      WITHD  = LSAME( JOB, 'N' )
      IWARN  = 0
      INFO   = 0
      NN     = N*N
      MINSMP = N
C
      IF( .NOT.( LSAME( JOB, 'Z' ) .OR. WITHD ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( L.LE.0 ) THEN
         INFO = -4
      ELSE IF( NSMP.LT.MINSMP ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.1 .OR. ( LDB.LT.N .AND. M.GT.0 ) ) THEN
         INFO = -9
      ELSE IF( LDC.LT.L ) THEN
         INFO = -11
      ELSE IF( LDD.LT.1 .OR. ( WITHD .AND. LDD.LT.L .AND. M.GT.0 ) )
     $      THEN
         INFO = -13
      ELSE IF( LDU.LT.1 .OR. ( M.GT.0 .AND. LDU.LT.NSMP ) ) THEN
         INFO = -15
      ELSE IF( LDY.LT.MAX( 1, NSMP ) ) THEN
         INFO = -17
      ELSE IF( TOL.GT.ONE ) THEN
         INFO = -19
      END IF
C
C     Compute workspace.
C      (Note: Comments in the code beginning "Workspace:" describe the
C       minimal amount of workspace needed at that point in the code,
C       as well as the preferred amount for good performance.
C       NB refers to the optimal block size for the immediately
C       following subroutine, as returned by ILAENV.)
C
      NSMPL  = NSMP*L
      IQ     = MINSMP*L
      NCP1   = N + 1
      ISIZE  = NSMPL*NCP1
      IC     = 2*NN
      MINWLS = MINSMP*NCP1
      ITAU   = IC + L*N
      LDW1   = ISIZE  + 2*N + MAX( IC, 4*N )
      LDW2   = MINWLS + 2*N + MAX( IQ*NCP1 + ITAU, 4*N )
      MINWRK = MAX( MIN( LDW1, LDW2 ), 2 )
      IF ( INFO.EQ.0 .AND. LDWORK.GE.MINWRK ) THEN
         MAXWRK = ISIZE + 2*N + MAX( N*ILAENV( 1, 'DGEQRF', ' ', NSMPL,
     $                                         N, -1, -1 ),
     $                               ILAENV( 1, 'DORMQR', 'LT', NSMPL,
     $                                       1, N, -1 ) )
         MAXWRK = MAX( MAXWRK, MINWRK )
      END IF
C
      IF ( INFO.EQ.0 .AND. LDWORK.LT.MINWRK ) THEN
         INFO = -22
         DWORK(1) = MINWRK
      END IF
C
C     Return if there are illegal arguments.
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'IB01RD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 ) THEN
         DWORK(1) = TWO
         DWORK(2) = ONE
         RETURN
      END IF
C
C     Set up the least squares problem, either directly, if enough
C     workspace, or sequentially, otherwise.
C
      IYPNT = 1
      IUPNT = 1
      INIR  = 1
      IF ( LDWORK.GE.LDW1 ) THEN
C
C        Enough workspace for solving the problem directly.
C
         NCYCLE = 1
         NOBS   = NSMP
         LDDW   = NSMPL
         INIGAM = 1
      ELSE
C
C        NCYCLE > 1  cycles are needed for solving the problem
C        sequentially, taking  NOBS  samples in each cycle (or the
C        remaining samples in the last cycle).
C
         JWORK  = LDWORK - MINWLS - 2*N - ITAU
         LDDW   = JWORK/NCP1
         NOBS   = LDDW/L
         LDDW   = L*NOBS
         NCYCLE = NSMP/NOBS
         IF ( MOD( NSMP, NOBS ).NE.0 )
     $      NCYCLE = NCYCLE + 1
         INIH   = INIR + NN
         INIGAM = INIH + N
      END IF
C
      NCYC   = NCYCLE.GT.1
      IRHS   = INIGAM + LDDW*N
      IXINIT = IRHS   + LDDW
      IC     = IXINIT + N
      IF( NCYC ) THEN
         IA   = IC + L*N
         LDR  = N
         IE   = INIGAM
      ELSE
         INIH = IRHS
         IA   = IC
         LDR  = LDDW
         IE   = IXINIT
      END IF
      IUTRAN = IA
      IAS    = IA + NN
      ITAU   = IA
      DUM(1) = ZERO
C
C     Set block parameters for passing through the array  U.
C
      BLOCK = M.GT.1 .AND. NSMP*M.GE.IBLOCK
      IF ( BLOCK ) THEN
         NRBL = ( LDWORK - IUTRAN + 1 )/M
         NC   = NOBS/NRBL
         IF ( MOD( NOBS, NRBL ).NE.0 )
     $      NC = NC + 1
         INIT  = ( NC - 1 )*NRBL
         BLOCK = BLOCK .AND. NRBL.GT.1
      END IF
C
C     Perform direct of sequential compression of the matrix  Gamma.
C
      DO 150 ICYCLE = 1, NCYCLE
         FIRST = ICYCLE.EQ.1
         IF ( .NOT.FIRST ) THEN
            IF ( ICYCLE.EQ.NCYCLE ) THEN
               NOBS = NSMP - ( NCYCLE - 1 )*NOBS
               LDDW = L*NOBS
               IF ( BLOCK ) THEN
                  NC = NOBS/NRBL
                  IF ( MOD( NOBS, NRBL ).NE.0 )
     $               NC = NC + 1
                  INIT = ( NC - 1 )*NRBL
               END IF
            END IF
         END IF
C
C        Compute the extended observability matrix  Gamma.
C        Workspace: need   s*L*(N + 1) + 2*N*N + 2*N + a + w,
C                   where  s = NOBS,
C                          a = 0,   w = 0,          if NCYCLE = 1,
C                          a = L*N, w = N*(N + 1),  if NCYCLE > 1;
C                   prefer as above, with  s = t,  a = w = 0.
C
         JWORK  = IAS + NN
         IEXPON = INT( LOG( DBLE( NOBS ) )/LOG( TWO ) )
         IREM   = L*( NOBS - 2**IEXPON )
         POWER2 = IREM.EQ.0
         IF ( .NOT.POWER2 )
     $      IEXPON = IEXPON + 1
C
         IF ( FIRST ) THEN
            CALL DLACPY( 'Full', L, N, C, LDC, DWORK(INIGAM), LDDW )
         ELSE
            CALL DLACPY( 'Full', L, N, DWORK(IC), L, DWORK(INIGAM),
     $                   LDDW )
         END IF
C                                       p
C        Use powers of the matrix  A:  A ,  p = 2**(J-1).
C
         CALL DLACPY( 'Upper', N, N, A, LDA, DWORK(IA), N )
         IF ( N.GT.1 )
     $      CALL DCOPY( N-1, A(2,1), LDA+1, DWORK(IA+1), N+1 )
         I2   = L
         NROW = 0
C
         DO 20 J = 1, IEXPON
            IG = INIGAM
            IF ( J.LT.IEXPON .OR. POWER2 ) THEN
               NROW = I2
            ELSE
               NROW = IREM
            END IF
C
            CALL DLACPY( 'Full', NROW, N, DWORK(IG), LDDW, DWORK(IG+I2),
     $                   LDDW )
            CALL DTRMM(  'Right', 'Upper', 'No Transpose', 'Non Unit',
     $                   NROW, N, ONE, DWORK(IA), N, DWORK(IG+I2),
     $                   LDDW )
C                                                            p
C           Compute the contribution of the subdiagonal of  A   to the
C           product.
C
            DO 10 IX = 1, N - 1
               CALL DAXPY( NROW, DWORK(IA+(IX-1)*N+IX), DWORK(IG+LDDW),
     $                     1, DWORK(IG+I2), 1 )
               IG = IG + LDDW
   10       CONTINUE
C
            IF ( J.LT.IEXPON ) THEN
               CALL DLACPY( 'Upper', N, N, DWORK(IA), N, DWORK(IAS), N )
               CALL DCOPY(  N-1, DWORK(IA+1), N+1, DWORK(IAS+1), N+1 )
               CALL MB01TD( N, DWORK(IAS), N, DWORK(IA), N,
     $                      DWORK(JWORK), IERR )
               I2 = I2*2
            END IF
   20    CONTINUE
C
         IF ( NCYC ) THEN
            IG = INIGAM + I2 + NROW - L
            CALL DLACPY( 'Full', L, N, DWORK(IG), LDDW, DWORK(IC), L )
            CALL DTRMM( 'Right', 'Upper', 'No Transpose', 'Non Unit', L,
     $                  N, ONE, A, LDA, DWORK(IC), L )
C
C           Compute the contribution of the subdiagonal of  A  to the
C           product.
C
            DO 30 IX = 1, N - 1
               CALL DAXPY( L, A(IX+1,IX), DWORK(IG+LDDW), 1,
     $                     DWORK(IC+(IX-1)*L), 1 )
               IG = IG + LDDW
   30       CONTINUE
C
         END IF
C
C        Setup (part of) the right hand side of the least squares
C        problem starting from  DWORK(IRHS);  use the estimated output
C        trajectory for zero initial state, or for the saved final state
C        value of the previous cycle.
C        A specialization of SLICOT Library routine TF01ND is used.
C        For large input sets  (NSMP*M >= IBLOCK),  chunks of  U  are
C        transposed, to reduce the number of row-wise passes.
C        Workspace: need   s*L*(N + 1) + N + w;
C                   prefer as above, with  s = t,  w = 0.
C
         IF ( FIRST )
     $      CALL DCOPY( N, DUM, 0, DWORK(IXINIT), 1 )
         CALL DCOPY( N, DWORK(IXINIT), 1, X0, 1 )
         IY = IRHS
C
         DO 40 J = 1, L
            CALL DCOPY( NOBS, Y(IYPNT,J), 1, DWORK(IY), L )
            IY = IY + 1
   40    CONTINUE
C
         IY = IRHS
         IU = IUPNT
         IF ( M.GT.0 ) THEN
            IF ( WITHD ) THEN
C
               IF ( BLOCK ) THEN
                  SWITCH = .TRUE.
                  NROW   = NRBL
C
                  DO 60 K = 1, NOBS
                     IF ( MOD( K-1, NROW ).EQ.0 .AND. SWITCH ) THEN
                        IUT = IUTRAN
                        IF ( K.GT.INIT ) THEN
                           NROW = NOBS - INIT
                           SWITCH = .FALSE.
                        END IF
                        CALL MA02AD( 'Full', NROW, M, U(IU,1), LDU,
     $                               DWORK(IUT), M )
                        IU = IU + NROW
                     END IF
                     CALL DGEMV( 'No transpose', L, N, -ONE, C, LDC, X0,
     $                           1, ONE, DWORK(IY), 1 )
                     CALL DGEMV( 'No transpose', L, M, -ONE, D, LDD,
     $                           DWORK(IUT), 1, ONE, DWORK(IY), 1 )
                     CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N,
     $                           A, LDA, X0, 1 )
C
                     DO 50 IX = 2, N
                        X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXINIT+IX-2)
   50                CONTINUE
C
                     CALL DGEMV( 'No transpose', N, M, ONE, B, LDB,
     $                           DWORK(IUT), 1, ONE, X0, 1 )
                     CALL DCOPY( N, X0, 1, DWORK(IXINIT), 1 )
                     IY  = IY  + L
                     IUT = IUT + M
   60             CONTINUE
C
               ELSE
C
                  DO 80 K = 1, NOBS
                     CALL DGEMV( 'No transpose', L, N, -ONE, C, LDC, X0,
     $                           1, ONE, DWORK(IY), 1 )
                     CALL DGEMV( 'No transpose', L, M, -ONE, D, LDD,
     $                           U(IU,1), LDU, ONE, DWORK(IY), 1 )
                     CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N,
     $                           A, LDA, X0, 1 )
C
                     DO 70 IX = 2, N
                        X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXINIT+IX-2)
   70                CONTINUE
C
                     CALL DGEMV( 'No transpose', N, M, ONE, B, LDB,
     $                           U(IU,1), LDU, ONE, X0, 1 )
                     CALL DCOPY( N, X0, 1, DWORK(IXINIT), 1 )
                     IY = IY + L
                     IU = IU + 1
   80             CONTINUE
C
               END IF
C
            ELSE
C
               IF ( BLOCK ) THEN
                  SWITCH = .TRUE.
                  NROW   = NRBL
C
                  DO 100 K = 1, NOBS
                     IF ( MOD( K-1, NROW ).EQ.0 .AND. SWITCH ) THEN
                        IUT = IUTRAN
                        IF ( K.GT.INIT ) THEN
                           NROW = NOBS - INIT
                           SWITCH = .FALSE.
                        END IF
                        CALL MA02AD( 'Full', NROW, M, U(IU,1), LDU,
     $                               DWORK(IUT), M )
                        IU = IU + NROW
                     END IF
                     CALL DGEMV( 'No transpose', L, N, -ONE, C, LDC, X0,
     $                           1, ONE, DWORK(IY), 1 )
                     CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N,
     $                           A, LDA, X0, 1 )
C
                     DO 90 IX = 2, N
                        X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXINIT+IX-2)
   90                CONTINUE
C
                     CALL DGEMV( 'No transpose', N, M, ONE, B, LDB,
     $                           DWORK(IUT), 1, ONE, X0, 1 )
                     CALL DCOPY( N, X0, 1, DWORK(IXINIT), 1 )
                     IY  = IY  + L
                     IUT = IUT + M
  100             CONTINUE
C
               ELSE
C
                  DO 120 K = 1, NOBS
                     CALL DGEMV( 'No transpose', L, N, -ONE, C, LDC, X0,
     $                           1, ONE, DWORK(IY), 1 )
                     CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N,
     $                           A, LDA, X0, 1 )
C
                     DO 110 IX = 2, N
                        X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXINIT+IX-2)
  110                CONTINUE
C
                     CALL DGEMV( 'No transpose', N, M, ONE, B, LDB,
     $                           U(IU,1), LDU, ONE, X0, 1 )
                     CALL DCOPY( N, X0, 1, DWORK(IXINIT), 1 )
                     IY = IY + L
                     IU = IU + 1
  120             CONTINUE
C
               END IF
C
            END IF
C
         ELSE
C
            DO 140 K = 1, NOBS
               CALL DGEMV( 'No transpose', L, N, -ONE, C, LDC, X0, 1,
     $                     ONE, DWORK(IY), 1 )
               CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', N, A,
     $                     LDA, X0, 1 )
C
               DO 130 IX = 2, N
                  X0(IX) = X0(IX) + A(IX,IX-1)*DWORK(IXINIT+IX-2)
  130          CONTINUE
C
               CALL DCOPY( N, X0, 1, DWORK(IXINIT), 1 )
               IY = IY + L
  140       CONTINUE
C
         END IF
C
C        Compress the data using (sequential) QR factorization.
C        Workspace: need   v + 2*N;
C                   where  v = s*L*(N + 1) + N + a + w.
C
         JWORK = ITAU + N
         IF ( FIRST ) THEN
C
C           Compress the first data segment of  Gamma.
C           Workspace: need   v + 2*N,
C                      prefer v + N + N*NB.
C
            CALL DGEQRF( LDDW, N, DWORK(INIGAM), LDDW, DWORK(ITAU),
     $                   DWORK(JWORK), LDWORK-JWORK+1, IERR )
C
C           Apply the transformation to the right hand side part.
C           Workspace: need   v + N + 1,
C                      prefer v + N + NB.
C
            CALL DORMQR( 'Left', 'Transpose', LDDW, 1, N, DWORK(INIGAM),
     $                   LDDW, DWORK(ITAU), DWORK(IRHS), LDDW,
     $                   DWORK(JWORK), LDWORK-JWORK+1, IERR )
C
            IF ( NCYC ) THEN
C
C              Save the triangular factor of  Gamma  and the
C              corresponding right hand side.
C
               CALL DLACPY( 'Upper', N, NCP1, DWORK(INIGAM), LDDW,
     $                      DWORK(INIR), LDR )
            END IF
         ELSE
C
C           Compress the current (but not the first) data segment of
C           Gamma.
C           Workspace: need   v + N - 1.
C
            CALL MB04OD( 'Full', N, 1,  LDDW, DWORK(INIR), LDR,
     $                   DWORK(INIGAM), LDDW, DWORK(INIH), LDR,
     $                   DWORK(IRHS), LDDW, DWORK(ITAU), DWORK(JWORK) )
         END IF
C
         IUPNT = IUPNT + NOBS
         IYPNT = IYPNT + NOBS
  150 CONTINUE
C
C     Estimate the reciprocal condition number of the triangular factor
C     of the QR decomposition.
C     Workspace: need  u + 3*N, where
C                      u = t*L*(N + 1), if NCYCLE = 1;
C                      u = w,           if NCYCLE > 1.
C
      CALL DTRCON( '1-norm', 'Upper', 'No Transpose', N, DWORK(INIR),
     $             LDR, RCOND, DWORK(IE), IWORK, IERR )
C
      TOLL = TOL
      IF ( TOLL.LE.ZERO )
     $   TOLL = DLAMCH( 'Precision' )
      IF ( RCOND.LE.TOLL**( TWO/THREE ) ) THEN
         IWARN = 4
C
C        The least squares problem is ill-conditioned.
C        Use SVD to solve it.
C        Workspace: need   u + 6*N;
C                   prefer larger.
C
         CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, DWORK(INIR+1),
     $                LDR )
         ISV   = IE
         JWORK = ISV + N
         CALL DGELSS( N, N, 1, DWORK(INIR), LDR, DWORK(INIH), LDR,
     $                DWORK(ISV), TOLL, RANK, DWORK(JWORK),
     $                LDWORK-JWORK+1, IERR )
         IF ( IERR.GT.0 ) THEN
C
C           Return if SVD algorithm did not converge.
C
            INFO = 2
            RETURN
         END IF
         MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) - JWORK + 1 )
      ELSE
C
C        Find the least squares solution using QR decomposition only.
C
         CALL DTRSV( 'Upper', 'No Transpose', 'Non Unit', N,
     $               DWORK(INIR), LDR, DWORK(INIH), 1 )
      END IF
C
C     Return the estimated initial state of the system  x0.
C
      CALL DCOPY( N, DWORK(INIH), 1, X0, 1 )
C
      DWORK(1) = MAXWRK
      DWORK(2) = RCOND
C
      RETURN
C
C *** End of IB01RD ***
      END