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! 18 SUBROUTINE CCSD_ASYMSQ(DISTAB,ISYMAB,SCR,ISYMG,ISYMD) 19C 20C Antisymmetric Squareup of the integral distribution, 21C for orbit-orbit Breit-Pauli correction 22C S. Coriani, April 2003. Based on CCSD_SYMSQO. 23C Modified for [T1+T2,r12]-Integrals (Elena Vollmer, September 2003) 24#include "implicit.h" 25 DIMENSION DISTAB(*), SCR(*) 26 PARAMETER (ONE = 1.0D0) 27#include "priunit.h" 28#include "ccorb.h" 29#include "ccsdsym.h" 30C 31 CALL QENTER('CCSD_ASYMSQ') 32C 33 IF (ISYMAB .EQ. 1) THEN 34C 35 KOFF1 = 1 36 KOFF2 = 1 37 DO 100 ISYMB = 1,NSYM 38 CALL ASQMATR(NBAS(ISYMB),DISTAB(KOFF1),SCR(KOFF2),ISYMG) 39 KOFF1 = KOFF1 + NBAS(ISYMB)*(NBAS(ISYMB)+1)/2 40 KOFF2 = KOFF2 + NBAS(ISYMB)*NBAS(ISYMB) 41 100 CONTINUE 42C 43 ELSE 44 KOFF1 = 1 45 KOFF2 = 1 46 DO 200 ISYMB = 1,NSYM 47C 48 ISYMA = MULD2H(ISYMB,ISYMAB) 49 50 IF (ISYMB .GT. ISYMA) THEN 51C 52 NTOT = NBAS(ISYMA)*NBAS(ISYMB) 53C 54 KOFF2 = KOFF1 55 KOFF3 = IAODIS(ISYMB,ISYMA) + 1 56 DO 210 B = 1,NBAS(ISYMB) 57 IF (ISYMG .EQ. 0) THEN 58 CALL DCOPY(NBAS(ISYMA),DISTAB(KOFF2),1,SCR(KOFF3), 59 * NBAS(ISYMB)) 60 ELSE 61 CALL DSCAL(NBAS(ISYMA),-ONE,SCR(KOFF3),NBAS(ISYMB)) 62 CALL DAXPY(NBAS(ISYMA),ONE,DISTAB(KOFF2),1,SCR(KOFF3), 63 * NBAS(ISYMB)) 64 END IF 65 KOFF2 = KOFF2 + NBAS(ISYMA) 66 KOFF3 = KOFF3 + 1 67 210 CONTINUE 68C 69 KOFF4 = IAODIS(ISYMA,ISYMB) + 1 70 IF (ISYMG .EQ. 0) THEN 71 CALL DCOPY(NTOT,DISTAB(KOFF1),1,SCR(KOFF4),1) 72 CALL DSCAL(NTOT,-ONE,SCR(KOFF4),1) 73 ELSE 74 CALL DSCAL(NTOT,-ONE,SCR(KOFF4),1) 75 CALL DAXPY(NTOT,-ONE,DISTAB(KOFF1),1,SCR(KOFF4),1) 76 END IF 77C 78 KOFF1 = KOFF1 + NTOT 79C 80 ENDIF 81C 82 200 CONTINUE 83C 84 ENDIF 85C 86 CALL QEXIT('CCSD_ASYMSQ') 87C 88 RETURN 89 END 90C /* Deck asqmatr */ 91 SUBROUTINE ASQMATR(NDIM,PKMAT,SQMAT,ISYMG) 92C 93C PURPOSE: 94C Antisymmetric Square up packed matrix. 95C 96 IMPLICIT DOUBLE PRECISION (A-H,O-Z) 97 DIMENSION PKMAT(*),SQMAT(NDIM,NDIM) 98 99C 100 IF (ISYMG .EQ. 0) THEN 101 102 IJ = 0 103 DO I = 1,NDIM 104 DO J = 1,I 105C 106 IJ = IJ + 1 107 SQMAT(I,J) = PKMAT(IJ) 108 SQMAT(J,I) = - PKMAT(IJ) 109 ENDDO 110 ENDDO 111 112 ELSE 113 IJ = 0 114 DO 100 I = 1,NDIM 115 DO 110 J = 1,I 116 IJ = IJ + 1 117 IF (I.EQ.J) THEN 118 SQMAT(J,I) = - PKMAT(IJ) - SQMAT(J,I) 119 ELSE 120 SQMAT(I,J) = PKMAT(IJ) - SQMAT(I,J) 121 SQMAT(J,I) = - PKMAT(IJ) - SQMAT(J,I) 122 END IF 123 110 CONTINUE 124 100 CONTINUE 125 ENDIF 126 127 RETURN 128 END 129