Program f08kufe

!     F08KUF Example Program Text

!     Mark 30.1 Release. NAG Copyright 2024.

!     .. Use Statements ..
      Use nag_library, Only: f06tff, f06thf, nag_wp, x04dbf, zgebrd, zgelqf,   &
                             zgeqrf, zunglq, zungqr, zunmbr
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Complex (Kind=nag_wp), Parameter :: zero = (0.0E0_nag_wp,0.0E0_nag_wp)
      Integer, Parameter               :: nin = 5, nout = 6
!     .. Local Scalars ..
      Integer                          :: i, ic, ifail, info, lda, ldph, ldu,  &
                                          lwork, m, n
!     .. Local Arrays ..
      Complex (Kind=nag_wp), Allocatable :: a(:,:), ph(:,:), tau(:), taup(:),  &
                                          tauq(:), u(:,:), work(:)
      Real (Kind=nag_wp), Allocatable  :: d(:), e(:)
      Character (1)                    :: clabs(1), rlabs(1)
!     .. Executable Statements ..
      Write (nout,*) 'F08KUF Example Program Results'
!     Skip heading in data file
      Read (nin,*)
      Do ic = 1, 2
        Read (nin,*) m, n
        lda = m
        ldph = n
        ldu = m
        lwork = 64*(m+n)
        Allocate (a(lda,n),ph(ldph,n),tau(n),taup(n),tauq(n),u(ldu,n),         &
          work(lwork),d(n),e(n-1))

!       Read A from data file

        Read (nin,*)(a(i,1:n),i=1,m)

        If (m>=n) Then

!         Compute the QR factorization of A
!         The NAG name equivalent of zgeqrf is f08asf
          Call zgeqrf(m,n,a,lda,tau,work,lwork,info)

!         Copy A to U
          Call f06tff('Lower',m,n,a,lda,u,ldu)

!         Form Q explicitly, storing the result in U
!         The NAG name equivalent of zungqr is f08atf
          Call zungqr(m,n,n,u,ldu,tau,work,lwork,info)

!         Copy R to PH (used as workspace)
          Call f06tff('Upper',n,n,a,lda,ph,ldph)

!         Set the strictly lower triangular part of R to zero
          Call f06thf('Lower',n-1,n-1,zero,zero,ph(2,1),ldph)

!         Bidiagonalize R
!         The NAG name equivalent of zgebrd is f08ksf
          Call zgebrd(n,n,ph,ldph,d,e,tauq,taup,work,lwork,info)

!         Update Q, storing the result in U
!         The NAG name equivalent of zunmbr is f08kuf
          Call zunmbr('Q','Right','No transpose',m,n,n,ph,ldph,tauq,u,ldu,     &
            work,lwork,info)

!         Print bidiagonal form and matrix Q

          Write (nout,*)
          Write (nout,*) 'Example 1: bidiagonal matrix B'
          Write (nout,*) 'Diagonal'
          Write (nout,99999) d(1:n)
          Write (nout,*) 'Superdiagonal'
          Write (nout,99999) e(1:n-1)
          Write (nout,*)
          Flush (nout)

!         ifail: behaviour on error exit
!                =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
          ifail = 0
          Call x04dbf('General',' ',m,n,u,ldu,'Bracketed','F7.4',              &
            'Example 1: matrix Q','Integer',rlabs,'Integer',clabs,80,0,ifail)

        Else

!         Compute the LQ factorization of A
!         The NAG name equivalent of zgelqf is f08avf
          Call zgelqf(m,n,a,lda,tau,work,lwork,info)

!         Copy A to PH
          Call f06tff('Upper',m,n,a,lda,ph,ldph)

!         Form Q explicitly, storing the result in PH
!         The NAG name equivalent of zunglq is f08awf
          Call zunglq(n,n,m,ph,ldph,tau,work,lwork,info)

!         Copy L to U (used as workspace)
          Call f06tff('Lower',m,m,a,lda,u,ldu)

!         Set the strictly upper triangular part of L to zero
          Call f06thf('Upper',m-1,m-1,zero,zero,u(1,2),ldu)

!         Bidiagonalize L
!         The NAG name equivalent of zgebrd is f08ksf
          Call zgebrd(m,m,u,ldu,d,e,tauq,taup,work,lwork,info)

!         Update P**H, storing the result in PH
!         The NAG name equivalent of zunmbr is f08kuf
          Call zunmbr('P','Left','Conjugate transpose',m,n,m,u,ldu,taup,ph,    &
            ldph,work,lwork,info)

!         Print bidiagonal form and matrix P**H

          Write (nout,*)
          Write (nout,*) 'Example 2: bidiagonal matrix B'
          Write (nout,*) 'Diagonal'
          Write (nout,99999) d(1:m)
          Write (nout,*) 'Superdiagonal'
          Write (nout,99999) e(1:m-1)
          Write (nout,*)
          Flush (nout)

          ifail = 0
          Call x04dbf('General',' ',m,n,ph,ldph,'Bracketed','F7.4',            &
            'Example 2: matrix P**H','Integer',rlabs,'Integer',clabs,80,0,     &
            ifail)

        End If
        Deallocate (a,ph,tau,taup,tauq,u,work,d,e)
      End Do

99999 Format (3X,(8F8.4))
    End Program f08kufe