void solveSingleScatterers(LSMSSystemParameters &lsms, LocalTypeInfo &local,
std::vector<Matrix<Real> > &vr, Complex energy,
std::vector<NonRelativisticSingleScattererSolution> &solution,int iie)
{
// ========================== SINGLE SCATTERER STUFF
Complex prel=std::sqrt(energy*(1.0+energy*c2inv));
Complex pnrel=std::sqrt(energy);
for(int i=0; i<local.num_local; i++)
solution[i].init(lsms,local.atom[i],&local.tmatStore(iie*local.blkSizeTmatStore,i));
if(lsms.nrelv>0) prel=pnrel;
if(local.atom.size()>solution.size()) solution.resize(local.atom.size());
// this is not ready for multithreading yet
// else: pragma omp parallel for
// if(lsms.global.iprint>=0) printf("calculate single scatterer solutions.\n");
for(int i=0; i<local.atom.size(); i++)
{
// if(lsms.global.iprint>=1) printf("calc single scatterer %d.%d\n",comm.rank,i);
//printf("calc single scatterer atom no. = %d\n",i);
calculateSingleScattererSolution(lsms,local.atom[i],vr[i],energy,prel,pnrel,solution[i]);
// calculate pmat_m (needed for tr_pxtau)
int kkrsz=local.atom[i].kkrsz;
int kkrszsqr=kkrsz*kkrsz;
int info;
int ipvt[kkrsz];
if(lsms.n_spin_cant==2 && lsms.nrel_rel==0)
{
local.atom[i].pmat_m[iie].resize(kkrsz,kkrsz);
Complex *pmat = new Complex[kkrszsqr];
Complex *wbig = new Complex[kkrszsqr];
Complex *pmat_m_ptr=&local.atom[i].pmat_m[iie](0,0);
cblas_zcopy(kkrszsqr,&solution[i].tmat_l(0,0,0),1,pmat,1);
cblas_zcopy(kkrszsqr,&solution[i].tmat_l(0,0,1),1,pmat_m_ptr,1);
zgetrf_(&kkrsz,&kkrsz,pmat_m_ptr,&kkrsz,ipvt,&info);
zgetri_(&kkrsz,pmat_m_ptr,&kkrsz,ipvt,wbig,&kkrszsqr,&info);
// -------------------------------------------------------------
zgetrf_(&kkrsz,&kkrsz,pmat,&kkrsz,ipvt,&info);
zgetri_(&kkrsz,pmat,&kkrsz,ipvt,wbig,&kkrszsqr,&info);
for(int j=0; j<kkrszsqr; j++) pmat_m_ptr[j]-=pmat[j];
delete [] wbig;
delete [] pmat;
}
}
// ========= END SINGLE SCATTERER STUFF ======================
}
void QuasiNewton<dcomplex>::symmNonHerDiag(int NTrial, ostream &output){
char JOBVL = 'N';
char JOBVR = 'V';
int TwoNTrial = 2*NTrial;
int *IPIV = new int[TwoNTrial];
int INFO;
ComplexCMMap SSuper(this->SSuperMem, TwoNTrial,TwoNTrial);
ComplexCMMap ASuper(this->ASuperMem, TwoNTrial,TwoNTrial);
ComplexCMMap SCPY(this->SCPYMem, TwoNTrial,TwoNTrial);
ComplexCMMap NHrProd(this->NHrProdMem,TwoNTrial,TwoNTrial);
SCPY = SSuper; // Copy of original matrix to use for re-orthogonalization
// Invert the metric (maybe not needed?)
zgetrf_(&TwoNTrial,&TwoNTrial,this->SSuperMem,&TwoNTrial,IPIV,&INFO);
zgetri_(&TwoNTrial,this->SSuperMem,&TwoNTrial,IPIV,this->WORK,&this->LWORK,
&INFO);
delete [] IPIV;
NHrProd = SSuper * ASuper;
// cout << "PROD" << endl << NHrProd << endl;
zgeev_(&JOBVL,&JOBVR,&TwoNTrial,NHrProd.data(),&TwoNTrial,this->ERMem,
this->SSuperMem,&TwoNTrial,this->SSuperMem,&TwoNTrial,
this->WORK,&this->LWORK,this->RWORK,&INFO);
// Sort eigensystem using Bubble Sort
ComplexVecMap E(this->ERMem,TwoNTrial);
ComplexCMMap VR(this->SSuperMem,TwoNTrial,TwoNTrial);
// cout << endl << ER << endl;
this->eigSrt(VR,E);
// cout << endl << ER << endl;
// Grab the "positive paired" roots (throw away other element of the pair)
this->ERMem += NTrial;
new (&E ) ComplexVecMap(this->ERMem,NTrial);
new (&SSuper) ComplexCMMap(this->SSuperMem+2*NTrial*NTrial,2*NTrial,NTrial);
RealVecMap ER(this->RealEMem,NTrial);
ER = E.real();
/*
* Re-orthogonalize the eigenvectors with respect to the metric S(R)
* because DSYGV orthogonalzies the vectors with respect to E(R)
* because we solve the opposite problem.
*
* Gramm-Schmidt
*/
this->metBiOrth(SSuper,SCPY);
// Separate the eigenvectors into gerade and ungerade parts
ComplexCMMap XTSigmaR(this->XTSigmaRMem,NTrial,NTrial);
ComplexCMMap XTSigmaL(this->XTSigmaLMem,NTrial,NTrial);
XTSigmaR = SSuper.block(0, 0,NTrial,NTrial);
XTSigmaL = SSuper.block(NTrial,0,NTrial,NTrial);
// CErr();
}
DLLEXPORT MKL_INT z_lu_inverse_factored(MKL_INT n, MKL_Complex16 a[], MKL_INT ipiv[], MKL_Complex16 work[], MKL_INT lwork)
{
MKL_INT i;
for(i = 0; i < n; ++i ){
ipiv[i] += 1;
}
MKL_INT info = 0;
zgetri_(&n,a,&n,ipiv,work,&lwork,&info);
for(i = 0; i < n; ++i ){
ipiv[i] -= 1;
}
return info;
}
DLLEXPORT MKL_INT z_lu_inverse(MKL_INT n, MKL_Complex16 a[], MKL_Complex16 work[], MKL_INT lwork)
{
MKL_INT* ipiv = new MKL_INT[n];
MKL_INT info = 0;
zgetrf_(&n,&n,a,&n,ipiv,&info);
if (info != 0){
delete[] ipiv;
return info;
}
zgetri_(&n,a,&n,ipiv,work,&lwork,&info);
delete[] ipiv;
return info;
}
DLLEXPORT int z_lu_inverse_factored(int n, doublecomplex a[], int ipiv[], doublecomplex work[], int lwork)
{
int i;
for(i = 0; i < n; ++i ){
ipiv[i] += 1;
}
int info = 0;
zgetri_(&n,a,&n,ipiv,work,&lwork,&info);
for(i = 0; i < n; ++i ){
ipiv[i] -= 1;
}
return info;
}
DLLEXPORT int z_lu_inverse(int n, doublecomplex a[], doublecomplex work[], int lwork)
{
int* ipiv = new int[n];
int info = 0;
zgetrf_(&n,&n,a,&n,ipiv,&info);
if (info != 0){
delete[] ipiv;
return info;
}
zgetri_(&n,a,&n,ipiv,work,&lwork,&info);
delete[] ipiv;
return info;
}
bool inv(const cmat &X, cmat &Y)
{
// it_assert1(X.rows() == X.cols(), "inv: matrix is not square");
int m = X.rows(), info, lwork;
lwork = m; // may be choosen better
ivec p(m);
Y = X;
cvec work(lwork);
zgetrf_(&m, &m, Y._data(), &m, p._data(), &info); // LU-factorization
if (info!=0)
return false;
zgetri_(&m, Y._data(), &m, p._data(), work._data(), &lwork, &info);
return (info==0);
}
void zinverma ( doubleComplex* in, doubleComplex* out, int leadDimIn )
{
int info = 0 ;
int* vectPivot = (int*) malloc ( sizeof(int) * (unsigned int)( leadDimIn) );
doubleComplex* work = (doubleComplex*) malloc ( sizeof(doubleComplex) * (unsigned int) (leadDimIn*leadDimIn) );
int i = 0 ;
for ( i = 0 ; i < leadDimIn*leadDimIn ; i ++)
{
out[i] = in[i] ;
}
zgetrf_ ( &leadDimIn, &leadDimIn, out, &leadDimIn, vectPivot, &info );
zgetri_ ( &leadDimIn, out, &leadDimIn , vectPivot, work , &leadDimIn , &info );
free(vectPivot);
free(work);
}
// Interface to lapack routine zgetri
// nn: nrow and ncol of A
void lapack_zgetri(int nn, dcmplx *AA, int *ipiv)
{
int lda, lwork, info;
dcmplx *work = NULL;
lda = (1 > nn) ? 1 : nn;
lwork = lda;
work = (dcmplx *) calloc(lwork, sizeof(dcmplx));
check_mem(work, "work");
zgetri_(&nn, AA, &lda, ipiv, work, &lwork, &info);
check(info == 0, "Failed zgetri, info = %d", info);
freeup(work);
return;
error:
if(work) freeup(work);
abort();
}
matrix inv(const matrix& A)
{ static StopWatch watch("inv(matrix)");
watch.start();
int N = A.nRows();
myassert(N > 0);
myassert(N == A.nCols());
matrix invA(A); //destructible copy
int ldA = A.nRows(); //leading dimension
std::vector<int> iPivot(N); //pivot info
int info; //error code in return
//LU decomposition (in place):
zgetrf_(&N, &N, invA.data(), &ldA, iPivot.data(), &info);
if(info<0) { logPrintf("Argument# %d to LAPACK LU decomposition routine ZGETRF is invalid.\n", -info); stackTraceExit(1); }
if(info>0) { logPrintf("LAPACK LU decomposition routine ZGETRF found input matrix to be singular at the %d'th step.\n", info); stackTraceExit(1); }
//Compute inverse in place:
int lWork = (64+1)*N;
std::vector<complex> work(lWork);
zgetri_(&N, invA.data(), &ldA, iPivot.data(), work.data(), &lWork, &info);
if(info<0) { logPrintf("Argument# %d to LAPACK matrix inversion routine ZGETRI is invalid.\n", -info); stackTraceExit(1); }
if(info>0) { logPrintf("LAPACK matrix inversion routine ZGETRI found input matrix to be singular at the %d'th step.\n", info); stackTraceExit(1); }
watch.stop();
return invA;
}
/**
* <p>Same as {@link dlm_invert_gel} but for complex input</p>
*
*/
INT16 dlm_invert_gelC(COMPLEX64* A, INT32 nXA, COMPLEX64* lpnDet) {
integer n = (integer) nXA;
integer c__1 = 1;
integer c_n1 = -1;
integer info = 0;
integer* ipiv = dlp_calloc(n, sizeof(integer));
void* work = NULL;
char opts[1] = { ' ' };
extern integer ilaenv_(integer*,char*,char*,integer*,integer*,integer*,integer*,ftnlen,ftnlen);
#ifdef __MAX_TYPE_32BIT
extern int cgetrf_(integer*,integer*,complex*,integer*,integer*,integer*);
extern int cgetri_(integer*,complex*,integer*,integer*,complex*,integer*,integer*);
char name[8] = { 'C', 'G', 'E', 'T', 'R', 'I' };
integer lwork = n * ilaenv_(&c__1, name, opts, &n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
work = dlp_calloc(lwork, sizeof(complex));
if(!ipiv || !work) return ERR_MEM;
cgetrf_(&n,&n,(complex*)A,&n,ipiv,&info);
if(lpnDet != NULL) *lpnDet = (info > 0) ? CMPLX(0.0) : dlm_get_det_trfC(A, nXA, ipiv);
cgetri_(&n,(complex*)A,&n,ipiv,work,&lwork,&info);
#else
extern int zgetrf_(integer*,integer*,doublecomplex*,integer*,integer*,integer*);
extern int zgetri_(integer*,doublecomplex*,integer*,integer*,doublecomplex*,integer*,integer*);
char name[8] = { 'Z', 'G', 'E', 'T', 'R', 'I' };
integer lwork = n * ilaenv_(&c__1, name, opts, &n, &c_n1, &c_n1, &c_n1, (ftnlen) 6, (ftnlen) 1);
work = dlp_calloc(lwork, sizeof(doublecomplex));
if (!ipiv || !work) return ERR_MEM;
zgetrf_(&n, &n, (doublecomplex*) A, &n, ipiv, &info);
if (lpnDet != NULL) *lpnDet = (info > 0) ? CMPLX(0.0) : dlm_get_det_trfC(A, nXA, ipiv);
zgetri_(&n, (doublecomplex*) A, &n, ipiv, work, &lwork, &info);
#endif
dlp_free(work);
dlp_free(ipiv);
return (info == 0) ? O_K : NOT_EXEC;
}
/* Subroutine */ int zerrge_(char *path, integer *nunit)
{
/* System generated locals */
integer i__1;
doublereal d__1, d__2;
doublecomplex z__1;
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
doublecomplex a[16] /* was [4][4] */, b[4];
integer i__, j;
doublereal r__[4];
doublecomplex w[8], x[4];
char c2[2];
doublereal r1[4], r2[4];
doublecomplex af[16] /* was [4][4] */;
integer ip[4], info;
doublereal anrm, ccond, rcond;
extern /* Subroutine */ int zgbtf2_(integer *, integer *, integer *,
integer *, doublecomplex *, integer *, integer *, integer *),
zgetf2_(integer *, integer *, doublecomplex *, integer *, integer
*, integer *), alaesm_(char *, logical *, integer *);
extern logical lsamen_(integer *, char *, char *);
extern /* Subroutine */ int zgbcon_(char *, integer *, integer *, integer
*, doublecomplex *, integer *, integer *, doublereal *,
doublereal *, doublecomplex *, doublereal *, integer *),
chkxer_(char *, integer *, integer *, logical *, logical *), zgecon_(char *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *, doublecomplex *, doublereal *,
integer *), zgbequ_(integer *, integer *, integer *,
integer *, doublecomplex *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *), zgbrfs_(
char *, integer *, integer *, integer *, integer *, doublecomplex
*, integer *, doublecomplex *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *, doublecomplex *, doublereal *,
integer *), zgbtrf_(integer *, integer *, integer *,
integer *, doublecomplex *, integer *, integer *, integer *),
zgeequ_(integer *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *), zgerfs_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *, doublecomplex *, doublereal *,
integer *), zgetrf_(integer *, integer *, doublecomplex *,
integer *, integer *, integer *), zgetri_(integer *,
doublecomplex *, integer *, integer *, doublecomplex *, integer *,
integer *), zgbtrs_(char *, integer *, integer *, integer *,
integer *, doublecomplex *, integer *, integer *, doublecomplex *,
integer *, integer *), zgetrs_(char *, integer *,
integer *, doublecomplex *, integer *, integer *, doublecomplex *,
integer *, integer *);
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZERRGE tests the error exits for the COMPLEX*16 routines */
/* for general matrices. */
/* Arguments */
/* ========= */
/* PATH (input) CHARACTER*3 */
/* The LAPACK path name for the routines to be tested. */
/* NUNIT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
infoc_1.nout = *nunit;
io___1.ciunit = infoc_1.nout;
s_wsle(&io___1);
e_wsle();
s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
/* Set the variables to innocuous values. */
for (j = 1; j <= 4; ++j) {
for (i__ = 1; i__ <= 4; ++i__) {
i__1 = i__ + (j << 2) - 5;
d__1 = 1. / (doublereal) (i__ + j);
d__2 = -1. / (doublereal) (i__ + j);
z__1.r = d__1, z__1.i = d__2;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
i__1 = i__ + (j << 2) - 5;
d__1 = 1. / (doublereal) (i__ + j);
d__2 = -1. / (doublereal) (i__ + j);
z__1.r = d__1, z__1.i = d__2;
af[i__1].r = z__1.r, af[i__1].i = z__1.i;
/* L10: */
}
i__1 = j - 1;
b[i__1].r = 0., b[i__1].i = 0.;
r1[j - 1] = 0.;
r2[j - 1] = 0.;
i__1 = j - 1;
w[i__1].r = 0., w[i__1].i = 0.;
i__1 = j - 1;
x[i__1].r = 0., x[i__1].i = 0.;
ip[j - 1] = j;
/* L20: */
}
infoc_1.ok = TRUE_;
/* Test error exits of the routines that use the LU decomposition */
/* of a general matrix. */
if (lsamen_(&c__2, c2, "GE")) {
/* ZGETRF */
s_copy(srnamc_1.srnamt, "ZGETRF", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
zgetrf_(&c_n1, &c__0, a, &c__1, ip, &info);
chkxer_("ZGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zgetrf_(&c__0, &c_n1, a, &c__1, ip, &info);
chkxer_("ZGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
zgetrf_(&c__2, &c__1, a, &c__1, ip, &info);
chkxer_("ZGETRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* ZGETF2 */
s_copy(srnamc_1.srnamt, "ZGETF2", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
zgetf2_(&c_n1, &c__0, a, &c__1, ip, &info);
chkxer_("ZGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zgetf2_(&c__0, &c_n1, a, &c__1, ip, &info);
chkxer_("ZGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
zgetf2_(&c__2, &c__1, a, &c__1, ip, &info);
chkxer_("ZGETF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* ZGETRI */
s_copy(srnamc_1.srnamt, "ZGETRI", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
zgetri_(&c_n1, a, &c__1, ip, w, &c__1, &info);
chkxer_("ZGETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zgetri_(&c__2, a, &c__1, ip, w, &c__2, &info);
chkxer_("ZGETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
zgetri_(&c__2, a, &c__2, ip, w, &c__1, &info);
chkxer_("ZGETRI", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* ZGETRS */
s_copy(srnamc_1.srnamt, "ZGETRS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
zgetrs_("/", &c__0, &c__0, a, &c__1, ip, b, &c__1, &info);
chkxer_("ZGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zgetrs_("N", &c_n1, &c__0, a, &c__1, ip, b, &c__1, &info);
chkxer_("ZGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zgetrs_("N", &c__0, &c_n1, a, &c__1, ip, b, &c__1, &info);
chkxer_("ZGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zgetrs_("N", &c__2, &c__1, a, &c__1, ip, b, &c__2, &info);
chkxer_("ZGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
zgetrs_("N", &c__2, &c__1, a, &c__2, ip, b, &c__1, &info);
chkxer_("ZGETRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* ZGERFS */
s_copy(srnamc_1.srnamt, "ZGERFS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
zgerfs_("/", &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
c__1, r1, r2, w, r__, &info);
chkxer_("ZGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zgerfs_("N", &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &c__1, x, &
c__1, r1, r2, w, r__, &info);
chkxer_("ZGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zgerfs_("N", &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &c__1, x, &
c__1, r1, r2, w, r__, &info);
chkxer_("ZGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zgerfs_("N", &c__2, &c__1, a, &c__1, af, &c__2, ip, b, &c__2, x, &
c__2, r1, r2, w, r__, &info);
chkxer_("ZGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
zgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__1, ip, b, &c__2, x, &
c__2, r1, r2, w, r__, &info);
chkxer_("ZGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
zgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__1, x, &
c__2, r1, r2, w, r__, &info);
chkxer_("ZGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
zgerfs_("N", &c__2, &c__1, a, &c__2, af, &c__2, ip, b, &c__2, x, &
c__1, r1, r2, w, r__, &info);
chkxer_("ZGERFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* ZGECON */
s_copy(srnamc_1.srnamt, "ZGECON", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
zgecon_("/", &c__0, a, &c__1, &anrm, &rcond, w, r__, &info)
;
chkxer_("ZGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zgecon_("1", &c_n1, a, &c__1, &anrm, &rcond, w, r__, &info)
;
chkxer_("ZGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
zgecon_("1", &c__2, a, &c__1, &anrm, &rcond, w, r__, &info)
;
chkxer_("ZGECON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* ZGEEQU */
s_copy(srnamc_1.srnamt, "ZGEEQU", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
zgeequ_(&c_n1, &c__0, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info);
chkxer_("ZGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zgeequ_(&c__0, &c_n1, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info);
chkxer_("ZGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
zgeequ_(&c__2, &c__2, a, &c__1, r1, r2, &rcond, &ccond, &anrm, &info);
chkxer_("ZGEEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* Test error exits of the routines that use the LU decomposition */
/* of a general band matrix. */
} else if (lsamen_(&c__2, c2, "GB")) {
/* ZGBTRF */
s_copy(srnamc_1.srnamt, "ZGBTRF", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
zgbtrf_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, ip, &info);
chkxer_("ZGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zgbtrf_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, ip, &info);
chkxer_("ZGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zgbtrf_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, ip, &info);
chkxer_("ZGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
zgbtrf_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, ip, &info);
chkxer_("ZGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
zgbtrf_(&c__2, &c__2, &c__1, &c__1, a, &c__3, ip, &info);
chkxer_("ZGBTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* ZGBTF2 */
s_copy(srnamc_1.srnamt, "ZGBTF2", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
zgbtf2_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, ip, &info);
chkxer_("ZGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zgbtf2_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, ip, &info);
chkxer_("ZGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zgbtf2_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, ip, &info);
chkxer_("ZGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
zgbtf2_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, ip, &info);
chkxer_("ZGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
zgbtf2_(&c__2, &c__2, &c__1, &c__1, a, &c__3, ip, &info);
chkxer_("ZGBTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* ZGBTRS */
s_copy(srnamc_1.srnamt, "ZGBTRS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
zgbtrs_("/", &c__0, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
info);
chkxer_("ZGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zgbtrs_("N", &c_n1, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
info);
chkxer_("ZGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zgbtrs_("N", &c__1, &c_n1, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
info);
chkxer_("ZGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
zgbtrs_("N", &c__1, &c__0, &c_n1, &c__1, a, &c__1, ip, b, &c__1, &
info);
chkxer_("ZGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zgbtrs_("N", &c__1, &c__0, &c__0, &c_n1, a, &c__1, ip, b, &c__1, &
info);
chkxer_("ZGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
zgbtrs_("N", &c__2, &c__1, &c__1, &c__1, a, &c__3, ip, b, &c__2, &
info);
chkxer_("ZGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
zgbtrs_("N", &c__2, &c__0, &c__0, &c__1, a, &c__1, ip, b, &c__1, &
info);
chkxer_("ZGBTRS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* ZGBRFS */
s_copy(srnamc_1.srnamt, "ZGBRFS", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
zgbrfs_("/", &c__0, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &
c__1, x, &c__1, r1, r2, w, r__, &info);
chkxer_("ZGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zgbrfs_("N", &c_n1, &c__0, &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &
c__1, x, &c__1, r1, r2, w, r__, &info);
chkxer_("ZGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zgbrfs_("N", &c__1, &c_n1, &c__0, &c__0, a, &c__1, af, &c__1, ip, b, &
c__1, x, &c__1, r1, r2, w, r__, &info);
chkxer_("ZGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
zgbrfs_("N", &c__1, &c__0, &c_n1, &c__0, a, &c__1, af, &c__1, ip, b, &
c__1, x, &c__1, r1, r2, w, r__, &info);
chkxer_("ZGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
zgbrfs_("N", &c__1, &c__0, &c__0, &c_n1, a, &c__1, af, &c__1, ip, b, &
c__1, x, &c__1, r1, r2, w, r__, &info);
chkxer_("ZGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
zgbrfs_("N", &c__2, &c__1, &c__1, &c__1, a, &c__2, af, &c__4, ip, b, &
c__2, x, &c__2, r1, r2, w, r__, &info);
chkxer_("ZGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
zgbrfs_("N", &c__2, &c__1, &c__1, &c__1, a, &c__3, af, &c__3, ip, b, &
c__2, x, &c__2, r1, r2, w, r__, &info);
chkxer_("ZGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
zgbrfs_("N", &c__2, &c__0, &c__0, &c__1, a, &c__1, af, &c__1, ip, b, &
c__1, x, &c__2, r1, r2, w, r__, &info);
chkxer_("ZGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 14;
zgbrfs_("N", &c__2, &c__0, &c__0, &c__1, a, &c__1, af, &c__1, ip, b, &
c__2, x, &c__1, r1, r2, w, r__, &info);
chkxer_("ZGBRFS", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* ZGBCON */
s_copy(srnamc_1.srnamt, "ZGBCON", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
zgbcon_("/", &c__0, &c__0, &c__0, a, &c__1, ip, &anrm, &rcond, w, r__,
&info);
chkxer_("ZGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zgbcon_("1", &c_n1, &c__0, &c__0, a, &c__1, ip, &anrm, &rcond, w, r__,
&info);
chkxer_("ZGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zgbcon_("1", &c__1, &c_n1, &c__0, a, &c__1, ip, &anrm, &rcond, w, r__,
&info);
chkxer_("ZGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
zgbcon_("1", &c__1, &c__0, &c_n1, a, &c__1, ip, &anrm, &rcond, w, r__,
&info);
chkxer_("ZGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
zgbcon_("1", &c__2, &c__1, &c__1, a, &c__3, ip, &anrm, &rcond, w, r__,
&info);
chkxer_("ZGBCON", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
/* ZGBEQU */
s_copy(srnamc_1.srnamt, "ZGBEQU", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
zgbequ_(&c_n1, &c__0, &c__0, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
&anrm, &info);
chkxer_("ZGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
zgbequ_(&c__0, &c_n1, &c__0, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
&anrm, &info);
chkxer_("ZGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
zgbequ_(&c__1, &c__1, &c_n1, &c__0, a, &c__1, r1, r2, &rcond, &ccond,
&anrm, &info);
chkxer_("ZGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
zgbequ_(&c__1, &c__1, &c__0, &c_n1, a, &c__1, r1, r2, &rcond, &ccond,
&anrm, &info);
chkxer_("ZGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
zgbequ_(&c__2, &c__2, &c__1, &c__1, a, &c__2, r1, r2, &rcond, &ccond,
&anrm, &info);
chkxer_("ZGBEQU", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
}
/* Print a summary line. */
alaesm_(path, &infoc_1.ok, &infoc_1.nout);
return 0;
/* End of ZERRGE */
} /* zerrge_ */
/* Main program */
int main() {
/* Locals */
int n = N, info,i,j;
int iter = 1;
/* Local arrays */
static complex A2[N][N];
static complex B2[N][N];
static complex A[N][N];
static complex U[N][N];
static complex b[N];
srand (1337);
static int ipiv[N];
int max = 0;
int min = 0;
int mu = 3;
int ml = 3;
int md = ml+mu+1;
complex sumA = 0;
complex sumU = 0;
complex ratio = 0;
//Initialize random band matrix
for (i=0;i<n;i++){
for (j=0; j<n; j++){
A2[i][j]=0;
B2[i][j]=0;
U[i][j]=0;
}
}
for (j=0;j<n;j++){
max = 0 > j-mu ? 0 : j-mu ;
min = n < j+ml+1 ? n : j+ml+1 ;
for(i=max;i<min;i++){
A2[i][j] = ((1 - ( 20.0 * rand() / ( RAND_MAX + 1.0 ) )),(1 - ( 20.0 * rand() / ( RAND_MAX + 1.0 ))));
}
}
for (i=0;i<n;i++){
for (j=0;j<n;j++){
A[i][j]=A2[i][j];
}
}
for (i=0;i<n;i++){
U[i][i]=1;
}
/// B2(ML+MU+1+i-j,j) = A(i,j) for max(1,j-MU)<=i<=min(N,j+ML)
for (j=0;j<n;j++){
max = (0 < j-mu) ? j-mu : 0 ;
min = (n < j+ml+1) ? n : j+ml+1 ;
for(i=max;i<min;i++){
B2[j][md+i-j-1]= A[j][i];
}
}
printf( "Matrix A\n" );
for( i = 0; i < n; i++ ) {
for( j = 0; j < n; j++ ) printf( " (%6.2f ,%6.2f) ", A[j][i] );
printf( "\n" );
}
printf( "Compressed A\n" );
for( i = 0; i < n; i++ ) {
for( j = 0; j < n; j++ ) printf( " (%6.2f, %6.2f)", B2[j][i] );
printf( "\n" );
}
printf( "Enter General Factor\n" );
for (i=0;i<iter;i++){
// printf( "Enter General Factor\n" );
zgetrf_(&n, &n, A2, &n, ipiv, &info);
// printf( "%d",info );
// printf( "Enter Inversion\n" );
zgetri_( &n, A2, &n, ipiv, b, &n, &info );
// printf( "%d",info );
// printf( "Exit inversion\n" );
}
printf( "\nExit inversion\n" );
printf( "Entering Banded Solve\n" );
for (i=0;i<iter;i++){
zgbsv_( &n, &ml, &mu, &n, B2, &n, ipiv, U, &n, &info );
// printf( "%d",info );
}
printf( "Exited Banded Solve\n" );
for (i=0;i<N;i++){
for (j=0;j<N;j++){
sumA = A2[j][i]+sumA;
sumU = U[j][i]+sumU;
}
}
ratio = sumA/sumU;
printf( "Accuracy - %f\n",ratio );
printf( "%d\n",info );
printf( "Inversed A\n" );
for( i = 0; i < n; i++ ) {
for( j = 0; j < n; j++ ) printf( " (%6.8f, %6.2f)", A2[j][i] );
printf( "\n" );
}
printf( "Inversed A (solve)\n" );
for( i = 0; i < n; i++ ) {
for( j = 0; j < n; j++ ) printf( " (%6.8f, %6.2f)", U[j][i] );
printf( "\n" );
}
exit( 0 );
}
