/*
* If symm != 0, symmetrize rdm1 and rdm2
* For spin density matrix, return rdm2 e.g.
* [beta alpha beta^+ alpha]
* transpose(1,0,2,3) to get the right order [alpha^+ beta beta^+ alpha]
* na, nb, nlinka, nlinkb label the intermediate determinants
* see ades_bcre_t1 and acre_bdes_t1 of fci_spin.c
*
* Note: na counts the alpha strings of intermediate determinants
* but nb counts the beta strings of ket
*/
void FCIspindm12_drv(void (*dm12kernel)(),
double *rdm1, double *rdm2, double *bra, double *ket,
int norb, int na, int nb, int neleca, int nelecb,
int *link_indexa, int *link_indexb, int symm)
{
const int nnorb = norb * norb;
int strk, i, j;
double *pdm1, *pdm2;
memset(rdm1, 0, sizeof(double) * nnorb);
memset(rdm2, 0, sizeof(double) * nnorb*nnorb);
#pragma omp parallel default(none) \
shared(dm12kernel, bra, ket, norb, na, nb, neleca, nelecb, \
link_indexa, link_indexb, rdm1, rdm2), \
private(strk, i, pdm1, pdm2)
{
pdm1 = (double *)malloc(sizeof(double) * nnorb);
pdm2 = (double *)malloc(sizeof(double) * nnorb*nnorb);
memset(pdm1, 0, sizeof(double) * nnorb);
memset(pdm2, 0, sizeof(double) * nnorb*nnorb);
#pragma omp for schedule(dynamic, 2)
for (strk = 0; strk < na; strk++) {
(*dm12kernel)(pdm1, pdm2, bra, ket,
strk, norb, na, nb, neleca, nelecb,
link_indexa, link_indexb);
}
#pragma omp critical
{
for (i = 0; i < nnorb; i++) {
rdm1[i] += pdm1[i];
}
for (i = 0; i < nnorb*nnorb; i++) {
rdm2[i] += pdm2[i];
}
}
free(pdm1);
free(pdm2);
}
if (symm) {
for (i = 0; i < norb; i++) {
for (j = 0; j < i; j++) {
rdm1[j*norb+i] = rdm1[i*norb+j];
}
}
for (i = 0; i < nnorb; i++) {
for (j = 0; j < i; j++) {
rdm2[j*nnorb+i] = rdm2[i*nnorb+j];
}
}
}
_transpose_jikl(rdm2, norb);
}
/*
* Note! The returned rdm2 from FCI*kern* function corresponds to
* [(p^+ q on <bra|) r^+ s] = [p q^+ r^+ s]
* in FCIrdm12kern_sf, FCIrdm12kern_spin0, FCIrdm12kern_a, ...
* t1 is calculated as |K> = i^+ j|0>. by doing dot(t1.T,t1) to get "rdm2",
* The ket part (k^+ l|0>) will generate the correct order for the last
* two indices kl of rdm2(i,j,k,l), But the bra part (i^+ j|0>)^dagger
* will generate an order of (i,j), which is identical to call a bra of
* (<0|i j^+). The so-obtained rdm2(i,j,k,l) corresponds to the
* operator sequence i j^+ k^+ l.
*
* symm = 1: symmetrizes the 1pdm, and 2pdm. This is true only if bra == ket,
* and the operators on bra are equivalent to those on ket, like
* FCIrdm12kern_a, FCIrdm12kern_b, FCIrdm12kern_sf, FCIrdm12kern_spin0
* sym = 2: consider the particle permutation symmetry:
* E^j_l E^i_k = E^i_k E^j_l - \delta_{il}E^j_k + \dleta_{jk}E^i_l
*/
void FCIrdm12_drv(void (*dm12kernel)(),
double *rdm1, double *rdm2, double *bra, double *ket,
int norb, int na, int nb, int nlinka, int nlinkb,
int *link_indexa, int *link_indexb, int symm)
{
const int nnorb = norb * norb;
int strk, i, j, k, l, ib, blen;
double *pdm1, *pdm2;
memset(rdm1, 0, sizeof(double) * nnorb);
memset(rdm2, 0, sizeof(double) * nnorb*nnorb);
_LinkT *clinka = malloc(sizeof(_LinkT) * nlinka * na);
_LinkT *clinkb = malloc(sizeof(_LinkT) * nlinkb * nb);
FCIcompress_link(clinka, link_indexa, norb, na, nlinka);
FCIcompress_link(clinkb, link_indexb, norb, nb, nlinkb);
#pragma omp parallel default(none) \
shared(dm12kernel, bra, ket, norb, na, nb, nlinka, \
nlinkb, clinka, clinkb, rdm1, rdm2, symm), \
private(strk, i, ib, blen, pdm1, pdm2)
{
pdm1 = calloc(nnorb, sizeof(double));
pdm2 = calloc(nnorb*nnorb, sizeof(double));
#pragma omp for schedule(dynamic, 40)
for (strk = 0; strk < na; strk++) {
for (ib = 0; ib < nb; ib += BUFBASE) {
blen = MIN(BUFBASE, nb-ib);
(*dm12kernel)(pdm1, pdm2, bra, ket, blen, strk, ib,
norb, na, nb, nlinka, nlinkb,
clinka, clinkb, symm);
}
}
#pragma omp critical
{
for (i = 0; i < nnorb; i++) {
rdm1[i] += pdm1[i];
}
for (i = 0; i < nnorb*nnorb; i++) {
rdm2[i] += pdm2[i];
}
}
free(pdm1);
free(pdm2);
}
free(clinka);
free(clinkb);
switch (symm) {
case BRAKETSYM:
for (i = 0; i < norb; i++) {
for (j = 0; j < i; j++) {
rdm1[j*norb+i] = rdm1[i*norb+j];
}
}
for (i = 0; i < nnorb; i++) {
for (j = 0; j < i; j++) {
rdm2[j*nnorb+i] = rdm2[i*nnorb+j];
}
}
_transpose_jikl(rdm2, norb);
break;
case PARTICLESYM:
// right 2pdm order is required here, which transposes the cre/des on bra
for (i = 0; i < norb; i++) {
for (j = 0; j < i; j++) {
pdm1 = rdm2 + (i*nnorb+j)*norb;
pdm2 = rdm2 + (j*nnorb+i)*norb;
for (k = 0; k < norb; k++) {
for (l = 0; l < norb; l++) {
pdm2[l*nnorb+k] = pdm1[k*nnorb+l];
} }
// E^j_lE^i_k = E^i_kE^j_l + \delta_{il}E^j_k - \dleta_{jk}E^i_l
for (k = 0; k < norb; k++) {
pdm2[i*nnorb+k] += rdm1[j*norb+k];
pdm2[k*nnorb+j] -= rdm1[i*norb+k];
}
} }
break;
default:
_transpose_jikl(rdm2, norb);
}
}
