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 19*=====================================================================* 20 SUBROUTINE CC_1IDX_D2EFF(BAODEN,ICON,G,ISYMG,D,ISYMD,ISYMQ, 21 & DHFAO,ZKABAO, 22 & B1DHFAO,B1KABAO,B2DHFAO,B2KABAO) 23*---------------------------------------------------------------------* 24* 25* Purpose: Add the extra terms to the "one-index" transformed 26* 2-electron density matrix which originate from the 27* orbital relaxation 28* 29* ICON -- analogous to ICON in CC_D2EFF 30* DHFAO -- usual Hatree-Fock density matrix 31* ZKABAO -- relaxation contribution to 1-electron density 32* B1DHFAO -- DHFAO with leading index transformed 33* B1KABAO -- ZKABAO with leading index transformed 34* B2DHFAO -- DHFAO with second index transformed 35* B2KABAO -- ZKABAO with second index transformed 36* ISYMQ -- symmetry of B1DHFAO, B1KABAO, B2DHFAO, B2KABAO 37* ISYM0 -- 1, not passed, symetry of DHFAO and ZKABAO 38* 39* Christof Haettig, March 1999, based on Asgers CC_D2EFF routine 40* 41*=====================================================================* 42#if defined (IMPLICIT_NONE) 43 IMPLICIT NONE 44#else 45# include "implicit.h" 46#endif 47#include "ccorb.h" 48#include "ccsdsym.h" 49 50 LOGICAL LOCDBG 51 PARAMETER (LOCDBG = .FALSE.) 52 53 INTEGER ISYM0 54 PARAMETER (ISYM0 = 1) 55 56 INTEGER ISYMG, ISYMD, ISYMQ, ICON 57 58#if defined (SYS_CRAY) 59 REAL BAODEN(*) 60 REAL DHFAO(*), B1DHFAO(*), B2DHFAO(*) 61 REAL ZKABAO(*), B1KABAO(*), B2KABAO(*) 62 REAL ONE, HALF, TWO, ZERO, FACI, FAC1, FAC2 63#else 64 DOUBLE PRECISION BAODEN(*) 65 DOUBLE PRECISION DHFAO(*), B1DHFAO(*), B2DHFAO(*) 66 DOUBLE PRECISION ZKABAO(*), B1KABAO(*), B2KABAO(*) 67 DOUBLE PRECISION ONE, HALF, TWO, ZERO, FACI, FAC1, FAC2 68#endif 69 PARAMETER(HALF=0.5D0, ONE=1.0D0, ZERO=0.0D0, TWO=2.0D0) 70 71 INTEGER KOFFGD, KOFFAB, KOFFAD, KOFFGB, ISYMA, ISYMB 72 73*---------------------------------------------------------------------* 74* set FACI : if ICON = 2 multiply all contributions by 0.5 75*---------------------------------------------------------------------* 76 FACI = ONE 77 IF (ICON .EQ. 2) FACI = HALF 78 79 80*---------------------------------------------------------------------* 81* Add coulomb terms: 82*---------------------------------------------------------------------* 83 84C ------------------------------------------------------ 85C 2 D^HF_alp,bet (D^zeta_gambar,del + D^Zeta_gam,delbar) 86C ------------------------------------------------------ 87 IF (MULD2H(ISYMG,ISYMD) .EQ. ISYMQ) THEN 88 KOFFGD = IAODIS(ISYMG,ISYMD) + NBAS(ISYMG)*(D - 1) + G 89 FAC1 = TWO * ( B1KABAO(KOFFGD) + B2KABAO(KOFFGD) ) * FACI 90 CALL DAXPY(N2BST(ISYM0),FAC1,DHFAO,1,BAODEN,1) 91 END IF 92 93C ------------------------------------------------------ 94C 2 D^zeta_alp,bet (D^HF_gambar,del + D^HF_gam,delbar) 95C ------------------------------------------------------ 96 IF (MULD2H(ISYMG,ISYMD) .EQ. ISYMQ) THEN 97 KOFFGD = IAODIS(ISYMG,ISYMD) + NBAS(ISYMG)*(D - 1) + G 98 FAC1 = TWO * ( B1DHFAO(KOFFGD) + B2DHFAO(KOFFGD) ) * FACI 99 CALL DAXPY(N2BST(ISYM0),FAC1,ZKABAO,1,BAODEN,1) 100 END IF 101 102*---------------------------------------------------------------------* 103* Add exchange terms: 104*---------------------------------------------------------------------* 105 106 107C -------------------------------- 108C - D^HF_alp,del D^zeta_gambar,bet 109C -------------------------------- 110 ISYMA = MULD2H(ISYMD,ISYM0) 111 ISYMB = MULD2H(ISYMG,ISYMQ) 112 DO B = 1, NBAS(ISYMB) 113 KOFFGB = IAODIS(ISYMG,ISYMB) + NBAS(ISYMG)*(B-1) + G 114 KOFFAD = IAODIS(ISYMA,ISYMD) + NBAS(ISYMA)*(D-1) + 1 115 KOFFAB = IAODIS(ISYMA,ISYMB) + NBAS(ISYMA)*(B-1) + 1 116 FAC2 = -B1KABAO(KOFFGB) * FACI 117 CALL DAXPY(NBAS(ISYMA),FAC2,DHFAO(KOFFAD),1, 118 & BAODEN(KOFFAB),1) 119 END DO 120 121C -------------------------------- 122C - D^HF_alp,delbar D^zeta_gam,bet 123C -------------------------------- 124 ISYMA = MULD2H(ISYMD,ISYMQ) 125 ISYMB = MULD2H(ISYMG,ISYM0) 126 DO B = 1, NBAS(ISYMB) 127 KOFFGB = IAODIS(ISYMG,ISYMB) + NBAS(ISYMG)*(B-1) + G 128 KOFFAD = IAODIS(ISYMA,ISYMD) + NBAS(ISYMA)*(D-1) + 1 129 KOFFAB = IAODIS(ISYMA,ISYMB) + NBAS(ISYMA)*(B-1) + 1 130 FAC2 = -ZKABAO(KOFFGB) * FACI 131 CALL DAXPY(NBAS(ISYMA),FAC2,B2DHFAO(KOFFAD),1, 132 & BAODEN(KOFFAB),1) 133 END DO 134 135C -------------------------------- 136C - D^zeta_alp,del D^HF_gambar,bet 137C -------------------------------- 138 ISYMA = MULD2H(ISYMD,ISYM0) 139 ISYMB = MULD2H(ISYMG,ISYMQ) 140 DO B = 1, NBAS(ISYMB) 141 KOFFGB = IAODIS(ISYMG,ISYMB) + NBAS(ISYMG)*(B-1) + G 142 KOFFAD = IAODIS(ISYMA,ISYMD) + NBAS(ISYMA)*(D-1) + 1 143 KOFFAB = IAODIS(ISYMA,ISYMB) + NBAS(ISYMA)*(B-1) + 1 144 FAC2 = -B1DHFAO(KOFFGB) * FACI 145 CALL DAXPY(NBAS(ISYMA),FAC2,ZKABAO(KOFFAD),1, 146 & BAODEN(KOFFAB),1) 147 END DO 148 149C -------------------------------- 150C - D^zeta_alp,delbar D^HF_gam,bet 151C -------------------------------- 152 ISYMA = MULD2H(ISYMD,ISYMQ) 153 ISYMB = MULD2H(ISYMG,ISYM0) 154 DO B = 1, NBAS(ISYMB) 155 KOFFGB = IAODIS(ISYMG,ISYMB) + NBAS(ISYMG)*(B-1) + G 156 KOFFAD = IAODIS(ISYMA,ISYMD) + NBAS(ISYMA)*(D-1) + 1 157 KOFFAB = IAODIS(ISYMA,ISYMB) + NBAS(ISYMA)*(B-1) + 1 158 FAC2 = -DHFAO(KOFFGB) * FACI 159 CALL DAXPY(NBAS(ISYMA),FAC2,B2KABAO(KOFFAD),1, 160 & BAODEN(KOFFAB),1) 161 END DO 162 163 RETURN 164 END 165*=====================================================================* 166