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 19C /* Deck ccrhsn3 */ 20 SUBROUTINE CCRHSN3(WORK,LWORK) 21! 22! Written by Kasper Hald late march 1999 23! 24! Based on CCRHSN 25! Written by Henrik Koch 25-Sep-1993 26! 27! Purpose: 28! 29! Calculation of the triplet Coupled Cluster global int. using 30! AO-integrals directly from disk. No intermediate files are 31! used in this calculation. The intermediates are written to disk 32! even if RSPIM is false. 33! 34! 35! N.B. The routine is only tested for OMEGOR 36! 37!---------------------------------------------------------------------- 38! 39 IMPLICIT NONE 40! 41#include "priunit.h" 42#include "dummy.h" 43#include "maxorb.h" 44#include "mxcent.h" 45#include "aovec.h" 46#include "iratdef.h" 47#include "ccorb.h" 48#include "ccisao.h" 49#include "blocks.h" 50#include "ccfield.h" 51#include "ccsdinp.h" 52#include "ccsdsym.h" 53#include "ccsdio.h" 54#include "distcl.h" 55#include "cbieri.h" 56#include "eritap.h" 57#include "second.h" 58#include "r12int.h" 59! 60 INTEGER LWORK, ISYMTR, LUCSIM, LUDTIM, IERRCS, IERRDT 61 INTEGER KOMG1, KOMG2, KLAMDP, KLAMIP, KLAMDH, KDENSI 62 INTEGER KFOCK, KEMAT1, KEMAT2, KEND1, LWRK1, JSYM, ISYMH, IC 63 INTEGER IF, KENDS2, LWRKS2, NTOSYM, KCCFB1, KINDXB, KT2AMT 64 INTEGER KODCL1, KODCL2, KODBC1, KODBC2, KRDBC1, KRDBC2 65 INTEGER KODPP1, KODPP2, KRDPP1, KRDPP2, KFREE, LFREE, KENDSV 66 INTEGER LWRKSV, ICDEL1, ISYMD1, NTOT, ILLL, NUMDIS, KRECNR 67 INTEGER IDEL, IDEL2, ISYMD, ISYDIS, KXINT, KEND2, LWRK2 68 INTEGER ISYDEN, ICON, ISYMLH, IOPT, ISYM0 69 INTEGER KDSRHF, KEND4, LWRK4, ISYMLP, IV, ISYM, LUBF 70 INTEGER KGAMMA, ISYMBF, LUGAM, LUFCK, ISYMEI, LUE1, LUE2 71 INTEGER KOFF, KT1AM, KT2AM 72! 73 INTEGER INDEXA(MXCORB_CC) 74! 75 INTEGER IDUM 76! 77#if defined (SYS_CRAY) 78 REAL WORK(LWORK) 79 REAL DTIME, DDOT, FACTC, FACTD, FAKE, FF, HALF, ONE 80 REAL PHONEY, RHO1N, RHO2N, FACTE1, FACTE2 81 REAL TIMALL, TIMBF, TIMC, TIMDM 82 REAL TIMEI, TIMF, TIMFCK, TIMGAM, TIMHER1 83 REAL TIMHER2, TIMLAM, TIMRDAO, TIMT2AO, TIMT2BT, TIMT2TR, TIMTRBT 84 REAL TWO, XMHALF, XMONE, ZERO, XNORM 85#else 86 DOUBLE PRECISION WORK(LWORK) 87 DOUBLE PRECISION DTIME, DDOT, FACTC, FACTD 88 DOUBLE PRECISION FAKE, FF, HALF, ONE, PHONEY 89 DOUBLE PRECISION RHO1N, RHO2N, FACTE1, FACTE2 90 DOUBLE PRECISION TIMALL, TIMBF, TIMC, TIMDM 91 DOUBLE PRECISION TIMEI, TIMFCK 92 DOUBLE PRECISION TIMGAM, TIMHER1, TIMHER2, TIMLAM 93 DOUBLE PRECISION TIMRDAO, TIMT2AO, TIMT2BT, TIMT2TR, TIMTRBT 94 DOUBLE PRECISION TWO, XMHALF, XMONE, ZERO, XNORM 95#endif 96! 97 PARAMETER (ZERO= 0.0D00, HALF= 0.5D00, ONE= 1.0D00, TWO= 2.0D00) 98 PARAMETER (XMHALF = -0.5D00, XMONE= -1.0D00 ) 99! 100 LOGICAL FCKCON, ETRAN, ANTISYM 101! 102 CHARACTER CSFIL*6, DTFIL*7 103 CHARACTER*10 MODEL 104! 105!----------------------------------------------------------- 106! For energy calculation trial vector is totalsymmetric. 107!----------------------------------------------------------- 108! 109 ISYMTR = 1 110! 111!---------------- 112! Open files. 113!---------------- 114! 115 LUDTIM = -1 116 LUCSIM = -1 117 CSFIL = 'PMAT_C' 118 DTFIL = 'PMAT_DT' 119! 120 IF (DUMPCD) THEN 121 CALL WOPEN2(LUDTIM,DTFIL,64,0) 122 CALL WOPEN2(LUCSIM,CSFIL,64,0) 123! 124 END IF 125! 126!---------------------------------- 127! Initialize timing parameters. 128!---------------------------------- 129! 130 TIMALL = SECOND() 131 TIMBF = 0.0D00 132 TIMDM = 0.0D00 133 TIMEI = 0.0D00 134 TIMFCK = 0.0D00 135 TIMHER1 = 0.0D00 136 TIMHER2 = 0.0D00 137 TIMLAM = 0.0D00 138 TIMRDAO = 0.0D00 139 TIMT2AO = 0.0D00 140 TIMT2BT = 0.0D00 141 TIMT2TR = 0.0D00 142 TIMTRBT = 0.0D00 143! 144!--------------------------- 145! Check inconsistencies. 146!--------------------------- 147! 148 IF (NEWGAM) THEN 149 IF ((.NOT. DUMPCD) .OR. (.NOT. OMEGOR)) THEN 150 WRITE(LUPRI,*) 'NEWGAM requires both DUMPCD and OMEGOR' 151 CALL QUIT('ERROR: NEWGAM inconsistency') 152 END IF 153 END IF 154! 155!--------------------------------- 156! Work space allocation no. 1. 157!--------------------------------- 158! 159 KT1AM = 1 160 KT2AM = KT1AM + NT1AMX 161 KLAMDP = KT2AM + NT2SQ(1) 162 KLAMDH = KLAMDP + NLAMDT 163 KEND1 = KLAMDH + NLAMDT 164 LWRK1 = LWORK - KEND1 165! 166 IF (LWRK1 .LT. NT2AMX) THEN 167 WRITE(LUPRI,*) 'Need : ',KEND1+NT2AMX,'Available : ',LWORK 168 CALL QUIT('Insufficient space in CCRHSN3') 169 ENDIF 170! 171!------------------------------- 172! Prepare the t2-amplitudes. 173!------------------------------- 174! 175 IOPT = 3 176 CALL CC_RDRSP('R0',0,1,IOPT,MODEL,WORK(KT1AM),WORK(KEND1)) 177! 178 CALL CC_T2SQ(WORK(KEND1),WORK(KT2AM),ISYMTR) 179! 180!---------------------------------- 181! Calculate the lamda matrices. 182!---------------------------------- 183! 184 TIMLAM = SECOND() 185 CALL LAMMAT(WORK(KLAMDP),WORK(KLAMDH),WORK(KT1AM), 186 & WORK(KEND1),LWRK1) 187 TIMLAM = SECOND() - TIMLAM 188! 189!==================================================== 190! Start the loop over distributions of integrals. 191!==================================================== 192! 193 KENDS2 = KEND1 194 LWRKS2 = LWRK1 195! 196 IF (DIRECT) THEN 197 DTIME = SECOND() 198 199 IF (HERDIR) THEN 200 CALL HERDI1(WORK(KEND1),LWRK1,IPRERI) 201 ELSE 202 KCCFB1 = KEND1 203 KINDXB = KCCFB1 + MXPRIM*MXCONT 204 KEND1 = KINDXB + (8*MXSHEL*MXCONT + 1)/IRAT 205 LWRK1 = LWORK - KEND1 206 CALL ERIDI1(KODCL1,KODCL2,KODBC1,KODBC2,KRDBC1,KRDBC2, 207 & KODPP1,KODPP2,KRDPP1,KRDPP2, 208 & KFREE,LFREE,KEND1,WORK(KCCFB1),WORK(KINDXB), 209 & WORK(KEND1),LWRK1,IPRERI) 210 KEND1 = KFREE 211 LWRK1 = LFREE 212 END IF 213 214 DTIME = SECOND() - DTIME 215 TIMHER1 = TIMHER1 + DTIME 216 NTOSYM = 1 217 ELSE 218 NTOSYM = NSYM 219 ENDIF 220! 221 KENDSV = KEND1 222 LWRKSV = LWRK1 223! 224 ICDEL1 = 0 225 DO 100 ISYMD1 = 1,NTOSYM 226! 227 IF (DIRECT) THEN 228 IF (HERDIR) THEN 229 NTOT = MAXSHL 230 ELSE 231 NTOT = MXCALL 232 END IF 233 ELSE 234 NTOT = NBAS(ISYMD1) 235 ENDIF 236! 237 DO 110 ILLL = 1,NTOT 238! 239!----------------------------------------------------------------- 240! If direct calculate the integrals and transposed t2am. 241!----------------------------------------------------------------- 242! 243 IF (DIRECT) THEN 244! 245 KEND1 = KENDSV 246 LWRK1 = LWRKSV 247! 248 DTIME = SECOND() 249 IF (HERDIR) THEN 250 CALL HERDI2(WORK(KEND1),LWRK1,INDEXA,ILLL,NUMDIS, 251 & IPRERI) 252 ELSE 253 CALL ERIDI2(ILLL,INDEXA,NUMDIS,0,0, 254 & WORK(KODCL1),WORK(KODCL2), 255 & WORK(KODBC1),WORK(KODBC2), 256 & WORK(KRDBC1),WORK(KRDBC2), 257 & WORK(KODPP1),WORK(KODPP2), 258 & WORK(KRDPP1),WORK(KRDPP2), 259 & WORK(KCCFB1),WORK(KINDXB), 260 & WORK(KEND1), LWRK1,IPRERI) 261 END IF 262 DTIME = SECOND() - DTIME 263 TIMHER2 = TIMHER2 + DTIME 264! 265 KRECNR = KEND1 266 KEND1 = KRECNR + (NBUFX(0) - 1)/IRAT + 1 267 LWRK1 = LWORK - KEND1 268 IF (LWRK1 .LT. 0) THEN 269 CALL QUIT('Insufficient core in CCRHSN3') 270 END IF 271! 272 ELSE 273 NUMDIS = 1 274 ENDIF 275! 276!----------------------------------------------------- 277! Loop over number of distributions in disk. 278!----------------------------------------------------- 279! 280 DO 120 IDEL2 = 1,NUMDIS 281! 282 IF (DIRECT) THEN 283 IDEL = INDEXA(IDEL2) 284 IF (NOAUXB) THEN 285 IDUM = 1 286 CALL IJKAUX(IDEL,IDUM,IDUM,IDUM) 287 END IF 288 ISYMD = ISAO(IDEL) 289 ELSE 290 IDEL = IBAS(ISYMD1) + ILLL 291 ISYMD = ISYMD1 292 ENDIF 293! 294 ISYDIS = MULD2H(ISYMD,ISYMOP) 295! 296!------------------------------------------ 297! Adresses for C/D 298!------------------------------------------ 299! 300 IT2DEL(IDEL) = ICDEL1 301 ICDEL1 = ICDEL1 + NT2BCD(ISYDIS) 302! 303!------------------------------------------ 304! Work space allocation no. 2. 305!------------------------------------------ 306! 307 KXINT = KEND1 308 KEND2 = KXINT + NDISAO(ISYDIS) 309 LWRK2 = LWORK - KEND2 310! 311 IF (LWRK2 .LT. 0) THEN 312 WRITE(LUPRI,*) 'Need : ',KEND2,'Available : ',LWORK 313 CALL QUIT('Insufficient space in CCRHSN3') 314 ENDIF 315! 316! 317!----------------------------------------- 318! Read in batch of integrals. 319!----------------------------------------- 320! 321 DTIME = SECOND() 322 CALL CCRDAO(WORK(KXINT),IDEL,IDEL2,WORK(KEND2),LWRK2, 323 * WORK(KRECNR),DIRECT) 324! 325 DTIME = SECOND() - DTIME 326 TIMRDAO = TIMRDAO + DTIME 327! 328!------------------------------------------ 329! Work space allocation no. 4. 330!------------------------------------------ 331! 332 KDSRHF = KEND2 333 KEND4 = KDSRHF + NDSRHF(ISYMD) 334 LWRK4 = LWORK - KEND4 335! 336 IF (LWRK4 .LT. 0) THEN 337 WRITE(LUPRI,*) 'Need : ',KEND4,'Available : ',LWORK 338 CALL QUIT('Insufficient space in CCRHSN') 339 ENDIF 340! 341!-------------------------------------------------------- 342! Transform one index in the integral batch. 343!-------------------------------------------------------- 344! 345 DTIME = SECOND() 346 ISYMLP = 1 347 CALL CCTRBT(WORK(KXINT),WORK(KDSRHF),WORK(KLAMDP), 348 * ISYMLP,WORK(KEND4),LWRK4,ISYDIS) 349 DTIME = SECOND() - DTIME 350 TIMTRBT = TIMTRBT + DTIME 351! 352!----------------------------------------------------- 353! Calculate (3)D 354!----------------------------------------------------- 355! 356 IF (.NOT. CC2) THEN 357! 358 DTIME = SECOND() 359! 360 FACTD = ONE 361 ICON = 5 362 IV = 1 363! 364 CALL CCRHS_D3(WORK(KXINT),WORK(KDSRHF),DUMMY, 365 * WORK(KT2AM),ISYMTR,WORK(KLAMDP),DUMMY, 366 * WORK(KLAMDH),WORK(KLAMDP),ISYMTR, 367 * WORK(KLAMDH),ISYMTR, 368 * DUMMY,WORK(KEND4),LWRK4,IDEL, 369 * ISYMD,FACTD,ICON,LUDTIM,DTFIL,IV) 370! 371 DTIME = SECOND() - DTIME 372 TIMDM = TIMDM + DTIME 373! 374 ENDIF 375! 376 120 CONTINUE 377 110 CONTINUE 378 100 CONTINUE 379! 380!-------------------- 381! Times 382!-------------------- 383! 384 TIMALL = SECOND() - TIMALL 385 IF ( IPRINT .GT. 2) THEN 386 WRITE(LUPRI,9999) 'RHSN3 - TOT.', TIMALL 387 ENDIF 388 IF (IPRINT .GT. 9) THEN 389 WRITE(LUPRI,9999) 'CCRHS_D3 ', TIMDM 390 WRITE(LUPRI,9999) 'HERDIS1 ', TIMHER1 391 WRITE(LUPRI,9999) 'HERDIS2 ', TIMHER2 392 WRITE(LUPRI,9999) 'CCRHS_LAM ', TIMLAM 393 WRITE(LUPRI,9999) 'CCRHS_RDAO ', TIMRDAO 394 ENDIF 3959999 FORMAT(7x,'Time used in',2x,A12,2x,': ',f10.2,' seconds') 396! 397!----------------- 398! Close files. 399!----------------- 400! 401 CALL WCLOSE2(LUDTIM,DTFIL,'KEEP') 402 CALL WCLOSE2(LUCSIM,CSFIL,'KEEP') 403! 404 RETURN 405 END 406