f08aece.c

/* nag_lapackeig_dgeqrf (f08aec) Example Program.
 *
 * Copyright 2025 Numerical Algorithms Group.
 *
 * Mark 31.1, 2025.
 */
#include<nag.h>
#include<stdio.h>
intmain(void){
/* Scalars */
Integeri,j,m,n,nrhs,pda,pdb,tau_len;
Integerexit_status=0;
NagErrorfail;
Nag_OrderTypeorder;
/* Arrays */
double*a=0,*b=0,*tau=0;
#ifdef NAG_COLUMN_MAJOR
#define A(I, J) a[(J - 1) * pda + I - 1]
#define B(I, J) b[(J - 1) * pdb + I - 1]
order=Nag_ColMajor;
#else
#define A(I, J) a[(I - 1) * pda + J - 1]
#define B(I, J) b[(I - 1) * pdb + J - 1]
order=Nag_RowMajor;
#endif
INIT_FAIL(fail);
printf("nag_lapackeig_dgeqrf (f08aec) Example Program Results\n\n");
/* Skip heading in data file */
scanf("%*[^\n] ");
scanf("%"NAG_IFMT"%"NAG_IFMT"%"NAG_IFMT"%*[^\n] ",&m,&n,&nrhs);
#ifdef NAG_COLUMN_MAJOR
pda=m;
pdb=m;
#else
pda=n;
pdb=nrhs;
#endif
tau_len=MIN(m,n);
/* Allocate memory */
if(!(a=NAG_ALLOC(m*n,double))||!(b=NAG_ALLOC(m*nrhs,double))||
!(tau=NAG_ALLOC(tau_len,double))){
printf("Allocation failure\n");
exit_status=-1;
gotoEND;
}
/* Read A and B from data file */
for(i=1;i<=m;++i){
for(j=1;j<=n;++j)
scanf("%lf",&A(i,j));
}
scanf("%*[^\n] ");
for(i=1;i<=m;++i){
for(j=1;j<=nrhs;++j)
scanf("%lf",&B(i,j));
}
scanf("%*[^\n] ");
/* Compute the QR factorization of A */
/* nag_lapackeig_dgeqrf (f08aec).
 * QR factorization of real general rectangular matrix
 */
nag_lapackeig_dgeqrf(order,m,n,a,pda,tau,&fail);
if(fail.code!=NE_NOERROR){
printf("Error from nag_lapackeig_dgeqrf (f08aec).\n%s\n",fail.message);
exit_status=1;
gotoEND;
}
/* Compute C = (Q^T)*B, storing the result in B */
/* nag_lapackeig_dormqr (f08agc).
 * Apply orthogonal transformation determined by nag_lapackeig_dgeqrf (f08aec)
 * or nag_lapackeig_dgeqpf (f08bec)
 */
nag_lapackeig_dormqr(order,Nag_LeftSide,Nag_Trans,m,nrhs,n,a,pda,tau,
b,pdb,&fail);
if(fail.code!=NE_NOERROR){
printf("Error from nag_lapackeig_dormqr (f08agc).\n%s\n",fail.message);
exit_status=1;
gotoEND;
}
/* Compute least squares solution by back-substitution in R*X = C */
/* nag_lapacklin_dtrtrs (f07tec).
 * Solution of real triangular system of linear equations,
 * multiple right-hand sides
 */
nag_lapacklin_dtrtrs(order,Nag_Upper,Nag_NoTrans,Nag_NonUnitDiag,n,nrhs,
a,pda,b,pdb,&fail);
if(fail.code!=NE_NOERROR){
printf("Error from nag_lapacklin_dtrtrs (f07tec).\n%s\n",fail.message);
exit_status=1;
gotoEND;
}
/* Print least squares solution(s) */
/* nag_file_print_matrix_real_gen (x04cac).
 * Print real general matrix (easy-to-use)
 */
fflush(stdout);
nag_file_print_matrix_real_gen(order,Nag_GeneralMatrix,Nag_NonUnitDiag,n,
nrhs,b,pdb,"Least squares solution(s)",0,
&fail);
if(fail.code!=NE_NOERROR){
printf("Error from nag_file_print_matrix_real_gen (x04cac).\n%s\n",
fail.message);
exit_status=1;
gotoEND;
}
END:
NAG_FREE(a);
NAG_FREE(b);
NAG_FREE(tau);
returnexit_status;
}