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_QAOS(QAOS,RMAT,XKAPPA,IREAL,ISYMQ,SAO,WORK,LWORK) 21*---------------------------------------------------------------------* 22* 23* Purpose: calculate the product of Q^{p,ao} matrix with the 24* AO overlap matrix: 25* 26* QAOS -- result matrix: CMO Q^p CMO^T S^AO 27* RMAT -- orbital connection matrix in AO basis 28* XKAPPA -- orbital relaxation vector in MO basis 29* IREAL -- flag for real/imaginary R and kappa 30* ISYMQ -- symmetry of XKAPPA, RMAT, and QAOS 31* SAO -- overlap matrix 32* 33* Christof Haettig, March 1999 34* 35* N.B.: not yet fully adapted non-antisymmetric kappa 36* and/or non-symmetric R !!! 37* 38*=====================================================================* 39#if defined (IMPLICIT_NONE) 40 IMPLICIT NONE 41#else 42# include "implicit.h" 43#endif 44#include "priunit.h" 45#include "dummy.h" 46#include "ccorb.h" 47#include "ccsdsym.h" 48 49 LOGICAL LOCDBG 50 PARAMETER (LOCDBG = .FALSE.) 51 INTEGER ISYM0 52 PARAMETER (ISYM0 = 1) 53 54 INTEGER IREAL, ISYMQ, LWORK 55 56#if defined (SYS_CRAY) 57 REAL QAOS(*), RMAT(*), XKAPPA(*), SAO(*), WORK(LWORK) 58 REAL ONE, ZERO 59#else 60 DOUBLE PRECISION QAOS(*), RMAT(*), XKAPPA(*), SAO(*), WORK(LWORK) 61 DOUBLE PRECISION ONE, ZERO 62#endif 63 PARAMETER(ONE=1.0D0, ZERO=0.0D0) 64 65 LOGICAL NOKAPPA 66 INTEGER ISYALP, ISYBET, ISYGAM, ISYMP, NBASA, NBASB 67 INTEGER KQMOP, KQMOH, KCMOQ 68 INTEGER KCMO, KQAO, KEND1, LWRK1, KOFF1, KOFF2, KOFF3, NORBSA 69 INTEGER NCMO(8), ICMO(8,8), ISYM, ICOUNT, ISYM2, ISYM1 70 71*---------------------------------------------------------------------* 72* set ICMO & NCMO arrays: 73*---------------------------------------------------------------------* 74 DO ISYM = 1, NSYM 75 ICOUNT = 0 76 DO ISYM2 = 1, NSYM 77 ISYM1 = MULD2H(ISYM,ISYM2) 78 ICMO(ISYM1,ISYM2) = ICOUNT 79 ICOUNT = ICOUNT + NBAS(ISYM1)*NORBS(ISYM2) 80 END DO 81 NCMO(ISYM) = ICOUNT 82 END DO 83 84*---------------------------------------------------------------------* 85* memory allocation: 86*---------------------------------------------------------------------* 87 KCMO = 1 88 KCMOQ = KCMO + NLAMDS 89 KQMOP = KCMOQ + NCMO(ISYMQ) 90 KQMOH = KQMOP + N2BST(ISYMQ) 91 KQAO = KQMOH + N2BST(ISYMQ) 92 KEND1 = KQAO + N2BST(ISYMQ) 93 LWRK1 = LWORK - KEND1 94 95 IF (LWRK1 .LT. 0) THEN 96 CALL QUIT('Insufficient work space in CC_QAOS.') 97 END IF 98 99*---------------------------------------------------------------------* 100* read (undifferentiated) MO coefficients from file: 101*---------------------------------------------------------------------* 102 CALL CC_GET_CMO(WORK(KCMO)) 103 104*---------------------------------------------------------------------* 105* build Q matrix in MO representation: 106*---------------------------------------------------------------------* 107 NOKAPPA = .FALSE. 108 CALL CC_QMAT(WORK(KQMOP),WORK(KQMOH),RMAT,XKAPPA, 109 & IREAL,ISYMQ,NOKAPPA,WORK(KCMO),WORK(KEND1),LWRK1) 110 111*---------------------------------------------------------------------* 112* transform to leading index to contravariant AO basis: 113* CMOQ = CMO x Q 114*---------------------------------------------------------------------* 115 DO ISYALP = 1, NSYM 116 ISYBET = MULD2H(ISYALP,ISYMQ) 117 118 NBASA = MAX(NBAS(ISYALP),1) 119 NORBSA = MAX(NORBS(ISYALP),1) 120 121 KOFF1 = KCMO + ICMO(ISYALP,ISYALP) 122 KOFF2 = KQMOP + IAODIS(ISYALP,ISYBET) 123 KOFF3 = KCMOQ + ICMO(ISYALP,ISYBET) 124 125 CALL DGEMM('N','N',NBAS(ISYALP),NORBS(ISYBET),NORBS(ISYALP), 126 & ONE,WORK(KOFF1),NBASA,WORK(KOFF2),NORBSA, 127 & ZERO,WORK(KOFF3),NBASA) 128 129 END DO 130 131*---------------------------------------------------------------------* 132* transform to second index to contravariant AO basis: 133* Q^ao = CMOQ x CMO^T 134*---------------------------------------------------------------------* 135 CALL DZERO(WORK(KQAO),N2BST(ISYMQ)) 136 137 DO ISYALP = 1, NSYM 138 139 ISYBET = MULD2H(ISYALP,ISYMQ) 140 ISYMP = ISYBET 141 142 NBASA = MAX(NBAS(ISYALP),1) 143 NBASB = MAX(NBAS(ISYBET),1) 144 145 KOFF1 = KCMOQ + ICMO(ISYALP,ISYMP) 146 KOFF2 = KCMO + ICMO(ISYBET,ISYMP) 147 KOFF3 = KQAO + IAODIS(ISYALP,ISYBET) 148 149 CALL DGEMM('N','T',NBAS(ISYALP),NBAS(ISYBET),NORBS(ISYMP), 150 & ONE,WORK(KOFF1),NBASA,WORK(KOFF2),NBASB, 151 & ZERO,WORK(KOFF3),NBASA) 152 153 END DO 154 155*---------------------------------------------------------------------* 156* multiply with the overlap matrix: 157*---------------------------------------------------------------------* 158 CALL CC_MAOMAO('N','N',ONE,WORK(KQAO),ISYMQ,SAO,ISYM0, 159 & ZERO,QAOS,ISYMQ) 160 161 RETURN 162 END 163*=====================================================================* 164