void SpinAdapted::diagonalise(Matrix& sym, DiagonalMatrix& d, Matrix& vec)
{
int nrows = sym.Nrows();
int ncols = sym.Ncols();
assert(nrows == ncols);
d.ReSize(nrows);
vec.ReSize(nrows, nrows);
Matrix workmat;
workmat = sym;
vector<double> workquery(1);
int info = 0;
double* dptr = d.Store();
int query = -1;
DSYEV('V', 'L', nrows, workmat.Store(), nrows, dptr, &(workquery[0]), query, info); // do query to find best size
int optlength = static_cast<int>(workquery[0]);
vector<double> workspace(optlength);
DSYEV('V', 'U', nrows, workmat.Store(), nrows, dptr, &(workspace[0]), optlength, info); // do query to find best size
if (info > 0)
{
pout << "failed to converge " << endl;
abort();
}
for (int i = 0; i < nrows; ++i)
for (int j = 0; j < ncols; ++j)
vec(j+1,i+1) = workmat(i+1,j+1);
}
double SpinAdapted::rowdoubleproduct(Matrix& a, int rowa, Matrix& b, int rowb)
{
assert(a.Ncols() == b.Ncols());
double* aptr = a.Store() + a.Ncols() * rowa;
double* bptr = b.Store() + b.Ncols() * rowb;
return DDOT(a.Ncols(), aptr, 1, bptr, 1);
}
void SpinAdapted::svd(Matrix& M, DiagonalMatrix& d, Matrix& U, Matrix& V)
{
int nrows = M.Nrows();
int ncols = M.Ncols();
assert(nrows >= ncols);
int minmn = min(nrows, ncols);
int maxmn = max(nrows, ncols);
int eigenrows = min(minmn, minmn);
d.ReSize(minmn);
Matrix Ut;
Ut.ReSize(nrows, nrows);
V.ReSize(ncols, ncols);
int lwork = maxmn * maxmn + 100;
double* workspace = new double[lwork];
// first transpose matrix
Matrix Mt;
Mt = M.t();
int info = 0;
DGESVD('A', 'A', nrows, ncols, Mt.Store(), nrows, d.Store(),
Ut.Store(), nrows, V.Store(), ncols, workspace, lwork, info);
U.ReSize(nrows, ncols);
SpinAdapted::Clear(U);
for (int i = 0; i < nrows; ++i)
for (int j = 0; j < ncols; ++j)
U(i+1,j+1) = Ut(j+1,i+1);
delete[] workspace;
}
void QRZ(const Matrix& X, Matrix& Y, Matrix& M)
{
REPORT
Tracer et("QRZ(2)");
int n = X.Nrows(); int s = X.Ncols(); int t = Y.Ncols();
if (Y.Nrows() != n)
{ Throw(ProgramException("Unequal column lengths",X,Y)); }
M.resize(s,t); M = 0;Real* m0 = M.Store(); Real* m;
Real* xi0 = X.Store();
int j, k; int i = s;
while (i--)
{
Real* xj0 = Y.Store(); Real* xi = xi0; k = n;
if (k) for (;;)
{
m = m0; Real Xi = *xi; Real* xj = xj0;
j = t; while(j--) *m++ += Xi * *xj++;
if (!(--k)) break;
xi += s; xj0 += t;
}
xj0 = Y.Store(); xi = xi0++; k = n;
if (k) for (;;)
{
m = m0; Real Xi = *xi; Real* xj = xj0;
j = t; while(j--) *xj++ -= *m++ * Xi;
if (!(--k)) break;
xi += s; xj0 += t;
}
m0 += t;
}
}
double SpinAdapted::MatrixDotProduct(const Matrix& a, const Matrix& b)
{
assert((a.Nrows() == b.Nrows()) && (a.Ncols() == b.Ncols()));
#ifdef BLAS
return DDOT(a.Storage(), a.Store(), 1, b.Store(), 1);
#else
abort();
#endif
}
void copy(const Matrix& a, Matrix& b)
{
if ((b.Nrows() != a.Nrows()) || (b.Ncols() != a.Ncols()))
b.ReSize(a.Nrows(), a.Ncols());
#ifdef BLAS
DCOPY((FORTINT) a.Storage(), a.Store(), (FORTINT) 1, b.Store(), (FORTINT) 1);
#else
b = a;
#endif
}
void SpinAdapted::MatrixScaleAdd (double d, const Matrix& a, Matrix& b)
{
assert (a.Nrows () == b.Nrows () && a.Ncols () == b.Ncols ());
#ifdef BLAS
int n = a.Nrows () * a.Ncols ();
assert (n == (b.Nrows () * b.Ncols ()));
DAXPY (n, d, a.Store (), 1, b.Store (), 1);
#else
b += d * a;
#endif
}
void SpinAdapted::MatrixMultiply (double d, const Matrix& a, Matrix& b)
{
// b += d * a;
#ifdef BLAS
assert ((a.Nrows () == b.Nrows ()) && (a.Ncols () == b.Ncols ()));
int n = a.Nrows () * a.Ncols ();
GAXPY (n, d, a.Store (), 1, b.Store (), 1);
#else
b += d * a;
#endif
}
void SpinAdapted::CatenateProduct (const ObjectMatrix<Matrix*>& a, Matrix& b, bool allocate)
{
try
{
std::vector<int> indexRows (a.Nrows ());
std::vector<int> indexCols (a.Ncols ());
int rowLength = 0;
int colLength = 0;
for (int i = 0; i < indexRows.size (); ++i)
{
indexRows [i] = (i > 0) ? a (i - 1,0)->Nrows () + indexRows [i - 1] : 1;
rowLength += a (i,0)->Nrows ();
}
for (int i = 0; i < indexCols.size (); ++i)
{
indexCols [i] = (i > 0) ? a (0,i - 1)->Ncols () + indexCols [i - 1] : 1;
colLength += a (0,i)->Ncols ();
}
if (!allocate)
assert (b.Nrows () == rowLength && b.Ncols () == colLength); // precondition
else
b.ReSize (rowLength, colLength);
for (int i = 0; i < a.Nrows (); ++i)
for (int j = 0; j < a.Ncols (); ++j)
{
#ifdef BLAS
int bcols = b.Ncols();
double* bptr = b.Store() + bcols * (indexRows[i] - 1) + (indexCols[j] - 1);
Matrix* aij = a(i, j);
double* aptr = aij->Store();
int nrows = aij->Nrows();
int ncols = aij->Ncols();
for (int r = 0; r < nrows; ++r)
{
DCOPY(ncols, aptr, 1, bptr, 1);
aptr += ncols;
bptr += bcols;
}
#else
b.SubMatrix (indexRows [i], indexRows [i] + a (i,j)->Nrows () - 1, indexCols [j], indexCols [j] + a (i,j)->Ncols () - 1) = *(a (i,j));
#endif
}
}
catch (Exception)
{
pout << Exception::what () << endl;
abort ();
}
}
void QRZT(Matrix& X, LowerTriangularMatrix& L)
{
REPORT
Tracer et("QRZT(1)");
int n = X.Ncols(); int s = X.Nrows(); L.resize(s);
if (n == 0 || s == 0) { L = 0.0; return; }
Real* xi = X.Store(); int k;
for (int i=0; i<s; i++)
{
Real sum = 0.0;
Real* xi0=xi; k=n; while(k--) { sum += square(*xi++); }
sum = sqrt(sum);
if (sum == 0.0)
{
REPORT
k=n; while(k--) { *xi0++ = 0.0; }
for (int j=i; j<s; j++) L.element(j,i) = 0.0;
}
else
{
L.element(i,i) = sum;
Real* xj0=xi0; k=n; while(k--) { *xj0++ /= sum; }
for (int j=i+1; j<s; j++)
{
sum=0.0;
xi=xi0; Real* xj=xj0; k=n; while(k--) { sum += *xi++ * *xj++; }
xi=xi0; k=n; while(k--) { *xj0++ -= sum * *xi++; }
L.element(j,i) = sum;
}
}
}
}
void QRZ(Matrix& X, UpperTriangularMatrix& U)
{
REPORT
Tracer et("QRZ(1)");
int n = X.Nrows(); int s = X.Ncols(); U.ReSize(s); U = 0.0;
Real* xi0 = X.Store(); Real* u0 = U.Store(); Real* u;
int j, k; int J = s; int i = s;
while (i--)
{
Real* xj0 = xi0; Real* xi = xi0; k = n;
if (k) for (;;)
{
u = u0; Real Xi = *xi; Real* xj = xj0;
j = J; while(j--) *u++ += Xi * *xj++;
if (!(--k)) break;
xi += s; xj0 += s;
}
Real sum = sqrt(*u0); *u0 = sum; u = u0+1;
if (sum == 0.0) Throw(SingularException(U));
int J1 = J-1; j = J1; while(j--) *u++ /= sum;
xj0 = xi0; xi = xi0++; k = n;
if (k) for (;;)
{
u = u0+1; Real Xi = *xi; Real* xj = xj0;
Xi /= sum; *xj++ = Xi;
j = J1; while(j--) *xj++ -= *u++ * Xi;
if (!(--k)) break;
xi += s; xj0 += s;
}
u0 += J--;
}
}
void SpinAdapted::MatrixScale(double d, Matrix& a)
{
#ifdef BLAS
DSCAL(a.Storage(), d, a.Store(), 1);
#else
a *= d;
#endif
}
void SpinAdapted::Randomise (Matrix& a)
{
Real* val = a.Store ();
for (int i = 0; i < a.Storage (); ++i)
{
*val = double(rand ()) / RAND_MAX;
++val;
}
}
void SpinAdapted::MatrixDiagonalScale(double d, const Matrix& a, double* b)
{
//assert (a.Nrows () == a.Ncols () && a.Nrows () == b.Ncols ());
#ifdef BLAS
int n = a.Nrows ();
DAXPY (n, d, a.Store (), n+1, b, 1);
#else
//b += d * a; Should add the non-blas analogue
#endif
}
void QRZT(const Matrix& X, Matrix& Y, Matrix& M)
{
REPORT
Tracer et("QRZT(2)");
int n = X.Ncols(); int s = X.Nrows(); int t = Y.Nrows();
if (Y.Ncols() != n)
{ Throw(ProgramException("Unequal row lengths",X,Y)); }
M.resize(t,s);
Real* xi = X.Store(); int k;
for (int i=0; i<s; i++)
{
Real* xj0 = Y.Store(); Real* xi0 = xi;
for (int j=0; j<t; j++)
{
Real sum=0.0;
xi=xi0; Real* xj=xj0; k=n; while(k--) { sum += *xi++ * *xj++; }
xi=xi0; k=n; while(k--) { *xj0++ -= sum * *xi++; }
M.element(j,i) = sum;
}
}
}
void updateQRZT(Matrix& X, LowerTriangularMatrix& L)
{
REPORT
Tracer et("updateQRZT");
int n = X.Ncols(); int s = X.Nrows();
if (s != L.Nrows())
Throw(ProgramException("Incompatible dimensions",X,L));
if (n == 0 || s == 0) return;
Real* xi = X.Store(); int k;
for (int i=0; i<s; i++)
{
Real r = L.element(i,i);
Real sum = 0.0;
Real* xi0=xi; k=n; while(k--) { sum += square(*xi++); }
sum = sqrt(sum + square(r));
if (sum == 0.0)
{
REPORT
k=n; while(k--) { *xi0++ = 0.0; }
for (int j=i; j<s; j++) L.element(j,i) = 0.0;
}
else
{
Real frs = fabs(r) + sum;
Real a0 = sqrt(frs / sum); Real alpha = a0 / frs;
if (r <= 0) { REPORT L.element(i,i) = sum; alpha = -alpha; }
else { REPORT L.element(i,i) = -sum; }
Real* xj0=xi0; k=n; while(k--) { *xj0++ *= alpha; }
for (int j=i+1; j<s; j++)
{
sum = 0.0;
xi=xi0; Real* xj=xj0; k=n; while(k--) { sum += *xi++ * *xj++; }
sum += a0 * L.element(j,i);
xi=xi0; k=n; while(k--) { *xj0++ -= sum * *xi++; }
L.element(j,i) -= sum * a0;
}
}
}
}
void QRZT(Matrix& X, LowerTriangularMatrix& L)
{
REPORT
Tracer et("QZT(1)");
int n = X.Ncols(); int s = X.Nrows(); L.ReSize(s);
Real* xi = X.Store(); int k;
for (int i=0; i<s; i++)
{
Real sum = 0.0;
Real* xi0=xi; k=n; while(k--) { sum += square(*xi++); }
sum = sqrt(sum);
L.element(i,i) = sum;
if (sum==0.0) Throw(SingularException(L));
Real* xj0=xi0; k=n; while(k--) { *xj0++ /= sum; }
for (int j=i+1; j<s; j++)
{
sum=0.0;
xi=xi0; Real* xj=xj0; k=n; while(k--) { sum += *xi++ * *xj++; }
xi=xi0; k=n; while(k--) { *xj0++ -= sum * *xi++; }
L.element(j,i) = sum;
}
}
}
void updateQRZ(Matrix& X, UpperTriangularMatrix& U)
{
REPORT
Tracer et("updateQRZ");
int n = X.Nrows(); int s = X.Ncols();
if (s != U.Ncols())
Throw(ProgramException("Incompatible dimensions",X,U));
if (n == 0 || s == 0) return;
Real* xi0 = X.Store(); Real* u0 = U.Store(); Real* u;
RowVector V(s); Real* v0 = V.Store(); Real* v; V = 0.0;
int j, k; int J = s; int i = s;
while (i--)
{
Real* xj0 = xi0; Real* xi = xi0; k = n;
if (k) for (;;)
{
v = v0; Real Xi = *xi; Real* xj = xj0;
j = J; while(j--) *v++ += Xi * *xj++;
if (!(--k)) break;
xi += s; xj0 += s;
}
Real r = *u0;
Real sum = sqrt(*v0 + square(r));
if (sum == 0.0)
{
REPORT
u = u0; v = v0;
j = J; while(j--) { *u++ = 0.0; *v++ = 0.0; }
xj0 = xi0++; k = n;
if (k) for (;;)
{
*xj0 = 0.0;
if (!(--k)) break;
xj0 += s;
}
u0 += J--;
}
else
{
Real frs = fabs(r) + sum;
Real a0 = sqrt(frs / sum); Real alpha = a0 / frs;
if (r <= 0) { REPORT alpha = -alpha; *u0 = sum; }
else { REPORT *u0 = -sum; }
j = J - 1; v = v0 + 1; u = u0 + 1;
while (j--)
{ *v = a0 * *u + alpha * *v; *u -= a0 * *v; ++v; ++u; }
xj0 = xi0; xi = xi0++; k = n;
if (k) for (;;)
{
v = v0 + 1; Real Xi = *xi; Real* xj = xj0;
Xi *= alpha; *xj++ = Xi;
j = J - 1; while(j--) *xj++ -= *v++ * Xi;
if (!(--k)) break;
xi += s; xj0 += s;
}
j = J; v = v0;
while (j--) *v++ = 0.0;
u0 += J--;
}
}
}
static void tql2(DiagonalMatrix& D, DiagonalMatrix& E, Matrix& Z)
{
Tracer et("Evalue(tql2)");
Real eps = FloatingPointPrecision::Epsilon();
int n = D.Nrows(); Real* z = Z.Store(); int l;
for (l=1; l<n; l++) E.element(l-1) = E.element(l);
Real b = 0.0; Real f = 0.0; E.element(n-1) = 0.0;
for (l=0; l<n; l++)
{
int i,j;
Real& dl = D.element(l); Real& el = E.element(l);
Real h = eps * ( fabs(dl) + fabs(el) );
if (b < h) b = h;
int m;
for (m=l; m<n; m++) if (fabs(E.element(m)) <= b) break;
bool test = false;
for (j=0; j<30; j++)
{
if (m==l) { test = true; break; }
Real& dl1 = D.element(l+1);
Real g = dl; Real p = (dl1-g) / (2.0*el); Real r = sqrt(p*p + 1.0);
dl = el / (p < 0.0 ? p-r : p+r); Real h = g - dl; f += h;
Real* dlx = &dl1; i = n-l-1; while (i--) *dlx++ -= h;
p = D.element(m); Real c = 1.0; Real s = 0.0;
for (i=m-1; i>=l; i--)
{
Real ei = E.element(i); Real di = D.element(i);
Real& ei1 = E.element(i+1);
g = c * ei; h = c * p;
if ( fabs(p) >= fabs(ei))
{
c = ei / p; r = sqrt(c*c + 1.0);
ei1 = s*p*r; s = c/r; c = 1.0/r;
}
else
{
c = p / ei; r = sqrt(c*c + 1.0);
ei1 = s * ei * r; s = 1.0/r; c /= r;
}
p = c * di - s*g; D.element(i+1) = h + s * (c*g + s*di);
Real* zki = z + i; Real* zki1 = zki + 1; int k = n;
while (k--)
{
h = *zki1; *zki1 = s*(*zki) + c*h; *zki = c*(*zki) - s*h;
zki += n; zki1 += n;
}
}
el = s*p; dl = c*p;
if (fabs(el) <= b) { test = true; break; }
}
if (!test) Throw ( ConvergenceException(D) );
dl += f;
}
for (int i=0; i<n; i++)
{
int k = i; Real p = D.element(i);
for (int j=i+1; j<n; j++)
{ if (D.element(j) < p) { k = j; p = D.element(j); } }
if (k != i)
{
D.element(k) = D.element(i); D.element(i) = p; int j = n;
Real* zji = z + i; Real* zjk = z + k;
while (j--) { p = *zji; *zji = *zjk; *zjk = p; zji += n; zjk += n; }
}
}
}
void RectMatrixCol::Reset (const Matrix& M, int col)
{
REPORT
RectMatrixRowCol::Reset( M.Store()+col, M.Nrows(), M.Ncols(), 1 );
}
void RectMatrixCol::Reset (const Matrix& M, int skip, int col, int length)
{
REPORT
RectMatrixRowCol::Reset
( M.Store()+col+skip*M.Ncols(), length, M.Ncols(), 1 );
}
void RectMatrixRow::Reset (const Matrix& M, int row)
{
REPORT
RectMatrixRowCol::Reset( M.Store()+row*M.Ncols(), M.Ncols(), 1, M.Ncols() );
}
void RectMatrixRow::Reset (const Matrix& M, int row, int skip, int length)
{
REPORT
RectMatrixRowCol::Reset
( M.Store()+row*M.Ncols()+skip, length, 1, M.Ncols() );
}
Matrix operator * (const Matrix& A, const Matrix& B)
{
if (A.Clo() != B.Rlo() || A.Chi() != B.Rhi())
Matpack.Error("Matrix operator * (const Matrix&, const Matrix&): "
"non conformant arguments\n");
// allocate return matrix
Matrix C(A.Rlo(),A.Rhi(),B.Clo(),B.Chi());
//------------------------------------------------------------------------//
// the BLAS version
//------------------------------------------------------------------------//
#if defined ( _MATPACK_USE_BLAS_ )
if ( LT(B) ) { // full matrix * lower triangle
#ifdef DEBUG
cout << "GM*LT\n";
#endif
checksquare(B);
// copy A to C to protect from overwriting
copyvec(C.Store(),A.Store(),A.Elements());
charT side('L'), uplo('U'), transc('N'), diag('N');
intT m(C.Cols()), n(C.Rows()),
ldb(B.Cols()), ldc(C.Cols());
doubleT alpha(1.0);
F77NAME(dtrmm)(&side,&uplo,&transc,&diag,&m,&n,
&alpha,B.Store(),&ldb, C.Store(),&ldc);
} else if ( UT(B) ) { // full matrix * upper triangle
#ifdef DEBUG
cout << "GM*UT\n";
#endif
checksquare(B);
// copy A to C to protect from overwriting
copyvec(C.Store(),A.Store(),A.Elements());
charT side('L'), uplo('L'), transc('N'), diag('N');
intT m(C.Cols()), n(C.Rows()),
ldb(B.Cols()), ldc(C.Cols());
doubleT alpha(1.0);
F77NAME(dtrmm)(&side,&uplo,&transc,&diag,&m,&n,
&alpha,B.Store(),&ldb, C.Store(),&ldc);
} else if ( LT(A) ) { // lower triangle * full matrix
#ifdef DEBUG
cout << "LT*GM\n";
#endif
checksquare(A);
// copy B to C to protect from overwriting
copyvec(C.Store(),B.Store(),B.Elements());
charT side('R'), uplo('U'), transc('N'), diag('N');
intT m(C.Cols()), n(C.Rows()),
ldb(A.Cols()), ldc(C.Cols());
doubleT alpha(1.0);
F77NAME(dtrmm)(&side,&uplo,&transc,&diag,&m,&n,
&alpha,A.Store(),&ldb, C.Store(),&ldc);
} else if ( UT(A) ) { // upper triangle * full matrix
#ifdef DEBUG
cout << "UT*GM\n";
#endif
checksquare(A);
// copy A to C to protect from overwriting
copyvec(C.Store(),B.Store(),B.Elements());
charT side('R'), uplo('L'), transc('N'), diag('N');
intT m(C.Cols()), n(C.Rows()),
ldb(A.Cols()), ldc(C.Cols());
doubleT alpha(1.0);
F77NAME(dtrmm)(&side,&uplo,&transc,&diag,&m,&n,
&alpha,A.Store(),&ldb, C.Store(),&ldc);
} else /* GM(A) and GM(B) */ { // GM*GM: full matrix * full matrix
#ifdef DEBUG
cout << "GM*GM\n";
#endif
charT t('N');
intT m(B.Cols()), n(A.Rows()), k(B.Rows()),
lda(A.Cols()), ldb(B.Cols()), ldc(C.Cols());
doubleT alpha(1.0), beta(0.0);
F77NAME(dgemm)(&t,&t, &m,&n,&k,
&alpha,B.Store(),&ldb, A.Store(),&lda,
&beta,C.Store(),&ldc);
}
//------------------------------------------------------------------------//
// the non-BLAS version
//------------------------------------------------------------------------//
#else
int cl = A.cl, ch = A.ch,
arl = A.rl, arh = A.rh,
bcl = B.cl, bch = B.ch;
// avoid call to index operator that optimizes very badely
double **a = A.M, **b = B.M, **c = C.M;
for (int i = arl; i <= arh; i++) {
for (int j = bcl; j <= bch; j++) c[i][j] = 0.0;
for (int l = cl; l <= ch; l++) {
if ( a[i][l] != 0.0 ) {
double temp = a[i][l];
for (int j = bcl; j <= bch; j++)
c[i][j] += temp * b[l][j];
}
}
}
#endif
return C.Value();
}
void SpinAdapted::MatrixTensorProduct (const Matrix& a_ref, char conjA, Real scaleA, const Matrix& b_ref, char conjB, Real scaleB, Matrix& c, int rowstride, int colstride, bool allocate)
{
#ifndef BLAS
Matrix A;
Matrix B;
#endif
Matrix& a = const_cast<Matrix&>(a_ref); // for BLAS calls
Matrix& b = const_cast<Matrix&>(b_ref);
int arows = a.Nrows();
int acols = a.Ncols();
// some specialisations
#ifdef FAST_MTP
// if ((brows == 1) && (bcols == 1))
{
double b00 = *b.Store();
if (conjA == 'n')
{
double* cptr = c.Store()+ rowstride*c.Ncols() + colstride;
for (int i=0; i< a.Nrows();i++)
DAXPY(a.Ncols(), scaleA * scaleB * b00, a.Store()+i*a.Ncols(), 1, cptr + i*c.Ncols(), 1);
return;
}
else
{
double* aptr = a.Store();
double* cptr = c.Store() + rowstride*c.Ncols() + colstride;
for (int col = 0; col < acols; ++col)
{
DAXPY(arows, scaleA * scaleB * b00, aptr, acols, cptr, 1);
++aptr;
cptr += c.Ncols();//arows;
}
return;
}
}
// else
// abort();
#else
try
{
if (conjA == 'n' && conjB == 'n')
{
if (allocate)
{
c.ReSize (a.Nrows () * b.Nrows (), a.Ncols () * b.Ncols ());
Clear (c);
}
//assert ((c.Nrows () == (a.Nrows () * b.Nrows ())) && (c.Ncols () == (a.Ncols () * b.Ncols ())));
#ifdef BLAS
int aRows = a.Nrows ();
int aCols = a.Ncols ();
int bRows = b.Nrows ();
int bCols = b.Ncols ();
for (int i = 0; i < aRows; ++i)
for (int j = 0; j < aCols; ++j)
{
Real scale = scaleA * scaleB * a (i+1,j+1);
for (int k = 0; k < bRows; ++k)
GAXPY (bCols, scale, &b (k+1,1), 1, &c (i * bRows + k+1 +rowstride,j * bCols+1+colstride), 1);
}
return;
#else
A = a;
B = b;
#endif
}
else if (conjA == 't' && conjB == 'n')
{
if (allocate)
{
c.ReSize (a.Ncols () * b.Nrows (), a.Nrows () * b.Ncols ());
Clear (c);
}
//assert ((c.Nrows () == (a.Ncols () * b.Nrows ())) && (c.Ncols () == (a.Nrows () * b.Ncols ())));
#ifdef BLAS
int aRows = a.Ncols ();
int aCols = a.Nrows ();
int bRows = b.Nrows ();
int bCols = b.Ncols ();
for (int i = 0; i < aRows; ++i)
for (int j = 0; j < aCols; ++j)
{
Real scale = scaleA * scaleB * a (j+1,i+1);
for (int k = 0; k < bRows; ++k)
GAXPY (bCols, scale, &b (k+1,1), 1, &c (i * bRows + k+1+rowstride,j * bCols+1+colstride), 1);
}
return;
#else
A = a.t ();
B = b;
#endif
}
else if (conjA == 'n' && conjB == 't')
{
if (allocate)
{
c.ReSize (a.Nrows () * b.Ncols (), a.Ncols () * b.Nrows ());
Clear (c);
}
//assert ((c.Nrows () == (a.Nrows () * b.Ncols ())) && (c.Ncols () == (a.Ncols () * b.Nrows ())));
#ifdef BLAS
int aRows = a.Nrows ();
int aCols = a.Ncols ();
int bRows = b.Ncols ();
int bCols = b.Nrows ();
for (int i = 0; i < aRows; ++i)
for (int j = 0; j < aCols; ++j)
{
Real scale = scaleA * scaleB * a (i+1,j+1);
for (int k = 0; k < bRows; ++k)
GAXPY (bCols, scale, &b (1,k+1), bRows, &c (i * bRows + k+1+rowstride,j * bCols+1+colstride), 1);
}
return;
#else
A = a;
B = b.t ();
#endif
}
else if (conjA == 't' && conjB == 't')
{
if (allocate)
{
c.ReSize (a.Ncols () * b.Ncols (), a.Nrows () * b.Nrows ());
Clear (c);
}
//assert ((c.Nrows () == (a.Ncols () * b.Ncols ())) && (c.Ncols () == (a.Nrows () * b.Nrows ())));
#ifdef BLAS
int aRows = a.Ncols ();
int aCols = a.Nrows ();
int bRows = b.Ncols ();
int bCols = b.Nrows ();
for (int i = 0; i < aRows; ++i)
for (int j = 0; j < aCols; ++j)
{
Real scale = scaleA * scaleB * a (j+1,i+1);
for (int k = 0; k < bRows; ++k)
GAXPY (bCols, scaleA * scaleB * a (j+1,i+1), &b (1,k+1), bRows, &c (i * bRows + k+1+rowstride,j * bCols+1+colstride), 1);
}
return;
#else
A = a.t ();
B = b.t ();
#endif
}
else
abort ();
#ifndef BLAS
for (int i = 1; i <= A.Nrows (); ++i)
for (int j = 1; j <= A.Ncols (); ++j)
c.SubMatrix ((i - 1) * B.Nrows () + 1, i * B.Nrows (), (j - 1) * B.Ncols () + 1, j * B.Ncols ()) += (scaleA * scaleB) * A (i,j) * B;
#endif
}
catch (Exception)
{
pout << Exception::what () << endl;
abort ();
}
#endif
}
static void tred2(const SymmetricMatrix& A, DiagonalMatrix& D,
DiagonalMatrix& E, Matrix& Z)
{
Tracer et("Evalue(tred2)");
Real tol =
FloatingPointPrecision::Minimum()/FloatingPointPrecision::Epsilon();
int n = A.Nrows(); Z.ReSize(n,n); Z.Inject(A);
D.ReSize(n); E.ReSize(n);
Real* z = Z.Store(); int i;
for (i=n-1; i > 0; i--) // i=0 is excluded
{
Real f = Z.element(i,i-1); Real g = 0.0;
int k = i-1; Real* zik = z + i*n;
while (k--) g += square(*zik++);
Real h = g + square(f);
if (g <= tol) { E.element(i) = f; h = 0.0; }
else
{
g = sign(-sqrt(h), f); E.element(i) = g; h -= f*g;
Z.element(i,i-1) = f-g; f = 0.0;
Real* zji = z + i; Real* zij = z + i*n; Real* ej = E.Store();
int j;
for (j=0; j<i; j++)
{
*zji = (*zij++)/h; g = 0.0;
Real* zjk = z + j*n; zik = z + i*n;
k = j; while (k--) g += *zjk++ * (*zik++);
k = i-j; while (k--) { g += *zjk * (*zik++); zjk += n; }
*ej++ = g/h; f += g * (*zji); zji += n;
}
Real hh = f / (h + h); zij = z + i*n; ej = E.Store();
for (j=0; j<i; j++)
{
f = *zij++; g = *ej - hh * f; *ej++ = g;
Real* zjk = z + j*n; Real* zik = z + i*n;
Real* ek = E.Store(); k = j+1;
while (k--) *zjk++ -= ( f*(*ek++) + g*(*zik++) );
}
}
D.element(i) = h;
}
D.element(0) = 0.0; E.element(0) = 0.0;
for (i=0; i<n; i++)
{
if (D.element(i) != 0.0)
{
for (int j=0; j<i; j++)
{
Real g = 0.0;
Real* zik = z + i*n; Real* zkj = z + j;
int k = i; while (k--) { g += *zik++ * (*zkj); zkj += n; }
Real* zki = z + i; zkj = z + j;
k = i; while (k--) { *zkj -= g * (*zki); zkj += n; zki += n; }
}
}
Real* zij = z + i*n; Real* zji = z + i;
int j = i; while (j--) { *zij++ = 0.0; *zji = 0.0; zji += n; }
D.element(i) = *zij; *zij = 1.0;
}
}
void SpinAdapted::MatrixMultiply (const Matrix& a, char conjA, const Matrix& b, char conjB, Matrix& c, Real scale, double cfactor)
{
//dmrginp.justmultiply.start();
//dmrginp.justmultiply -> start(); //ROA
Matrix& a_ref = const_cast<Matrix&>(a); // for BLAS calls
Matrix& b_ref = const_cast<Matrix&>(b);
try
{
int aRows = a_ref.Nrows ();
int aCols = a_ref.Ncols ();
int bRows = b_ref.Nrows ();
int bCols = b_ref.Ncols ();
int cRows = c.Nrows ();
int cCols = c.Ncols ();
if (conjA == 'n' && conjB == 'n')
{
assert ((aCols == bRows) && (cRows == aRows) && (cCols == bCols));
#ifdef BLAS
GEMM ('n', 'n', bCols, aRows, bRows, scale, b.Store (), bCols, a.Store (), aCols, cfactor, c.Store (), bCols);
#else
c += (scale * a) * b;
#endif
}
else if (conjA == 'n' && conjB == 't')
{
assert ((aCols == bCols) && (cRows == aRows) && (cCols == bRows));
#ifdef BLAS
GEMM ('t', 'n', bRows, aRows, bCols, scale, b.Store (), bCols, a.Store (), aCols, cfactor, c.Store (), bRows);
#else
c += (scale * a) * b.t ();
#endif
}
else if (conjA == 't' && conjB == 'n')
{
assert ((aRows == bRows) && (cRows == aCols) && (cCols == bCols));
#ifdef BLAS
GEMM ('n', 't', bCols, aCols, bRows, scale, b.Store (), bCols, a.Store (), aCols, cfactor, c.Store (), bCols);
#else
c += (scale * a.t ()) * b;
#endif
}
else if (conjA == 't' && conjB == 't')
{
assert ((aRows == bCols) && (cRows == aCols) && (cCols == bRows));
#ifdef BLAS
GEMM ('t', 't', bRows, aCols, bCols, scale, b.Store (), bCols, a.Store (), aCols, cfactor, c.Store (), bRows);
#else
c += (scale * a.t ()) * b.t ();
#endif
}
else
abort ();
}
catch (Exception)
{
pout << Exception::what () << endl;
abort ();
}
//dmrginp.justmultiply.stop();
//dmrginp.justmultiply -> stop(); //ROA
}
void SpinAdapted::OneElectronArray::ReadFromDumpFile(ifstream& dumpFile, int norbs) {
pout << "OneElectronArray::ReadFromDumpFile is deprecated" << endl;
if (bin) {
dumpFile.seekg (0, ios::end);
//int size = dumpFile.tellg();
double size = dumpFile.tellg();
dumpFile.seekg (0, ios::beg);
FORTINT nmo = rhf ? static_cast<int>(2*sqrt(size / (sizeof(double)))) : static_cast<int>(sqrt(size / (sizeof(double))));
ReSize(nmo);
if (rhf) nmo /= 2;
char buffer[nmo*nmo*sizeof(double)] ;
dumpFile.read(buffer, nmo*nmo*sizeof(double));
Matrix Aoints, Moints;
Aoints.ReSize(nmo,nmo);
Moints.ReSize(nmo, nmo);
Aoints = 0;
for(int i=0;i<nmo;++i)
for(int j=0; j<nmo; ++j)
{
int a=i,b=j;
Aoints(a+1,b+1) = ((double*)(&buffer[(i*nmo +j)*sizeof(double)]))[0];
}
//the above are the ao integrals...need mo integrals
//first read the mo coefficients
ifstream moCoeff;
moCoeff.open("42.0", ios::binary);
if (rhf) {
Matrix CoeffMatrix;
CoeffMatrix.ReSize(nmo, nmo);
char coeffchars[nmo*nmo*sizeof(double)];
moCoeff.read(coeffchars, nmo*nmo*sizeof(double));
double* coeffs = ((double*)(coeffchars));
for (int i=0; i<nmo; i++)
for (int j=0; j<nmo; j++) {
CoeffMatrix(i+1,j+1) = coeffs[i*nmo+j];
}
moCoeff.read(coeffchars, nmo*sizeof(double));
double* occnums = ((double*)(coeffchars));
Occnum.resize(2*nmo);
for (int i=0; i<nmo; i++) {
Occnum.at(2*i) = occnums[i];
Occnum.at(2*i+1) = occnums[i];
}
double scale=1.0, cfactor=0.0;
double* inter = new double[nmo*nmo];
char n='n', t='t';
dgemm_ (&n, &n, &nmo, &nmo, &nmo, &scale, Aoints.Store(), &nmo, CoeffMatrix.Store (), &nmo, &cfactor, inter, &nmo);
dgemm_ (&t, &n, &nmo, &nmo, &nmo, &scale, CoeffMatrix.Store (), &nmo, inter, &nmo, &cfactor, Moints.Store (), &nmo);
delete [] inter;
for(int i=0;i<nmo;++i)
for(int j=0; j<nmo; ++j)
{
int a=i,b=j;
if (rhf)
{
a*=2;
b*=2;
}
(*this)(a,b) = Moints(a/2+1, b/2+1);
}
}
}
else {
int n = 0;
string msg; int msgsize = 5000;
Input::ReadMeaningfulLine(dumpFile, msg, msgsize);
vector<string> tok;
boost::split(tok, msg, is_any_of(" \t"), token_compress_on);
if (tok.size() != 1) {
perr << "The first line of one electron integral file should be number of orbitals"<<endl;
perr << "Error at line :"<<msg<<endl;
abort();
}
if (atoi(tok[0].c_str()) != norbs) {
perr << "Number of orbitals in one electron integral file should be equal to one given in input file"<<endl;
perr << "# orbs in input file : "<<norbs<<endl;
perr << "# orbs in one electron integral file : "<<atoi(tok[0].c_str())/2<<endl;
abort();
}
n = norbs;
if (rhf)
{
n=2*n;
}
ReSize(n);
int i, j;
Input::ReadMeaningfulLine(dumpFile, msg, msgsize);
while (msg.size() != 0)
{
boost::split(tok, msg, is_any_of(" \t"), token_compress_on);
if (tok.size() != 3) {
perr<< "The format of one electron integral file incorrect"<<endl;
perr <<"error at this line: "<<msg<<endl;
abort();
}
i = atoi(tok[0].c_str());
j = atoi(tok[1].c_str());
if (i >= n || j >= n) {
perr << "index of orbitals in one electron integral file cannot be bigger than "<<n<<endl;
perr<< "error at this line: "<<msg<<endl;
abort();
}
if (rhf)
{
i=2*i;
j=2*j;
}
(*this)(i, j) = atof(tok[2].c_str());
msg.resize(0);
Input::ReadMeaningfulLine(dumpFile, msg, msgsize);
}
}
}
