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! /* Deck cc_bf3 */ 20 SUBROUTINE CC_BF3(XINT,OMEGA2,XLAMD1,ISYML1,XLAMD2, 21 * ISYML2,XLAMD3,ISYML3, 22 * SCRM,ISYMM1,SCRM2,ISYMM2,WORK,LWORK, 23 * IDEL,ISYMD,IOPT) 24! 25! Written by Henrik Koch 3-Jan-1994 26! Symmetry by Henrik Koch and Alfredo Sanchez. 18-July-1994 27! Generalized by Asger Halkier and Henrik Koch 19/9 - 1995 28! to handle left-hand-side transformation contribution as well. 29! Righthand generalizations and debugging Ove Christiansen 23-9-1995 30! 31! Ove Christiansen 24-9-1996: Generalization for calculating 32! terms similar to B and F-terms in the transformation 33! of vectors with the F-matrix. 34! 35! Kasper Hald and Christof Haettig 22-2-1999 36! Generalized to calculate the BF-term for the triplet case. 37! 38! Purpose: Calculate B-term and F-term in the orthonormal basis. 39! 40! IOPT equals one for energy-calculations and two or three for 41! response calculations (2 for left trans. and 3 for right trans.) 42! IOPT eq. 4 for F*vector contributions. 43! IOPT equals 5 (Tilde)rhoBF(-) 44! 45! 46! XLAMD1 is always a true lamda matrix whereas XLAMD2 47! is an AO transformed trialvector in the case af a 48! response calculation. 49! 50! 51! 24-9-1996: 52! 53! 54! IF (IOPT .EQ. 2/3) 55! scrm is left/right vector transformed 56! to tci,j(delta): vector general symmetry 57! lambda particle/hole matrix is tot.sym. 58! XLAMD1 is ordinary lambda particle/hole matrix. 59! XLAMD2 is transformed (barred) 60! lambda particle/hole matrix. 61! (XLAMD1(gam,i)*XLAMD2(del,j) 62! +XLAMD2(gam,i)*XLAMD1(del,j)) 63! 64! IF (IOPT .EQ. 5) 65! Triplet minus-intermediate. 66! SCRM is right vector transformed 67! to t(ci,j)(delta) 68! Lambda particle/hole matrix is tot. sym. 69! XLAMD1 is ordinary lambda particle/hole matr. 70! XLAMD2 is the transformed lambda part./hole matr. 71! XLAMD1(gam,i)*XLAMD2(del,j) 72! +XLAMD2(gam,i)*XLAMD1(del,j) 73! 74! IF (IOPT .EQ. 6) 75! Same as IOPT .EQ. 3 except for the fact 76! that the product of PLUS and PLUS 77! (See the routine) is zero. (The T-amplitudes 78! for the (+)triplet case are antisymmetric 79! with respect to the interchange of i and j ) 80! 81! The symmetry input to this routine is somewhat redundant but 82! hopefully logical and flexible: 83! Isymm1 is symmetry of SCRM 84! Isymm2 is symmetry of SCRM2 85! Isyml1 is symmetry of XLAMD1 86! Isyml2 is symmetry of XLAMD2 87! Isyml3 is symmetry of XLAMD3 88! 89 IMPLICIT NONE 90! 91 INTEGER LWORK, ISYMGD, ISYMM1, ISYML1, ISYML2 92 INTEGER KMGD, KMGD2, KEND1, LWRK1, IDEL, ISYMD 93 INTEGER ISYMJ, ISYMCI, ISYMI, ISYMC, ISYMG, ISYMGI, ISYMGJ, ISYMM2 94 INTEGER NVIRC, NBASG, NTOTD, NTOTGI, NTOTG 95 INTEGER KOFF1, KOFF2, KOFF3, IOPT, ISYML3 96! 97#if defined (SYS_CRAY) 98 REAL ZERO, HALF, ONE, TWO, THREEH 99 REAL XINT(*), OMEGA2(*), XLAMD1(*), XLAMD2(*), XLAMD3(*) 100 REAL SCRM(*), SCRM2(*), WORK(LWORK) 101#else 102 DOUBLE PRECISION ZERO, HALF, ONE, TWO, THREEH, FACT 103 DOUBLE PRECISION XINT(*), OMEGA2(*), XLAMD1(*), XLAMD2(*) 104 DOUBLE PRECISION XLAMD3(*), SCRM(*), SCRM2(*), WORK(LWORK) 105#endif 106! 107 PARAMETER(ZERO= 0.0D00, HALF= 0.5D00, ONE= 1.0D00, TWO= 2.0D00, 108 & THREEH = 1.5D0*HALF) 109 DOUBLE PRECISION :: FACT2, FACT3 110! 111#include "priunit.h" 112#include "ccorb.h" 113#include "ccsdsym.h" 114! 115 CALL QENTER('CC_BF3') 116 117 FACT2 = 2.0D0 118 FACT3 =-1.0D0 119! 120!------------------------ 121! Dynamic allocation. 122!------------------------ 123! 124 ISYMGD = MULD2H(ISYMM1,ISYML1) 125! 126 KMGD = 1 127 KEND1 = KMGD + NT2BGD(ISYMGD) 128 LWRK1 = LWORK - KEND1 129 130 IF (IOPT .EQ. 2) THEN 131 KMGD2 = KEND1 132 KEND1 = KMGD2 + NT2BGD(ISYMGD) 133 LWRK1 = LWORK - KEND1 134 END IF 135! 136 IF (LWRK1 .LT. 0) THEN 137 WRITE(LUPRI,*) 'Need : ',KEND1,'Available : ',LWORK 138 CALL QUIT('Insufficient space in CC_BF3') 139 ENDIF 140! 141 D = IDEL - IBAS(ISYMD) 142 NTOTD = MAX(1,NBAS(ISYMD)) 143! 144!----------------------------- 145! Prepare the data arrays. 146!----------------------------- 147! 148 DO 100 ISYMJ = 1,NSYM 149! 150 ISYMCI = MULD2H(ISYMJ,ISYMM1) 151! 152 DO 110 ISYMI = 1,NSYM 153! 154 ISYMC = MULD2H(ISYMI,ISYMCI) 155 ISYMG = MULD2H(ISYMC,ISYML1) 156 ISYMGI = MULD2H(ISYMG,ISYMI) 157! 158 NVIRC = MAX(NVIR(ISYMC),1) 159 NBASG = MAX(NBAS(ISYMG),1) 160! 161 KOFF1 = IGLMVI(ISYMG,ISYMC) + 1 162! 163 DO 120 J = 1,NRHF(ISYMJ) 164! 165 KOFF2 = IT2BCD(ISYMCI,ISYMJ) + IT1AM(ISYMC,ISYMI) 166 * + NT1AM(ISYMCI)*(J - 1) + 1 167 KOFF3 = IT2BGD(ISYMGI,ISYMJ) + IT1AO(ISYMG,ISYMI) 168 * + NT1AO(ISYMGI)*(J - 1) + 1 169! 170 CALL DGEMM('N','N',NBAS(ISYMG),NRHF(ISYMI),NVIR(ISYMC), 171 * ONE,XLAMD1(KOFF1),NBASG,SCRM(KOFF2),NVIRC, 172 * ZERO,WORK(KOFF3),NBASG) 173! 174 120 CONTINUE 175! 176 110 CONTINUE 177 178 ISYMGI = MULD2H(ISYMCI,ISYML1) 179C L(gamma,i)*C(delta,j) 180 IF ((IOPT .EQ.2) .AND. (ISYMGI .EQ. ISYML2)) THEN 181 KOFF1 = 1 182 KOFF2 = IGLMRH(ISYMD,ISYMJ) + D 183 KOFF3 = IT2BGD(ISYMGI,ISYMJ) + 1 184 NTOTGI = MAX(1,NT1AO(ISYMGI)) 185 CALL DGER(NT1AO(ISYMGI),NRHF(ISYMJ),FACT2, 186 & XLAMD2,1,XLAMD1(KOFF2),NTOTD, 187 & WORK(KOFF3),NTOTGI) 188 END IF 189C 190 IF (IOPT.EQ.2) THEN 191C C(gamma,j)*L(delta,i) 192 ISYMI = MULD2H(ISYML2,ISYMD) 193 ISYMG = MULD2H(ISYMGI,ISYMI) 194 NTOTG = MAX(1,NBAS(ISYMG)) 195 DO J = 1, NRHF(ISYMJ) 196 KOFF1 = IGLMRH(ISYMG,ISYMJ) 197 & + NBAS(ISYMG)*(J-1) + 1 198 KOFF2 = IGLMRH(ISYMD,ISYMI) + D 199 KOFF3 = IT2BGD(ISYMGI,ISYMJ) 200 & + NT1AO(ISYMGI)*(J-1) 201 & + IT1AO(ISYMG,ISYMI) + 1 202 CALL DGER(NBAS(ISYMG),NRHF(ISYMI),FACT3, 203 & XLAMD1(KOFF1),1,XLAMD2(KOFF2),NTOTD, 204 & WORK(KOFF3),NTOTG) 205 END DO 206C 207C L(gamma,j)*C(delta,i) 208 ISYMI = MULD2H(ISYML1,ISYMD) 209 ISYMG = MULD2H(ISYMGI,ISYMI) 210 NTOTG = MAX(1,NBAS(ISYMG)) 211 DO J = 1, NRHF(ISYMJ) 212 KOFF1 = IGLMRH(ISYMG,ISYMJ) 213 & + NBAS(ISYMG)*(J-1) + 1 214 KOFF2 = IGLMRH(ISYMD,ISYMI) + D 215 KOFF3 = IT2BGD(ISYMGI,ISYMJ) 216 & + NT1AO(ISYMGI)*(J-1) 217 & + IT1AO(ISYMG,ISYMI) + 1 218 CALL DGER(NBAS(ISYMG),NRHF(ISYMI),FACT3, 219 & XLAMD2(KOFF1),1,XLAMD1(KOFF2),NTOTD, 220 & WORK(KOFF3),NTOTG) 221 END DO 222C 223 END IF 224! 225 100 CONTINUE 226! 227 IF (IOPT .EQ. 2) THEN 228! 229 DO ISYMJ = 1,NSYM 230! 231 ISYMCI = MULD2H(ISYMJ,ISYMM1) 232! 233 DO ISYMI = 1,NSYM 234! 235 ISYMC = MULD2H(ISYMI,ISYMCI) 236 ISYMG = MULD2H(ISYMC,ISYML1) 237 ISYMGI = MULD2H(ISYMG,ISYMI) 238! 239 NVIRC = MAX(NVIR(ISYMC),1) 240 NBASG = MAX(NBAS(ISYMG),1) 241! 242 KOFF1 = IGLMVI(ISYMG,ISYMC) + 1 243! 244 DO J = 1,NRHF(ISYMJ) 245! 246 KOFF2 = IT2BCD(ISYMCI,ISYMJ) + IT1AM(ISYMC,ISYMI) 247 * + NT1AM(ISYMCI)*(J - 1) + 1 248 KOFF3 = IT2BGD(ISYMGI,ISYMJ) + IT1AO(ISYMG,ISYMI) 249 * + NT1AO(ISYMGI)*(J - 1) + KMGD2 250! 251 CALL DGEMM('N','N',NBAS(ISYMG),NRHF(ISYMI), 252 & NVIR(ISYMC), 253 * ONE,XLAMD1(KOFF1),NBASG,SCRM2(KOFF2),NVIRC, 254 * ZERO,WORK(KOFF3),NBASG) 255 END DO 256C 257 END DO 258 ISYMGI = MULD2H(ISYMCI,ISYML1) 259C C(gamma,i)*L(delta,j) 260 IF ((IOPT .EQ.2) .AND. (ISYMGI .EQ. ISYML1)) THEN 261 KOFF1 = 1 262 KOFF2 = IGLMRH(ISYMD,ISYMJ) + D 263 KOFF3 = IT2BGD(ISYMGI,ISYMJ) + KMGD2 264 NTOTGI = MAX(1,NT1AO(ISYMGI)) 265 CALL DGER(NT1AO(ISYMGI),NRHF(ISYMJ),FACT2, 266 & XLAMD1,1,XLAMD2(KOFF2),NTOTD, 267 & WORK(KOFF3),NTOTGI) 268 END IF 269C 270 IF (IOPT.EQ.2) THEN 271C C(gamma,j)*L(delta,i) 272 ISYMI = MULD2H(ISYML2,ISYMD) 273 ISYMG = MULD2H(ISYMGI,ISYMI) 274 NTOTG = MAX(1,NBAS(ISYMG)) 275 DO J = 1, NRHF(ISYMJ) 276 KOFF1 = IGLMRH(ISYMG,ISYMJ) 277 & + NBAS(ISYMG)*(J-1) + 1 278 KOFF2 = IGLMRH(ISYMD,ISYMI) + D 279 KOFF3 = IT2BGD(ISYMGI,ISYMJ) 280 & + NT1AO(ISYMGI)*(J-1) 281 & + IT1AO(ISYMG,ISYMI) + KMGD2 282 CALL DGER(NBAS(ISYMG),NRHF(ISYMI),FACT3, 283 & XLAMD1(KOFF1),1,XLAMD2(KOFF2),NTOTD, 284 & WORK(KOFF3),NTOTG) 285 END DO 286C 287C L(gamma,j)*C(delta,i) 288 ISYMI = MULD2H(ISYML1,ISYMD) 289 ISYMG = MULD2H(ISYMGI,ISYMI) 290 NTOTG = MAX(1,NBAS(ISYMG)) 291 DO J = 1, NRHF(ISYMJ) 292 KOFF1 = IGLMRH(ISYMG,ISYMJ) 293 & + NBAS(ISYMG)*(J-1) + 1 294 KOFF2 = IGLMRH(ISYMD,ISYMI) + D 295 KOFF3 = IT2BGD(ISYMGI,ISYMJ) 296 & + NT1AO(ISYMGI)*(J-1) 297 & + IT1AO(ISYMG,ISYMI) + KMGD2 298 CALL DGER(NBAS(ISYMG),NRHF(ISYMI),FACT3, 299 & XLAMD2(KOFF1),1,XLAMD1(KOFF2),NTOTD, 300 & WORK(KOFF3),NTOTG) 301C 302 END DO 303 END IF 304! 305 END DO !ISYMJ 306 END IF 307! 308!--------------------------------------------------------- 309! Calculate extra contribution to T2 double AO transf. 310! if F-matrix transformation. 311!--------------------------------------------------------- 312! 313 IF (IOPT .EQ. 4) THEN 314! 315 IF (MULD2H(ISYML3,ISYMM2).NE.ISYMGD) THEN 316 CALL QUIT('CC_BF: Symmetry mismatch') 317 ENDIF 318 DO 200 ISYMJ = 1,NSYM 319! 320 ISYMCI = MULD2H(ISYMJ,ISYMM2) 321! 322 DO 210 ISYMI = 1,NSYM 323! 324 ISYMC = MULD2H(ISYMI,ISYMCI) 325 ISYMG = MULD2H(ISYMC,ISYML3) 326 ISYMGI = MULD2H(ISYMG,ISYMI) 327! 328 NVIRC = MAX(NVIR(ISYMC),1) 329 NBASG = MAX(NBAS(ISYMG),1) 330! 331 KOFF1 = IGLMVI(ISYMG,ISYMC) + 1 332! 333 DO 220 J = 1,NRHF(ISYMJ) 334! 335 KOFF2 = IT2BCD(ISYMCI,ISYMJ) + IT1AM(ISYMC,ISYMI) 336 * + NT1AM(ISYMCI)*(J - 1) + 1 337 KOFF3 = IT2BGD(ISYMGI,ISYMJ) + IT1AO(ISYMG,ISYMI) 338 * + NT1AO(ISYMGI)*(J - 1) + 1 339! 340 CALL DGEMM('N','N',NBAS(ISYMG),NRHF(ISYMI),NVIR(ISYMC) 341 * ,ONE,XLAMD3(KOFF1),NBASG,SCRM2(KOFF2),NVIRC, 342 * ONE,WORK(KOFF3),NBASG) 343! 344 220 CONTINUE 345! 346 210 CONTINUE 347! 348 200 CONTINUE 349! 350 ENDIF 351! 352!-------------------------------- 353! Calculate the contribution. 354!-------------------------------- 355! 356 CALL CC_BF31(XINT,OMEGA2,WORK(KMGD),WORK(KMGD2),ISYMGD, 357 * XLAMD1,ISYML1, 358 * XLAMD2,ISYML2,WORK(KEND1),LWRK1, 359 * IDEL,ISYMD,IOPT) 360! 361 CALL QEXIT('CC_BF3') 362! 363 RETURN 364 END 365C /* Deck cc_bf3_1 */ 366 SUBROUTINE CC_BF31(XINT,OMEGA2,XMGD,XMGD2,ISYMGD,XLAMD1,ISYML1, 367 * XLAMD2,ISYML2,WORK,LWORK, 368 * IDEL,ISYMD,IOPT) 369! 370! Written by Henrik Koch 3-Jan-1994 371! 372! Purpose: Calculate B-term. 373! 374! See CC_BF for more info. 375! 376 IMPLICIT NONE 377! 378#include "priunit.h" 379#include "iratdef.h" 380#include "ccorb.h" 381#include "ccsdsym.h" 382#include "ccsdinp.h" 383! 384 INTEGER LWORK, INDEX, ISYDIS, ISYMD, ISYRES, ISYMGD, ISYCH 385 INTEGER ISYML2, ISYML1, ISYMIJ, ISYMAB, ISYMG, IDEL, KSCRAB 386 INTEGER KINDV1, KINDV2, KEND1, LWRK1, NSIZE, IMAXG, NMAXG 387 INTEGER NBATCH, IBATCH, NUMG, IG1, IG2, KINTP, KINTM 388 INTEGER KT2MP, KT2MM, KEND2, LWRK2 389 INTEGER IOPT, ISHELP, KOFF, KOFF1, KOFF2, NUMGM, NTOTAB 390 INTEGER LT2MM 391! 392#if defined (SYS_CRAY) 393 REAL ZERO, HALF, ONE, FOURTH, TWO, THREE 394 REAL XTWO, XHALF, XONE, FACT 395 REAL XINT(*), OMEGA2(*), XMGD(*), XMGD2(*),XLAMD1(*), XLAMD2(*) 396 REAL WORK(LWORK) 397#else 398 DOUBLE PRECISION ZERO, HALF, ONE, FOURTH, TWO 399 DOUBLE PRECISION THREE, XTWO, XHALF, XONE, FACT 400 DOUBLE PRECISION XINT(*), OMEGA2(*), XMGD(*), XMGD2(*),XLAMD1(*) 401 DOUBLE PRECISION XLAMD2(*), WORK(LWORK) 402#endif 403 PARAMETER(ZERO = 0.0D00, HALF = 0.5D00, ONE = 1.0D00) 404 PARAMETER(FOURTH = 0.25D00, TWO = 2.0D00, THREE = 3.0D00) 405 PARAMETER(XTWO = -2.0D00, XHALF= -0.5D00, XONE= -1.0D00) 406! 407 INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J 408! 409 CALL QENTER('CC_BF31') 410! 411 ISYDIS = MULD2H(ISYMOP,ISYMD) 412 ISYRES = MULD2H(ISYDIS,ISYMGD) 413 ISYCH = MULD2H(ISYML2,ISYMD) 414! 415 IF (ISYML1 .NE. 1) 416 & CALL QUIT('CC_BF3: Symmetry of XLAMD1 must be 1') 417 IF (ISYML2 .NE. MULD2H(ISYMGD,ISYMD)) 418 * CALL QUIT('Symmetry mismatch in CC_BF3_1') 419! 420!================================ 421! Calculate the contribution. 422!================================ 423! 424 DO 100 ISYMIJ = 1 , NSYM 425C 426 ISYMAB = MULD2H(ISYMIJ,ISYRES) 427 ISYMG = MULD2H(ISYMAB,ISYDIS) 428 D = IDEL - IBAS(ISYMD) 429C 430 KSCRAB = 1 431 KINDV1 = KSCRAB + N2BST(ISYMAB) 432 KINDV2 = KINDV1 + (NNBST(ISYMAB) - 1)/IRAT + 1 433 KEND1 = KINDV2 + (NNBST(ISYMAB) - 1)/IRAT + 1 434 LWRK1 = LWORK - KEND1 435C 436 IF (LWRK1 .LT. 0) THEN 437 CALL QUIT('Insufficient space in CC_BF3_1') 438 ENDIF 439C 440C-------------------------------- 441C Calculate index vectors. 442C-------------------------------- 443C 444 CALL CCSD_INDEX(WORK(KINDV1),WORK(KINDV2),ISYMAB) 445C 446C------------------------------ 447C Work space allocation. 448C------------------------------ 449C 450 IF (IOPT.EQ.2) THEN 451 NSIZE = 2*NNBST(ISYMAB) + NMIJP(ISYMIJ) + NMATIJ(ISYMIJ) 452 ELSE 453 NSIZE = 2*(NNBST(ISYMAB) + NMIJP(ISYMIJ)) 454 END IF 455C 456 IF ((NNBST(ISYMAB) .EQ. 0) .OR. 457 * (NMIJP(ISYMIJ) .EQ. 0)) GOTO 100 458C 459 IF (ISYMG .EQ. ISYMD) THEN 460 IMAXG = D 461 ELSE IF (ISYMG .LT. ISYMD) THEN 462 IMAXG = NBAS(ISYMG) 463 ELSE 464 GOTO 100 465 ENDIF 466C 467 IF (IMAXG.EQ.0) GOTO 100 468C 469 IF (LWRK1.LT.NSIZE) THEN 470 CALL QUIT('Insufficient memory in CC_BF1.') 471 END IF 472C 473 NMAXG = MIN(IMAXG,LWRK1/NSIZE) 474 NBATCH = (IMAXG - 1)/NMAXG + 1 475C 476 DO 110 IBATCH = 1 , NBATCH 477C 478 NUMG = NMAXG 479 IF (IBATCH .EQ. NBATCH) THEN 480 NUMG = IMAXG - NMAXG*(NBATCH - 1) 481 ENDIF 482C 483 IG1 = NMAXG*(IBATCH - 1) + 1 484 IG2 = NMAXG*(IBATCH - 1) + NUMG 485C 486 IF (IOPT.EQ.2) THEN 487 LT2MM = NUMG*NMATIJ(ISYMIJ) 488 ELSE 489 LT2MM = NUMG*NMIJP(ISYMIJ) 490 END IF 491C 492 KINTP = KEND1 493 KINTM = KINTP + NNBST(ISYMAB)*NUMG 494 KT2MP = KINTM + NNBST(ISYMAB)*NUMG 495 KT2MM = KT2MP + NUMG*NMIJP(ISYMIJ) 496 KEND2 = KT2MM + LT2MM 497 LWRK2 = LWORK - KEND2 498C 499 IF (LWRK2 .LT. 0) THEN 500 CALL QUIT('Insufficient space in CC_BF31') 501 ENDIF 502C 503C----------------------------------- 504C Construct T2MP and T2MM. 505C----------------------------------- 506C 507 IF (IOPT.NE.2) THEN 508 CALL CC_T2MP_T2MM() 509 ELSE 510 CALL CC_T2MP_T2MM3(XMGD,XMGD2,WORK(KT2MP),WORK(KT2MM), 511 & ISYMIJ,ISYMG,NUMG,IG1) 512 ENDIF 513 514C 515C----------------------------------- 516C Construct INTP and INTM. 517C----------------------------------- 518C 519 CALL CCRHS_IPM(XINT,WORK(KINTP),WORK(KINTM),WORK(KSCRAB), 520 * WORK(KINDV1),WORK(KINDV2),ISYMAB,ISYMG, 521 * NUMG,IG1,IG2) 522C 523C------------------------------- 524C Scale the diagonals. 525C------------------------------- 526C 527 IF ((ISYMG .EQ. ISYMD) .AND. (IBATCH .EQ. NBATCH)) THEN 528 KOFF = KINTP + NNBST(ISYMAB)*(NUMG - 1) 529 CALL DSCAL(NNBST(ISYMAB),HALF,WORK(KOFF),1) 530 ENDIF 531C 532C---------------------------------------- 533C Add the B-term contributions. 534C---------------------------------------- 535C 536 NUMGM = MAX(NUMG,1) 537 NTOTAB = MAX(NNBST(ISYMAB),1) 538C 539 IF (IOPT.EQ.2) THEN 540 KOFF1 = IT2ORT(ISYMAB,ISYMIJ) + 1 541 KOFF2 = NT2ORT(ISYRES) + IT2ORT3(ISYMAB,ISYMIJ) + 1 542 543 CALL DGEMM('N','N',NNBST(ISYMAB),NMIJP(ISYMIJ),NUMG, 544 * ONE,WORK(KINTP),NTOTAB,WORK(KT2MP),NUMGM, 545 * ONE,OMEGA2(KOFF1),NTOTAB) 546 547 CALL DGEMM('N','N',NNBST(ISYMAB),NMATIJ(ISYMIJ),NUMG, 548 * ONE,WORK(KINTM),NTOTAB,WORK(KT2MM),NUMGM, 549 * ONE,OMEGA2(KOFF2),NTOTAB) 550 551 ELSE IF (.NOT. (IOPT .EQ. 5)) THEN 552! 553 KOFF = IT2ORT(ISYMAB,ISYMIJ) + 1 554! 555 CALL DGEMM('N','N',NNBST(ISYMAB),NMIJP(ISYMIJ),NUMG, 556 * ONE,WORK(KINTM),NTOTAB,WORK(KT2MM),NUMGM, 557 * ONE,OMEGA2(KOFF),NTOTAB) 558! 559 ELSE 560 KOFF1 = IT2ORT(ISYMAB,ISYMIJ) + 1 561! 562 CALL DGEMM('N','N',NNBST(ISYMAB),NMIJP(ISYMIJ),NUMG, 563 * ONE,WORK(KINTM),NTOTAB,WORK(KT2MP),NUMGM, 564 * ONE,OMEGA2(KOFF1),NTOTAB) 565! 566 KOFF2 = NT2ORT(ISYRES) + IT2ORT(ISYMAB,ISYMIJ) + 1 567! 568 CALL DGEMM('N','N',NNBST(ISYMAB),NMIJP(ISYMIJ),NUMG, 569 * ONE,WORK(KINTP),NTOTAB,WORK(KT2MM),NUMGM, 570 * ONE,OMEGA2(KOFF2),NTOTAB) 571! 572 END IF 573 110 CONTINUE 574! 575 100 CONTINUE 576! 577 CALL QEXIT('CC_BF31') 578! 579 RETURN 580 CONTAINS 581 SUBROUTINE CC_T2MP_T2MM() 582C------------------------------------------------------- 583C Creates the plus and minus versions of 584C the back transformed plus and minus vectors 585C------------------------------------------------------- 586 587 INTEGER :: NGIJ, NGJI, NTOTI, NIJ, NGIJPM 588 INTEGER :: KOFFP, KOFFM, KOFF1, KOFF2, ISHELP 589 INTEGER :: ISYMI, ISYMJ, ISYMGI, ISYMGJ 590 INTEGER :: I,J 591 DOUBLE PRECISION :: FACT 592 593 DO 200 ISYMJ = 1 , NSYM 594C 595 ISYMI = MULD2H(ISYMJ,ISYMIJ) 596 ISYMGI = MULD2H(ISYMI,ISYMG) 597 ISYMGJ = MULD2H(ISYMJ,ISYMG) 598C 599 IF (ISYMI .GT. ISYMJ) GOTO 200 600C 601 NTOTI = NRHF(ISYMI) 602C 603 DO 210 J = 1 , NRHF(ISYMJ) 604C 605 IF (ISYMI .EQ. ISYMJ) NTOTI = J 606C 607 DO 220 I = 1,NTOTI 608C 609 NGIJ = IT2BGD(ISYMGI,ISYMJ) 610 * + NT1AO(ISYMGI)*(J - 1) 611 * + IT1AO(ISYMG,ISYMI) 612 * + NBAS(ISYMG)*(I - 1) + IG1 613C 614 NGJI = IT2BGD(ISYMGJ,ISYMI) 615 * + NT1AO(ISYMGJ)*(I - 1) 616 * + IT1AO(ISYMG,ISYMJ) 617 * + NBAS(ISYMG)*(J - 1) + IG1 618C 619 IF (ISYMI .EQ. ISYMJ) THEN 620 NIJ = IMIJP(ISYMI,ISYMJ) + INDEX(I,J) 621 ELSE 622 NIJ = IMIJP(ISYMI,ISYMJ) 623 * + NRHF(ISYMI)*(J - 1) + I 624 ENDIF 625C 626 NGIJPM = NUMG*(NIJ - 1) 627C 628 KOFFP = KT2MP + NGIJPM 629 KOFFM = KT2MM + NGIJPM 630C 631C 632 IF (IOPT .NE. 6) THEN 633 CALL DCOPY(NUMG,XMGD(NGIJ),1,WORK(KOFFP),1) 634 ENDIF 635! 636 CALL DCOPY(NUMG,XMGD(NGIJ),1,WORK(KOFFM),1) 637C 638 IF (IOPT .NE. 6) THEN 639 CALL DAXPY(NUMG,ONE,XMGD(NGJI),1,WORK(KOFFP),1) 640 ENDIF 641! 642 CALL DAXPY(NUMG,-ONE,XMGD(NGJI),1,WORK(KOFFM),1) 643! 644C 645C------------------------------------------------- 646C Add the F-term contributions. 647C------------------------------------------------- 648C 649 FACT = ONE 650C 651 IF ((IOPT .EQ. 2) .OR. (IOPT .EQ. 4)) THEN 652 FACT = THREE 653 ENDIF 654C 655 IF ((ISYMJ .EQ. ISYCH).AND.(ISYMI .EQ. ISYMG)) THEN 656C 657 KOFF1 = IGLMRH(ISYMD,ISYMJ) 658 & + NBAS(ISYMD)*(J - 1) + D 659 KOFF2 = ILMRHF(ISYMI) + NBAS(ISYMG)*(I - 1) +IG1 660C 661 IF (IOPT .EQ. 5) THEN 662! 663 CALL DAXPY(NUMG,XHALF*XLAMD2(KOFF1), 664 * XLAMD1(KOFF2),1,WORK(KOFFP),1) 665 CALL DAXPY(NUMG,XHALF*XLAMD2(KOFF1), 666 & XLAMD1(KOFF2),1,WORK(KOFFM),1) 667 ELSE 668! 669 IF (IOPT .NE. 6) THEN 670 CALL DAXPY(NUMG,XLAMD2(KOFF1),XLAMD1(KOFF2), 671 & 1,WORK(KOFFP),1) 672 ENDIF 673! 674 CALL DAXPY(NUMG,FACT*XLAMD2(KOFF1), 675 & XLAMD1(KOFF2),1,WORK(KOFFM),1) 676! 677 ENDIF 678C 679 ENDIF 680C 681 IF ((ISYMI .EQ. ISYCH).AND.(ISYMJ .EQ. ISYMG)) THEN 682C 683 KOFF1 = IGLMRH(ISYMD,ISYMI) 684 & + NBAS(ISYMD)*(I - 1) + D 685 KOFF2 = ILMRHF(ISYMJ) + NBAS(ISYMG)*(J - 1) +IG1 686C 687 IF (IOPT .EQ. 5) THEN 688! 689 CALL DAXPY(NUMG,XHALF*XLAMD2(KOFF1), 690 * XLAMD1(KOFF2),1,WORK(KOFFP),1) 691 CALL DAXPY(NUMG,HALF*XLAMD2(KOFF1), 692 * XLAMD1(KOFF2),1,WORK(KOFFM),1) 693! 694 ELSE 695! 696 IF (IOPT .NE. 6) THEN 697 CALL DAXPY(NUMG,XLAMD2(KOFF1),XLAMD1(KOFF2), 698 * 1,WORK(KOFFP),1) 699 ENDIF 700! 701 CALL DAXPY(NUMG,-FACT*XLAMD2(KOFF1), 702 * XLAMD1(KOFF2),1,WORK(KOFFM),1) 703C 704 ENDIF 705! 706 ENDIF 707C 708C--------------------------------------------------------------------- 709C For response calculation add permuted terms. 710C--------------------------------------------------------------------- 711C 712 IF (IOPT .GE. 2) THEN 713C 714 ISHELP = MULD2H(ISYMG,ISYML2) 715C 716 IF ((IOPT .EQ. 2) .OR. (IOPT .EQ. 4)) THEN 717 FACT = THREE 718 ENDIF 719C 720 IF ((ISYMJ .EQ. ISYMD) .AND. 721 & (ISYMI .EQ. ISHELP)) THEN 722C 723 KOFF1 = ILMRHF(ISYMJ) 724 & + NBAS(ISYMD)*(J - 1) + D 725 KOFF2 = IGLMRH(ISYMG,ISYMI) 726 & + NBAS(ISYMG)*(I - 1) +IG1 727C 728 IF (IOPT .EQ. 5) THEN 729C 730 CALL DAXPY(NUMG,HALF*XLAMD1(KOFF1), 731 & XLAMD2(KOFF2),1,WORK(KOFFP),1) 732 CALL DAXPY(NUMG,HALF*XLAMD1(KOFF1), 733 & XLAMD2(KOFF2),1,WORK(KOFFM),1) 734C 735 ELSE 736C 737 IF (IOPT .NE. 6) THEN 738 CALL DAXPY(NUMG,XLAMD1(KOFF1), 739 & XLAMD2(KOFF2),1,WORK(KOFFP),1) 740 ENDIF 741! 742 CALL DAXPY(NUMG,FACT*XLAMD1(KOFF1), 743 & XLAMD2(KOFF2),1,WORK(KOFFM),1) 744C 745 ENDIF 746C 747 ENDIF 748C 749 IF ((ISYMI .EQ. ISYMD) .AND. 750 & (ISYMJ .EQ. ISHELP)) THEN 751C 752 KOFF1 = ILMRHF(ISYMI) 753 & + NBAS(ISYMD)*(I - 1) + D 754 KOFF2 = IGLMRH(ISYMG,ISYMJ) 755 & + NBAS(ISYMG)*(J - 1) + IG1 756C 757 IF (IOPT .EQ. 5) THEN 758C 759 CALL DAXPY(NUMG,HALF*XLAMD1(KOFF1), 760 & XLAMD2(KOFF2),1,WORK(KOFFP),1) 761 CALL DAXPY(NUMG,XHALF*XLAMD1(KOFF1), 762 & XLAMD2(KOFF2),1,WORK(KOFFM),1) 763C 764 ELSE 765C 766 IF (IOPT .NE. 6) THEN 767 CALL DAXPY(NUMG,XLAMD1(KOFF1), 768 & XLAMD2(KOFF2),1,WORK(KOFFP),1) 769 ENDIF 770! 771 CALL DAXPY(NUMG,-FACT*XLAMD1(KOFF1), 772 & XLAMD2(KOFF2),1,WORK(KOFFM),1) 773C 774 ENDIF 775C 776 ENDIF 777C 778 ENDIF 779C 780 220 CONTINUE 781C 782 210 CONTINUE 783C 784 200 CONTINUE 785 END SUBROUTINE 786 787 SUBROUTINE CC_T2MP_T2MM3(XMGD,XMGD2,T2P,T2M, 788 & ISYMIJ,ISYMG,NUMG,IG1) 789C------------------------------------------------------- 790C Creates the plus and minus versions of 791C the back transformed plus and minus vectors 792C In the case that + and - triplets are treated 793C simultaniously. 794C------------------------------------------------------- 795 796 DOUBLE PRECISION, INTENT(IN) :: XMGD(*), XMGD2(*) 797 DOUBLE PRECISION, INTENT(OUT):: T2P(*), T2M(*) 798 INTEGER, INTENT(IN) :: ISYMG, ISYMIJ, NUMG, IG1 799 800 INTEGER :: IGIJ, IGJI 801 INTEGER :: NGIJ, NGJI, NTOTI 802 INTEGER :: NIJT, NIJS, NJIS, NG 803 INTEGER :: KOFFP, KOFFM1, KOFFM2, ISHELP 804 INTEGER :: ISYMI, ISYMJ, ISYMGI, ISYMGJ 805 INTEGER :: I, J 806C 807 DOUBLE PRECISION :: FACT1, FACT2 808 809 DO 200 ISYMJ = 1 , NSYM 810C 811 ISYMI = MULD2H(ISYMJ,ISYMIJ) 812 ISYMGI = MULD2H(ISYMI,ISYMG) 813 ISYMGJ = MULD2H(ISYMJ,ISYMG) 814C 815 IF (ISYMI .GT. ISYMJ) GOTO 200 816C 817 NTOTI = NRHF(ISYMI) 818C 819 DO 210 J = 1 , NRHF(ISYMJ) 820C 821 IF (ISYMI .EQ. ISYMJ) NTOTI = J 822C 823 DO 220 I = 1, NTOTI 824C 825 IGIJ = IT2BGD(ISYMGI,ISYMJ) 826 * + NT1AO(ISYMGI)*(J - 1) 827 * + IT1AO(ISYMG,ISYMI) 828 * + NBAS(ISYMG)*(I - 1) + IG1 - 1 829C 830 IGJI = IT2BGD(ISYMGJ,ISYMI) 831 * + NT1AO(ISYMGJ)*(I - 1) 832 * + IT1AO(ISYMG,ISYMJ) 833 * + NBAS(ISYMG)*(J - 1) + IG1 - 1 834C 835 IF (ISYMI .EQ. ISYMJ) THEN 836 NIJT = IMIJP(ISYMI,ISYMJ) + J*(J-1)/2 + I 837 ELSE 838 NIJT = IMIJP(ISYMI,ISYMJ) 839 * + NRHF(ISYMI)*(J - 1) + I 840 ENDIF 841 842 NIJS = IMATIJ(ISYMI,ISYMJ) + NRHF(ISYMI)*(J-1) + I 843 NJIS = IMATIJ(ISYMJ,ISYMI) + NRHF(ISYMJ)*(I-1) + J 844C 845 KOFFP = NUMG*(NIJT-1) 846 KOFFM1 = NUMG*(NIJS-1) 847 KOFFM2 = NUMG*(NJIS-1) 848C 849 DO NG = 1, NUMG 850 NGIJ = IGIJ + NG 851 NGJI = IGJI + NG 852 T2P(KOFFP+NG) = XMGD(NGIJ) + XMGD2(NGJI) 853 T2M(KOFFM1+NG) = XMGD(NGIJ) - XMGD2(NGJI) 854 END DO 855C 856 IF ( IGIJ .NE. IGJI ) THEN 857 DO NG = 1, NUMG 858 NGIJ = IGIJ + NG 859 NGJI = IGJI + NG 860 T2M(KOFFM2+NG) = XMGD(NGJI) - XMGD2(NGIJ) 861 END DO 862 END IF 863C 864C 865 220 CONTINUE 866C 867 210 CONTINUE 868C 869 200 CONTINUE 870 END SUBROUTINE 871 872 END 873C /* Deck ccrhs_d3 */ 874 SUBROUTINE CCRHS_D3(XINT,DSRHF,OMEGA2,T2AM,ISYMT2, 875 * XLAMDP,XLAMIP,XLAMDH, 876 * XLAMPC,ISYMPC,XLAMHC,ISYMHC, 877 * SCRM,WORK,LWORK,IDEL,ISYMD,FACTD,ICON, 878 * LUD,DFIL,IV) 879! 880! Written by Henrik Koch 9-Jan-1994 881! 882! Generalisation for CCLR by Ove Christiansen august-september 1995 883! (right transformation) and september 1996 (F-matrix). 884! 885! Generalisation to calculate the D-intermediates for the 886! triplet case by Kasper Hald 17-2-1999 887! 888! Purpose: Calculate D-term. 889! 890 IMPLICIT NONE 891! 892 INTEGER LWORK, ISYDIS, ISYAIK, ISYMPC, ISYMT2, KSCR1, KSCR2 893 INTEGER KSCR3, KEND1, LWRK1, ISYMD, INDEX, ISYMHC, LUD, IV 894 INTEGER KOFF1, ISYML, ISYMA, ISYMG 895 INTEGER NBASA, NBASG, NVIRD, KSCR11, KEND2, LWRK2, KOFF2 896 INTEGER KOFF3, KOFF5, KOFF6, NRHFK, ISYMAI, NTOTDL 897 INTEGER IOFF, IDEL, IERR, ICON 898! 899#if defined (SYS_CRAY) 900 REAL ONE, TWO, FACTD 901 REAL XINT(*), DSRHF(*), OMEGA2(*), WORK(LWORK) 902 REAL XLAMDP(*), XLAMIP(*), XLAMDH(*), SCRM(*) 903 REAL XLAMPC(*), XLAMHC(*), T2AM(*) 904#else 905 DOUBLE PRECISION ONE, TWO, FACTD 906 DOUBLE PRECISION XINT(*), DSRHF(*), OMEGA2(*), WORK(LWORK) 907 DOUBLE PRECISION XLAMDP(*), XLAMIP(*), XLAMDH(*), SCRM(*) 908 DOUBLE PRECISION XLAMPC(*), XLAMHC(*), T2AM(*) 909#endif 910! 911 PARAMETER (ONE = 1.0D00, TWO = 2.0D00) 912 CHARACTER DFIL*(*) 913! 914#include "priunit.h" 915#include "ccorb.h" 916#include "ccsdsym.h" 917#include "ccsdinp.h" 918! 919 CALL QENTER('CCRHS_D3') 920! 921 ISYDIS = MULD2H(ISYMD,ISYMOP) 922 ISYAIK = MULD2H(ISYDIS,ISYMPC) 923 IF (ISYMT2 .NE. ISYMPC) CALL QUIT('Symmetry Mismatch in CCRHS_D3') 924C 925C------------------------ 926C Dynamic allocation. 927C------------------------ 928C 929 KSCR1 = 1 930 KSCR2 = KSCR1 + MAX(NT2BCD(ISYAIK),NT2BCD(ISYDIS)) 931 KSCR3 = KSCR2 + NT2BGD(ISYDIS) 932 IF (ICON .EQ. 2) THEN 933 KEND1 = KSCR3 + NT2BGD(ISYMD) 934 ELSE IF (ICON .EQ.5) THEN 935 KEND1 = KSCR3 + MAX(NT2BGD(ISYMD),NT2BCD(ISYAIK), 936 * NT2BCD(ISYDIS)) 937 ELSE 938 KEND1 = KSCR3 + NT2BGD(ISYAIK) 939 ENDIF 940 LWRK1 = LWORK - KEND1 941C 942 IF (LWRK1 .LT. 0) THEN 943 WRITE(LUPRI,*) 'Need : ',KEND1,'Available : ',LWORK 944 CALL QUIT('Insufficient space in CCRHS_D3') 945 ENDIF 946C 947C-------------------------------- 948C Calculate the contribution. 949C-------------------------------- 950C 951 CALL CCRHS_D31(XINT,DSRHF,OMEGA2,T2AM,ISYMT2, 952 * SCRM,WORK(KSCR1),WORK(KSCR2), 953 * WORK(KSCR3),XLAMDP,XLAMIP, 954 * XLAMDH,XLAMPC,ISYMPC,XLAMHC,ISYMHC, 955 * WORK(KEND1),LWRK1,ISYDIS,IDEL, 956 * ISYMD,FACTD,ICON,LUD,DFIL,IV) 957C 958 CALL QEXIT('CCRHS_D3') 959C 960 RETURN 961 END 962 SUBROUTINE CCRHS_D31(XINT,DSRHF,OMEGA2,T2AM,ISYMT2, 963 * SCRM,SCR1,SCR2,SCR3, 964 * XLAMDP,XLAMIP,XLAMDH,XLAMPC,ISYMPC,XLAMHC, 965 * ISYMHC,WORK,LWORK,ISYDIS,IDEL,ISYDEL,FACTD, 966 * ICON,LUD,DFIL,IV) 967C 968C Written by Henrik Koch 3-Jan-1994 969C 970C Modification by Ove Christiansen 25-7-1995 to allow for a 971C general factor (FACTD). NB: Assumes DUMCD. 972C - calculate intermediates for CCLR. 973C 974C 29-9-1995 (17-9-1996 F-matrix.) Ove Christiansen: 975C 976C 1. If Icon = 2 both contributions are calculated, 977C for total sym. case. Otherwise 978C a.ICON = 1 only the integral Laikc(del) 979C = La-bar,i,k,c + La,i-bar,k,c 980C for Jacobian right transformation 981C b.ICON = 3 982C La-bar,i,k,c + La,i-bar,k,c + Tx*Int 983C for F-matrix times vector. 984C 985C 2. Allow for general transformation matrix for 986C alpha to a(XLAMPC) and for i (XLAMHC). 987C (the extra i transformation introduces new 988C blocks which is only entered when icon = 1 or 3) 989C 990C 3. If icon diff. from 2 (we have linear response) 991C The D intermediate is stored according to 992C the number of simultaneous trial vector 993C given by IV. This is ensured using IT2DLR. 994C 995! 17-2-1999 Kasper Hald: 996! 997! IF ICON = 4 then the triplet intermediate: 998! 999! g(a-bar,i,l,c) + g(a,i-bar,l,c) is calculated 1000! 1001! IF ICON = 5 then the triplet intermediate: 1002! 1003! g(aikc) + sum(dl)t(ai,dl)L(kcld) - sum(dl)t(di,al)g(ldkc) 1004! 1005! ICON 6: g(a-bar,i,l,c) - g(a,i-bar,l,c) 1006! 1007! ICON 4, ICON 5 and ICON 6 assumes DUMPCD 1008! 1009! Purpose: Calculate D-term. 1010! 1011 IMPLICIT NONE 1012! 1013#include "priunit.h" 1014#include "maxorb.h" 1015#include "ccorb.h" 1016#include "symsq.h" 1017#include "ccsdsym.h" 1018#include "ccsdio.h" 1019! 1020 INTEGER LWORK, ICON, ISYMK, ISYMAG, ISYMDL, KSCR10, KEND1 1021 INTEGER LWRK1, KOFF1, ISYML, ISYMD, ISYMA, ISYMG 1022 INTEGER NBASA, NBASG, NVIRD, KSCR11, KEND2, LWRK2, KOFF2 1023 INTEGER KOFF3, KOFF5, KOFF6, INDEX, ISYAIK, ISYDIS, ISYMPC 1024 INTEGER NRHFK, ISYMAI, NTOTDL, IOFF, IERR, ISYMBG 1025 INTEGER ISYMI, ISYMB, NBASB, KSCR12, NAI, KOFF7, KOFF8 1026 INTEGER ISYMHC, ISALIK, ISYALG, ISYALI, NT1AOM, ISYMAL 1027 INTEGER NBASAL, KOFF4, MAI, ISYMBJ, ISYDEL, ISYMJ, NVIRB 1028 INTEGER NTOTBJ, NBJ, NAIBJ, MALI, IV, IDEL, ISYM5, IOPT5 1029 INTEGER ISYMT2, LUD 1030! 1031#if defined (SYS_CRAY) 1032 REAL ZERO, ONE, HALF, XMHALF, TWO, XMONE, FACTD 1033 REAL XINT(*), OMEGA2(*), T2AM(*), DSRHF(*), SCRM(*) 1034 REAL SCR1(*), SCR2(*), SCR3(*), XLAMDP(*), XLAMIP(*), XLAMDH(*) 1035 REAL XLAMPC(*), XLAMHC(*), WORK(LWORK) 1036#else 1037 DOUBLE PRECISION ZERO, ONE, HALF, XMHALF, TWO, XMONE, FACTD 1038 DOUBLE PRECISION XINT(*), OMEGA2(*), T2AM(*), DSRHF(*), SCRM(*) 1039 DOUBLE PRECISION SCR1(*), SCR2(*), SCR3(*), XLAMDP(*), XLAMIP(*) 1040 DOUBLE PRECISION XLAMDH(*), XLAMPC(*), XLAMHC(*), WORK(LWORK) 1041#endif 1042 PARAMETER(ZERO=0.0D00,ONE=1.0D00,HALF=0.5D00,XMHALF=-0.5D00) 1043 PARAMETER(TWO=2.0D00, XMONE=-1.0D00) 1044 CHARACTER DFIL*(*) 1045C 1046 INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J 1047C 1048 CALL QENTER('CCRHS_D31') 1049C 1050 ISYAIK = MULD2H(ISYDIS,ISYMPC) 1051C 1052C------------------------------------------------------- 1053C Calculate the integrals K(k,dl) = (k d | l delta). 1054C------------------------------------------------------- 1055C 1056 IF ((ICON .EQ. 2) .OR. (ICON .EQ. 3) .OR. (ICON .EQ. 5)) THEN 1057C 1058 DO 100 ISYMK = 1,NSYM 1059C 1060 ISYMAG = MULD2H(ISYMK,ISYDIS) 1061C 1062 DO 110 K = 1,NRHF(ISYMK) 1063C 1064 ISYMDL = MULD2H(ISYMK,ISYDIS) 1065C 1066 KSCR10 = 1 1067 KEND1 = KSCR10 + N2BST(ISYMAG) 1068 LWRK1 = LWORK - KEND1 1069C 1070 IF (LWRK1 .LT. 0) THEN 1071 CALL QUIT('Not enough space for '// 1072 & 'allocation in CCRHS_D31(1)') 1073 END IF 1074C 1075 KOFF1 = IDSRHF(ISYMAG,ISYMK) + NNBST(ISYMAG)*(K-1) + 1 1076 CALL CCSD_SYMSQ(DSRHF(KOFF1),ISYMAG,WORK(KSCR10)) 1077C 1078 DO 120 ISYML = 1,NSYM 1079C 1080 ISYMD = MULD2H(ISYML,ISYMDL) 1081 ISYMA = ISYML 1082 ISYMG = ISYMD 1083C 1084 NBASA = MAX(NBAS(ISYMA),1) 1085 NBASG = MAX(NBAS(ISYMG),1) 1086 NVIRD = MAX(NVIR(ISYMD),1) 1087C 1088 KSCR11 = KEND1 1089 KEND2 = KSCR11 + NBAS(ISYMG)*NRHF(ISYML) 1090 LWRK2 = LWORK - KEND2 1091C 1092 IF (LWRK2 .LT. 0) THEN 1093 CALL QUIT('Not enough space for '// 1094 & 'allocation in CCRHS_D31') 1095 END IF 1096C 1097 KOFF2 = KSCR10 + IAODIS(ISYMA,ISYMG) 1098 KOFF3 = ILMRHF(ISYML) + 1 1099C 1100 CALL DGEMM('T','N',NBAS(ISYMG),NRHF(ISYML), 1101 * NBAS(ISYMA),ONE,WORK(KOFF2),NBASA, 1102 * XLAMDP(KOFF3),NBASA, 1103 * ZERO,WORK(KSCR11),NBASG) 1104C 1105 KOFF5 = ILMVIR(ISYMD) + 1 1106 KOFF6 = IT2BCD(ISYMDL,ISYMK) + NT1AM(ISYMDL)*(K - 1) 1107 * + IT1AM(ISYMD,ISYML) + 1 1108C 1109 CALL DGEMM('T','N',NVIR(ISYMD),NRHF(ISYML), 1110 * NBAS(ISYMG),ONE,XLAMDH(KOFF5),NBASG, 1111 * WORK(KSCR11),NBASG, 1112 * ZERO,SCR1(KOFF6),NVIRD) 1113C 1114 120 CONTINUE 1115C 1116 110 CONTINUE 1117C 1118 100 CONTINUE 1119! 1120!---------------------------------------------------- 1121! For ICON = 5 calculate the last part 1122! of the intermediate. (t2(di,al)*g(ldkc)) 1123!---------------------------------------------------- 1124! 1125 IF (ICON .EQ. 5) THEN 1126! 1127!--------------------------- 1128! Transpose T2. 1129!--------------------------- 1130! 1131 ISYM5 = ISYMT2 1132 CALL CCSD_T2TP(T2AM,WORK,LWORK,ISYM5) 1133! 1134 IF (LWORK .LT. NT2BCD(ISYDIS)) THEN 1135 CALL QUIT('Not enough space in CCRHS_D3 (IOPT = 5)') 1136 ENDIF 1137! 1138!----------------------------- 1139! Calculate the cont. 1140!----------------------------- 1141! 1142 DO 123 ISYMK = 1,NSYM 1143! 1144 ISYMDL = MULD2H(ISYMK,ISYDIS) 1145! 1146 NRHFK = MAX(NRHF(ISYMK),1) 1147! 1148 DO 126 K = 1,NRHF(ISYMK) 1149! 1150 KOFF1 = IT2BCD(ISYMDL,ISYMK)+NT1AM(ISYMDL)*(K-1)+1 1151 KOFF2 = IT2BCT(ISYMK,ISYMDL) + K 1152! 1153 CALL DCOPY(NT1AM(ISYMDL),SCR1(KOFF1),1,WORK(KOFF2), 1154 * NRHFK) 1155! 1156 126 CONTINUE 1157! 1158 123 CONTINUE 1159! 1160 CALL DCOPY(NT2BCD(ISYDIS),WORK,1,SCR3,1) 1161! 1162 IF (LWORK .LT. NT2BCD(ISYAIK)) THEN 1163 CALL QUIT('Insufficient work space in CCRHS_D31') 1164 ENDIF 1165! 1166 DO ISYMK = 1,NSYM 1167! 1168 ISYMDL = MULD2H(ISYMK,ISYDIS) 1169 ISYMAI = MULD2H(ISYAIK,ISYMK) 1170! 1171 NRHFK = MAX(NRHF(ISYMK),1) 1172 NTOTDL = MAX(NT1AM(ISYMDL),1) 1173! 1174 KOFF1 = IT2BCT(ISYMK,ISYMDL) + 1 1175 KOFF2 = IT2SQ(ISYMDL,ISYMAI) + 1 1176 KOFF3 = IT2BCT(ISYMK,ISYMAI) + 1 1177! 1178 CALL DGEMM('N','N',NRHF(ISYMK),NT1AM(ISYMAI),NT1AM(ISYMDL), 1179 * ONE,SCR3(KOFF1),NRHFK,T2AM(KOFF2),NTOTDL,ZERO, 1180 * WORK(KOFF3),NRHFK) 1181! 1182 ENDDO 1183! 1184 CALL DCOPY(NT2BCD(ISYAIK),WORK,1,SCR3,1) 1185! 1186!---------------------------------------- 1187! Transpose T2 (back). 1188!---------------------------------------- 1189! 1190 ISYM5 = ISYMT2 1191 CALL CCSD_T2TP(T2AM,WORK,LWORK,ISYM5) 1192! 1193 ENDIF 1194! 1195!-------------------------------------------- 1196! Transpose integral array. 1197!-------------------------------------------- 1198! 1199 CALL CC_MTCME(SCR1,WORK,LWORK,ISYDIS,1) 1200C 1201 IF (LWORK .LT. NT2BCD(ISYDIS)) THEN 1202 CALL QUIT('Not enough space for allocation in CCRHS_D31(3)') 1203 END IF 1204C 1205 DO 130 ISYMK = 1,NSYM 1206C 1207 ISYMDL = MULD2H(ISYMK,ISYDIS) 1208C 1209 NRHFK = MAX(NRHF(ISYMK),1) 1210C 1211 DO 140 K = 1,NRHF(ISYMK) 1212C 1213 KOFF1 = IT2BCD(ISYMDL,ISYMK) + NT1AM(ISYMDL)*(K - 1) + 1 1214 KOFF2 = IT2BCT(ISYMK,ISYMDL) + K 1215C 1216 CALL DCOPY(NT1AM(ISYMDL),SCR1(KOFF1),1,WORK(KOFF2),NRHFK) 1217C 1218 140 CONTINUE 1219C 1220 130 CONTINUE 1221C 1222 CALL DCOPY(NT2BCD(ISYDIS),WORK,1,SCR1,1) 1223C 1224C----------------------------------------- 1225C Calculate the first contribution. 1226C sum(2*t(ai,dl)-t(di,al))*L(ldkc) 1227C----------------------------------------- 1228C 1229 IF (LWORK .LT. NT2BCD(ISYAIK)) THEN 1230 CALL QUIT('Insufficient work space in CCRHS_D31') 1231 ENDIF 1232C 1233 DO 200 ISYMK = 1,NSYM 1234C 1235 ISYMDL = MULD2H(ISYMK,ISYDIS) 1236 ISYMAI = MULD2H(ISYAIK,ISYMK) 1237C 1238 NRHFK = MAX(NRHF(ISYMK),1) 1239 NTOTDL = MAX(NT1AM(ISYMDL),1) 1240C 1241 KOFF1 = IT2BCT(ISYMK,ISYMDL) + 1 1242 KOFF2 = IT2SQ(ISYMDL,ISYMAI) + 1 1243 KOFF3 = IT2BCT(ISYMK,ISYMAI) + 1 1244C 1245 CALL DGEMM('N','N',NRHF(ISYMK),NT1AM(ISYMAI),NT1AM(ISYMDL), 1246 * ONE,SCR1(KOFF1),NRHFK,T2AM(KOFF2),NTOTDL,ZERO, 1247 * WORK(KOFF3),NRHFK) 1248C 1249 200 CONTINUE 1250C 1251 CALL DCOPY(NT2BCD(ISYAIK),WORK,1,SCR1,1) 1252! 1253 ENDIF 1254! 1255 IF (ICON .EQ. 5) THEN 1256! 1257 CALL DAXPY(NT2BCD(ISYAIK),XMONE,SCR3,1,SCR1,1) 1258! 1259 ENDIF 1260! 1261C---------------------------------------------------------- 1262C Calculate the integrals K(k,ai) = (k i | alfa delta). 1263C---------------------------------------------------------- 1264C 1265 DO 300 ISYMA = 1,NSYM 1266C 1267 ISYMBG = MULD2H(ISYMA,ISYDIS) 1268C 1269 KSCR10 = 1 1270 KEND1 = KSCR10 + N2BST(ISYMBG) 1271 LWRK1 = LWORK - KEND1 1272 IF (LWRK1 .LT. 0) THEN 1273 CALL QUIT('Not enough space for allocation in CCRHS_D31') 1274 END IF 1275C 1276 DO 310 A = 1,NBAS(ISYMA) 1277C 1278 KOFF1 = IDSAOG(ISYMA,ISYDIS) + NNBST(ISYMBG)*(A - 1) + 1 1279 CALL CCSD_SYMSQ(XINT(KOFF1),ISYMBG,WORK(KSCR10)) 1280C 1281 DO 320 ISYMG = 1,NSYM 1282C 1283 ISYMI = ISYMG 1284 ISYMB = MULD2H(ISYMG,ISYMBG) 1285 ISYMK = ISYMB 1286 ISYMAI = MULD2H(ISYMA,ISYMI) 1287C 1288 NBASB = MAX(NBAS(ISYMB),1) 1289 NBASG = MAX(NBAS(ISYMG),1) 1290 NRHFK = MAX(NRHF(ISYMK),1) 1291C 1292 KSCR11 = KEND1 1293 KSCR12 = KSCR11 + NRHF(ISYMK)*NBAS(ISYMG) 1294 KEND2 = KSCR12 + NRHF(ISYMK)*NRHF(ISYMI) 1295 LWRK2 = LWORK - KEND2 1296 IF (LWRK2 .LT. 0) THEN 1297 CALL QUIT('Not enough space for '// 1298 & 'allocation in CCRHS_D1') 1299 END IF 1300C 1301 KOFF2 = ILMRHF(ISYMK) + 1 1302 KOFF3 = KSCR10 + IAODIS(ISYMB,ISYMG) 1303C 1304 CALL DGEMM('T','N',NRHF(ISYMK),NBAS(ISYMG),NBAS(ISYMB), 1305 * ONE,XLAMDP(KOFF2),NBASB,WORK(KOFF3),NBASB, 1306 * ZERO,WORK(KSCR11),NRHFK) 1307C 1308 KOFF5 = ILMRHF(ISYMI) + 1 1309C 1310 CALL DGEMM('N','N',NRHF(ISYMK),NRHF(ISYMI),NBAS(ISYMG), 1311 * ONE,WORK(KSCR11),NRHFK,XLAMDH(KOFF5),NBASG, 1312 * ZERO,WORK(KSCR12),NRHFK) 1313C 1314 DO 330 I = 1,NRHF(ISYMI) 1315C 1316 NAI = IT1AO(ISYMA,ISYMI) + NBAS(ISYMA)*(I-1) + A 1317C 1318 KOFF8 = IT2BGT(ISYMK,ISYMAI) 1319 * + NRHF(ISYMK)*(NAI - 1) + 1 1320 KOFF7 = KSCR12 + NRHF(ISYMK)*(I - 1) 1321C 1322 CALL DCOPY(NRHF(ISYMK),WORK(KOFF7),1,SCR2(KOFF8),1) 1323C 1324 330 CONTINUE 1325C 1326C------------------------------------------------------- 1327C In 2C1 linear transformation extra cont. 1328C------------------------------------------------------- 1329C 1330 IF ((ICON .EQ. 1) .OR. (ICON.EQ.3)) THEN 1331C 1332 ISYMI = MULD2H(ISYMG,ISYMHC) 1333 ISYMAI = MULD2H(ISYMA,ISYMI) 1334C 1335 KEND2 = KSCR12 + NRHF(ISYMK)*NRHF(ISYMI) 1336 LWRK2 = LWORK - KEND2 1337 IF (LWRK2 .LT. 0) THEN 1338 CALL QUIT('Not enough space for '// 1339 & 'allocation in CCRHS_D1') 1340 END IF 1341C 1342 KOFF5 = IGLMRH(ISYMG,ISYMI) + 1 1343C 1344 CALL DGEMM('N','N',NRHF(ISYMK),NRHF(ISYMI), 1345 * NBAS(ISYMG),ONE,WORK(KSCR11),NRHFK, 1346 * XLAMHC(KOFF5),NBASG, 1347 * ZERO,WORK(KSCR12),NRHFK) 1348C 1349 DO 331 I = 1,NRHF(ISYMI) 1350C 1351 NAI = IT1AO(ISYMA,ISYMI) + NBAS(ISYMA)*(I-1) + A 1352C 1353 KOFF8 = IT2BGT(ISYMK,ISYMAI) 1354 * + NRHF(ISYMK)*(NAI - 1) + 1 1355 KOFF7 = KSCR12 + NRHF(ISYMK)*(I - 1) 1356C 1357 CALL DCOPY(NRHF(ISYMK),WORK(KOFF7),1,SCR3(KOFF8),1) 1358C 1359 331 CONTINUE 1360C 1361 ENDIF 1362C 1363 320 CONTINUE 1364C 1365 310 CONTINUE 1366C 1367 300 CONTINUE 1368C 1369 IF ((ICON .EQ. 4) .OR. (ICON .EQ. 5) .OR. (ICON .EQ. 6)) THEN 1370! 1371 CALL DSCAL(NT2BGD(ISYDIS),ZERO,SCR2,1) 1372C 1373 ISALIK = MULD2H(ISYDIS,ISYMHC) 1374C 1375 CALL DSCAL(NT2BGD(ISALIK),ZERO,SCR3,1) 1376! 1377 ELSE 1378! 1379 CALL DSCAL(NT2BGD(ISYDIS),-ONE,SCR2,1) 1380C 1381 ISALIK = MULD2H(ISYDIS,ISYMHC) 1382C 1383 CALL DSCAL(NT2BGD(ISALIK),-ONE,SCR3,1) 1384C 1385 ENDIF 1386! 1387!--------------------------------------------------------------- 1388! For ICON = 4 and ICON = 6 the real calculations begins here 1389!--------------------------------------------------------------- 1390! 1391 DO 340 ISYMK = 1,NSYM 1392C 1393 ISYALG = MULD2H(ISYMK,ISYDIS) 1394 ISYALI = MULD2H(ISYMHC,ISYALG) 1395 NT1AOM = MAX(NT1AO(ISYALG),NT1AO(ISYALI)) 1396C 1397 KSCR10 = 1 1398 KSCR11 = KSCR10 + N2BST(ISYALG) 1399 KEND1 = KSCR11 + NT1AOM 1400 LWRK1 = LWORK - KEND1 1401 IF (LWRK1 .LT. 0) THEN 1402 CALL QUIT('Insufficient space for allocation in CCRHS_D31') 1403 END IF 1404C 1405 DO 350 K = 1,NRHF(ISYMK) 1406C 1407 KOFF1 = IDSRHF(ISYALG,ISYMK) + NNBST(ISYALG)*(K - 1) + 1 1408 CALL CCSD_SYMSQ(DSRHF(KOFF1),ISYALG,WORK(KSCR10)) 1409C 1410 ISYALI = ISYALG 1411 CALL DZERO(WORK(KSCR11),NT1AO(ISYALI)) 1412C 1413C------------------------------ 1414C Usual contribution. 1415C------------------------------ 1416C 1417 DO 360 ISYMI = 1,NSYM 1418C 1419 ISYMAL = MULD2H(ISYMI,ISYALI) 1420 ISYMG = ISYMI 1421C 1422 NBASAL = MAX(NBAS(ISYMAL),1) 1423 NBASG = MAX(NBAS(ISYMG),1) 1424C 1425 KOFF2 = KSCR10 + IAODIS(ISYMAL,ISYMG) 1426 KOFF3 = ILMRHF(ISYMI) + 1 1427 KOFF4 = KSCR11 + IT1AO(ISYMAL,ISYMI) 1428C 1429 CALL DGEMM('N','N',NBAS(ISYMAL),NRHF(ISYMI),NBAS(ISYMG), 1430 * ONE,WORK(KOFF2),NBASAL,XLAMDH(KOFF3),NBASG, 1431 * ZERO,WORK(KOFF4),NBASAL) 1432C 1433 360 CONTINUE 1434C 1435 NRHFK = MAX(NRHF(ISYMK),1) 1436 KOFF5 = IT2BGT(ISYMK,ISYALI) + K 1437C 1438 IF ((ICON .EQ. 4) .OR. (ICON .EQ. 5) .OR. (ICON .EQ. 6) 1439 * ) THEN 1440 CALL DAXPY(NT1AO(ISYALI),ONE,WORK(KSCR11),1,SCR2(KOFF5), 1441 * NRHFK) 1442! 1443 ELSE 1444 CALL DAXPY(NT1AO(ISYALI),TWO,WORK(KSCR11),1,SCR2(KOFF5), 1445 * NRHFK) 1446 ENDIF 1447C 1448C---------------------------------------------------- 1449C In 2C1 linear tronsformation extra cont. 1450C---------------------------------------------------- 1451C 1452 IF ((ICON .EQ. 3) .OR. (ICON .EQ. 1) 1453 & .OR. (ICON .EQ. 4) .OR. (ICON .EQ. 6)) THEN 1454C 1455 ISYALI = MULD2H(ISYALG,ISYMHC) 1456C 1457 CALL DZERO(WORK(KSCR11),NT1AO(ISYALI)) 1458C 1459 DO 361 ISYMI = 1,NSYM 1460C 1461 ISYMAL = MULD2H(ISYMI,ISYALI) 1462 ISYMG = MULD2H(ISYMI,ISYMHC) 1463C 1464 NBASAL = MAX(NBAS(ISYMAL),1) 1465 NBASG = MAX(NBAS(ISYMG),1) 1466C 1467 KOFF2 = KSCR10 + IAODIS(ISYMAL,ISYMG) 1468 KOFF3 = IGLMRH(ISYMG,ISYMI) + 1 1469 KOFF4 = KSCR11 + IT1AO(ISYMAL,ISYMI) 1470C 1471 CALL DGEMM('N','N',NBAS(ISYMAL),NRHF(ISYMI), 1472 & NBAS(ISYMG),ONE,WORK(KOFF2),NBASAL, 1473 & XLAMHC(KOFF3),NBASG, 1474 & ZERO,WORK(KOFF4),NBASAL) 1475C 1476 361 CONTINUE 1477C 1478 NRHFK = MAX(NRHF(ISYMK),1) 1479 KOFF5 = IT2BGT(ISYMK,ISYALI) + K 1480C 1481 IF (ICON .EQ. 4 ) THEN 1482 CALL DAXPY(NT1AO(ISYALI),ONE,WORK(KSCR11),1, 1483 & SCR3(KOFF5),NRHFK) 1484 ELSE IF (ICON .EQ. 6) THEN 1485 CALL DAXPY(NT1AO(ISYALI),XMONE,WORK(KSCR11),1, 1486 & SCR3(KOFF5),NRHFK) 1487 ELSE 1488 CALL DAXPY(NT1AO(ISYALI),TWO,WORK(KSCR11),1, 1489 & SCR3(KOFF5),NRHFK) 1490 ENDIF 1491C 1492 ENDIF 1493C 1494 350 CONTINUE 1495C 1496 340 CONTINUE 1497C 1498 IF (.NOT. DUMPCD) THEN 1499C 1500C----------------------------------------- 1501C Back transformation to the AO basis. 1502C----------------------------------------- 1503C 1504 DO 400 ISYMAI = 1,NSYM 1505C 1506 ISYMK = MULD2H(ISYMAI,ISYDIS) 1507C 1508 NRHFK = MAX(NRHF(ISYMK),1) 1509C 1510 DO 410 ISYMI = 1,NSYM 1511C 1512 ISYMA = MULD2H(ISYMI,ISYMAI) 1513C 1514 NBASA = MAX(NBAS(ISYMA),1) 1515C 1516 DO 420 I = 1,NRHF(ISYMI) 1517C 1518 NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I - 1) + 1 1519 MAI = IT1AO(ISYMA,ISYMI) + NBAS(ISYMA)*(I - 1) + 1 1520C 1521 KOFF1 = IT2BCT(ISYMK,ISYMAI) + NRHF(ISYMK)*(NAI - 1) + 1 1522 KOFF2 = ILMVIR(ISYMA) + 1 1523 KOFF3 = IT2BGT(ISYMK,ISYMAI) + NRHF(ISYMK)*(MAI - 1) + 1 1524C 1525 CALL DGEMM('N','T',NRHF(ISYMK),NBAS(ISYMA),NVIR(ISYMA), 1526 * HALF,SCR1(KOFF1),NRHFK,XLAMIP(KOFF2),NBASA, 1527 * ONE,SCR2(KOFF3),NRHFK) 1528C 1529 420 CONTINUE 1530C 1531 410 CONTINUE 1532C 1533 400 CONTINUE 1534C 1535C 1536 DO 500 ISYMK = 1,NSYM 1537C 1538 ISYMBJ = MULD2H(ISYMK,ISYDEL) 1539C 1540 DO 510 K = 1,NRHF(ISYMK) 1541C 1542 DO 520 ISYMJ = 1,NSYM 1543C 1544 ISYMB = MULD2H(ISYMJ,ISYMBJ) 1545C 1546 NBASB = MAX(NBAS(ISYMB),1) 1547 NVIRB = MAX(NVIR(ISYMB),1) 1548C 1549 KOFF1 = ILMVIR(ISYMB) + 1 1550 KOFF2 = IT2BCD(ISYMBJ,ISYMK) + NT1AM(ISYMBJ)*(K - 1) 1551 * + IT1AM(ISYMB,ISYMJ) + 1 1552 KOFF3 = IT2BGD(ISYMBJ,ISYMK) + NT1AO(ISYMBJ)*(K - 1) 1553 * + IT1AO(ISYMB,ISYMJ) + 1 1554C 1555 CALL DGEMM('N','N',NBAS(ISYMB),NRHF(ISYMJ),NVIR(ISYMB), 1556 * ONE,XLAMIP(KOFF1),NBASB,SCRM(KOFF2),NVIRB, 1557 * ZERO,SCR3(KOFF3),NBASB) 1558C 1559 520 CONTINUE 1560C 1561 510 CONTINUE 1562C 1563 500 CONTINUE 1564C 1565C--------------------------------------- 1566C Calculate the second contribution. 1567C--------------------------------------- 1568C 1569 DO 600 ISYMAI = 1,NSYM 1570C 1571 ISYMK = MULD2H(ISYMAI,ISYDIS) 1572 ISYMBJ = MULD2H(ISYMK,ISYDEL) 1573C 1574 IF (NRHF(ISYMK) .EQ. 0) GOTO 600 1575C 1576 IF (LWORK .LT. NT1AO(ISYMBJ)) THEN 1577 CALL QUIT('Insufficient work space in CCRHS_D31') 1578 ENDIF 1579C 1580 NTOTBJ = MAX(NT1AO(ISYMBJ),1) 1581 NRHFK = MAX(NRHF(ISYMK),1) 1582C 1583 IF (.NOT. OMEGSQ) THEN 1584C 1585 DO 610 NAI = 1,NT1AO(ISYMAI) 1586C 1587 KOFF1 = IT2BGD(ISYMBJ,ISYMK) + 1 1588 KOFF2 = IT2BGT(ISYMK,ISYMAI) 1589 * + NRHF(ISYMK)*(NAI - 1) + 1 1590C 1591 CALL DGEMV('N',NT1AO(ISYMBJ),NRHF(ISYMK),ONE, 1592 * SCR3(KOFF1),NTOTBJ,SCR2(KOFF2),1, 1593 * ZERO,WORK,1) 1594C 1595 IF (ISYMAI .EQ. ISYMBJ) THEN 1596 WORK(NAI) = TWO*WORK(NAI) 1597 ENDIF 1598C 1599 DO 620 NBJ = 1,NT1AO(ISYMBJ) 1600 NAIBJ = IT2AO(ISYMAI,ISYMBJ) + INDEX(NAI,NBJ) 1601 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) + HALF*WORK(NBJ) 1602 620 CONTINUE 1603C 1604 610 CONTINUE 1605C 1606 ELSE 1607C 1608 KOFF1 = IT2BGD(ISYMBJ,ISYMK) + 1 1609 KOFF2 = IT2BGT(ISYMK,ISYMAI) + 1 1610 KOFF3 = IT2AOS(ISYMBJ,ISYMAI) + 1 1611C 1612 CALL DGEMM('N','N',NT1AO(ISYMBJ),NT1AO(ISYMAI),NRHF(ISYMK), 1613 * HALF,SCR3(KOFF1),NTOTBJ,SCR2(KOFF2),NRHFK, 1614 * ONE,OMEGA2(KOFF3),NT1AO(ISYMBJ)) 1615C 1616 ENDIF 1617C 1618 600 CONTINUE 1619C 1620 GOTO 999 1621C 1622C------------------- 1623C I/O algorithm. 1624C------------------- 1625C 1626 ENDIF 1627C 1628C---------------------------------------------------------------------- 1629C Transform the alpha index of K(k,ai) to a. 1630C for 2C1 transformation this means lamdpc is a C1 transformed lambda 1631C---------------------------------------------------------------------- 1632C 1633 ISYAIK = MULD2H(ISYDIS,ISYMPC) 1634C 1635 DO 710 ISYMAI = 1,NSYM 1636C 1637 ISYMK = MULD2H(ISYMAI,ISYAIK) 1638 NRHFK = MAX(NRHF(ISYMK),1) 1639C 1640 DO 720 ISYMI = 1,NSYM 1641C 1642 ISYMA = MULD2H(ISYMI,ISYMAI) 1643 ISYMAL = MULD2H(ISYMPC,ISYMA) 1644 ISYALI = MULD2H(ISYMAL,ISYMI) 1645 NBASAL = MAX(NBAS(ISYMAL),1) 1646C 1647 DO 730 I = 1,NRHF(ISYMI) 1648C 1649 NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I - 1) + 1 1650 MALI = IT1AO(ISYMAL,ISYMI) + NBAS(ISYMAL)*(I - 1) + 1 1651C 1652 KOFF1 = IT2BGT(ISYMK,ISYALI) + NRHF(ISYMK)*(MALI - 1) + 1 1653 KOFF2 = IGLMVI(ISYMAL,ISYMA) + 1 1654 KOFF3 = IT2BCT(ISYMK,ISYMAI) + NRHF(ISYMK)*(NAI - 1) + 1 1655C 1656 CALL DGEMM('N','N',NRHF(ISYMK),NVIR(ISYMA),NBAS(ISYMAL), 1657 * ONE,SCR2(KOFF1),NRHFK,XLAMPC(KOFF2),NBASAL, 1658 * FACTD ,SCR1(KOFF3),NRHFK) 1659! 1660 730 CONTINUE 1661 720 CONTINUE 1662 710 CONTINUE 1663! 1664!----------------------------------------------- 1665! Transform the alpha index of K(k,ai) to a. 1666! I is C1 transformed. 1667!----------------------------------------------- 1668! 1669 IF ((ICON .EQ. 3) .OR. (ICON .EQ. 1) 1670 * .OR. (ICON .EQ. 4) .OR. (ICON .EQ. 6)) THEN 1671C 1672 ISYAIK = MULD2H(ISYDIS,ISYMHC) 1673C 1674 DO 750 ISYMAI = 1,NSYM 1675C 1676 ISYMK = MULD2H(ISYMAI,ISYAIK) 1677 NRHFK = MAX(NRHF(ISYMK),1) 1678C 1679 DO 760 ISYMI = 1,NSYM 1680C 1681 ISYMA = MULD2H(ISYMI,ISYMAI) 1682 ISYMAL= ISYMA 1683 ISYALI= MULD2H(ISYMAL,ISYMI) 1684 NBASAL = MAX(NBAS(ISYMAL),1) 1685C 1686 DO 770 I = 1,NRHF(ISYMI) 1687C 1688 NAI = IT1AM(ISYMA,ISYMI) 1689 * + NVIR(ISYMA)*(I - 1) + 1 1690 MALI = IT1AO(ISYMAL,ISYMI) 1691 * + NBAS(ISYMAL)*(I - 1) + 1 1692C 1693 KOFF1 = IT2BGT(ISYMK,ISYALI) 1694 * + NRHF(ISYMK)*(MALI - 1) + 1 1695 KOFF2 = ILMVIR(ISYMA) + 1 1696 KOFF3 = IT2BCT(ISYMK,ISYMAI) 1697 * + NRHF(ISYMK)*(NAI - 1) + 1 1698C 1699 CALL DGEMM('N','N',NRHF(ISYMK),NVIR(ISYMA), 1700 * NBAS(ISYMAL),ONE,SCR3(KOFF1),NRHFK, 1701 * XLAMDP(KOFF2),NBASAL, 1702 * ONE,SCR1(KOFF3),NRHFK) 1703C 1704 770 CONTINUE 1705 760 CONTINUE 1706 750 CONTINUE 1707C 1708 ENDIF 1709C 1710C--------------------------------------- 1711C Dump to disk the new contribution. 1712C--------------------------------------- 1713C 1714C 1715 IF ((ICON .EQ. 2 ) .OR. (ICON .EQ. 5)) THEN 1716 IOFF = IT2DEL(IDEL) + 1 1717 ELSE 1718 IOFF = IT2DLR(IDEL,IV) + 1 1719 ENDIF 1720C 1721 IF (NT2BCD(ISYAIK) .GT. 0) THEN 1722 CALL PUTWA2(LUD,DFIL,SCR1,IOFF,NT2BCD(ISYAIK)) 1723 ENDIF 1724C 1725 999 CONTINUE 1726C 1727 CALL QEXIT('CCRHS_D31') 1728C 1729 RETURN 1730 END 1731C /* Deck ccrhs_e */ 1732 SUBROUTINE CCRHS_E3(OMEGA2,OM2CONT,T2AM,EMAT1,EMAT2,WORK,LWORK, 1733 * ISYMTR,ISYMIM,OMEGA22,ANTISYM) 1734C 1735C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 1736C Written by Henrik Koch & Ove Christiansen 20-Jan-1994 1737C Symmetry 3-aug 1738C Contraction of EI intermediates with double excitaion amplitudes. 1739C It is assumed that the fock matrix is included. OC 13-1-1995 1740C 1741! Generalized to the triplet case by Kasper Hald. march-1999 1742! IF OM2CONT = .TRUE. => Symmetric permutation of (ai,bj) 1743! is calculated in OMEGA2. IF ANTISYM = .TRUE. => 1744! antisymmetric prem. of (ai,bj) is calculated in OMEGA22. 1745! 1746C Purpose: Calculate E-terms 1747C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 1748C 1749 IMPLICIT NONE 1750! 1751#include "priunit.h" 1752#include "ccorb.h" 1753#include "ccsdsym.h" 1754#include "ccsdinp.h" 1755! 1756 INTEGER LWORK, INDEX, ISYAIBJ, ISYMTR, ISYMIM, ISYMAI, ISYMCJ 1757 INTEGER ISYMBJ, NAI, ISYMJ, ISYMC, ISYMB, NVIRB, NVIRC 1758 INTEGER KOFF1, KOFF2, KOFF3, NBJ, NAIBJ, ISYMBK, ISYMK, NRHFK 1759! 1760#if defined (SYS_CRAY) 1761 REAL ZERO, ONE, TWO 1762 REAL EMAT1(*), EMAT2(*), T2AM(*), OMEGA2(*), OMEGA22(*) 1763 REAL WORK(LWORK) 1764#else 1765 DOUBLE PRECISION ZERO, ONE, TWO 1766 DOUBLE PRECISION EMAT1(*), EMAT2(*), T2AM(*), OMEGA2(*) 1767 DOUBLE PRECISION OMEGA22(*), WORK(LWORK) 1768#endif 1769! 1770 LOGICAL ANTISYM, OM2CONT 1771! 1772 PARAMETER(ZERO=0.0D00,ONE=1.0D00,TWO=2.0D00) 1773C 1774 INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J 1775C 1776 CALL QENTER('CCRHS_E3') 1777C 1778C-------------------------------------------------------------- 1779C Contract and accumulate the first intermediate in OMEGA2. 1780C-------------------------------------------------------------- 1781C 1782 ISYAIBJ = MULD2H(ISYMTR,ISYMIM) 1783C 1784 DO 300 ISYMAI = 1,NSYM 1785C 1786 ISYMCJ = MULD2H(ISYMAI,ISYMTR) 1787 ISYMBJ = MULD2H(ISYMAI,ISYAIBJ) 1788C 1789 IF (LWORK .LT. NT1AM(ISYMBJ)) THEN 1790 CALL QUIT('Insufficient space for allocation in CCRHS_E1') 1791 END IF 1792C 1793 DO 310 NAI = 1,NT1AM(ISYMAI) 1794C 1795 CALL DZERO(WORK,NT1AM(ISYMBJ)) 1796C 1797 DO 320 ISYMJ = 1,NSYM 1798C 1799 ISYMC = MULD2H(ISYMJ,ISYMCJ) 1800 ISYMB = MULD2H(ISYMJ,ISYMBJ) 1801C 1802 NVIRB = MAX(NVIR(ISYMB),1) 1803 NVIRC = MAX(NVIR(ISYMC),1) 1804C 1805 KOFF1 = IMATAB(ISYMB,ISYMC) + 1 1806 KOFF2 = IT2SQ(ISYMCJ,ISYMAI) + NT1AM(ISYMCJ)*(NAI - 1) 1807 * + IT1AM(ISYMC,ISYMJ) + 1 1808 KOFF3 = IT1AM(ISYMB,ISYMJ) + 1 1809C 1810 CALL DGEMM('N','N',NVIR(ISYMB),NRHF(ISYMJ), 1811 * NVIR(ISYMC),ONE,EMAT1(KOFF1),NVIRB, 1812 * T2AM(KOFF2),NVIRC, 1813 * ONE,WORK(KOFF3),NVIRB) 1814 320 CONTINUE 1815C 1816 IF (OM2CONT) THEN 1817 IF (ISYMAI .EQ. ISYMBJ ) THEN 1818C 1819 WORK(NAI) = TWO*WORK(NAI) 1820 DO 330 NBJ = 1,NT1AM(ISYMBJ) 1821 NAIBJ = IT2AM(ISYMAI,ISYMBJ) + INDEX(NAI,NBJ) 1822 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) + WORK(NBJ) 1823 330 CONTINUE 1824C 1825 ENDIF 1826C 1827 IF (ISYMAI .LT. ISYMBJ) THEN 1828C 1829 DO 340 NBJ = 1,NT1AM(ISYMBJ) 1830 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 1831 * + NT1AM(ISYMAI)*(NBJ - 1) + NAI 1832 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) + WORK(NBJ) 1833 340 CONTINUE 1834C 1835 ENDIF 1836C 1837 IF (ISYMBJ .LT. ISYMAI) THEN 1838C 1839 DO 350 NBJ = 1,NT1AM(ISYMBJ) 1840 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 1841 * + NT1AM(ISYMBJ)*(NAI - 1) + NBJ 1842 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) + WORK(NBJ) 1843 350 CONTINUE 1844C 1845 ENDIF 1846! 1847 ENDIF 1848 IF (ANTISYM) THEN 1849 IF (ISYMAI .EQ. ISYMBJ) THEN 1850! 1851 IF (NAI .GE. NT1AM(ISYMBJ)) THEN 1852! 1853 DO NBJ = 1, NT1AM(ISYMBJ) 1854 NAIBJ = IT2AM(ISYMAI, ISYMBJ) + INDEX(NAI,NBJ) 1855 OMEGA22(NAIBJ) = OMEGA22(NAIBJ) + WORK(NBJ) 1856 ENDDO 1857 ELSE 1858! 1859 DO NBJ = 1, NAI - 1 1860 NAIBJ = IT2AM(ISYMAI, ISYMBJ) + INDEX(NAI,NBJ) 1861 OMEGA22(NAIBJ) = OMEGA22(NAIBJ) + WORK(NBJ) 1862 ENDDO 1863 DO NBJ = NAI + 1, NT1AM(ISYMBJ) 1864 NAIBJ = IT2AM(ISYMAI, ISYMBJ) + INDEX(NAI,NBJ) 1865 OMEGA22(NAIBJ) = OMEGA22(NAIBJ) - WORK(NBJ) 1866 ENDDO 1867 ENDIF 1868 ENDIF 1869! 1870 IF (ISYMAI .LT. ISYMBJ) THEN 1871 DO NBJ = 1, NT1AM(ISYMBJ) 1872 NAIBJ = IT2AM(ISYMAI, ISYMBJ) 1873 * + NT1AM(ISYMAI)*(NBJ - 1) + NAI 1874 OMEGA22(NAIBJ) = OMEGA22(NAIBJ) - WORK(NBJ) 1875 ENDDO 1876 ENDIF 1877! 1878 IF (ISYMAI .GT. ISYMBJ) THEN 1879 DO NBJ = 1, NT1AM(ISYMBJ) 1880 NAIBJ = IT2AM(ISYMAI, ISYMBJ) 1881 * + NT1AM(ISYMBJ)*(NAI - 1) + NBJ 1882 OMEGA22(NAIBJ) = OMEGA22(NAIBJ) + WORK(NBJ) 1883 ENDDO 1884 ENDIF 1885 ENDIF 1886 310 CONTINUE 1887 300 CONTINUE 1888C 1889C----------------------------------------------------- 1890C Contract and accumulate the second intermediate. 1891C----------------------------------------------------- 1892C 1893C 1894 DO 400 ISYMAI = 1,NSYM 1895C 1896 ISYMBK = MULD2H(ISYMAI,ISYMTR) 1897 ISYMBJ = MULD2H(ISYMAI,ISYAIBJ) 1898C 1899 IF (LWORK .LT. NT1AM(ISYMBJ)) THEN 1900 CALL QUIT('Insufficient space for allocation in CCRHS_E1') 1901 END IF 1902C 1903 DO 410 NAI = 1,NT1AM(ISYMAI) 1904C 1905 CALL DZERO(WORK,NT1AM(ISYMBJ)) 1906C 1907 DO 420 ISYMB = 1,NSYM 1908C 1909 ISYMJ = MULD2H(ISYMB,ISYMBJ) 1910 ISYMK = MULD2H(ISYMJ,ISYMIM) 1911C 1912 NVIRB = MAX(NVIR(ISYMB),1) 1913 NRHFK = MAX(NRHF(ISYMK),1) 1914C 1915 KOFF1 = IT2SQ(ISYMBK,ISYMAI) + NT1AM(ISYMBK)*(NAI - 1) 1916 * + IT1AM(ISYMB,ISYMK) + 1 1917 KOFF2 = IMATIJ(ISYMK,ISYMJ) + 1 1918 KOFF3 = IT1AM(ISYMB,ISYMJ) + 1 1919C 1920 CALL DGEMM('N','N',NVIR(ISYMB),NRHF(ISYMJ), 1921 * NRHF(ISYMK),ONE,T2AM(KOFF1),NVIRB, 1922 * EMAT2(KOFF2),NRHFK, 1923 * ONE,WORK(KOFF3),NVIRB) 1924 420 CONTINUE 1925C 1926C 1927 IF (OM2CONT) THEN 1928 IF (ISYMAI .EQ. ISYMBJ ) THEN 1929C 1930 WORK(NAI) = TWO*WORK(NAI) 1931C 1932 DO 430 NBJ = 1,NT1AM(ISYMBJ) 1933 NAIBJ = IT2AM(ISYMAI,ISYMBJ) + INDEX(NAI,NBJ) 1934 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) - WORK(NBJ) 1935 430 CONTINUE 1936C 1937 ENDIF 1938C 1939 IF (ISYMAI .LT. ISYMBJ) THEN 1940C 1941 DO 440 NBJ = 1,NT1AM(ISYMBJ) 1942 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 1943 * + NT1AM(ISYMAI)*(NBJ - 1) + NAI 1944 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) - WORK(NBJ) 1945 440 CONTINUE 1946C 1947 ENDIF 1948C 1949 IF (ISYMBJ .LT. ISYMAI) THEN 1950C 1951 DO 450 NBJ = 1,NT1AM(ISYMBJ) 1952 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 1953 * + NT1AM(ISYMBJ)*(NAI - 1) + NBJ 1954 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) - WORK(NBJ) 1955 450 CONTINUE 1956C 1957 ENDIF 1958 ENDIF 1959 IF (ANTISYM) THEN 1960! 1961 IF (ISYMAI .EQ. ISYMBJ) THEN 1962! 1963 DO NBJ = 1, NAI - 1 1964 NAIBJ = IT2AM(ISYMAI, ISYMBJ) + INDEX(NAI,NBJ) 1965 OMEGA22(NAIBJ) = OMEGA22(NAIBJ) - WORK(NBJ) 1966 ENDDO 1967 DO NBJ = NAI + 1, NT1AM(ISYMBJ) 1968 NAIBJ = IT2AM(ISYMAI,ISYMBJ) + INDEX(NAI,NBJ) 1969 OMEGA22(NAIBJ) = OMEGA22(NAIBJ) + WORK(NBJ) 1970 ENDDO 1971 ENDIF 1972! 1973 IF (ISYMAI .LT. ISYMBJ) THEN 1974 DO NBJ = 1, NT1AM(ISYMBJ) 1975 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 1976 * + NT1AM(ISYMAI)*(NBJ - 1) + NAI 1977 OMEGA22(NAIBJ) = OMEGA22(NAIBJ) + WORK(NBJ) 1978 ENDDO 1979 ENDIF 1980! 1981 IF (ISYMAI .GT. ISYMBJ) THEN 1982 DO NBJ = 1, NT1AM(ISYMBJ) 1983 NAIBJ = IT2AM(ISYMAI, ISYMBJ) 1984 * + NT1AM(ISYMBJ)*(NAI - 1) + NBJ 1985 OMEGA22(NAIBJ) = OMEGA22(NAIBJ) - WORK(NBJ) 1986 ENDDO 1987 ENDIF 1988 ENDIF 1989 410 CONTINUE 1990 400 CONTINUE 1991C 1992 CALL QEXIT('CCRHS_E3') 1993C 1994 RETURN 1995 END 1996 SUBROUTINE CCRHS_C3(XINT,DSRHF,OMEGA2,T2AM,ISYMT2, 1997 * XLAMDP,XLAMIP,XLAMDH, 1998 * XLAMPC,ISYMPC,XLAMHC,ISYMHC,SCRM,WORK,LWORK, 1999 * IDEL,ISYMD,FACTC,ICON,LUC,CFIL,IV) 2000C 2001C Written by Henrik Koch 3-Jan-1994 2002C Symmetry by Henrik Koch and Alfredo Sanchez. 27-July-1994 2003C Generalisation for CCLR by Ove Christiansen august-september 1995 2004C (right transformation) and september 1996 (F-matrix). 2005! Generalisation to the CCLR triplet case by Kasper Hald 2006! 11-march-1999. 2007C 2008C Purpose: Calculate C-term. 2009C 2010 IMPLICIT NONE 2011#include "priunit.h" 2012#include "maxorb.h" 2013#include "ccorb.h" 2014#include "symsq.h" 2015#include "ccsdsym.h" 2016#include "ccsdio.h" 2017#include "ccsdinp.h" 2018! 2019 INTEGER LWORK, ISYDIS, ISYMD, ISYAIK, ISYMPC, KSCR1, KSCR2 2020 INTEGER KSCR3, ICON, KEND1, LWRK1, ISYMT2, ISYMHC, IDEL, LUC 2021 INTEGER IV 2022! 2023#if defined (SYS_CRAY) 2024 REAL FACTC 2025 REAL XINT(*), DSRHF(*), OMEGA2(*), XLAMDH(*), WORK(LWORK) 2026 REAL XLAMDP(*), XLAMIP(*), SCRM(*), XLAMPC(*), XLAMHC(*) 2027 REAL T2AM(*) 2028#else 2029 DOUBLE PRECISION FACTC 2030 DOUBLE PRECISION XINT(*), DSRHF(*), OMEGA2(*), XLAMDH(*) 2031 DOUBLE PRECISION WORK(LWORK), XLAMDP(*), XLAMIP(*), SCRM(*) 2032 DOUBLE PRECISION XLAMPC(*), XLAMHC(*), T2AM(*) 2033#endif 2034C 2035 CHARACTER CFIL*(*) 2036C 2037 CALL QENTER('CCRHS_C3') 2038C 2039 ISYDIS = MULD2H(ISYMD,ISYMOP) 2040 ISYAIK = MULD2H(ISYDIS,ISYMPC) 2041C 2042C-------------------------------------- 2043C Dynamic allocation of work space. 2044C-------------------------------------- 2045C 2046 KSCR1 = 1 2047 KSCR2 = KSCR1 + MAX(NT2BCD(ISYAIK),NT2BCD(ISYDIS)) 2048 KSCR3 = KSCR2 + NT2BGD(ISYDIS) 2049 IF ((ICON .EQ. 2) .OR. (ICON .EQ. 5)) THEN 2050 KEND1 = KSCR3 + NT2BGD(ISYMD) 2051 ELSE 2052 KEND1 = KSCR3 + NT2BGD(ISYAIK) 2053 ENDIF 2054 LWRK1 = LWORK - KEND1 2055 IF (LWRK1 .LT. 0) THEN 2056 CALL QUIT('Insufficient space for allocation in CCRHS_C3') 2057 END IF 2058C 2059C-------------------------------------- 2060C Transpose the cluster amplitudes. 2061C-------------------------------------- 2062C 2063 IF ((ICON .EQ. 2) .OR. (ICON .EQ. 3)) THEN 2064 IF (.NOT. T2TCOR) THEN 2065 CALL CCSD_T2TP(T2AM,WORK(KEND1),LWRK1,ISYMT2) 2066 ENDIF 2067 IF (.NOT. DUMPCD) CALL CCSD_T2MTP(SCRM,WORK(KEND1),LWRK1,ISYMD) 2068 ENDIF 2069C 2070C-------------------------------- 2071C Calculate the contribution. 2072C-------------------------------- 2073C 2074 CALL CCRHS_C31(XINT,DSRHF,OMEGA2,T2AM,ISYMT2,SCRM, 2075 * WORK(KSCR1),WORK(KSCR2),WORK(KSCR3),XLAMDP, 2076 * XLAMIP,XLAMDH,XLAMPC,ISYMPC,XLAMHC,ISYMHC, 2077 * WORK(KEND1),LWRK1, 2078 * ISYDIS,IDEL,ISYMD,FACTC,ICON,LUC,CFIL,IV) 2079C 2080C-------------------------------------- 2081C Transpose the cluster amplitudes. 2082C-------------------------------------- 2083C 2084 IF ((ICON .EQ. 2) .OR. (ICON .EQ. 3)) THEN 2085 IF (.NOT. T2TCOR) THEN 2086 CALL CCSD_T2TP(T2AM,WORK(KEND1),LWRK1,ISYMT2) 2087 ENDIF 2088 IF (.NOT. DUMPCD) CALL CCSD_T2MTP(SCRM,WORK(KEND1),LWRK1,ISYMD) 2089 ENDIF 2090C 2091 CALL QEXIT('CCRHS_C3') 2092C 2093 RETURN 2094 END 2095 SUBROUTINE CCRHS_C31(XINT,DSRHF,OMEGA2,T2AM,ISYMT2,SCRM,SCR1, 2096 * SCR2,SCR3,XLAMDP,XLAMIP,XLAMDH, 2097 * XLAMPC,ISYMPC,XLAMHC,ISYMHC,WORK, 2098 * LWORK,ISYDIS,IDEL,ISYDEL,FACTC,ICON,LUC, 2099 * CFIL,IV) 2100C 2101C Written by Henrik Koch 3-Jan-1994 2102C Symmetry by Henrik Koch and Alfredo Sanchez. 27-July-1994 2103C 2104C modification by Ove Christiansen 25-7-1995 to allow for a 2105C general factor (FACTC) ( assumes DUMCD ) 2106C and - calculate intermediates for CCLR. 2107C 2108C modification by Ove Christiansen 17-9-1996 for calculating 2109C local C-intermediate for F-matrix transformation. 2110! 2111! Modification by Kasper Hald 15-2-1999 for calculating the 2112! local C-intermediate for triplet energy calculations. 2113! 2114C Thus: 2115C 2116C Modification to calculate terms in 2C1 right transformation in 2117C CCLR : 2118C 2119C 1. if icon = 2 both contributions are calculated, 2120C otherwise if ICON =1:only the integral 2121C TILDE[(ki | ac)] 2122C = (k i-bar | a c) + (k i | a-bar c) 2123C 2124C 3: (k i-bar | a c) + (k i | a-bar c) 2125C + FACTC*Sum(xT*int) 2126! where xT may be non total symmetric. 2127! 2128! 4: (k i-bar | a c) - (k i | a-bar c) 2129! 2130C 2. Allow for general transformation matrix for 2131C alpha to a(XLAMPC) and for i (XLAMHC). 2132C (the extra i transformation introduces new 2133C blocks which is only entered when 2134C icon =1 or 3) 2135C 2136C 3. If icon diff. from 2 (we have linear response) 2137C The C intermediate is stored according to 2138C the number of simultaneous trial vector 2139C given by IV. This is ensured using IT2DLR. 2140C 2141! 4. ICON = 4 is used for the triplet case. 2142! 2143! 2144C Thus in energy calc: icon = 2,fact = 1/2 2145C For right transformation: 2146C icon=1,fact=anything, iv = current vector being transformed 2147C For F-matrix transformation: 2148C icon=3,fact=1.0, NB - not implemented several vectors yet. 2149! For Triplet calculation: 2150! icon=4,fact=anything, iv = current vector being transformed 2151! 2152C Purpose: Calculate C-term intermediate. 2153C 2154 IMPLICIT NONE 2155#include "priunit.h" 2156#include "maxorb.h" 2157#include "ccorb.h" 2158#include "symsq.h" 2159#include "ccsdsym.h" 2160#include "ccsdio.h" 2161! 2162 INTEGER LWORK, ISYMHC, INDEX, ISYAIK, ISYDIS, ISYMPC, ISAIK2 2163 INTEGER ISYMT2, ICON, ISYML, ISYMAG, KSCR10, KEND1, LWRK1 2164 INTEGER KOFF1, ISYMDL, ISYMD, ISYMK, ISYMA, ISYMG, NBASA 2165 INTEGER NBASG, NRHFK, KSCR11, KEND2, LWRK2, KOFF2, NDL, KOFF3 2166 INTEGER KOFF5, KOFF6, ISYMAI, NTOTDL, IOFF, IDEL, IERR 2167 INTEGER KOFF7, KOFF8, ISYMBG, ISYMI, ISYMB, NBASB, KSCR12 2168 INTEGER NAI, MAI, ISYMBJ, ISYDEL, ISYMJ, NVIRB, NTOTBJ 2169 INTEGER ISYMAJ, ISYMBI, NAJ, NBI, NBJ, NAIBJ, NAJBI, KOFF 2170 INTEGER NBIAJ, ISYMAL, ISYALI, NBASAL, MALI, IV, LUC 2171! 2172#if defined (SYS_CRAY) 2173 REAL ZERO, ONE, HALF, XMHALF, TWO, XMONE, FACTC 2174 REAL XINT(*), OMEGA2(*), T2AM(*), DSRHF(*), SCRM(*) 2175 REAL SCR1(*), SCR2(*), SCR3(*), XLAMDP(*), XLAMIP(*), XLAMDH(*) 2176 REAL XLAMPC(*), XLAMHC(ISYMHC), WORK(LWORK) 2177 REAL FACTOR1 2178#else 2179 DOUBLE PRECISION ZERO, ONE, HALF, XMHALF, TWO, XMONE, FACTC 2180 DOUBLE PRECISION XINT(*), OMEGA2(*), T2AM(*), DSRHF(*), SCRM(*) 2181 DOUBLE PRECISION SCR1(*), SCR2(*), SCR3(*), XLAMDP(*), XLAMIP(*) 2182 DOUBLE PRECISION XLAMDH(*), XLAMPC(*), XLAMHC(ISYMHC) 2183 DOUBLE PRECISION WORK(LWORK), FACTOR1 2184#endif 2185! 2186 PARAMETER (ZERO=0.0D00,ONE=1.0D00,HALF=0.5D00,XMHALF=-0.5D00) 2187 PARAMETER (TWO=2.0D00,XMONE= -1.0D00) 2188 CHARACTER CFIL*(*) 2189C 2190 INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J 2191C 2192 CALL QENTER('CCRHS_C31') 2193C 2194 ISYAIK = MULD2H(ISYDIS,ISYMPC) 2195 ISAIK2 = MULD2H(ISYDIS,ISYMT2) 2196 IF (ISYAIK .NE. ISAIK2) THEN 2197 CALL QUIT('Symmetry mismatch in CCRHS_C3') 2198 ENDIF 2199C 2200C------------------------------------------------------- 2201C Calculate the integrals K(k,dl) = (k d | l delta). 2202C------------------------------------------------------- 2203C 2204 IF ((ICON .EQ. 2) .OR. (ICON .EQ. 3)) THEN 2205C 2206 DO 100 ISYML = 1,NSYM 2207C 2208 ISYMAG = MULD2H(ISYML,ISYDIS) 2209C 2210 DO 110 L = 1,NRHF(ISYML) 2211C 2212 KSCR10 = 1 2213 KEND1 = KSCR10 + N2BST(ISYMAG) 2214 LWRK1 = LWORK - KEND1 2215 IF (LWRK1 .LT. 0) THEN 2216 CALL QUIT('Not enough space for '// 2217 & 'allocation in CCRHS_C31(1)') 2218 END IF 2219C 2220 KOFF1 = IDSRHF(ISYMAG,ISYML) + NNBST(ISYMAG)*(L-1) + 1 2221 CALL CCSD_SYMSQ(DSRHF(KOFF1),ISYMAG,WORK(KSCR10)) 2222C 2223 DO 120 ISYMDL = 1,NSYM 2224C 2225 ISYMD = MULD2H(ISYML,ISYMDL) 2226 ISYMK = MULD2H(ISYMDL,ISYDIS) 2227 ISYMA = ISYMK 2228 ISYMG = ISYMD 2229C 2230 NBASA = MAX(NBAS(ISYMA),1) 2231 NBASG = MAX(NBAS(ISYMG),1) 2232 NRHFK = MAX(NRHF(ISYMK),1) 2233C 2234 KSCR11 = KEND1 2235 KEND2 = KSCR11 + NRHF(ISYMK)*NBAS(ISYMG) 2236 LWRK2 = LWORK - KEND2 2237 IF (LWRK2 .LT. 0) THEN 2238 CALL QUIT('Not enough space for '// 2239 * 'allocation in CCRHS_C31 (2)') 2240 END IF 2241C 2242 KOFF2 = ILMRHF(ISYMK) + 1 2243 KOFF3 = IAODIS(ISYMA,ISYMG) + 1 2244C 2245 CALL DGEMM('T','N',NRHF(ISYMK),NBAS(ISYMG), 2246 * NBAS(ISYMA),ONE,XLAMDP(KOFF2),NBASA, 2247 * WORK(KOFF3),NBASA, 2248 * ZERO,WORK(KSCR11),NRHFK) 2249C 2250 NDL = IT1AM(ISYMD,ISYML) 2251 * + NVIR(ISYMD)*(L - 1) + 1 2252 KOFF5 = ILMVIR(ISYMD) + 1 2253 KOFF6 = IT2BCT(ISYMK,ISYMDL) 2254 * + NRHF(ISYMK)*(NDL - 1) + 1 2255C 2256 CALL DGEMM('N','N',NRHF(ISYMK),NVIR(ISYMD), 2257 * NBAS(ISYMG),ONE,WORK(KSCR11),NRHFK, 2258 * XLAMDH(KOFF5),NBASG, 2259 * ZERO,SCR1(KOFF6),NRHFK) 2260C 2261 120 CONTINUE 2262C 2263 110 CONTINUE 2264C 2265 100 CONTINUE 2266C 2267C----------------------------------------- 2268C Calculate the first contribution. 2269C Sum(dl)T(al,di)*I(lckd) 2270C----------------------------------------- 2271C 2272 IF (LWORK .LT. NT2BCD(ISYAIK)) THEN 2273 CALL QUIT('Insufficient work space in CCRHS_C31 (3)') 2274 ENDIF 2275C 2276 DO 200 ISYMK = 1,NSYM 2277C 2278 ISYMAI = MULD2H(ISYAIK,ISYMK) 2279 ISYMDL = MULD2H(ISYDIS,ISYMK) 2280C 2281 NRHFK = MAX(NRHF(ISYMK),1) 2282 NTOTDL = MAX(NT1AM(ISYMDL),1) 2283C 2284 KOFF1 = IT2BCT(ISYMK,ISYMDL) + 1 2285 KOFF2 = IT2SQ(ISYMDL,ISYMAI) + 1 2286 KOFF3 = IT2BCT(ISYMK,ISYMAI) + 1 2287C 2288 CALL DGEMM('N','N',NRHF(ISYMK),NT1AM(ISYMAI),NT1AM(ISYMDL), 2289 * ONE,SCR1(KOFF1),NRHFK,T2AM(KOFF2),NTOTDL,ZERO, 2290 * WORK(KOFF3),NRHFK) 2291C 2292 200 CONTINUE 2293! 2294 CALL DCOPY(NT2BCD(ISYAIK),WORK,1,SCR1,1) 2295! 2296 ENDIF 2297! 2298C---------------------------------------------------------- 2299C Calculate the integrals K(k,ai) = (k i | alfa delta). 2300C---------------------------------------------------------- 2301C 2302 DO 300 ISYMA = 1,NSYM 2303C 2304 ISYMBG = MULD2H(ISYMA,ISYDIS) 2305C 2306 KSCR10 = 1 2307 KEND1 = KSCR10 + N2BST(ISYMBG) 2308 LWRK1 = LWORK - KEND1 2309 IF (LWRK1 .LT. 0) THEN 2310 CALL QUIT( 2311 * 'Not enough space for allocation in CCRHS_C31 (4)') 2312 END IF 2313C 2314 DO 310 A = 1,NBAS(ISYMA) 2315C 2316 KOFF1 = IDSAOG(ISYMA,ISYDIS) + NNBST(ISYMBG)*(A - 1) + 1 2317 CALL CCSD_SYMSQ(XINT(KOFF1),ISYMBG,WORK(KSCR10)) 2318C 2319 DO 320 ISYMG = 1,NSYM 2320C 2321 ISYMI = ISYMG 2322 ISYMB = MULD2H(ISYMG,ISYMBG) 2323 ISYMK = ISYMB 2324 ISYMAI = MULD2H(ISYMA,ISYMI) 2325C 2326 NBASB = MAX(NBAS(ISYMB),1) 2327 NBASG = MAX(NBAS(ISYMG),1) 2328 NRHFK = MAX(NRHF(ISYMK),1) 2329C 2330 KSCR11 = KEND1 2331 KSCR12 = KSCR11 + NRHF(ISYMK)*NBAS(ISYMG) 2332 KEND2 = KSCR12 + NRHF(ISYMK)*NRHF(ISYMI) 2333 LWRK2 = LWORK - KEND2 2334 IF (LWRK2 .LT. 0) THEN 2335 CALL QUIT('Not enough space for '// 2336 & 'allocation in CCRHS_C31(5)') 2337 END IF 2338C 2339 KOFF2 = ILMRHF(ISYMK) + 1 2340 KOFF3 = KSCR10 + IAODIS(ISYMB,ISYMG) 2341C 2342 CALL DGEMM('T','N',NRHF(ISYMK),NBAS(ISYMG),NBAS(ISYMB), 2343 * ONE,XLAMDP(KOFF2),NBASB,WORK(KOFF3),NBASB, 2344 * ZERO,WORK(KSCR11),NRHFK) 2345C 2346 KOFF5 = ILMRHF(ISYMI) + 1 2347C 2348 CALL DGEMM('N','N',NRHF(ISYMK),NRHF(ISYMI), 2349 & NBAS(ISYMG),ONE,WORK(KSCR11),NRHFK, 2350 & XLAMDH(KOFF5),NBASG, 2351 & ZERO,WORK(KSCR12),NRHFK) 2352C 2353 DO 330 I = 1,NRHF(ISYMI) 2354C 2355 NAI = IT1AO(ISYMA,ISYMI) + NBAS(ISYMA)*(I-1) + A 2356C 2357 KOFF8 = IT2BGT(ISYMK,ISYMAI) 2358 * + NRHF(ISYMK)*(NAI - 1) + 1 2359 KOFF7 = KSCR12 + NRHF(ISYMK)*(I - 1) 2360C 2361 CALL DCOPY(NRHF(ISYMK),WORK(KOFF7),1,SCR2(KOFF8),1) 2362C 2363 330 CONTINUE 2364C 2365C 2366C------------------------------------------------------- 2367C In 2C1 linear transformation extra cont. 2368C------------------------------------------------------- 2369C 2370 IF ((ICON .EQ. 3) .OR. (ICON .EQ. 1) .OR. 2371 & (ICON .EQ. 4)) THEN 2372C 2373 ISYMI = MULD2H(ISYMG,ISYMHC) 2374 ISYMAI = MULD2H(ISYMA,ISYMI) 2375C 2376 KEND2 = KSCR12 + NRHF(ISYMK)*NRHF(ISYMI) 2377 LWRK2 = LWORK - KEND2 2378 IF (LWRK2 .LT. 0) THEN 2379 CALL QUIT('Not enough space for '// 2380 & 'allocation in CCRHS_C31') 2381 END IF 2382C 2383 KOFF5 = IGLMRH(ISYMG,ISYMI) + 1 2384C 2385 IF (ICON .EQ. 4) THEN 2386 FACTOR1 = XMONE 2387 ELSE 2388 FACTOR1 = ONE 2389 ENDIF 2390! 2391 CALL DGEMM('N','N',NRHF(ISYMK),NRHF(ISYMI), 2392 * NBAS(ISYMG),FACTOR1,WORK(KSCR11),NRHFK, 2393 * XLAMHC(KOFF5),NBASG, 2394 * ZERO,WORK(KSCR12),NRHFK) 2395C 2396 DO 331 I = 1,NRHF(ISYMI) 2397C 2398 NAI = IT1AO(ISYMA,ISYMI) + NBAS(ISYMA)*(I-1) + A 2399C 2400 KOFF8 = IT2BGT(ISYMK,ISYMAI) 2401 * + NRHF(ISYMK)*(NAI - 1) + 1 2402 KOFF7 = KSCR12 + NRHF(ISYMK)*(I - 1) 2403C 2404 CALL DCOPY(NRHF(ISYMK),WORK(KOFF7),1,SCR3(KOFF8),1) 2405C 2406 331 CONTINUE 2407C 2408 ENDIF 2409C 2410 320 CONTINUE 2411C 2412 310 CONTINUE 2413C 2414 300 CONTINUE 2415 2416C 2417 IF (.NOT. DUMPCD) THEN 2418C 2419C----------------------------------------- 2420C Back transformation to the AO basis. 2421C----------------------------------------- 2422C 2423 DO 400 ISYMAI = 1,NSYM 2424C 2425 ISYMK = MULD2H(ISYMAI,ISYDIS) 2426C 2427 NRHFK = MAX(NRHF(ISYMK),1) 2428C 2429 DO 410 ISYMI = 1,NSYM 2430C 2431 ISYMA = MULD2H(ISYMI,ISYMAI) 2432C 2433 NBASA = MAX(NBAS(ISYMA),1) 2434C 2435 DO 420 I = 1,NRHF(ISYMI) 2436C 2437 NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I - 1) + 1 2438 MAI = IT1AO(ISYMA,ISYMI) + NBAS(ISYMA)*(I - 1) + 1 2439C 2440 KOFF1 = IT2BCT(ISYMK,ISYMAI) + NRHF(ISYMK)*(NAI - 1) + 1 2441 KOFF2 = ILMVIR(ISYMA) + 1 2442 KOFF3 = IT2BGT(ISYMK,ISYMAI) + NRHF(ISYMK)*(MAI - 1) + 1 2443C 2444 CALL DGEMM('N','T',NRHF(ISYMK),NBAS(ISYMA),NVIR(ISYMA), 2445 * XMHALF,SCR1(KOFF1),NRHFK,XLAMIP(KOFF2),NBASA, 2446 * ONE,SCR2(KOFF3),NRHFK) 2447C 2448 420 CONTINUE 2449C 2450 410 CONTINUE 2451C 2452 400 CONTINUE 2453C 2454C 2455 DO 500 ISYMK = 1,NSYM 2456C 2457 ISYMBJ = MULD2H(ISYMK,ISYDEL) 2458C 2459 DO 510 K = 1,NRHF(ISYMK) 2460C 2461 DO 520 ISYMJ = 1,NSYM 2462C 2463 ISYMB = MULD2H(ISYMJ,ISYMBJ) 2464C 2465 NBASB = MAX(NBAS(ISYMB),1) 2466 NVIRB = MAX(NVIR(ISYMB),1) 2467C 2468 KOFF1 = ILMVIR(ISYMB) + 1 2469 KOFF2 = IT2BCD(ISYMBJ,ISYMK) + NT1AM(ISYMBJ)*(K - 1) 2470 * + IT1AM(ISYMB,ISYMJ) + 1 2471 KOFF3 = IT2BGD(ISYMBJ,ISYMK) + NT1AO(ISYMBJ)*(K - 1) 2472 * + IT1AO(ISYMB,ISYMJ) + 1 2473C 2474 CALL DGEMM('N','N',NBAS(ISYMB),NRHF(ISYMJ),NVIR(ISYMB), 2475 * ONE,XLAMIP(KOFF1),NBASB,SCRM(KOFF2),NVIRB, 2476 * ZERO,SCR3(KOFF3),NBASB) 2477C 2478 520 CONTINUE 2479C 2480 510 CONTINUE 2481C 2482 500 CONTINUE 2483C 2484C--------------------------------------- 2485C Calculate the second contribution. 2486C 2487C Alfredo will introduce the batching over ai before the 2488C end of august 1994. 2489C--------------------------------------- 2490C 2491 DO 600 ISYMAI = 1,NSYM 2492C 2493 ISYMK = MULD2H(ISYMAI,ISYDIS) 2494 ISYMBJ = MULD2H(ISYMK,ISYDEL) 2495C 2496 IF (NRHF(ISYMK) .EQ. 0) GOTO 600 2497C 2498 IF (LWORK .LT. NT1AO(ISYMBJ)) THEN 2499 CALL QUIT('Insufficient work space in CCRHS_C1') 2500 ENDIF 2501C 2502 NTOTBJ = MAX(NT1AO(ISYMBJ),1) 2503C 2504 DO 610 ISYMI = 1,NSYM 2505C 2506 ISYMA = MULD2H(ISYMI,ISYMAI) 2507C 2508 DO 620 I = 1,NRHF(ISYMI) 2509C 2510 DO 630 A = 1,NBAS(ISYMA) 2511C 2512 NAI = IT1AO(ISYMA,ISYMI) + NBAS(ISYMA)*(I-1) + A 2513C 2514 KOFF1 = IT2BGD(ISYMBJ,ISYMK) + 1 2515 KOFF2 = IT2BGT(ISYMK,ISYMAI) 2516 * + NRHF(ISYMK)*(NAI - 1) + 1 2517C 2518 CALL DGEMV('N',NT1AO(ISYMBJ),NRHF(ISYMK),ONE, 2519 * SCR3(KOFF1),NTOTBJ,SCR2(KOFF2),1, 2520 * ZERO,WORK,1) 2521C 2522 IF (.NOT. OMEGSQ) THEN 2523C 2524C 2525 IF (ISYMAI .EQ. ISYMBJ) THEN 2526 WORK(NAI) = TWO*WORK(NAI) 2527 ENDIF 2528C 2529 DO 640 ISYMJ = 1,NSYM 2530C 2531 ISYMB = MULD2H(ISYMJ,ISYMBJ) 2532 ISYMAJ = MULD2H(ISYMA,ISYMJ) 2533 ISYMBI = MULD2H(ISYMB,ISYMI) 2534C 2535 DO 650 J = 1,NRHF(ISYMJ) 2536C 2537 NAJ = IT1AO(ISYMA,ISYMJ) + NBAS(ISYMA)*(J-1) + A 2538C 2539 DO 660 B = 1,NBAS(ISYMB) 2540C 2541 NBI = IT1AO(ISYMB,ISYMI) 2542 * + NBAS(ISYMB)*(I-1) + B 2543 NBJ = IT1AO(ISYMB,ISYMJ) 2544 * + NBAS(ISYMB)*(J-1) + B 2545C 2546 NAIBJ = IT2AO(ISYMAI,ISYMBJ) + INDEX(NAI,NBJ) 2547 NAJBI = IT2AO(ISYMAJ,ISYMBI) + INDEX(NAJ,NBI) 2548C 2549 OMEGA2(NAIBJ) = OMEGA2(NAIBJ)-HALF*WORK(NBJ) 2550 OMEGA2(NAJBI) = OMEGA2(NAJBI)-WORK(NBJ) 2551C 2552 660 CONTINUE 2553 650 CONTINUE 2554 640 CONTINUE 2555C 2556C 2557 ELSE 2558C 2559C 2560 KOFF = IT2AOS(ISYMBJ,ISYMAI) 2561 * + NT1AO(ISYMBJ)*(NAI - 1) + 1 2562 CALL DAXPY(NT1AO(ISYMBJ),-HALF,WORK,1,OMEGA2(KOFF),1) 2563C 2564 DO 740 ISYMJ = 1,NSYM 2565C 2566 ISYMB = MULD2H(ISYMJ,ISYMBJ) 2567 ISYMAJ = MULD2H(ISYMA,ISYMJ) 2568 ISYMBI = MULD2H(ISYMB,ISYMI) 2569C 2570 NBI = IT1AO(ISYMB,ISYMI) + NBAS(ISYMB)*(I-1) + 1 2571C 2572 DO 750 J = 1,NRHF(ISYMJ) 2573C 2574 NAJ = IT1AO(ISYMA,ISYMJ) + NBAS(ISYMA)*(J-1) + A 2575 NBJ = IT1AO(ISYMB,ISYMJ) + NBAS(ISYMB)*(J-1) + 1 2576C 2577 NBIAJ = IT2AOS(ISYMBI,ISYMAJ) 2578 * + NT1AO(ISYMBI)*(NAJ - 1) + NBI 2579C 2580 CALL DAXPY(NBAS(ISYMB),-ONE,WORK(NBJ),1, 2581 * OMEGA2(NBIAJ),1) 2582C 2583 750 CONTINUE 2584 740 CONTINUE 2585C 2586 ENDIF 2587C 2588 630 CONTINUE 2589 620 CONTINUE 2590C 2591 610 CONTINUE 2592 600 CONTINUE 2593C 2594 GOTO 999 2595C 2596C------------------- 2597C I/O algorithm. 2598C------------------- 2599C 2600 ENDIF 2601C 2602C----------------------------------------------- 2603C Transform the alpha index of K(k,ai) to a. 2604C----------------------------------------------- 2605C 2606 ISYAIK = MULD2H(ISYDIS,ISYMPC) 2607C 2608 IF ((ICON .EQ. 1) .OR. (ICON .EQ. 4)) THEN 2609 CALL DZERO(SCR1,NT2BCD(ISYAIK)) 2610 ENDIF 2611C 2612 DO 810 ISYMAI = 1,NSYM 2613C 2614 ISYMK = MULD2H(ISYMAI,ISYAIK) 2615 NRHFK = MAX(NRHF(ISYMK),1) 2616C 2617 DO 820 ISYMI = 1,NSYM 2618C 2619 ISYMA = MULD2H(ISYMI,ISYMAI) 2620 ISYMAL= MULD2H(ISYMPC,ISYMA) 2621 ISYALI= MULD2H(ISYMAL,ISYMI) 2622 NBASAL = MAX(NBAS(ISYMAL),1) 2623C 2624 DO 830 I = 1,NRHF(ISYMI) 2625C 2626 NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I - 1) + 1 2627 MALI = IT1AO(ISYMAL,ISYMI) + NBAS(ISYMAL)*(I - 1) + 1 2628C 2629 KOFF1 = IT2BGT(ISYMK,ISYALI) + NRHF(ISYMK)*(MALI- 1) + 1 2630 KOFF2 = IGLMVI(ISYMAL,ISYMA) + 1 2631 KOFF3 = IT2BCT(ISYMK,ISYMAI) + NRHF(ISYMK)*(NAI - 1) + 1 2632C 2633 CALL DGEMM('N','N',NRHF(ISYMK),NVIR(ISYMA),NBAS(ISYMAL), 2634 * ONE,SCR2(KOFF1),NRHFK,XLAMPC(KOFF2),NBASAL, 2635 * FACTC,SCR1(KOFF3),NRHFK) 2636C 2637 830 CONTINUE 2638 820 CONTINUE 2639 810 CONTINUE 2640C 2641C----------------------------------------------- 2642C Transform the alpha index of K(k,ai) to a. 2643C I is C1 transformed. 2644C----------------------------------------------- 2645C 2646 IF ((ICON .EQ. 3) .OR. (ICON .EQ. 1) .OR. (ICON .EQ. 4)) THEN 2647C 2648 ISYAIK = MULD2H(ISYDIS,ISYMHC) 2649C 2650 DO 850 ISYMAI = 1,NSYM 2651C 2652 ISYMK = MULD2H(ISYMAI,ISYAIK) 2653 NRHFK = MAX(NRHF(ISYMK),1) 2654C 2655 DO 860 ISYMI = 1,NSYM 2656C 2657 ISYMA = MULD2H(ISYMI,ISYMAI) 2658 ISYMAL= ISYMA 2659 ISYALI= MULD2H(ISYMAL,ISYMI) 2660 NBASAL = MAX(NBAS(ISYMAL),1) 2661C 2662 DO 870 I = 1,NRHF(ISYMI) 2663C 2664 NAI = IT1AM(ISYMA,ISYMI) 2665 * + NVIR(ISYMA)*(I - 1) + 1 2666 MALI = IT1AO(ISYMAL,ISYMI) 2667 * + NBAS(ISYMAL)*(I - 1) + 1 2668C 2669 KOFF1 = IT2BGT(ISYMK,ISYALI) 2670 * + NRHF(ISYMK)*(MALI - 1) + 1 2671 KOFF2 = ILMVIR(ISYMA) + 1 2672 KOFF3 = IT2BCT(ISYMK,ISYMAI) 2673 * + NRHF(ISYMK)*(NAI - 1) + 1 2674C 2675 CALL DGEMM('N','N',NRHF(ISYMK),NVIR(ISYMA), 2676 * NBAS(ISYMAL),ONE,SCR3(KOFF1),NRHFK, 2677 * XLAMDP(KOFF2),NBASAL, 2678 * ONE,SCR1(KOFF3),NRHFK) 2679C 2680 870 CONTINUE 2681 860 CONTINUE 2682 850 CONTINUE 2683C 2684 ENDIF 2685C 2686C--------------------------------------------------------- 2687C Dump to disk the new contribution. 2688C--------------------------------------------------------- 2689C 2690 IF ( ICON .EQ. 2 ) THEN 2691C 2692 IOFF = IT2DEL(IDEL) + 1 2693C 2694 ELSE 2695C 2696 IOFF = IT2DLR(IDEL,IV) + 1 2697C 2698 ENDIF 2699C 2700 IF (NT2BCD(ISYAIK) .GT. 0) THEN 2701 CALL PUTWA2(LUC,CFIL,SCR1,IOFF,NT2BCD(ISYAIK)) 2702 ENDIF 2703C 2704 999 CONTINUE 2705C 2706 CALL QEXIT('CCRHS_C31') 2707C 2708 RETURN 2709 END 2710C /* Deck ccrhs_t2tr */ 2711 SUBROUTINE CCRHS3_T2TR(T2AM,WORK,LWORK,ISYM,IOPT) 2712C 2713C Alfredo Sanchez and Henrik Koch 30-July 1994 2714C 2715! 19-03-99: Kasper Hald 2716! Generalized to calculate only the last term i.e. 2717! only exchange (IOPT = 2) 2718! 2719! IOPT = 1 : The normal 2T2 - T2 2720! IOPT = 2 : Only exchange 2721! 2722C PURPOSE: 2723C Calculate two coulomb minus exchange of t2 amplitudes, 2724C Calculate only minus the exchange term. 2725C The amplitudes are assumed to be a square matrix. 2726C 2727 IMPLICIT NONE 2728#include "priunit.h" 2729#include "ccorb.h" 2730#include "ccsdsym.h" 2731! 2732 INTEGER LWORK, ISYMJ, ISYMB, ISYMBJ, ISYMAI, ISYM, NBJ, ISYMI 2733 INTEGER ISYMA, ISYMAJ, ISYMBI, KSCR1, KSCR2, KEND1, LWRK1 2734 INTEGER NRHFI, NBI, NAIBJ, NAJBI, IOPT, KOFF 2735! 2736#if defined (SYS_CRAY) 2737 REAL ONE, TWO, ZERO, XMONE 2738 REAL T2AM(*), WORK(LWORK) 2739#else 2740 DOUBLE PRECISION ONE, TWO, ZERO, XMONE 2741 DOUBLE PRECISION T2AM(*), WORK(LWORK) 2742#endif 2743 PARAMETER (ONE = 1.0D00, TWO = 2.0D00, ZERO = 0.0D00) 2744 PARAMETER (XMONE = -1.0D00) 2745C 2746 CALL QENTER('CCRHS3_T2TR') 2747C 2748C---------------------------------------------------------- 2749C Calculate two coulomb minus exchange of t2-amplitude, 2750C or minus exchange. 2751C---------------------------------------------------------- 2752C 2753 DO 100 ISYMJ = 1,NSYM 2754C 2755 DO 110 J = 1,NRHF(ISYMJ) 2756C 2757 DO 120 ISYMB = 1,NSYM 2758C 2759 ISYMBJ = MULD2H(ISYMB,ISYMJ) 2760 ISYMAI = MULD2H(ISYMBJ,ISYM) 2761C 2762 DO 130 B = 1,NVIR(ISYMB) 2763C 2764 NBJ = IT1AM(ISYMB,ISYMJ)+NVIR(ISYMB)*(J-1)+B 2765C 2766 DO 140 ISYMI = 1,ISYMJ 2767C 2768 ISYMA = MULD2H(ISYMI,ISYMAI) 2769 ISYMAJ = MULD2H(ISYMA,ISYMJ) 2770 ISYMBI = MULD2H(ISYMB,ISYMI) 2771C 2772 KSCR1 = 1 2773 KSCR2 = KSCR1 + NVIR(ISYMA) 2774 KEND1 = KSCR2 + NVIR(ISYMA) 2775 LWRK1 = LWORK - KEND1 2776 IF (LWRK1 .LT. 0) THEN 2777 CALL QUIT('Insufficient space in CCRHS3_T2TR') 2778 ENDIF 2779C 2780 IF (ISYMI .EQ. ISYMJ) THEN 2781 NRHFI = J - 1 2782 ELSE 2783 NRHFI = NRHF(ISYMI) 2784 END IF 2785C 2786 DO 150 I = 1,NRHFI 2787C 2788 NBI = IT1AM(ISYMB,ISYMI)+NVIR(ISYMB)*(I-1)+B 2789C 2790 NAIBJ = IT2SQ(ISYMAI,ISYMBJ) 2791 * + NT1AM(ISYMAI)*(NBJ-1) 2792 * + IT1AM(ISYMA,ISYMI)+NVIR(ISYMA)*(I-1)+1 2793C 2794 NAJBI = IT2SQ(ISYMAJ,ISYMBI) 2795 * + NT1AM(ISYMAJ)*(NBI-1) 2796 * + IT1AM(ISYMA,ISYMJ)+NVIR(ISYMA)*(J-1)+1 2797C 2798! 2799 CALL DCOPY(NVIR(ISYMA),T2AM(NAIBJ),1, 2800 * WORK(KSCR1),1) 2801 CALL DCOPY(NVIR(ISYMA),T2AM(NAJBI),1, 2802 * WORK(KSCR2),1) 2803C 2804 IF (IOPT .EQ. 1) THEN 2805 CALL DSCAL(NVIR(ISYMA),TWO,T2AM(NAIBJ),1) 2806 CALL DSCAL(NVIR(ISYMA),TWO,T2AM(NAJBI),1) 2807 ELSE IF (IOPT .EQ. 2) THEN 2808 CALL DSCAL(NVIR(ISYMA),ZERO,T2AM(NAIBJ),1) 2809 CALL DSCAL(NVIR(ISYMA),ZERO,T2AM(NAJBI),1) 2810 ELSE 2811 CALL QUIT('IOPT Mismatch in CCRHS3_T2TR ') 2812 ENDIF 2813! 2814 CALL DAXPY(NVIR(ISYMA),-ONE,WORK(KSCR2),1, 2815 * T2AM(NAIBJ),1) 2816 CALL DAXPY(NVIR(ISYMA),-ONE,WORK(KSCR1),1, 2817 * T2AM(NAJBI),1) 2818C 2819 150 CONTINUE 2820C 2821 140 CONTINUE 2822C 2823 130 CONTINUE 2824C 2825 120 CONTINUE 2826C 2827 110 CONTINUE 2828C 2829 100 CONTINUE 2830C 2831 IF (IPRCC .GT. 20) THEN 2832 IF (IOPT .EQ. 1) THEN 2833 CALL AROUND('Two coulomb minus exchamge of t2am') 2834 ELSE IF (IOPT .EQ. 2) THEN 2835 CALL AROUND('The minus exchange of the T2AM') 2836 ENDIF 2837 DO 200 ISYMBJ = 1,NSYM 2838 ISYMAI = MULD2H(ISYMBJ,ISYM) 2839 KOFF = IT2SQ(ISYMAI,ISYMBJ) + 1 2840 WRITE(LUPRI,*) 2841 WRITE(LUPRI,*) 'Symmetry block:',ISYMBJ 2842 CALL OUTPUT(T2AM(KOFF),1,NT1AM(ISYMAI),1,NT1AM(ISYMBJ), 2843 * NT1AM(ISYMAI),NT1AM(ISYMBJ),1,LUPRI) 2844 200 CONTINUE 2845 END IF 2846C 2847 CALL QEXIT('CCRHS3_T2TR') 2848C 2849 RETURN 2850 END 2851C /* Deck ccrhs_cio */ 2852 SUBROUTINE CCRHS3_CIO(OMEGA2,T2AM,XLAMDH,WORK,LWORK, 2853 * ISYVEC,ISYCIM,LUC,CFIL,IV,IOPT,FACCN, 2854 * NORMALCONT,FACCP,PIJCONT,ANTISYM) 2855! 2856! asm 17-aug-1994 2857! 2858! Ove Christiansen 30-7-1995: modified to account for general 2859! non. total symmetric vectors (ISYVEC) 2860! and 2861! intermediates (ISYCIM). LUC and CFIL 2862! is used to control from which file 2863! the intermediate is obtained. 2864! 2865! if iopt = 1 the C intermediate is 2866! assumed to be as in energy clac. 2867! 2868! if iopt ne. 1 we use the intermediate 2869! on luc with address given according 2870! to 2871! transformed vector nr iv (iv is not 2872! 1 if several vectros are trans. 2873! simultaneously.) 2874! 2875! 2876! Kasper Hald 22-3-1999 Modified to calculate the triplet 2877! contributions. Use ANTISYM and FACCN, 2878! NORMALCONT, FACCP, PIJCONT 2879! 2880! in energy calc: iv=1,iopt=1 2881! FACCN = -HALF and FACCP = -1 2882! NORMALCONT = .TRUE. 2883! PIJCONT = .TRUE. 2884! 2885! PURPOSE: 2886! Calculate the C-term making I/O 2887! 2888! N.B. The diagonal is set to zero since the diagonal elements 2889! are identical zero in the triplet case. 2890! 2891 IMPLICIT NONE 2892! 2893#include "priunit.h" 2894#include "ccorb.h" 2895#include "ccsdsym.h" 2896#include "maxorb.h" 2897#include "ccsdio.h" 2898! 2899 INTEGER LWORK, INDEX, ISAIBJ, ISYVEC, ISYCIM, ISYMAI, ISYMBJ 2900 INTEGER ISYMCK, ISYMDK, NT1AI, LENAI, LENMIN, NDISAI, NBATAI 2901 INTEGER ILSTAI, IBATAI, IFSTAI, KSCR1, KSCR2, KEND, LWRK1 2902 INTEGER KOFF1, ISYDEL, ISYMK, IDELTA, ID, IOPT, IOFF, IV 2903 INTEGER LEN, IERR, NAI, KAI, KOFF2, KOFF3, KOFF4, KOFF5, KOFF6 2904 INTEGER ISYMC, NBASD, NVIRC, NT1BJ, NT1CK, KOFF7, KOFF8 2905 INTEGER ISYMI, ISYMA, ISYMJ, ISYMB, ISYMAJ, ISYMBI, NAJ 2906 INTEGER CCRHSCOUNT, LUC 2907! 2908#if defined (SYS_CRAY) 2909 REAL ZERO, HALF, ONE, TWO, FACCN, FACCP 2910 REAL OMEGA2(*), T2AM(*), XLAMDH(*), WORK(LWORK) 2911#else 2912 DOUBLE PRECISION ZERO, HALF, ONE, TWO, FACCN, FACCP 2913 DOUBLE PRECISION OMEGA2(*), T2AM(*), XLAMDH(*), WORK(LWORK) 2914#endif 2915! 2916 PARAMETER (ZERO= 0.0D00, HALF= 0.5D00, ONE= 1.0D00, TWO= 2.0D00) 2917 CHARACTER CFIL*(*) 2918 LOGICAL ANTISYM, NORMALCONT, PIJCONT 2919! 2920C INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J 2921! 2922 CALL QENTER('CCRHS3_CIO') 2923! 2924 IF (OMEGSQ) THEN 2925 WRITE(LUPRI,*) 'I/O in C-term not implemented for '// 2926 & 'square Omega2' 2927 CALL QUIT('OMEGSQ = .TRUE. in CCRHS3_CIO') 2928 END IF 2929! 2930 ISAIBJ = MULD2H(ISYVEC,ISYCIM) 2931! 2932 DO 100 ISYMAI = 1,NSYM 2933! 2934 IF (NT1AM(ISYMAI) .EQ. 0) GOTO 100 2935! 2936 ISYMBJ = MULD2H(ISYMAI,ISAIBJ) 2937 ISYMCK = MULD2H(ISYVEC,ISYMBJ) 2938 ISYMDK = MULD2H(ISYCIM,ISYMAI) 2939! 2940!------------------------ 2941! Batch structure. 2942!------------------------ 2943! 2944 NT1AI = NT1AM(ISYMAI) 2945! 2946 LENAI = NT1AO(ISYMDK) 2947 LENMIN = 2*LENAI 2948 IF (LENMIN .EQ. 0) GOTO 100 2949! 2950 NDISAI = LWORK / LENMIN 2951 IF (NDISAI .LT. 1) THEN 2952 CALL QUIT('Insufficient space for '// 2953 & 'allocation in CCRHS3_CIO-1') 2954 END IF 2955 NDISAI = MIN(NDISAI,NT1AI) 2956! 2957 NBATAI = (NT1AI - 1) / NDISAI + 1 2958! 2959!-------------------------- 2960! Loop over batches. 2961!-------------------------- 2962! 2963 ILSTAI = 0 2964 DO 110 IBATAI = 1,NBATAI 2965! 2966 IFSTAI = ILSTAI + 1 2967 ILSTAI = ILSTAI + NDISAI 2968 IF (ILSTAI .GT. NT1AI) THEN 2969 ILSTAI = NT1AI 2970 NDISAI = ILSTAI - IFSTAI + 1 2971 END IF 2972! 2973!----------------------------- 2974! Memory allocation. 2975!----------------------------- 2976! 2977 KSCR1 = 1 2978 KSCR2 = KSCR1 + NDISAI*NT1AO(ISYMDK) 2979 KEND = KSCR2 + NDISAI*NT1AO(ISYMDK) 2980 LWRK1 = LWORK - KEND 2981! 2982 IF (LWRK1 .LT. 0) THEN 2983 CALL QUIT('Insufficient space for '// 2984 & 'allocation in CCRHS3_CIO-2') 2985 END IF 2986! 2987!---------------------------------- 2988! Construct P(del k,#ai). 2989!---------------------------------- 2990! 2991 KOFF1 = KSCR1 2992 DO 120 ISYDEL = 1,NSYM 2993! 2994 ISYMK = MULD2H(ISYDEL,ISYMDK) 2995! 2996 DO 130 IDELTA = 1,NBAS(ISYDEL) 2997! 2998 ID = IDELTA + IBAS(ISYDEL) 2999! 3000 IF (IOPT .EQ. 1 ) THEN 3001 IOFF = IT2DEL(ID) + IT2BCT(ISYMK,ISYMAI) 3002 * + NRHF(ISYMK)*(IFSTAI - 1) + 1 3003 ELSE 3004 IOFF = IT2DLR(ID,IV) + IT2BCT(ISYMK,ISYMAI) 3005 * + NRHF(ISYMK)*(IFSTAI - 1) + 1 3006 ENDIF 3007! 3008 LEN = NDISAI*NRHF(ISYMK) 3009! 3010 IF (LEN .GT. 0) THEN 3011 CALL GETWA2(LUC,CFIL,WORK(KOFF1),IOFF,LEN) 3012 ENDIF 3013! 3014 DO 140 NAI = IFSTAI,ILSTAI 3015! 3016 KAI = NAI - IFSTAI + 1 3017! 3018 KOFF2 = KOFF1 + NRHF(ISYMK)*(KAI - 1) 3019 KOFF3 = KSCR2 + NT1AO(ISYMDK)*(KAI - 1) 3020 * + IT1AO(ISYDEL,ISYMK) + IDELTA - 1 3021! 3022 CALL DCOPY(NRHF(ISYMK),WORK(KOFF2),1,WORK(KOFF3), 3023 * NBAS(ISYDEL)) 3024! 3025 140 CONTINUE 3026! 3027 KOFF1 = KOFF1 + LEN 3028! 3029 130 CONTINUE 3030 120 CONTINUE 3031! 3032!----------------------------------------- 3033! Transform delta index to c. 3034!----------------------------------------- 3035! 3036 DO 150 NAI = IFSTAI,ILSTAI 3037! 3038 KAI = NAI - IFSTAI + 1 3039! 3040 DO 160 ISYMC = 1,NSYM 3041! 3042 ISYDEL = ISYMC 3043 ISYMK = MULD2H(ISYMC,ISYMCK) 3044! 3045 NBASD = MAX(NBAS(ISYDEL),1) 3046 NVIRC = MAX(NVIR(ISYMC),1) 3047! 3048 KOFF4 = ILMVIR(ISYDEL) + 1 3049 KOFF5 = KSCR2 + NT1AO(ISYMDK)*(KAI - 1) 3050 * + IT1AO(ISYDEL,ISYMK) 3051 KOFF6 = KSCR1 + NT1AM(ISYMCK)*(KAI - 1) 3052 * + IT1AM(ISYMC,ISYMK) 3053! 3054 CALL DGEMM('T','N',NVIR(ISYMC),NRHF(ISYMK), 3055 * NBAS(ISYDEL),ONE,XLAMDH(KOFF4),NBASD, 3056 * WORK(KOFF5),NBASD,ZERO,WORK(KOFF6), 3057 * NVIRC) 3058! 3059 160 CONTINUE 3060 150 CONTINUE 3061! 3062!-------------------------------------------- 3063! Contract P(ck,#ai) with T(bj,ck). 3064!-------------------------------------------- 3065! 3066 NT1BJ = MAX(NT1AM(ISYMBJ),1) 3067 NT1CK = MAX(NT1AM(ISYMCK),1) 3068! 3069 KOFF7 = IT2SQ(ISYMBJ,ISYMCK) + 1 3070! 3071 CALL DGEMM('N','N',NT1AM(ISYMBJ),NDISAI,NT1AM(ISYMCK), 3072 * ONE,T2AM(KOFF7),NT1BJ,WORK(KSCR1),NT1CK, 3073 * ZERO,WORK(KSCR2),NT1BJ) 3074! 3075!-------------------------------------------------- 3076! Scale the diagonal with zero if antisym 3077! since the diagonal is then identical zero 3078! If not antisym scale the diagonal with 3079! two. 3080!-------------------------------------------------- 3081! 3082 IF (ISYMBJ .EQ. ISYMAI) THEN 3083! 3084 DO 170 NAI = IFSTAI,ILSTAI 3085 KOFF8 = KSCR2 + NT1AM(ISYMBJ)*(NAI-IFSTAI) + NAI - 1 3086 IF (ANTISYM) THEN 3087 WORK(KOFF8) = ZERO * WORK(KOFF8) 3088 ELSE 3089 WORK(KOFF8) = TWO * WORK(KOFF8) 3090 ENDIF 3091 170 CONTINUE 3092! 3093 END IF 3094! 3095!----------------------------------------------- 3096! Add the result to the packed omega2. 3097!----------------------------------------------- 3098! 3099 DO 180 ISYMI = 1,NSYM 3100! 3101 ISYMA = MULD2H(ISYMI,ISYMAI) 3102! 3103 DO 190 I = 1,NRHF(ISYMI) 3104! 3105 DO 200 A = 1,NVIR(ISYMA) 3106! 3107 NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I - 1) + A 3108 IF ((NAI .LT. IFSTAI) .OR. (NAI .GT. ILSTAI)) 3109 * GOTO 200 3110! 3111 DO 210 ISYMJ = 1,NSYM 3112! 3113 ISYMB = MULD2H(ISYMJ,ISYMBJ) 3114 ISYMAJ = MULD2H(ISYMA,ISYMJ) 3115 ISYMBI = MULD2H(ISYMB,ISYMI) 3116! 3117 DO 220 J = 1,NRHF(ISYMJ) 3118! 3119 NAJ = IT1AM(ISYMA,ISYMJ) 3120 * + NVIR(ISYMA)*(J-1) + A 3121! 3122 CALL CC_PUTC3(WORK(KSCR2),OMEGA2,ISYMAI, 3123 * ISYMAJ,ISYMBI,ISYMBJ,ISYMB, 3124 * ISYMI,ISYMJ,NAI,NAJ,I,J, 3125 * IFSTAI,FACCN,NORMALCONT, 3126 * FACCP,PIJCONT,ANTISYM) 3127! 3128 220 CONTINUE 3129 210 CONTINUE 3130 200 CONTINUE 3131 190 CONTINUE 3132 180 CONTINUE 3133! 3134 110 CONTINUE 3135 100 CONTINUE 3136! 3137 CALL QEXIT('CCRHS3_CIO') 3138! 3139 RETURN 3140 END 3141! /* Deck cc_putc */ 3142 SUBROUTINE CC_PUTC3(SCR2,OMEGA2,ISYMAI,ISYMAJ,ISYMBI,ISYMBJ, 3143 * ISYMB,ISYMI,ISYMJ,NAI,NAJ,I,J,IFSTAI,FACCN, 3144 * NORMALCONT,FACCP,PIJCONT,ANTISYM) 3145! 3146! Ove Christiansen 30-10-1995: Put in C contribution in omega vector 3147! avoid troble on cray with optimizatio 3148! 3149! Kasper Hald Spring 1999 : Generalized to triplet excitation 3150! energies 3151!. 3152! 3153 IMPLICIT NONE 3154! 3155#include "priunit.h" 3156#include "ccorb.h" 3157#include "ccsdsym.h" 3158#include "maxorb.h" 3159#include "ccsdio.h" 3160! 3161 INTEGER INDEX, ISYMAI, ISYMBJ, ISYMB, NBJ, ISYMJ, KOFF9, NAI 3162 INTEGER IFSTAI, NAIBJ, ISYMAJ, ISYMBI, NBI, NAJBI, ISYMI, NAJ 3163! 3164#if defined (SYS_CRAY) 3165 REAL ZERO, HALF, ONE, TWO, FACCN, FACCP 3166 REAL SCR2(*), OMEGA2(*) 3167#else 3168 DOUBLE PRECISION ZERO, HALF, ONE, TWO, FACCN, FACCP 3169 DOUBLE PRECISION SCR2(*), OMEGA2(*) 3170#endif 3171! 3172 LOGICAL NORMALCONT, PIJCONT, ANTISYM 3173 PARAMETER (ZERO= 0.0D00, HALF= 0.5D00, ONE= 1.0D00, TWO= 2.0D00) 3174! 3175 INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J 3176! 3177 CALL QENTER('CC_PUTC3') 3178! 3179!------------------------------ 3180! Symmetric cont. 3181!------------------------------ 3182! 3183 IF (.NOT. ANTISYM) THEN 3184! 3185 IF (NORMALCONT) THEN 3186! 3187 IF ( ISYMAI .EQ. ISYMBJ ) THEN 3188! 3189 DO B = 1,NVIR(ISYMB) 3190! 3191 NBJ = IT1AM(ISYMB,ISYMJ) 3192 * + NVIR(ISYMB)*(J-1) + B 3193 KOFF9 = NT1AM(ISYMBJ)*(NAI - IFSTAI) + NBJ 3194 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 3195 * + INDEX(NAI,NBJ) 3196 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) 3197 * + FACCN * SCR2(KOFF9) 3198C 3199 ENDDO 3200C 3201 ENDIF 3202C 3203 IF ( ISYMAI .LT. ISYMBJ ) THEN 3204C 3205 DO B = 1,NVIR(ISYMB) 3206C 3207 NBJ = IT1AM(ISYMB,ISYMJ) 3208 * + NVIR(ISYMB)*(J-1) + B 3209 KOFF9 = NT1AM(ISYMBJ)*(NAI - IFSTAI) + NBJ 3210 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 3211 * + NT1AM(ISYMAI)*(NBJ - 1) + NAI 3212 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) 3213 * + FACCN * SCR2(KOFF9) 3214C 3215 ENDDO 3216C 3217 ENDIF 3218C 3219 IF ( ISYMBJ .LT. ISYMAI ) THEN 3220C 3221 DO B = 1,NVIR(ISYMB) 3222C 3223 NBJ = IT1AM(ISYMB,ISYMJ) 3224 * + NVIR(ISYMB)*(J-1) + B 3225 KOFF9 = NT1AM(ISYMBJ)*(NAI - IFSTAI) + NBJ 3226 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 3227 * + NT1AM(ISYMBJ)*(NAI - 1) + NBJ 3228 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) 3229 * + FACCN * SCR2(KOFF9) 3230C 3231 ENDDO 3232C 3233 ENDIF 3234! 3235 ENDIF 3236C 3237 IF (PIJCONT) THEN 3238! 3239 IF (ISYMAJ .EQ. ISYMBI) THEN 3240C 3241 DO B = 1,NVIR(ISYMB) 3242C 3243 NBI = IT1AM(ISYMB,ISYMI) 3244 * + NVIR(ISYMB)*(I-1) + B 3245 NBJ = IT1AM(ISYMB,ISYMJ) 3246 * + NVIR(ISYMB)*(J-1) + B 3247 KOFF9 = NT1AM(ISYMBJ)*(NAI - IFSTAI) + NBJ 3248 NAJBI = IT2AM(ISYMAJ,ISYMBI) 3249 * + INDEX(NAJ,NBI) 3250 OMEGA2(NAJBI) = OMEGA2(NAJBI) + FACCP*SCR2(KOFF9) 3251C 3252 ENDDO 3253C 3254 ENDIF 3255C 3256 IF (ISYMAJ .LT. ISYMBI) THEN 3257C 3258 DO B = 1,NVIR(ISYMB) 3259C 3260 NBI = IT1AM(ISYMB,ISYMI) 3261 * + NVIR(ISYMB)*(I-1) + B 3262 NBJ = IT1AM(ISYMB,ISYMJ) 3263 * + NVIR(ISYMB)*(J-1) + B 3264 KOFF9 = NT1AM(ISYMBJ)*(NAI - IFSTAI) + NBJ 3265 NAJBI = IT2AM(ISYMAJ,ISYMBI) 3266 * + NT1AM(ISYMAJ)*(NBI - 1) 3267 * + NAJ 3268 OMEGA2(NAJBI) = OMEGA2(NAJBI) + FACCP*SCR2(KOFF9) 3269C 3270 ENDDO 3271C 3272 ENDIF 3273C 3274 IF (ISYMBI .LT. ISYMAJ) THEN 3275C 3276 DO B = 1,NVIR(ISYMB) 3277C 3278 NBI = IT1AM(ISYMB,ISYMI) 3279 * + NVIR(ISYMB)*(I-1) + B 3280 NBJ = IT1AM(ISYMB,ISYMJ) 3281 * + NVIR(ISYMB)*(J-1) + B 3282 KOFF9 = NT1AM(ISYMBJ)*(NAI - IFSTAI) + NBJ 3283 NAJBI = IT2AM(ISYMAJ,ISYMBI) 3284 * + NT1AM(ISYMBI)*(NAJ - 1) 3285 * + NBI 3286 OMEGA2(NAJBI) = OMEGA2(NAJBI) + FACCP*SCR2(KOFF9) 3287C 3288 ENDDO 3289C 3290 ENDIF 3291C 3292 ENDIF 3293! 3294!------------------------- 3295! ANTISYM cont. 3296!------------------------- 3297! 3298 ELSE 3299! 3300 IF (NORMALCONT) THEN 3301! 3302 IF ( ISYMAI .EQ. ISYMBJ ) THEN 3303! 3304 DO B = 1,NVIR(ISYMB) 3305! 3306 NBI = IT1AM(ISYMB,ISYMI) 3307 * + NVIR(ISYMB)*(I-1) + B 3308 NBJ = IT1AM(ISYMB,ISYMJ) 3309 * + NVIR(ISYMB)*(J-1) + B 3310 KOFF9 = NT1AM(ISYMBJ)*(NAI - IFSTAI) + NBJ 3311 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 3312 * + INDEX(NAI,NBJ) 3313 IF (NAI .GT. NBJ) THEN 3314 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) 3315 * + FACCN * SCR2(KOFF9) 3316 ELSE IF (NAI .LT. NBJ) THEN 3317 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) 3318 * - FACCN * SCR2(KOFF9) 3319 ENDIF 3320! 3321 ENDDO 3322! 3323 ENDIF 3324! 3325 IF ( ISYMAI .LT. ISYMBJ ) THEN 3326C 3327 DO B = 1,NVIR(ISYMB) 3328C 3329 NBJ = IT1AM(ISYMB,ISYMJ) 3330 * + NVIR(ISYMB)*(J-1) + B 3331 KOFF9 = NT1AM(ISYMBJ)*(NAI - IFSTAI) + NBJ 3332 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 3333 * + NT1AM(ISYMAI)*(NBJ - 1) + NAI 3334 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) 3335 * - FACCN * SCR2(KOFF9) 3336C 3337 ENDDO 3338C 3339 ENDIF 3340C 3341 IF ( ISYMAI .GT. ISYMBJ ) THEN 3342C 3343 DO B = 1,NVIR(ISYMB) 3344C 3345 NBJ = IT1AM(ISYMB,ISYMJ) 3346 * + NVIR(ISYMB)*(J-1) + B 3347 KOFF9 = NT1AM(ISYMBJ)*(NAI - IFSTAI) + NBJ 3348 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 3349 * + NT1AM(ISYMBJ)*(NAI - 1) + NBJ 3350 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) 3351 * + FACCN * SCR2(KOFF9) 3352C 3353 ENDDO 3354C 3355 ENDIF 3356! 3357 ENDIF 3358! 3359 IF (PIJCONT) THEN 3360! 3361 IF (ISYMAJ .EQ. ISYMBI) THEN 3362C 3363 DO B = 1,NVIR(ISYMB) 3364C 3365 NBI = IT1AM(ISYMB,ISYMI) 3366 * + NVIR(ISYMB)*(I-1) + B 3367 NBJ = IT1AM(ISYMB,ISYMJ) 3368 * + NVIR(ISYMB)*(J-1) + B 3369 KOFF9 = NT1AM(ISYMBJ)*(NAI - IFSTAI) + NBJ 3370 NAJBI = IT2AM(ISYMAJ,ISYMBI) 3371 * + INDEX(NAJ,NBI) 3372! 3373 IF (NAJ .GT. NBI) THEN 3374 OMEGA2(NAJBI) = OMEGA2(NAJBI) + FACCP*SCR2(KOFF9) 3375 ELSE IF (NAJ .LT. NBI) THEN 3376 OMEGA2(NAJBI) = OMEGA2(NAJBI) - FACCP*SCR2(KOFF9) 3377 ENDIF 3378! 3379 ENDDO 3380! 3381 ENDIF 3382C 3383 IF (ISYMAJ .GT. ISYMBI) THEN 3384C 3385 DO B = 1,NVIR(ISYMB) 3386C 3387 NBI = IT1AM(ISYMB,ISYMI) 3388 * + NVIR(ISYMB)*(I-1) + B 3389 NBJ = IT1AM(ISYMB,ISYMJ) 3390 * + NVIR(ISYMB)*(J-1) + B 3391 KOFF9 = NT1AM(ISYMBJ)*(NAI - IFSTAI) + NBJ 3392 NAJBI = IT2AM(ISYMAJ,ISYMBI) 3393 * + NT1AM(ISYMBI)*(NAJ - 1) 3394 * + NBI 3395! 3396 OMEGA2(NAJBI) = OMEGA2(NAJBI) + FACCP*SCR2(KOFF9) 3397C 3398 ENDDO 3399C 3400 ENDIF 3401C 3402 IF (ISYMAJ .LT. ISYMBI) THEN 3403C 3404 DO B = 1,NVIR(ISYMB) 3405C 3406 NBI = IT1AM(ISYMB,ISYMI) 3407 * + NVIR(ISYMB)*(I-1) + B 3408 NBJ = IT1AM(ISYMB,ISYMJ) 3409 * + NVIR(ISYMB)*(J-1) + B 3410 KOFF9 = NT1AM(ISYMBJ)*(NAI - IFSTAI) + NBJ 3411 NAJBI = IT2AM(ISYMAJ,ISYMBI) 3412 * + NT1AM(ISYMAJ)*(NBI - 1) 3413 * + NAJ 3414! 3415 OMEGA2(NAJBI) = OMEGA2(NAJBI) - FACCP*SCR2(KOFF9) 3416C 3417 ENDDO 3418C 3419 ENDIF 3420C 3421 ENDIF 3422! 3423 ENDIF 3424! 3425 CALL QEXIT('CC_PUTC3') 3426! 3427 RETURN 3428 END 3429C /* Deck ccrhs_dio */ 3430 SUBROUTINE CCRHS3_DIO(OMEGA2,OM2CONT,T2AM,XLAMDH,WORK,LWORK, 3431 * ISYVEC,ISYDIM,LUD,DFIL,IV,IOPT,FACD, 3432 * ANTISYM,OMEGA22,FACD2) 3433C 3434C asm 20-aug-1994 3435C 3436C Ove Christiansen 30-7-1995: Modified to account for general 3437C non. total symmetric vectors (ISYVEC) 3438C and intermediates (ISYDIM). 3439C LUD and DFIL is 3440C used to control from which file the 3441C intermediate is obtained. 3442C 3443C if iopt = 1 the D intermediate 3444C is assumed 3445C to be as in energy calc. 3446C 3447C if iopt ne. 1 we use the intermediate 3448C on luc with address given 3449C according to transformed 3450C vector nr iv (iv is not 1 3451C if several vectors are transformed 3452C simultaneously.) 3453C 3454C in energy calc: iv=1,iopt=1 3455C 3456! Kasper Hald 22-3-1999: Generalized to the triplet case and for a 3457! general factor FACD. Have also introduced 3458! the inputvar. OMEGA22, OM2CONT and 3459! FACD2 so can calculate both 3460! the symmetric and antisymmetric of a 3461! given D-term. 3462C PURPOSE: 3463C Calculate the D-term making I/O 3464C 3465 IMPLICIT NONE 3466#include "priunit.h" 3467#include "ccorb.h" 3468#include "ccsdsym.h" 3469#include "maxorb.h" 3470#include "ccsdio.h" 3471! 3472 INTEGER LWORK, INDEX, ISYVEC, ISAIBJ, ISYMAI, ISYMBJ, ISYMCK 3473 INTEGER ISYMDK, NT1AI, LENAI, LENMIN, NDISAI, NBATAI 3474 INTEGER ILSTAI, IBATAI, IFSTAI, KSCR1, KSCR2, KEND, LWRK1, KOFF1 3475 INTEGER ISYDEL, ISYMK, IDELTA, ID, IOPT, IOFF, IV, LEN, IERR 3476 INTEGER NAI, KAI, KOFF2, KOFF3, ISYDIM, ISYMC, NBASD, NVIRC 3477 INTEGER KOFF4, KOFF5, KOFF6, NT1BJ, NT1CK, KOFF7, KOFF8, LUD 3478! 3479#if defined (SYS_CRAY) 3480 REAL ZERO, HALF, ONE, TWO, FACD, FACD2 3481 REAL OMEGA2(*), T2AM(*), XLAMDH(*), WORK(LWORK), OMEGA22(*) 3482#else 3483 DOUBLE PRECISION ZERO, HALF, ONE, TWO, FACD, FACD2 3484 DOUBLE PRECISION OMEGA2(*), T2AM(*), XLAMDH(*), WORK(LWORK) 3485 DOUBLE PRECISION OMEGA22(*) 3486#endif 3487! 3488 PARAMETER (ZERO= 0.0D00, HALF= 0.5D00, ONE= 1.0D00, TWO= 2.0D00) 3489 CHARACTER DFIL*(*) 3490! 3491 LOGICAL ANTISYM, OM2CONT, LOGIC1 3492C 3493C INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J 3494C 3495 CALL QENTER('CCRHS3_DIO') 3496C 3497 IF (OMEGSQ) THEN 3498 WRITE(LUPRI,*) 'I/O in D-term not implemented '// 3499 & 'for square Omega2' 3500 CALL QUIT('OMEGSQ = .TRUE. in CCRHS3_DIO') 3501 END IF 3502C 3503 ISAIBJ = MULD2H(ISYVEC,ISYDIM) 3504C 3505 DO 100 ISYMAI = 1,NSYM 3506C 3507 IF (NT1AM(ISYMAI) .EQ. 0) GOTO 100 3508C 3509C 3510 ISYMBJ = MULD2H(ISYMAI,ISAIBJ) 3511 ISYMCK = MULD2H(ISYVEC,ISYMBJ) 3512 ISYMDK = MULD2H(ISYDIM,ISYMAI) 3513C 3514C------------------------ 3515C Batch structure. 3516C------------------------ 3517C 3518 NT1AI = NT1AM(ISYMAI) 3519C 3520 LENAI = NT1AO(ISYMDK) 3521 LENMIN = 2*LENAI 3522 IF (LENMIN .EQ. 0) GOTO 100 3523C 3524 NDISAI = LWORK / LENMIN 3525 IF (NDISAI .LT. 1) THEN 3526 CALL QUIT('Insufficient space for allocation in CCRHS3_DIO') 3527 END IF 3528 NDISAI = MIN(NDISAI,NT1AI) 3529C 3530 NBATAI = (NT1AI - 1) / NDISAI + 1 3531C 3532C-------------------------- 3533C Loop over batches. 3534C-------------------------- 3535C 3536 ILSTAI = 0 3537 DO 110 IBATAI = 1,NBATAI 3538C 3539 IFSTAI = ILSTAI + 1 3540 ILSTAI = ILSTAI + NDISAI 3541 IF (ILSTAI .GT. NT1AI) THEN 3542 ILSTAI = NT1AI 3543 NDISAI = ILSTAI - IFSTAI + 1 3544 END IF 3545C 3546C----------------------------- 3547C Memory allocation. 3548C----------------------------- 3549C 3550 KSCR1 = 1 3551 KSCR2 = KSCR1 + NDISAI*NT1AO(ISYMDK) 3552 KEND = KSCR2 + NDISAI*NT1AO(ISYMDK) 3553 LWRK1 = LWORK - KEND 3554C 3555 IF (LWRK1 .LT. 0) THEN 3556 CALL QUIT('Insufficient space for '// 3557 & 'allocation in CCRHS_DIO') 3558 END IF 3559C 3560C---------------------------------- 3561C Construct P(del k,#ai). 3562C---------------------------------- 3563C 3564 KOFF1 = KSCR1 3565 DO 120 ISYDEL = 1,NSYM 3566C 3567 ISYMK = MULD2H(ISYDEL,ISYMDK) 3568C 3569 DO 130 IDELTA = 1,NBAS(ISYDEL) 3570C 3571 ID = IDELTA + IBAS(ISYDEL) 3572C 3573!------------------------------------ 3574! IOPT part. 3575!------------------------------------ 3576! 3577 IF (IOPT .EQ. 1 ) THEN 3578 IOFF = IT2DEL(ID) + IT2BCT(ISYMK,ISYMAI) 3579 * + NRHF(ISYMK)*(IFSTAI - 1) + 1 3580 ELSE 3581 IOFF = IT2DLR(ID,IV) + IT2BCT(ISYMK,ISYMAI) 3582 * + NRHF(ISYMK)*(IFSTAI - 1) + 1 3583 ENDIF 3584C 3585 LEN = NDISAI*NRHF(ISYMK) 3586C 3587 IF (LEN .GT. 0) THEN 3588 CALL GETWA2(LUD,DFIL,WORK(KOFF1),IOFF,LEN) 3589 ENDIF 3590C 3591 DO 140 NAI = IFSTAI,ILSTAI 3592C 3593 KAI = NAI - IFSTAI + 1 3594C 3595 KOFF2 = KOFF1 + NRHF(ISYMK)*(KAI - 1) 3596 KOFF3 = KSCR2 + NT1AO(ISYMDK)*(KAI - 1) 3597 * + IT1AO(ISYDEL,ISYMK) + IDELTA - 1 3598C 3599 CALL DCOPY(NRHF(ISYMK),WORK(KOFF2),1,WORK(KOFF3), 3600 * NBAS(ISYDEL)) 3601C 3602 140 CONTINUE 3603C 3604 KOFF1 = KOFF1 + LEN 3605C 3606 130 CONTINUE 3607 120 CONTINUE 3608C 3609C-------------------------------------- 3610C Transform delta index to c. 3611C-------------------------------------- 3612C 3613 DO 150 NAI = IFSTAI,ILSTAI 3614C 3615 KAI = NAI - IFSTAI + 1 3616C 3617 DO 160 ISYMC = 1,NSYM 3618C 3619 ISYDEL = ISYMC 3620 ISYMK = MULD2H(ISYMC,ISYMCK) 3621C 3622 NBASD = MAX(NBAS(ISYDEL),1) 3623 NVIRC = MAX(NVIR(ISYMC),1) 3624C 3625 KOFF4 = ILMVIR(ISYDEL) + 1 3626 KOFF5 = KSCR2 + NT1AO(ISYMDK)*(KAI - 1) 3627 * + IT1AO(ISYDEL,ISYMK) 3628 KOFF6 = KSCR1 + NT1AM(ISYMCK)*(KAI - 1) 3629 * + IT1AM(ISYMC,ISYMK) 3630C 3631 CALL DGEMM('T','N',NVIR(ISYMC),NRHF(ISYMK), 3632 * NBAS(ISYDEL),ONE,XLAMDH(KOFF4),NBASD, 3633 * WORK(KOFF5),NBASD,ZERO,WORK(KOFF6), 3634 * NVIRC) 3635C 3636 160 CONTINUE 3637 150 CONTINUE 3638C 3639C-------------------------------------------- 3640C Contract P(ck,#ai) with T(bj,ck). 3641C-------------------------------------------- 3642C 3643 NT1BJ = MAX(NT1AM(ISYMBJ),1) 3644 NT1CK = MAX(NT1AM(ISYMCK),1) 3645C 3646 KOFF7 = IT2SQ(ISYMBJ,ISYMCK) + 1 3647C 3648 CALL DGEMM('N','N',NT1AM(ISYMBJ),NDISAI,NT1AM(ISYMCK), 3649 * ONE,T2AM(KOFF7),NT1BJ,WORK(KSCR1),NT1CK, 3650 * ZERO,WORK(KSCR2),NT1BJ) 3651C 3652C------------------------------ 3653C Scale the diagonal. 3654C------------------------------ 3655C 3656 IF (OM2CONT) THEN 3657! 3658 IF (ISYMBJ .EQ. ISYMAI) THEN 3659C 3660 DO NAI = IFSTAI,ILSTAI 3661 KOFF8 = KSCR2 + NT1AM(ISYMBJ)*(NAI-IFSTAI) + NAI - 1 3662 WORK(KOFF8) = TWO * WORK(KOFF8) 3663 ENDDO 3664C 3665 END IF 3666C 3667C----------------------------------------------- 3668C Add the result to the packed omega2. 3669! This term is SYMMETRIC in (ai,bj) 3670C----------------------------------------------- 3671! 3672 LOGIC1 = .FALSE. 3673! 3674 DO 180 NAI = IFSTAI,ILSTAI 3675! 3676 CALL CC_PUTD3(WORK(KSCR2),OMEGA2,ISYMAI,ISYMBJ,NAI, 3677 * IFSTAI,FACD,LOGIC1) 3678 180 CONTINUE 3679! 3680 ENDIF 3681! 3682!------------------------------------ 3683! Zero the diagonal 3684!------------------------------------ 3685! 3686 IF (ANTISYM) THEN 3687! 3688 IF (ISYMBJ .EQ. ISYMAI) THEN 3689C 3690 DO 190 NAI = IFSTAI,ILSTAI 3691 KOFF8 = KSCR2 + NT1AM(ISYMBJ)*(NAI-IFSTAI) + NAI - 1 3692 WORK(KOFF8) = ZERO 3693 190 CONTINUE 3694C 3695 END IF 3696C 3697C-------------------------------------------------- 3698C Add the result to the packed omega2. 3699! This term is ANTISYMMETRIC in (ai,bj) 3700C-------------------------------------------------- 3701! 3702 LOGIC1 = .TRUE. 3703! 3704 DO NAI = IFSTAI,ILSTAI 3705! 3706 CALL CC_PUTD3(WORK(KSCR2),OMEGA22,ISYMAI,ISYMBJ,NAI, 3707 * IFSTAI,FACD2,LOGIC1) 3708 ENDDO 3709! 3710 ENDIF 3711! 3712 110 CONTINUE 3713 100 CONTINUE 3714C 3715 CALL QEXIT('CCRHS3_DIO') 3716C 3717 RETURN 3718 END 3719C /* Deck cc_putd3 */ 3720 SUBROUTINE CC_PUTD3(SCR2,OMEGA2,ISYMAI,ISYMBJ,NAI,IFSTAI,FACD, 3721 * ANTISYM) 3722C 3723C Ove Christiansen 30-10-1995: Put in D contribution in omega vector 3724C avoid troble on cray 3725C with optimization. 3726C 3727! Kasper Hald 22-3-1999: Generalized to the triplet case with 3728! ANTISYM and FACD. 3729 IMPLICIT NONE 3730! 3731#include "priunit.h" 3732#include "ccorb.h" 3733#include "ccsdsym.h" 3734#include "maxorb.h" 3735#include "ccsdio.h" 3736! 3737 INTEGER INDEX, ISYMAI, ISYMBJ, NBJ, KOFF9, NAI, IFSTAI, NAIBJ 3738! 3739#if defined (SYS_CRAY) 3740 REAL ZERO, HALF, ONE, TWO, FACD 3741 REAL SCR2(*), OMEGA2(*) 3742#else 3743 DOUBLE PRECISION ZERO, HALF, ONE, TWO, FACD 3744 DOUBLE PRECISION SCR2(*), OMEGA2(*) 3745#endif 3746 PARAMETER (ZERO= 0.0D00, HALF= 0.5D00, ONE= 1.0D00, TWO= 2.0D00) 3747 LOGICAL ANTISYM 3748! 3749 INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J 3750! 3751 CALL QENTER('CC_PUTD3') 3752! 3753 IF (.NOT. ANTISYM) THEN 3754! 3755 IF ( ISYMAI .EQ. ISYMBJ) THEN 3756 DO 190 NBJ = 1,NT1AM(ISYMBJ) 3757! 3758 KOFF9 = NT1AM(ISYMBJ)*(NAI-IFSTAI)+ NBJ 3759 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 3760 * + INDEX(NAI,NBJ) 3761! 3762 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) + FACD*SCR2(KOFF9) 3763! 3764 190 CONTINUE 3765! 3766 ENDIF 3767! 3768 IF ( ISYMAI .LT. ISYMBJ) THEN 3769 DO 200 NBJ = 1,NT1AM(ISYMBJ) 3770! 3771 KOFF9 = NT1AM(ISYMBJ)*(NAI-IFSTAI)+ NBJ 3772 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 3773 * + NT1AM(ISYMAI)*(NBJ - 1) + NAI 3774 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) + FACD*SCR2(KOFF9) 3775! 3776 200 CONTINUE 3777! 3778 ENDIF 3779! 3780 IF (ISYMBJ .LT. ISYMAI) THEN 3781 DO 210 NBJ = 1,NT1AM(ISYMBJ) 3782! 3783 KOFF9 = NT1AM(ISYMBJ)*(NAI-IFSTAI)+ NBJ 3784 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 3785 * + NT1AM(ISYMBJ)*(NAI - 1) + NBJ 3786 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) + FACD*SCR2(KOFF9) 3787! 3788 210 CONTINUE 3789! 3790 ENDIF 3791! 3792!----------------------- 3793! ANTISYM Cont. 3794!----------------------- 3795! 3796 ELSE 3797! 3798 IF ( ISYMAI .EQ. ISYMBJ) THEN 3799! 3800 DO NBJ = 1,NT1AM(ISYMBJ) 3801 KOFF9 = NT1AM(ISYMBJ)*(NAI-IFSTAI)+ NBJ 3802 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 3803 * + INDEX(NAI,NBJ) 3804! 3805 IF (NAI .LT. NBJ) THEN 3806 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) - FACD*SCR2(KOFF9) 3807 ELSE IF (NAI .GT. NBJ) THEN 3808 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) + FACD*SCR2(KOFF9) 3809 ENDIF 3810! 3811 ENDDO 3812! 3813 ENDIF 3814! 3815 IF ( ISYMAI .LT. ISYMBJ) THEN 3816! 3817 DO NBJ = 1,NT1AM(ISYMBJ) 3818! 3819 KOFF9 = NT1AM(ISYMBJ)*(NAI-IFSTAI)+ NBJ 3820 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 3821 * + NT1AM(ISYMAI)*(NBJ - 1) + NAI 3822 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) - FACD*SCR2(KOFF9) 3823! 3824 ENDDO 3825! 3826 ENDIF 3827! 3828 IF (ISYMBJ .LT. ISYMAI) THEN 3829 DO NBJ = 1,NT1AM(ISYMBJ) 3830! 3831 KOFF9 = NT1AM(ISYMBJ)*(NAI-IFSTAI)+ NBJ 3832 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 3833 * + NT1AM(ISYMBJ)*(NAI - 1) + NBJ 3834 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) + FACD*SCR2(KOFF9) 3835! 3836 ENDDO 3837! 3838 ENDIF 3839! 3840 ENDIF 3841! 3842 CALL QEXIT('CC_PUTD3') 3843! 3844 RETURN 3845 END 3846C /* Deck ccrhs_h3 */ 3847 SUBROUTINE CCRHS_H3(DSRHF,OMEGA1,XLAMDP,XLAMDH,SCRM, 3848 * WORK,LWORK,ISYDIS,ISYDEL,ISYMTR,FACH) 3849C 3850C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 3851C Written by Henrik Koch & Ove Christiansen 19-Jan-1994 3852C Generalized to do linear transformation parts by 3853C OC 30-1-1995 3854! Generalized to a general factor FACH 3855! Kasper Hald 25-3-99 3856! 3857C Purpose: Calculate H-term. 3858C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 3859C 3860 IMPLICIT NONE 3861! 3862#include "priunit.h" 3863#include "ccorb.h" 3864#include "ccsdsym.h" 3865! 3866 INTEGER LWORK, ISYDIS, ISYDEL, ISYMTR 3867! 3868#if defined (SYS_CRAY) 3869 REAL FACH 3870 REAL DSRHF(*), OMEGA1(*), XLAMDH(*), WORK(LWORK) 3871 REAL XLAMDP(*), SCRM(*) 3872#else 3873 DOUBLE PRECISION FACH 3874 DOUBLE PRECISION DSRHF(*), OMEGA1(*), XLAMDH(*), WORK(LWORK) 3875 DOUBLE PRECISION XLAMDP(*), SCRM(*) 3876#endif 3877C 3878 CALL QENTER('CCRHS_H3') 3879C 3880C-------------------------------- 3881C Calculate the contribution. 3882C-------------------------------- 3883C 3884 CALL CCRHS_H31(DSRHF,OMEGA1,SCRM,XLAMDP,XLAMDH,WORK,LWORK, 3885 * ISYDIS,ISYDEL,ISYMTR,FACH) 3886C 3887 CALL QEXIT('CCRHS_H3') 3888C 3889 RETURN 3890 END 3891 SUBROUTINE CCRHS_H31(DSRHF,OMEGA1,SCRM,XLAMDP,XLAMDH,WORK,LWORK, 3892 * ISYDIS,ISYDEL,ISYMTR,FACH) 3893C 3894C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 3895C Written by Henrik Koch & Ove Christiansen 19-Jan-1994 3896C Generalized to do linear transformation parts by 3897C OC 30-1-1995 3898C 3899C Purpose: Calculate H-term. 3900C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 3901C 3902 IMPLICIT NONE 3903! 3904#include "priunit.h" 3905#include "ccorb.h" 3906#include "ccsdsym.h" 3907! 3908 INTEGER LWORK, INDEX, ISYAKL, ISYMTR, ISYDEL, ISYML, ISYMGB 3909 INTEGER ISYMAK, ISYMKI, KSCR1, KEND1, LWRK1, KOFF1, ISYMI 3910 INTEGER ISYMB, ISYMG, ISYMK, ISYMA, KSCR2, KSCR3, KEND2 3911 INTEGER LWRK2, NBASG, NBASB, NRHFK, NVIRA, KOFF2, KOFF3 3912 INTEGER KOFF4, KOFF5, KOFF6, ISYDIS 3913! 3914#if defined (SYS_CRAY) 3915 REAL ZERO, ONE, FACH 3916 REAL DSRHF(*),OMEGA1(*),SCRM(*) 3917 REAL XLAMDP(*),XLAMDH(*),WORK(LWORK) 3918#else 3919 DOUBLE PRECISION ZERO, ONE, FACH 3920 DOUBLE PRECISION DSRHF(*),OMEGA1(*),SCRM(*) 3921 DOUBLE PRECISION XLAMDP(*),XLAMDH(*),WORK(LWORK) 3922#endif 3923 PARAMETER(ZERO=0.0D00,ONE=1.0D00) 3924C 3925C INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J 3926C 3927 CALL QENTER('CCRHS_H31') 3928C 3929C-------------------------------------- 3930C Calculate contribution. 3931C-------------------------------------- 3932C 3933 ISYAKL = MULD2H(ISYMTR,ISYDEL) 3934C 3935 DO 100 ISYML = 1,NSYM 3936C 3937 ISYMGB = MULD2H(ISYML,ISYDIS) 3938 ISYMAK = MULD2H(ISYML,ISYAKL) 3939 ISYMKI = ISYMGB 3940C 3941 KSCR1 = 1 3942 KEND1 = KSCR1 + N2BST(ISYMGB) 3943 LWRK1 = LWORK - KEND1 3944C 3945 IF (LWRK1 .LT. 0) THEN 3946 WRITE(LUPRI,*) 'Need : ',KEND1,'Available : ',LWORK 3947 CALL QUIT('Insufficient space in CCRHS_H1') 3948 ENDIF 3949 DO 110 L = 1,NRHF(ISYML) 3950C 3951 KOFF1 = IDSRHF(ISYMGB,ISYML) + NNBST(ISYMGB)*(L - 1) + 1 3952 CALL CCSD_SYMSQ(DSRHF(KOFF1),ISYMGB,WORK(KSCR1)) 3953C 3954 DO 120 ISYMI = 1,NSYM 3955C 3956 ISYMB = ISYMI 3957 ISYMG = MULD2H(ISYMB,ISYMGB) 3958 ISYMK = ISYMG 3959 ISYMA = MULD2H(ISYMK,ISYMAK) 3960C 3961 KSCR2 = KEND1 3962 KSCR3 = KSCR2 + NBAS(ISYMG)*NRHF(ISYMI) 3963 KEND2 = KSCR3 + NRHF(ISYMK)*NRHF(ISYMI) 3964 LWRK2 = LWORK - KEND2 3965C 3966 IF (LWRK2 .LT. 0) THEN 3967 WRITE(LUPRI,*) 'Need : ',KEND2,'Available : ',LWORK 3968 CALL QUIT('Insufficient space in CCRHS_H1') 3969 ENDIF 3970C 3971 NBASG = MAX(NBAS(ISYMG),1) 3972 NBASB = MAX(NBAS(ISYMB),1) 3973 NRHFK = MAX(NRHF(ISYMK),1) 3974 NVIRA = MAX(NVIR(ISYMA),1) 3975C 3976 KOFF2 = KSCR1 + IAODIS(ISYMG,ISYMB) 3977 KOFF3 = ILMRHF(ISYMI) + 1 3978C 3979 CALL DGEMM('N','N',NBAS(ISYMG),NRHF(ISYMI),NBAS(ISYMB), 3980 * ONE,WORK(KOFF2),NBASG,XLAMDH(KOFF3),NBASB, 3981 * ZERO,WORK(KSCR2),NBASG) 3982C 3983 KOFF4 = ILMRHF(ISYMK) + 1 3984C 3985 CALL DGEMM('T','N',NRHF(ISYMK),NRHF(ISYMI),NBAS(ISYMG), 3986 * ONE,XLAMDP(KOFF4),NBASG,WORK(KSCR2),NBASG, 3987 * ZERO,WORK(KSCR3),NRHFK) 3988C 3989 KOFF5 = IT2BCD(ISYMAK,ISYML) + NT1AM(ISYMAK)*(L - 1) 3990 * + IT1AM(ISYMA,ISYMK) + 1 3991 KOFF6 = IT1AM(ISYMA,ISYMI) + 1 3992C 3993 CALL DGEMM('N','N',NVIR(ISYMA),NRHF(ISYMI),NRHF(ISYMK), 3994 * -FACH,SCRM(KOFF5),NVIRA,WORK(KSCR3),NRHFK, 3995 * ONE,OMEGA1(KOFF6),NVIRA) 3996C 3997 120 CONTINUE 3998C 3999 110 CONTINUE 4000C 4001 100 CONTINUE 4002C 4003 CALL QEXIT('CCRHS_H31') 4004C 4005 RETURN 4006 END 4007C /* Deck ccrhs_g */ 4008 SUBROUTINE CCRHS_G3(DSRHF,OMEGA1,XLAMP1,ISYMP1,XLAMH1,ISYMH1,SCRM, 4009 * WORK,LWORK,ISYDIS,ISYDEL,ISYMTR,FACG) 4010C 4011C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 4012C Written by Henrik Koch & Ove Christiansen 19-Jan-1994 4013C Generalized to calculated term of linear transformation 4014C and handle different transformations on integral indices by 4015C OC 30-1-1995 4016C 4017C G(a,i) = sum(cdk)[t(ci,dk)*Lackd] 4018C G(a,i)for fixed del = sum(ck)[M(ci,k)*L(alfa gamma k] 4019C 4020C XLAMP1 is the transformation matrix for a ; XLAMP or a oneindex 4021C transformed 4022C XLAMH1 is the transformation matrix for c ; XLAMH or a oneindex 4023C transformed. 4024C DSRHF is the (alfa gamma | k) array for a given delta. 4025C 4026C not implemented yet with DSRHF and SCRM index transformed. 4027C 4028C tested for energy with symmetry: ordinary XLAM matrices 4029C - OC 10-2-1995 4030C tested for linear transformation without symmetry. 4031C - OC spring 95 4032C 4033C Kasper Hald 25-3-1999 : Generalized to a general factor FACG 4034C 4035C Purpose: Calculate G-term. 4036C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 4037! 4038 IMPLICIT NONE 4039! 4040#include "priunit.h" 4041#include "ccorb.h" 4042#include "ccsdsym.h" 4043! 4044 INTEGER LWORK, ISYINT, ISYMH1, ISYALI, KSCR1, KEND1 4045 INTEGER LWRK1, ISYMTR, ISYMP1, ISYDIS, ISYDEL 4046! 4047#if defined (SYS_CRAY) 4048 REAL FACG 4049 REAL DSRHF(*), OMEGA1(*), XLAMP1(*) 4050 REAL WORK(LWORK), XLAMH1(*), SCRM(*) 4051#else 4052 DOUBLE PRECISION FACG 4053 DOUBLE PRECISION DSRHF(*), OMEGA1(*), XLAMP1(*) 4054 DOUBLE PRECISION WORK(LWORK), XLAMH1(*), SCRM(*) 4055#endif 4056C 4057 CALL QENTER('CCRHS_G3') 4058C 4059C------------------------ 4060C Dynamic allocation. 4061C------------------------ 4062C 4063 ISYINT = MULD2H(ISYMH1,ISYMOP) 4064 ISYALI = MULD2H(ISYINT,ISYMTR) 4065C 4066 KSCR1 = 1 4067 KEND1 = KSCR1 + NT1AO(ISYALI) 4068 LWRK1 = LWORK - KEND1 4069C 4070 IF (LWRK1 .LT. 0) THEN 4071 WRITE(LUPRI,*) 'Need : ',KEND1,'Available : ',LWORK 4072 CALL QUIT('Insufficient space in CCRHS_G') 4073 ENDIF 4074C 4075C-------------------------------- 4076C Calculate the contribution. 4077C-------------------------------- 4078C 4079 CALL CCRHS_G31(DSRHF,OMEGA1,SCRM,XLAMP1,ISYMP1,XLAMH1,ISYMH1, 4080 * WORK(KSCR1),WORK(KEND1),LWRK1,ISYDIS,ISYDEL,ISYMTR, 4081 * FACG) 4082C 4083C 4084 CALL QEXIT('CCRHS_G3') 4085C 4086 RETURN 4087 END 4088 SUBROUTINE CCRHS_G31(DSRHF,OMEGA1,SCRM,XLAMP1,ISYMP1,XLAMH1, 4089 * ISYMH1,SCR1,WORK,LWORK,ISYDIS,ISYDEL,ISYMTR,FACG) 4090C 4091C 4092C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 4093C Written by Henrik Koch & Ove Christiansen 19-Jan-1994 4094C Generalized to calculated term of linear transformation 4095C by OC 30-1-1995 4096! FACG by KH 25-3-99 4097! 4098C Purpose: Calculate G-term. 4099C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 4100C 4101 IMPLICIT NONE 4102! 4103#include "priunit.h" 4104#include "ccorb.h" 4105#include "ccsdsym.h" 4106! 4107 INTEGER LWORK, INDEX, ISYINT, ISYMH1, ISYALI, ISYMTR, ISYMAI 4108 INTEGER ISYMP1, ISYDEL, ISYCIK, ISYMK, ISYDIS, ISYMAG 4109 INTEGER ISYMCI, ISYMGI, KSCR10, KEND1, LWRK1, KOFF1, ISYMI 4110 INTEGER ISYMG, ISYMA, ISYMC, NBASG, NBASA, NVIRC, KSCR11 4111 INTEGER KEND2, LWRK2, KOFF2, KOFF3, KOFF4, KOFF6, ISYMAL, NVIRA 4112! 4113#if defined (SYS_CRAY) 4114 REAL ZERO, ONE, TWO, FACG 4115 REAL DSRHF(*), OMEGA1(*), SCRM(*), SCR1(*) 4116 REAL XLAMP1(*), XLAMH1(*), WORK(LWORK) 4117#else 4118 DOUBLE PRECISION ZERO, ONE, TWO, FACG 4119 DOUBLE PRECISION DSRHF(*), OMEGA1(*), SCRM(*), SCR1(*) 4120 DOUBLE PRECISION XLAMP1(*), XLAMH1(*), WORK(LWORK) 4121#endif 4122! 4123 PARAMETER(ZERO=0.0D00,ONE=1.0D00) 4124 PARAMETER(TWO=2.0D00) 4125C 4126C INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J 4127C 4128 CALL QENTER('CCRHS_G31') 4129C 4130 ISYINT = MULD2H(ISYMH1,ISYMOP) 4131 ISYALI = MULD2H(ISYINT,ISYMTR) 4132 ISYMAI = MULD2H(ISYALI,ISYMP1) 4133 ISYCIK = MULD2H(ISYMTR,ISYDEL) 4134C 4135 CALL DZERO(SCR1,NT1AO(ISYMAI)) 4136C 4137 DO 100 ISYMK = 1,NSYM 4138C 4139 ISYMAG = MULD2H(ISYMK,ISYDIS) 4140 ISYMCI = MULD2H(ISYMK,ISYCIK) 4141 ISYMGI = MULD2H(ISYALI,ISYMAG) 4142C 4143 KSCR10 = 1 4144 KEND1 = KSCR10 + N2BST(ISYMAG) 4145 LWRK1 = LWORK - KEND1 4146C 4147 IF (LWRK1 .LT. 0) THEN 4148 WRITE(LUPRI,*) 'Need : ',KEND1,'Available : ',LWORK 4149 CALL QUIT('Insufficient space in CCRHS_G1') 4150 ENDIF 4151C 4152 DO 110 K = 1,NRHF(ISYMK) 4153C 4154 KOFF1 = IDSRHF(ISYMAG,ISYMK) + NNBST(ISYMAG)*(K - 1) + 1 4155 CALL CCSD_SYMSQ(DSRHF(KOFF1),ISYMAG,WORK(KSCR10)) 4156C 4157 DO 120 ISYMI = 1,NSYM 4158C 4159 ISYMG = MULD2H(ISYMI,ISYMGI) 4160 ISYMA = MULD2H(ISYMG,ISYMAG) 4161 ISYMC = ISYMG 4162C 4163 NBASG = MAX(NBAS(ISYMG),1) 4164 NBASA = MAX(NBAS(ISYMA),1) 4165 NVIRC = MAX(NVIR(ISYMC),1) 4166C 4167 KSCR11 = KEND1 4168 KEND2 = KSCR11 + NBAS(ISYMG)*NRHF(ISYMI) 4169 LWRK2 = LWORK - KEND2 4170C 4171 IF (LWRK2 .LT. 0) THEN 4172 WRITE(LUPRI,*) 'Need : ',KEND2,'Available : ',LWORK 4173 CALL QUIT('Insufficient space in CCRHS_G1') 4174 ENDIF 4175C 4176 KOFF2 = IGLMVI(ISYMG,ISYMC) + 1 4177 KOFF3 = IT2BCD(ISYMCI,ISYMK) + NT1AM(ISYMCI)*(K - 1) 4178 * + IT1AM(ISYMC,ISYMI) + 1 4179C 4180 CALL DGEMM('N','N',NBAS(ISYMG),NRHF(ISYMI),NVIR(ISYMC), 4181 * ONE,XLAMH1(KOFF2),NBASG,SCRM(KOFF3),NVIRC, 4182 * ZERO,WORK(KSCR11),NBASG) 4183C 4184 KOFF4 = KSCR10 + IAODIS(ISYMA,ISYMG) 4185 KOFF6 = IT1AO(ISYMA,ISYMI) + 1 4186C 4187 CALL DGEMM('N','N',NBAS(ISYMA),NRHF(ISYMI),NBAS(ISYMG), 4188 * ONE,WORK(KOFF4),NBASA,WORK(KSCR11),NBASG, 4189 * ONE,SCR1(KOFF6),NBASA) 4190C 4191 120 CONTINUE 4192C 4193 110 CONTINUE 4194C 4195 100 CONTINUE 4196C 4197C---------------------------------------------- 4198C Accumulation into OMEGA1 in the MO basis. 4199C---------------------------------------------- 4200C 4201 DO 200 ISYMI = 1,NSYM 4202C 4203 ISYMA = MULD2H(ISYMI,ISYMAI) 4204 ISYMAL= MULD2H(ISYMI,ISYALI) 4205C 4206 NBASA = MAX(NBAS(ISYMA),1) 4207 NVIRA = MAX(NVIR(ISYMA),1) 4208C 4209 KOFF1 = IGLMVI(ISYMAL,ISYMA) + 1 4210 KOFF2 = IT1AO(ISYMA,ISYMI) + 1 4211 KOFF3 = IT1AM(ISYMA,ISYMI) + 1 4212C 4213 CALL DGEMM('T','N',NVIR(ISYMA),NRHF(ISYMI),NBAS(ISYMA),FACG, 4214 * XLAMP1(KOFF1),NBASA,SCR1(KOFF2),NBASA,ONE, 4215 * OMEGA1(KOFF3),NVIRA) 4216C 4217 200 CONTINUE 4218C 4219 CALL QEXIT('CCRHS_G31') 4220C 4221 RETURN 4222 END 4223C /* Deck cc_rvec3 */ 4224 SUBROUTINE CC_RVEC3(LU,FIL,LLEN,LEN,NR,IDISP,VEC) 4225! 4226! Kasper Hald : April 1. 1999 (And that's not even a joke) 4227! 4228! The routine reads LEN elements from the file FIL with 4229! logical unit number LU. The address is given by the length 4230! of each file multiplied with (NR - 1). In the triplet 4231! case we store different length files so a displacement IDISP 4232! can be given. 4233! 4234 IMPLICIT NONE 4235#if defined (SYS_CRAY) 4236 REAL VEC(*) 4237#else 4238 DOUBLE PRECISION VEC(*) 4239#endif 4240 CHARACTER FIL*(*) 4241 INTEGER LU, LLEN, LEN, NR, IDISP, IOFF, IERR 4242! 4243 CALL QENTER('CC_RVEC3') 4244! 4245 IOFF = 1 + LLEN*(NR-1) + IDISP 4246! 4247 IF (LEN .GT. 0) THEN 4248 CALL GETWA2(LU,FIL,VEC,IOFF,LEN) 4249 ENDIF 4250! 4251 CALL QEXIT('CC_RVEC3') 4252! 4253 RETURN 4254 END 4255C /* Deck cc_wvec3 */ 4256 SUBROUTINE CC_WVEC3(LU,FIL,LLEN,LEN,NR,IDISP,VEC) 4257! 4258! Kasper Hald April 1. 1999 (And that's not even a joke) 4259! 4260! Writes the vector VEC to the file FIL with logical unit number 4261! LU. The address is calculated from LLEN, NR and the displacement 4262! IDISP. 4263! 4264 IMPLICIT NONE 4265! 4266#if defined (SYS_CRAY) 4267 REAL VEC(*) 4268#else 4269 DOUBLE PRECISION VEC(*) 4270#endif 4271 CHARACTER FIL*(*) 4272 INTEGER LU, LLEN, LEN, NR, IDISP, IOFF, IERR 4273! 4274 CALL QENTER('CC_WVEC3') 4275! 4276 IOFF = 1 + LLEN*(NR-1) + IDISP 4277! 4278 IF (LEN .GT. 0) THEN 4279 CALL PUTWA2(LU,FIL,VEC,IOFF,LEN) 4280 ENDIF 4281! 4282 CALL QEXIT('CC_WVEC3') 4283! 4284 RETURN 4285 END 4286C /* Deck ccrhs_t2bt */ 4287 SUBROUTINE CCRHS3_T2BT(T2AM,WORK,LWORK,ISYM,IOPT) 4288C 4289C Alfredo Sanchez and Henrik Koch 30-July 1994 4290C 4291C Kasper Hald 17-may 1999 4292C 4293C Backtransform -exchange 4294C 4295C PURPOSE: 4296C Back transform t2 amplitudes. 4297C The amplitudes are assumed to be a square matrix. 4298C 4299C IOPT = 1 : 2T2 - T2 -> T2 4300C IOPT = 2 : 0 - T2 (Pure exchange) -> T2 4301C 4302 IMPLICIT NONE 4303C 4304 INTEGER LWORK, ISYMJ, ISYMB, ISYMBJ, ISYMAI, NBJ, ISYMI, ISYMA 4305 INTEGER ISYMBI, KSCR1, ISYM, ISYMAJ, KSCR2, KEND1, LWRK1 4306 INTEGER NRHFI, NBI, NAIBJ, NAJBI, IOPT, KOFF 4307C 4308#if defined (SYS_CRAY) 4309 REAL ONETHD, TWOTHD, ONEMINUS 4310 REAL T2AM(*), WORK(LWORK) 4311#else 4312 DOUBLE PRECISION ONETHD, TWOTHD, ONEMINUS 4313 DOUBLE PRECISION T2AM(*), WORK(LWORK) 4314#endif 4315 PARAMETER(ONETHD = 1.0D00/3.0D00,TWOTHD = 2.0D00/3.0D00) 4316 PARAMETER(ONEMINUS = -1.0D00) 4317#include "priunit.h" 4318#include "ccorb.h" 4319#include "ccsdsym.h" 4320C 4321 CALL QENTER('CCRHS3_T2BT') 4322C 4323C---------------------------------- 4324C Back transform t2-amplitudes. 4325C---------------------------------- 4326C 4327 DO 100 ISYMJ = 1,NSYM 4328C 4329 DO 110 J = 1,NRHF(ISYMJ) 4330C 4331 DO 120 ISYMB = 1,NSYM 4332C 4333 ISYMBJ = MULD2H(ISYMB,ISYMJ) 4334 ISYMAI = MULD2H(ISYMBJ,ISYM) 4335C 4336 DO 130 B = 1,NVIR(ISYMB) 4337C 4338 NBJ = IT1AM(ISYMB,ISYMJ)+NVIR(ISYMB)*(J-1)+B 4339C 4340 DO 140 ISYMI = 1,ISYMJ 4341C 4342 ISYMA = MULD2H(ISYMI,ISYMAI) 4343 ISYMAJ = MULD2H(ISYMA,ISYMJ) 4344 ISYMBI = MULD2H(ISYMB,ISYMI) 4345C 4346 KSCR1 = 1 4347 IF (IOPT .EQ. 1) THEN 4348 KSCR2 = KSCR1 + NVIR(ISYMA) 4349 KEND1 = KSCR2 + NVIR(ISYMA) 4350 ELSE IF (IOPT .EQ. 2) THEN 4351 KEND1 = KSCR1 + NVIR(ISYMA) 4352 ENDIF 4353 LWRK1 = LWORK - KEND1 4354 IF (LWRK1 .LT. 0) THEN 4355 CALL QUIT('Insufficient space in CCRHS3_T2TR') 4356 ENDIF 4357C 4358 IF (ISYMI .EQ. ISYMJ) THEN 4359 NRHFI = J - 1 4360 ELSE 4361 NRHFI = NRHF(ISYMI) 4362 END IF 4363C 4364 DO 150 I = 1,NRHFI 4365C 4366 NBI = IT1AM(ISYMB,ISYMI)+NVIR(ISYMB)*(I-1)+B 4367C 4368 NAIBJ = IT2SQ(ISYMAI,ISYMBJ) 4369 * + NT1AM(ISYMAI)*(NBJ-1) 4370 * + IT1AM(ISYMA,ISYMI)+NVIR(ISYMA)*(I-1)+1 4371C 4372 NAJBI = IT2SQ(ISYMAJ,ISYMBI) 4373 * + NT1AM(ISYMAJ)*(NBI-1) 4374 * + IT1AM(ISYMA,ISYMJ)+NVIR(ISYMA)*(J-1)+1 4375C 4376 IF (IOPT .EQ. 1) THEN 4377! 4378 CALL DCOPY(NVIR(ISYMA),T2AM(NAIBJ),1, 4379 * WORK(KSCR1),1) 4380 CALL DCOPY(NVIR(ISYMA),T2AM(NAJBI),1, 4381 * WORK(KSCR2),1) 4382C 4383 CALL DSCAL(NVIR(ISYMA),TWOTHD,T2AM(NAIBJ),1) 4384 CALL DSCAL(NVIR(ISYMA),TWOTHD,T2AM(NAJBI),1) 4385C 4386 CALL DAXPY(NVIR(ISYMA),ONETHD,WORK(KSCR2),1, 4387 * T2AM(NAIBJ),1) 4388 CALL DAXPY(NVIR(ISYMA),ONETHD,WORK(KSCR1),1, 4389 * T2AM(NAJBI),1) 4390C 4391 ELSE IF (IOPT .EQ. 2) THEN 4392C 4393 CALL DSCAL(NVIR(ISYMA),ONEMINUS,T2AM(NAIBJ),1) 4394 CALL DSCAL(NVIR(ISYMA),ONEMINUS,T2AM(NAJBI),1) 4395C 4396 CALL DCOPY(NVIR(ISYMA),T2AM(NAIBJ),1, 4397 * WORK(KSCR1),1) 4398 CALL DCOPY(NVIR(ISYMA),T2AM(NAJBI),1, 4399 * T2AM(NAIBJ),1) 4400 CALL DCOPY(NVIR(ISYMA),WORK(KSCR1),1, 4401 * T2AM(NAJBI),1) 4402C 4403 ELSE 4404 CALL QUIT('IOPT mismatch in CCRHS3_T2BT') 4405 ENDIF 4406C 4407 150 CONTINUE 4408C 4409 140 CONTINUE 4410C 4411 130 CONTINUE 4412C 4413 120 CONTINUE 4414C 4415 110 CONTINUE 4416C 4417 100 CONTINUE 4418C 4419 IF (IPRCC .GT. 20) THEN 4420 CALL AROUND('Back-transformed t2am') 4421 DO 200 ISYMBJ = 1,NSYM 4422 ISYMAI = MULD2H(ISYMBJ,ISYM) 4423 KOFF = IT2SQ(ISYMAI,ISYMBJ) + 1 4424 WRITE(LUPRI,*) 4425 WRITE(LUPRI,*) 'Symmetry block:',ISYMBJ 4426 CALL OUTPUT(T2AM(KOFF),1,NT1AM(ISYMAI),1,NT1AM(ISYMBJ), 4427 * NT1AM(ISYMAI),NT1AM(ISYMBJ),1,LUPRI) 4428 200 CONTINUE 4429 END IF 4430C 4431 CALL QEXIT('CCRHS3_T2BT') 4432C 4433 RETURN 4434 END 4435C /* Deck ccrhs3_cd */ 4436 SUBROUTINE CCRHS3_CD(LUD,DFIL,LUC,CFIL,IDEL,WORK,LWORK, 4437 * LUCD,CDFIL,ISYMD,ISYMPC) 4438! 4439! Written by Kasper Hald. 4440! 4441! 4442! Purpose : Calculate (3)D - (1)C and write to disk. 4443! 4444! 4445 IMPLICIT NONE 4446! 4447#include "priunit.h" 4448#include "ccsdsym.h" 4449#include "maxorb.h" 4450#include "ccorb.h" 4451#include "ccsdio.h" 4452! 4453 INTEGER LWORK,LUC,LUCD,LUD,IDEL,ISYMTR,ISYMD, ISYMPC 4454 INTEGER IERRCD, IERRC, IERRD, KSCR1, KSCR2, KEND1, LWRK1 4455 INTEGER ISYAIK, ISYDIS, IOFF 4456! 4457#if defined (SYS_CRAY) 4458 REAL XMONE, WORK(LWORK) 4459#else 4460 DOUBLE PRECISION XMONE, WORK(LWORK) 4461#endif 4462! 4463 PARAMETER(XMONE= -1.0D00) 4464! 4465 CHARACTER*8 CFIL,DFIL,CDFIL 4466! 4467 CALL QENTER('CCRHS3_CD') 4468! 4469 ISYDIS = MULD2H(ISYMD,ISYMOP) 4470 ISYAIK = MULD2H(ISYDIS,ISYMPC) 4471! 4472!-------------------------- 4473! Allocation. 4474!-------------------------- 4475! 4476 KSCR1 = 1 4477 KSCR2 = KSCR1 + NT2BCD(ISYAIK) 4478 KEND1 = KSCR2 + NT2BCD(ISYAIK) 4479 LWRK1 = LWORK - KEND1 4480! 4481 IF (LWRK1 .LE. 0 ) THEN 4482 CALL QUIT('Too little workspace in CCRHS3_CD ') 4483 ENDIF 4484! 4485 IOFF = IT2DEL(IDEL) + 1 4486! 4487 IF (NT2BCD(ISYAIK) .GT. 0) THEN 4488 CALL GETWA2(LUD,DFIL,WORK(KSCR1),IOFF,NT2BCD(ISYAIK)) 4489 CALL GETWA2(LUC,CFIL,WORK(KSCR2),IOFF,NT2BCD(ISYAIK)) 4490 ENDIF 4491! 4492!------------------------------------- 4493! Calculate the contribution. 4494!------------------------------------- 4495! 4496 CALL DAXPY(NT2BCD(ISYAIK),XMONE,WORK(KSCR2),1,WORK(KSCR1),1) 4497! 4498!-------------------------------------- 4499! Save the new intermediate. 4500!-------------------------------------- 4501! 4502 IF (NT2BCD(ISYAIK) .GT. 0) THEN 4503 CALL PUTWA2(LUCD,CDFIL,WORK(KSCR1),IOFF,NT2BCD(ISYAIK)) 4504 ENDIF 4505! 4506 CALL QEXIT('CCRHS3_CD') 4507! 4508 RETURN 4509 END 4510C /* Deck ccrhs3_prcd */ 4511 SUBROUTINE CCRHS3_PRCD(LUD,DFIL,IDEL,WORK,LWORK,ISYMD,ISYMPC) 4512! 4513! Written by Kasper Hald 4514! 4515! Purpose : Prints the different elements of the 4516! C or D intermediates. 4517! 4518! 4519 IMPLICIT NONE 4520! 4521#include "priunit.h" 4522#include "ccsdsym.h" 4523#include "maxorb.h" 4524#include "ccorb.h" 4525#include "ccsdio.h" 4526! 4527 INTEGER LWORK, LUD, IOFF, KSCR1, KEND1, LWRK1, ISYMPC 4528 INTEGER ISYMD, ISYDIS, ISYAIK, IDEL, IERRD 4529! 4530#if defined (SYS_CRAY) 4531 REAL WORK(LWORK) 4532#else 4533 DOUBLE PRECISION WORK(LWORK) 4534#endif 4535! 4536 CHARACTER*8 DFIL 4537! 4538 CALL QENTER('CCRHS3_PRCD') 4539! 4540 ISYDIS = MULD2H(ISYMD,ISYMOP) 4541 ISYAIK = MULD2H(ISYDIS,ISYMPC) 4542! 4543!-------------------------------- 4544! Allocation. 4545!-------------------------------- 4546! 4547 KSCR1 = 1 4548 KEND1 = KSCR1 +NT2BCD(ISYAIK) 4549 LWRK1 = LWORK - KEND1 4550! 4551 IF (LWRK1 .LE. 0) THEN 4552 CALL QUIT('Too little workspace in CCRHS3_PRCD ') 4553 ENDIF 4554! 4555 IOFF = IT2DEL(IDEL) + 1 4556! 4557 IF (NT2BCD(ISYAIK) .GT. 0) THEN 4558 CALL GETWA2(LUD,DFIL,WORK(KSCR1),IOFF,NT2BCD(ISYAIK)) 4559 ENDIF 4560! 4561!--------------------------------------- 4562! Print the C/D intermediate. 4563!--------------------------------------- 4564! 4565 IF (NT2BCD(ISYAIK) .GT. 0) THEN 4566 WRITE(LUPRI,*) ' The elements of ',DFIL 4567! 4568 DO I=1,NT2BCD(ISYAIK) 4569! 4570 WRITE(LUPRI,*) 'Element : ',WORK(KSCR1+I-1) 4571! 4572 ENDDO 4573! 4574 ENDIF 4575! 4576 CALL QEXIT('CCRHS3_PRCD') 4577! 4578 RETURN 4579 END 4580C /* Deck ccrhs3_ei */ 4581 SUBROUTINE CCRHS3_EI(DSRHF,EMAT1,EMAT2,T2AM,SCRM,XLAMDP, 4582 * XLAMDH,WORK,LWORK,IDEL,ISYMD,ISYDIS, 4583 * ISYMTR,FACE1,FACE2) 4584C 4585C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 4586C Written by Henrik Koch 12-Jan-1994 4587C Symmetry 2-aug 4588C Modified slightly by Ove Christiansen 31-1-95 for 4589C construction of linear transformation intermediates. 4590C ISYMTR = SYM OF T2-VEC 4591! Kasper Hald : General factor for E1 and E2 (FACE1 and FACE2) 4592C 4593C Purpose: Calculate E-intermediates. 4594C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 4595C 4596 IMPLICIT NONE 4597! 4598 INTEGER LWORK, KSCR1, KSCR2, KSCR3, KEND1, LWRK1, ISYDIS 4599 INTEGER IDEL, ISYMTR, ISYMD 4600! 4601#if defined (SYS_CRAY) 4602 REAL ONE, TWO, FACE1, FACE2 4603 REAL WORK(LWORK), XLAMDP(*), XLAMDH(*) 4604 REAL EMAT1(*), EMAT2(*), DSRHF(*), T2AM(*), SCRM(*) 4605#else 4606 DOUBLE PRECISION ONE, TWO,FACE1, FACE2 4607 DOUBLE PRECISION WORK(LWORK), XLAMDP(*), XLAMDH(*) 4608 DOUBLE PRECISION EMAT1(*), EMAT2(*), DSRHF(*), T2AM(*) 4609 DOUBLE PRECISION SCRM(*) 4610#endif 4611! 4612 PARAMETER (ONE = 1.0D00, TWO = 2.0D00) 4613#include "priunit.h" 4614#include "ccorb.h" 4615#include "ccsdsym.h" 4616! 4617 CALL QENTER('CCRHS3_EI') 4618! 4619!------------------------ 4620! Dynamic allocation. 4621!------------------------ 4622! 4623 KSCR1 = 1 4624 KSCR2 = KSCR1 + NT2BCD(ISYDIS) 4625 KSCR3 = KSCR2 + NT2BGD(ISYDIS) 4626 KEND1 = KSCR3 + NT2BGD(ISYDIS) 4627 LWRK1 = LWORK - KEND1 4628! 4629 IF (LWRK1 .LT. 0) THEN 4630 WRITE(LUPRI,*) 'Need : ',KEND1,'Available : ',LWORK 4631 CALL QUIT('Insufficient space in CCRHS3_EI') 4632 ENDIF 4633! 4634!-------------------------------- 4635! Calculate the contribution. 4636!-------------------------------- 4637! 4638 CALL CCRHS3_EI1(DSRHF,EMAT1,EMAT2,T2AM,SCRM, 4639 * WORK(KSCR1),WORK(KSCR2),WORK(KSCR3), 4640 * XLAMDP,XLAMDH,WORK(KEND1),LWRK1,IDEL, 4641 * ISYMD,ISYDIS,ISYMTR,FACE1,FACE2) 4642! 4643 CALL QEXIT('CCRHS3_EI') 4644! 4645 RETURN 4646 END 4647 SUBROUTINE CCRHS3_EI1(DSRHF,EMAT1,EMAT2,T2AM,SCRM,SCR1,SCR2, 4648 * SCR3,XLAMDP,XLAMDH,WORK,LWORK,IDEL, 4649 * ISYMD,ISYDIS,ISYMTR,FACE1,FACE2) 4650! 4651C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 4652C Written by Henrik Koch 12-Jan-1994 4653C Symmetry 2-aug 4654C Modified slightly by Ove Christiansen 31-1-95 for 4655C construction of linear transformation intermediates. 4656C ISYMTR = SYM OF T2-VEC 4657! Kasper Hald : General factor for E1 and E2 (FACE1 and FACE2) 4658C 4659C Purpose: Calculate E-intermediates. 4660C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 4661C 4662 IMPLICIT NONE 4663#include "priunit.h" 4664#include "ccorb.h" 4665#include "ccsdsym.h" 4666! 4667 INTEGER LWORK, IDEL, ISYMD, ISYDIS, ISYMTR, KBM 4668 INTEGER ISYMJ, ISYMDJ, ISYMEM, ISYMGM, ISYME, NVIRE 4669 INTEGER ISYMK, NT1GM, NRHFK, KOFF1, KOFF2, KOFF3, KOFF4 4670 INTEGER KOFF5, KOFF6, ISYMBM, ISYMB, NT1DL, ISYMM, ISYMAG 4671 INTEGER ISYMDL, ISYMGL, KSCR1, KEND1, LWRK1, ISYML 4672 INTEGER ISYMD1, ISYMA, ISYMG, NBASA, NBASG, NVIRD, INDEX 4673 4674! 4675#if defined (SYS_CRAY) 4676 REAL ZERO, HALF, ONE, TWO, FACE1, FACE2 4677 REAL WORK(LWORK), XLAMDP(*),XLAMDH(*), DSRHF(*) 4678 REAL EMAT1(*), EMAT2(*), T2AM(*), SCRM(*), SCR1(*) 4679 REAL SCR2(*), SCR3(*) 4680#else 4681 DOUBLE PRECISION ZERO, HALF, ONE, TWO, FACE1, FACE2 4682 DOUBLE PRECISION WORK(LWORK), XLAMDP(*), XLAMDH(*) 4683 DOUBLE PRECISION DSRHF(*), EMAT1(*), EMAT2(*), T2AM(*) 4684 DOUBLE PRECISION SCRM(*), SCR1(*), SCR2(*), SCR3(*) 4685#endif 4686! 4687 PARAMETER(ZERO=0.0D00,HALF=0.5D00,ONE=1.0D00,TWO=2.0D00) 4688! 4689C INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J 4690! 4691 CALL QENTER('CCRHS3_EI1') 4692! 4693!=================================== 4694! First intermediate I(b,delta). 4695!=================================== 4696! 4697!------------------------------------------------------- 4698! Construct the integrals I(dl,m) = (l d | m delta). 4699!------------------------------------------------------- 4700! 4701 DO 100 ISYMM = 1,NSYM 4702! 4703 ISYMAG = MULD2H(ISYMM,ISYDIS) 4704 ISYMDL = ISYMAG 4705 ISYMGL = ISYMAG 4706! 4707 DO 110 M = 1,NRHF(ISYMM) 4708! 4709 KSCR1 = 1 4710 KEND1 = KSCR1 + N2BST(ISYMAG) 4711 LWRK1 = LWORK - KEND1 4712 IF (LWRK1. LT. 0) THEN 4713 CALL QUIT('Insufficient core in CCRHS_EI1') 4714 END IF 4715! 4716 KOFF1 = IDSRHF(ISYMAG,ISYMM)+NNBST(ISYMAG)*(M-1)+1 4717 CALL CCSD_SYMSQ(DSRHF(KOFF1),ISYMAG,WORK(KSCR1)) 4718! 4719 DO 120 ISYML = 1,NSYM 4720! 4721 ISYMD1 = MULD2H(ISYML,ISYMDL) 4722 ISYMA = ISYML 4723 ISYMG = ISYMD1 4724! 4725 NBASA = MAX(NBAS(ISYMA),1) 4726 NBASG = MAX(NBAS(ISYMG),1) 4727 NVIRD = MAX(NVIR(ISYMD1),1) 4728! 4729 KOFF2 = KSCR1 + IAODIS(ISYMA,ISYMG) 4730 KOFF3 = ILMRHF(ISYML) + 1 4731 KOFF4 = IT2BGD(ISYMGL,ISYMM) + NT1AO(ISYMGL)*(M - 1) 4732 * + IT1AO(ISYMG,ISYML) + 1 4733! 4734 CALL DGEMM('T','N',NBAS(ISYMG),NRHF(ISYML), 4735 * NBAS(ISYMA),ONE,WORK(KOFF2),NBASA, 4736 * XLAMDP(KOFF3),NBASA,ZERO,SCR2(KOFF4), 4737 * NBASG) 4738! 4739 KOFF5 = ILMVIR(ISYMD1) + 1 4740 KOFF6 = IT2BCD(ISYMDL,ISYMM) + NT1AM(ISYMDL)*(M - 1) 4741 * + IT1AM(ISYMD1,ISYML) + 1 4742! 4743 CALL DGEMM('T','N',NVIR(ISYMD1),NRHF(ISYML), 4744 * NBAS(ISYMG),ONE,XLAMDH(KOFF5),NBASG, 4745 * SCR2(KOFF4),NBASG,ZERO,SCR1(KOFF6),NVIRD) 4746! 4747 120 CONTINUE 4748! 4749 110 CONTINUE 4750! 4751 100 CONTINUE 4752! 4753!------------------------------------------------------- 4754! Contract the integrals in SCR1 with t2 amplitudes. 4755!------------------------------------------------------- 4756! 4757 DO 200 ISYMM = 1,NSYM 4758! 4759 ISYMDL = MULD2H(ISYMM,ISYDIS) 4760 ISYMBM = MULD2H(ISYMDL,ISYMTR) 4761 ISYMB = MULD2H(ISYMBM,ISYMM) 4762! 4763 DO 210 M = 1,NRHF(ISYMM) 4764! 4765 NT1DL = MAX(NT1AM(ISYMDL),1) 4766! 4767 KBM = IT1AM(ISYMB,ISYMM) + NVIR(ISYMB)*(M - 1) + 1 4768 KOFF1 = IT2SQ(ISYMDL,ISYMBM) 4769 * + NT1AM(ISYMDL)*(KBM - 1) + 1 4770 KOFF2 = IT2BCD(ISYMDL,ISYMM) 4771 * + NT1AM(ISYMDL)*(M - 1) + 1 4772 KOFF3 = IEMAT1(ISYMB,ISYMD) 4773 * + (IDEL - IBAS(ISYMD) - 1)*NVIR(ISYMB) + 1 4774! 4775 CALL DGEMV('T',NT1AM(ISYMDL),NVIR(ISYMB),FACE1, 4776 * T2AM(KOFF1),NT1DL,SCR1(KOFF2),1,ONE, 4777 * EMAT1(KOFF3),1) 4778! 4779 210 CONTINUE 4780! 4781 200 CONTINUE 4782! 4783!================================ 4784! Second intermediate I(k,j). 4785!================================ 4786! 4787!------------------------------------------- 4788! Transform the SCRM amplitudes to SCR3. 4789!------------------------------------------- 4790! 4791 DO 300 ISYMJ = 1,NSYM 4792! 4793 ISYMDJ = MULD2H(ISYMD,ISYMJ) 4794 ISYMEM = MULD2H(ISYMDJ,ISYMTR) 4795 ISYMGM = ISYMEM 4796! 4797 DO 310 J = 1,NRHF(ISYMJ) 4798! 4799 DO 320 ISYMM = 1,NSYM 4800! 4801 ISYME = MULD2H(ISYMM,ISYMEM) 4802 ISYMG = ISYME 4803! 4804 NVIRE = MAX(NVIR(ISYME),1) 4805 NBASG = MAX(NBAS(ISYMG),1) 4806! 4807 KOFF1 = ILMVIR(ISYME) + 1 4808 KOFF2 = IT2BCD(ISYMEM,ISYMJ) + NT1AM(ISYMEM)*(J - 1) 4809 * + IT1AM(ISYME,ISYMM) + 1 4810 KOFF3 = IT2BGD(ISYMGM,ISYMJ) + NT1AO(ISYMGM)*(J - 1) 4811 * + IT1AO(ISYMG,ISYMM) + 1 4812! 4813 CALL DGEMM('N','N',NBAS(ISYMG),NRHF(ISYMM), 4814 * NVIR(ISYME),ONE,XLAMDH(KOFF1), 4815 * NBASG,SCRM(KOFF2),NVIRE,ZERO, 4816 * SCR3(KOFF3),NBASG) 4817! 4818 320 CONTINUE 4819 310 CONTINUE 4820 300 CONTINUE 4821! 4822!---------------------------------------------------------------- 4823! Contract the integrals in SCR2 with the amplitudes in SCR3. 4824!---------------------------------------------------------------- 4825! 4826 DO 400 ISYMJ = 1,NSYM 4827! 4828 ISYMDJ = MULD2H(ISYMD,ISYMJ) 4829 ISYMEM = MULD2H(ISYMDJ,ISYMTR) 4830 ISYMGM = ISYMEM 4831 ISYMK = MULD2H(ISYMGM,ISYDIS) 4832! 4833 NT1GM = MAX(NT1AO(ISYMGM),1) 4834 NRHFK = MAX(NRHF(ISYMK),1) 4835! 4836 KOFF1 = IT2BGD(ISYMGM,ISYMK) + 1 4837 KOFF2 = IT2BGD(ISYMGM,ISYMJ) + 1 4838 KOFF3 = IMATIJ(ISYMK,ISYMJ) + 1 4839! 4840 CALL DGEMM('T','N',NRHF(ISYMK),NRHF(ISYMJ),NT1AO(ISYMGM), 4841 * FACE2,SCR2(KOFF1),NT1GM,SCR3(KOFF2),NT1GM, 4842 * ONE,EMAT2(KOFF3),NRHFK) 4843! 4844 400 CONTINUE 4845! 4846 CALL QEXIT('CCRHS3_EI1') 4847! 4848 RETURN 4849 END 4850C /* Deck cc_aofock3 */ 4851 SUBROUTINE CC_AOFOCK3(XINT,DENSIT,FOCK,WORK,LWORK,IDEL, 4852 * ISYMD,ISYDEN) 4853C 4854C Written by Asger Halkier and Henrik Koch 27-4-95. 4855C 4856C Debugged Ove Christiansen august 1995 4857C 4858C Purpose: Calculate the two electron contribution to the 4859C AO-fock matrix using matrix vector routines. 4860C 4861C Obs: It can be done as F(g>=d) = G(a>=b) I(a>=b,g,d) where 4862C G(a>=b) = D(a,b) + D(b,a), the diagonal properly scaled 4863C 4864 IMPLICIT NONE 4865 INTEGER ISYDIS, ISYMD, ISYMG, ISYMAB, NDISTG, NBATCH 4866 INTEGER IBATCH, NUMG, IG1, IG2, KOFF2, IG, KOFF1, ISYMA 4867 INTEGER ISYDEN, ISYMB, KAD, IDEL, KGB, NTOTA, NTOTG, LWORK 4868#include "priunit.h" 4869#include "maxorb.h" 4870#if defined (SYS_CRAY) 4871 REAL ZERO, ONE, TWO 4872 REAL XINT(*), DENSIT(*), FOCK(*), WORK(LWORK) 4873#else 4874 DOUBLE PRECISION ZERO, ONE, TWO 4875 DOUBLE PRECISION XINT(*), DENSIT(*), FOCK(*), WORK(LWORK) 4876#endif 4877 PARAMETER(ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0) 4878#include "ccorb.h" 4879#include "symsq.h" 4880#include "ccsdsym.h" 4881C 4882 CALL QENTER('CC_AOFOCK3') 4883C 4884 ISYDIS = MULD2H(ISYMD,ISYMOP) 4885C 4886 DO 100 ISYMG = 1,NSYM 4887C 4888 IF (NBAS(ISYMG) .EQ. 0) GOTO 100 4889C 4890 ISYMAB = MULD2H(ISYMG,ISYDIS) 4891C 4892 NDISTG = MIN(LWORK/N2BST(ISYMAB),NBAS(ISYMG)) 4893C 4894 IF (NDISTG .LT. 1) THEN 4895 CALL QUIT('Insufficient work space in CC_AOFOCK1') 4896 ENDIF 4897C 4898 NBATCH = (NBAS(ISYMG) - 1)/NDISTG + 1 4899C 4900C------------------------------------- 4901C Start the loops over batches. 4902C------------------------------------- 4903C 4904 DO 110 IBATCH = 1,NBATCH 4905C 4906 NUMG = NDISTG 4907 IF (IBATCH .EQ. NBATCH) THEN 4908 NUMG = NBAS(ISYMG) - NDISTG*(NBATCH - 1) 4909 ENDIF 4910C 4911 IG1 = NDISTG*(IBATCH - 1) + 1 4912 IG2 = NDISTG*(IBATCH - 1) + NUMG 4913C 4914 KOFF2 = 1 4915 DO 120 IG = IG1,IG2 4916C 4917 KOFF1 = IDSAOG(ISYMG,ISYDIS) 4918 * + (IG - 1)*NNBST(ISYMAB) + 1 4919C 4920 CALL CCSD_SYMSQ(XINT(KOFF1),ISYMAB,WORK(KOFF2)) 4921C 4922 KOFF2 = KOFF2 + N2BST(ISYMAB) 4923C 4924 120 CONTINUE 4925C 4926 ISYMA = MULD2H(ISYMD,ISYDEN) 4927 ISYMB = MULD2H(ISYMA,ISYMAB) 4928C 4929 KAD = IAODIS(ISYMA,ISYMD) 4930 * + NBAS(ISYMA)*(IDEL - IBAS(ISYMD) - 1) + 1 4931C 4932 DO 130 IG = IG1,IG2 4933C 4934 KOFF1 = (IG - IG1)*N2BST(ISYMAB) 4935 * + IAODIS(ISYMA,ISYMB) + 1 4936 KGB = IAODIS(ISYMG,ISYMB) + IG 4937C 4938 NTOTA = MAX(NBAS(ISYMA),1) 4939 NTOTG = MAX(NBAS(ISYMG),1) 4940C 4941 CALL DGEMV('T',NBAS(ISYMA),NBAS(ISYMB),-ONE,WORK(KOFF1), 4942 * NTOTA,DENSIT(KAD),1,ONE,FOCK(KGB),NTOTG) 4943C 4944 130 CONTINUE 4945C 4946 110 CONTINUE 4947 100 CONTINUE 4948C 4949 CALL QEXIT('CC_AOFOCK3') 4950C 4951 RETURN 4952 END 4953C /* Deck cc_mofcon3 */ 4954 SUBROUTINE CC_MOFCON3(XINT,OMEGA2,XLAMDP,XLAMDH,XLAMPC,XLAMHC, 4955 * WORK,LWORK,IDEL,ISYMD,ISYMTR,IOPT, 4956 * ANTISYM) 4957C 4958C Written by Asger Halkier and Henrik Koch 3-5-95. 4959C Debugged By Ove Christiansen 25-7-1995 4960C ANTISYM flag introduced K. Hald & C. Haettig August 99 4961C 4962C Purpose: To calculate the F-term's contribution to the 4963C vector function using matrix vector routines. 4964C Special version adapted for triplet case. 4965C 4966C N.B. This routine assumes AO-symmetric integrals, and can therefor 4967C not be used directly for calculations with London-orbitals!!! 4968C 4969#include "implicit.h" 4970#include "priunit.h" 4971#include "maxorb.h" 4972 PARAMETER(ZERO = 0.0D0,ONE = 1.0D0,XMONE=-1.0D0,TWO = 2.0D0) 4973 DIMENSION XINT(*),OMEGA2(*) 4974 DIMENSION XLAMPC(*),XLAMHC(*),XLAMDH(*),XLAMDP(*) 4975 DIMENSION WORK(LWORK) 4976 LOGICAL ANTISYM 4977#include "ccorb.h" 4978#include "symsq.h" 4979#include "ccsdsym.h" 4980C 4981 INDEX(I,J) = MAX(I,J)*(MAX(I,J) - 3)/2 + I + J 4982C 4983 CALL QENTER('CC_MOFCON3') 4984C 4985 ISYDIS = MULD2H(ISYMD,ISYMOP) 4986C 4987 DO 100 ISYMG = 1,NSYM 4988C 4989 IF (NBAS(ISYMG) .EQ. 0) GOTO 100 4990C 4991 ISALBE = MULD2H(ISYMG,ISYDIS) 4992 ISYMAI = MULD2H(ISALBE,ISYMTR) 4993 ISYMJ = ISYMG 4994C 4995C----------------------------------------- 4996C Dynamic allocation of work space. 4997C----------------------------------------- 4998C 4999 KSCR1 = 1 5000 KSCR2 = KSCR1 + NNBST(ISALBE)*NRHF(ISYMJ) 5001 KSCR3 = KSCR2 + N2BST(ISALBE) 5002 KSCR4 = KSCR3 + NT1AM(ISYMAI) 5003 KEND1 = KSCR4 + NT1AM(ISYMAI) 5004 LWRK1 = LWORK - KEND1 5005C 5006 IF (LWRK1 .LT. 0) THEN 5007 WRITE(LUPRI,*) 'Lwrk1 = ',LWRK1 5008 CALL QUIT('Insufficient work space area in CC_MOFCON') 5009 ENDIF 5010C 5011C-------------------------------- 5012C Do first transformation. 5013C-------------------------------- 5014C 5015 KOFF1 = IDSAOG(ISYMG,ISYDIS) + 1 5016 KOFF2 = ILMRHF(ISYMJ) + 1 5017C 5018 NTALBE = MAX(NNBST(ISALBE),1) 5019 NTOTG = MAX(NBAS(ISYMG),1) 5020C 5021 CALL DGEMM('N','N',NNBST(ISALBE),NRHF(ISYMJ),NBAS(ISYMG), 5022 * ONE,XINT(KOFF1),NTALBE,XLAMDH(KOFF2),NTOTG, 5023 * ZERO,WORK(KSCR1),NTALBE) 5024C 5025C----------------------------------- 5026C Last index transformations. 5027C----------------------------------- 5028C 5029 DO 110 J = 1,NRHF(ISYMJ) 5030C 5031 KOFF1 = KSCR1 + NNBST(ISALBE)*(J - 1) 5032C 5033 CALL CCSD_SYMSQ(WORK(KOFF1),ISALBE,WORK(KSCR2)) 5034C 5035 DO 120 ISYMI = 1,NSYM 5036C 5037 ISYMBE = ISYMI 5038 ISYMAL = MULD2H(ISYMBE,ISALBE) 5039 ISYMA = MULD2H(ISYMAL,ISYMTR) 5040C 5041 IF (LWRK1 .LT. NBAS(ISYMAL)*NRHF(ISYMI)) THEN 5042 CALL QUIT('Insufficient space for '// 5043 & '2. trf. in CC_MOFCON') 5044 ENDIF 5045C 5046 KOFF2 = KSCR2 + IAODIS(ISYMAL,ISYMBE) 5047 KOFF3 = ILMRHF(ISYMI) + 1 5048 KOFF4 = IGLMVI(ISYMAL,ISYMA) + 1 5049 KOFF5 = KSCR3 + IT1AM(ISYMA,ISYMI) 5050C 5051 NTOTAL = MAX(NBAS(ISYMAL),1) 5052 NTOTBE = MAX(NBAS(ISYMBE),1) 5053 NTOTA = MAX(NVIR(ISYMA),1) 5054C 5055 CALL DGEMM('N','N',NBAS(ISYMAL),NRHF(ISYMI),NBAS(ISYMBE), 5056 * ONE,WORK(KOFF2),NTOTAL,XLAMDH(KOFF3),NTOTBE, 5057 * ZERO,WORK(KEND1),NTOTAL) 5058C 5059 CALL DGEMM('T','N',NVIR(ISYMA),NRHF(ISYMI),NBAS(ISYMAL), 5060 * ONE,XLAMPC(KOFF4),NTOTAL,WORK(KEND1),NTOTAL, 5061 * ZERO,WORK(KOFF5),NTOTA) 5062C 5063 IF (IOPT .EQ. 2) THEN 5064C 5065 ISYMBE = MULD2H(ISYMI,ISYMTR) 5066 ISYMAL = MULD2H(ISYMBE,ISALBE) 5067 ISYMA = ISYMAL 5068C 5069 IF (LWRK1 .LT. NBAS(ISYMAL)*NRHF(ISYMI)) THEN 5070 CALL QUIT('Insufficient space for '// 5071 & '2. trf. in CC_MOFCON') 5072 ENDIF 5073C 5074 KOFF2 = KSCR2 + IAODIS(ISYMAL,ISYMBE) 5075 KOFF3 = IGLMRH(ISYMBE,ISYMI) + 1 5076 KOFF4 = ILMVIR(ISYMA) + 1 5077 KOFF5 = KSCR3 + IT1AM(ISYMA,ISYMI) 5078C 5079 NTOTAL = MAX(NBAS(ISYMAL),1) 5080 NTOTBE = MAX(NBAS(ISYMBE),1) 5081 NTOTA = MAX(NVIR(ISYMA),1) 5082C 5083 CALL DGEMM('N','N',NBAS(ISYMAL),NRHF(ISYMI), 5084 * NBAS(ISYMBE),ONE,WORK(KOFF2),NTOTAL, 5085 * XLAMHC(KOFF3),NTOTBE,ZERO,WORK(KEND1), 5086 * NTOTAL) 5087C 5088 CALL DGEMM('T','N',NVIR(ISYMA),NRHF(ISYMI), 5089 * NBAS(ISYMAL),ONE,XLAMDP(KOFF4),NTOTAL, 5090 * WORK(KEND1),NTOTAL,ONE,WORK(KOFF5),NTOTA) 5091C 5092 ENDIF 5093C 5094 5095 120 CONTINUE 5096C 5097C-------------------------------------------------- 5098C Storing the result in the omega2-array. 5099C-------------------------------------------------- 5100C 5101 ISYMB = ISYMD 5102 ISYMBJ = MULD2H(ISYMB,ISYMJ) 5103C 5104 DO 130 B = 1,NVIR(ISYMB) 5105C 5106 NBJ = IT1AM(ISYMB,ISYMJ) + NVIR(ISYMB)*(J - 1) + B 5107 NDB = ILMVIR(ISYMB) + NBAS(ISYMD)*(B - 1) 5108 * + IDEL - IBAS(ISYMD) 5109C 5110 CALL DZERO(WORK(KSCR4),NT1AM(ISYMAI)) 5111C 5112 XLB = XLAMDP(NDB) 5113C 5114 CALL DAXPY(NT1AM(ISYMAI),XLB,WORK(KSCR3),1,WORK(KSCR4),1) 5115C 5116 IF (ISYMBJ .EQ. ISYMAI) THEN 5117C 5118 NTOTAI = NBJ 5119C 5120 IF (.NOT. ANTISYM) THEN 5121! 5122 IF (IOPT .EQ. 2) THEN 5123 NTOTAI = NT1AM(ISYMAI) 5124 WORK(KSCR4+NBJ-1) = TWO*WORK(KSCR4+NBJ-1) 5125 ENDIF 5126C 5127 DO 140 NAI = 1,NTOTAI 5128C 5129 NAIBJ = IT2AM(ISYMAI,ISYMBJ) + INDEX(NAI,NBJ) 5130C 5131 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) + WORK(KSCR4+NAI-1) 5132C 5133 140 CONTINUE 5134 ELSE 5135 IF (IOPT .EQ. 1) CALL QUIT( 5136 * 'IOPT .EQ. 1 .AND. ANTISYM in MOFCON3 not legal') 5137! 5138 DO NAI = 1,NBJ-1 5139 NAIBJ = IT2AM(ISYMAI,ISYMBJ) + INDEX(NAI,NBJ) 5140 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) + WORK(KSCR4+NAI-1) 5141 ENDDO 5142C 5143 DO NAI = NBJ+1,NT1AM(ISYMAI) 5144 NAIBJ = IT2AM(ISYMAI,ISYMBJ) + INDEX(NAI,NBJ) 5145 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) - WORK(KSCR4+NAI-1) 5146 ENDDO 5147! 5148 ENDIF 5149C 5150 ENDIF 5151C 5152 IF (ISYMAI .LT. ISYMBJ) THEN 5153C 5154 IF (.NOT. ANTISYM) THEN 5155 DO NAI = 1,NT1AM(ISYMAI) 5156 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 5157 * + NT1AM(ISYMAI)*(NBJ - 1) + NAI 5158 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) + WORK(KSCR4+NAI-1) 5159 END DO 5160 ELSE 5161 DO NAI = 1,NT1AM(ISYMAI) 5162 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 5163 * + NT1AM(ISYMAI)*(NBJ - 1) + NAI 5164 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) + WORK(KSCR4+NAI-1) 5165 END DO 5166 END IF 5167C 5168 ENDIF 5169C 5170 IF ((ISYMBJ .LT. ISYMAI) .AND. (IOPT .EQ. 2)) THEN 5171C 5172 IF (.NOT.ANTISYM) THEN 5173 DO NAI = 1,NT1AM(ISYMAI) 5174 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 5175 * + NT1AM(ISYMBJ)*(NAI - 1) + NBJ 5176 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) + WORK(KSCR4+NAI-1) 5177 END DO 5178 ELSE 5179 DO NAI = 1,NT1AM(ISYMAI) 5180 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 5181 * + NT1AM(ISYMBJ)*(NAI - 1) + NBJ 5182 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) - WORK(KSCR4+NAI-1) 5183 END DO 5184 END IF 5185C 5186 ENDIF 5187C 5188 130 CONTINUE 5189C 5190 110 CONTINUE 5191C 5192 100 CONTINUE 5193C 5194 CALL QEXIT('CC_MOFCON3') 5195C 5196 RETURN 5197 END 5198C /* Deck cc_pram3 */ 5199 SUBROUTINE CC_PRAM3(CAM1,CAMP,CAMM,PT1,PTP,PTM,ISYMTR,LGRS) 5200C 5201C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 5202C 30-5-1995 Ove Christiansen 5203C 05-8-1999 Kasper Hald & Christof Haettig : adapted for triplet 5204C 5205C Purpose: Writes out vector: 5206C %T1 and %T2 and ||T1||/||T2|| 5207C&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 5208C 5209#include "implicit.h" 5210C 5211 PARAMETER (TWO = 2.0D0, THPRT = 1.0D-9) 5212C 5213#include "priunit.h" 5214#include "ccorb.h" 5215#include "ccsdsym.h" 5216#include "ccsdinp.h" 5217C 5218C 5219 LOGICAL LGRS 5220 DIMENSION CAM1(*), CAMP(*), CAMM(*) 5221C 5222 INDEX(I,J) = MAX(I,J)*(MAX(I,J) - 3)/2 + I + J 5223C 5224 CALL QENTER('CC_PRAM3') 5225C 5226C------------------------ 5227C Add up the vectors. 5228C------------------------ 5229C 5230 C1NOSQ = DDOT(NT1AM(ISYMTR),CAM1,1,CAM1,1) 5231 IF (.NOT. CCS) THEN 5232 C2PNOSQ = DDOT(NT2AM(ISYMTR),CAMP,1,CAMP,1) 5233 C2MNOSQ = DDOT(NT2AM(ISYMTR),CAMM,1,CAMM,1) 5234 ELSE 5235 C2PNOSQ = 0.0D0 5236 C2MNOSQ = 0.0D0 5237 END IF 5238C 5239 CNOSQ = C1NOSQ + C2PNOSQ + C2MNOSQ 5240C 5241C 5242 IF (CNOSQ .EQ. 0.0D0) THEN 5243 PT1 = 0.0D0 5244 PTP = 0.0D0 5245 PTM = 0.0D0 5246 ELSE 5247 PT1 = (C1NOSQ /CNOSQ)*100.0D0 5248 PTP = (C2PNOSQ/CNOSQ)*100.0D0 5249 PTM = (C2MNOSQ/CNOSQ)*100.0D0 5250 END IF 5251C 5252 IF (.NOT. CCS .AND. CNOSQ .NE. 0.0D0) THEN 5253 WRITE(LUPRI,'(//5X,A)') 5254 * 'CC_PRAM:Overall Contribution of the Different Components' 5255 WRITE(LUPRI,'(5X,A//)') 5256 * '--------------------------------------------------------' 5257 WRITE(LUPRI,'(/5X,A,5X,F10.4,A)') 5258 * 'Single Excitation Contribution : ', PT1,' %' 5259 WRITE(LUPRI,'(/5X,A,5X,F10.4,A,F10.4,A)') 5260 * 'Double Excitation Contribution (+/-): ', 5261 * PTP,' % /',PTM,' % ' 5262 WRITE(LUPRI,'(/5X,A,5X,F10.4)') 5263 * '||T1||/||T2|| : ', 5264 * SQRT(C1NOSQ/(C2PNOSQ+C2MNOSQ)) 5265 IF (LGRS) WRITE(LUPRI,'(/5X,A,5X,F10.4)') 5266 * 'Tau1 diagnostic : ', 5267 * SQRT(C1NOSQ/(TWO*DFLOAT(NRHFT))) 5268 END IF 5269C 5270 WRITE(LUPRI,'(/5X,A,5X,F10.4)') 5271 * 'Norm of Total Amplitude Vector : ',SQRT(CNOSQ) 5272C 5273 CALL FLSHFO(LUPRI) 5274C 5275C---------------------------------------------- 5276C Initialize threshold etc from Printlevel. 5277C---------------------------------------------- 5278C 5279 NL = MAX(1,2*IPRINT) 5280 CNOSQ = MAX(CNOSQ,THPRT) 5281 THR1 = SQRT(C1NOSQ/CNOSQ)/NL 5282 THR2 = SQRT((C2PNOSQ+C2MNOSQ)/CNOSQ)/NL 5283 THR1 = MAX(THR1,1.0D-03) 5284 THR2 = MAX(THR2,1.0D-03) 5285 SUMOFP = 0.0D00 5286C 5287C--------------------------------------- 5288C Loop through single excitation part. 5289C--------------------------------------- 5290C 5291 WRITE(LUPRI,'(//A)') 5292 * ' +==============================================' 5293 * //'===============================+' 5294 WRITE(LUPRI,'(1X,A)') 5295 * '| symmetry| orbital index | Excitation Numbers' 5296 * //' | Amplitude |' 5297 WRITE(LUPRI,'(1X,A)') 5298 * '| Index | a b i j | NAI NBJ |' 5299 * //' NAIBJ | |' 5300 WRITE(LUPRI,'(A)') 5301 * ' +==============================================' 5302 * //'===============================+' 5303C 5304 ISYMAI = MULD2H(ISYMTR,ISYMOP) 5305C 5306 1 CONTINUE 5307 N1 = 0 5308C 5309 DO 100 ISYMA = 1,NSYM 5310C 5311 ISYMI = MULD2H(ISYMAI,ISYMA) 5312C 5313 DO 110 I = 1,NRHF(ISYMI) 5314C 5315 MI = IORB(ISYMI) + I 5316C 5317 DO 120 A=1,NVIR(ISYMA) 5318C 5319 NAI = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I-1) + A 5320C 5321 MA = IORB(ISYMA) + NRHF(ISYMA) + A 5322C 5323 IF (ABS(CAM1(NAI)) .GT. THR1 ) THEN 5324C 5325 WRITE(LUPRI,9990) ISYMA,ISYMI,A,I,NAI,CAM1(NAI) 5326C 5327 N1 = N1 + 1 5328 SUMOFP = SUMOFP + CAM1(NAI)*CAM1(NAI) 5329C 5330 ENDIF 5331C 5332 120 CONTINUE 5333 110 CONTINUE 5334 100 CONTINUE 5335C 5336 IF ((N1.LT.1).AND.(SQRT(C1NOSQ/CNOSQ).GT.1.0D-3)) THEN 5337 THR1 = THR1/5.0D0 5338 GOTO 1 5339 ENDIF 5340C 5341 CALL FLSHFO(LUPRI) 5342C 5343C-------------------------------------------- 5344C Loop through Doublee excitation vector. 5345C If not ccs or ccp2 5346C-------------------------------------------- 5347C 5348 IF (.NOT. ( CCS .OR. CCP2 )) THEN 5349C 5350 WRITE(LUPRI,'(A)') 5351 * ' +----------------------------------------------' 5352 * //'-------------------------------+' 5353C 5354 5355 2 CONTINUE 5356 N2 = 0 5357C 5358 DO 200 ISYMAI = 1,NSYM 5359C 5360 ISYMBJ = MULD2H(ISYMAI,ISYMTR) 5361C 5362 DO 210 ISYMJ = 1,NSYM 5363C 5364 ISYMB = MULD2H(ISYMJ,ISYMBJ) 5365C 5366 DO 220 ISYMI = 1,NSYM 5367C 5368 ISYMA = MULD2H(ISYMI,ISYMAI) 5369C 5370 DO 230 J = 1,NRHF(ISYMJ) 5371C 5372 MJ = IORB(ISYMJ) + J 5373C 5374 DO 240 B = 1,NVIR(ISYMB) 5375C 5376 NBJ = IT1AM(ISYMB,ISYMJ) 5377 * + NVIR(ISYMB)*(J - 1) + B 5378C 5379 MB = IORB(ISYMB) + NRHF(ISYMB) + B 5380C 5381 DO 250 I = 1,NRHF(ISYMI) 5382C 5383 MI = IORB(ISYMI) + I 5384C 5385 DO 260 A = 1,NVIR(ISYMA) 5386C 5387 NAI = IT1AM(ISYMA,ISYMI) 5388 * + NVIR(ISYMA)*(I - 1) + A 5389C 5390 MA = IORB(ISYMA) + NRHF(ISYMA) + A 5391C 5392 IF (((ISYMAI.EQ.ISYMBJ).AND. 5393 * (NAI .LT. NBJ)).OR.(ISYMAI.LT.ISYMBJ)) 5394 * GOTO 260 5395C 5396 IF (ISYMAI.EQ.ISYMBJ) THEN 5397 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 5398 * + INDEX(NAI,NBJ) 5399 ELSE 5400 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 5401 * + NT1AM(ISYMAI)*(NBJ-1) + NAI 5402 ENDIF 5403C 5404 IF (ABS(CAMP(NAIBJ)) .GT. THR2 ) THEN 5405 WRITE(LUPRI,9991) ISYMA,ISYMB,ISYMI,ISYMJ, 5406 * A,B,I,J,NAI,NBJ,NAIBJ, 5407 * CAMP(NAIBJ) 5408 N2 = N2 + 1 5409 SUMOFP = SUMOFP + CAMP(NAIBJ)*CAMP(NAIBJ) 5410 ENDIF 5411C 5412 IF (ABS(CAMM(NAIBJ)) .GT. THR2 ) THEN 5413 WRITE(LUPRI,9992) ISYMA,ISYMB,ISYMI,ISYMJ, 5414 * A,B,I,J,NAI,NBJ,NAIBJ, 5415 * CAMM(NAIBJ) 5416 N2 = N2 + 1 5417 SUMOFP = SUMOFP + CAMM(NAIBJ)*CAMM(NAIBJ) 5418 ENDIF 5419C 5420 260 CONTINUE 5421 250 CONTINUE 5422 240 CONTINUE 5423 230 CONTINUE 5424 220 CONTINUE 5425 210 CONTINUE 5426 200 CONTINUE 5427C 5428 IF ((N2.LT.1).AND.(SQRT((C2PNOSQ+C2MNOSQ)/CNOSQ).GT.1.0D-3)) THEN 5429 THR2 = THR2/5D00 5430 GOTO 2 5431 ENDIF 5432C 5433 ENDIF 5434C 5435 WRITE(LUPRI,'(A)') 5436 * ' +==============================================' 5437 * //'===============================+' 5438C 5439 WRITE(LUPRI,'(//10X,A,8X,F10.4)') 5440 * 'Norm of Printed Amplitude Vector : ',SQRT(SUMOFP) 5441 WRITE(LUPRI,'(//10X,A43,1X,F9.6)') 5442 * 'Printed all single excitations greater than',THR1 5443 IF (.NOT. (CCS.OR.CCP2)) THEN 5444 WRITE(LUPRI,'(//10X,A43,1X,F9.6)') 5445 * 'Printed all double excitations greater than',THR2 5446 ENDIF 5447C 5448 9990 FORMAT(1X,'| ',I1,3X,I1,2X,' | ',I3,5X,I3,4X,' | ',I8,9x, 5449 * ' | ',12x,' | ',1x, F10.6,' |') 5450 9991 FORMAT(1X,'| ',I1,1X,I1,1X,I1,1X,I1,' | ', 5451 * I3,1X,I3,1X,I3,1X,I3,' | ', 5452 * I8,1x,I8,' | (+)',I9,' | ',1x,F10.6,' |') 5453 9992 FORMAT(1X,'| ',I1,1X,I1,1X,I1,1X,I1,' | ', 5454 * I3,1X,I3,1X,I3,1X,I3,' | ', 5455 * I8,1x,I8,' | (-)',I9,' | ',1x,F10.6,' |') 5456C 5457 CALL QEXIT('CC_PRAM3') 5458C 5459 RETURN 5460 END 5461C /* Deck ccrhs3_ij */ 5462 SUBROUTINE CCRHS3_IJ(OMEGA2,WORK,LWORK,ISYVEC) 5463! 5464! Written by Kasper Hald and Poul Joergensen 5465! Spring 1999. 5466! 5467! Purpose : Calculate Omega(aibj) - Omega(ajbi) 5468! 5469! N.B. It is assumed that omega will be in packed form. 5470! 5471! 5472 IMPLICIT NONE 5473! 5474#include "priunit.h" 5475#include "maxorb.h" 5476#include "ccorb.h" 5477#include "symsq.h" 5478#include "ccsdsym.h" 5479#include "cclr.h" 5480#include "ccsdio.h" 5481! 5482 INTEGER LWORK, LWRK1, KEND1, KSCR1, ISYMJ, ISYMI, ISYMA 5483 INTEGER ISYMB, ISYMAI, ISYMAJ, ISYMBI, ISYMBJ 5484 INTEGER NAI, NAJ, NBI, NBJ, NAIBJ, NAJBI, NTOTA,ISYVEC 5485 INTEGER INDEX 5486 INTEGER MA, MB, MI, MJ 5487! 5488#if defined (SYS_CRAY) 5489 REAL WORK(LWORK), OMEGA2(*) 5490 REAL ZERO 5491#else 5492 DOUBLE PRECISION WORK(LWORK), OMEGA2(*) 5493 DOUBLE PRECISION ZERO 5494#endif 5495! 5496 PARAMETER(ZERO = 0.0D00) 5497! 5498 INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J 5499! 5500 CALL QENTER('CCRHS3_IJ') 5501! 5502!----------------------------------- 5503! Allocation of workspace. 5504!----------------------------------- 5505! 5506 KSCR1 = 1 5507 KEND1 = KSCR1 + NT2AM(ISYVEC) 5508 LWRK1 = LWORK - KEND1 5509! 5510 IF (LWRK1 .LE. 0) THEN 5511 CALL QUIT('Too little workspace in CCRHS3_IJ ') 5512 ENDIF 5513! 5514!------------------------------------------ 5515! Copy OMEGA to workspace. 5516!------------------------------------------ 5517! 5518C CALL DCOPY(NT2AM(ISYVEC),OMEGA2,1,WORK(KSCR1),1) 5519! 5520!------------------------------------------ 5521! Calculate the contribution. 5522!------------------------------------------ 5523! 5524 DO 100 ISYMBJ = 1,NSYM 5525 ISYMAI = MULD2H(ISYMBJ,ISYVEC) 5526! 5527 IF (ISYMAI .LE. ISYMBJ) THEN 5528! 5529 DO 110 ISYMI = 1,NSYM 5530! 5531 ISYMA = MULD2H(ISYMAI,ISYMI) 5532! 5533 DO 120 ISYMJ = 1,NSYM 5534! 5535 ISYMB = MULD2H(ISYMBJ,ISYMJ) 5536 ISYMBI = MULD2H(ISYMB,ISYMI) 5537 ISYMAJ = MULD2H(ISYMA,ISYMJ) 5538! 5539 DO 130 I = 1,NRHF(ISYMI) 5540 MI = IORB(ISYMI) + I 5541 DO 140 J = 1,NRHF(ISYMJ) 5542 MJ = IORB(ISYMJ) + J 5543! 5544 DO 150 A = 1,NVIR(ISYMA) 5545 MA = IORB(ISYMA) + NRHF(ISYMA) + A 5546 NAJ = IT1AM(ISYMA,ISYMJ) 5547 * + NVIR(ISYMA)*(J-1) + A 5548 NAI = IT1AM(ISYMA,ISYMI) 5549 * + NVIR(ISYMA)*(I-1) + A 5550! 5551 DO 160 B = 1,NVIR(ISYMB) 5552 MB = IORB(ISYMB) + NRHF(ISYMB) + B 5553! 5554 NBI = IT1AM(ISYMB,ISYMI) 5555 * + NVIR(ISYMB)*(I-1) + B 5556 NBJ = IT1AM(ISYMB,ISYMJ) 5557 * + NVIR(ISYMB)*(J-1) + B 5558! 5559 IF (ISYMAI .EQ. ISYMBJ) THEN 5560! 5561 IF ((NAI .LE. NBJ) .AND. 5562 * (MA .LE. MB)) THEN 5563! 5564 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 5565 * + INDEX(NAI,NBJ) 5566! 5567 IF (ISYMAJ .EQ. ISYMBI) THEN 5568 NAJBI = IT2AM(ISYMAJ,ISYMBI) 5569 * + INDEX(NAJ,NBI) 5570 ELSEIF (ISYMAJ .LT. ISYMBI) THEN 5571 NAJBI = IT2AM(ISYMAJ,ISYMBI) 5572 * + NT1AM(ISYMAJ)*(NBI-1)+NAJ 5573 ELSEIF (ISYMAJ .GT. ISYMBI) THEN 5574 NAJBI = IT2AM(ISYMBI,ISYMAJ) 5575 * + NT1AM(ISYMBI)*(NAJ-1)+NBI 5576 ENDIF 5577! 5578 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) 5579 * - OMEGA2(NAJBI) 5580 OMEGA2(NAJBI) = ZERO 5581! 5582 ENDIF 5583! 5584 ELSEIF (ISYMAI .LT. ISYMBJ) THEN 5585! 5586 IF (((MA .LE. MB) .AND. 5587 * (MI .LE. MJ)) .OR. 5588 * ((MA .GE. MB) .AND. 5589 * (MI .GE. MJ))) THEN 5590! 5591 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 5592 * + NT1AM(ISYMAI)*(NBJ-1)+NAI 5593! 5594 IF (ISYMAJ .EQ. ISYMBI) THEN 5595 NAJBI = IT2AM(ISYMAJ,ISYMBI) 5596 * + INDEX(NAJ,NBI) 5597 ELSEIF (ISYMAJ .LT. ISYMBI) THEN 5598 NAJBI = IT2AM(ISYMAJ,ISYMBI) 5599 * + NT1AM(ISYMAJ)*(NBI-1)+NAJ 5600 ELSEIF (ISYMAJ .GT. ISYMBI) THEN 5601 NAJBI = IT2AM(ISYMBI,ISYMAJ) 5602 * + NT1AM(ISYMBI)*(NAJ-1)+NBI 5603 ENDIF 5604! 5605 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) 5606 * - OMEGA2(NAJBI) 5607 OMEGA2(NAJBI) = ZERO 5608! 5609 ENDIF 5610! 5611 ENDIF 5612! 5613 160 CONTINUE 5614 150 CONTINUE 5615 140 CONTINUE 5616 130 CONTINUE 5617 120 CONTINUE 5618 110 CONTINUE 5619 ENDIF 5620 100 CONTINUE 5621! 5622 CALL QEXIT('CCRHS3_IJ') 5623! 5624 RETURN 5625 END 5626C /* Deck ccrhs3_r2ij */ 5627 SUBROUTINE CCRHS3_R2IJ(C2AM,WORK,LWORK,ISYVEC) 5628! 5629! Written by Kasper Hald. 5630! Spring 1999. 5631! 5632! Purpose : Take the (+)R(ab,ij) vector 5633! for ai<bj AND i<j and "square" it up 5634! to include all terms ai<bj i.e. 5635! a lower triangular matrix. 5636! 5637! N.B. It is assumed that omega will be in packed form. 5638! 5639! 5640 IMPLICIT NONE 5641! 5642#include "priunit.h" 5643#include "maxorb.h" 5644#include "ccorb.h" 5645#include "symsq.h" 5646#include "ccsdsym.h" 5647#include "cclr.h" 5648#include "ccsdio.h" 5649! 5650 INTEGER LWORK, LWRK1, KEND1, KSCR1, ISYMJ, ISYMI, ISYMA 5651 INTEGER ISYMB, ISYMAI, ISYMAJ, ISYMBI, ISYMBJ, ISYVEC 5652 INTEGER NAI, NAJ, NBI, NBJ, NAIBJ, NAJBI, NTOTA 5653 INTEGER INDEX 5654 INTEGER MA, MB, MI, MJ 5655! 5656#if defined (SYS_CRAY) 5657 REAL WORK(LWORK), C2AM(*) 5658 REAL ZERO 5659#else 5660 DOUBLE PRECISION WORK(LWORK), C2AM(*) 5661 DOUBLE PRECISION ZERO 5662#endif 5663! 5664 PARAMETER(ZERO = 0.0D00) 5665! 5666 INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J 5667! 5668 CALL QENTER('CCRHS3_R2IJ') 5669! 5670!----------------------------------- 5671! Allocation of workspace. 5672!----------------------------------- 5673! 5674 KSCR1 = 1 5675 KEND1 = KSCR1 + NT2AM(ISYVEC) 5676 LWRK1 = LWORK - KEND1 5677! 5678 IF (LWRK1 .LE. 0) THEN 5679 CALL QUIT('Too little workspace in CCRHS3_R2IJ ') 5680 ENDIF 5681! 5682!------------------------------------------ 5683! Copy OMEGA to workspace. 5684!------------------------------------------ 5685! 5686 CALL DCOPY(NT2AM(ISYVEC),C2AM,1,WORK(KSCR1),1) 5687 CALL DZERO(C2AM,NT2AM(ISYVEC)) 5688! 5689!------------------------------------------ 5690! Calculate the contribution. 5691!------------------------------------------ 5692! 5693 DO 100 ISYMBJ = 1,NSYM 5694 ISYMAI = MULD2H(ISYMBJ,ISYVEC) 5695! 5696 IF (ISYMAI .LE. ISYMBJ) THEN 5697! 5698 DO 110 ISYMI = 1,NSYM 5699! 5700 ISYMA = MULD2H(ISYMAI,ISYMI) 5701! 5702 DO 120 ISYMJ = 1,NSYM 5703! 5704 ISYMB = MULD2H(ISYMBJ,ISYMJ) 5705 ISYMAJ = MULD2H(ISYMA,ISYMJ) 5706 ISYMBI = MULD2H(ISYMB,ISYMI) 5707! 5708 DO 130 I = 1,NRHF(ISYMI) 5709 MI = IORB(ISYMI) + I 5710 DO 140 J = 1,NRHF(ISYMJ) 5711 MJ = IORB(ISYMJ) + J 5712! 5713 IF (MI .NE. MJ) THEN 5714 DO 150 A = 1,NVIR(ISYMA) 5715 MA = IORB(ISYMA) + NRHF(ISYMA) + A 5716 NAJ = IT1AM(ISYMA,ISYMJ) 5717 * + NVIR(ISYMA)*(J-1) + A 5718 NAI = IT1AM(ISYMA,ISYMI) 5719 * + NVIR(ISYMA)*(I-1) + A 5720! 5721 DO 160 B = 1,NVIR(ISYMB) 5722 MB = IORB(ISYMB) + NRHF(ISYMB) + B 5723! 5724 IF (MA .NE. MB) THEN 5725! 5726 NBI = IT1AM(ISYMB,ISYMI) 5727 * + NVIR(ISYMB)*(I-1) + B 5728 NBJ = IT1AM(ISYMB,ISYMJ) 5729 * + NVIR(ISYMB)*(J-1) + B 5730! 5731 IF (ISYMAI .EQ. ISYMBJ) THEN 5732! 5733 IF ((NAI .LT. NBJ) .AND. 5734 * (MA .LT. MB)) THEN 5735! 5736 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 5737 * + INDEX(NAI,NBJ) 5738! 5739 IF (ISYMAJ .EQ. ISYMBI) THEN 5740 NAJBI = IT2AM(ISYMAJ,ISYMBI) 5741 * + INDEX(NAJ,NBI) 5742 ELSEIF (ISYMAJ .LT. ISYMBI) THEN 5743 NAJBI = IT2AM(ISYMAJ,ISYMBI) 5744 * + NT1AM(ISYMAJ)*(NBI-1)+NAJ 5745 ELSEIF (ISYMAJ .GT. ISYMBI) THEN 5746 NAJBI = IT2AM(ISYMBI,ISYMAJ) 5747 * + NT1AM(ISYMBI)*(NAJ-1)+NBI 5748 ENDIF 5749! 5750 C2AM(NAJBI) = - WORK(NAIBJ) 5751 C2AM(NAIBJ) = WORK(NAIBJ) 5752! 5753 ENDIF 5754! 5755 ELSEIF (ISYMAI .LT. ISYMBJ) THEN 5756! 5757 IF (((MA .LT. MB) .AND. 5758 * (MI .LT. MJ)) .OR. 5759 * ((MA .GT. MB) .AND. 5760 * (MI .GT. MJ))) THEN 5761! 5762 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 5763 * + NT1AM(ISYMAI)*(NBJ-1) + NAI 5764! 5765 IF (ISYMAJ .EQ. ISYMBI) THEN 5766 NAJBI = IT2AM(ISYMAJ,ISYMBI) 5767 * + INDEX(NAJ,NBI) 5768 ELSEIF (ISYMAJ .LT. ISYMBI) THEN 5769 NAJBI = IT2AM(ISYMAJ,ISYMBI) 5770 * + NT1AM(ISYMAJ)*(NBI-1)+NAJ 5771 ELSEIF (ISYMAJ .GT. ISYMBI) THEN 5772 NAJBI = IT2AM(ISYMBI,ISYMAJ) 5773 * + NT1AM(ISYMBI)*(NAJ-1)+NBI 5774 ENDIF 5775! 5776 C2AM(NAJBI) = - WORK(NAIBJ) 5777 C2AM(NAIBJ) = WORK(NAIBJ) 5778! 5779 ENDIF 5780! 5781 ENDIF 5782! 5783 ENDIF 5784 160 CONTINUE 5785 150 CONTINUE 5786 ENDIF 5787 140 CONTINUE 5788 130 CONTINUE 5789 120 CONTINUE 5790 110 CONTINUE 5791 ENDIF 5792 100 CONTINUE 5793! 5794 CALL QEXIT('CCRHS3_R2IJ') 5795! 5796 RETURN 5797 END 5798 SUBROUTINE CCRHS_A3(OMEGA2,T2AM,GAMMA,WORK,LWORK,ISYGAM,ISYVEC, 5799 * IOPT,ANTISYM) 5800C 5801C Written by Henrik Koch & Ove Christiansen 20-Jan-1994 5802C 5803C Generalised to non. total sym gamma (isygam) og non. tot. sym 5804C double excitation vector (isyvec) Ove Christiansen 29-7-1995 5805C 5806C Generalised to handle left hand side contribution (IOPT 2) as 5807C well as usual contributions (IOPT 1) by Asger Halkier 22/11-95. 5808C 5809C Introduced the ANTISYM logical to calculate either the 5810C symmetric or the antisymmetric square up of GAMMA 5811C 5812C Purpose: Calculate A-term. 5813C 5814 IMPLICIT NONE 5815#include "priunit.h" 5816#include "ccorb.h" 5817#include "ccsdsym.h" 5818! 5819 INTEGER LWORK, ISYGAM, ISYVEC, IOPT 5820 INTEGER ISAIBJ, ISYMLJ, ISYMKI, KSCR1, KEND1, LWRK1 5821 INTEGER ISYML, ISYMJ, NLJ, ISYMK, ISYMI, NKI, NKILJ 5822 INTEGER NSTO, ISYMB 5823 INTEGER KOFF1, KOFF2, KOFF3, NVIRA, ISYMA, NBL, NAI, NAIBJ 5824 INTEGER NTOT, ISYMBJ, ISYMAI, ISYMBL, ISYMAK, KSCR2, KEND2 5825 INTEGER LWRK2, NBJ, NRHFK 5826 INTEGER INDEX 5827! 5828#if defined (SYS_CRAY) 5829 REAL OMEGA2(*), GAMMA(*), T2AM(*), WORK(LWORK) 5830 REAL ZERO, ONE, XMONE, FACT 5831#else 5832 DOUBLE PRECISION OMEGA2(*), GAMMA(*), T2AM(*), WORK(LWORK) 5833 DOUBLE PRECISION ZERO, ONE, XMONE, FACT 5834#endif 5835 PARAMETER(ZERO=0.0D00, ONE=1.0D00, XMONE = -1.0D00) 5836 LOGICAL ANTISYM 5837C 5838 INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J 5839C 5840 CALL QENTER('CCRHS_A3') 5841C 5842C---------------------------- 5843C Calculate contribution. 5844C---------------------------- 5845C 5846 ISAIBJ = MULD2H(ISYGAM,ISYVEC) 5847C 5848 DO 100 ISYMLJ = 1,NSYM 5849C 5850 ISYMKI = MULD2H(ISYMLJ,ISYGAM) 5851C 5852 KSCR1 = 1 5853 KEND1 = KSCR1 + NMATIJ(ISYMKI) 5854 LWRK1 = LWORK - KEND1 5855C 5856 IF (LWRK1 .LT. 0) THEN 5857 CALL QUIT('Insufficient space for allocation in CCRHS_A3') 5858 END IF 5859C 5860 DO 110 ISYMJ = 1,NSYM 5861C 5862 ISYML = MULD2H(ISYMJ,ISYMLJ) 5863C 5864 DO 120 J = 1,NRHF(ISYMJ) 5865C 5866 DO 130 L = 1,NRHF(ISYML) 5867C 5868 IF (IOPT .EQ. 1) THEN 5869C 5870 NLJ = IMATIJ(ISYML,ISYMJ) 5871 * + NRHF(ISYML)*(J - 1) + L 5872C 5873 ELSE IF (IOPT .EQ. 2) THEN 5874C 5875 NLJ = IMATIJ(ISYMJ,ISYML) 5876 * + NRHF(ISYMJ)*(L - 1) + J 5877C 5878 ENDIF 5879C 5880 DO 140 ISYMK = 1,NSYM 5881C 5882 ISYMI = MULD2H(ISYMK,ISYMKI) 5883C 5884 DO 150 I = 1,NRHF(ISYMI) 5885C 5886 DO 160 K = 1,NRHF(ISYMK) 5887C 5888 IF (IOPT .EQ. 1) THEN 5889C 5890 NKI = IMATIJ(ISYMK,ISYMI) 5891 * + NRHF(ISYMK)*(I - 1) + K 5892C 5893 ELSE IF (IOPT .EQ. 2) THEN 5894C 5895 NKI = IMATIJ(ISYMI,ISYMK) 5896 * + NRHF(ISYMI)*(K - 1) + I 5897C 5898 ENDIF 5899C 5900 IF (ISYMKI .EQ. ISYMLJ) THEN 5901 NKILJ = IGAMMA(ISYMKI,ISYMLJ) 5902 * + INDEX(NKI,NLJ) 5903 FACT = ONE 5904 IF (NKI .EQ. NLJ) FACT = ZERO 5905 IF (NKI .LT. NLJ) FACT = XMONE 5906 ELSE 5907 IF (ISYMKI .LT. ISYMLJ) THEN 5908 NKILJ = IGAMMA(ISYMKI,ISYMLJ) 5909 * + NMATIJ(ISYMKI)*(NLJ - 1) + NKI 5910 FACT = XMONE 5911 ELSE 5912 NKILJ = IGAMMA(ISYMLJ,ISYMKI) 5913 * + NMATIJ(ISYMLJ)*(NKI - 1) + NLJ 5914 FACT = ONE 5915 ENDIF 5916 ENDIF 5917C 5918 IF (.NOT. ANTISYM) FACT = ONE 5919! 5920 NSTO = IMATIJ(ISYMK,ISYMI) 5921 * + NRHF(ISYMK)*(I - 1) + K 5922C 5923 WORK(KSCR1 + NSTO - 1) = FACT * GAMMA(NKILJ) 5924C 5925 160 CONTINUE 5926 150 CONTINUE 5927 140 CONTINUE 5928C 5929 DO 170 ISYMB = 1,NSYM 5930C 5931 ISYMBJ = MULD2H(ISYMB,ISYMJ) 5932 ISYMAI = MULD2H(ISYMBJ,ISAIBJ) 5933 ISYMBL = MULD2H(ISYMB,ISYML) 5934 ISYMAK = MULD2H(ISYVEC,ISYMBL) 5935C 5936 KSCR2 = KEND1 5937 KEND2 = KSCR2 + NT1AM(ISYMAI) 5938 LWRK2 = LWORK - KEND2 5939C 5940 IF (LWRK2 .LT. 0) THEN 5941 CALL QUIT('Insufficient space in CCRHS_A3') 5942 END IF 5943C 5944 IF (ISYMAI .GT. ISYMBJ) GOTO 170 5945C 5946 DO 180 B = 1,NVIR(ISYMB) 5947C 5948 NBJ = IT1AM(ISYMB,ISYMJ) 5949 * + NVIR(ISYMB)*(J - 1) + B 5950 NBL = IT1AM(ISYMB,ISYML) 5951 * + NVIR(ISYMB)*(L - 1) + B 5952C 5953 CALL DZERO(WORK(KSCR2),NT1AM(ISYMAI)) 5954C 5955 DO 190 ISYMI = 1,NSYM 5956C 5957 ISYMK = MULD2H(ISYMI,ISYMKI) 5958 ISYMA = MULD2H(ISYMK,ISYMAK) 5959C 5960 NVIRA = MAX(NVIR(ISYMA),1) 5961 NRHFK = MAX(NRHF(ISYMK),1) 5962C 5963 KOFF1 = IT2SQ(ISYMAK,ISYMBL) 5964 * + NT1AM(ISYMAK)*(NBL - 1) 5965 * + IT1AM(ISYMA,ISYMK) + 1 5966 KOFF2 = KSCR1 + IMATIJ(ISYMK,ISYMI) 5967 KOFF3 = KSCR2 + IT1AM(ISYMA,ISYMI) 5968C 5969 CALL DGEMM('N','N',NVIR(ISYMA),NRHF(ISYMI), 5970 * NRHF(ISYMK),ONE,T2AM(KOFF1), 5971 * NVIRA,WORK(KOFF2),NRHFK,ZERO, 5972 * WORK(KOFF3),NVIRA) 5973C 5974 190 CONTINUE 5975C 5976 IF (ISYMAI .EQ. ISYMBJ) THEN 5977 NTOT = NBJ 5978 ELSE 5979 NTOT = NT1AM(ISYMAI) 5980 ENDIF 5981C 5982 DO 200 NAI = 1,NTOT 5983C 5984 IF (ISYMAI .EQ. ISYMBJ) THEN 5985 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 5986 * + INDEX(NAI,NBJ) 5987 ELSE 5988 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 5989 * + NT1AM(ISYMAI)*(NBJ - 1) + NAI 5990 ENDIF 5991C 5992 OMEGA2(NAIBJ) = OMEGA2(NAIBJ) 5993 * + WORK(KSCR2 + NAI - 1) 5994C 5995 200 CONTINUE 5996C 5997 180 CONTINUE 5998 170 CONTINUE 5999C 6000 130 CONTINUE 6001 120 CONTINUE 6002 110 CONTINUE 6003 100 CONTINUE 6004C 6005 CALL QEXIT('CCRHS_A3') 6006C 6007 RETURN 6008 END 6009C /* Deck cc_t2sq3 */ 6010 SUBROUTINE CC_T2SQ3(T2AM,T2SQ,ISYM) 6011! 6012!-------------------------------------------------------- 6013! Kasper Hald 8/3-1999 to squareup a 6014! antisymmetric matrix as in the triplet case. 6015! 6016! Based on CC_T2SQ by Henrik Koch, Alfredo Sanchez 6017! and Ove Christiansen. 6018!-------------------------------------------------------- 6019! 6020 IMPLICIT NONE 6021#if defined (SYS_CRAY) 6022 REAL T2AM(*), T2SQ(*) 6023#else 6024 DOUBLE PRECISION T2AM(*), T2SQ(*) 6025#endif 6026 INTEGER ISYM, KOFF1, KOFF2, ISYMBJ, KOFF, ISYMAI, NAMP, NAI 6027 INTEGER NBJ 6028#include "priunit.h" 6029#include "ccorb.h" 6030#include "ccsdsym.h" 6031! 6032 CALL QENTER('CC_T2SQ3') 6033! 6034 IF (ISYM.EQ.1) THEN 6035 KOFF1 = 1 6036 KOFF2 = 1 6037 DO 100 ISYMBJ = 1,NSYM 6038 IF (NT1AM(ISYMBJ) .GT. 0) THEN 6039 CALL SQMATR3(NT1AM(ISYMBJ),T2AM(KOFF1),T2SQ(KOFF2)) 6040 KOFF1 = KOFF1 + NT1AM(ISYMBJ)*(NT1AM(ISYMBJ)+1)/2 6041 KOFF2 = KOFF2 + NT1AM(ISYMBJ)*NT1AM(ISYMBJ) 6042 ENDIF 6043 100 CONTINUE 6044! 6045 ELSE 6046! 6047 KOFF = 1 6048 DO 200 ISYMBJ = 1,NSYM 6049 ISYMAI = MULD2H(ISYM,ISYMBJ) 6050! 6051 IF (ISYMBJ.GT.ISYMAI) THEN 6052! 6053 NAMP = NT1AM(ISYMAI)*NT1AM(ISYMBJ) 6054! 6055 IF (NAMP .GT. 0) THEN 6056 KOFF1 = IT2SQ(ISYMAI,ISYMBJ) + 1 6057 CALL DCOPY(NAMP,T2AM(KOFF),1,T2SQ(KOFF1),1) 6058 NAI = MAX(NT1AM(ISYMAI),1) 6059 NBJ = MAX(NT1AM(ISYMBJ),1) 6060 KOFF2 = IT2SQ(ISYMBJ,ISYMAI) + 1 6061 CALL TRM3(T2AM(KOFF),NAI,NT1AM(ISYMAI),NT1AM(ISYMBJ), 6062 * T2SQ(KOFF2),NBJ) 6063 KOFF = KOFF + NAMP 6064! 6065 ENDIF 6066! 6067 ENDIF 6068! 6069 200 CONTINUE 6070! 6071 ENDIF 6072! 6073 CALL QEXIT('CC_T2SQ3') 6074! 6075 RETURN 6076 END 6077! /* Deck trm3 */ 6078 SUBROUTINE TRM3(A,LDA,M,N,B,LDB) 6079! 6080!--------------------------------------------------------------- 6081! 6082! Transpose a matrix A with dimension m,n 6083! in array with logical dim. lda. 6084! and put minus the result into B with logical dim. ldb. 6085! 6086! Kasper Hald 8/3 - 1999 6087! 6088! Based on TRM by Ove Christiansen. 6089!--------------------------------------------------------------- 6090! 6091 IMPLICIT NONE 6092#include "priunit.h" 6093! 6094 INTEGER LDA, LDB, M, N, I 6095#if defined (SYS_CRAY) 6096 REAL A(LDA,*), B(LDB,*) 6097 REAL XMONE 6098#else 6099 DOUBLE PRECISION A(LDA,*), B(LDB,*) 6100 DOUBLE PRECISION XMONE 6101#endif 6102 PARAMETER(XMONE = -1.0D00) 6103! 6104 CALL QENTER('TRM3') 6105! 6106 DO 100 I = 1, N 6107! 6108 CALL DSCAL(M,XMONE,A(1,I),1) 6109 CALL DCOPY(M,A(1,I),1,B(I,1),LDB) 6110 CALL DSCAL(M,XMONE,A(1,I),1) 6111! 6112 100 CONTINUE 6113! 6114 CALL QEXIT('TRM3') 6115! 6116 RETURN 6117 END 6118C /* Deck sqmatr3 */ 6119 SUBROUTINE SQMATR3(NDIM,PKMAT,SQMAT) 6120! 6121!----------------------------------------------------- 6122! Written by Kasper Hald 8/3-1999 6123! 6124! This subroutine squares up the packed 6125! triplet matrix for the totalsymmetric case. 6126! 6127! Based on SQMATR by Henrik Koch. 6128!----------------------------------------------------- 6129! 6130 IMPLICIT NONE 6131#include "priunit.h" 6132 INTEGER I, J, NDIM, IJ 6133#if defined (SYS_CRAY) 6134 REAL PKMAT(*), SQMAT(NDIM,NDIM) 6135 REAL ZERO,XMONE 6136#else 6137 DOUBLE PRECISION PKMAT(*), SQMAT(NDIM,NDIM) 6138 DOUBLE PRECISION ZERO,XMONE 6139#endif 6140! 6141 PARAMETER(XMONE = -1.0D00) 6142! 6143 CALL QENTER('SQMATR3') 6144! 6145 DO 100 I = 1,NDIM 6146 DO 110 J = 1,I 6147! 6148 IJ = I*(I-1)/2 + J 6149 SQMAT(I,J) = XMONE * PKMAT(IJ) 6150 SQMAT(J,I) = PKMAT(IJ) 6151! 6152 110 CONTINUE 6153 100 CONTINUE 6154! 6155 CALL QEXIT('SQMATR3') 6156! 6157 RETURN 6158 END 6159C /* Deck cc_t2motrip */ 6160 SUBROUTINE CC_T2MOTRIP(RHO1,CTR2,ISYMC2,OMEGA2,RHO2,GAMMA, 6161 * XLAMDP,XLAMPC,ISYMPC,WORK,LWORK,ISYMBF, 6162 * ICON,RHO22,RHO22CONT,ANTISYM) 6163C 6164C Henrik Koch and Alfredo Sanchez. 15-July-1994 6165C 6166C Transform the Omega2 vector from the AO basis to the MO 6167C basis. 6168C 6169C Ove Christiansen 4-8-1995: 6170C 6171C Generalizations for CC response. 6172C 6173C 1.ISYMBF is the symmetry of the BF (ali,bej) vector. 6174C 2.Transform with a non total symmetric lambda matrix. 6175C (one with sym 1 and one with sym isympc) 6176C 6177C note that if newgam is true gamma is the gamma vector on return 6178C with the same symmetry as the input BF. 6179C (transformed with xlamdp) 6180C 6181C if newgam is false the gamma intermediate is not returned. 6182C 6183C ICON is 2 for response to calculat a-tild,ibj and ai,b-tilde,j 6184C 6185C NB these changes are only carried through completely and 6186C tested for omegor 6187C 6188C Asger Halkier 2/11-1995: 6189C 6190C For ICON equal to 3 the contraction of the (ali,bej) vector with 6191C the trialvector CTR2 (i.e the LT21BF-term) is calculated and 6192C stored in RHO1! 6193C 6194C Ove Christiansen 4-10-1996: 6195C 6196C For use in F-matrix generalize ICON .EQ. 3 section 6197C 6198! Kasper Hald and Christof Haettig. 12-3-1999 6199! 6200! If ANTISYM then rho is calculated as 6201! INTP*KT2MM + INTM*KT2MP 6202! 6203! For ICON .EQ. 1 AND antisym then we will get 6204! Lambda(al a) * Lambda(be b) * rho(ANTISYM) 6205! 6206! To ONLY calculate the new GAMMA ICON=4 6207! The calculated gamma will be added to the excisting gamma 6208! 6209! For ICON .EQ. 5 we calculate 6210! (Lambda(bar)(be b)Lambda(al a) - Lambda(bar)(al a)Lambda(be b)) 6211! * rho(symmetric) and store it in RHO2. 6212! (Lambda(bar)(be b)Lambda(al a) + Lambda(bar)(al a)Lambda(be b)) 6213! * rho(symmetric) and store it in RHO22. 6214! 6215! For ICON .EQ. 6 : Here KT2MP is identical to zero (C2+ in the 6216! triplet case) so we only calculate INTM*KT2MM 6217! 6218C NOTE: Linear response options only valid and debugged for OMEGOR! 6219C 6220 IMPLICIT NONE 6221#include "priunit.h" 6222#include "maxorb.h" 6223#include "ccorb.h" 6224#include "ccsdsym.h" 6225#include "symsq.h" 6226#include "cclr.h" 6227! 6228 INTEGER INDEX, ISYMBF, ISYMPC, ISYMO1, ISYMO2, ISYMC2, ICON 6229 INTEGER ISYMJ, ISYMI, ISYMIJ, ISALBE, ISYMAB, ISYBE, ISYAL 6230 INTEGER ISYALI, ISYBEJ, ISYMA, NVA, NRA, ISYMB, NVB, NRB 6231 INTEGER KSCR1, KSCR2, KSCR3, KSCR4, KSCR5, KEND1, LWRK1 6232 INTEGER LWORK, NAI, NBJ, NAB, NAIBJ, NBJAI, NIJ, NABP 6233 INTEGER NABIJP, NABIJM, ISYMAI, ISYMBJ, NBASA, NBASB 6234 INTEGER NVIRA, KOFF1, KOFF2, ISYMK, ISYMC, ISYMD, ISYDI 6235 INTEGER ISYCJ, LENGTH, NTOTAL, NTOTBE, NTOTK, NCJ 6236 INTEGER NDICJ, NCK, NRHFA1, ISYML, ISYMKI, ISYMLJ, NLJ 6237 INTEGER NKL, NKI, NKILJ 6238! 6239#if defined (SYS_CRAY) 6240 REAL ZERO, HALF, ONE, TWO, FAC, FAC1, FAC2, FACT 6241 REAL RHO1(*), CTR2(*), OMEGA2(*), RHO2(*), GAMMA(*) 6242 REAL GAMMA(*), XLAMDP(*), WORK(*), XLAMPC(*), RHO22(*) 6243#else 6244 DOUBLE PRECISION ZERO, HALF, ONE, TWO, FAC, FAC1, FAC2, FACT 6245 DOUBLE PRECISION RHO1(*), CTR2(*), OMEGA2(*), RHO2(*), GAMMA(*) 6246 DOUBLE PRECISION XLAMDP(*), WORK(*), XLAMPC(*), RHO22(*) 6247#endif 6248 PARAMETER (ZERO= 0.0D00, HALF= 0.5D00, ONE= 1.0D00, TWO= 2.0D00) 6249! 6250 LOGICAL ANTISYM, RHO22CONT 6251C 6252 INDEX(I,J) = MAX(I,J)*(MAX(I,J)-3)/2 + I + J 6253C 6254 CALL QENTER('CC_T2MOTRIP') 6255C 6256 ISYMO2 = MULD2H(ISYMBF,ISYMPC) 6257 ISYMO1 = MULD2H(ISYMO2,ISYMC2) 6258C 6259 IF (ICON .NE. 3) THEN 6260 CALL DZERO(RHO2,NT2AM(ISYMO2)) 6261 ENDIF 6262C 6263 DO 100 ISYMJ = 1,NSYM 6264 DO 110 ISYMI = 1,NSYM 6265C 6266 ISYMIJ = MULD2H(ISYMI,ISYMJ) 6267 ISALBE = MULD2H(ISYMIJ,ISYMBF) 6268 ISYMAB = MULD2H(ISYMIJ,ISYMO2) 6269C 6270 DO 120 ISYBE = 1,NSYM 6271C 6272 ISYAL = MULD2H(ISYBE,ISALBE) 6273 ISYALI = MULD2H(ISYAL,ISYMI) 6274 ISYBEJ = MULD2H(ISYBE,ISYMJ) 6275C 6276C----------------------------------------------- 6277C Dynamic allocation of work space. 6278C----------------------------------------------- 6279C 6280 ISYMA = MULD2H(ISYAL,ISYMPC) 6281 NVA = MAX(NVIR(ISYMA),NVIR(ISYAL)) 6282 NRA = MAX(NRHF(ISYMA),NRHF(ISYAL)) 6283 ISYMB = MULD2H(ISYBE,ISYMPC) 6284 NVB = MAX(NVIR(ISYMB),NVIR(ISYBE),NRHF(ISYBE)) 6285 NRB = MAX(NRHF(ISYMB),NRHF(ISYBE)) 6286C 6287 KSCR1 = 1 6288 KSCR2 = KSCR1 + NBAS(ISYAL)*NBAS(ISYBE) 6289 KSCR3 = KSCR2 + NBAS(ISYAL)*NVB 6290 IF (NEWGAM) THEN 6291 KSCR4 = KSCR3 + NVA*NVB 6292 KSCR5 = KSCR4 + NBAS(ISYAL)*NRB 6293 KEND1 = KSCR5 + NRA*NRB 6294 ELSE 6295 KEND1 = KSCR3 + NVA*NVB 6296 END IF 6297 LWRK1 = LWORK - KEND1 6298C 6299 IF (LWRK1 .LT. 0) THEN 6300 CALL QUIT('Not enough space in CC_T2MOTRIP') 6301 END IF 6302C 6303 DO 130 J = 1,NRHF(ISYMJ) 6304 DO 140 I = 1,NRHF(ISYMI) 6305C 6306C------------------------------------------ 6307C Squareup the AB block. 6308C------------------------------------------ 6309C 6310 IF ((.NOT. OMEGSQ) .AND. (.NOT. OMEGOR)) THEN 6311C 6312 DO 150 B = 1,NBAS(ISYBE) 6313 NBJ = IT1AO(ISYBE,ISYMJ) 6314 * + NBAS(ISYBE)*(J-1) + B 6315 DO 155 A = 1,NBAS(ISYAL) 6316C 6317 NAI = IT1AO(ISYAL,ISYMI) 6318 * + NBAS(ISYAL)*(I-1) + A 6319 NAB = KSCR1 + NBAS(ISYAL)*(B - 1) + A - 1 6320C 6321 IF (ISYMO2 .EQ. 1) THEN 6322 NAIBJ = IT2AO(ISYALI,ISYBEJ) 6323 * + INDEX(NAI,NBJ) 6324 ELSEIF (ISYALI .LT. ISYBEJ) THEN 6325 NAIBJ = IT2AO(ISYALI,ISYBEJ) 6326 * + NT1AO(ISYALI)*(NBJ - 1) + NAI 6327 ELSEIF (ISYALI .GT. ISYBEJ) THEN 6328 NAIBJ = IT2AO(ISYALI,ISYBEJ) 6329 * + NT1AO(ISYBEJ)*(NAI - 1) + NBJ 6330 ENDIF 6331C 6332 WORK(NAB) = OMEGA2(NAIBJ) 6333C 6334 155 CONTINUE 6335 150 CONTINUE 6336C 6337 ENDIF 6338C 6339 IF (OMEGSQ) THEN 6340C 6341 DO 160 B = 1,NBAS(ISYBE) 6342 NBJ = IT1AO(ISYBE,ISYMJ) 6343 * + NBAS(ISYBE)*(J-1) + B 6344 DO 165 A = 1,NBAS(ISYAL) 6345C 6346 NAI = IT1AO(ISYAL,ISYMI) 6347 * + NBAS(ISYAL)*(I-1) + A 6348 NAB = KSCR1 + NBAS(ISYAL)*(B - 1) + A - 1 6349C 6350 NAIBJ = IT2AOS(ISYALI,ISYBEJ) 6351 * + NT1AO(ISYALI)*(NBJ - 1) + NAI 6352 NBJAI = IT2AOS(ISYBEJ,ISYALI) 6353 * + NT1AO(ISYBEJ)*(NAI - 1) + NBJ 6354C 6355 WORK(NAB) = OMEGA2(NAIBJ) + OMEGA2(NBJAI) 6356C 6357 165 CONTINUE 6358 160 CONTINUE 6359C 6360 ENDIF 6361C 6362 IF (OMEGOR) THEN 6363! 6364 IF (.NOT. ANTISYM) THEN 6365! 6366 IF (ISYMI .EQ. ISYMJ) THEN 6367 NIJ = IMIJP(ISYMI,ISYMJ) + INDEX(I,J) 6368 FAC1 = ONE 6369 IF (I .GT. J) FAC1 = -ONE 6370 ELSE IF (ISYMI .LT. ISYMJ) THEN 6371 NIJ = IMIJP(ISYMI,ISYMJ) 6372 * + NRHF(ISYMI)*(J - 1) + I 6373 FAC1 = ONE 6374 ELSE 6375 NIJ = IMIJP(ISYMI,ISYMJ) 6376 * + NRHF(ISYMJ)*(I - 1) + J 6377 FAC1 = -ONE 6378 ENDIF 6379C 6380 DO 166 B = 1,NBAS(ISYBE) 6381 DO 167 A = 1,NBAS(ISYAL) 6382C 6383 IF (ISYAL .EQ. ISYBE) THEN 6384 NABP = IAODPK(ISYAL,ISYBE) 6385 * + INDEX(A,B) 6386 FAC2 = ONE 6387 IF (A .GT. B) FAC2 = -ONE 6388 ELSE IF (ISYAL .LT. ISYBE) THEN 6389 NABP = IAODPK(ISYAL,ISYBE) 6390 * + NBAS(ISYAL)*(B - 1) + A 6391 FAC2 = ONE 6392 ELSE 6393 NABP = IAODPK(ISYAL,ISYBE) 6394 * + NBAS(ISYBE)*(A - 1) + B 6395 FAC2 = -ONE 6396 ENDIF 6397C 6398 IF (ICON .NE. 6) THEN 6399 NABIJP = IT2ORT(ISALBE,ISYMIJ) 6400 * + NNBST(ISALBE)*(NIJ - 1) + NABP 6401C 6402 NABIJM = NT2ORT(ISYMBF) 6403 * + IT2ORT(ISALBE,ISYMIJ) 6404 * + NNBST(ISALBE)*(NIJ - 1) + NABP 6405! 6406 ELSE 6407 NABIJM = IT2ORT(ISALBE,ISYMIJ) 6408 * + NNBST(ISALBE)*(NIJ - 1) + NABP 6409! 6410 ENDIF 6411C 6412 NAB = KSCR1 + NBAS(ISYAL)*(B - 1) + A - 1 6413C 6414 FAC = FAC1*FAC2 6415C 6416 IF (ICON .NE. 6) THEN 6417 WORK(NAB) = 6418 * HALF*(OMEGA2(NABIJP) + FAC*OMEGA2(NABIJM)) 6419 ELSE 6420 WORK(NAB) = HALF*FAC*OMEGA2(NABIJM) 6421 ENDIF 6422C 6423 167 CONTINUE 6424 166 CONTINUE 6425C 6426 ELSE 6427! 6428 IF (ISYMI .EQ. ISYMJ) THEN 6429 NIJ = IMIJP(ISYMI,ISYMJ) + INDEX(I,J) 6430 FAC1 = ONE 6431 IF (I .GT. J) FAC1 = -ONE 6432! 6433 ELSE IF (ISYMI .LT. ISYMJ) THEN 6434 NIJ = IMIJP(ISYMI,ISYMJ) 6435 * + NRHF(ISYMI)*(J - 1) + I 6436 FAC1 = ONE 6437 ELSE 6438 NIJ = IMIJP(ISYMI,ISYMJ) 6439 * + NRHF(ISYMJ)*(I - 1) + J 6440 FAC1 = -ONE 6441 ENDIF 6442! 6443 DO 168 B = 1,NBAS(ISYBE) 6444 DO 169 A = 1,NBAS(ISYAL) 6445! 6446 IF (ISYAL .EQ. ISYBE) THEN 6447 NABP = IAODPK(ISYAL,ISYBE) 6448 * + INDEX(A,B) 6449 FAC2 = ONE 6450 IF (A .GT. B) FAC2 = -ONE 6451 ELSE IF (ISYAL .LT. ISYBE) THEN 6452 NABP = IAODPK(ISYAL,ISYBE) 6453 * + NBAS(ISYAL)*(B - 1) + A 6454 FAC2 = ONE 6455 ELSE 6456 NABP = IAODPK(ISYAL,ISYBE) 6457 * + NBAS(ISYBE)*(A - 1) + B 6458 FAC2 = -ONE 6459 ENDIF 6460! 6461 NABIJP = IT2ORT(ISALBE,ISYMIJ) 6462 * + NNBST(ISALBE)*(NIJ - 1) + NABP 6463! 6464 NABIJM = NT2ORT(ISYMBF) 6465 * + IT2ORT(ISALBE,ISYMIJ) 6466 * + NNBST(ISALBE)*(NIJ - 1) + NABP 6467! 6468 NAB = KSCR1 + NBAS(ISYAL)*(B - 1) + A - 1 6469! 6470! 6471 IF ((ISYAL .EQ. ISYBE) .AND. 6472 * (ISYMI. EQ. ISYMJ) .AND. (A .EQ. B) 6473 * .AND. (I .EQ. J)) THEN 6474! 6475 WORK(NAB) = ZERO 6476! 6477 ELSE 6478! 6479 WORK(NAB) = 6480 * HALF*(OMEGA2(NABIJP)*FAC2 6481 * + FAC1*OMEGA2(NABIJM)) 6482 ENDIF 6483! 6484 169 CONTINUE 6485 168 CONTINUE 6486! 6487 ENDIF 6488C 6489C------------------------------------------------------------ 6490C Transform the AB block to virtual space. 6491C------------------------------------------------------------ 6492C 6493! IF (.NOT. (ICON .EQ. 4)) THEN 6494! 6495 IF (ICON .NE. 3) THEN 6496C 6497 ISYMA = MULD2H(ISYAL,ISYMPC) 6498 ISYMB = ISYBE 6499 ISYMAI = MULD2H(ISYMA,ISYMI) 6500 ISYMBJ = MULD2H(ISYMB,ISYMJ) 6501C 6502 NBASA = MAX(NBAS(ISYAL),1) 6503 NBASB = MAX(NBAS(ISYBE),1) 6504 NVIRA = MAX(NVIR(ISYMA),1) 6505C 6506 KOFF1 = ILMVIR(ISYBE) + 1 6507C 6508 CALL DGEMM('N','N',NBAS(ISYAL),NVIR(ISYMB), 6509 * NBAS(ISYBE),ONE,WORK(KSCR1),NBASA, 6510 * XLAMDP(KOFF1),NBASB,ZERO,WORK(KSCR2), 6511 * NBASA) 6512C 6513 KOFF2 = IGLMVI(ISYAL,ISYMA) + 1 6514C 6515 CALL DGEMM('T','N',NVIR(ISYMA),NVIR(ISYMB), 6516 * NBAS(ISYAL),ONE,XLAMPC(KOFF2),NBASA, 6517 * WORK(KSCR2),NBASA,ZERO,WORK(KSCR3), 6518 * NVIRA) 6519C 6520C-------------------------------------------- 6521C Store the omega2 vector. 6522C-------------------------------------------- 6523C 6524 DO 170 B = 1,NVIR(ISYMB) 6525 NBJ = IT1AM(ISYMB,ISYMJ) 6526 * + NVIR(ISYMB)*(J-1) + B 6527 DO 180 A = 1,NVIR(ISYMA) 6528C 6529 NAI = IT1AM(ISYMA,ISYMI) 6530 * + NVIR(ISYMA)*(I-1) + A 6531 NAB = KSCR3 + NVIR(ISYMA)*(B - 1) + A - 1 6532C 6533 IF (ISYMAI .EQ. ISYMBJ) THEN 6534C 6535 IF (NAI .GT. NBJ) GOTO 180 6536C 6537 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 6538 * + INDEX(NAI,NBJ) 6539 ELSEIF (ISYMAI .LT. ISYMBJ) THEN 6540 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 6541 * + NT1AM(ISYMAI)*(NBJ - 1) + NAI 6542 ELSEIF (ISYMAI .GT. ISYMBJ) THEN 6543 GOTO 180 6544c NAIBJ = IT2AM(ISYMAI,ISYMBJ) 6545c * + NT1AM(ISYMBJ)*(NAI - 1) + NBJ 6546 ENDIF 6547C 6548 RHO2(NAIBJ) = RHO2(NAIBJ) + WORK(NAB) 6549! 6550 IF ((ICON .EQ.5) .AND. (RHO22CONT)) THEN 6551 RHO22(NAIBJ) = RHO22(NAIBJ) + WORK(NAB) 6552 ENDIF 6553C 6554 180 CONTINUE 6555 170 CONTINUE 6556C 6557 ENDIF 6558C 6559C-------------------------------------- 6560C CCLR contribution. 6561C-------------------------------------- 6562C 6563 IF ((ICON .EQ. 2) .OR. (ICON .EQ. 5)) THEN 6564C 6565 CALL DZERO(WORK(KSCR2),NVA*NVB) 6566 ISYMA = ISYAL 6567 ISYMB = MULD2H(ISYBE,ISYMPC) 6568 ISYMAI = MULD2H(ISYMA,ISYMI) 6569 ISYMBJ = MULD2H(ISYMB,ISYMJ) 6570C 6571 NBASA = MAX(NBAS(ISYAL),1) 6572 NBASB = MAX(NBAS(ISYBE),1) 6573 NVIRA = MAX(NVIR(ISYMA),1) 6574C 6575 IF ((ICON .EQ. 5)) THEN 6576 FACT = -ONE 6577 ELSE 6578 FACT = ONE 6579 ENDIF 6580C 6581 KOFF1 = IGLMVI(ISYBE,ISYMB) + 1 6582C 6583 CALL DGEMM('N','N',NBAS(ISYAL),NVIR(ISYMB), 6584 * NBAS(ISYBE),FACT,WORK(KSCR1),NBASA, 6585 * XLAMPC(KOFF1),NBASB,ZERO,WORK(KSCR2), 6586 * NBASA) 6587C 6588 KOFF2 = ILMVIR(ISYAL) + 1 6589C 6590 CALL DGEMM('T','N',NVIR(ISYMA),NVIR(ISYMB), 6591 * NBAS(ISYAL),ONE,XLAMDP(KOFF2),NBASA, 6592 * WORK(KSCR2),NBASA,ZERO,WORK(KSCR3), 6593 * NVIRA) 6594C 6595C-------------------------------------------- 6596C Store the omega2 vector. 6597C-------------------------------------------- 6598C 6599 DO 181 B = 1,NVIR(ISYMB) 6600 NBJ = IT1AM(ISYMB,ISYMJ) 6601 * + NVIR(ISYMB)*(J-1) + B 6602 DO 182 A = 1,NVIR(ISYMA) 6603C 6604 NAI = IT1AM(ISYMA,ISYMI) 6605 * + NVIR(ISYMA)*(I-1) + A 6606C 6607 IF (ISYMAI .EQ. ISYMBJ) THEN 6608 IF (NAI .GT. NBJ ) GOTO 182 6609 NAIBJ = IT2AM(ISYALI,ISYBEJ) 6610 * + INDEX(NAI,NBJ) 6611 ELSEIF (ISYMAI .LT. ISYMBJ) THEN 6612 NAIBJ = IT2AM(ISYMAI,ISYMBJ) 6613 * + NT1AM(ISYMAI)*(NBJ - 1) + NAI 6614 ELSEIF (ISYMAI .GT. ISYMBJ) THEN 6615 GOTO 182 6616c NAIBJ = IT2AM(ISYMAI,ISYMBJ) 6617c * + NT1AM(ISYMBJ)*(NAI - 1) + NBJ 6618 ENDIF 6619C 6620 NAB = KSCR3+ NVIR(ISYMA)*(B - 1) + A - 1 6621 RHO2(NAIBJ) = RHO2(NAIBJ) + WORK(NAB) 6622! 6623 IF ((ICON .EQ. 5) .AND. (RHO22CONT)) THEN 6624 RHO22(NAIBJ) = RHO22(NAIBJ) - WORK(NAB) 6625 ENDIF 6626C 6627 182 CONTINUE 6628 181 CONTINUE 6629C 6630 ENDIF 6631C 6632C============================================================ 6633C Section for calculating the LT21BF-term. 6634C============================================================ 6635C 6636 IF (ICON .EQ. 3) THEN 6637C 6638 ISYMK = ISYBE 6639 ISYMD = MULD2H(ISYAL,ISYMPC) 6640 ISYMC = MULD2H(ISYMK,ISYMO1) 6641 ISYDI = MULD2H(ISYMD,ISYMI) 6642 ISYCJ = MULD2H(ISYMC,ISYMJ) 6643C 6644 LENGTH = NBAS(ISYAL)*NRHF(ISYMK) 6645C 6646 CALL DZERO(WORK(KSCR2),LENGTH) 6647C 6648C---------------------------------------------------------- 6649C Transform the AO-block to MO-basis. 6650C---------------------------------------------------------- 6651C 6652 KOFF1 = ILMRHF(ISYMK) + 1 6653C 6654 NTOTAL = MAX(NBAS(ISYAL),1) 6655 NTOTBE = MAX(NBAS(ISYBE),1) 6656C 6657 CALL DGEMM('N','N',NBAS(ISYAL),NRHF(ISYMK), 6658 * NBAS(ISYBE),ONE,WORK(KSCR1),NTOTAL, 6659 * XLAMDP(KOFF1),NTOTBE,ZERO, 6660 * WORK(KSCR2),NTOTAL) 6661C 6662 KOFF2 = IGLMVI(ISYAL,ISYMD) + 1 6663C 6664 NTOTAL = MAX(NBAS(ISYAL),1) 6665 NTOTK = MAX(NRHF(ISYMK),1) 6666C 6667 CALL DGEMM('T','N',NRHF(ISYMK),NVIR(ISYMD), 6668 * NBAS(ISYAL),ONE,WORK(KSCR2),NTOTAL, 6669 * XLAMPC(KOFF2),NTOTAL,ZERO, 6670 * WORK(KSCR3),NTOTK) 6671C 6672C----------------------------------------------------------------- 6673C Contraction with CTR2 & storage in result. 6674C----------------------------------------------------------------- 6675C 6676 DO 47 C = 1,NVIR(ISYMC) 6677C 6678 NCJ = IT1AM(ISYMC,ISYMJ) 6679 * + NVIR(ISYMC)*(J - 1) + C 6680 NDICJ = IT2SQ(ISYDI,ISYCJ) 6681 * + NT1AM(ISYDI)*(NCJ - 1) 6682 * + IT1AM(ISYMD,ISYMI) 6683 * + NVIR(ISYMD)*(I - 1) + 1 6684 NCK = IT1AM(ISYMC,ISYMK) + C 6685C 6686 CALL DGEMV('N',NRHF(ISYMK),NVIR(ISYMD), 6687 * -ONE,WORK(KSCR3),NTOTK, 6688 * CTR2(NDICJ),1,ONE,RHO1(NCK), 6689 * NVIR(ISYMC)) 6690C 6691 47 CONTINUE 6692C 6693 ENDIF 6694C 6695 ENDIF 6696! 6697C------------------------------------------------------------- 6698C Transform the AB block to occupied space. 6699C------------------------------------------------------------- 6700C 6701 IF (.NOT. NEWGAM) GOTO 999 6702C 6703 NBASA = MAX(NBAS(ISYAL),1) 6704 NBASB = MAX(NBAS(ISYBE),1) 6705 NRHFA1 = MAX(NRHF(ISYAL),1) 6706C 6707 KOFF1 = ILMRHF(ISYBE) + 1 6708C 6709 CALL DGEMM('N','N',NBAS(ISYAL),NRHF(ISYBE), 6710 * NBAS(ISYBE),ONE,WORK(KSCR1),NBASA, 6711 * XLAMDP(KOFF1),NBASB,ZERO,WORK(KSCR4), 6712 * NBASA) 6713C 6714 KOFF2 = ILMRHF(ISYAL) + 1 6715C 6716 CALL DGEMM('T','N',NRHF(ISYAL),NRHF(ISYBE), 6717 * NBAS(ISYAL),ONE,XLAMDP(KOFF2),NBASA, 6718 * WORK(KSCR4),NBASA,ZERO,WORK(KSCR5), 6719 * NRHFA1) 6720C 6721C------------------------------------------- 6722C Store the gamma matrix. 6723C------------------------------------------- 6724C 6725 ISYMK = ISYAL 6726 ISYML = ISYBE 6727C 6728 ISYMKI = MULD2H(ISYMK,ISYMI) 6729 ISYMLJ = MULD2H(ISYML,ISYMJ) 6730C 6731 DO 190 L = 1,NRHF(ISYML) 6732C 6733 NLJ = IMATIJ(ISYML,ISYMJ) 6734 * + NRHF(ISYML)*(J - 1) + L 6735C 6736 DO 200 K = 1,NRHF(ISYMK) 6737C 6738 NKL = KSCR5 + NRHF(ISYMK)*(L - 1) + K - 1 6739C 6740 NKI = IMATIJ(ISYMK,ISYMI) 6741 * + NRHF(ISYMK)*(I - 1) + K 6742C 6743 IF (ISYMKI .EQ. ISYMLJ) THEN 6744 NKILJ = IGAMMA(ISYMKI,ISYMLJ) 6745 * + INDEX(NKI,NLJ) 6746 IF (NKI .LE. NLJ) THEN 6747 GAMMA(NKILJ) = GAMMA(NKILJ) 6748 * + WORK(NKL) 6749 ENDIF 6750 ELSE IF (ISYMKI .LT. ISYMLJ) THEN 6751 NKILJ = IGAMMA(ISYMKI,ISYMLJ) 6752 * + NMATIJ(ISYMKI)*(NLJ - 1) + NKI 6753 GAMMA(NKILJ) = GAMMA(NKILJ) + WORK(NKL) 6754 ENDIF 6755C 6756 200 CONTINUE 6757 190 CONTINUE 6758 999 CONTINUE 6759 140 CONTINUE 6760 130 CONTINUE 6761 120 CONTINUE 6762 110 CONTINUE 6763 100 CONTINUE 6764C 6765 CALL QEXIT('CC_T2MOTRIP') 6766C 6767 RETURN 6768 END 6769C /* Deck hescompa */ 6770 SUBROUTINE HESCOMPA(REDHES1,REDHES2,NREDH,NCOMPO,COMTHRES) 6771! 6772! Written by Kasper Hald 3/2-2000 6773! 6774! Compares 2 Hessian matrices. 6775! This routine is only meant to be used for 6776! comparisons of "small" arrays, since it scales 6777! as N^8 6778! 6779! REDHES1 and REDHES2 are the 2 Hessians (Surprise?) 6780! NREDH are the number of vectors/components that are 6781! important. 6782! NCOMPO are the no. of components per vector (greater or equal 6783! to NREDH) 6784! COMTHRES is the threshold that you compare against 6785! 6786 IMPLICIT NONE 6787! 6788#include "priunit.h" 6789! 6790 INTEGER NREDH, NCOMPO, I, J, K, L, KOFF1, KOFF2 6791! 6792#if defined (SYS_CRAY) 6793 REAL REDHES1(*), REDHES2(*), COMTHRES 6794 REAL DIFF1, DIFF2 6795#else 6796 DOUBLE PRECISION REDHES1(*), REDHES2(*), COMTHRES 6797 DOUBLE PRECISION DIFF1, DIFF2 6798#endif 6799! 6800 CALL QENTER('HESCOMPA') 6801! 6802 WRITE(LUPRI,*)' ' 6803 WRITE(LUPRI,*)'THRESHOLD FOR HESCOMPA = ',COMTHRES 6804 WRITE(LUPRI,*)' ' 6805! 6806 DO I=1,NREDH 6807! 6808 DO J=1,NREDH 6809! 6810 KOFF1 = (I-1)*NCOMPO + J 6811 KOFF2 = (J-1)*NCOMPO + I 6812! 6813C IF ((ABS(REDHES1(KOFF1)) .LT. COMTHRES) .AND. 6814C * (ABS(REDHES2(KOFF1)) .GT. COMTHRES)) THEN 6815C WRITE(LUPRI,*)'Diff.1 for (J,I) = ',J,I 6816C WRITE(LUPRI,*)'REDHES1(KOFF1) = ',REDHES1(KOFF1) 6817C WRITE(LUPRI,*)'REDHES2(KOFF1) = ',REDHES2(KOFF1) 6818C ENDIF 6819 IF ((ABS(REDHES1(KOFF1)) .GT. COMTHRES) .AND. 6820 * (ABS(REDHES2(KOFF1)) .LT. COMTHRES)) THEN 6821 WRITE(LUPRI,*)'Diff.2 for (J,I) =',J,I 6822 WRITE(LUPRI,*)'REDHES1(KOFF1) = ',REDHES1(KOFF1) 6823 WRITE(LUPRI,*)'REDHES2(KOFF1) = ',REDHES2(KOFF1) 6824 WRITE(LUPRI,*)'REDHES1(KOFF2) = ',REDHES1(KOFF2) 6825 WRITE(LUPRI,*)'REDHES2(KOFF2) = ',REDHES2(KOFF2) 6826 ENDIF 6827! 6828 ENDDO 6829! 6830 ENDDO 6831! 6832! DO I=1,NREDH 6833! 6834! DO J=1,NCOMPO 6835! 6836! DO K=1, NREDH 6837! 6838! DO L=1, NCOMPO 6839! 6840! KOFF1 = (I-1)*NCOMPO + J 6841! KOFF2 = (K-1)*NCOMPO + L 6842! DIFF1 = REDHES1(KOFF1) - REDHES1(KOFF2) 6843! DIFF2 = REDHES2(KOFF1) - REDHES2(KOFF2) 6844! 6845! IF ((DIFF1 .LT. COMTHRES) .AND. 6846! * (DIFF2 .GT. COMTHRES)) THEN 6847! WRITE(LUPRI,*)'COMPARISON ERROR FOR ELEMENTS NO. (', 6848! * I,',',J,') and NO. (',K,',',L,') ' 6849! WRITE(LUPRI,*)'Difference for Array1 = ',DIFF1 6850! WRITE(LUPRI,*)'Difference for Array2 = ',DIFF2 6851! ENDIF 6852! IF ((DIFF1 .GT. COMTHRES) .AND. 6853! * (DIFF2 .LT. COMTHRES)) THEN 6854! WRITE(LUPRI,*)'COMPARISON ERROR FOR ELEMENTS NO. (', 6855! * I,',',J,') and NO. (',K,',',L,') ' 6856! WRITE(LUPRI,*)'Difference for Array1 = ',DIFF1 6857! WRITE(LUPRI,*)'Difference for Array2 = ',DIFF2 6858! ENDIF 6859! 6860! ENDDO 6861! 6862! ENDDO 6863! 6864! ENDDO 6865! 6866! ENDDO 6867! 6868 CALL QEXIT('HESCOMPA') 6869! 6870 RETURN 6871 END 6872