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