1! 2! Dalton, a molecular electronic structure program 3! Copyright (C) by the authors of Dalton. 4! 5! This program is free software; you can redistribute it and/or 6! modify it under the terms of the GNU Lesser General Public 7! License version 2.1 as published by the Free Software Foundation. 8! 9! This program is distributed in the hope that it will be useful, 10! but WITHOUT ANY WARRANTY; without even the implied warranty of 11! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12! Lesser General Public License for more details. 13! 14! If a copy of the GNU LGPL v2.1 was not distributed with this 15! code, you can obtain one at https://www.gnu.org/licenses/old-licenses/lgpl-2.1.en.html. 16! 17! 18C 19C /* Deck ccpt_etars_1e */ 20 SUBROUTINE CCPT_ETARS_1E(ETAIJ,ETAAB, 21 * XINTIJ,XINTAI,XINTIA,XINTAB, 22 * DIA,WORK,LWORK,ISYM) 23C 24C Written by S. Coriani 21/1-2002 25C 26C Version: 1.0 27C 28C Purpose: To set up the one-electron contribution to the 29C right hand side of the equation for 30C zeta-kappa-0_ij (ETAIJ) and zeta-kappa-0_ab (ETAAB) 31C from MO-integrals (XIN*) and (T) 32C contribution to CCSD(T) density (D_ia) 33C ISYM is the symmetry of both the density and the 34C integrals! 35C 36C Based on CC2_ETIJ/CC2_ETAB by A. Halkier & S. Coriani 37C 38#include "implicit.h" 39 PARAMETER(ZERO = 0.0D0, ONE = 1.0D0) 40 DIMENSION ETAIJ(*), ETAAB(*) 41 DIMENSION XINTIJ(*), XINTAI(*), XINTIA(*), XINTAB(*) 42 DIMENSION DIA(*), WORK(LWORK) 43#include "priunit.h" 44#include "ccorb.h" 45#include "ccsdsym.h" 46#include "cclr.h" 47C 48 CALL QENTER('CCPT_ETARS_1E') 49C 50 DO 100 ISYMI = 1,NSYM 51C 52C---------------------------------------------------------------- 53C Calculate terms to eta_ij. 54C---------------------------------------------------------------- 55C 56 ISYMJ = ISYMI 57 ISYMC = MULD2H(ISYMI,ISYM) 58C 59 KOFFRE = IMATIJ(ISYMI,ISYMJ) + 1 60C 61 NTOTRE = MAX(NRHF(ISYMI),1) 62 NTOTC = MAX(NVIR(ISYMC),1) 63C 64 KOFF5 = IT1AM(ISYMC,ISYMI) + 1 65 KOFF6 = IT1AM(ISYMC,ISYMJ) + 1 66C 67 CALL DGEMM('T','N',NRHF(ISYMI),NRHF(ISYMJ),NVIR(ISYMC),ONE, 68 * XINTIA(KOFF5),NTOTC,DIA(KOFF6),NTOTC,ONE, 69 * ETAIJ(KOFFRE),NTOTRE) 70C 71 CALL DGEMM('T','N',NRHF(ISYMI),NRHF(ISYMJ),NVIR(ISYMC),-ONE, 72 * DIA(KOFF5),NTOTC,XINTIA(KOFF6),NTOTC,ONE, 73 * ETAIJ(KOFFRE),NTOTRE) 74C 75 100 CONTINUE 76C 77 DO 101 ISYMA = 1,NSYM 78C 79C---------------------------------------------------------------- 80C Calculate terms to eta_ab. 81C---------------------------------------------------------------- 82C 83 ISYMB = ISYMA 84 ISYMK = MULD2H(ISYMA,ISYM) 85 ISYMC = MULD2H(ISYMA,ISYM) 86C 87 KOFFRE = IMATAB(ISYMA,ISYMB) + 1 88C 89 NTOTRE = MAX(NVIR(ISYMA),1) 90 NTOTA = MAX(NVIR(ISYMA),1) 91 NTOTB = MAX(NVIR(ISYMB),1) 92C 93 KOFF1 = IT1AM(ISYMA,ISYMK) + 1 94 KOFF2 = IT1AM(ISYMB,ISYMK) + 1 95C 96 CALL DGEMM('N','T',NVIR(ISYMA),NVIR(ISYMB),NRHF(ISYMK),ONE, 97 * XINTIA(KOFF1),NTOTA,DIA(KOFF2),NTOTB,ONE, 98 * ETAAB(KOFFRE),NTOTRE) 99C 100 CALL DGEMM('N','T',NVIR(ISYMA),NVIR(ISYMB),NRHF(ISYMK),-ONE, 101 * DIA(KOFF1),NTOTA,XINTIA(KOFF2),NTOTB,ONE, 102 * ETAAB(KOFFRE),NTOTRE) 103C 104 101 CONTINUE 105C 106 CALL QEXIT('CCPT_ETARS_1E') 107C 108 RETURN 109 END 110C 111C------------------------------------------------------------------------ 112C /* Deck ccpt_etaai_1e */ 113 SUBROUTINE ccpt_etaai_1e(ETAKA,XINTIJ,XINTAI,XINTIA,XINTAB, 114 * DIA,WORK,LWORK,ISYM) 115C 116C Written by Sonia Coriani 22/2 - 2002 117C 118C Version: 1.0 119C 120C Purpose: To set up the right hand side of the equation for 121C zeta-kappa-0 (ETAKA) from MO-integrals (XI*) and (T) 122C one-electron density contribution D_ia to the Coupled 123C Cluster densities 124C ISYM is the symmetry of both the density and the 125C integrals! 126C Based on CCDENZK0 by A. Halkier 127C 128#include "implicit.h" 129 PARAMETER(ZERO = 0.0D0, ONE = 1.0D0) 130 DIMENSION ETAKA(*), XINTIJ(*), XINTAI(*), XINTIA(*), XINTAB(*) 131 DIMENSION DIA(*) 132 DIMENSION WORK(LWORK) 133#include "priunit.h" 134#include "ccorb.h" 135#include "ccsdsym.h" 136C 137 CALL QENTER('ccpt_etaai_1e') 138C 139 DO 100 ISYMA = 1,NSYM 140C 141 ISYMI = ISYMA 142 ISYMB = MULD2H(ISYMA,ISYM) 143 ISYMJ = MULD2H(ISYMA,ISYM) 144C 145 KOFFRE = IT1AM(ISYMA,ISYMI) + 1 146C 147 NTOTRE = MAX(NVIR(ISYMA),1) 148 NTOTB = MAX(NVIR(ISYMB),1) 149 NTOTJ = MAX(NRHF(ISYMJ),1) 150C 151 KOFF1 = IMATAB(ISYMA,ISYMB) + 1 152 KOFF2 = IT1AM(ISYMB,ISYMI) + 1 153C 154 KOFF5 = IT1AM(ISYMA,ISYMJ) + 1 155 KOFF6 = IMATIJ(ISYMJ,ISYMI) + 1 156C 157C------------------------------------------------------- 158C Calculate terms originating from [H(t1),E(ia)]. 159C------------------------------------------------------- 160C 161 CALL DGEMM('N','N',NVIR(ISYMA),NRHF(ISYMI),NVIR(ISYMB), 162 * ONE,XINTAB(KOFF1),NTOTRE,DIA(KOFF2),NTOTB, 163 * ONE,ETAKA(KOFFRE),NTOTRE) 164C 165 CALL DGEMM('N','N',NVIR(ISYMA),NRHF(ISYMI),NRHF(ISYMJ), 166 * -ONE,DIA(KOFF5),NTOTRE,XINTIJ(KOFF6),NTOTJ, 167 * ONE,ETAKA(KOFFRE),NTOTRE) 168C 169 100 CONTINUE 170C 171 CALL QEXIT('ccpt_etaai_1e') 172C 173 RETURN 174 END 175C 176C---------------------------------------------------------------- 177C /* Deck ccpt_etars_2e */ 178 SUBROUTINE CCPT_ETARS_2E(ETAIJ,ETAAB, 179 & XINTIJ,XINTAI,XINTIA,XINTAB, 180 & DSIJ,DAI,DIA,DSAB,WORK,LWORK,ISYM) 181C 182C Written by S. Coriani 11/2-2002 183C 184C Version: 1.0 185C 186C Purpose: To set up the two-electron contribution to the 187C right hand side of the equation for 188C zeta-kappa-0_ij (ETAIJ) and zeta-kappa-0_ab (ETAAB) 189C from MO-integrals (XIN*) and (T) 190C contribution to CCSD(T) densities (d_pq;gamma,delta) 191C ISYM is the symmetry of both the density and the 192C integrals! 193C 194#include "implicit.h" 195 PARAMETER(ZERO = 0.0D0, ONE = 1.0D0) 196 DIMENSION ETAIJ(*), ETAAB(*) 197 DIMENSION XINTIJ(*), XINTAI(*), XINTIA(*), XINTAB(*) 198 DIMENSION DIA(*),DAI(*),DSIJ(*),DSAB(*),WORK(LWORK) 199#include "priunit.h" 200#include "ccorb.h" 201#include "ccsdsym.h" 202#include "cclr.h" 203C 204 CALL QENTER('CCPT_ETARS_2E') 205C 206C-------------------------------------------- 207C Two-electron density contribution to eta_ij 208C-------------------------------------------- 209C 210 DO 100 ISYMI = 1,NSYM 211C 212 ISYMJ = ISYMI 213 ISYMK = MULD2H(ISYMI,ISYM) 214 ISYMC = MULD2H(ISYMI,ISYM) 215C 216 KOFFIJ = IMATIJ(ISYMI,ISYMJ) + 1 217C 218 NTOTI = MAX(NRHF(ISYMI),1) 219 NTOTJ = MAX(NRHF(ISYMJ),1) 220 NTOTK = MAX(NRHF(ISYMK),1) 221 NTOTC = MAX(NVIR(ISYMC),1) 222C 223C---------------------------------------------------------------- 224C Calculate sum_k terms to eta_ij. 225C---------------------------------------------------------------- 226C 227 KOFF1 = IMATIJ(ISYMK,ISYMI) + 1 228 KOFF2 = IMATIJ(ISYMK,ISYMJ) + 1 229 KOFF3 = IMATIJ(ISYMI,ISYMK) + 1 230 KOFF4 = IMATIJ(ISYMJ,ISYMK) + 1 231C 232 CALL DGEMM('T','N',NRHF(ISYMI),NRHF(ISYMJ),NRHF(ISYMK),ONE, 233 * XINTIJ(KOFF1),NTOTK,DSIJ(KOFF2),NTOTK,ONE, 234 * ETAIJ(KOFFIJ),NTOTI) 235C 236 CALL DGEMM('N','T',NRHF(ISYMI),NRHF(ISYMJ),NRHF(ISYMK),ONE, 237 * XINTIJ(KOFF3),NTOTI,DSIJ(KOFF4),NTOTJ,ONE, 238 * ETAIJ(KOFFIJ),NTOTI) 239C 240 CALL DGEMM('N','T',NRHF(ISYMI),NRHF(ISYMJ),NRHF(ISYMK),-ONE, 241 * DSIJ(KOFF3),NTOTI,XINTIJ(KOFF4),NTOTJ,ONE, 242 * ETAIJ(KOFFIJ),NTOTI) 243C 244 CALL DGEMM('T','N',NRHF(ISYMI),NRHF(ISYMJ),NRHF(ISYMK),-ONE, 245 * DSIJ(KOFF1),NTOTK,XINTIJ(KOFF2),NTOTK,ONE, 246 * ETAIJ(KOFFIJ),NTOTI) 247C 248C---------------------------------------------------------------- 249C Calculate sum_c terms to eta_ij. 250C---------------------------------------------------------------- 251C 252 KOFF5 = IT1AM(ISYMC,ISYMI) + 1 253 KOFF6 = IT1AM(ISYMC,ISYMJ) + 1 254C 255 CALL DGEMM('T','N',NRHF(ISYMI),NRHF(ISYMJ),NVIR(ISYMC),ONE, 256 * XINTAI(KOFF5),NTOTC,DAI(KOFF6),NTOTC,ONE, 257 * ETAIJ(KOFFIJ),NTOTI) 258C 259 CALL DGEMM('T','N',NRHF(ISYMI),NRHF(ISYMJ),NVIR(ISYMC),ONE, 260 * XINTIA(KOFF5),NTOTC,DIA(KOFF6),NTOTC,ONE, 261 * ETAIJ(KOFFIJ),NTOTI) 262C 263 CALL DGEMM('T','N',NRHF(ISYMI),NRHF(ISYMJ),NVIR(ISYMC),-ONE, 264 * DIA(KOFF5),NTOTC,XINTIA(KOFF6),NTOTC,ONE, 265 * ETAIJ(KOFFIJ),NTOTI) 266C 267 CALL DGEMM('T','N',NRHF(ISYMI),NRHF(ISYMJ),NVIR(ISYMC),-ONE, 268 * DAI(KOFF5),NTOTC,XINTAI(KOFF6),NTOTC,ONE, 269 * ETAIJ(KOFFIJ),NTOTI) 270 271 100 CONTINUE 272C 273C-------------------------------------------- 274C Two-electron density contribution to eta_ab 275C-------------------------------------------- 276C 277 DO 101 ISYMA = 1,NSYM 278C 279C---------------------------------------------------------------- 280C Calculate sum_k terms to eta_ab. 281C---------------------------------------------------------------- 282C 283 ISYMB = ISYMA 284 ISYMK = MULD2H(ISYMA,ISYM) 285 ISYMC = MULD2H(ISYMA,ISYM) 286C 287 KOFFAB = IMATAB(ISYMA,ISYMB) + 1 288C 289 NTOTA = MAX(NVIR(ISYMA),1) 290 NTOTB = MAX(NVIR(ISYMB),1) 291 NTOTC = MAX(NVIR(ISYMC),1) 292 NTOTK = MAX(NRHF(ISYMK),1) 293C 294 KOFF1 = IT1AM(ISYMA,ISYMK) + 1 295 KOFF2 = IT1AM(ISYMB,ISYMK) + 1 296C 297 CALL DGEMM('N','T',NVIR(ISYMA),NVIR(ISYMB),NRHF(ISYMK),ONE, 298 * XINTIA(KOFF1),NTOTA,DIA(KOFF2),NTOTB,ONE, 299 * ETAAB(KOFFAB),NTOTA) 300C 301 CALL DGEMM('N','T',NVIR(ISYMA),NVIR(ISYMB),NRHF(ISYMK),-ONE, 302 * DAI(KOFF1),NTOTA,XINTAI(KOFF2),NTOTB,ONE, 303 * ETAAB(KOFFAB),NTOTA) 304C 305 CALL DGEMM('N','T',NVIR(ISYMA),NVIR(ISYMB),NRHF(ISYMK),-ONE, 306 * DIA(KOFF1),NTOTA,XINTIA(KOFF2),NTOTB,ONE, 307 * ETAAB(KOFFAB),NTOTA) 308C 309 CALL DGEMM('N','T',NVIR(ISYMA),NVIR(ISYMB),NRHF(ISYMK),ONE, 310 * XINTAI(KOFF1),NTOTA,DAI(KOFF2),NTOTB,ONE, 311 * ETAAB(KOFFAB),NTOTA) 312C 313C---------------------------------------------------------------- 314C Calculate sum_c terms to eta_ab. 315C---------------------------------------------------------------- 316C 317 KOFF3 = IMATAB(ISYMC,ISYMA) + 1 318 KOFF4 = IMATAB(ISYMC,ISYMB) + 1 319 KOFF5 = IMATAB(ISYMA,ISYMC) + 1 320 KOFF6 = IMATAB(ISYMB,ISYMC) + 1 321C 322 CALL DGEMM('T','N',NVIR(ISYMA),NVIR(ISYMB),NVIR(ISYMC),ONE, 323 * XINTAB(KOFF3),NTOTC,DSAB(KOFF4),NTOTC,ONE, 324 * ETAAB(KOFFAB),NTOTA) 325C 326 CALL DGEMM('N','T',NVIR(ISYMA),NVIR(ISYMB),NVIR(ISYMC),-ONE, 327 * DSAB(KOFF5),NTOTA,XINTAB(KOFF6),NTOTB,ONE, 328 * ETAAB(KOFFAB),NTOTA) 329C 330 CALL DGEMM('T','N',NVIR(ISYMA),NVIR(ISYMB),NVIR(ISYMC),-ONE, 331 * DSAB(KOFF3),NTOTC,XINTAB(KOFF4),NTOTC,ONE, 332 * ETAAB(KOFFAB),NTOTA) 333C 334 CALL DGEMM('N','T',NVIR(ISYMA),NVIR(ISYMB),NVIR(ISYMC),ONE, 335 * XINTAB(KOFF5),NTOTA,DSAB(KOFF6),NTOTB,ONE, 336 * ETAAB(KOFFAB),NTOTA) 337C 338 101 CONTINUE 339C 340 CALL QEXIT('CCPT_ETARS_2E') 341C 342 RETURN 343 END 344C------------------------------------------------------------------------ 345C /* Deck ccpt_etaai_2e */ 346 SUBROUTINE ccpt_etaai_2e(ETAKA,XINTIJ,XINTAI,XINTIA,XINTAB, 347 & DSIJ,DAI,DIA,DSAB,WORK,LWORK,ISYM) 348C 349C Written by Sonia Coriani 08/2 - 2002. Based on CCDENZK0 350C 351C Version: 1.0 352C 353C Purpose: To set up the right hand side of the equation for 354C zeta-kappa-0 (ETAKA) from MO-integrals (XI*) and 355C pure (T) two-electron density contribution 356C d_pq(gamma,delta) to the Coupled Cluster densities 357C ISYM is the symmetry of both the density and the 358C integrals! 359C 360#include "implicit.h" 361 PARAMETER(ZERO = 0.0D0, ONE = 1.0D0) 362 DIMENSION ETAKA(*), XINTIJ(*), XINTAI(*), XINTIA(*), XINTAB(*) 363 DIMENSION DAI(*), DIA(*), DSIJ(*), DSAB(*) 364 DIMENSION WORK(LWORK) 365#include "priunit.h" 366#include "ccorb.h" 367#include "ccsdsym.h" 368C 369 CALL QENTER('ccpt_etaai_2e') 370C 371 DO 100 ISYMA = 1,NSYM 372C 373 ISYMI = ISYMA 374 ISYMB = MULD2H(ISYMA,ISYM) 375 ISYMJ = MULD2H(ISYMA,ISYM) 376C 377 KOFFAI = IT1AM(ISYMA,ISYMI) + 1 378C 379 NTOTA = MAX(NVIR(ISYMA),1) 380 NTOTB = MAX(NVIR(ISYMB),1) 381 NTOTJ = MAX(NRHF(ISYMJ),1) 382 NTOTI = MAX(NRHF(ISYMI),1) 383C 384 KOFF1 = IMATAB(ISYMB,ISYMA) + 1 385 KOFF2 = IT1AM(ISYMB,ISYMI) + 1 386 387 ! sum_b d_bi g_ba = sum_b (g_ba)^T d_bi 388 389 CALL DGEMM('T','N',NVIR(ISYMA),NRHF(ISYMI),NVIR(ISYMB), 390 * ONE,XINTAB(KOFF1),NTOTB,DAI(KOFF2),NTOTB,ONE, 391 * ETAKA(KOFFAI),NTOTA) 392 393 ! - sum_b ds_ab g_bi 394 395 KOFF3 = IMATAB(ISYMA,ISYMB) + 1 396 KOFF4 = IT1AM(ISYMB,ISYMI) + 1 397C 398 CALL DGEMM('N','N',NVIR(ISYMA),NRHF(ISYMI),NVIR(ISYMB), 399 * -ONE,DSAB(KOFF3),NTOTA,XINTAI(KOFF4),NTOTB,ONE, 400 * ETAKA(KOFFAI),NTOTA) 401 402 ! - sum_j g_ja(aj) d_ji ????????????????????????????????? 403 404 405 KOFF5 = IT1AM(ISYMA,ISYMJ) + 1 406 KOFF6 = IMATIJ(ISYMJ,ISYMI) + 1 407C 408 CALL DGEMM('N','N',NVIR(ISYMA),NRHF(ISYMI),NRHF(ISYMJ), 409 * ONE,XINTIA(KOFF5),NTOTA,DSIJ(KOFF6),NTOTJ,ONE, 410 * ETAKA(KOFFAI),NTOTA) 411 412 ! - sum_j d_aj g_ij^T 413 414 KOFF7 = IT1AM(ISYMA,ISYMJ) + 1 415 KOFF8 = IMATIJ(ISYMI,ISYMJ) + 1 416C 417 CALL DGEMM('N','T',NVIR(ISYMA),NRHF(ISYMI),NRHF(ISYMJ), 418 * -ONE,DAI(KOFF7),NTOTA,XINTIJ(KOFF8),NTOTI,ONE, 419 * ETAKA(KOFFAI),NTOTA) 420 421 ! - sum_b d_ba^T g_bi 422 423 KOFF9 = IMATAB(ISYMB,ISYMA) + 1 424 KOFF10 = IT1AM(ISYMB,ISYMI) + 1 425C 426 CALL DGEMM('T','N',NVIR(ISYMA),NRHF(ISYMI),NVIR(ISYMB), 427 * -ONE,DSAB(KOFF9),NTOTB,XINTAI(KOFF10),NTOTB, 428 * ONE,ETAKA(KOFFAI),NTOTA) 429 430 ! sum_b g_ab d_ib(bi) 431 432 KOFF11 = IMATAB(ISYMA,ISYMB) + 1 433 KOFF12 = IT1AM(ISYMB,ISYMI) + 1 434 435 CALL DGEMM('N','N',NVIR(ISYMA),NRHF(ISYMI),NVIR(ISYMB), 436 * ONE,XINTAB(KOFF11),NTOTA,DIA(KOFF12),NTOTB, 437 * ONE,ETAKA(KOFFAI),NTOTA) 438 439 ! sum_j d_ja(aj) g_ji 440 441 KOFF13 = IT1AM(ISYMA,ISYMJ) + 1 442 KOFF14 = IMATIJ(ISYMJ,ISYMI) + 1 443C 444 CALL DGEMM('N','N',NVIR(ISYMA),NRHF(ISYMI),NRHF(ISYMJ), 445 * -ONE,DIA(KOFF13),NTOTA,XINTIJ(KOFF14),NTOTJ, 446 * ONE,ETAKA(KOFFAI),NTOTA) 447 448 ! sum_j g_aj d_ij^T 449 450 KOFF15 = IT1AM(ISYMA,ISYMJ) + 1 451 KOFF16 = IMATIJ(ISYMI,ISYMJ) + 1 452C 453 CALL DGEMM('N','T',NVIR(ISYMA),NRHF(ISYMI),NRHF(ISYMJ), 454 * ONE,XINTAI(KOFF15),NTOTA,DSIJ(KOFF16),NTOTI, 455 * ONE,ETAKA(KOFFAI),NTOTA) 456C 457 458 100 CONTINUE 459C 460 CALL QEXIT('ccpt_etaai_2e') 461C 462 RETURN 463 END 464