2
/* T3_RHF_AAA(): Computes all T3(IJK,ABC) amplitudes for a given I, J,
3
** K combination for input C2, F, and E intermediates. This function
4
** will work for AAA or BBB spin cases, with either RHF/ROHF or UHF
9
** double ***W1: The target triples amplitudes in an nirreps x AB x
10
** C array. The memory for this must be allocated externally.
12
** int nirreps: Number of irreps.
14
** int I: Absolute index of orbital I.
16
** int Gi: Irrep of I.
18
** int J: Absolute index of orbital J.
20
** int Gj: Irrep of J.
22
** int K: Absolute index of orbital K.
24
** int Gk: Irrep of K.
26
** dpdbuf4 *C2: Pointer to dpd buffer for double excitation amps,
29
** dpdbuf4 *F: Pointer to dpd buffer for three-virtual-index
30
** intermediate, ordered (IA,BC).
32
** dpdbuf4 *E: Pointer to dpd buffer for three-occupied-index
33
** intermediate, ordered (IJ,KA).
35
** dpdfile2 *fIJ: Pointer to the dpd file2 for the occ-occ block of
36
** the Fock matrix (or other appropriate one-electron operator).
38
** dpdfile2 *fAB: Pointer to the dpd file2 for the vir-vir block of
39
** the Fock matrix (or other appropriate one-electron operator).
41
** int *occpi: Number of occupied orbitals per irrep lookup array.
43
** int *occ_off: Offset lookup for translating between absolute and
44
** relative orbital indices for occupied space.
46
** int *virtpi: Number of virtual orbitals per irrep lookup array.
48
** int *vir_off: Offset lookup for translating between absolute and
49
** relative orbital indices for virtual space.
51
** double omega: a constant to add to the final denominators -
61
#include <libdpd/dpd.h>
64
void T3_AAA(double ***W1, int nirreps, int I, int Gi, int J, int Gj, int K, int Gk,
65
dpdbuf4 *C2, dpdbuf4 *F, dpdbuf4 *E, dpdfile2 *fIJ, dpdfile2 *fAB,
66
int *occpi, int *occ_off, int *virtpi, int *vir_off, double omega)
70
int ij, ji, ik, ki, jk, kj;
71
int Gij, Gji, Gik, Gki, Gjk, Gkj, Gijk;
84
int nrows, ncols, nlinks;
89
GC = C2->file.my_irrep;
90
/* F and E are assumed to have same irrep */
91
GF = GE = F->file.my_irrep;
94
dpd_file2_mat_init(fIJ);
95
dpd_file2_mat_init(fAB);
96
dpd_file2_mat_rd(fIJ);
97
dpd_file2_mat_rd(fAB);
99
for(h=0; h < nirreps; h++) {
100
dpd_buf4_mat_irrep_init(C2, h);
101
dpd_buf4_mat_irrep_rd(C2, h);
103
dpd_buf4_mat_irrep_init(E, h);
104
dpd_buf4_mat_irrep_rd(E, h);
116
ij = C2->params->rowidx[I][J];
117
ji = C2->params->rowidx[J][I];
118
jk = C2->params->rowidx[J][K];
119
kj = C2->params->rowidx[K][J];
120
ik = C2->params->rowidx[I][K];
121
ki = C2->params->rowidx[K][I];
124
if(fIJ->params->rowtot[Gi]) dijk += fIJ->matrix[Gi][i][i];
125
if(fIJ->params->rowtot[Gj]) dijk += fIJ->matrix[Gj][j][j];
126
if(fIJ->params->rowtot[Gk]) dijk += fIJ->matrix[Gk][k][k];
128
W2 = (double ***) malloc(nirreps * sizeof(double **));
130
for(Gab=0; Gab < nirreps; Gab++) {
131
Gc = Gab ^ Gijk ^ GX3; /* changed */
133
W2[Gab] = dpd_block_matrix(F->params->coltot[Gab], virtpi[Gc]);
135
if(F->params->coltot[Gab] && virtpi[Gc]) {
136
memset(W1[Gab][0], 0, F->params->coltot[Gab]*virtpi[Gc]*sizeof(double));
140
for(Gd=0; Gd < nirreps; Gd++) {
142
/* +t_kjcd * F_idab */
144
Gab = Gid ^ GF; /* changed */
146
Gc = Gjk ^ Gd ^ GC; /* changed */
148
cd = C2->col_offset[Gjk][Gc];
149
id = F->row_offset[Gid][I];
151
F->matrix[Gid] = dpd_block_matrix(virtpi[Gd], F->params->coltot[Gid^GF]);
152
dpd_buf4_mat_irrep_rd_block(F, Gid, id, virtpi[Gd]);
154
nrows = F->params->coltot[Gid^GF];
158
if(nrows && ncols && nlinks)
159
C_DGEMM('t','t',nrows, ncols, nlinks, 1.0, F->matrix[Gid][0], nrows,
160
&(C2->matrix[Gjk][kj][cd]), nlinks, 1.0, W1[Gab][0], ncols);
162
dpd_free_block(F->matrix[Gid], virtpi[Gd], F->params->coltot[Gid^GF]);
164
/* +t_ikcd * F_jdab */
166
Gab = Gjd ^ GF; /* changed */
167
Gc = Gik ^ Gd ^ GC; /* changed */
169
cd = C2->col_offset[Gik][Gc];
170
jd = F->row_offset[Gjd][J];
172
F->matrix[Gjd] = dpd_block_matrix(virtpi[Gd], F->params->coltot[Gjd^GF]);
173
dpd_buf4_mat_irrep_rd_block(F, Gjd, jd, virtpi[Gd]);
175
nrows = F->params->coltot[Gjd^GF];
179
if(nrows && ncols && nlinks)
180
C_DGEMM('t','t',nrows, ncols, nlinks, 1.0, F->matrix[Gjd][0], nrows,
181
&(C2->matrix[Gik][ik][cd]), nlinks, 1.0, W1[Gab][0], ncols);
183
dpd_free_block(F->matrix[Gjd], virtpi[Gd], F->params->coltot[Gjd^GF]);
185
/* -t_ijcd * F_kdab */
186
Gkd = Gk ^ Gd; /*changed */
190
cd = C2->col_offset[Gij][Gc];
191
kd = F->row_offset[Gkd][K];
193
F->matrix[Gkd] = dpd_block_matrix(virtpi[Gd], F->params->coltot[Gkd^GF]);
194
dpd_buf4_mat_irrep_rd_block(F, Gkd, kd, virtpi[Gd]);
196
nrows = F->params->coltot[Gkd^GF];
200
if(nrows && ncols && nlinks)
201
C_DGEMM('t', 't', nrows, ncols, nlinks, -1.0, F->matrix[Gkd][0], nrows,
202
&(C2->matrix[Gij][ij][cd]), nlinks, 1.0, W1[Gab][0], ncols);
204
dpd_free_block(F->matrix[Gkd], virtpi[Gd], F->params->coltot[Gkd^GF]);
208
for(Gl=0; Gl < nirreps; Gl++) {
210
/* -t_ilab * E_jklc */
211
Gil = Gi ^ Gl; /* changed */
215
lc = E->col_offset[Gjk][Gl];
216
il = C2->row_offset[Gil][I];
218
nrows = C2->params->coltot[Gil^GC];
222
if(nrows && ncols && nlinks)
223
C_DGEMM('t', 'n', nrows, ncols, nlinks, -1.0, C2->matrix[Gil][il], nrows,
224
&(E->matrix[Gjk][jk][lc]), ncols, 1.0, W1[Gab][0], ncols);
226
/* +t_jlab * E_iklc */
227
Gjl = Gj ^ Gl; /* changed */
231
lc = E->col_offset[Gik][Gl];
232
jl = C2->row_offset[Gjl][J];
234
nrows = C2->params->coltot[Gjl^GC];
238
if(nrows && ncols && nlinks)
239
C_DGEMM('t', 'n', nrows, ncols, nlinks, 1.0, C2->matrix[Gjl][jl], nrows,
240
&(E->matrix[Gik][ik][lc]), ncols, 1.0, W1[Gab][0], ncols);
242
/* +t_klab * E_jilc */
243
Gkl = Gk ^ Gl; /* changed! */
247
lc = E->col_offset[Gji][Gl];
248
kl = C2->row_offset[Gkl][K];
250
nrows = C2->params->coltot[Gkl^GC];
254
if(nrows && ncols && nlinks)
255
C_DGEMM('t', 'n', nrows, ncols, nlinks, 1.0, C2->matrix[Gkl][kl], nrows,
256
&(E->matrix[Gji][ji][lc]), ncols, 1.0, W1[Gab][0], ncols);
260
for(Gd=0; Gd < nirreps; Gd++) {
261
/* +t_kjbd * F_idca */
262
Gid = Gi ^ Gd; /* changed */
266
bd = C2->col_offset[Gjk][Gb];
267
id = F->row_offset[Gid][I];
269
F->matrix[Gid] = dpd_block_matrix(virtpi[Gd], F->params->coltot[Gid^GF]);
270
dpd_buf4_mat_irrep_rd_block(F, Gid, id, virtpi[Gd]);
272
nrows = F->params->coltot[Gid^GF];
276
if(nrows && ncols && nlinks)
277
C_DGEMM('t','t',nrows, ncols, nlinks, 1.0, F->matrix[Gid][0], nrows,
278
&(C2->matrix[Gjk][kj][bd]), nlinks, 1.0, W2[Gca][0], ncols);
280
dpd_free_block(F->matrix[Gid], virtpi[Gd], F->params->coltot[Gid^GF]);
282
/* +t_ikbd * F_jdca */
287
bd = C2->col_offset[Gik][Gb];
288
jd = F->row_offset[Gjd][J];
290
F->matrix[Gjd] = dpd_block_matrix(virtpi[Gd], F->params->coltot[Gjd^GF]);
291
dpd_buf4_mat_irrep_rd_block(F, Gjd, jd, virtpi[Gd]);
293
nrows = F->params->coltot[Gjd^GF];
297
if(nrows && ncols && nlinks)
298
C_DGEMM('t','t',nrows, ncols, nlinks, 1.0, F->matrix[Gjd][0], nrows,
299
&(C2->matrix[Gik][ik][bd]), nlinks, 1.0, W2[Gca][0], ncols);
301
dpd_free_block(F->matrix[Gjd], virtpi[Gd], F->params->coltot[Gjd^GF]);
303
/* -t_ijbd * F_kdca */
308
bd = C2->col_offset[Gij][Gb];
309
kd = F->row_offset[Gkd][K];
311
F->matrix[Gkd] = dpd_block_matrix(virtpi[Gd], F->params->coltot[Gkd^GF]);
312
dpd_buf4_mat_irrep_rd_block(F, Gkd, kd, virtpi[Gd]);
314
nrows = F->params->coltot[Gkd^GF];
318
if(nrows && ncols && nlinks)
319
C_DGEMM('t','t',nrows, ncols, nlinks, -1.0, F->matrix[Gkd][0], nrows,
320
&(C2->matrix[Gij][ij][bd]), nlinks, 1.0, W2[Gca][0], ncols);
322
dpd_free_block(F->matrix[Gkd], virtpi[Gd], F->params->coltot[Gkd^GF]);
325
for(Gl=0; Gl < nirreps; Gl++) {
326
/* -t_ilca * E_jklb */
331
lb = E->col_offset[Gjk][Gl];
332
il = C2->row_offset[Gil][I];
334
nrows = C2->params->coltot[Gil^GC];
338
if(nrows && ncols && nlinks)
339
C_DGEMM('t', 'n', nrows, ncols, nlinks, -1.0, C2->matrix[Gil][il], nrows,
340
&(E->matrix[Gjk][jk][lb]), ncols, 1.0, W2[Gca][0], ncols);
342
/* +t_jlca * E_iklb */
347
lb = E->col_offset[Gik][Gl];
348
jl = C2->row_offset[Gjl][J];
350
nrows = C2->params->coltot[Gjl^GC];
354
if(nrows && ncols && nlinks)
355
C_DGEMM('t', 'n', nrows, ncols, nlinks, 1.0, C2->matrix[Gjl][jl], nrows,
356
&(E->matrix[Gik][ik][lb]), ncols, 1.0, W2[Gca][0], ncols);
358
/* +t_klca * E_jilb */
363
lb = E->col_offset[Gji][Gl];
364
kl = C2->row_offset[Gkl][K];
366
nrows = C2->params->coltot[Gkl^GC];
370
if(nrows && ncols && nlinks)
371
C_DGEMM('t', 'n', nrows, ncols, nlinks, 1.0, C2->matrix[Gkl][kl], nrows,
372
&(E->matrix[Gji][ji][lb]), ncols, 1.0, W2[Gca][0], ncols);
375
dpd_3d_sort(W2, W1, nirreps, Gijk^GX3, F->params->coltot, F->params->colidx,
376
F->params->colorb, F->params->rsym, F->params->ssym, vir_off,
377
vir_off, virtpi, vir_off, F->params->colidx, bca, 1);
379
for(Gab=0; Gab < nirreps; Gab++) {
380
Gc = Gab ^ Gijk ^ GX3; /* changed */
381
if(F->params->coltot[Gab] && virtpi[Gc]) {
382
memset(W2[Gab][0], 0, F->params->coltot[Gab]*virtpi[Gc]*sizeof(double));
386
for(Gd=0; Gd < nirreps; Gd++) {
387
/* -t_kjad * F_idcb */
392
ad = C2->col_offset[Gkj][Ga];
393
id = F->row_offset[Gid][I];
395
F->matrix[Gid] = dpd_block_matrix(virtpi[Gd], F->params->coltot[Gid^GF]);
396
dpd_buf4_mat_irrep_rd_block(F, Gid, id, virtpi[Gd]);
398
nrows = F->params->coltot[Gid^GF];
402
if(nrows && ncols && nlinks)
403
C_DGEMM('t','t',nrows, ncols, nlinks, -1.0, F->matrix[Gid][0], nrows,
404
&(C2->matrix[Gkj][kj][ad]), nlinks, 1.0, W2[Gcb][0], ncols);
406
dpd_free_block(F->matrix[Gid], virtpi[Gd], F->params->coltot[Gid^GF]);
408
/* -t_ikad * F_jdcb */
413
ad = C2->col_offset[Gik][Ga];
414
jd = F->row_offset[Gjd][J];
416
F->matrix[Gjd] = dpd_block_matrix(virtpi[Gd], F->params->coltot[Gjd^GF]);
417
dpd_buf4_mat_irrep_rd_block(F, Gjd, jd, virtpi[Gd]);
419
nrows = F->params->coltot[Gjd^GF];
423
if(nrows && ncols && nlinks)
424
C_DGEMM('t','t',nrows, ncols, nlinks, -1.0, F->matrix[Gjd][0], nrows,
425
&(C2->matrix[Gik][ik][ad]), nlinks, 1.0, W2[Gcb][0], ncols);
427
dpd_free_block(F->matrix[Gjd], virtpi[Gd], F->params->coltot[Gjd^GF]);
429
/* +t_ijad * F_kdcb */
434
ad = C2->col_offset[Gij][Ga];
435
kd = F->row_offset[Gkd][K];
437
F->matrix[Gkd] = dpd_block_matrix(virtpi[Gd], F->params->coltot[Gkd^GF]);
438
dpd_buf4_mat_irrep_rd_block(F, Gkd, kd, virtpi[Gd]);
440
nrows = F->params->coltot[Gkd^GF];
444
if(nrows && ncols && nlinks)
445
C_DGEMM('t','t',nrows, ncols, nlinks, 1.0, F->matrix[Gkd][0], nrows,
446
&(C2->matrix[Gij][ij][ad]), nlinks, 1.0, W2[Gcb][0], ncols);
448
dpd_free_block(F->matrix[Gkd], virtpi[Gd], F->params->coltot[Gkd^GF]);
452
for(Gl=0; Gl < nirreps; Gl++) {
453
/* +t_ilcb * E_jkla */
458
la = E->col_offset[Gjk][Gl];
459
il = C2->row_offset[Gil][I];
461
nrows = C2->params->coltot[Gil^GC];
465
if(nrows && ncols && nlinks)
466
C_DGEMM('t', 'n', nrows, ncols, nlinks, 1.0, C2->matrix[Gil][il], nrows,
467
&(E->matrix[Gjk][jk][la]), ncols, 1.0, W2[Gcb][0], ncols);
469
/* -t_jlcb * E_ikla */
474
la = E->col_offset[Gik][Gl];
475
jl = C2->row_offset[Gjl][J];
477
nrows = C2->params->coltot[Gjl^GC];
481
if(nrows && ncols && nlinks)
482
C_DGEMM('t', 'n', nrows, ncols, nlinks, -1.0, C2->matrix[Gjl][jl], nrows,
483
&(E->matrix[Gik][ik][la]), ncols, 1.0, W2[Gcb][0], ncols);
485
/* -t_klcb * E_jila */
490
la = E->col_offset[Gji][Gl];
491
kl = C2->row_offset[Gkl][K];
493
nrows = C2->params->coltot[Gkl^GC];
497
if(nrows && ncols && nlinks)
498
C_DGEMM('t', 'n', nrows, ncols, nlinks, -1.0, C2->matrix[Gkl][kl], nrows,
499
&(E->matrix[Gji][ji][la]), ncols, 1.0, W2[Gcb][0], ncols);
503
dpd_3d_sort(W2, W1, nirreps, Gijk^GX3, F->params->coltot, F->params->colidx,
504
F->params->colorb, F->params->rsym, F->params->ssym, vir_off,
505
vir_off, virtpi, vir_off, F->params->colidx, cba, 1);
507
for(Gab=0; Gab < nirreps; Gab++) {
508
Gc = Gab ^ Gijk ^ GX3; /* assumes totally symmetric! */
510
for(ab=0; ab < F->params->coltot[Gab]; ab++) {
511
A = F->params->colorb[Gab][ab][0];
512
B = F->params->colorb[Gab][ab][1];
513
Ga = F->params->rsym[A];
514
Gb = F->params->ssym[B];
518
for(c=0; c < virtpi[Gc]; c++) {
522
if(fAB->params->rowtot[Ga]) denom -= fAB->matrix[Ga][a][a];
523
if(fAB->params->rowtot[Gb]) denom -= fAB->matrix[Gb][b][b];
524
if(fAB->params->rowtot[Gc]) denom -= fAB->matrix[Gc][c][c];
526
W1[Gab][ab][c] /= (omega + denom);
532
for(Gab=0; Gab < nirreps; Gab++) {
533
Gc = Gab ^ Gijk ^ GX3; /* changed */
534
dpd_free_block(W2[Gab], F->params->coltot[Gab], virtpi[Gc]);
538
dpd_file2_mat_close(fIJ);
539
dpd_file2_mat_close(fAB);
541
for(h=0; h < nirreps; h++) {
542
dpd_buf4_mat_irrep_close(C2, h);
543
dpd_buf4_mat_irrep_close(E, h);