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*---------------------------------------------------------------------* 20c/* Deck CC_BATST */ 21*=====================================================================* 22 SUBROUTINE CC_BATST(WORK,LWORK) 23#if defined (IMPLICIT_NONE) 24 IMPLICIT NONE 25#else 26# include "implicit.h" 27#endif 28#include "priunit.h" 29#include "ccsdinp.h" 30#include "ccsdsym.h" 31#include "ccorb.h" 32 33* local parameters: 34 CHARACTER MSGDBG*(18) 35 PARAMETER (MSGDBG='[debug] CC_BATST> ') 36 37 LOGICAL LOCDBG 38 PARAMETER (LOCDBG = .FALSE.) 39 LOGICAL NEW_CODE 40 PARAMETER (NEW_CODE = .TRUE.) 41 INTEGER MXCTRAN 42 PARAMETER (MXCTRAN = 2) 43 44 INTEGER LWORK 45#if defined (SYS_CRAY) 46 REAL WORK(LWORK) 47 REAL DDOT, RDUM 48#else 49 DOUBLE PRECISION WORK(LWORK) 50 DOUBLE PRECISION DDOT, RDUM 51#endif 52 53 LOGICAL LORXA, LORXB, LORXC 54 CHARACTER*(3) LISTA, LISTB, LISTC 55 CHARACTER*(8) FILCMA, LABELA, LABELB, LABELC 56 CHARACTER*(10) MODEL 57 INTEGER IOPTRES, IDUM 58 INTEGER ICTRAN(4,MXCTRAN), NCTRAN 59 INTEGER IDLSTA, IDLSTB, IDLSTC, ISYMA, ISYMB, ISYMC, ISYMABC 60 INTEGER KTHETA1, KTHETA2, KT1AMPC, KT2AMPC, KRESLT1, KRESLT2 61 INTEGER KEND1, LEND1, IOPT, IRELAXA 62 63* external function: 64 INTEGER IROPER 65 INTEGER IR1TAMP 66C INTEGER IL1ZETA 67 INTEGER ILSTSYM 68 69 70 71*---------------------------------------------------------------------* 72* call B{O} matrix transformation: 73*---------------------------------------------------------------------* 74 LISTA = 'o1' 75 LISTB = 'R1' 76 LISTC = 'R1' 77 LABELA = 'ZDIPLEN ' 78 LABELB = 'ZDIPLEN ' 79 LABELC = 'ZDIPLEN ' 80 LORXA = .FALSE. 81 LORXB = .FALSE. 82 LORXC = .FALSE. 83 IDLSTA = IROPER(LABELA,ISYMA) 84 IDLSTB = IR1TAMP(LABELB,LORXB,0.0D0,ISYMB) 85 IDLSTC = IR1TAMP(LABELC,LORXC,0.0D0,ISYMC) 86 IRELAXA = 0 87 IF (LORXA) IRELAXA = IR1TAMP(LABELA,LORXA,0.0D0,ISYMA) 88 89 ICTRAN(1,1) = IDLSTA 90 ICTRAN(2,1) = IDLSTB 91 ICTRAN(3,1) = IDLSTC 92 NCTRAN = 1 93 94 IOPTRES = 1 95 FILCMA = 'CCCMAT' 96 97 CALL CC_BAMAT(ICTRAN, NCTRAN, LISTA, LISTB, LISTC, 98 & IOPTRES, FILCMA, IDUM, RDUM, 0, WORK, LWORK ) 99 100 101 ISYMA = ILSTSYM(LISTA,IDLSTA) 102 ISYMB = ILSTSYM(LISTB,IDLSTB) 103 ISYMC = ILSTSYM(LISTC,IDLSTC) 104 ISYMABC = MULD2H(MULD2H(ISYMA,ISYMB),ISYMC) 105 106 KTHETA1 = ICTRAN(4,1) 107 KTHETA2 = KTHETA1 + NT1AM(ISYMABC) 108 109 IF (NSYM.EQ.1 .AND. LOCDBG) THEN 110 KT1AMPC = KTHETA2 + NT2AM(ISYMABC) 111 KT2AMPC = KT1AMPC + NT1AM(ISYMC) 112 KRESLT1 = KT2AMPC + NT2AM(ISYMC) 113 KRESLT2 = KRESLT1 + NT1AM(ISYMABC) 114 KEND1 = KRESLT2 + NT2AM(ISYMABC) 115 LEND1 = LWORK - KEND1 116 117 IF (LEND1 .LT. 0) THEN 118 CALL QUIT('Insufficient work space in CC_BATST.') 119 END IF 120 121 IOPT = 3 122 Call CC_RDRSP(LISTC,IDLSTC,ISYMC,IOPT,MODEL, 123 & WORK(KT1AMPC),WORK(KT2AMPC)) 124 125 WRITE (LUPRI,*) 'CC_BATST: C vector:' 126 Call CC_PRP(WORK(KT1AMPC),WORK(KT2AMPC),ISYMC,1,1) 127 128 ! zero singles or doubles C vector: 129C CALL DZERO(WORK(KT1AMPC),NT1AM(ISYMC)) 130C CALL DZERO(WORK(KT2AMPC),NT2AM(ISYMC)) 131 CALL DZERO(WORK(KRESLT1),NT1AM(ISYMABC)+NT2AM(ISYMABC)) 132 133 IF (NEW_CODE) THEN 134 CALL CC_FDBAMAT(WORK(KRESLT1),WORK(KRESLT2), 135 > LISTB,IDLSTB,LISTC,IDLSTC, 136 > LABELA,IRELAXA,WORK(KEND1),LEND1) 137 ELSE 138 IPRINT = 6 139 CALL CC_FDBA(NT1AM(ISYMABC),NT2AM(ISYMABC), 140 > LISTA,IDLSTA,LISTB,IDLSTB, 141 > WORK(KT1AMPC), WORK(KRESLT1), 142 > WORK(KEND1), LEND1) 143 ENDIF 144 145 IPRINT = 0 146 147 IF (.TRUE.) THEN 148 WRITE (LUPRI,*) 149 WRITE (LUPRI,*) 150 WRITE (LUPRI,*) 'FINITE DIFFERENCE TEST FOR B{O} MATRIX:' 151 WRITE (LUPRI,*) '---------------------------------------' 152 WRITE (LUPRI,*) 153 & 'LISTA, IDLSTA, ISYMA:',LISTA(1:2),IDLSTA,ISYMA 154 WRITE (LUPRI,*) 155 & 'LISTB, IDLSTB, ISYMB:',LISTB(1:2),IDLSTB,ISYMB 156 WRITE (LUPRI,*) 157 & 'LISTC, IDLSTC, ISYMC:',LISTC(1:2),IDLSTC,ISYMC 158 WRITE (LUPRI,*) 'ISYMABC:',ISYMABC 159 WRITE (LUPRI,*) 160 WRITE (LUPRI,*) 'finite difference Theta vector:' 161 Call CC_PRP(WORK(KRESLT1),WORK(KRESLT2),ISYMABC,1,1) 162 WRITE (LUPRI,*) 'analytical Theta vector:' 163 Call CC_PRP(WORK(KTHETA1),WORK(KTHETA2),ISYMABC,1,1) 164 END IF 165 166 Call DAXPY(NT1AM(ISYMABC),-1.0d0,WORK(KTHETA1),1, 167 & WORK(KRESLT1),1) 168 IF (.NOT.CCS) THEN 169 Call DAXPY(NT2AM(ISYMABC),-1.0d0,WORK(KTHETA2),1, 170 & WORK(KRESLT2),1) 171 ELSE 172 Call DZERO(WORK(KRESLT2),NT2AM(ISYMABC)) 173 END IF 174 175 WRITE (LUPRI,*) 176 WRITE (LUPRI,*) 'FINITE DIFFERENCE TEST FOR B{O} MATRIX:' 177 WRITE (LUPRI,*) '---------------------------------------' 178 WRITE (LUPRI,*) 'Norm of difference between analytical THETA ' 179 > // 'vector and the numerical result:' 180 WRITE (LUPRI,*) 'singles excitation part:', 181 > DSQRT(DDOT(NT1AM(ISYMA),WORK(KRESLT1),1,WORK(KRESLT1),1)) 182 WRITE (LUPRI,*) 'double excitation part: ', 183 > DSQRT(DDOT(NT2AM(ISYMA),WORK(KRESLT2),1,WORK(KRESLT2),1)) 184 185 WRITE (LUPRI,*) 'difference vector:' 186 Call CC_PRP(WORK(KRESLT1),WORK(KRESLT2),ISYMABC,1,1) 187 188 CALL FLSHFO(LUPRI) 189 190 191 ELSE IF (NSYM.NE.1 .AND. LOCDBG) THEN 192 WRITE (LUPRI,*) 'CC_BATST> can not calculate finite diff. '// 193 & 'B{O} matrix' 194 WRITE (LUPRI,*) 'CC_BATST> with symmetry.' 195 END IF 196 197 RETURN 198 END 199*=====================================================================* 200