Moved handle_orgqr_info

Author: loiseaujc

src/lapack/stdlib_linalg_lapack_aux.fypp

@@ -46,6 +46,7 @@ module stdlib_linalg_lapack_aux
      public :: handle_gesv_info
      public :: handle_gees_info
      public :: handle_geqrf_info
+     public :: handle_orgqr_info
 
      ! SELCTG is a LOGICAL FUNCTION of three DOUBLE PRECISION arguments 
      ! used to select eigenvalues to sort to the top left of the Schur form. 
@@ -1457,4 +1458,29 @@ module stdlib_linalg_lapack_aux
 
      end subroutine handle_geqrf_info
 
+     elemental subroutine handle_orgqr_info(this,info,m,n,k,lwork,err)
+         character(len=*), intent(in) :: this
+         integer(ilp), intent(in) :: info,m,n,k,lwork
+         type(linalg_state_type), intent(out) :: err
+
+         ! Process output
+         select case (info)
+            case (0)
+                ! Success
+            case (-1)
+                err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix size m=',m)
+            case (-2)
+                err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix size n=',n)
+            case (-4)
+                err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid k=min(m,n)=',k)
+            case (-5)
+                err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix size a=',[m,n])                
+            case (-8)
+                err = linalg_state_type(this,LINALG_ERROR,'invalid input for lwork=',lwork)
+            case default
+                err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'catastrophic error')
+         end select
+
+     end subroutine handle_orgqr_info     
+
 end module stdlib_linalg_lapack_aux

src/stdlib_linalg_qr.fypp

@@ -3,7 +3,7 @@
 submodule (stdlib_linalg) stdlib_linalg_qr
      use stdlib_linalg_constants
      use stdlib_linalg_lapack, only: geqrf, orgqr, ungqr
-     use stdlib_linalg_lapack_aux, only: handle_geqrf_info
+     use stdlib_linalg_lapack_aux, only: handle_geqrf_info, handle_orgqr_info
      use stdlib_linalg_state, only: linalg_state_type, linalg_error_handling, LINALG_ERROR, &
          LINALG_INTERNAL_ERROR, LINALG_VALUE_ERROR     
      implicit none
@@ -43,29 +43,6 @@ submodule (stdlib_linalg) stdlib_linalg_qr
 
      end subroutine check_problem_size
 
-     elemental subroutine handle_orgqr_info(info,m,n,k,lwork,err)
-         integer(ilp), intent(in) :: info,m,n,k,lwork
-         type(linalg_state_type), intent(out) :: err
-
-         ! Process output
-         select case (info)
-            case (0)
-                ! Success
-            case (-1)
-                err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix size m=',m)
-            case (-2)
-                err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix size n=',n)
-            case (-4)
-                err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid k=min(m,n)=',k)
-            case (-5)
-                err = linalg_state_type(this,LINALG_VALUE_ERROR,'invalid matrix size a=',[m,n])                
-            case (-8)
-                err = linalg_state_type(this,LINALG_ERROR,'invalid input for lwork=',lwork)
-            case default
-                err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'catastrophic error')
-         end select
-
-     end subroutine handle_orgqr_info     
 
      #:for rk,rt,ri in RC_KINDS_TYPES
 
@@ -103,7 +80,7 @@ submodule (stdlib_linalg) stdlib_linalg_qr
          lwork_ord = -1_ilp
          call #{if rt.startswith('complex')}# ungqr #{else}# orgqr #{endif}#  &
               (m,m,k,a_dummy,m,tau_dummy,work_dummy,lwork_ord,info)
-         call handle_orgqr_info(info,m,n,k,lwork_ord,err0)   
+         call handle_orgqr_info(this,info,m,n,k,lwork_ord,err0)   
          if (err0%error()) then 
             call linalg_error_handling(err0,err)
             return
@@ -215,7 +192,7 @@ submodule (stdlib_linalg) stdlib_linalg_qr
                  ! Convert K elementary reflectors tau(1:k) -> orthogonal matrix Q
                  call #{if rt.startswith('complex')}# ungqr #{else}# orgqr #{endif}#  &
                       (q1,q2,k,amat,lda,tau,work,lwork,info)
-                 call handle_orgqr_info(info,m,n,k,lwork,err0)      
+                 call handle_orgqr_info(this,info,m,n,k,lwork,err0)      
 
                  ! Copy result back to Q
                  if (.not.use_q_matrix) q = amat(:q1,:q2)