3
\brief Enter brief description of file here
6
/* T3_RHF_ic(): Computes all T3(IJK,ABC) amplitudes for a given I, J,
7
** K combination for input T2, F, and E intermediates. This function
8
** is specifically for AAB spin cases with RHF orbitals.
9
** This _ic version assumes WAbEi is available in memory
12
** double ***W1: The target triples amplitudes in an nirreps x AB x
13
** C array. The memory for this must be allocated externally.
15
** int nirreps: Number of irreps.
17
** int I: Absolute index of orbital I.
19
** int Gi: Irrep of I.
21
** int J: Absolute index of orbital J.
23
** int Gj: Irrep of J.
25
** int K: Absolute index of orbital K.
27
** int Gk: Irrep of K.
29
** dpdbuf4 *T2: Pointer to dpd buffer for double excitation amps,
32
** dpdbuf4 *F: Pointer to dpd buffer for three-virtual-index
33
** intermediate, ordered (IA,BC).
35
** dpdbuf4 *E: Pointer to dpd buffer for three-occupied-index
36
** intermediate, ordered (IJ,KA).
38
** dpdfile2 *fIJ: Pointer to the dpd file2 for the occ-occ block of
39
** the Fock matrix (or other appropriate one-electron operator).
41
** dpdfile2 *fAB: Pointer to the dpd file2 for the vir-vir block of
42
** the Fock matrix (or other appropriate one-electron operator).
44
** int *occpi: Number of occupied orbitals per irrep lookup array.
46
** int *occ_off: Offset lookup for translating between absolute and
47
** relative orbital indices for occupied space.
49
** int *virtpi: Number of virtual orbitals per irrep lookup array.
51
** int *vir_off: Offset lookup for translating between absolute and
52
** relative orbital indices for virtual space.
54
** double omega: constant to add to denominators - needed for EOM CC3
57
** -modified for RHF, RAK 2004
58
** -omega argument added, RAK 2006
66
#include <libdpd/dpd.h>
72
void T3_RHF_ic(double ***W1, int nirreps, int I, int Gi, int J, int Gj, int K, int Gk,
73
dpdbuf4 *T2, dpdbuf4 *F, dpdbuf4 *E, dpdfile2 *fIJ, dpdfile2 *fAB,
74
int *occpi, int *occ_off, int *virtpi, int *vir_off, double omega)
78
int ij, ji, ik, ki, jk, kj;
79
int Gij, Gji, Gik, Gki, Gjk, Gkj, Gijk;
92
int nrows, ncols, nlinks;
97
GC = T2->file.my_irrep;
98
/* F and E are assumed to have same irrep */
99
GF = GE = F->file.my_irrep;
111
ij = T2->params->rowidx[I][J];
112
ji = T2->params->rowidx[J][I];
113
jk = T2->params->rowidx[J][K];
114
kj = T2->params->rowidx[K][J];
115
ik = T2->params->rowidx[I][K];
116
ki = T2->params->rowidx[K][I];
119
if(fIJ->params->rowtot[Gi]) dijk += fIJ->matrix[Gi][i][i];
120
if(fIJ->params->rowtot[Gj]) dijk += fIJ->matrix[Gj][j][j];
121
if(fIJ->params->rowtot[Gk]) dijk += fIJ->matrix[Gk][k][k];
123
W2 = (double ***) malloc(nirreps * sizeof(double **));
125
for(Gab=0; Gab < nirreps; Gab++) {
126
Gc = Gab ^ Gijk ^ GX3;
128
W2[Gab] = dpd_block_matrix(F->params->coltot[Gab], virtpi[Gc]);
130
if(F->params->coltot[Gab] && virtpi[Gc]) {
131
memset(W1[Gab][0], 0, F->params->coltot[Gab]*virtpi[Gc]*sizeof(double));
135
/***** do terms that are (ab,c) and don't need sorted *****/
136
for(Gd=0; Gd < nirreps; Gd++) {
139
/* +t_JkDc * F_IDAB */
144
cd = T2->col_offset[Gjk][Gc];
145
id = F->row_offset[Gid][I];
147
nrows = F->params->coltot[Gid^GF];
151
if(nrows && ncols && nlinks)
152
C_DGEMM('t','t',nrows, ncols, nlinks, 1.0, F->matrix[Gid][id], nrows,
153
&(T2->matrix[Gjk][kj][cd]), nlinks, 1.0, W1[Gab][0], ncols);
157
for(Gl=0; Gl < nirreps; Gl++) {
160
/* -t_ILAB * E_JkLc */
165
lc = E->col_offset[Gjk][Gl];
166
il = T2->row_offset[Gil][I];
168
nrows = T2->params->coltot[Gil^GC];
172
if(nrows && ncols && nlinks)
173
C_DGEMM('t', 'n', nrows, ncols, nlinks, -1.0, T2->matrix[Gil][il], nrows,
174
&(E->matrix[Gjk][jk][lc]), ncols, 1.0, W1[Gab][0], ncols);
178
/***** Do terms (ba,c) that need bac sorts *****/
180
/* zero out W2 memory */
181
for(Gab=0; Gab < nirreps; Gab++) {
182
Gc = Gab ^ Gijk ^ GX3;
183
if(F->params->coltot[Gab] && virtpi[Gc]) {
184
memset(W2[Gab][0], 0, F->params->coltot[Gab]*virtpi[Gc]*sizeof(double));
188
for(Gd=0; Gd < nirreps; Gd++) {
190
/* + F_JdBa * t_IkDc */
195
cd = T2->col_offset[Gik][Gc];
196
jd = F->row_offset[Gjd][J];
198
nrows = F->params->coltot[Gjd^GF];
202
if(nrows && ncols && nlinks)
203
C_DGEMM('t','t',nrows, ncols, nlinks, 1.0, F->matrix[Gjd][jd], nrows,
204
&(T2->matrix[Gik][ki][cd]), nlinks, 1.0, W2[Gab][0], ncols);
208
for(Gl=0; Gl < nirreps; Gl++) {
210
/* +t_JlAb * E_IkLc */
215
lc = E->col_offset[Gik][Gl];
216
jl = T2->row_offset[Gjl][J];
218
nrows = T2->params->coltot[Gjl^GC];
222
if(nrows && ncols && nlinks)
223
C_DGEMM('t', 'n', nrows, ncols, nlinks, -1.0, T2->matrix[Gjl][jl], nrows,
224
&(E->matrix[Gik][ik][lc]), ncols, 1.0, W2[Gab][0], ncols);
227
dpd_3d_sort(W2, W1, nirreps, Gijk^GX3, F->params->coltot, F->params->colidx,
228
F->params->colorb, F->params->rsym, F->params->ssym, vir_off,
229
vir_off, virtpi, vir_off, F->params->colidx, bac, 1);
232
/***** do (ac,b) terms that require acb sort *****/
234
/* zero out W2 memory */
235
for(Gab=0; Gab < nirreps; Gab++) {
236
Gc = Gab ^ Gijk ^ GX3;
237
if(F->params->coltot[Gab] && virtpi[Gc]) {
238
memset(W2[Gab][0], 0, F->params->coltot[Gab]*virtpi[Gc]*sizeof(double));
242
for(Gd=0; Gd < nirreps; Gd++) {
244
/* + F_IdAc * t_JkBd */
249
bd = T2->col_offset[Gjk][Gb];
250
id = F->row_offset[Gid][I];
252
nrows = F->params->coltot[Gid^GF];
256
if(nrows && ncols && nlinks)
257
C_DGEMM('t','t',nrows, ncols, nlinks, 1.0, F->matrix[Gid][id], nrows,
258
&(T2->matrix[Gjk][jk][bd]), nlinks, 1.0, W2[Gca][0], ncols);
262
for(Gl=0; Gl < nirreps; Gl++) {
264
/* -t_IlAc * E_KjLb */
269
lb = E->col_offset[Gjk][Gl];
270
il = T2->row_offset[Gil][I];
272
nrows = T2->params->coltot[Gil^GC];
276
if(nrows && ncols && nlinks)
277
C_DGEMM('t', 'n', nrows, ncols, nlinks, -1.0, T2->matrix[Gil][il], nrows,
278
&(E->matrix[Gjk][kj][lb]), ncols, 1.0, W2[Gca][0], ncols);
282
dpd_3d_sort(W2, W1, nirreps, Gijk^GX3, F->params->coltot, F->params->colidx,
283
F->params->colorb, F->params->rsym, F->params->ssym, vir_off,
284
vir_off, virtpi, vir_off, F->params->colidx, acb, 1);
287
/***** do (ca,b) terms that need a bca sort *****/
289
/* zero out W2 memory */
290
for(Gab=0; Gab < nirreps; Gab++) {
291
Gc = Gab ^ Gijk ^ GX3;
292
if(F->params->coltot[Gab] && virtpi[Gc]) {
293
memset(W2[Gab][0], 0, F->params->coltot[Gab]*virtpi[Gc]*sizeof(double));
297
for(Gd=0; Gd < nirreps; Gd++) {
299
/* + F_KdCa * t_JiBd */
304
bd = T2->col_offset[Gij][Gb];
305
kd = F->row_offset[Gkd][K];
307
nrows = F->params->coltot[Gkd^GF];
311
if(nrows && ncols && nlinks)
312
C_DGEMM('t','t',nrows, ncols, nlinks, 1.0, F->matrix[Gkd][kd], nrows,
313
&(T2->matrix[Gij][ji][bd]), nlinks, 1.0, W2[Gca][0], ncols);
317
for(Gl=0; Gl < nirreps; Gl++) {
319
/* - t_KlCa * E_IjLb */
324
lb = E->col_offset[Gji][Gl];
325
kl = T2->row_offset[Gkl][K];
327
nrows = T2->params->coltot[Gkl^GC];
331
if(nrows && ncols && nlinks)
332
C_DGEMM('t', 'n', nrows, ncols, nlinks, -1.0, T2->matrix[Gkl][kl], nrows,
333
&(E->matrix[Gji][ij][lb]), ncols, 1.0, W2[Gca][0], ncols);
336
dpd_3d_sort(W2, W1, nirreps, Gijk^GX3, F->params->coltot, F->params->colidx,
337
F->params->colorb, F->params->rsym, F->params->ssym, vir_off,
338
vir_off, virtpi, vir_off, F->params->colidx, bca, 1);
341
/***** do (cb,a) terms that require a cba sort *****/
342
/* zero out W2 memory */
343
for(Gab=0; Gab < nirreps; Gab++) {
344
Gc = Gab ^ Gijk ^ GX3;
345
if(F->params->coltot[Gab] && virtpi[Gc]) {
346
memset(W2[Gab][0], 0, F->params->coltot[Gab]*virtpi[Gc]*sizeof(double));
350
for(Gd=0; Gd < nirreps; Gd++) {
352
/* + F_KdCb * t_IjAd */
357
ad = T2->col_offset[Gij][Ga];
358
kd = F->row_offset[Gkd][K];
360
nrows = F->params->coltot[Gkd^GF];
364
if(nrows && ncols && nlinks)
365
C_DGEMM('t','t',nrows, ncols, nlinks, 1.0, F->matrix[Gkd][kd], nrows,
366
&(T2->matrix[Gij][ij][ad]), nlinks, 1.0, W2[Gcb][0], ncols);
370
for(Gl=0; Gl < nirreps; Gl++) {
372
/* -t_KlCb * E_JiLa */
377
la = E->col_offset[Gji][Gl];
378
kl = T2->row_offset[Gkl][K];
380
nrows = T2->params->coltot[Gkl^GC];
384
if(nrows && ncols && nlinks)
385
C_DGEMM('t', 'n', nrows, ncols, nlinks, -1.0, T2->matrix[Gkl][kl], nrows,
386
&(E->matrix[Gji][ji][la]), ncols, 1.0, W2[Gcb][0], ncols);
389
dpd_3d_sort(W2, W1, nirreps, Gijk^GX3, F->params->coltot, F->params->colidx,
390
F->params->colorb, F->params->rsym, F->params->ssym, vir_off,
391
vir_off, virtpi, vir_off, F->params->colidx, cba, 1);
393
/***** do (bc,a) terms that require a cab sort *****/
394
/* zero out W2 memory */
395
for(Gab=0; Gab < nirreps; Gab++) {
396
Gc = Gab ^ Gijk ^ GX3;
397
if(F->params->coltot[Gab] && virtpi[Gc]) {
398
memset(W2[Gab][0], 0, F->params->coltot[Gab]*virtpi[Gc]*sizeof(double));
402
for(Gd=0; Gd < nirreps; Gd++) {
404
/* + t_IkAd * F_JdBc */
409
ad = T2->col_offset[Gik][Ga];
410
jd = F->row_offset[Gjd][J];
412
nrows = F->params->coltot[Gjd^GF];
416
if(nrows && ncols && nlinks)
417
C_DGEMM('t','t',nrows, ncols, nlinks, 1.0, F->matrix[Gjd][jd], nrows,
418
&(T2->matrix[Gik][ik][ad]), nlinks, 1.0, W2[Gcb][0], ncols);
422
for(Gl=0; Gl < nirreps; Gl++) {
424
/* - t_JlBc * E_Kila */
429
la = E->col_offset[Gik][Gl];
430
jl = T2->row_offset[Gjl][J];
432
nrows = T2->params->coltot[Gjl^GC];
436
if(nrows && ncols && nlinks)
437
C_DGEMM('t', 'n', nrows, ncols, nlinks, -1.0, T2->matrix[Gjl][jl], nrows,
438
&(E->matrix[Gik][ki][la]), ncols, 1.0, W2[Gcb][0], ncols);
441
dpd_3d_sort(W2, W1, nirreps, Gijk^GX3, F->params->coltot, F->params->colidx,
442
F->params->colorb, F->params->rsym, F->params->ssym, vir_off,
443
vir_off, virtpi, vir_off, F->params->colidx, cab, 1);
445
for(Gab=0; Gab < nirreps; Gab++) {
446
Gc = Gab ^ Gijk ^ GX3;
448
for(ab=0; ab < F->params->coltot[Gab]; ab++) {
449
A = F->params->colorb[Gab][ab][0];
450
B = F->params->colorb[Gab][ab][1];
451
Ga = F->params->rsym[A];
452
Gb = F->params->ssym[B];
456
for(c=0; c < virtpi[Gc]; c++) {
460
if(fAB->params->rowtot[Ga]) denom -= fAB->matrix[Ga][a][a];
461
if(fAB->params->rowtot[Gb]) denom -= fAB->matrix[Gb][b][b];
462
if(fAB->params->rowtot[Gc]) denom -= fAB->matrix[Gc][c][c];
464
W1[Gab][ab][c] /= (denom + omega);
470
for(Gab=0; Gab < nirreps; Gab++) {
471
Gc = Gab ^ Gijk ^ GX3;
472
dpd_free_block(W2[Gab], F->params->coltot[Gab], virtpi[Gc]);