1! 2! Dalton, a molecular electronic structure program 3! Copyright (C) by the authors of Dalton. 4! 5! This program is free software; you can redistribute it and/or 6! modify it under the terms of the GNU Lesser General Public 7! License version 2.1 as published by the Free Software Foundation. 8! 9! This program is distributed in the hope that it will be useful, 10! but WITHOUT ANY WARRANTY; without even the implied warranty of 11! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12! Lesser General Public License for more details. 13! 14! If a copy of the GNU LGPL v2.1 was not distributed with this 15! code, you can obtain one at https://www.gnu.org/licenses/old-licenses/lgpl-2.1.en.html. 16! 17! 18C 19c*DECK CC_LR 20 SUBROUTINE CC_LR(WORK,LWORK) 21C 22C---------------------------------------------------------------------- 23C 24C Purpose: Direct calculation of Coupled Cluster 25C polarizabilities. 26C (without orbital relaxation) 27C 28C CIS, CCS, CC2, CCSD 29C 30C Written by Ove Christiansen februar 1996. 31C Modified version for general linear response properties 32C Ove Christiansen November 1996. 33C New loop structure for general prop. Ove Christiansen April 1997. 34C SCF model added. Christof Haettig November 1998. 35C 1/2 C^{+/-w} symmetrization introduced. Ch. Haettig, March 1999. 36C 37C---------------------------------------------------------------------- 38C 39 USE PELIB_INTERFACE, ONLY: USE_PELIB 40#include "implicit.h" 41#include "priunit.h" 42#include "dummy.h" 43 LOGICAL LOCDBG 44 PARAMETER (LOCDBG = .FALSE.) 45 PARAMETER (TOLFRQ=1.0D-08,ONE=1.0D0,XMONE=-1.0D0,THR=1.0D-08) 46 INTEGER LUFCK 47 PARAMETER (HALF = 0.5D0, ZERO = 0.0D0) 48 INTEGER ISYM0 49 PARAMETER (ISYM0 = 1) 50C 51#include "iratdef.h" 52#include "inftap.h" 53#include "mxcent.h" 54#include "maxaqn.h" 55#include "maxorb.h" 56#include "cclr.h" 57#include "ccorb.h" 58#include "ccsdsym.h" 59#include "ccsdio.h" 60#include "ccsdinp.h" 61#include "ccsections.h" 62#include "cclrinf.h" 63#include "ccroper.h" 64#include "ccr1rsp.h" 65#include "ccrspprp.h" 66#include "ccexpfck.h" 67#include "ccfro.h" 68#include "leinf.h" 69#include "symmet.h" 70#include "codata.h" 71#include "qm3.h" 72C 73 LOGICAL FTSAV,LRLXA,LRLXB,LPDBSA,LPDBSB,LPRTSCF,OPTST,NOKAPPA 74 LOGICAL SHIELD 75 DIMENSION WORK(LWORK) 76 CHARACTER MODEL*10,MODELP*10 77 CHARACTER LABELA*8, LABELB*8, LABSOP*8 78 SAVE LPRTSCF 79 DATA LPRTSCF /.TRUE./ 80 PARAMETER ( TWO = 2.0D0 ) 81C 82C 83C 84C------------------------------------ 85C Header of Property calculation. 86C------------------------------------ 87C 88 CALL QENTER('CC_LR') 89 WRITE (LUPRI,'(1X,A,/)') ' ' 90 WRITE (LUPRI,'(1X,A)') 91 *'*********************************************************'// 92 *'**********' 93 WRITE (LUPRI,'(1X,A)') 94 *'* '// 95 *' *' 96 WRITE (LUPRI,'(1X,A)') 97 *'*---------- OUTPUT FROM COUPLED CLUSTER LINEAR RESPONSE >'// 98 *'---------*' 99 IF ( DIPPOL ) THEN 100 WRITE (LUPRI,'(1X,A)') 101 * '* '// 102 * ' *' 103 WRITE (LUPRI,'(1X,A)') 104 * '*---------- CALCULATION OF CC POLARIZABILITIES >'// 105 * '---------*' 106 ENDIF 107 WRITE (LUPRI,'(1X,A)') 108 *'* '// 109 *' *' 110 WRITE (LUPRI,'(1X,A,/)') 111 *'*********************************************************'// 112 *'**********' 113C 114 MODEL = 'CCSD ' 115 IF (CC2) THEN 116 MODEL = 'CC2 ' 117 ENDIF 118 IF (CCS) THEN 119 MODEL = 'CCS ' 120 ENDIF 121 IF (CC3 ) THEN 122 MODEL = 'CC3 ' 123 WRITE(LUPRI,'(/,1x,A)') 'CC3 Polari not implemented yet' 124 CALL QEXIT('CC_LR') 125 RETURN 126 ENDIF 127 IF (CC1A) THEN 128 MODEL = 'CCSDT-1a ' 129 WRITE(LUPRI,'(/,1x,A)') 'CC1A Polari not implemented yet' 130 CALL QEXIT('CC_LR') 131 RETURN 132 ENDIF 133 IF (CC1B) THEN 134 MODEL = 'CCSDT-1b ' 135 WRITE(LUPRI,'(/,1x,A)') 'CC1B Polari not implemented yet' 136 CALL QEXIT('CC_LR') 137 RETURN 138 ENDIF 139 IF (CCSD) THEN 140 MODEL = 'CCSD ' 141 ENDIF 142C 143 IF (CIS) THEN 144 MODELP = 'CIS ' 145 ELSE 146 MODELP = MODEL 147 ENDIF 148C 149 CALL AROUND( 'Calculation of '//MODELP// 150 * ' linear response properties ') 151C 152 IF (IPRINT.GT.10) WRITE(LUPRI,*) 'CC_LR Workspace:',LWORK 153C 154 CALL FLSHFO(LUPRI) 155C 156 NLRPRP = NLROP*NBLRFR 157C 158C -------------------------------------------------------------- 159C open AOPROPER file for GETGPV routine of the RSP program... 160C -------------------------------------------------------------- 161C 162 CALL CC_SIRINF(NCMOT,NASHT,N2ASHX,LCINDX) 163C 164 IF (LUPROP .LE. 0) CALL GPOPEN(LUPROP,'AOPROPER','UNKNOWN',' ', 165 & 'UNFORMATTED',IDUMMY,.FALSE.) 166C 167C ------------------------------- 168C allocate workspace for results: 169C ------------------------------- 170C 171 KCMO = 1 172 KUDV = KCMO + NCMOT 173 KXINDX = KUDV + N2ASHX 174 KR2EFF = KXINDX + LCINDX 175 KFOCK0 = KR2EFF + N2BST(1) 176 KOVERLP = KFOCK0 + N2BST(1) 177 KEND1 = KOVERLP + N2BST(1) 178 179 KPOL = KEND1 180 KPOLF = KPOL + 2*NLRPRP 181 KPOLSCF = KPOLF + 2*NLRPRP 182 KEND1 = KPOLSCF + 2*NLRPRP 183 184 LEND1 = LWORK - KEND1 185 186 IF (LEND1 .LT. 0) THEN 187 CALL QUIT('Insufficient memory in CC_LR.') 188 END IF 189 190 CALL DZERO(WORK(KPOL),2*NLRPRP) 191 CALL DZERO(WORK(KPOLF),2*NLRPRP) 192 CALL DZERO(WORK(KPOLSCF),2*NLRPRP) 193C 194C ------------------------------ 195C read MO coefficient from file: 196C ------------------------------ 197C 198 CALL GPOPEN(LUSIFC,'SIRIFC','OLD',' ','UNFORMATTED',IDUMMY, 199 & .FALSE.) 200 REWIND LUSIFC 201 CALL MOLLAB('SIR IPH ',LUSIFC,LUPRI) 202 READ (LUSIFC) 203 READ (LUSIFC) 204 CALL READI(LUSIFC,IRAT*NCMOT,WORK(KCMO)) 205 CALL GPCLOSE(LUSIFC,'KEEP') 206C 207C ------------------------------------ 208C loop over operators and frequencies: 209C ------------------------------------ 210C 211 NSCF = 0 212C 213 DO 1000 IOPER = 1, NLROP 214 IOPERA = IALROP(IOPER) 215 IOPERB = IBLROP(IOPER) 216 LRLXA = LALORX(IOPER) 217 LRLXB = LBLORX(IOPER) 218 ISAMA = ISYMAT(IOPERA) 219 ISAMB = ISYMAT(IOPERB) 220 ISYMA = ISYOPR(IOPERA) 221 ISYMB = ISYOPR(IOPERB) 222 LABELA = LBLOPR(IOPERA) 223 LABELB = LBLOPR(IOPERB) 224 LPDBSA = LPDBSOP(IOPERA) 225 LPDBSB = LPDBSOP(IOPERB) 226 227 ISAPROP = ISAMA * ISAMB 228 229 IF (ISYMA.EQ.ISYMB) THEN 230 DO IFREQ = 1, NBLRFR 231 DO ISIGN = +1, -1, -2 232C 233 IOFSGN = ((-ISIGN+1)/2) * NLRPRP 234C 235 SIGN = DBLE(ISIGN) 236 FREQA = SIGN * ALRFR(IFREQ) 237 FREQB = SIGN * BLRFR(IFREQ) 238C 239 IF (IPRINT .GT. 5 .OR. LOCDBG) THEN 240 WRITE(LUPRI,'(/,1x,A,F16.8,/,A,I2,/,3A,/,A,2L3,/,A,2L3)') 241 * 'Calculating response property with frequency',FREQB, 242 * ' Operator symmetry = ',ISYMB, 243 * ' Labels = ',LABELA, LABELB, 244 * ' orbital relaxation flags = ',LRLXA, LRLXB, 245 * ' pert.-dep. basis set flags = ',LPDBSA, LPDBSB 246 ENDIF 247C 248 KPRP1 = KPOL + IOFSGN + NBLRFR*(IOPER-1) + IFREQ - 1 249 KPRP2 = KPOLF + IOFSGN + NBLRFR*(IOPER-1) + IFREQ - 1 250C 251C------------------------------------------- 252C The etaA*tB(omeg) contributions. 253C------------------------------------------- 254C 255 CALL CC_EATB(LABELA,ISYMA,FREQA,LRLXA,LPDBSA, 256 * LABELB,ISYMB,FREQB,LRLXB,LPDBSB, 257 * WORK(KPRP1),WORK(KEND1),LEND1) 258C 259 IF ( .NOT. ASYMSD) THEN 260C 261C------------------------------------------------------- 262C IF ordinatry form the calculate EATB form. 263C------------------------------------------------------- 264C 265 CALL CC_EATB(LABELB,ISYMB,FREQB,LRLXB,LPDBSB, 266 * LABELA,ISYMA,FREQA,LRLXA,LPDBSA, 267 * WORK(KPRP1),WORK(KEND1),LEND1) 268C 269C-------------------------------------------------- 270C The FtA(-omeg)*tB(omeg) contribution. 271C-------------------------------------------------- 272C 273 IF (.NOT.CIS) THEN 274 CALL CC_FABCON(LABELA,ISYMA,FREQA,LRLXA, 275 * LABELB,ISYMB,FREQB,LRLXB, 276 * WORK(KPRP2),WORK(KEND1),LEND1) 277 ENDIF 278C 279C--------------------------------------------------- 280C The Pt-barA(-omeg)*t-barB(omeg) 281C contribution for solvent calculations. 282C--------------------------------------------------- 283C 284 IF (CCSLV.OR.USE_PELIB()) THEN 285 CALL CC_PABCON(LABELA,ISYMA,FREQA,LRLXA, 286 * LABELB,ISYMB,FREQB,LRLXB, 287 * WORK(KPRP2),WORK(KEND1),LEND1) 288 ENDIF 289C 290 ELSE 291C 292C------------------------------------------------------------------- 293C Use asymmetric form for calculating polarizability. 294C Calculate trivial LAKSIB contribution to polarizability. 295C------------------------------------------------------------------- 296C 297 CALL CC_LAKSIB(LABELA,ISYMA,FREQA,LRLXA, 298 * LABELB,ISYMB,FREQB,LRLXB, 299 * WORK(KPRP2),WORK(KEND1),LEND1) 300C 301 ENDIF 302 303C------------------------------------------------------------------- 304C construct the zeroth-order eff. CC Fock matrix in MO 305C and initialize the 'eff.' sec. order connection matrix 306C------------------------------------------------------------------- 307 IF ( (LRLXA .OR. LPDBSA) .AND. (LRLXB .OR. LPDBSB) ) THEN 308 IFOCK = IEFFFOCK('HAM0 ',ISYM0,1) 309 IADRF = IADRFCK(1,IFOCK) 310 311 LUFCK = -1 312 CALL WOPEN2(LUFCK,FILFCKEFF,64,0) 313 CALL GETWA2(LUFCK,FILFCKEFF,WORK(KFOCK0), 314 & IADRF,N2BST(ISYM0)) 315 CALL WCLOSE2(LUFCK,FILFCKEFF,'KEEP') 316 317 CALL RDONEL('OVERLAP ',.TRUE.,WORK(KEND1),NBAST) 318 CALL CCSD_SYMSQ(WORK(KEND1),ISYM0,WORK(KOVERLP)) 319 320 CALL CC_EFFCKMO(WORK(KFOCK0),ISYM0,WORK(KCMO), 321 & WORK(KOVERLP),WORK(KEND1),LEND1) 322 323 ELSE 324 CALL DZERO(WORK(KFOCK0),N2BST(1)) 325 END IF 326 327 CALL DZERO(WORK(KR2EFF),N2BST(1)) 328 329C------------------------------------------------------------------- 330C construct the X^(1) interm. for the A perturbation and 331C calculate its contribution to the response function: 332C------------------------------------------------------------------- 333 RLXBCON = ZERO 334 335 IF (LRLXB.OR.LPDBSB) THEN 336 337 KXIMA = KEND1 338 KAPB = KXIMA + N2BST(ISYMA) 339 KQMATH = KAPB + 2*NALLAI(ISYMB) 340 KQMATP = KQMATH + MAX(N2BST(ISYMB),N2BST(ISYMA)) 341 KRMAT = KQMATP + MAX(N2BST(ISYMB),N2BST(ISYMA)) 342 KAPBSQ = KRMAT + MAX(N2BST(ISYMB),N2BST(ISYMA)) 343 KQTRP = KAPBSQ + N2BST(ISYMB) 344 KEND2 = KQTRP + MAX(N2BST(ISYMB),N2BST(ISYMA)) 345 LWRK2 = LWORK - KEND2 346 IF (LWRK2 .LT. 0) THEN 347 CALL QUIT('Insufficient memory in CC_LR.') 348 END IF 349 350 351 CALL CCRLXXIM(WORK(KXIMA),ISYMA,LABELA,LRLXA,LPDBSA, 352 & FREQA,WORK(KCMO),WORK(KEND2),LWRK2) 353 354 IF (LRLXB) THEN 355 IKAPPA = IR1KAPPA(LABELB,FREQB,ISYMB) 356 CALL CC_RDHFRSP('R1 ',IKAPPA,ISYMB,WORK(KAPB)) 357 ELSE 358 CALL DZERO(WORK(KAPB),2*NALLAI(ISYMB)) 359 END IF 360 361 CALL CC_GET_RMAT(WORK(KRMAT),IOPERB,1,ISYMB, 362 & WORK(KEND2),LWRK2) 363 NOKAPPA = .FALSE. 364 CALL CC_QMAT(WORK(KQMATP),WORK(KQMATH), 365 & WORK(KRMAT),WORK(KAPB), 366 & ISAMB,ISYMB,NOKAPPA,WORK(KCMO), 367 & WORK(KEND2),LWRK2) 368 369 DO ISYM1 = 1, NSYM 370 ISYM2 = MULD2H(ISYM1,ISYMB) 371 KOFF1 = KQMATH + IAODIS(ISYM1,ISYM2) 372 KOFF2 = KQTRP + IAODIS(ISYM2,ISYM1) 373 CALL TRSREC(NBAS(ISYM1),NBAS(ISYM2), 374 & WORK(KOFF1),WORK(KOFF2)) 375 END DO 376 CALL DCOPY(N2BST(ISYMB),WORK(KQTRP),1,WORK(KQMATH),1) 377 CALL DSCAL(N2BST(ISYMB),-HALF,WORK(KQMATH),1) 378 379 DO ISYM1 = 1, NSYM 380 ISYM2 = MULD2H(ISYM1,ISYMB) 381 KOFF1 = KQMATP + IAODIS(ISYM1,ISYM2) 382 KOFF2 = KQTRP + IAODIS(ISYM2,ISYM1) 383 CALL TRSREC(NBAS(ISYM1),NBAS(ISYM2), 384 & WORK(KOFF1),WORK(KOFF2)) 385 END DO 386 CALL DCOPY(N2BST(ISYMB),WORK(KQTRP),1,WORK(KQMATP),1) 387 CALL DSCAL(N2BST(ISYMB),-HALF,WORK(KQMATP),1) 388 389 RLXBCON = 390 & - DDOT(N2BST(ISYMA),WORK(KQMATH),1,WORK(KXIMA),1) 391 & - DBLE(ISAMA) * 392 & DDOT(N2BST(ISYMA),WORK(KQMATP),1,WORK(KXIMA),1) 393 394 IF (LOCDBG) THEN 395 WRITE(LUPRI,*) 'XIMA for RLXBCON:' 396 CALL CC_PRONELAO(WORK(KXIMA),ISYMA) 397 WRITE(LUPRI,*) 'transpose QMATH:' 398 CALL CC_PRONELAO(WORK(kqtrp),ISYMB) 399 WRITE(LUPRI,*) 'RLXBCON:',RLXBCON 400 END IF 401 402 WORK(KPRP1) = WORK(KPRP1) + RLXBCON 403 404 CALL CCKAPPASQ(WORK(KAPBSQ),WORK(KAPB),ISYMB,'N') 405 406 CALL CC_GET_RMAT(WORK(KRMAT),IOPERA,1,ISYMA, 407 & WORK(KEND2),LWRK2) 408 409 NOKAPPA = .TRUE. 410 CALL CC_QMAT(WORK(KQMATP),WORK(KQMATH), 411 & WORK(KRMAT),DUMMY, 412 & ISAMA,ISYMA,NOKAPPA,WORK(KCMO), 413 & WORK(KEND2),LWRK2) 414 415 CALL CC_MMOMMO('N','N',+1.0D0,WORK(KAPBSQ),ISYMB, 416 & WORK(KQMATH),ISYMA,1.0D0,WORK(KR2EFF),1) 417 CALL CC_MMOMMO('N','N',-1.0D0,WORK(KQMATH),ISYMA, 418 & WORK(KAPBSQ),ISYMB,1.0D0,WORK(KR2EFF),1) 419 420 IF (LOCDBG .OR. IPRINT.GT.1) THEN 421 WRITE (LUPRI,*) 'CC_LR> RLXBCON = ',RLXBCON 422 WRITE (LUPRI,*) 'CC_LR> PRP1 = ',WORK(KPRP1) 423 END IF 424 IF (LOCDBG) THEN 425 WRITE (LUPRI,*) 'RMAT A: AO' 426 CALL CC_PRONELAO(WORK(KRMAT),ISYMA) 427 WRITE (LUPRI,*) 'RMAT A: MO' 428 CALL CC_PRONELAO(WORK(KQMATH),ISYMA) 429 WRITE (LUPRI,*) 'KAPPA B:' 430 CALL CC_PRONELAO(WORK(KAPBSQ),ISYMB) 431 WRITE (LUPRI,*) 'KR2EFF:' 432 CALL CC_PRONELAO(WORK(KR2EFF),ISYM0) 433 END IF 434 END IF 435 436C------------------------------------------------------------------- 437C construct the X^(1) interm. for the B perturbation and 438C calculate its contribution to the response function: 439C------------------------------------------------------------------- 440 RLXACON = ZERO 441 442 IF (LRLXA .OR. LPDBSA) THEN 443 444 KXIMB = KEND1 445 KAPA = KXIMB + N2BST(ISYMB) 446 KAPASQ = KAPA + 2*NALLAI(ISYMA) 447 KRMAT = KAPASQ + N2BST(ISYMA) 448 KQMATH = KRMAT + MAX(N2BST(ISYMA),N2BST(ISYMB)) 449 KQMATP = KQMATH + MAX(N2BST(ISYMA),N2BST(ISYMB)) 450 KQTRP = KQMATP + MAX(N2BST(ISYMA),N2BST(ISYMB)) 451 KEND2 = KQTRP + MAX(N2BST(ISYMA),N2BST(ISYMB)) 452 LWRK2 = LWORK - KEND2 453 IF (LWRK2 .LT. 0) THEN 454 CALL QUIT('Insufficient memory in CC_LR.') 455 END IF 456 457 458 CALL CCRLXXIM(WORK(KXIMB),ISYMB,LABELB,LRLXB,LPDBSA, 459 & FREQB,WORK(KCMO),WORK(KEND2),LWRK2) 460 461 IF (LRLXA) THEN 462 IKAPPA = IR1KAPPA(LABELA,FREQA,ISYMA) 463 CALL CC_RDHFRSP('R1 ',IKAPPA,ISYMA,WORK(KAPA)) 464 ELSE 465 CALL DZERO(WORK(KAPA),2*NALLAI(ISYMA)) 466 END IF 467 468 CALL CC_GET_RMAT(WORK(KRMAT),IOPERA,1,ISYMA, 469 & WORK(KEND2),LWRK2) 470 471 NOKAPPA = .FALSE. 472 CALL CC_QMAT(WORK(KQMATP),WORK(KQMATH), 473 & WORK(KRMAT),WORK(KAPA), 474 & ISAMA,ISYMA,NOKAPPA,WORK(KCMO), 475 & WORK(KEND2),LWRK2) 476 477 DO ISYM1 = 1, NSYM 478 ISYM2 = MULD2H(ISYM1,ISYMB) 479 KOFF1 = KQMATH + IAODIS(ISYM1,ISYM2) 480 KOFF2 = KQTRP + IAODIS(ISYM2,ISYM1) 481 CALL TRSREC(NBAS(ISYM1),NBAS(ISYM2), 482 & WORK(KOFF1),WORK(KOFF2)) 483 END DO 484 CALL DCOPY(N2BST(ISYMB),WORK(KQTRP),1,WORK(KQMATH),1) 485 CALL DSCAL(N2BST(ISYMB),-HALF,WORK(KQMATH),1) 486 487 DO ISYM1 = 1, NSYM 488 ISYM2 = MULD2H(ISYM1,ISYMB) 489 KOFF1 = KQMATP + IAODIS(ISYM1,ISYM2) 490 KOFF2 = KQTRP + IAODIS(ISYM2,ISYM1) 491 CALL TRSREC(NBAS(ISYM1),NBAS(ISYM2), 492 & WORK(KOFF1),WORK(KOFF2)) 493 END DO 494 CALL DCOPY(N2BST(ISYMB),WORK(KQTRP),1,WORK(KQMATP),1) 495 CALL DSCAL(N2BST(ISYMB),-HALF,WORK(KQMATP),1) 496 497 RLXACON = 498 & - DDOT(N2BST(ISYMB),WORK(KQMATH),1,WORK(KXIMB),1) 499 & - DBLE(ISAMB) * 500 & DDOT(N2BST(ISYMB),WORK(KQMATP),1,WORK(KXIMB),1) 501 502 if (locdbg) then 503 WRITE(LUPRI,*) 'XIMB for RLXACON:' 504 call cc_pronelao(work(kximb),isymb) 505 WRITE(LUPRI,*) 'transpose QMATH:' 506 call cc_pronelao(work(KQTRP),isymb) 507 WRITE(LUPRI,*) 'RLXACON:',RLXACON 508 end if 509 510 WORK(KPRP1) = WORK(KPRP1) + RLXACON 511 512 513 CALL CCKAPPASQ(WORK(KAPASQ),WORK(KAPA),ISYMA,'N') 514 515 CALL CC_GET_RMAT(WORK(KRMAT),IOPERB,1,ISYMB, 516 & WORK(KEND2),LWRK2) 517 518 NOKAPPA = .TRUE. 519 CALL CC_QMAT(WORK(KQMATP),WORK(KQMATH), 520 & WORK(KRMAT),DUMMY, 521 & ISAMB,ISYMB,NOKAPPA,WORK(KCMO), 522 & WORK(KEND2),LWRK2) 523 524 525 CALL CC_MMOMMO('N','N',+1.0D0,WORK(KAPASQ),ISYMA, 526 & WORK(KQMATH),ISYMB,1.0D0,WORK(KR2EFF),1) 527 CALL CC_MMOMMO('N','N',-1.0D0,WORK(KQMATH),ISYMB, 528 & WORK(KAPASQ),ISYMA,1.0D0,WORK(KR2EFF),1) 529 530 IF (LOCDBG .OR. IPRINT.GT.1) THEN 531 WRITE (LUPRI,*) 'CC_LR> RLXACON = ',RLXACON 532 WRITE (LUPRI,*) 'CC_LR> PRP1 = ',WORK(KPRP1) 533 END IF 534 IF (LOCDBG) THEN 535 WRITE (LUPRI,*) 'RMAT B:' 536 CALL CC_PRONELAO(WORK(KQMATH),ISYMB) 537 WRITE (LUPRI,*) 'KAPPA A:' 538 CALL CC_PRONELAO(WORK(KAPASQ),ISYMA) 539 WRITE (LUPRI,*) 'KR2EFF:' 540 CALL CC_PRONELAO(WORK(KR2EFF),ISYM0) 541 END IF 542 END IF 543 544 IF (LPDBSA .OR. LPDBSB) THEN 545 CALL CC_FIND_SO_OP(LABELA,LABELB,LABSOP,ISYSOP,ISGNSOP, 546 * INUM,WORK(KEND1),LEND1) 547 IF (INUM.LT.0) CALL QUIT('Operator error in CC_LR.') 548 IEXPV = IEXPECT(LABSOP,ISYSOP) 549 XSTAT = DBLE(ISGNSOP) * 550 * ( EXPVALUE(1,IEXPV) + EXPVALUE(2,IEXPV) ) 551 XNUCL = CC_NUCCON(LABSOP,ISYSOP) 552 553 XREO = TWO*DDOT(N2BST(1),WORK(KR2EFF),1,WORK(KFOCK0),1) 554 555 IF (LOCDBG .OR. IPRINT.GT.1) THEN 556 WRITE (LUPRI,*) LABSOP, 557 * EXPVALUE(1,IEXPV),EXPVALUE(2,IEXPV) 558 WRITE (LUPRI,*) 559 * 'CC_LR> contrib. of Fock^(eff,0) :',XREO 560 END IF 561 IF (LOCDBG) THEN 562 WRITE (LUPRI,*) 563 * 'CC_LR> [K^(A),R^(B)]+[K^(B),R^(A)] :' 564 CALL CC_PRONELAO(WORK(KR2EFF),1) 565 WRITE (LUPRI,*) 'CC_LR> Fock^(eff,0) :' 566 CALL CC_PRONELAO(WORK(KFOCK0),1) 567 END IF 568 ELSE 569 XSTAT = ZERO 570 XNUCL = ZERO 571 XREO = ZERO 572 END IF 573 574 WORK(KPRP1) = WORK(KPRP1) + XREO + XSTAT - XNUCL 575 576 IF (LOCDBG .OR. IPRINT.GT.10) THEN 577 WRITE (LUPRI,*) 'CC_LR> RLXACON = ',RLXACON 578 WRITE (LUPRI,*) 'CC_LR> RLXBCON = ',RLXBCON 579 WRITE (LUPRI,*) 'CC_LR> XSTAT(CC) = ',XSTAT 580 WRITE (LUPRI,*) 'CC_LR> XNUCL = ',XNUCL 581 WRITE (LUPRI,*) 'CC_LR> XREO = ',XREO 582 WRITE (LUPRI,*) 'CC_LR> PRP1 = ',WORK(KPRP1) 583 WRITE (LUPRI,*) 'CC_LR> PRP2 = ',WORK(KPRP2) 584 END IF 585C 586C-------------------------------------------------------------- 587C in relaxed case calculate SCF result if possible: 588C-------------------------------------------------------------- 589C 590 IF (LRLXA.AND.LRLXB) THEN 591 592 IF (LEND1 .LT. 4*NALLAI(ISYMA)) THEN 593 CALL QUIT('Insufficient memory in CC_LR.') 594 END IF 595 596 KG1 = KEND1 597 LWRKG1 = LWORK - KG1 598 599 KG2 = KG1 + NALLAI(ISYMA) 600 KAPPA1 = KG2 + NALLAI(ISYMA) 601 KAPPA2 = KAPPA1 + NALLAI(ISYMA) 602 603 NSCF = NSCF + 1 604 KPRP = KPOLSCF + IOFSGN + NBLRFR*(IOPER-1) + IFREQ - 1 605 606 IDXR = IR1KAPPA(LABELA,+FREQA,ISYMA) 607 CALL CC_GETHFGD(IDXR,'R1 ',LRTHFLBL,IDUM,IDUM,RDUM, 608 * ISYLRTHF,FRQLRTHF,IDUM,NLRTHFLBL, 609 * MAXTLBL,IREAL,WORK(KCMO),WORK(KUDV), 610 * WORK(KXINDX),FRVAL,WORK(KG1),LWRKG1) 611 612 IDXR = IR1KAPPA(LABELB,+FREQB,ISYMB) 613 CALL CC_RDHFRSP('R1 ',IDXR,ISYMB,WORK(KAPPA1)) 614 615 XRLXAB=DDOT(2*NALLAI(ISYMB),WORK(KAPPA1),1,WORK(KG1),1) 616 617 618 IDXR = IR1KAPPA(LABELB,+FREQB,ISYMB) 619 CALL CC_GETHFGD(IDXR,'R1 ',LRTHFLBL,IDUM,IDUM,RDUM, 620 * ISYLRTHF,FRQLRTHF,IDUM,NLRTHFLBL, 621 * MAXTLBL,IREAL,WORK(KCMO),WORK(KUDV), 622 * WORK(KXINDX),FRVAL,WORK(KG1),LWRKG1) 623 624 IDXR = IR1KAPPA(LABELA,+FREQA,ISYMA) 625 CALL CC_RDHFRSP('R1 ',IDXR,ISYMA,WORK(KAPPA1)) 626 627 XRLXBA=DDOT(2*NALLAI(ISYMA),WORK(KAPPA1),1,WORK(KG1),1) 628 629 WORK(KPRP) = XRLXAB 630 631 ERROR = XRLXBA - DBLE(ISAPROP) * XRLXAB 632 633 IF (LOCDBG.OR.DABS(ERROR).GT.THRLEQ.OR.IPRINT.GT.1) THEN 634 WRITE (LUPRI,*)'CC_LR>', LABELA,FREQA,LABELB,FREQB 635 WRITE (LUPRI,*)'CC_LR> ',XRLXAB,XRLXBA,ERROR,THRLEQ 636 IF (ERROR.GT.THRLEQ) THEN 637 WRITE (LUPRI,*) 638 * 'Warning: large errors in SCF second-', 639 * 'order property encountered!!!' 640 END IF 641 END IF 642 643 KFOCK1 = KEND1 644 KR1DEN = KFOCK1 + N2BST(ISYMA) 645 KEND2 = KR1DEN + N2BST(ISYMB) 646 LWRK2 = LWORK - KEND2 647 648 LUFCK = -1 649 IFOCK = IEFFFOCK(LABELA,ISYM,1) 650 IADRF = IADRFCK(2,IFOCK) 651 CALL WOPEN2(LUFCK,FILFCKEFF,64,0) 652 CALL GETWA2(LUFCK,FILFCKEFF,WORK(KFOCK1), 653 & IADRF,N2BST(ISYMA)) 654 CALL WCLOSE2(LUFCK,FILFCKEFF,'KEEP') 655 656 CALL CC_HFR1DEN(WORK(KR1DEN),IOPERB,1,ISYMB, 657 & WORK(KEND2),LWRK2) 658 659 XREOB = -TWO * DDOT(N2BST(ISYMA),WORK(KFOCK1),1, 660 & WORK(KR1DEN),1) 661 IF (LOCDBG .OR. IPRINT.GT.1) THEN 662 WRITE (LUPRI,*) 'CC_LR> XREOB = ',XREOB 663 END IF 664 665 KFOCK1 = KEND1 666 KR1DEN = KFOCK1 + N2BST(ISYMB) 667 KEND2 = KR1DEN + N2BST(ISYMA) 668 LWRK2 = LWORK - KEND2 669 670 LUFCK = -1 671 IFOCK = IEFFFOCK(LABELB,ISYM,1) 672 IADRF = IADRFCK(2,IFOCK) 673 CALL WOPEN2(LUFCK,FILFCKEFF,64,0) 674 CALL GETWA2(LUFCK,FILFCKEFF,WORK(KFOCK1), 675 & IADRF,N2BST(ISYMB)) 676 CALL WCLOSE2(LUFCK,FILFCKEFF,'KEEP') 677 678 CALL CC_HFR1DEN(WORK(KR1DEN),IOPERA,1,ISYMA, 679 & WORK(KEND2),LWRK2) 680 681 XREOA = - TWO * DDOT(N2BST(ISYMA),WORK(KFOCK1),1, 682 & WORK(KR1DEN),1) 683 IF (LOCDBG .OR. IPRINT.GT.1) THEN 684 WRITE (LUPRI,*) 'CC_LR> XREOA = ',XREOA 685 END IF 686 687 IF (LPDBSA .OR. LPDBSB) THEN 688 CALL CC_FIND_SO_OP(LABELA,LABELB,LABSOP,ISYSOP, 689 * ISGNSOP,INUM,WORK(KEND1),LEND1) 690 IF (INUM.LT.0) CALL QUIT('Operator error in CC_LR.') 691 IEXPV = IEXPECT(LABSOP,ISYSOP) 692 XSTAT = EXPVALUE(3,IEXPV) + EXPVALUE(4,IEXPV) 693 XNUCL = CC_NUCCON(LABSOP,ISYSOP) 694 ELSE 695 XSTAT = ZERO 696 XNUCL = ZERO 697 END IF 698 699 WORK(KPRP) = WORK(KPRP) + XREOA+XREOB+XNUCL+XSTAT 700 701 IF (LOCDBG .OR. IPRINT.GT.1) THEN 702 WRITE (LUPRI,*) 'SCF <<',LABELA,';',LABELB,'>> : ' 703 WRITE (LUPRI,*) 'relaxation contribution:',XRLXAB 704 WRITE (LUPRI,*) 'reorthog. contribution:',XREOA+XREOB 705 WRITE (LUPRI,*) 'static electronic cont.:',XSTAT 706 WRITE (LUPRI,*) 'nuclear contribution:',XNUCL 707 WRITE (LUPRI,*) 'total result :',WORK(KPRP) 708 END IF 709 710 END IF 711C 712 END DO 713 END DO 714C 715 ENDIF 716 1000 CONTINUE 717C 718 IF (LUPROP .GT. 0) CALL GPCLOSE(LUPROP,'KEEP') 719C 720C------------------------------------ 721C Output SCF response properties: 722C------------------------------------ 723C 724 IF ( NSCF.GT.1 .AND. (LPRTSCF.OR.LOCDBG) ) THEN 725C 726 WRITE(LUPRI,'(//,1X,A)') 727 * 'SCF linear response properties in atomic units:' 728 WRITE(LUPRI,'(1X,A,/)') 729 * '-----------------------------------------------' 730C 731 DO IOPER = 1,NLROP 732 IOPERA = IALROP(IOPER) 733 IOPERB = IBLROP(IOPER) 734 LRLXA = LALORX(IOPER) 735 LRLXB = LBLORX(IOPER) 736 ISYMA = ISYOPR(IOPERA) 737 ISYMB = ISYOPR(IOPERB) 738 LABELA = LBLOPR(IOPERA) 739 LABELB = LBLOPR(IOPERB) 740 LPDBSA = LPDBSOP(IOPERA) 741 LPDBSB = LPDBSOP(IOPERB) 742 IF(LRLXA.AND.LRLXB)THEN 743 DO IFREQ = 1, NBLRFR 744 KPRP1 = KPOLSCF + NBLRFR*(IOPER-1) + IFREQ - 1 745 IF (ISYMA.EQ.ISYMB) THEN 746 WRITE(LUPRI,'(1X,A2,A8,A1,A8,A3,F9.6,A,F15.8)') '<<', 747 * LABELA,',',LABELB,'>>(',BLRFR(IFREQ),') =',WORK(KPRP1) 748 ELSE 749 WRITE(LUPRI,'(1X,A2,A8,A1,A8,A3,F9.6,A,F15.8,A)') '<<', 750 * LABELA,',',LABELB,'>>(',BLRFR(IFREQ),') =',WORK(KPRP1), 751 * ' BY SYMMETRY !' 752 ENDIF 753 END DO 754 END IF 755 END DO 756C 757 LPRTSCF = .FALSE. 758C 759 END IF 760C 761C------------------------------------------------- 762C Output Linear response properties. 763C IF DIPPOL put into polarizability tensor. 764C------------------------------------------------- 765C 766 KPOL2 = KEND1 767 KEND2 = KPOL2 + NBLRFR*3*3 768 LEND2 = LWORK - KEND2 769C 770 CALL DZERO(WORK(KPOL2),3*3*NBLRFR) 771C 772 CALL DAXPY(2*NLRPRP,ONE,WORK(KPOLF),1,WORK(KPOL),1) 773C 774 WRITE(LUPRI,'(//,1X,A6,A)') MODELP(1:6), 775 * 'linear response properties in atomic units:' 776 WRITE(LUPRI,'(1X,A,/)') 777 * '-------------------------------------------------' 778C 779 DO 4000 IOPER = 1,NLROP 780 IOPERA = IALROP(IOPER) 781 IOPERB = IBLROP(IOPER) 782 ISYMA = ISYOPR(IOPERA) 783 ISYMB = ISYOPR(IOPERB) 784 ISYMAB = MULD2H(ISYMA,ISYMB) 785 LABELA = LBLOPR(IOPERA) 786 LABELB = LBLOPR(IOPERB) 787 ISAMA = ISYMAT(IOPERA) 788 ISAMB = ISYMAT(IOPERB) 789 790 ISAPROP = ISAMA * ISAMB 791 SIGN = DBLE(ISAPROP) 792 793 IF ((LABELA(1:5).EQ.'dh/dB'.AND.LABELB(1:4).EQ.'PSO ').OR. 794 * (LABELB(1:5).EQ.'dh/dB'.AND.LABELA(1:4).EQ.'PSO ') )THEN 795 SHIELD = .TRUE. 796 FACTOR = 1.0D06 * ALPHA2 ! conversion to ppm 797 ELSE 798 SHIELD = .FALSE. 799 FACTOR = 1.0D0 800 END IF 801 802 DO IFREQ = 1, NBLRFR 803 KPRP1P = KPOL + NBLRFR*(IOPER-1) + IFREQ - 1 804 KPRP1M = KPOL + NLRPRP + NBLRFR*(IOPER-1) + IFREQ - 1 805 806 RESULT = HALF*( WORK(KPRP1P) + SIGN * WORK(KPRP1M) ) 807 ERROR = HALF*( WORK(KPRP1P) - SIGN * WORK(KPRP1M) ) 808 809 IF (IPRINT.GT.11 .OR. ISAPROP.EQ.0) THEN 810 811 IF (ISAPROP .EQ. 0) THEN 812 WRITE(LUPRI,'(/1X,A,/1X,A)') 813 * 'Cannot determine if real or imaginary property...', 814 * 'the non-symmetrized results for +/- w are:' 815 ELSE 816 WRITE(LUPRI,'(/1X,A)') 'non-symmetrized '// 817 & 'results for +/-w:' 818 ENDIF 819 820 WRITE(LUPRI,'(1X,A2,A8,A1,A8,A3,F9.6,A,F15.8)') 821 * '<<',LABELA,',',LABELB, 822 * '>>(',BLRFR(IFREQ),') =',WORK(KPRP1P) 823 WRITE(LUPRI,'(1X,A2,A8,A1,A8,A3,F9.6,A,F15.8)') 824 * '<<',LABELA,',',LABELB, 825 * '>>(',-BLRFR(IFREQ),') =',WORK(KPRP1M) 826 827 WRITE(LUPRI,'(1X,A)') 828 & 'symmetric/antisymmetric contributions:' 829 WRITE(LUPRI,'(1X,A2,A8,A1,A8,A3,F9.6,A,F15.8,A,F15.8)') 830 * '<<',LABELA,',',LABELB, '>>(',-BLRFR(IFREQ),') =', 831 * HALF*(WORK(KPRP1P)+WORK(KPRP1M)),' / ', 832 * HALF*(WORK(KPRP1P)-WORK(KPRP1M)) 833 834 IF (ISAPROP .EQ. +1) THEN 835 WRITE(LUPRI,'(1X,2A,/1X,2A)') 836 * 'the symmetric contribution corresponds to ', 837 * 'the (real) physical result,', 838 * 'the antisymmetric contribution is an artifact of ', 839 * 'the non-symmetric CC parametrization.' 840 ELSE IF (ISAPROP .EQ. -1) THEN 841 WRITE(LUPRI,'(1X,2A,/1X,2A)') 842 * 'the antisymmetric contribution corresponds to ', 843 * 'the imaginary part of the physical result,', 844 * 'the symmetric contribution is an artifact of ', 845 * 'the non-symmetric CC parametrization.' 846 ENDIF 847 848 ELSE 849 850 IF (SHIELD) THEN 851 WRITE(LUPRI,'(1X,A2,A8,A1,A8,A3,F9.6,A,F15.8,2X,F15.8)') 852 * '<<',LABELA,',',LABELB, 853 * '>>(',BLRFR(IFREQ),') =',RESULT,FACTOR*RESULT 854 ELSE 855 IF (ISYMA.EQ.ISYMB) THEN 856 WRITE(LUPRI,'(1X,A2,A8,A1,A8,A3,F9.6,A,F15.8)') 857 * '<<',LABELA,',',LABELB, 858 * '>>(',BLRFR(IFREQ),') =',RESULT 859 ELSE 860 WRITE(LUPRI,'(1X,A2,A8,A1,A8,A3,F9.6,A,F15.8,A)') 861 * '<<',LABELA,',',LABELB, 862 * '>>(',BLRFR(IFREQ),') =',RESULT,' BY SYMMETRY !' 863 ENDIF 864 END IF 865 866 ENDIF 867 CALL WRIPRO(RESULT,MODELP,2, 868 * LABELA,LABELB,LABELA,LABELB, 869 * BLRFR(IFREQ),BLRFR(IFREQ),BLRFR(IFREQ),ISYMAB, 870 * 0,0,0) 871 END DO 872 873 IF (DIPPOL.AND.(LABELA(2:7).EQ.'DIPLEN') 874 * .AND.(LABELB(2:7).EQ.'DIPLEN')) THEN 875 DO 6000 IFREQ = 1, NBLRFR 876 KPRP1P = KPOL + NBLRFR*(IOPER-1) + IFREQ - 1 877 KPRP1M = KPOL + NLRPRP + NBLRFR*(IOPER-1) + IFREQ - 1 878 879 RESULT = HALF*( WORK(KPRP1P) + SIGN * WORK(KPRP1M) ) 880 ERROR = HALF*( WORK(KPRP1P) - SIGN * WORK(KPRP1M) ) 881 882 KPOLOF = KPOL2 + 3*3*(IFREQ-1) - 1 883 884 IF (LABELA(1:2).EQ.'XD') IADR1 = 1 885 IF (LABELA(1:2).EQ.'YD') IADR1 = 2 886 IF (LABELA(1:2).EQ.'ZD') IADR1 = 3 887 IF (LABELB(1:2).EQ.'XD') IADR2 = 1 888 IF (LABELB(1:2).EQ.'YD') IADR2 = 2 889 IF (LABELB(1:2).EQ.'ZD') IADR2 = 3 890 IPOL = KPOLOF + 3*(IADR2-1) + IADR1 891 WORK(IPOL) = RESULT 892 6000 CONTINUE 893 ENDIF 894 4000 CONTINUE 895C 896C--------------------------------- 897C Perform analysis for DIPPOL. 898C--------------------------------- 899C 900 IF (DIPPOL) THEN 901 DO 9000 IFREQ = 1, NBLRFR 902 KPOLI = KPOL2 + 3*3*(IFREQ-1) 903 CALL DSCAL(9,XMONE,WORK(KPOLI),1) 904 CALL CC_POLPRI(WORK(KPOLI),BLRFR(IFREQ)) 905 9000 CONTINUE 906 ENDIF 907C 908C------------- 909 CALL QEXIT('CC_LR') 910 RETURN 911 END 912c*DECK CC_EATB 913 SUBROUTINE CC_EATB(LABELA,ISYMA,FREQA,LRLXA,LPDBSA, 914 * LABELB,ISYMB,FREQB,LRLXB,LPDBSB, 915 * PRP,WORK,LWORK) 916C 917C---------------------------------------------------------------------- 918C 919C Purpose: Calculate etaA*tB contribution to second order properties. 920C 921C 922C Written by Ove Christiansen 21-6-1996 923C New version november 1996. 924C 925C---------------------------------------------------------------------- 926C 927#include "implicit.h" 928#include "priunit.h" 929#include "maxorb.h" 930#include "ccorb.h" 931#include "iratdef.h" 932#include "cclr.h" 933#include "ccsdsym.h" 934#include "ccsdio.h" 935#include "ccsdinp.h" 936#include "dummy.h" 937C 938 PARAMETER( TWO = 2.0D00,TOLFRQ=1.0D-08 ) 939 DIMENSION WORK(LWORK) 940 CHARACTER LABELA*8,LABELB*8,MODEL*10 941 LOGICAL LRLXA, LRLXB, LPDBSA, LPDBSB 942C 943 IF ( IPRINT .GT. 10 ) THEN 944 CALL AROUND( 'IN CC_EATB: Calculating polarizabilty ') 945 ENDIF 946C 947C------------------------ 948C Allocate workspace. 949C------------------------ 950C 951 IF (ISYMA .NE. ISYMB ) CALL QUIT('Symmetry mismatch in CC_EATB') 952 NTAMPB = NT1AM(ISYMB) + NT2AM(ISYMB) 953 IF ( CCS ) NTAMPB = NT1AM(ISYMB) 954 NTAMPA = NT1AM(ISYMA) + NT2AM(ISYMA) 955 IF ( CCS ) NTAMPA = NT1AM(ISYMA) 956C 957 KETA = 1 958 KEND1 = KETA + NTAMPA 959 LEND1 = LWORK - KEND1 960 961 KETA1 = KETA 962 KETA2 = KETA1 + NT1AM(ISYMA) 963C 964 KR1 = KEND1 965 KEND2 = KR1 + NTAMPB 966 LEND2 = LWORK - KEND2 967C 968 IF (LEND2 .LT. 0) 969 * CALL QUIT('Insufficient space for allocation in CC_EATB') 970C 971C---------------------------------------------- 972C Calculate contribution to polarizability. 973C---------------------------------------------- 974C 975 IF (LRLXA .OR. LPDBSA) THEN 976 ILSTETA = IETA1(LABELA,LRLXA,FREQA,ISYMA) 977 IOPT = 3 978 CALL CC_RDRSP('X1 ',ILSTETA,ISYMA,IOPT,MODEL, 979 * WORK(KETA1),WORK(KETA2)) 980 IF (DEBUG) THEN 981 WRITE (LUPRI,*) 'IETA1:',ILSTETA 982 WRITE (LUPRI,*) 'norm(eta1):', 983 * DDOT(NT1AM(ISYMA),WORK(KETA1),1,WORK(KETA1),1) 984 WRITE (LUPRI,*) 'norm(eta2):', 985 * DDOT(NT2AM(ISYMA),WORK(KETA2),1,WORK(KETA2),1) 986 END IF 987 ELSE 988 CALL CC_ETAC(ISYMA,LABELA,WORK(KETA),'L0',1,0, 989 * DUMMY,WORK(KEND1),LEND1) 990 END IF 991C 992 KR11 = KR1 993 KR12 = KR1 + NT1AM(ISYMB) 994 ILSTNR = IR1TAMP(LABELB,LRLXB,FREQB,ISYMB) 995 IOPT = 3 996 CALL CC_RDRSP('R1 ',ILSTNR,ISYMB,IOPT,MODEL,WORK(KR11), 997 * WORK(KR12)) 998 IF (IPRINT .GT. 40 ) THEN 999 CALL AROUND( 'In CC_EATB: RSP vector ' ) 1000 CALL CC_PRP(WORK(KR1),WORK(KR1+NT1AM(ISYMB)),ISYMB,1,1) 1001 ENDIF 1002 EATBCN = DDOT(NTAMPA,WORK(KETA),1,WORK(KR1),1) 1003C 1004 IF ( IPRINT .GT. 9 ) THEN 1005 WRITE(LUPRI,*) ' Singles contribution:', 1006 * DDOT(NT1AM(ISYMA),WORK(KETA),1,WORK(KR1),1) 1007 IF (.NOT. CCS) WRITE(LUPRI,*) ' Doubles contribution:', 1008 * DDOT(NT2AM(ISYMA),WORK(KETA+NT1AM(ISYMA)),1, 1009 * WORK(KR1+NT1AM(ISYMA)),1) 1010 ENDIF 1011C 1012C------------------------------------ 1013C Add to response function array. 1014C------------------------------------ 1015C 1016 IF (IPRINT .GT. 2 ) THEN 1017 WRITE(LUPRI,'(1X,A2,A8,A1,A8,A3,F10.6,A,F14.10)') 1018 * '<<',LABELA,',',LABELB,'>>(', 1019 * FREQB,') EtaA*tB cont. = ',EATBCN 1020 ENDIF 1021 PRP = EATBCN + PRP 1022C 1023 RETURN 1024 END 1025c*DECK CC_FABCON 1026 SUBROUTINE CC_FABCON(LABELA,ISYMA,FREQA,LRLXA, 1027 * LABELB,ISYMB,FREQB,LRLXB, 1028 * PRP,WORK,LWORK) 1029C 1030C---------------------------------------------------------------------- 1031C 1032C Purpose: Calculate F*TA(-omeg)*TB(omeg) 1033C 1034C Written by Ove Christiansen 21-6-1996 1035C New version 7-11-1996 1036C 1037C---------------------------------------------------------------------- 1038C 1039#include "implicit.h" 1040#include "priunit.h" 1041#include "maxorb.h" 1042#include "ccorb.h" 1043#include "iratdef.h" 1044#include "cclr.h" 1045#include "ccsdsym.h" 1046#include "ccsdio.h" 1047#include "ccsdinp.h" 1048#include "leinf.h" 1049C 1050 PARAMETER( TWO = 2.0D00,HALF=0.5D00,TOLFRQ=1.0D-08 ) 1051 DIMENSION WORK(LWORK) 1052 CHARACTER LABELA*8,LABELB*8,MODEL*10 1053 LOGICAL LRLXA,LRLXB 1054C 1055 IF ( IPRINT .GT. 10 ) THEN 1056 CALL AROUND( 'IN CC_FABCON: Calculating polarizabilty F-cont.') 1057 ENDIF 1058C 1059 NTAMPA = NT1AM(ISYMA) + NT2AM(ISYMA) 1060 IF ( CCS ) NTAMPA = NT1AM(ISYMA) 1061 NTAMPB = NT1AM(ISYMB) + NT2AM(ISYMB) 1062 IF ( CCS ) NTAMPB = NT1AM(ISYMB) 1063 IF (ISYMA .NE. ISYMB ) CALL QUIT('Symmetry mismatch in CC_FABCON') 1064C 1065C----------------------------------------------- 1066C Loop perturbations of this symmetry class. 1067C----------------------------------------------- 1068C 1069 KR1 = 1 1070 KEND1 = KR1 + NTAMPB 1071 LEND1 = LWORK - KEND1 1072 IF (LEND1.LT. 0 ) 1073 & CALL QUIT(' TOO LITTLE WORKSPACE IN CC_FABCON-1 ') 1074C 1075C------------------------------ 1076C Get F-transformed vector. 1077C------------------------------ 1078C 1079 KR11 = KR1 1080 KR12 = KR1 + NT1AM(ISYMB) 1081 ILSTNR = IR1TAMP(LABELB,LRLXB,FREQB,ISYMB) 1082 IOPT = 3 1083 CALL CC_RDRSP('F1',ILSTNR,ISYMB,IOPT,MODEL,WORK(KR11), 1084 * WORK(KR12)) 1085 IF (IPRINT .GT. 40 ) THEN 1086 CALL AROUND( 'In CC_EATB: F*RSP vector ' ) 1087 CALL CC_PRP(WORK(KR1),WORK(KR1+NT1AM(ISYMB)),ISYMB,1,1) 1088 ENDIF 1089C 1090 IF ( DEBUG ) THEN 1091 XLV = DDOT(NTAMPB, WORK(KR1),1,WORK(KR1),1) 1092 WRITE(LUPRI,1) 'Norm of F_Response vector: ',XLV 1093 ENDIF 1094C 1095 KR2 = KEND1 1096 KEND2 = KR2 + NTAMPA 1097 LEND2 = LWORK - KEND2 1098 IF (LEND2.LT. 0 ) 1099 & CALL QUIT(' TOO LITTLE WORKSPACE IN CC_ABFCON-2 ') 1100C 1101C----------------------------------------------------------- 1102C Get response vectors and do the dot with the F*vector. 1103C----------------------------------------------------------- 1104C 1105 KR21 = KR2 1106 KR22 = KR2 + NT1AM(ISYMA) 1107 ILSTNR = IR1TAMP(LABELA,LRLXA,FREQA,ISYMA) 1108 IOPT = 3 1109 CALL CC_RDRSP('R1',ILSTNR,ISYMA,IOPT,MODEL,WORK(KR21), 1110 * WORK(KR22)) 1111 IF ( DEBUG ) THEN 1112 XLV = DDOT(NTAMPA, WORK(KR2),1,WORK(KR2),1) 1113 WRITE(LUPRI,1) 'Norm of Response vector: ',XLV 1114 ENDIF 1115C 1116 FABCON = DDOT(NTAMPA,WORK(KR1),1,WORK(KR2),1) 1117 IF ( IPRINT .GT. 9 ) THEN 1118 WRITE(LUPRI,*) ' Singles contribution:', 1119 * DDOT(NT1AM(ISYMA),WORK(KR1),1,WORK(KR2),1) 1120 IF (.NOT. CCS) WRITE(LUPRI,*) ' Doubles contribution:', 1121 * DDOT(NT2AM(ISYMA),WORK(KR1+NT1AM(ISYMA)),1, 1122 * WORK(KR2+NT1AM(ISYMA)),1) 1123 ENDIF 1124 IF (IPRINT .GT. 2 ) THEN 1125 WRITE(LUPRI,'(1X,A2,A8,A1,A8,A3,F10.6,A,F14.10)') 1126 * '<<',LABELA,',',LABELB,'>>(', 1127 * FREQB,') F*tA*tB cont. = ',FABCON 1128 ENDIF 1129 PRP = PRP + FABCON 1130C 1131 1 FORMAT(1x,A35,1X,E20.10) 1132 RETURN 1133 END 1134c*DECK CC_LAKSIB 1135 SUBROUTINE CC_LAKSIB(LABELA,ISYMA,FREQA,LRLXA, 1136 * LABELB,ISYMB,FREQB,LRLXB, 1137 * PRP,WORK,LWORK) 1138C 1139C---------------------------------------------------------------------- 1140C 1141C Purpose: Calculate LD*ksiC contribution to second order properties. 1142C For use in calculation of molecular properties from 1143C Asymmetric formulaes not in accordance with 2n+2 rule for 1144C the multipliers, left vector, t-bar, lamdas, zeta or 1145C whatever your preferred choice is today. 1146C 1147C Written by Ove Christiansen 17-10-1996/7-11-1996 1148C 1149C---------------------------------------------------------------------- 1150C 1151#include "implicit.h" 1152#include "priunit.h" 1153#include "maxorb.h" 1154#include "ccorb.h" 1155#include "iratdef.h" 1156#include "cclr.h" 1157#include "ccsdsym.h" 1158#include "ccsdio.h" 1159#include "ccsdinp.h" 1160C 1161 PARAMETER( TWO = 2.0D00,TOLFRQ=1.0D-08 ) 1162 DIMENSION WORK(LWORK) 1163 CHARACTER LABELA*8,LABELB*8,MODEL*10 1164 LOGICAL LRLXA, LRLXB 1165C 1166 IF ( IPRINT .GT. 5 ) THEN 1167 CALL AROUND( 'IN CC_LAKSIB: Calculating polarizabilty ' 1168 * //'contribution') 1169 WRITE(LUPRI,'(/,1x,A,F16.8,/,A,I2,/,3A,/,A,2L3)') 1170 * 'Calculating response property with frequency',FREQB, 1171 * ' Operator symmetry = ',ISYMB, 1172 * ' Labels = ',LABELA, LABELB, 1173 * ' orbital relaxation flags = ',LRLXA, LRLXB 1174 ENDIF 1175C 1176C------------------------ 1177C Allocate workspace. 1178C------------------------ 1179C 1180 NTAMPA = NT1AM(ISYMA) + NT2AM(ISYMA) 1181 IF ( CCS ) NTAMPA = NT1AM(ISYMA) 1182 NTAMPB = NT1AM(ISYMB) + NT2AM(ISYMB) 1183 IF ( CCS ) NTAMPB = NT1AM(ISYMB) 1184 IF (ISYMA .NE. ISYMB ) CALL QUIT('Symmetry mismatch in CC_LAKSIB') 1185C 1186 KKSI = 1 1187 KEND1 = KKSI + NTAMPA 1188 LEND1 = LWORK - KEND1 1189 1190 KKSI1 = KKSI 1191 KKSI2 = KKSI1 + NT1AM(ISYMA) 1192C 1193 KR1 = KEND1 1194 KEND2 = KR1 + NTAMPB 1195 LEND2 = LWORK - KEND2 1196C 1197 IF (LEND2 .LT. 0) 1198 * CALL QUIT('Insufficient space for allocation in CC_LAKSIB') 1199C 1200C---------------------------------------------- 1201C Calculate contribution to polarizability. 1202C---------------------------------------------- 1203C 1204 IF (LRLXA) THEN 1205 ILSTRHS = IRHSR1(LABELA,LRLXA,FREQA,ISYMA) 1206 IOPT = 3 1207 CALL CC_RDRSP('O1 ',ILSTRHS,ISYMA,IOPT,MODEL, 1208 * WORK(KKSI1),WORK(KKSI2)) 1209 IF (DEBUG) THEN 1210 WRITE (LUPRI,*) 'IRHSR1:',ILSTRHS 1211 WRITE (LUPRI,*) 'norm(xksi1):', 1212 * DDOT(NT1AM(ISYMA),WORK(KKSI1),1,WORK(KKSI1),1) 1213 WRITE (LUPRI,*) 'norm(xksi2):', 1214 * DDOT(NT2AM(ISYMA),WORK(KKSI2),1,WORK(KKSI2),1) 1215 call cc_prp(work(kksi1),work(kksi2),isyma,1,1) 1216 END IF 1217 ELSE 1218 CALL CC_XKSI(WORK(KKSI),LABELA,ISYMA,0,DUMMY,WORK(KEND1),LEND1) 1219 END IF 1220C 1221 KR11 = KR1 1222 KR12 = KR1 + NT1AM(ISYMB) 1223 ILSTNR = IL1ZETA(LABELB,LRLXB,FREQB,ISYMB) 1224 IOPT = 3 1225 CALL CC_RDRSP('L1',ILSTNR,ISYMB,IOPT,MODEL,WORK(KR11), 1226 * WORK(KR12)) 1227 ABCON = DDOT(NTAMPA,WORK(KR1),1,WORK(KKSI),1) 1228 IF ( DEBUG ) THEN 1229 XLV = DDOT(NTAMPB, WORK(KR1),1,WORK(KR1),1) 1230 WRITE(LUPRI,1) 'Norm of Response vector: ',XLV 1231 ENDIF 1232C 1233 IF ( IPRINT .GT. 9 ) THEN 1234 WRITE(LUPRI,*) ' Singles contribution:', 1235 * DDOT(NT1AM(ISYMA),WORK(KKSI),1,WORK(KR1),1) 1236 IF (.NOT. CCS) WRITE(LUPRI,*) ' Doubles contribution:', 1237 * DDOT(NT2AM(ISYMA),WORK(KKSI+NT1AM(ISYMA)),1, 1238 * WORK(KR1+NT1AM(ISYMA)),1) 1239 ENDIF 1240 IF (IPRINT .GT. 2 ) THEN 1241 WRITE(LUPRI,'(1X,A2,A8,A1,A8,A3,F10.6,A,F10.6)') 1242 * '<<',LABELA,',',LABELB,'>>(', 1243 * FREQB,') LB*ksiA cont. = ',ABCON 1244 ENDIF 1245 PRP = PRP + ABCON 1246C 1247 1 FORMAT(1x,A35,1X,E20.10) 1248 RETURN 1249 END 1250c*DECK CC_POLPRI 1251 SUBROUTINE CC_POLPRI(POL,FRQ) 1252C 1253C---------------------------------------------------------------------- 1254C 1255C Purpose: Calculate LD*ksiC contribution to second order properties. 1256C For use in calculation of molecular properties from 1257C Asymmetric formulaes not in accordance with 2n+2 rule for 1258C the multipliers, left vector, t-bar, lamdas, zeta or 1259C whatever your preferred choice is today. 1260C 1261C Written by Ove Christiansen 17-10-1996/7-11-1996 1262C 1263C---------------------------------------------------------------------- 1264C 1265#include "implicit.h" 1266#include "priunit.h" 1267#include "dummy.h" 1268#include "maxorb.h" 1269 PARAMETER (TOLFRQ = 1.0D-08,ONE= 1.0D0,THR = 1.0D-08) 1270 PARAMETER (DPOLAUTSI = 1.648778D-41, QPOLAUTSI = 4.617048 D-62 ) 1271C 1272C DPOL C2m2J-1, QPOL C2m4J-1 1273C 1274#include "iratdef.h" 1275#include "cclr.h" 1276#include "ccorb.h" 1277#include "ccsdsym.h" 1278#include "ccsdio.h" 1279#include "ccsdinp.h" 1280#include "cclrinf.h" 1281#include "ccrspprp.h" 1282C 1283 DIMENSION POL(*),PVAL(3),PAXIS(3,3) 1284 CHARACTER MODEL*10 1285C 1286 IF ( IPRINT .GT. 10 ) THEN 1287 CALL AROUND( 'IN CC_POLPRI: Output polarizabilities ' ) 1288 ENDIF 1289C 1290 MODEL = 'CCSD ' 1291 IF (CCS) MODEL = 'CCS ' 1292 IF (CIS) MODEL = 'CIS ' 1293 IF (CC2) MODEL = 'CC2 ' 1294C 1295 IF (.NOT.(CCS.OR.CC2.OR.CCSD)) THEN 1296 WRITE(LUPRI,'(A)') 1297 & ' CC_POLPRI: Do not want to calculate anything' 1298 * //' else than CCS, CC2 and CCSD properties ' 1299 CALL QUIT('Model not CCS, CC2, or CCSD in CC_POLPRI') 1300 ENDIF 1301C 1302C-------------------------------------- 1303C Find the frequency components. 1304C-------------------------------------- 1305C 1306 WRITE(LUPRI,'(//,1X,A6,A,F10.6,/)') MODEL(1:6), 1307 * 'polarizability for frequency: ',FRQ 1308 CALL OUTPUT(POL,1,3,1,3,3,3,1,LUPRI) 1309cmbh: print polarizability for MidasCpp 1310 call wripro(POL(1),' '//MODEL(1:6)//' ',2, 1311 * 'X_DIPLEN','X_DIPLEN','X_DIPLEN','X_DIPLEN', 1312 * FRQ,FRQ,FRQ,1,0,0,0) 1313 call wripro(POL(2),' '//MODEL(1:6)//' ',2, 1314 * 'X_DIPLEN','Y_DIPLEN','X_DIPLEN','Y_DIPLEN', 1315 * FRQ,FRQ,FRQ,1,0,0,0) 1316 call wripro(POL(3),' '//MODEL(1:6)//' ',2, 1317 * 'X_DIPLEN','Z_DIPLEN','X_DIPLEN','Z_DIPLEN', 1318 * FRQ,FRQ,FRQ,1,0,0,0) 1319 call wripro(POL(5),' '//MODEL(1:6)//' ',2, 1320 * 'Y_DIPLEN','Y_DIPLEN','Y_DIPLEN','Y_DIPLEN', 1321 * FRQ,FRQ,FRQ,1,0,0,0) 1322 call wripro(POL(6),' '//MODEL(1:6)//' ',2, 1323 * 'Y_DIPLEN','Z_DIPLEN','Y_DIPLEN','Z_DIPLEN', 1324 * FRQ,FRQ,FRQ,1,0,0,0) 1325 call wripro(POL(9),' '//MODEL(1:6)//' ',2, 1326 * 'Z_DIPLEN','Z_DIPLEN','Z_DIPLEN','Z_DIPLEN', 1327 * FRQ,FRQ,FRQ,1,0,0,0) 1328cmbh end 1329C 1330 CALL TNSRAN(POL,PVAL,PAXIS, 1331 * ALFSQ,BETSQ,ITST,ITST2, 1332 * APAR,APEN,XKAPPA,IPAR) 1333 WRITE(LUPRI,'(/,1X,A38,F14.6)') 1334 * 'Alfa**2 Invariant: ' 1335 * //' ',ALFSQ 1336 WRITE(LUPRI,'(1X,A38,F14.6)') 1337 * 'Beta**2 Invariant: ' 1338 * //' ',BETSQ 1339 SHPAL = SQRT(ALFSQ) 1340 ANINV = SQRT(BETSQ) 1341 WRITE(LUPRI,'(/,1X,A42,F10.6,A)') 'Isotropic Polarizability: ' 1342 * //' ',SHPAL,' a.u.' 1343 WRITE(LUPRI,'(1X,A42,F10.6,A)') 'Polarizability anisotropy ' 1344 * //'invariant: ',ANINV,' a.u.' 1345 IF (ITST .EQ. 0) THEN 1346 IF (ITST2 .EQ. 3) THEN 1347 WRITE(LUPRI,'(/,1X,A)') 1348 * 'Polarizability has spherical symmetry:' 1349 WRITE(LUPRI,'(1X,A,F10.6,A,3X,E15.6,A)') 1350 * 'Isotropic polarizabilty: ',APAR,' a.u.',APAR*DPOLAUTSI,' S.I.' 1351 ELSE IF (ITST2 .EQ. 1) THEN 1352 WRITE(LUPRI,'(/,1X,A,/)') 1353 * 'Polarizability has cylinder symmetry: ' 1354 WRITE(LUPRI,'(1X,A,F10.6,A,3X,E15.6,A)') 1355 * 'Parallel component: ',APAR,' a.u.',APAR*DPOLAUTSI,' S.I.' 1356 WRITE(LUPRI,'(1X,A,F10.6,A,3X,E15.6,A)') 1357 * 'Perpendicular component: ',APEN,' a.u.',APEN*DPOLAUTSI,' S.I.' 1358 WRITE(LUPRI,'(/,1X,A42,F12.6)') 1359 * 'Dimensionless polarizability anisotropy: ',XKAPPA 1360 ELSE IF (ITST2. EQ. 0) THEN 1361 WRITE(LUPRI,'(/,1X,A,/)') 1362 * 'Polarizability is diagonal with diagonal values: ' 1363 WRITE(LUPRI,'(1X,A)') 1364 * ' a.u. S.I. ' 1365 WRITE(LUPRI,'(1X,A,F10.6,3X,E15.6)') 1366 * 'XX ',PVAL(1),PVAL(1)*DPOLAUTSI 1367 WRITE(LUPRI,'(1X,A,F10.6,3X,E15.6)') 1368 * 'YY ',PVAL(2),PVAL(2)*DPOLAUTSI 1369 WRITE(LUPRI,'(1X,A,F10.6,3X,E15.6)') 1370 * 'ZZ ',PVAL(3),PVAL(3)*DPOLAUTSI 1371 ENDIF 1372 ELSE 1373 WRITE(LUPRI,'(/,1X,A,/)') 1374 * 'Principal values of diagonalized Polarizability:' 1375 WRITE(LUPRI,'(1X,A)') 1376 * ' a.u. S.I. ' 1377 WRITE(LUPRI,'(1X,A,F10.6,3X,E15.6)') 1378 * '1 ',PVAL(1),PVAL(1)*DPOLAUTSI 1379 WRITE(LUPRI,'(1X,A,F10.6,3X,E15.6)') 1380 * '2 ',PVAL(2),PVAL(2)*DPOLAUTSI 1381 WRITE(LUPRI,'(1X,A,F10.6,3X,E15.6)') 1382 * '3 ',PVAL(3),PVAL(3)*DPOLAUTSI 1383 WRITE(LUPRI,'(/,1X,A,/)') 1384 * 'Principal axis of diagonalized Polarizability:' 1385 CALL OUTPUT(POL,1,3,1,3,3,3,1,LUPRI) 1386 ENDIF 1387 WRITE(LUPRI,'(/,1X,A,E18.8,A,/)') 1388 * 'Conversion factor (a.u. - S.I.):',DPOLAUTSI,' (C^2m^2J^-1)' 1389C 1390 CALL WRIPRO(SHPAL,MODEL,2, 1391 * 'isoalpha','isoalpha','isoalpha','isoalpha', 1392 * FRQ,DUMMY,DUMMY,1,0,0,0) 1393C 1394 CALL WRIPRO(ANINV,MODEL,2, 1395 * 'anis_inv','anis_inv','anis_inv','anis_inv', 1396 * FRQ,DUMMY,DUMMY,1,0,0,0) 1397C 1398 END 1399c*DECK CC_LRESID 1400 SUBROUTINE CC_LRESID(WORK,LWORK) 1401C 1402C----------------------------------------------------------------------------- 1403C 1404C Purpose: Direct calculation of Coupled Cluster 1405C linear response residue calculation. 1406C 1407C CCS, CC2, CCSD 1408C 1409C Modified version for general linear response properties 1410C Ove Christiansen November 1996. 1411C 1412C Symmetrization (C+/-w operator) 1413C Thomas Bondo Pedersen, January 2005. 1414C 1415C----------------------------------------------------------------------------- 1416C 1417#include "implicit.h" 1418#include "priunit.h" 1419#include "dummy.h" 1420#include "maxorb.h" 1421 PARAMETER (TOLFRQ=1.0D-08,ONE=1.0D0,XMONE=-1.0D0,THR=1.0D-08) 1422C 1423#include "iratdef.h" 1424#include "cclr.h" 1425#include "ccorb.h" 1426#include "ccsdsym.h" 1427#include "ccsdio.h" 1428#include "ccinftap.h" 1429#include "ccsdinp.h" 1430#include "cclrinf.h" 1431#include "ccexci.h" 1432#include "cclres.h" 1433#include "ccroper.h" 1434C 1435 LOGICAL LCALC 1436 DIMENSION WORK(LWORK) 1437 CHARACTER MODEL*10,MODELP*10 1438 CHARACTER LABELA*8,LABELB*8 1439C 1440 LOGICAL LOCDBG 1441 PARAMETER (LOCDBG = .FALSE.) 1442C 1443#include "leinf.h" 1444C 1445#include "mxcent.h" 1446#include "maxaqn.h" 1447#include "symmet.h" 1448#include "codata.h" 1449C 1450 PARAMETER (RAUSI = FPEPS0*(HBAR**3)*1.0D55/(EMASS**2)) 1451 PARAMETER (RAUCGS = ECHARGE*ECHARGE*HBAR*XTANG*CCM*1.0D36/EMASS) 1452C 1453 TIMTOT = SECOND() 1454 NTOT = 0 1455C 1456C------------------------------------ 1457C Header of Property calculation. 1458 1459C 1460 WRITE (LUPRI,'(1X,A,/)') ' ' 1461 WRITE (LUPRI,'(1X,A)') 1462 *'*********************************************************'// 1463 *'**********' 1464 WRITE (LUPRI,'(1X,A)') 1465 *'* '// 1466 *' *' 1467 WRITE (LUPRI,'(1X,A)') 1468 *'*---------- OUTPUT FROM COUPLED CLUSTER LINEAR RESPONSE >'// 1469 *'---------*' 1470 IF ( OSCSTR ) THEN 1471 WRITE (LUPRI,'(1X,A)') 1472 * '* '// 1473 * ' *' 1474 WRITE (LUPRI,'(1X,A)') 1475 * '*---------- CALCULATION OF CC OSCILLATOR STRENGTHS >'// 1476 * '---------*' 1477 ENDIF 1478 WRITE (LUPRI,'(1X,A)') 1479 *'* '// 1480 *' *' 1481 WRITE (LUPRI,'(1X,A,/)') 1482 *'*********************************************************'// 1483 *'**********' 1484C 1485 MODEL = 'CCSD ' 1486 IF (CC2) THEN 1487 MODEL = 'CC2 ' 1488 ENDIF 1489 IF (CCS) THEN 1490 MODEL = 'CCS ' 1491 ENDIF 1492 IF (CC3 ) THEN 1493 MODEL = 'CC3 ' 1494 WRITE(LUPRI,'(/,1x,A)') 1495 * 'CC3 Oscillator strengths not implemented yet' 1496 RETURN 1497 ENDIF 1498 IF (CC1A) THEN 1499 MODEL = 'CCSDT-1a ' 1500 WRITE(LUPRI,'(/,1x,A)') 1501 * 'CC1A Oscillator strengths not implemented yet' 1502 RETURN 1503 ENDIF 1504 IF (CCSD) THEN 1505 MODEL = 'CCSD ' 1506 ENDIF 1507C 1508 IF (CIS) THEN 1509 MODELP = 'CIS ' 1510 ELSE 1511 MODELP = MODEL 1512 ENDIF 1513C 1514 CALL AROUND( 'Calculation of '//MODELP// ' residues ') 1515C 1516 IF (IPRINT.GT.10) WRITE(LUPRI,*) 'CC_LRESID Workspace:',LWORK 1517C 1518C------------------------------------------------------------------------- 1519C Calculate polarizabilities in loops over symmetries and frequencies. 1520C------------------------------------------------------------------------- 1521C 1522 CALL FLSHFO(LUPRI) 1523C 1524 NALRPRP = NLRSOP*NXLRSST 1525 NBLRPRP = NLRSOP*NXLRSST 1526C 1527 KOSCS = 1 1528 KOSCSF = KOSCS + NALRPRP 1529 KSYMB = KOSCSF + NBLRPRP 1530 KSYMA = KSYMB + NBLRPRP 1531 KEND1 = KSYMA + NALRPRP 1532 LEND1 = LWORK - KEND1 1533C 1534 IF (LEND1 .LT. 0) THEN 1535 CALL QUIT('Insufficient memory in CC_LRESID [1]') 1536 END IF 1537C 1538 CALL DZERO(WORK(KOSCS),NALRPRP) 1539 CALL DZERO(WORK(KOSCSF),NBLRPRP) 1540 CALL DZERO(WORK(KSYMB),NBLRPRP) 1541 CALL DZERO(WORK(KSYMA),NALRPRP) 1542C 1543C---------------------------------------------- 1544C Loop over states and operators requested. 1545C---------------------------------------------- 1546C 1547 DO 1000 IRSD = 1, NXLRSST 1548 ISTATE = ILRSST(IRSD) 1549 ISYME = ISYEXC(ISTATE) 1550 ISTSY = ILRSST(IRSD)-ISYOFE(ISYME) 1551 EIGV = EIGVAL(ISTATE) 1552 IF (IPRINT .GT. 5) THEN 1553 WRITE(LUPRI,'(/,1x,A,I3,/1X,A,I3,A,F16.8)') 1554 * 'Calculating linear response residues for state',ISTSY, 1555 * 'of symmetry ',ISYME,' and with eigenvalue: ',EIGV 1556 ENDIF 1557C 1558 DO 2000 IOPER = 1, NLRSOP 1559 ISYMA = ISYOPR(IALRSOP(IOPER)) 1560 ISYMB = ISYOPR(IBLRSOP(IOPER)) 1561 1562 IF ((ISYME.EQ.ISYMA).AND.(ISYME.EQ.ISYMB)) THEN 1563 1564 LABELA = LBLOPR(IALRSOP(IOPER)) 1565 LABELB = LBLOPR(IBLRSOP(IOPER)) 1566C 1567C---------------------------------------- 1568C Calculate transition moments. 1569C---------------------------------------- 1570C 1571 KRES1 = KOSCS + NLRSOP*(IRSD-1) + IOPER - 1 1572 KRES2 = KOSCSF + NLRSOP*(IRSD-1) + IOPER - 1 1573 CALL CC_LRSD(LABELA,ISYMA, 1574 * LABELB,ISYMB, 1575 * ISTATE,WORK(KRES1),WORK(KRES2), 1576 * WORK(KEND1),LEND1) 1577C 1578 KRES3 = KSYMB + NLRSOP*(IRSD-1) + IOPER - 1 1579 KRES4 = KSYMA + NLRSOP*(IRSD-1) + IOPER - 1 1580 IF (LABELA .EQ. LABELB) THEN 1581 WORK(KRES3) = WORK(KRES1) 1582 WORK(KRES4) = WORK(KRES2) 1583 ELSE 1584 CALL CC_LRSD(LABELB,ISYMB, 1585 * LABELA,ISYMA, 1586 * ISTATE,WORK(KRES3),WORK(KRES4), 1587 * WORK(KEND1),LEND1) 1588 END IF 1589 IF (LOCDBG) THEN 1590 WRITE(LUPRI,*) ' Residue symmetrization:' 1591 WRITE(LUPRI,*) ' Exc. state: ',ISTSY,' of sym. ', 1592 & ISYME,':' 1593 WRITE(LUPRI,*) ' T(0f,',LABELA,') = ',WORK(KRES1) 1594 WRITE(LUPRI,*) ' T(f0,',LABELB,') = ',WORK(KRES2) 1595 WRITE(LUPRI,*) ' T(0f,',LABELB,') = ',WORK(KRES3) 1596 WRITE(LUPRI,*) ' T(f0,',LABELA,') = ',WORK(KRES4) 1597 CALL FLSHFO(LUPRI) 1598 END IF 1599C 1600 ENDIF 1601 2000 CONTINUE 1602 1000 CONTINUE 1603C 1604C----------------------------------------- 1605C Output Linear response properties. 1606C Save requested transition strengths. 1607C----------------------------------------- 1608C 1609 IF (OSCSTR) THEN 1610 LOSCIL = NEXCI*3*3 1611 ELSE 1612 LOSCIL = 0 1613 END IF 1614C 1615 IF (VELSTR) THEN 1616 LOSCIV = NEXCI*3*3 1617 ELSE 1618 LOSCIV = 0 1619 END IF 1620C 1621 IF (MIXSTR) THEN 1622 LOSCIM = NEXCI*3*3 1623 ELSE 1624 LOSCIM = 0 1625 END IF 1626C 1627 IF (ROTLEN) THEN 1628 LROTL = NEXCI*3 1629 LCHKL = NEXCI 1630 ELSE 1631 LROTL = 0 1632 LCHKL = 0 1633 ENDIF 1634C 1635 IF (ROTVEL) THEN 1636 LROTV = NEXCI*3 1637 LCHKV = NEXCI 1638 ELSE 1639 LROTV = 0 1640 LCHKV = 0 1641 ENDIF 1642C 1643 IF (RTNLEN) THEN 1644 LRQL = NEXCI*3*9 1645 LRML = NEXCI*3*3 1646 NWRL = 0 1647 ELSE 1648 LRQL = 0 1649 LRML = 0 1650 ENDIF 1651C 1652 IF (RTNVEL) THEN 1653 LRQV = NEXCI*3*9 1654 LRMV = NEXCI*3*3 1655 NWRV = 0 1656 ELSE 1657 LRQV = 0 1658 LRMV = 0 1659 ENDIF 1660C 1661 KOSCS2 = KEND1 1662 KTRS = KOSCS2 + LOSCIL 1663 KVELST = KTRS + LOSCIL 1664 KVELST2= KVELST + LOSCIV 1665 KMIXST = KVELST2 + LOSCIV 1666 KMIXST2= KMIXST + LOSCIM 1667 KROTL = KMIXST2 + LOSCIM 1668 KROTV = KROTL + LROTL 1669 KRQL = KROTV + LROTV 1670 KRML = KRQL + LRQL 1671 KRQL2 = KRML + LRML 1672 KRML2 = KRQL2 + LRML 1673 KRQV = KRML2 + LRML 1674 KRMV = KRQV + LRQV 1675 KRQV2 = KRMV + LRMV 1676 KRMV2 = KRQV2 + LRMV 1677 KCHKL = KRMV2 + LRMV 1678 KCHKV = KCHKL + LCHKL 1679 KEND2 = KCHKV + LCHKV 1680 LEND2 = LWORK - KEND2 1681C 1682 IF (LEND2 .LT. 0) THEN 1683 CALL QUIT('Insufficient memory in CC_LRESID [2]') 1684 END IF 1685C 1686 IF (OSCSTR) THEN 1687 CALL DZERO(WORK(KOSCS2),LOSCIL) 1688 CALL DZERO(WORK(KTRS),LOSCIL) 1689 END IF 1690 IF (VELSTR) THEN 1691 CALL DZERO(WORK(KVELST),LOSCIV) 1692 CALL DZERO(WORK(KVELST2),LOSCIV) 1693 END IF 1694 IF (MIXSTR) THEN 1695 CALL DZERO(WORK(KMIXST),LOSCIM) 1696 CALL DZERO(WORK(KMIXST2),LOSCIM) 1697 END IF 1698 IF (ROTLEN) THEN 1699 CALL DZERO(WORK(KROTL),LROTL) 1700 CALL DZERO(WORK(KROTL),LROTL) 1701 CALL DZERO(WORK(KCHKL),LCHKL) 1702 END IF 1703 IF (ROTVEL) THEN 1704 CALL DZERO(WORK(KROTV),LROTV) 1705 CALL DZERO(WORK(KROTV),LROTV) 1706 CALL DZERO(WORK(KCHKV),LCHKV) 1707 END IF 1708 IF (RTNLEN) THEN 1709 CALL DZERO(WORK(KRQL),LRQL) 1710 CALL DZERO(WORK(KRML),LRML) 1711 CALL DZERO(WORK(KRQL2),LRML) 1712 CALL DZERO(WORK(KRML2),LRML) 1713 END IF 1714 IF (RTNVEL) THEN 1715 CALL DZERO(WORK(KRQV),LRQV) 1716 CALL DZERO(WORK(KRMV),LRMV) 1717 CALL DZERO(WORK(KRQV2),LRMV) 1718 CALL DZERO(WORK(KRMV2),LRMV) 1719 END IF 1720C 1721 WRITE(LUPRI,'(//,1X,A6,A)') MODELP(1:6), 1722 * 'Right transition moments in atomic units:' 1723 WRITE(LUPRI,'(1X,A,/)') 1724 * '-----------------------------------------------' 1725C 1726 DO IOPER = 1, NLRSOP 1727 ISYMA = ISYOPR(IALRSOP(IOPER)) 1728 ISYMB = ISYOPR(IBLRSOP(IOPER)) 1729 LABELA = LBLOPR(IALRSOP(IOPER)) 1730 LABELB = LBLOPR(IBLRSOP(IOPER)) 1731 DO IRSD = 1, NXLRSST 1732 ISTATE = ILRSST(IRSD) 1733 ISYME = ISYEXC(ISTATE) 1734 ISTSY = ILRSST(IRSD)-ISYOFE(ISYME) 1735 EIGV = EIGVAL(ISTATE) 1736 IF ((ISYME.EQ.ISYMA).AND.(ISYME.EQ.ISYMB)) THEN 1737 K1 = NLRSOP*(IRSD-1) + IOPER + KOSCS - 1 1738 WRITE(LUPRI,'(1X,I2,F15.6,2X,A1,A8,A6,1X,F15.8)') 1739 * ISTATE,EIGV,'<',LABELA,'|f> = ',WORK(K1) 1740 ENDIF 1741 END DO 1742 END DO 1743C 1744 WRITE(LUPRI,'(//,1X,A6,A)') MODELP(1:6), 1745 * 'Left transition moments in atomic units:' 1746 WRITE(LUPRI,'(1X,A,/)') 1747 * '-----------------------------------------------' 1748C 1749 DO IOPER = 1, NLRSOP 1750 ISYMA = ISYOPR(IALRSOP(IOPER)) 1751 ISYMB = ISYOPR(IBLRSOP(IOPER)) 1752 LABELA = LBLOPR(IALRSOP(IOPER)) 1753 LABELB = LBLOPR(IBLRSOP(IOPER)) 1754 DO IRSD = 1, NXLRSST 1755 ISTATE = ILRSST(IRSD) 1756 ISYME = ISYEXC(ISTATE) 1757 ISTSY = ILRSST(IRSD)-ISYOFE(ISYME) 1758 EIGV = EIGVAL(ISTATE) 1759 IF ((ISYME.EQ.ISYMA).AND.(ISYME.EQ.ISYMB)) THEN 1760 K1 = NLRSOP*(IRSD-1) + IOPER + KOSCSF - 1 1761 WRITE(LUPRI,'(1X,I2,F15.6,2X,A3,A8,A4,1X,F15.8)') 1762 * ISTATE,EIGV,'<f|',LABELB,'> = ',WORK(K1) 1763 ENDIF 1764 END DO 1765 END DO 1766C 1767 CALL FLSHFO(LUPRI) 1768C 1769C---------------------------------------------------------------- 1770C Calculate linear response residues from transition moments, 1771C incl. symmetrization. 1772C---------------------------------------------------------------- 1773C 1774 WRITE(LUPRI,'(//,1X,A6,A)') MODELP(1:6), 1775 * 'linear response residue property in atomic units:' 1776C 1777 WRITE(LUPRI,'(1X,A,/)') 1778 * '-------------------------------------------------------' 1779C 1780 DO IOPER = 1, NLRSOP 1781 ISYMA = ISYOPR(IALRSOP(IOPER)) 1782 ISYMB = ISYOPR(IBLRSOP(IOPER)) 1783 LABELA = LBLOPR(IALRSOP(IOPER)) 1784 LABELB = LBLOPR(IBLRSOP(IOPER)) 1785 DO IRSD = 1, NXLRSST 1786 ISTATE = ILRSST(IRSD) 1787 ISYME = ISYEXC(ISTATE) 1788 ISTSY = ILRSST(IRSD)-ISYOFE(ISYME) 1789 EIGV = EIGVAL(ISTATE) 1790 ISYMEA = MULD2H(ISYME,ISYMA) 1791 IF ((ISYME.EQ.ISYMA).AND.(ISYME.EQ.ISYMB)) THEN 1792 NTOT = NTOT + 1 1793 K1 = NLRSOP*(IRSD-1) + IOPER + KOSCS - 1 1794 K2 = NLRSOP*(IRSD-1) + IOPER + KOSCSF - 1 1795 K3 = NLRSOP*(IRSD-1) + IOPER + KSYMB - 1 1796 K4 = NLRSOP*(IRSD-1) + IOPER + KSYMA - 1 1797 IHERMA = ISYMAT(IALRSOP(IOPER)) 1798 IHERMB = ISYMAT(IBLRSOP(IOPER)) 1799 ISASB = IHERMA*IHERMB 1800 IF (ISASB .EQ. 0) THEN 1801 WRITE(LUPRI,*) ' WARNING: operators ',LABELA,LABELB, 1802 & ' have undefined hermiticities: ', 1803 & IHERMA,IHERMB 1804 WRITE(LUPRI,*) ' Residue not appropriately symmetrized..' 1805 CALL FLSHFO(LUPRI) 1806 SIGN = 1.0D0 1807 ELSE 1808 SIGN = DBLE(ISASB) 1809 ENDIF 1810 RESIDAB = WORK(K1)*WORK(K2) 1811 RESIDBA = WORK(K3)*WORK(K4) 1812 RESIDUE = 0.5D0*(RESIDAB + SIGN*RESIDBA) 1813 IF (RESIDUE.GE.0.0D0) THEN 1814 SQRRES=SQRT(RESIDUE) 1815 ELSE 1816 SQRRES=-SQRT(-RESIDUE) 1817 ENDIF 1818 WRITE(LUPRI,'(1X,A6,A8,A1,A8,A3,F9.6,A,F15.8,A,F12.8,A)') 1819 * 'RES{<<',LABELA,',',LABELB,'>>(',EIGV,')} =', 1820 * RESIDUE,' ( ',SQRRES,')' 1821 IF (LOCDBG) THEN 1822 WRITE(LUPRI,*) ' A,B: ',RESIDAB, 1823 & ' B,A: ',RESIDBA, 1824 & ' combination: ',ISASB 1825 END IF 1826 IF (OSCSTR) THEN ! length gauge oscillator strength 1827 IF (LABELA(2:7).EQ.'DIPLEN' .AND. 1828 & LABELB(2:7).EQ.'DIPLEN') THEN 1829 IF (LABELA(1:1).EQ.'X') IADR1 = 1 1830 IF (LABELA(1:1).EQ.'Y') IADR1 = 2 1831 IF (LABELA(1:1).EQ.'Z') IADR1 = 3 1832 IF (LABELB(1:1).EQ.'X') IADR2 = 1 1833 IF (LABELB(1:1).EQ.'Y') IADR2 = 2 1834 IF (LABELB(1:1).EQ.'Z') IADR2 = 3 1835 IF ((IADR1+IADR2).GE.2) THEN 1836 IOSCS2 = 3*3*(ISTATE-1)+3*(IADR2-1)+IADR1+KOSCS2-1 1837 WORK(IOSCS2) = RESIDUE 1838 END IF 1839 END IF 1840 END IF 1841 IF (VELSTR) THEN ! velocity gauge oscillator strength 1842 IF (LABELA(2:7).EQ.'DIPVEL' .AND. 1843 & LABELB(2:7).EQ.'DIPVEL') THEN 1844 IF (LABELA(1:1).EQ.'X') IADR1 = 1 1845 IF (LABELA(1:1).EQ.'Y') IADR1 = 2 1846 IF (LABELA(1:1).EQ.'Z') IADR1 = 3 1847 IF (LABELB(1:1).EQ.'X') IADR2 = 1 1848 IF (LABELB(1:1).EQ.'Y') IADR2 = 2 1849 IF (LABELB(1:1).EQ.'Z') IADR2 = 3 1850 IF ((IADR1+IADR2).GE.2) THEN 1851 IOSCS2 = 3*3*(ISTATE-1)+3*(IADR2-1)+IADR1+KVELST-1 1852 WORK(IOSCS2) = RESIDUE 1853 END IF 1854 END IF 1855 END IF 1856 IF (MIXSTR) THEN ! Mixed gauge oscillator strength 1857 IF (LABELA(2:7).EQ.'DIPLEN' .AND. 1858 & LABELB(2:7).EQ.'DIPVEL') THEN 1859 IF (LABELA(1:1).EQ.'X') IADR1 = 1 1860 IF (LABELA(1:1).EQ.'Y') IADR1 = 2 1861 IF (LABELA(1:1).EQ.'Z') IADR1 = 3 1862 IF (LABELB(1:1).EQ.'X') IADR2 = 1 1863 IF (LABELB(1:1).EQ.'Y') IADR2 = 2 1864 IF (LABELB(1:1).EQ.'Z') IADR2 = 3 1865 IOSCS2 = 3*3*(ISTATE-1)+3*(IADR2-1)+IADR1+KMIXST-1 1866 WORK(IOSCS2) = RESIDUE 1867 END IF 1868 END IF 1869 IF (ROTLEN) THEN ! Length gauge rotatory strength 1870 IF (LABELA(2:7) .EQ. 'DIPLEN' .AND. 1871 & LABELB(2:7) .EQ. 'ANGMOM') THEN 1872 IF (LABELA(1:1).EQ.'X') IADR1 = 1 1873 IF (LABELA(1:1).EQ.'Y') IADR1 = 2 1874 IF (LABELA(1:1).EQ.'Z') IADR1 = 3 1875 IF (LABELB(1:1).EQ.'X') IADR2 = 1 1876 IF (LABELB(1:1).EQ.'Y') IADR2 = 2 1877 IF (LABELB(1:1).EQ.'Z') IADR2 = 3 1878 IF (IADR1 .EQ. IADR2) THEN 1879 IROTST = KROTL + 3*(ISTATE-1) + IADR1 - 1 1880 WORK(IROTST) = RESIDUE 1881 END IF 1882 END IF 1883 END IF 1884 IF (ROTVEL) THEN ! Velocity gauge rotatory strength 1885 IF (LABELA(2:7) .EQ. 'DIPVEL' .AND. 1886 & LABELB(2:7) .EQ. 'ANGMOM') THEN 1887 IF (LABELA(1:1).EQ.'X') IADR1 = 1 1888 IF (LABELA(1:1).EQ.'Y') IADR1 = 2 1889 IF (LABELA(1:1).EQ.'Z') IADR1 = 3 1890 IF (LABELB(1:1).EQ.'X') IADR2 = 1 1891 IF (LABELB(1:1).EQ.'Y') IADR2 = 2 1892 IF (LABELB(1:1).EQ.'Z') IADR2 = 3 1893 IF (IADR1 .EQ. IADR2) THEN 1894 IROTST = KROTV + 3*(ISTATE-1) + IADR1 - 1 1895 WORK(IROTST) = RESIDUE 1896 END IF 1897 END IF 1898 END IF 1899 IF (RTNLEN) THEN 1900 IF (LABELA(2:7) .EQ. 'DIPLEN') THEN 1901 IF (LABELB(3:8) .EQ. 'SECMOM') THEN 1902 IF (LABELA(1:1).EQ.'X') IADR1 = 1 1903 IF (LABELA(1:1).EQ.'Y') IADR1 = 2 1904 IF (LABELA(1:1).EQ.'Z') IADR1 = 3 1905 IF (LABELB(1:2).EQ.'XX') THEN 1906 IADR23 = 1 1907 IADR32 = 0 1908 ELSE IF (LABELB(1:2).EQ.'XY') THEN 1909 IADR23 = 4 1910 IADR32 = 2 1911 ELSE IF (LABELB(1:2).EQ.'XZ') THEN 1912 IADR23 = 7 1913 IADR32 = 3 1914 ELSE IF (LABELB(1:2).EQ.'YY') THEN 1915 IADR23 = 5 1916 IADR32 = 0 1917 ELSE IF (LABELB(1:2).EQ.'YZ') THEN 1918 IADR23 = 8 1919 IADR32 = 6 1920 ELSE IF (LABELB(1:2).EQ.'ZZ') THEN 1921 IADR23 = 9 1922 IADR32 = 0 1923 END IF 1924 IRTEN = KRQL + 3*9*(ISTATE-1) 1925 & + 3*(IADR23-1) + IADR1 - 1 1926 WORK(IRTEN) = RESIDUE 1927 IF (IADR32 .NE. 0) THEN 1928 IRTEN = KRQL + 3*9*(ISTATE-1) 1929 & + 3*(IADR32-1) + IADR1 - 1 1930 WORK(IRTEN) = RESIDUE 1931 END IF 1932 ELSE IF (LABELB(2:7) .EQ. 'ANGMOM') THEN 1933 IF (LABELA(1:1).EQ.'X') IADR1 = 1 1934 IF (LABELA(1:1).EQ.'Y') IADR1 = 2 1935 IF (LABELA(1:1).EQ.'Z') IADR1 = 3 1936 IF (LABELB(1:1).EQ.'X') IADR2 = 1 1937 IF (LABELB(1:1).EQ.'Y') IADR2 = 2 1938 IF (LABELB(1:1).EQ.'Z') IADR2 = 3 1939 IRTEN = KRML + 3*3*(ISTATE-1) 1940 & + 3*(IADR2-1) + IADR1 - 1 1941 WORK(IRTEN) = RESIDUE 1942 END IF 1943 END IF 1944 END IF 1945 IF (RTNVEL) THEN 1946 IF (LABELA(2:7) .EQ. 'DIPVEL') THEN 1947 IF (LABELB(3:8) .EQ. 'ROTSTR') THEN 1948 IF (LABELA(1:1).EQ.'X') IADR1 = 1 1949 IF (LABELA(1:1).EQ.'Y') IADR1 = 2 1950 IF (LABELA(1:1).EQ.'Z') IADR1 = 3 1951 IF (LABELB(1:2).EQ.'XX') THEN 1952 IADR23 = 1 1953 IADR32 = 0 1954 ELSE IF (LABELB(1:2).EQ.'XY') THEN 1955 IADR23 = 4 1956 IADR32 = 2 1957 ELSE IF (LABELB(1:2).EQ.'XZ') THEN 1958 IADR23 = 7 1959 IADR32 = 3 1960 ELSE IF (LABELB(1:2).EQ.'YY') THEN 1961 IADR23 = 5 1962 IADR32 = 0 1963 ELSE IF (LABELB(1:2).EQ.'YZ') THEN 1964 IADR23 = 8 1965 IADR32 = 6 1966 ELSE IF (LABELB(1:2).EQ.'ZZ') THEN 1967 IADR23 = 9 1968 IADR32 = 0 1969 END IF 1970 IRTEN = KRQV + 3*9*(ISTATE-1) 1971 & + 3*(IADR23-1) + IADR1 - 1 1972 WORK(IRTEN) = RESIDUE 1973 IF (IADR32 .NE. 0) THEN 1974 IRTEN = KRQV + 3*9*(ISTATE-1) 1975 & + 3*(IADR32-1) + IADR1 - 1 1976 WORK(IRTEN) = RESIDUE 1977 END IF 1978 ELSE IF (LABELB(2:7) .EQ. 'ANGMOM') THEN 1979 IF (LABELA(1:1).EQ.'X') IADR1 = 1 1980 IF (LABELA(1:1).EQ.'Y') IADR1 = 2 1981 IF (LABELA(1:1).EQ.'Z') IADR1 = 3 1982 IF (LABELB(1:1).EQ.'X') IADR2 = 1 1983 IF (LABELB(1:1).EQ.'Y') IADR2 = 2 1984 IF (LABELB(1:1).EQ.'Z') IADR2 = 3 1985 IRTEN = KRMV + 3*3*(ISTATE-1) 1986 & + 3*(IADR2-1) + IADR1 - 1 1987 WORK(IRTEN) = RESIDUE 1988 END IF 1989 END IF 1990 END IF 1991 ELSE 1992 RESIDUE = 0.0D0 1993 SQRRES = 0.0D0 1994 ENDIF 1995 IF (LABELA.EQ.LABELB) THEN 1996 CALL WRIPRO(SQRRES,MODEL,-1, 1997 * LABELA,LABELB,LABELA,LABELB, 1998 * EIGV,EIGV,EIGV,ISYMEA,ISYME,1,ISTATE) 1999 ENDIF 2000 END DO 2001 END DO 2002 2003C 2004C----------------------------------------------- 2005C Perform analysis for oscillator strengths. 2006C----------------------------------------------- 2007C 2008 IF (OSCSTR) CALL DCOPY(LOSCIL,WORK(KOSCS2),1,WORK(KTRS),1) 2009 IF (VELSTR) CALL DCOPY(LOSCIV,WORK(KVELST),1,WORK(KVELST2),1) 2010 IF (MIXSTR) CALL DCOPY(LOSCIM,WORK(KMIXST),1,WORK(KMIXST2),1) 2011C 2012C------------------------------------------------------------- 2013C Write out strength for CCS, CC2, and CCSD on unit LUOSC. 2014C------------------------------------------------------------- 2015C 2016 LUOSC = LURES 2017 IF (OSCSTR .AND. (CCS.OR.CC2.OR.CCSD)) THEN 2018C 2019 WRITE(LUOSC,'(//A)') 2020 * ' +==============================================' 2021 * //'===============================+' 2022 WRITE(LUOSC,'(1X,A26,A10,A)') 2023 * '| sym. | Exci. | ',MODELP,' Transition properti' 2024 * //'es |' 2025 WRITE(LUOSC,'(A)') 2026 * ' |(spin, | +-----------------------------' 2027 * //'-------------------------------+' 2028 WRITE(LUOSC,'(1X,A)') 2029 * '| spat) | | Dipole Strength(a.u.) | Oscillator stre' 2030 * //'ngth | Direction |' 2031 WRITE(LUOSC,'(A)') 2032 * ' +==============================================' 2033 * //'===============================+' 2034C 2035 DO 9001 ISYM = 1, NSYM 2036 DO 9002 IEX = 1, NCCEXCI(ISYM,1) 2037 ISTATE = ISYOFE(ISYM) + IEX 2038 EIGV = EIGVAL(ISTATE) 2039 KOSCSI = KOSCS2 + 3*3*(ISTATE-1) 2040 KTRSI = KTRS + 3*3*(ISTATE-1) 2041 LCALC = .FALSE. 2042 LDIP = 1 2043 DO IRSD = 1, NXLRSST 2044 ISTATE = ILRSST(IRSD) 2045 ISYME = ISYEXC(ISTATE) 2046 ISTSY = ILRSST(IRSD)-ISYOFE(ISYME) 2047 IF ((ISYME.EQ.ISYM).AND.(IEX.EQ.ISTSY)) LCALC =.TRUE. 2048 END DO 2049 CALL CC_OSCPRI(WORK(KTRSI),WORK(KOSCSI),EIGV, 2050 * IEX,ISYM,WORK(KEND2),LEND2,MODELP,LCALC, 2051 * LDIP,LUOSC) 2052 9002 CONTINUE 2053 2054 IF (.NOT.((ISYM .EQ. NSYM).OR.(NCCEXCI(ISYM,1).EQ.0))) THEN 2055 NREST = 0 2056 DO 9003 ISYM2 = ISYM+1,NSYM 2057 NREST = NREST + NCCEXCI(ISYM2,1) 2058 9003 CONTINUE 2059 IF (NREST.EQ.0) GOTO 9001 2060 WRITE(LUOSC,'(A)') 2061 * ' +----------------------------------------------' 2062 * //'-------------------------------+' 2063 ENDIF 2064 9001 CONTINUE 2065C 2066 WRITE(LUOSC,'(A)') 2067 * ' +==============================================' 2068 * //'===============================+' 2069C 2070 ENDIF 2071C 2072 LUOSC = LURES 2073 IF (VELSTR .AND. (CCS.OR.CC2.OR.CCSD)) THEN 2074C 2075 WRITE(LUOSC,'(//A)') 2076 * ' +==============================================' 2077 * //'===============================+' 2078 WRITE(LUOSC,'(1X,A26,A10,A)') 2079 * '| sym. | Exci. | ',MODELP,' Transition properti' 2080 * //'es |' 2081 WRITE(LUOSC,'(A)') 2082 * ' |(spin, | +-----------------------------' 2083 * //'-------------------------------+' 2084 WRITE(LUOSC,'(1X,A)') 2085 * '| spat) | | Veloc. Strength(a.u.) | Oscillator stre' 2086 * //'ngth | Direction |' 2087 WRITE(LUOSC,'(A)') 2088 * ' +==============================================' 2089 * //'===============================+' 2090C 2091 DO 9005 ISYM = 1, NSYM 2092 DO 9006 IEX = 1, NCCEXCI(ISYM,1) 2093 ISTATE = ISYOFE(ISYM) + IEX 2094 EIGV = EIGVAL(ISTATE) 2095 KOSCSI = KVELST + 3*3*(ISTATE-1) 2096 KTRSI = KVELST2+ 3*3*(ISTATE-1) 2097 LCALC = .FALSE. 2098 LDIP = 2 2099 DO IRSD = 1, NXLRSST 2100 ISTATE = ILRSST(IRSD) 2101 ISYME = ISYEXC(ISTATE) 2102 ISTSY = ILRSST(IRSD)-ISYOFE(ISYME) 2103 IF ((ISYME.EQ.ISYM).AND.(IEX.EQ.ISTSY)) LCALC =.TRUE. 2104 END DO 2105 CALL CC_OSCPRI(WORK(KTRSI),WORK(KOSCSI),EIGV, 2106 * IEX,ISYM,WORK(KEND2),LEND2,MODELP,LCALC, 2107 * LDIP,LUOSC) 2108 9006 CONTINUE 2109 2110 IF (.NOT.((ISYM .EQ. NSYM).OR.(NCCEXCI(ISYM,1).EQ.0))) THEN 2111 NREST = 0 2112 DO 9007 ISYM2 = ISYM+1,NSYM 2113 NREST = NREST + NCCEXCI(ISYM2,1) 2114 9007 CONTINUE 2115 IF (NREST.EQ.0) GOTO 9005 2116 WRITE(LUOSC,'(A)') 2117 * ' +----------------------------------------------' 2118 * //'-------------------------------+' 2119 ENDIF 2120 9005 CONTINUE 2121C 2122 WRITE(LUOSC,'(A)') 2123 * ' +==============================================' 2124 * //'===============================+' 2125C 2126 ENDIF 2127C 2128 IF (MIXSTR .AND. (CCS.OR.CC2.OR.CCSD)) THEN 2129C 2130 WRITE(LUOSC,'(//A)') 2131 * ' +==============================================' 2132 * //'===============================+' 2133 WRITE(LUOSC,'(1X,A26,A10,A)') 2134 * '| sym. | Exci. | ',MODELP,' Mixed Gauge Osci' 2135 * //'llator Strength |' 2136 WRITE(LUOSC,'(A)') 2137 * ' |(spin, | +-----------------------------' 2138 * //'-------------------------------+' 2139 WRITE(LUOSC,'(1X,A)') 2140 * '| spat) | | Dipole Strength(a.u.) | Oscillator stre' 2141 * //'ngth | Direction |' 2142 WRITE(LUOSC,'(A)') 2143 * ' +==============================================' 2144 * //'===============================+' 2145C 2146 DO ISYM = 1, NSYM 2147 DO IEX = 1, NCCEXCI(ISYM,1) 2148 ISTATE = ISYOFE(ISYM) + IEX 2149 EIGV = EIGVAL(ISTATE) 2150 KOSCSI = KMIXST + 3*3*(ISTATE-1) 2151 KTRSI = KMIXST2+ 3*3*(ISTATE-1) 2152 LCALC = .FALSE. 2153 LDIP = 3 2154 DO IRSD = 1, NXLRSST 2155 ISTATE = ILRSST(IRSD) 2156 ISYME = ISYEXC(ISTATE) 2157 ISTSY = ILRSST(IRSD)-ISYOFE(ISYME) 2158 IF ((ISYME.EQ.ISYM).AND.(IEX.EQ.ISTSY)) LCALC =.TRUE. 2159 END DO 2160 CALL CC_OSCPRI(WORK(KTRSI),WORK(KOSCSI),EIGV, 2161 * IEX,ISYM,WORK(KEND2),LEND2,MODELP,LCALC, 2162 * LDIP,LUOSC) 2163 END DO 2164 2165 IF (.NOT.((ISYM .EQ. NSYM).OR.(NCCEXCI(ISYM,1).EQ.0))) THEN 2166 NREST = 0 2167 DO ISYM2 = ISYM+1,NSYM 2168 NREST = NREST + NCCEXCI(ISYM2,1) 2169 END DO 2170 IF (NREST.EQ.0) GOTO 9008 2171 WRITE(LUOSC,'(A)') 2172 * ' +----------------------------------------------' 2173 * //'-------------------------------+' 2174 END IF 2175 9008 CONTINUE 2176 END DO 2177C 2178 WRITE(LUOSC,'(A)') 2179 * ' +==============================================' 2180 * //'===============================+' 2181C 2182 END IF 2183C 2184 LUOSC = LURES 2185 IF (ROTLEN .AND. (CCS.OR.CC2.OR.CCSD)) THEN 2186 2187 WRITE(LUOSC,'(//A)') 2188 * ' +==============================================' 2189 * //'===============================+' 2190 WRITE(LUOSC,'(1X,A26,A10,A)') 2191 * '| sym. | Exci. | ',MODELP,' Length Gauge Rota' 2192 * //'tory Strength |' 2193 WRITE(LUOSC,'(A)') 2194 * ' |(spin, | +-----------------------------' 2195 * //'-------------------------------+' 2196 WRITE(LUOSC,'(1X,A)') 2197 * '| spat) | | D-55 SI | D-40 cgs ' 2198 * //' | Direction |' 2199 WRITE(LUOSC,'(A)') 2200 * ' +==============================================' 2201 * //'===============================+' 2202 2203 DO ISYM = 1, NSYM 2204 DO IEX = 1, NCCEXCI(ISYM,1) 2205 ISTATE = ISYOFE(ISYM) + IEX 2206 EIGV = EIGVAL(ISTATE) 2207 KTRSI = KROTL + 3*(ISTATE-1) 2208 KSTREN = KCHKL + ISTATE - 1 2209 LCALC = .FALSE. 2210 LDIP = 1 2211 DO IRSD = 1, NXLRSST 2212 ISTATE = ILRSST(IRSD) 2213 ISYME = ISYEXC(ISTATE) 2214 ISTSY = ILRSST(IRSD)-ISYOFE(ISYME) 2215 IF ((ISYME.EQ.ISYM).AND.(IEX.EQ.ISTSY)) LCALC =.TRUE. 2216 END DO 2217 CALL CC_ROTPRI(WORK(KTRSI),WORK(KSTREN),EIGV,IEX,ISYM,MODELP, 2218 & LCALC,LDIP,LUOSC) 2219 2220 END DO 2221 2222 IF (.NOT.((ISYM .EQ. NSYM).OR.(NCCEXCI(ISYM,1).EQ.0))) THEN 2223 NREST = 0 2224 DO ISYM2 = ISYM+1,NSYM 2225 NREST = NREST + NCCEXCI(ISYM2,1) 2226 END DO 2227 IF (NREST.EQ.0) GOTO 9009 2228 WRITE(LUOSC,'(A)') 2229 * ' +----------------------------------------------' 2230 * //'-------------------------------+' 2231 END IF 2232 9009 CONTINUE 2233 END DO 2234 2235 WRITE(LUOSC,'(A)') 2236 * ' +==============================================' 2237 * //'===============================+' 2238 2239 END IF 2240C 2241 LUOSC = LURES 2242 IF (ROTVEL .AND. (CCS.OR.CC2.OR.CCSD)) THEN 2243 2244 WRITE(LUOSC,'(//A)') 2245 * ' +==============================================' 2246 * //'===============================+' 2247 WRITE(LUOSC,'(1X,A26,A10,A)') 2248 * '| sym. | Exci. | ',MODELP,' Velocity Gauge Rota' 2249 * //'tory Strength |' 2250 WRITE(LUOSC,'(A)') 2251 * ' |(spin, | +-----------------------------' 2252 * //'-------------------------------+' 2253 WRITE(LUOSC,'(1X,A)') 2254 * '| spat) | | D-55 SI | D-40 cgs ' 2255 * //' | Direction |' 2256 WRITE(LUOSC,'(A)') 2257 * ' +==============================================' 2258 * //'===============================+' 2259 2260 DO ISYM = 1, NSYM 2261 DO IEX = 1, NCCEXCI(ISYM,1) 2262 ISTATE = ISYOFE(ISYM) + IEX 2263 EIGV = EIGVAL(ISTATE) 2264 KTRSI = KROTV + 3*(ISTATE-1) 2265 KSTREN = KCHKV + ISTATE - 1 2266 LCALC = .FALSE. 2267 LDIP = 2 2268 DO IRSD = 1, NXLRSST 2269 ISTATE = ILRSST(IRSD) 2270 ISYME = ISYEXC(ISTATE) 2271 ISTSY = ILRSST(IRSD)-ISYOFE(ISYME) 2272 IF ((ISYME.EQ.ISYM).AND.(IEX.EQ.ISTSY)) LCALC =.TRUE. 2273 END DO 2274 CALL CC_ROTPRI(WORK(KTRSI),WORK(KSTREN),EIGV,IEX,ISYM,MODELP, 2275 & LCALC,LDIP,LUOSC) 2276 2277 END DO 2278 2279 IF (.NOT.((ISYM .EQ. NSYM).OR.(NCCEXCI(ISYM,1).EQ.0))) THEN 2280 NREST = 0 2281 DO ISYM2 = ISYM+1,NSYM 2282 NREST = NREST + NCCEXCI(ISYM2,1) 2283 END DO 2284 IF (NREST.EQ.0) GOTO 9010 2285 WRITE(LUOSC,'(A)') 2286 * ' +----------------------------------------------' 2287 * //'-------------------------------+' 2288 END IF 2289 9010 CONTINUE 2290 END DO 2291 2292 WRITE(LUOSC,'(A)') 2293 * ' +==============================================' 2294 * //'===============================+' 2295 2296 END IF 2297 2298 LUOSC = LURES 2299 IF (RTNLEN .AND. (CCS.OR.CC2.OR.CCSD)) THEN 2300 2301 WRITE(LUOSC,'(//A)') 2302 * ' +==============================================' 2303 * //'===============================+' 2304 WRITE(LUOSC,'(1X,A26,A10,A)') 2305 * '| sym. | Exci. | ',MODELP,' Length Gauge Rot.' 2306 * //'Str. Tensor, El. Quad.|' 2307 WRITE(LUOSC,'(A)') 2308 * ' |(spin, | +-----------------------------' 2309 * //'-------------------------------+' 2310 WRITE(LUOSC,'(1X,A)') 2311 * '| spat) | | D-55 SI | D-40 cgs ' 2312 * //' | Component |' 2313 WRITE(LUOSC,'(A)') 2314 * ' +==============================================' 2315 * //'===============================+' 2316 2317 DO ISYM = 1, NSYM 2318 DO IEX = 1, NCCEXCI(ISYM,1) 2319 ISTATE = ISYOFE(ISYM) + IEX 2320 EIGV = EIGVAL(ISTATE) 2321 KOFFQ = KRQL + 3*9*(ISTATE-1) 2322 KOFQ2 = KRQL2 + 3*3*(ISTATE-1) 2323 LCALC = .FALSE. 2324 LDIP = 1 2325 DO IRSD = 1, NXLRSST 2326 ISTATE = ILRSST(IRSD) 2327 ISYME = ISYEXC(ISTATE) 2328 ISTSY = ILRSST(IRSD)-ISYOFE(ISYME) 2329 IF ((ISYME.EQ.ISYM).AND.(IEX.EQ.ISTSY)) LCALC =.TRUE. 2330 END DO 2331 CALL CC_RTQPRI(WORK(KOFFQ),WORK(KOFQ2),EIGV,IEX,ISYM,MODELP, 2332 & LCALC,LDIP,LUOSC,NWRL) 2333 2334 END DO 2335 2336 IF (.NOT.((ISYM .EQ. NSYM).OR.(NCCEXCI(ISYM,1).EQ.0))) THEN 2337 NREST = 0 2338 DO ISYM2 = ISYM+1,NSYM 2339 NREST = NREST + NCCEXCI(ISYM2,1) 2340 END DO 2341 IF (NREST.EQ.0) GOTO 9011 2342 WRITE(LUOSC,'(A)') 2343 * ' +----------------------------------------------' 2344 * //'-------------------------------+' 2345 END IF 2346 9011 CONTINUE 2347 END DO 2348 2349 WRITE(LUOSC,'(A)') 2350 * ' +==============================================' 2351 * //'===============================+' 2352 2353 WRITE(LUOSC,'(//A)') 2354 * ' +==============================================' 2355 * //'===============================+' 2356 WRITE(LUOSC,'(1X,A26,A10,A)') 2357 * '| sym. | Exci. | ',MODELP,' Length Gauge Rot.' 2358 * //'Str. Tensor, Mag. Dip.|' 2359 WRITE(LUOSC,'(A)') 2360 * ' |(spin, | +-----------------------------' 2361 * //'-------------------------------+' 2362 WRITE(LUOSC,'(1X,A)') 2363 * '| spat) | | D-55 SI | D-40 cgs ' 2364 * //' | Component |' 2365 WRITE(LUOSC,'(A)') 2366 * ' +==============================================' 2367 * //'===============================+' 2368 2369 DO ISYM = 1, NSYM 2370 DO IEX = 1, NCCEXCI(ISYM,1) 2371 ISTATE = ISYOFE(ISYM) + IEX 2372 EIGV = EIGVAL(ISTATE) 2373 KOFFM = KRML + 3*3*(ISTATE-1) 2374 KOFM2 = KRML2 + 3*3*(ISTATE-1) 2375 KSTREN = KCHKL + ISTATE - 1 2376 LCALC = .FALSE. 2377 LDIP = 1 2378 DO IRSD = 1, NXLRSST 2379 ISTATE = ILRSST(IRSD) 2380 ISYME = ISYEXC(ISTATE) 2381 ISTSY = ILRSST(IRSD)-ISYOFE(ISYME) 2382 IF ((ISYME.EQ.ISYM).AND.(IEX.EQ.ISTSY)) LCALC =.TRUE. 2383 END DO 2384 CALL CC_RTMPRI(WORK(KOFFM),WORK(KOFM2),EIGV,IEX,ISYM,MODELP, 2385 & LCALC,LDIP,LUOSC,WORK(KSTREN),NWRL) 2386 2387 END DO 2388 2389 IF (.NOT.((ISYM .EQ. NSYM).OR.(NCCEXCI(ISYM,1).EQ.0))) THEN 2390 NREST = 0 2391 DO ISYM2 = ISYM+1,NSYM 2392 NREST = NREST + NCCEXCI(ISYM2,1) 2393 END DO 2394 IF (NREST.EQ.0) GOTO 9012 2395 WRITE(LUOSC,'(A)') 2396 * ' +----------------------------------------------' 2397 * //'-------------------------------+' 2398 END IF 2399 9012 CONTINUE 2400 END DO 2401 2402 WRITE(LUOSC,'(A)') 2403 * ' +==============================================' 2404 * //'===============================+' 2405 2406 CALL DAXPY(LRML,1.0D0,WORK(KRQL2),1,WORK(KRML2),1) ! Get total tensor (in KRML2) 2407 2408 WRITE(LUOSC,'(//A)') 2409 * ' +==============================================' 2410 * //'===============================+' 2411 WRITE(LUOSC,'(1X,A26,A10,A)') 2412 * '| sym. | Exci. | ',MODELP,' Length Gauge Rot.' 2413 * //'Str. Tensor, Total |' 2414 WRITE(LUOSC,'(A)') 2415 * ' |(spin, | +-----------------------------' 2416 * //'-------------------------------+' 2417 WRITE(LUOSC,'(1X,A)') 2418 * '| spat) | | D-55 SI | D-40 cgs ' 2419 * //' | Component |' 2420 WRITE(LUOSC,'(A)') 2421 * ' +==============================================' 2422 * //'===============================+' 2423 2424 DO ISYM = 1, NSYM 2425 DO IEX = 1, NCCEXCI(ISYM,1) 2426 ISTATE = ISYOFE(ISYM) + IEX 2427 EIGV = EIGVAL(ISTATE) 2428 KOFM2 = KRML2 + 3*3*(ISTATE-1) 2429 KSTREN = KCHKL + ISTATE - 1 2430 LCALC = .FALSE. 2431 LDIP = 1 2432 DO IRSD = 1, NXLRSST 2433 ISTATE = ILRSST(IRSD) 2434 ISYME = ISYEXC(ISTATE) 2435 ISTSY = ILRSST(IRSD)-ISYOFE(ISYME) 2436 IF ((ISYME.EQ.ISYM).AND.(IEX.EQ.ISTSY)) LCALC =.TRUE. 2437 END DO 2438 CALL CC_RTTPRI(WORK(KOFM2),EIGV,IEX,ISYM,MODELP, 2439 & LCALC,LDIP,LUOSC,WORK(KSTREN),NWRL) 2440 2441 END DO 2442 2443 IF (.NOT.((ISYM .EQ. NSYM).OR.(NCCEXCI(ISYM,1).EQ.0))) THEN 2444 NREST = 0 2445 DO ISYM2 = ISYM+1,NSYM 2446 NREST = NREST + NCCEXCI(ISYM2,1) 2447 END DO 2448 IF (NREST.EQ.0) GOTO 9013 2449 WRITE(LUOSC,'(A)') 2450 * ' +----------------------------------------------' 2451 * //'-------------------------------+' 2452 END IF 2453 9013 CONTINUE 2454 END DO 2455 2456 WRITE(LUOSC,'(A)') 2457 * ' +==============================================' 2458 * //'===============================+' 2459 2460 IF (NWRL .NE. 0) THEN 2461 WRITE(LUOSC,'(//,1X,A,I4,A)') 2462 & '***NOTICE:',NWRL,' warnings issued for Rot. Str. Tensors.' 2463 WRITE(LUOSC,'(1X,A)') 2464 & ' Length gauge tensors are wrong!' 2465 END IF 2466 2467 END IF 2468 2469 LUOSC = LURES 2470 IF (RTNVEL .AND. (CCS.OR.CC2.OR.CCSD)) THEN 2471 2472 WRITE(LUOSC,'(//A)') 2473 * ' +==============================================' 2474 * //'===============================+' 2475 WRITE(LUOSC,'(1X,A26,A10,A)') 2476 * '| sym. | Exci. | ',MODELP,' Velocity Gauge Rot.' 2477 * //'Str. Tensor, El. Quad.|' 2478 WRITE(LUOSC,'(A)') 2479 * ' |(spin, | +-----------------------------' 2480 * //'-------------------------------+' 2481 WRITE(LUOSC,'(1X,A)') 2482 * '| spat) | | D-55 SI | D-40 cgs ' 2483 * //' | Component |' 2484 WRITE(LUOSC,'(A)') 2485 * ' +==============================================' 2486 * //'===============================+' 2487 2488 DO ISYM = 1, NSYM 2489 DO IEX = 1, NCCEXCI(ISYM,1) 2490 ISTATE = ISYOFE(ISYM) + IEX 2491 EIGV = EIGVAL(ISTATE) 2492 KOFFQ = KRQV + 3*9*(ISTATE-1) 2493 KOFQ2 = KRQV2 + 3*3*(ISTATE-1) 2494 LCALC = .FALSE. 2495 LDIP = 2 2496 DO IRSD = 1, NXLRSST 2497 ISTATE = ILRSST(IRSD) 2498 ISYME = ISYEXC(ISTATE) 2499 ISTSY = ILRSST(IRSD)-ISYOFE(ISYME) 2500 IF ((ISYME.EQ.ISYM).AND.(IEX.EQ.ISTSY)) LCALC =.TRUE. 2501 END DO 2502 CALL CC_RTQPRI(WORK(KOFFQ),WORK(KOFQ2),EIGV,IEX,ISYM,MODELP, 2503 & LCALC,LDIP,LUOSC,NWRV) 2504 2505 END DO 2506 2507 IF (.NOT.((ISYM .EQ. NSYM).OR.(NCCEXCI(ISYM,1).EQ.0))) THEN 2508 NREST = 0 2509 DO ISYM2 = ISYM+1,NSYM 2510 NREST = NREST + NCCEXCI(ISYM2,1) 2511 END DO 2512 IF (NREST.EQ.0) GOTO 9014 2513 WRITE(LUOSC,'(A)') 2514 * ' +----------------------------------------------' 2515 * //'-------------------------------+' 2516 END IF 2517 9014 CONTINUE 2518 END DO 2519 2520 WRITE(LUOSC,'(A)') 2521 * ' +==============================================' 2522 * //'===============================+' 2523 2524 WRITE(LUOSC,'(//A)') 2525 * ' +==============================================' 2526 * //'===============================+' 2527 WRITE(LUOSC,'(1X,A26,A10,A)') 2528 * '| sym. | Exci. | ',MODELP,' Velocity Gauge Rot.' 2529 * //'Str. Tensor, Mag. Dip.|' 2530 WRITE(LUOSC,'(A)') 2531 * ' |(spin, | +-----------------------------' 2532 * //'-------------------------------+' 2533 WRITE(LUOSC,'(1X,A)') 2534 * '| spat) | | D-55 SI | D-40 cgs ' 2535 * //' | Component |' 2536 WRITE(LUOSC,'(A)') 2537 * ' +==============================================' 2538 * //'===============================+' 2539 2540 DO ISYM = 1, NSYM 2541 DO IEX = 1, NCCEXCI(ISYM,1) 2542 ISTATE = ISYOFE(ISYM) + IEX 2543 EIGV = EIGVAL(ISTATE) 2544 KOFFM = KRMV + 3*3*(ISTATE-1) 2545 KOFM2 = KRMV2 + 3*3*(ISTATE-1) 2546 KSTREN = KCHKV + ISTATE - 1 2547 LCALC = .FALSE. 2548 LDIP = 2 2549 DO IRSD = 1, NXLRSST 2550 ISTATE = ILRSST(IRSD) 2551 ISYME = ISYEXC(ISTATE) 2552 ISTSY = ILRSST(IRSD)-ISYOFE(ISYME) 2553 IF ((ISYME.EQ.ISYM).AND.(IEX.EQ.ISTSY)) LCALC =.TRUE. 2554 END DO 2555 CALL CC_RTMPRI(WORK(KOFFM),WORK(KOFM2),EIGV,IEX,ISYM,MODELP, 2556 & LCALC,LDIP,LUOSC,WORK(KSTREN),NWRV) 2557 2558 END DO 2559 2560 IF (.NOT.((ISYM .EQ. NSYM).OR.(NCCEXCI(ISYM,1).EQ.0))) THEN 2561 NREST = 0 2562 DO ISYM2 = ISYM+1,NSYM 2563 NREST = NREST + NCCEXCI(ISYM2,1) 2564 END DO 2565 IF (NREST.EQ.0) GOTO 9015 2566 WRITE(LUOSC,'(A)') 2567 * ' +----------------------------------------------' 2568 * //'-------------------------------+' 2569 END IF 2570 9015 CONTINUE 2571 END DO 2572 2573 WRITE(LUOSC,'(A)') 2574 * ' +==============================================' 2575 * //'===============================+' 2576 2577 CALL DAXPY(LRMV,1.0D0,WORK(KRQV2),1,WORK(KRMV2),1) ! Get total tensor (in KRMV2) 2578 2579 WRITE(LUOSC,'(//A)') 2580 * ' +==============================================' 2581 * //'===============================+' 2582 WRITE(LUOSC,'(1X,A26,A10,A)') 2583 * '| sym. | Exci. | ',MODELP,' Velocity Gauge Rot.' 2584 * //'Str. Tensor, Total |' 2585 WRITE(LUOSC,'(A)') 2586 * ' |(spin, | +-----------------------------' 2587 * //'-------------------------------+' 2588 WRITE(LUOSC,'(1X,A)') 2589 * '| spat) | | D-55 SI | D-40 cgs ' 2590 * //' | Component |' 2591 WRITE(LUOSC,'(A)') 2592 * ' +==============================================' 2593 * //'===============================+' 2594 2595 DO ISYM = 1, NSYM 2596 DO IEX = 1, NCCEXCI(ISYM,1) 2597 ISTATE = ISYOFE(ISYM) + IEX 2598 EIGV = EIGVAL(ISTATE) 2599 KOFM2 = KRMV2 + 3*3*(ISTATE-1) 2600 KSTREN = KCHKV + ISTATE - 1 2601 LCALC = .FALSE. 2602 LDIP = 2 2603 DO IRSD = 1, NXLRSST 2604 ISTATE = ILRSST(IRSD) 2605 ISYME = ISYEXC(ISTATE) 2606 ISTSY = ILRSST(IRSD)-ISYOFE(ISYME) 2607 IF ((ISYME.EQ.ISYM).AND.(IEX.EQ.ISTSY)) LCALC =.TRUE. 2608 END DO 2609 CALL CC_RTTPRI(WORK(KOFM2),EIGV,IEX,ISYM,MODELP, 2610 & LCALC,LDIP,LUOSC,WORK(KSTREN),NWRV) 2611 2612 END DO 2613 2614 IF (.NOT.((ISYM .EQ. NSYM).OR.(NCCEXCI(ISYM,1).EQ.0))) THEN 2615 NREST = 0 2616 DO ISYM2 = ISYM+1,NSYM 2617 NREST = NREST + NCCEXCI(ISYM2,1) 2618 END DO 2619 IF (NREST.EQ.0) GOTO 9016 2620 WRITE(LUOSC,'(A)') 2621 * ' +----------------------------------------------' 2622 * //'-------------------------------+' 2623 END IF 2624 9016 CONTINUE 2625 END DO 2626 2627 WRITE(LUOSC,'(A)') 2628 * ' +==============================================' 2629 * //'===============================+' 2630 2631 IF (NWRV .NE. 0) THEN 2632 WRITE(LUOSC,'(//,1X,A,I4,A)') 2633 & '***NOTICE:',NWRV,' warnings issued for Rot. Str. Tensors.' 2634 WRITE(LUOSC,'(1X,A)') 2635 & ' Velocity gauge tensors are wrong!' 2636 END IF 2637 2638 END IF 2639 2640 LUOSC = LURES 2641 IF (ROTLEN .OR. ROTVEL .OR. RTNLEN .OR. RTNVEL) THEN 2642 WRITE(LUOSC,'(/,1X,A)') 2643 & 'Conversion factors for rotatory strengths:' 2644 WRITE(LUOSC,'(3X,A,F15.10,A)') 2645 & 'SI units: 1 a.u. = ',RAUSI,'D-55 A^2 m^3 s' 2646 WRITE(LUOSC,'(3X,A,F15.10,A)') 2647 & 'cgs units: 1 a.u. = ',RAUCGS,'D-40 cm^5 g s^-2' 2648 END IF 2649C 2650 TIMTOT = SECOND() - TIMTOT 2651 WRITE(LUPRI,'(/,1X,A,I5,A,F10.2,A)') 2652 & ' Time for',NTOT,' linear response residues: ', 2653 & TIMTOT,' seconds.' 2654 CALL FLSHFO(LUPRI) 2655C 2656 RETURN 2657 END 2658c*DECK CC_LRSD 2659 SUBROUTINE CC_LRSD(LABELA,ISYMA, 2660 * LABELB,ISYMB, 2661 * ISTATE,RES1,RES2,WORK,LWORK) 2662C 2663C------------------------------------------------------------------------ 2664C 2665C Purpose: Calculate etaA*tB contribution to second order properties. 2666C 2667C 2668C Written by Ove Christiansen 21-6-1996 2669C New version november 1996. 2670C 2671C------------------------------------------------------------------------ 2672C 2673#include "implicit.h" 2674#include "priunit.h" 2675#include "maxorb.h" 2676#include "ccorb.h" 2677#include "iratdef.h" 2678#include "cclr.h" 2679#include "ccsdsym.h" 2680#include "ccsdio.h" 2681#include "ccsdinp.h" 2682#include "ccexci.h" 2683#include "cclres.h" 2684#include "dummy.h" 2685C 2686 PARAMETER( TWO = 2.0D00,TOLFRQ=1.0D-08 ) 2687 2688 DIMENSION WORK(LWORK) 2689 CHARACTER LABELA*8,LABELB*8,MODEL*10 2690C 2691 IF ( IPRINT .GT. 10 ) THEN 2692 CALL AROUND( 'IN CC_LRSD: Calculating residues ') 2693 ENDIF 2694C 2695C------------------------ 2696C Allocate workspace. 2697C------------------------ 2698C 2699 IF (ISYMA .NE. ISYMB ) CALL QUIT('Symmetry mismatch in CC_EATB') 2700 NTAMPB = NT1AM(ISYMB) + NT2AM(ISYMB) 2701 IF ( CCS ) NTAMPB = NT1AM(ISYMB) 2702 NTAMPA = NT1AM(ISYMA) + NT2AM(ISYMA) 2703 IF ( CCS ) NTAMPA = NT1AM(ISYMA) 2704C 2705 KETA = 1 2706 KEND1 = KETA + NTAMPA 2707 LEND1 = LWORK - KEND1 2708C 2709 KKSI = KETA 2710C 2711 KR1 = KEND1 2712 KEND2 = KR1 + NTAMPB 2713 LEND2 = LWORK - KEND2 2714C 2715 IF (LEND2 .LT. 0) 2716 * CALL QUIT('Insufficient space for allocation in CC_EATB') 2717C 2718C--------------------------------------------- 2719C Calculate first contribution to residue. 2720C--------------------------------------------- 2721C 2722 CALL CC_ETAC(ISYMA,LABELA,WORK(KETA),'L0',1,0, 2723 * DUMMY,WORK(KEND1),LEND1) 2724C 2725 KR11 = KR1 2726 KR12 = KR1 + NT1AM(ISYMB) 2727 IOPT = 3 2728 CALL CC_RDRSP('RE',ISTATE,ISYMA,IOPT,MODEL,WORK(KR11), 2729 * WORK(KR12)) 2730C 2731 EATBCN = DDOT(NTAMPA,WORK(KETA),1,WORK(KR1),1) 2732C 2733 IF ( IPRINT .GT. 9 ) THEN 2734 WRITE(LUPRI,*) ' Singles contribution:', 2735 * DDOT(NT1AM(ISYMA),WORK(KETA),1,WORK(KR1),1) 2736 IF (.NOT. CCS) WRITE(LUPRI,*) ' Doubles contribution:', 2737 * DDOT(NT2AM(ISYMA),WORK(KETA+NT1AM(ISYMA)),1, 2738 * WORK(KR1+NT1AM(ISYMA)),1) 2739 ENDIF 2740C 2741C------------------------------------ 2742C Add to response function array. 2743C------------------------------------ 2744C 2745 IF (IPRINT .GT. 2 ) THEN 2746 WRITE(LUPRI,'(1X,A1,A8,A3,A,F10.6)') 2747 * '<',LABELA,'|f>',' EtaA*RE cont. = ',EATBCN 2748 ENDIF 2749 RES1 = EATBCN + RES1 2750C 2751C------------------------------------- 2752C Calculate F-matrix contribution. 2753C------------------------------------- 2754C 2755 IF ((.NOT. CIS).AND.(.NOT.LRS2N1)) THEN 2756 IOPT = 3 2757 KF11 = KETA 2758 KF12 = KETA + NT1AM(ISYMA) 2759 ILSTNR = IR1TAMP(LABELA,.FALSE.,-EIGVAL(ISTATE),ISYMA) 2760 CALL CC_RDRSP('F1',ILSTNR,ISYMB,IOPT,MODEL,WORK(KF11), 2761 * WORK(KF12)) 2762 IF (IPRINT .GT. 40 ) THEN 2763 CALL AROUND( 'In CC_LRSD: F-transformed resp. vector ' ) 2764 CALL CC_PRP(WORK(KF11),WORK(KF12),ISYMB,1,1) 2765 ENDIF 2766 ENDIF 2767 IF ((.NOT. CIS).AND.LRS2N1) THEN 2768 CALL CC_XKSI(WORK(KETA),LABELA,ISYMA,0,DUMMY,WORK(KEND1),LEND1) 2769 ILSTNR = ILRMAMP(ISTATE,EIGVAL(ISTATE),ISYMA) 2770 CALL CC_RDRSP('M1',ILSTNR,ISYMA,IOPT,MODEL,WORK(KR11), 2771 * WORK(KR12)) 2772 ENDIF 2773C 2774 EATBCN = DDOT(NTAMPA,WORK(KETA),1,WORK(KR1),1) 2775C 2776 IF ( IPRINT .GT. 9 ) THEN 2777 WRITE(LUPRI,*) ' Singles contribution:', 2778 * DDOT(NT1AM(ISYMA),WORK(KETA),1,WORK(KR1),1) 2779 IF (.NOT. CCS) WRITE(LUPRI,*) ' Doubles contribution:', 2780 * DDOT(NT2AM(ISYMA),WORK(KETA+NT1AM(ISYMA)),1, 2781 * WORK(KR1+NT1AM(ISYMA)),1) 2782 ENDIF 2783C 2784C------------------------------------ 2785C Add to response function array. 2786C------------------------------------ 2787C 2788 IF ((IPRINT.GT.2).AND.(.NOT. CIS)) THEN 2789 IF (.NOT.LRS2N1) THEN 2790 WRITE(LUPRI,'(1X,A1,A8,A3,A,F10.6)') 2791 * '<',LABELA,'|f>',' F*taA*RE cont. = ',EATBCN 2792 ELSE 2793 WRITE(LUPRI,'(1X,A1,A8,A3,A,F10.6)') 2794 * '<',LABELA,'|f>',' Mf*KsiA cont. = ',EATBCN 2795 ENDIF 2796 ENDIF 2797C 2798 IF (.NOT.CIS) RES1 = EATBCN + RES1 2799C 2800C--------------------------------------------- 2801C Calculate second contribution to residue. 2802C--------------------------------------------- 2803C 2804 CALL CC_XKSI(WORK(KETA),LABELB,ISYMB,0,DUMMY,WORK(KEND1),LEND1) 2805C 2806 KR11 = KR1 2807 KR12 = KR1 + NT1AM(ISYMB) 2808 2809 CALL CC_RDRSP('LE',ISTATE,ISYMB,IOPT,MODEL,WORK(KR11), 2810 * WORK(KR12)) 2811 IF (IPRINT .GT. 40 ) THEN 2812 CALL AROUND( 'In CC_LRSD: Left Eigen vector ' ) 2813 CALL CC_PRP(WORK(KR1),WORK(KR1+NT1AM(ISYMB)),ISYMB,1,1) 2814 ENDIF 2815C 2816 EATBCN = DDOT(NTAMPA,WORK(KETA),1,WORK(KR1),1) 2817C 2818 IF ( IPRINT .GT. 9 ) THEN 2819 WRITE(LUPRI,*) ' Singles contribution:', 2820 * DDOT(NT1AM(ISYMA),WORK(KETA),1,WORK(KR1),1) 2821 IF (.NOT. CCS) WRITE(LUPRI,*) ' Doubles contribution:', 2822 * DDOT(NT2AM(ISYMA),WORK(KETA+NT1AM(ISYMA)),1, 2823 * WORK(KR1+NT1AM(ISYMA)),1) 2824 ENDIF 2825C 2826C------------------------------------ 2827C Add to response function array. 2828C------------------------------------ 2829C 2830 IF (IPRINT .GT. 2 ) THEN 2831 WRITE(LUPRI,'(1X,A3,A8,A1,A,F10.6)') 2832 * '<f|',LABELB,'>',' LE*XksiB cont. = ',EATBCN 2833 ENDIF 2834 RES2 = EATBCN + RES2 2835C 2836 RETURN 2837 END 2838c*DECK CC_OSCPRI 2839 SUBROUTINE CC_OSCPRI(TRS,OSC,EIGV,IEX,ISYM,WORK,LWORK,MODEL,LCALC, 2840 * LDIP,LUOSC) 2841C 2842C------------------------------------------------------------------------ 2843C 2844C Purpose: Calculate LD*ksiC contribution to second order properties. 2845C For use in calculation of molecular properties from 2846C Asymmetric formulaes not in accordance with 2n+2 rule for 2847C the multipliers, left vector, t-bar, lamdas, zeta or 2848C whatever your preferred choice is today. 2849C 2850C Written by Ove Christiansen 17-10-1996/7-11-1996 2851C 2852C------------------------------------------------------------------------ 2853C 2854#include "implicit.h" 2855#include "pgroup.h" 2856#include "priunit.h" 2857#include "dummy.h" 2858#include "maxorb.h" 2859 PARAMETER (TOLFRQ = 1.0D-08,ONE= 1.0D0,THR = 1.0D-08) 2860C 2861#include "iratdef.h" 2862#include "cclr.h" 2863#include "ccorb.h" 2864#include "ccsdsym.h" 2865#include "ccsdio.h" 2866#include "ccsdinp.h" 2867C 2868 DIMENSION OSC(*),PVAL(3),PAXIS(3,3) 2869 CHARACTER MODEL*10,CDIP*7 2870 LOGICAL LCALC 2871C 2872 IF ( IPRINT .GT. 10 ) THEN 2873 CALL AROUND( 'IN CC_OSCPRI: Output transition properties ' ) 2874 ENDIF 2875C 2876C------------------------------------------ 2877C write out transition strength matrix. 2878C------------------------------------------ 2879C 2880 2881 IMULT = 1 ! force singlet spin symmetry... 2882 2883 IF (LCALC) THEN 2884C 2885 WRITE(LUPRI,'(//,1X,A6,A,I3,A,I2,/,A7,A,F11.8,/)') MODEL(1:6), 2886 * 'Transition strength matrix for state nr.',IEX, 2887 * ' of symmetry',ISYM,MODEL(1:6),'excitation energy:',EIGV 2888 IF (LDIP .EQ. 1) THEN 2889 WRITE(LUPRI,'(1X,A)') 'Gauge: length' 2890 ELSE IF (LDIP .EQ. 2) THEN 2891 WRITE(LUPRI,'(1X,A)') 'Gauge: velocity' 2892 ELSE IF (LDIP .EQ. 3) THEN 2893 WRITE(LUPRI,'(1X,A)') 'Gauge: mixed length/velocity' 2894 ELSE 2895 WRITE(LUPRI,'(1X,A)') 'Gauge: UNKNOWN' 2896 WRITE(LUPRI,'(1X,A)') '- scaling factors will be incorrect!' 2897 ENDIF 2898 CALL OUTPUT(TRS,1,3,1,3,3,3,1,LUPRI) 2899C 2900 CALL TNSRAN(TRS,PVAL,PAXIS, 2901 * ALFSQ,BETSQ,ITST,ITST2, 2902 * APAR1,APEN1,XKAPPA,IPAR) 2903 WRITE(LUPRI,'(/,1X,A,/)') 2904 * 'Principal values of diagonalized transition strength matrix:' 2905 WRITE(LUPRI,'(1X,A)') ' a.u. ' 2906 WRITE(LUPRI,'(1X,A,F16.8)') '1 ',PVAL(1) 2907 WRITE(LUPRI,'(1X,A,F16.8)') '2 ',PVAL(2) 2908 WRITE(LUPRI,'(1X,A,F16.8)') '3 ',PVAL(3) 2909 WRITE(LUPRI,'(/,1X,A,/)') 2910 * 'Principal axis of diagonalized transition strength matrix:' 2911 CALL OUTPUT(PAXIS,1,3,1,3,3,3,1,LUPRI) 2912 TRA = PVAL(1)+PVAL(2)+PVAL(3) 2913C 2914C------------------------------------------ 2915C First scale it - then 2916C write out oscillator strength matrix. 2917C------------------------------------------ 2918C 2919 IF (LDIP .EQ. 1) THEN 2920 FACT = EIGV*2.0D0/3.0D0 2921 ELSE IF (LDIP .EQ. 2) THEN 2922 FACT = -2.0D0/(3.0D0*EIGV) 2923 ELSE IF (LDIP .EQ. 3) THEN 2924 FACT = -2.0D0/3.0D0 2925 ELSE 2926 FACT = 1.0D0 2927 ENDIF 2928 CALL DSCAL(3*3,FACT,OSC,1) 2929 WRITE(LUPRI,'(//,1X,A6,A,I3,A,I2,/,A7,A,F11.8,/)') MODEL(1:6), 2930 * ' oscillator strength matrix for state nr.',IEX, 2931 * ' of symmetry',ISYM,MODEL(1:6),'excitation energy:',EIGV 2932 CALL OUTPUT(OSC,1,3,1,3,3,3,1,LUPRI) 2933 CALL TNSRAN(OSC,PVAL,PAXIS, 2934 * ALFSQ,BETSQ,ITST,ITST2, 2935 * APAR2,APEN2,XKAPPA,IPAR) 2936 WRITE(LUPRI,'(/,1X,A,/)') 2937 * 'Principal values of diagonalized oscillator strength matrix:' 2938 WRITE(LUPRI,'(1X,A)') ' a.u. ' 2939 WRITE(LUPRI,'(1X,A,F12.8)') '1 ',PVAL(1) 2940 WRITE(LUPRI,'(1X,A,F12.8)') '2 ',PVAL(2) 2941 WRITE(LUPRI,'(1X,A,F12.8)') '3 ',PVAL(3) 2942 WRITE(LUPRI,'(/,1X,A,/)') 2943 * 'Principal axis of diagonalized oscillator strength matrix:' 2944 CALL OUTPUT(PAXIS,1,3,1,3,3,3,1,LUPRI) 2945 OSCS = PVAL(1)+PVAL(2)+PVAL(3) 2946 2947 CALL WRIPRO(OSCS,MODEL,400, 2948 & "OSCI-LEN","OSCI-LEN","OSCI-LEN","OSCI-LEN", 2949 & EIGV,EIGV,EIGV,ISYM,ISYM,1,IEX) 2950 2951 CDIP = 'unknown' 2952 IF (IPAR .EQ.1) CDIP = ' X ' 2953 IF (IPAR .EQ.2) CDIP = ' Y ' 2954 IF (IPAR .EQ.3) CDIP = ' Z ' 2955 IF (IPAR .EQ.4) CDIP = ' (X,Y) ' 2956 IF (IPAR .EQ.5) CDIP = ' (X,Z) ' 2957 IF (IPAR .EQ.6) CDIP = ' (Y,Z) ' 2958 IF (IPAR .EQ.7) CDIP = '(X,Y,Z)' 2959 IF (IPAR .EQ.8) CDIP = ' - ' 2960c 2961c IF ( IEX .EQ. 1) THEN 2962C IMULT = 1 is hardwired in since for linear response residues 2963C only singlet states have a non-vanishing oscillator strength anyway 2964 WRITE(LUOSC,9988) IMULT,REP(ISYM-1),IEX,TRA,OSCS,CDIP 2965c ELSE 2966c WRITE(LUOSC,9989) IEX,TRA,OSCS,CDIP 2967c ENDIF 2968C 2969 ELSE IF (.NOT.LCALC) THEN 2970 CDIP = ' ? ' 2971c IF ( IEX .EQ. 1) THEN 2972 WRITE(LUOSC,9986) IMULT,REP(ISYM-1),IEX,'Not calculated', 2973 * 'Not calculated',CDIP 2974c ELSE 2975c WRITE(LUOSC,9987) IEX,'Not calculated','Not calculated',CDIP 2976c ENDIF 2977 ENDIF 2978C 2979 9986 FORMAT(1X,'| ^',I1,A3,' | ',I4,' | ',A16,4X, 2980 * ' |',A15,5X,' | ',A7,' ',1X,' |') 2981 9987 FORMAT(1X,'| | ',I4,' | ',A16,4X, 2982 * ' |',A15,5X,' | ',A7,' ',1X,' |') 2983 9988 FORMAT(1X,'| ^',I1,A3,' | ',I4,' | ',F16.7,4X, 2984 * ' |',F15.7,5X,' | ',A7,' ',1X,' |') 2985 9989 FORMAT(1X,'| | ',I4,' | ',F16.7,4X, 2986 * ' |',F15.7,5X,' | ',A7,' ',1X,' |') 2987C 2988 END 2989 SUBROUTINE CC_TSTAV(ILSTNR,VEC,WORK,LWORK,IOPTTST) 2990C 2991C---------------------------------------------------------------------- 2992C 2993C Purpose: Calculate first order property from first order response 2994C vectors to test these. 2995C NOT MEANT to advocate this way of calculating 2996C expectation values. 2997C 2998C Written by Ove Christiansen 10-5-1996 / 2.0: 13-3-1997 2999C 3000C---------------------------------------------------------------------- 3001C 3002#include "implicit.h" 3003#include "priunit.h" 3004#include "maxorb.h" 3005#include "iratdef.h" 3006C 3007 LOGICAL LOCDBG 3008 PARAMETER( LOCDBG = .FALSE. ) 3009 PARAMETER( TWO = 2.0D00,XHALF = 0.5D00 ) 3010 DIMENSION WORK(LWORK),VEC(*) 3011 CHARACTER*10 MODEL 3012C 3013#include "ccorb.h" 3014#include "cclr.h" 3015#include "ccsdsym.h" 3016#include "ccsdio.h" 3017#include "ccsdinp.h" 3018#include "ccroper.h" 3019#include "ccr1rsp.h" 3020#include "ccx1rsp.h" 3021#include "leinf.h" 3022C 3023C------------------------------------------------------------- 3024C Calculate response contribution to expectation value. 3025C------------------------------------------------------------- 3026C 3027 IF (.NOT.CCS) THEN 3028 NVAR = NT1AM(ISYMOP) + NT2AM(ISYMOP) 3029 IF (CCR12) THEN 3030 NVAR = NVAR + NTR12AM(ISYMOP) 3031 ENDIF 3032 KETA = 1 3033 KWRK1 = KETA + NVAR 3034 LWRK1 = LWORK - KWRK1 3035 IF (LWRK1 .LT. 0 ) 3036 & CALL QUIT('Too little workspace in CC_TSTAV-1') 3037 IF (IOPTTST.EQ.0) THEN 3038 CALL CC_ETA(WORK(KETA),WORK(KWRK1),LWRK1) 3039 ELSE IF (IOPTTST.EQ.1) THEN 3040 IOPT = 3 3041 CALL CC_RDRSP('L0 ',0,ISYMOP,IOPT,MODEL,WORK(KETA), 3042 * WORK(KETA+NT1AM(ISYMOP))) 3043 IF (CCR12) THEN 3044 IOPT = 32 3045 CALL CC_RDRSP('L0 ',0,ISYMOP,IOPT,MODEL,DUMMY, 3046 * WORK(KETA+NT1AM(ISYMOP)+NT2AM(ISYMOP))) 3047 ENDIF 3048 ELSE 3049 WRITE(LUPRI,*) 'IOPTTST = ',IOPTTST 3050 CALL QUIT('ILLEGAL VALUE FOR IOPTTST IN CC_TSTAV.') 3051 END IF 3052 PROPRSP = DDOT(NVAR,WORK(KETA),1,VEC,1) 3053 3054 IF (LOCDBG) THEN 3055 write(lupri,*) 'Input vector:' 3056 call cc_prp(vec,vec(nt1am(isymop)+1),isymop,1,1) 3057 if (CCR12) call cc_prpr12(vec(1+nt1am(isymop)+nt2am(isymop)), 3058 * isymop,1,.true.) 3059 write(lupri,*) 'L0/X0 vector:' 3060 call cc_prp(work(keta),work(keta+nt1am(isymop)),isymop,1,1) 3061 if (CCR12) call cc_prpr12(work(keta+nt1am(isymop)+ 3062 * nt2am(isymop)),isymop,1,.true.) 3063 write(lupri,*) 'PROPRSP:',PROPRSP 3064 END IF 3065 ELSE 3066 PROPRSP = 0.0D0 3067 KWRK1 = 1 3068 LWRK1 = LWORK 3069 ENDIF 3070C 3071C------------------------------------------ 3072C Calculate average value contribution. 3073C------------------------------------------ 3074C 3075 ! find operator index 3076 ISYM = 1 3077 IOPER = IROPER(LRTLBL(ILSTNR),ISYM) 3078C 3079 IF ( LORXLRT(ILSTNR) .OR. LPDBSOP(IOPER) ) THEN 3080 ! if the orbitals are allowed to relax in the field or if the 3081 ! basis set depends on the perturbation, read the average 3082 ! value contribution from the ccx1rsp.h common blocks 3083 ILSTETA = IETA1(LRTLBL(ILSTNR),LORXLRT(ILSTNR), 3084 & FRQLRT(ILSTNR),ISYM) 3085 PROPAVE = AVEX1(ILSTETA) 3086 ELSE 3087 ! if it is a simple unrelaxed one-electron perturbation 3088 ! calculate the average value contribution in CC_AVE 3089 FF = 1.0D00 3090 CALL CC_AVE(PROPAVE,LRTLBL(ILSTNR),WORK(KWRK1),LWRK1,FF) 3091 END IF 3092C 3093 WRITE(LUPRI,'(1X,A,A)') 'Operator: : ',LRTLBL(ILSTNR) 3094 WRITE(LUPRI,'(1X,A,F16.10)') 'Average contribution: ', 3095 * PROPAVE 3096 WRITE(LUPRI,'(1X,A,F16.10)') 'Response contribution: ', 3097 * PROPRSP 3098 WRITE(LUPRI,'(1X,A,F16.10)') 'Total expectation value:', 3099 * PROPAVE + PROPRSP 3100C 3101 CALL FLSHFO(LUPRI) 3102 END 3103 SUBROUTINE CC_AVE(XVALUE,LBL,WORK,LWORK,FF) 3104C 3105C----------------------------------------------------------------------- 3106C 3107C Purpose: Calculate <HF|C|CC> contribution to first order property. 3108C C is assumed to be a one-electron operator. 3109C 3110C Written by Ove Christiansen 10-5-1996 3111C 3112C Bug-Fix for frozen-core calculations: Chr. Neiss 22-04-2005 3113C 3114C----------------------------------------------------------------------- 3115C 3116#include "implicit.h" 3117#include "priunit.h" 3118#include "dummy.h" 3119#include "maxorb.h" 3120#include "iratdef.h" 3121C 3122 CHARACTER LBL*(*), MODEL*10 3123 DIMENSION WORK(LWORK) 3124 INTEGER ICMO(8,8), NCMO(8), IGLMRHS(8,8), NGLMDS(8), IGLMVIS(8,8) 3125C 3126#include "ccorb.h" 3127#include "cclr.h" 3128#include "ccsdsym.h" 3129#include "ccsdio.h" 3130#include "ccsdinp.h" 3131#include "leinf.h" 3132C 3133 IF ( IPRINT .GT. 10 ) THEN 3134 CALL AROUND( 'IN CC_AVE ') 3135 ENDIF 3136C 3137 DO ISYM = 1, NSYM 3138 ICOUNT = 0 3139 ICOUNT2 = 0 3140 ICOUNT3 = 0 3141 DO ISYM2 = 1, NSYM 3142 ISYM1 = MULD2H(ISYM,ISYM2) 3143 ICMO(ISYM1,ISYM2) = ICOUNT 3144 IGLMRHS(ISYM1,ISYM2) = ICOUNT2 3145 ICOUNT = ICOUNT + NBAS(ISYM1)*NORBS(ISYM2) 3146 ICOUNT2 = ICOUNT2 + NBAS(ISYM1)*NRHFS(ISYM2) 3147 ICOUNT3 = ICOUNT3 + NBAS(ISYM1)*NRHFS(ISYM2) 3148 END DO 3149 NCMO(ISYM) = ICOUNT 3150 NGLMDS(ISYM) = ICOUNT2 3151 DO ISYM2 = 1, NSYM 3152 ISYM1 = MULD2H(ISYM,ISYM2) 3153 IGLMVIS(ISYM1,ISYM2) = ICOUNT3 3154 ICOUNT3 = ICOUNT3 + NBAS(ISYM1)*NVIRS(ISYM2) 3155 END DO 3156 END DO 3157C 3158 KONEP = 1 3159 KT1AM = KONEP + N2BST(ISYMOP) 3160 KLAMDPS= KT1AM + NT1AMX 3161 KLAMDHS= KLAMDPS+ NGLMDS(1) 3162 KEND1 = KLAMDHS+ NGLMDS(1) 3163 LWRK1 = LWORK - KEND1 3164 IF ( LWRK1 .LT. 0 ) 3165 * CALL QUIT(' Too little workspace in CC_AVE') 3166C 3167 CALL DZERO(WORK(KONEP),N2BST(ISYMOP)) 3168 CALL CC_ONEP(WORK(KONEP),WORK(KEND1),LWRK1,FF,1,LBL) 3169C 3170 IF (.NOT.CCS) THEN 3171 IOPT = 1 3172 CALL CC_RDRSP('R0 ',0,1,IOPT,MODEL,WORK(KT1AM),DUMMY) 3173 ELSE IF (CCS ) THEN 3174 CALL DZERO(WORK(KT1AM),NT1AMX) 3175 ENDIF 3176C 3177 CALL LAMMATS(WORK(KLAMDPS),WORK(KLAMDHS),WORK(KT1AM),ISYMOP, 3178 * .FALSE.,.FALSE.,NGLMDS,IGLMRHS,IGLMVIS,ICMO, 3179 * WORK(KEND1),LWRK1) 3180C 3181 XVALUE = 0.0D0 3182C 3183 DO ISYM = 1, NSYM 3184 3185 KSCR1 = KEND1 3186 KEND2 = KSCR1 + NBAS(ISYM) * NRHFS(ISYM) 3187 LWRK2 = LWORK - KEND2 3188 IF ( LWRK2 .LT. 0 ) THEN 3189 WRITE (LUPRI,*) 'LWORK, LWRK2: ',WORK, LWRK2 3190 CALL QUIT('Too little workspace in CC_AVE') 3191 END IF 3192 3193 NBAS1 = MAX(NBAS(ISYM),1) 3194 KOFF1 = KONEP + IAODIS(ISYM,ISYM) 3195 KOFF2 = KLAMDHS + IGLMRHS(ISYM,ISYM) 3196 3197 CALL DGEMM('N','N',NBAS(ISYM),NRHFS(ISYM),NBAS(ISYM), 3198 * 1.0D0,WORK(KOFF1),NBAS1,WORK(KOFF2),NBAS1, 3199 * 0.0D0,WORK(KSCR1),NBAS1) 3200 3201 KOFF2 = KLAMDPS + IGLMRHS(ISYM,ISYM) 3202 3203 TRACE = DDOT(NBAS(ISYM)*NRHFS(ISYM), 3204 & WORK(KOFF2),1,WORK(KSCR1),1) 3205 XVALUE = XVALUE + 2.0D0 * TRACE 3206 END DO 3207C 3208 END 3209c*DECK CC_XKSI 3210 SUBROUTINE CC_XKSI(XKSI,LBPERT,ISYMPT,IOPTCC2,XINT,WORK,LWORK) 3211C 3212C---------------------------------------------------------------------- 3213C 3214C Purpose: Calculate XKSI vector. 3215C 3216C IOPTCC2 = 1 -- use for CC2 the CMO vector instead of the lambda 3217C matrices to transform the Fock mat. in the E-term 3218C 3219C SLV98,OC: Allow for input of integrals if 3220C LBPERT.eq.'GIVE INT' 3221C 3222C Written by Ove Christiansen 16 februar 1996 3223C 3224C---------------------------------------------------------------------- 3225C 3226#include "implicit.h" 3227#include "priunit.h" 3228#include "dummy.h" 3229#include "maxorb.h" 3230#include "iratdef.h" 3231C 3232 PARAMETER( TWO = 2.0D00,XHALF = 0.5D00 ) 3233 LOGICAL FCKCON,ETRAN 3234 INTEGER IOPTCC2 3235 CHARACTER LBPERT*(*), MODEL*10 3236 DIMENSION XKSI(*),WORK(LWORK),XINT(*) 3237C 3238#include "ccorb.h" 3239#include "cclr.h" 3240#include "ccsdsym.h" 3241#include "ccsdio.h" 3242#include "ccsdinp.h" 3243#include "leinf.h" 3244C 3245 IF ( IPRINT .GT. 10 ) THEN 3246 CALL AROUND( 'IN CC_XKSI: Constructing XKSI vector ') 3247 ENDIF 3248C 3249C------------------------------------------------------------------- 3250C Read in AO property integrals and transform to T1 transformed 3251C MO basis. 3252C------------------------------------------------------------------- 3253C 3254 KFOCK = 1 3255 KT1AM = KFOCK + N2BST(ISYMPT) 3256 KLAMDP = KT1AM + NT1AM(ISYMOP) 3257 KLAMDH = KLAMDP + NLAMDT 3258 KEND1 = KLAMDH + NLAMDT 3259C 3260 IF (CC2 .AND. IOPTCC2.EQ.1) THEN 3261 KCMO = KEND1 3262 KFCKHF = KCMO + NLAMDT 3263 KEND1 = KFCKHF + N2BST(ISYMPT) 3264 END IF 3265C 3266 LEND1 = LWORK - KEND1 3267C 3268 IF ( .NOT. CCS) THEN 3269C 3270 KT2AM = KEND1 3271 KEND2 = KT2AM + NT2SQ(1) 3272 LEND2 = LWORK - KEND2 3273C 3274 KT2PK = KEND2 3275 KEND3 = KT2PK + NT2AMX 3276 LEND3 = LWORK - KEND3 3277C 3278 ELSE 3279C 3280 KEND2 = KEND1 3281 LEND2 = LEND1 3282 KEND3 = KEND1 3283 LEND3 = LEND1 3284C 3285 ENDIF 3286C 3287 IF (LEND3 .LT. 0 ) THEN 3288 WRITE(LUPRI,*) 'Requested workspace, available workspace =', 3289 * KEND3,LWORK 3290 CALL QUIT('TOO LITTLE WORKSPACE IN CC_XKSI-1') 3291 ENDIF 3292C 3293 CALL DZERO(WORK(KT1AM),NT1AM(1)) 3294C 3295 IF (.NOT.(CCS.OR.CCP2)) THEN 3296 IOPT = 3 3297 CALL CC_RDRSP('R0',0,1,IOPT,MODEL,WORK(KT1AM),WORK(KT2PK)) 3298 CALL CC_T2SQ(WORK(KT2PK),WORK(KT2AM),1) 3299 ENDIF 3300C 3301 CALL LAMMAT(WORK(KLAMDP),WORK(KLAMDH),WORK(KT1AM), 3302 * WORK(KEND2),LEND2) 3303C 3304 IF (CC2 .AND. IOPTCC2.EQ.1) THEN 3305 LUSIFC = -1 3306 CALL GPOPEN(LUSIFC,'SIRIFC','OLD',' ','UNFORMATTED', 3307 * IDUMMY,.FALSE.) 3308 REWIND(LUSIFC) 3309 CALL MOLLAB('TRCCINT ',LUSIFC,LUPRI) 3310 READ(LUSIFC) 3311 READ(LUSIFC) 3312 READ(LUSIFC) (WORK(KCMO+I-1),I=1,NLAMDS) 3313 CALL GPCLOSE(LUSIFC,'KEEP') 3314 CALL CMO_REORDER(WORK(KCMO),WORK(KEND2),LEND2) 3315 END IF 3316C 3317 CALL DZERO(WORK(KFOCK),N2BST(ISYMPT)) 3318C 3319C SLV98,OC if option for solvent 3320C 3321 IF (LBPERT.EQ.'GIVE INT') THEN 3322 CALL DCOPY(N2BST(ISYMPT),XINT,1,WORK(KFOCK),1) 3323 ELSE 3324 FF = 1.0D0 3325 CALL CC_ONEP(WORK(KFOCK),WORK(KEND2),LEND2,FF,ISYMPT,LBPERT) 3326 ENDIF 3327C 3328 IF (CC2 .AND. IOPTCC2.EQ.1) THEN 3329 CALL DCOPY(N2BST(ISYMPT),WORK(KFOCK),1,WORK(KFCKHF),1) 3330 CALL CC_FCKMO(WORK(KFCKHF),WORK(KCMO),WORK(KCMO), 3331 * WORK(KEND2),LEND2,ISYMPT,1,1) 3332 END IF 3333C 3334 CALL CC_FCKMO(WORK(KFOCK),WORK(KLAMDP),WORK(KLAMDH), 3335 * WORK(KEND2),LEND2,ISYMPT,1,1) 3336C 3337 IF (IPRINT .GT. 50) THEN 3338 CALL AROUND( 'In CC_XKSI: MO^(t1) property matrix' ) 3339 CALL CC_PRFCKMO(WORK(KFOCK),ISYMPT) 3340 ENDIF 3341C 3342C------------------------------ 3343C Contract into ksi vector. 3344C first zero result. 3345C------------------------------ 3346C 3347 CALL DZERO(XKSI(1),NT1AM(ISYMPT)) 3348 IF (.NOT. CCS) CALL DZERO(XKSI(1+NT1AM(ISYMPT)),NT2AM(ISYMPT)) 3349C 3350C---------------------- 3351C Calculate J-term. 3352C---------------------- 3353C 3354 CALL CCRHS_J(XKSI(1),ISYMPT,WORK(KFOCK)) 3355C 3356 IF (.NOT. CCS) THEN 3357C 3358C---------------------------------- 3359C Calculate E contributions. 3360C---------------------------------- 3361C 3362 KEI1 = KEND2 3363 KEI2 = KEI1 + NEMAT1(ISYMPT) 3364 KEND3 = KEI2 + NMATIJ(ISYMPT) 3365 LEND3 = LWORK - KEND3 3366C 3367 IF (LEND3.LT. 0 ) 3368 & CALL QUIT(' TOO LITTLE WORKSPACE IN CC_XKSI-2') 3369C 3370 FCKCON = .TRUE. 3371 ETRAN = .FALSE. 3372C 3373 IF (CC2 .AND. IOPTCC2.EQ.1) THEN 3374 CALL CCRHS_EFCK(WORK(KEI1),WORK(KEI2),WORK(KCMO), 3375 * WORK(KFCKHF),WORK(KEND3),LEND3,FCKCON, 3376 * ETRAN,ISYMPT) 3377 ELSE 3378 CALL CCRHS_EFCK(WORK(KEI1),WORK(KEI2),WORK(KLAMDH), 3379 * WORK(KFOCK),WORK(KEND3),LEND3,FCKCON, 3380 * ETRAN,ISYMPT) 3381 END IF 3382C 3383 CALL CCRHS_E(XKSI(1+NT1AM(ISYMPT)),WORK(KT2AM),WORK(KEI1), 3384 * WORK(KEI2),WORK(KEND3),LEND3,ISYMOP,ISYMPT) 3385C 3386 CALL CCLR_DIASCL(XKSI(1+NT1AM(ISYMPT)),XHALF,ISYMPT) 3387C 3388C------------------------- 3389C Calculate I-term. 3390C------------------------- 3391C 3392 CALL CCRHS_T2TR(WORK(KT2AM),WORK(KEND2),LEND2,1) 3393C 3394 CALL CCRHS_I(XKSI(1),WORK(KT2AM),WORK(KFOCK), 3395 * WORK(KEND2),LEND2,ISYMOP,ISYMPT) 3396C 3397 ENDIF 3398C 3399 IF (IPRINT .GT. 40 ) THEN 3400 NC2 = 1 3401 IF ( CCS ) NC2 = 0 3402 CALL AROUND( 'In CC_XKSI: XKSI vector ' ) 3403 CALL CC_PRP(XKSI(1),XKSI(1+NT1AM(ISYMPT)),ISYMPT,1,NC2) 3404 ENDIF 3405C 3406 IF ( IPRINT .GT. 10 ) THEN 3407 XKSI1 = DDOT(NT1AM(ISYMPT),XKSI(1),1,XKSI(1),1) 3408 WRITE(LUPRI,*) 'Norm of XKSI1: ',XKSI1 3409 IF ( .NOT. CCS ) THEN 3410 XKSI2 = DDOT(NT2AM(ISYMPT),XKSI(1+NT1AM(ISYMPT)), 3411 * 1,XKSI(1+NT1AM(ISYMPT)),1) 3412 WRITE(LUPRI,*) 'Norm of XKSI2: ',XKSI2 3413 ENDIF 3414 CALL AROUND( 'END OF CC_XKSI ') 3415 ENDIF 3416C 3417 END 3418c*DECK CC_ETAC 3419 SUBROUTINE CC_ETAC(ISYMC,LBLC,ETAC,LIST,ILSTNR,IOPTCC2, 3420 * XINT,WORK,LWORK) 3421C 3422C----------------------------------------------------------------------- 3423C 3424C Purpose: Calculate ETAC vector. 3425C 3426C Important note: Requires work space of dimension of 3427C NT2AM + NT2SQ in addition to ETAC, so please take care. 3428C 3429C eta(tau,nu)= (<HF| + Sum(mu)L(0 or 1)<mu|) 3430C exp(-t)[C,tau,nu]exp(T)|HF> 3431C 3432C LIST= 'L0' for zeroth order left amplitudes. 3433C ISYML should be ISYMOP in this case. 3434C 'L1' for first order left amplitudes, read in from file 3435C In this case the vector is found according to its list 3436C number ILSTNR. 3437C 3438C For L1 HF contribution is skipped. 3439C 3440C IOPTCC2 = 1 -- transform for CC2 the Fock matrix entering the 3441C E term contribution with CMO vector instead with 3442C Lambda matrices 3443C 3444C C property integrals read according to LBLC 3445C 3446C SLV98,OC: Allow for input of integrals if 3447C LBLC.eq.'GIVE INT' 3448C 3449C 3450C Written by Ove Christiansen 20-6-1996/1-11-1996 3451C 3452C 3453C----------------------------------------------------------------------- 3454C 3455#include "implicit.h" 3456#include "priunit.h" 3457#include "dummy.h" 3458#include "maxorb.h" 3459#include "ccorb.h" 3460#include "iratdef.h" 3461#include "cclr.h" 3462#include "ccexci.h" 3463#include "ccsdsym.h" 3464#include "ccsdio.h" 3465#include "ccsdinp.h" 3466C 3467 PARAMETER( TWO = 2.0D00, XHALF = 0.5D00 ) 3468 DIMENSION ETAC(*),WORK(LWORK),XINT(*) 3469 CHARACTER LBLC*(*),LIST*(*),MODEL*10 3470 INTEGER IOPTCC2 3471 LOGICAL FCKCON,ETRAN 3472C 3473 IF ( IPRINT .GT. 10 ) THEN 3474 CALL AROUND( 'IN CC_ETAC: Constructing EtaC vector ') 3475 ENDIF 3476C 3477C-------------------------------- 3478C find symmetry of D operator. 3479C-------------------------------- 3480C 3481 ISYML = ILSTSYM(LIST,ILSTNR) 3482C 3483 ISYRES = MULD2H(ISYML,ISYMC) 3484 IF (( LIST .EQ. 'L0').AND.(ISYML.NE.1)) THEN 3485 CALL QUIT('Misuse of CC_ETAC') 3486 ENDIF 3487C 3488 TIMEC = SECOND() 3489C 3490 MODEL = 'CCSD ' 3491 IF (CCS) MODEL = 'CCS ' 3492 IF (CC2) MODEL = 'CC2 ' 3493C 3494C-------------------- 3495C Allocate space. 3496C-------------------- 3497C 3498 KCTMO = 1 3499 KT1AM = KCTMO + N2BST(ISYMC) 3500 KLAMDP = KT1AM + NT1AM(ISYMOP) 3501 KLAMDH = KLAMDP + NLAMDT 3502 KEND1 = KLAMDH + NLAMDT 3503C 3504 IF (CC2 .AND. IOPTCC2.EQ.1) THEN 3505 KCMO = KEND1 3506 KFCKHF = KCMO + NLAMDT 3507 KEND1 = KFCKHF + N2BST(ISYMC) 3508 END IF 3509C 3510 LEND1 = LWORK - KEND1 3511C 3512 IF ( .NOT. CCS) THEN 3513C 3514 KL1AM = KEND1 3515 KL2AM = KL1AM + NT1AM(ISYML) 3516 KEND2 = KL2AM + NT2SQ(ISYML) 3517 LEND2 = LWORK - KEND2 3518 KT2AM = KEND2 3519 KEND21= KT2AM + MAX(NT2AM(ISYML),NT2AM(1)) 3520 LEND21= LWORK - KEND2 3521C 3522 ELSE 3523C 3524 KL1AM = KEND1 3525 KEND2 = KL1AM + NT1AM(ISYML) 3526 LEND2 = LEND1 3527 KEND21= KEND1 3528 LEND21= LEND1 3529C 3530 ENDIF 3531C 3532 IF (LEND21.LT. 0 ) CALL QUIT(' TOO LITTLE WORKSPACE IN CC_ETAC-1') 3533C 3534C----------------------- 3535C get T1 amplitudes. 3536C----------------------- 3537C 3538 CALL DZERO(WORK(KT1AM),NT1AM(1)) 3539 IF ( .NOT. CCS) THEN 3540 IOPT = 1 3541 CALL CC_RDRSP('R0',0,1,IOPT,MODEL,WORK(KT1AM),DUMMY) 3542 ENDIF 3543C 3544 CALL LAMMAT(WORK(KLAMDP),WORK(KLAMDH),WORK(KT1AM), 3545 * WORK(KEND21),LEND21) 3546C 3547 IF (CC2 .AND. IOPTCC2.EQ.1) THEN 3548 LUSIFC = -1 3549 CALL GPOPEN(LUSIFC,'SIRIFC','OLD',' ','UNFORMATTED', 3550 * IDUMMY,.FALSE.) 3551 REWIND(LUSIFC) 3552 CALL MOLLAB('TRCCINT ',LUSIFC,LUPRI) 3553 READ(LUSIFC) 3554 READ(LUSIFC) 3555 READ(LUSIFC) (WORK(KCMO+I-1),I=1,NLAMDS) 3556 CALL GPCLOSE(LUSIFC,'KEEP') 3557 CALL CMO_REORDER(WORK(KCMO),WORK(KEND21),LEND21) 3558 END IF 3559C 3560C------------------------------- 3561C get AO property integrals. 3562C------------------------------- 3563C 3564 CALL DZERO(WORK(KCTMO),N2BST(ISYMC)) 3565 FF = 1.0D0 3566C SLV98,OC give integrals option 3567 IF (LBLC.EQ.'GIVE INT') THEN 3568 CALL DCOPY(N2BST(ISYMC),XINT(1),1,WORK(KCTMO),1) 3569 ELSE 3570 FF = 1.0D0 3571 CALL CC_ONEP(WORK(KCTMO),WORK(KEND21),LEND21,FF,ISYMC,LBLC) 3572 ENDIF 3573C 3574 IF (CC2 .AND. IOPTCC2.EQ.1) THEN 3575 CALL DCOPY(N2BST(ISYMC),WORK(KCTMO),1,WORK(KFCKHF),1) 3576 CALL CC_FCKMO(WORK(KFCKHF),WORK(KCMO),WORK(KCMO), 3577 * WORK(KEND21),LEND21,ISYMC,1,1) 3578 END IF 3579C 3580C----------------------------------------------- 3581C Make MO T1-transformed property integrals. 3582C----------------------------------------------- 3583C 3584 CALL CC_FCKMO(WORK(KCTMO),WORK(KLAMDP),WORK(KLAMDH), 3585 * WORK(KEND21),LEND21,ISYMC,1,1) 3586C 3587C---------------------------------------------- 3588C Calculate 2Cia (stored ia) Hartree-Fock contribution. 3589C---------------------------------------------- 3590C 3591 CALL DZERO(ETAC,NT1AM(ISYRES)) 3592C 3593 IF (LIST .EQ. 'L0') THEN 3594 DO 100 ISYMI = 1,NSYM 3595C 3596 ISYMA = MULD2H(ISYMI,ISYMC) 3597C 3598 DO 110 A = 1,NVIR(ISYMA) 3599C 3600 DO 120 I = 1,NRHF(ISYMI) 3601C 3602 KOFF1 = IT1AM(ISYMA,ISYMI) + NVIR(ISYMA)*(I - 1) + A 3603 KOFF2 = KCTMO + IFCVIR(ISYMI,ISYMA) 3604 * + NORB(ISYMI)*(A - 1) + I - 1 3605C 3606 ETAC(KOFF1) = TWO*WORK(KOFF2) 3607C 3608 120 CONTINUE 3609 110 CONTINUE 3610C 3611 100 CONTINUE 3612C 3613 ENDIF 3614C 3615 IF ( DEBUG ) THEN 3616 ETA1 = DDOT(NT1AM(ISYRES),ETAC(1),1,ETAC(1),1) 3617 WRITE(LUPRI,*) ' ' 3618 WRITE(LUPRI,1) 'Norm of ETAC - First contribution:',ETA1 3619 ENDIF 3620C 3621C------------------------ 3622C IF CCS then return. 3623C------------------------ 3624C 3625 IF ( CCS .AND. (LIST .EQ. 'L0')) RETURN 3626C 3627C---------------------------------------------- 3628C Read zero'th order amplitude multipliers. 3629C---------------------------------------------- 3630C 3631 IOPT = 3 3632 CALL CC_RDRSP(LIST,ILSTNR,ISYML,IOPT,MODEL, 3633 * WORK(KL1AM),WORK(KT2AM)) 3634 IF (.NOT. CCS) CALL CC_T2SQ(WORK(KT2AM),WORK(KL2AM),ISYML) 3635C 3636C-------------------------------- 3637C Put T2 amplitudes in etac2. 3638C-------------------------------- 3639C 3640 IF (.NOT. CCS) THEN 3641 IOPT = 2 3642 CALL CC_RDRSP('R0',0,1,IOPT,MODEL,DUMMY,WORK(KT2AM)) 3643 ENDIF 3644C 3645C-------------------------------- 3646C Make X and Y intermediates. 3647C-------------------------------- 3648C 3649 IF (.NOT. CCS) THEN 3650 KXMAT = KEND21 3651 KYMAT = KXMAT + NMATIJ(ISYML) 3652 KEND3 = KYMAT + NMATAB(ISYML) 3653 LEND3 = LWORK - KEND3 3654 IF (LEND3.LT. 0 ) 3655 & CALL QUIT(' TOO LITTLE WORKSPACE IN CC_ETAC-2') 3656C 3657 IF ( DEBUG ) THEN 3658 XYI = DDOT(NT1AM(ISYML),WORK(KL1AM),1,WORK(KL1AM),1) 3659 WRITE(LUPRI,1) 'CC_ETAC: L1AM vector: ',XYI 3660 XYI = DDOT(NT2SQ(ISYML),WORK(KL2AM),1,WORK(KL2AM),1) 3661 WRITE(LUPRI,1) 'CC_ETAC: L2AM vector: ',XYI 3662 XXI = DDOT(NT2AM(ISYMOP),WORK(KT2AM),1,WORK(KT2AM),1) 3663 WRITE(LUPRI,1) 'T2AM vector : ',XXI 3664 ENDIF 3665 CALL CC_XI(WORK(KXMAT),WORK(KL2AM),ISYML,WORK(KT2AM),1, 3666 * WORK(KEND3),LEND3) 3667 CALL CC_YI(WORK(KYMAT),WORK(KL2AM),ISYML,WORK(KT2AM),1, 3668 * WORK(KEND3),LEND3) 3669 IF ( DEBUG ) THEN 3670 XYI = DDOT(NMATAB(ISYML),WORK(KYMAT),1,WORK(KYMAT),1) 3671 WRITE(LUPRI,1) 'CC_ETAC: YI intermediate is: ',XYI 3672 XXI = DDOT(NMATIJ(ISYML),WORK(KXMAT),1,WORK(KXMAT),1) 3673 WRITE(LUPRI,1) 'CC_ETAC: XI intermediate is: ',XXI 3674 ENDIF 3675 ELSE 3676 KEND3 = KEND2 3677 LEND3 = LEND2 3678 ENDIF 3679C 3680C---------------------------------------------- 3681C Calculate X and Y contributions to etac1. 3682C etac1 = -sum(e)Cie*Yae - sum(l)Cla*Xli 3683C---------------------------------------------- 3684C 3685 IF ( (.NOT.CCS) .AND. (.NOT.(CC2.AND.IOPTCC2.EQ.1)) ) THEN 3686 CALL CC_21EFM(ETAC,WORK(KCTMO),ISYMC,WORK(KXMAT), 3687 * WORK(KYMAT),ISYML,WORK(KEND3),LEND3) 3688C 3689 IF ( DEBUG ) THEN 3690 ETA1 = DDOT(NT1AM(ISYRES),ETAC(1),1,ETAC(1),1) 3691 WRITE(LUPRI,1) 'Norm of eta1-after X&Y cont: ',ETA1 3692 ENDIF 3693 ENDIF 3694C 3695C------------------------------------------------ 3696C Workspace for T2AM and X and Y is now free. 3697C etac2 = P(ab,ij)(2l(ai)*Cjb - l(aj)*c(ib)) 3698C------------------------------------------------ 3699C 3700 IF (.NOT. CCS) THEN 3701 CALL DZERO(ETAC(1+NT1AM(ISYRES)),NT2AM(ISYRES)) 3702 CALL CC_L1FCK(ETAC(1+NT1AM(ISYRES)),WORK(KL1AM),WORK(KCTMO), 3703 * ISYML,ISYMC,WORK(KEND2),LEND2) 3704C 3705 IF ( DEBUG ) THEN 3706 ETA1 = DDOT(NT1AM(ISYRES),ETAC(1),1,ETAC(1),1) 3707 ETA2 = DDOT(NT2AM(ISYRES),ETAC(1+NT1AM(ISYRES)),1, 3708 * ETAC(1+NT1AM(ISYRES)),1) 3709 WRITE(LUPRI,1) 'Norm of eta1-after L1c cont: ',ETA1 3710 WRITE(LUPRI,1) 'Norm of eta2-after L1c cont: ',ETA2 3711 ENDIF 3712 ENDIF 3713C 3714 KEI1 = KEND2 3715 KEI2 = KEI1 + NEMAT1(ISYMC) 3716 KEND3 = KEI2 + NMATIJ(ISYMC) 3717 LEND3 = LWORK - KEND3 3718 IF (LEND3.LT. 0 ) CALL QUIT(' TOO LITTLE WORKSPACE IN CC_ETAC-3') 3719C 3720C-------------------------------- 3721C Put A into E matrix format. 3722C-------------------------------- 3723C 3724 FCKCON = .TRUE. 3725 ETRAN = .FALSE. 3726 CALL CCRHS_EFCK(WORK(KEI1),WORK(KEI2),WORK(KLAMDH), 3727 * WORK(KCTMO),WORK(KEND3),LEND3,FCKCON, 3728 * ETRAN,ISYMC) 3729C 3730C-------------------------------------------- 3731C etac1 = sum(b)Lbi*Cba - sum(j)Laj*Cij. 3732C-------------------------------------------- 3733C 3734 IF ( DEBUG ) THEN 3735 XE1 = DDOT(NMATAB(ISYMC),WORK(KEI1),1,WORK(KEI1),1) 3736 XE2 = DDOT(NMATIJ(ISYMC),WORK(KEI2),1,WORK(KEI2),1) 3737 WRITE(LUPRI,1) 'Norm of EI1 -after EFCK: ',XE1 3738 WRITE(LUPRI,1) 'Norm of EI2 -after EFCK: ',XE2 3739 ETA1 = DDOT(NT1AM(ISYML),WORK(KL1AM),1,WORK(KL1AM),1) 3740 WRITE(LUPRI,1) 'Norm of L1AM before CCLR_E1C1: ',ETA1 3741 ENDIF 3742C 3743c test 3744c kei11= kend3 3745c kei21= kei11+ NMATAB(ISYMC) 3746c kend3 = kei21+ NMATIJ(ISYMC) 3747c lend3 = lwork -kend3 3748c call dzero(work(kei11),NMATAB(ISYMC)) 3749c call dzero(work(kei21),NMATIJ(ISYMC)) 3750c call dcopy(NMATAB(ISYMC),work(kei1),1,work(kei11),1) 3751c call dcopy(NMATIJ(ISYMC),work(kei2),1,work(kei21),1) 3752c CALL CCLR_E1C1(ETAC,WORK(KL1AM),WORK(KEI11),WORK(KEI21), 3753c * WORK(KEND3),LEND3,ISYML,ISYMC,'T') 3754c test 3755C 3756 CALL CCLR_E1C1(ETAC,WORK(KL1AM),WORK(KEI1),WORK(KEI2), 3757 * WORK(KEND3),LEND3,ISYML,ISYMC,'T') 3758C 3759 IF (DEBUG ) THEN 3760 ETA1 = DDOT(NT1AM(ISYRES),ETAC(1),1,ETAC(1),1) 3761 WRITE(LUPRI,1) 'Norm of eta1 - after CCLR_E1C1: ',ETA1 3762 ENDIF 3763C 3764C--------------------------------------------------------------- 3765C etac2 = P(ab,ij)(sum(e)2L(aiej)*Ceb - sym(k)L(aibk)*c(jk)) 3766C--------------------------------------------------------------- 3767C 3768 IF (.NOT. CCS) THEN 3769C 3770 IF (CC2 .AND. IOPTCC2.EQ.1) THEN 3771 FCKCON = .TRUE. 3772 ETRAN = .FALSE. 3773 CALL CCRHS_EFCK(WORK(KEI1),WORK(KEI2),WORK(KCMO), 3774 * WORK(KFCKHF),WORK(KEND3),LEND3,FCKCON,ETRAN,ISYMC) 3775 END IF 3776 3777 CALL CC_EITR(WORK(KEI1),WORK(KEI2),WORK(KEND3),LEND3, 3778 * ISYMC) 3779C 3780 CALL CCRHS_E(ETAC(1+NT1AM(ISYRES)),WORK(KL2AM), 3781 * WORK(KEI1),WORK(KEI2),WORK(KEND3), 3782 * LEND3,ISYML,ISYMC) 3783C 3784 IF (IPRINT .GT. 40 ) THEN 3785 CALL AROUND( 'In CC_ETAC: EtaC vector ' ) 3786 CALL CC_PRP(ETAC(1),ETAC(1+NT1AM(ISYRES)),ISYMC,1,1) 3787 ENDIF 3788C 3789 IF (DEBUG .OR. ( IPRINT .GT. 20 )) THEN 3790 ETA1 = DDOT(NT1AM(ISYRES),ETAC(1),1,ETAC(1),1) 3791 ETA2 = DDOT(NT2AM(ISYRES),ETAC(1+NT1AM(ISYRES)),1, 3792 * ETAC(1+NT1AM(ISYRES)),1) 3793 WRITE(LUPRI,1) 'Norm of eta1 - end of CC_ETAC: ',ETA1 3794 WRITE(LUPRI,1) 'Norm of eta2 - end of CC_ETAC: ',ETA2 3795 CALL AROUND( 'END OF CC_ETAC ') 3796 ENDIF 3797 ENDIF 3798C 3799 IF (IPRINT .GT. 5 ) THEN 3800 TIMEC = SECOND() - TIMEC 3801 WRITE(LUPRI,9999) 'CC_ETA ', TIMEC 3802 ENDIF 3803C 3804 1 FORMAT(1x,A35,1X,E20.10) 38059999 FORMAT(1x,'Time used in',2x,A18,2x,': ',f10.2,' seconds') 3806C 3807 END 3808c /* Deck polsym */ 3809 SUBROUTINE POLSYM(A,FACT) 3810C 3811#include "implicit.h" 3812C 3813 DIMENSION A(3,3) 3814C 3815 DO 10 I = 1, 3 3816 DO 20 J = 1, I -1 3817 A(J,I) = (A(J,I) + A(I,J))*FACT 3818 A(I,J) = A(J,I) 3819 20 CONTINUE 3820 A(I,I) = 2.0D00*A(I,I)*FACT 3821 10 CONTINUE 3822C 3823 RETURN 3824 END 3825c*DECK TNSRAN 3826 SUBROUTINE TNSRAN(TNSR,PVAL,PAXIS,ALFSQ,BETSQ,ITST,ITST2, 3827 * APAR,APEN,XKAPPA,IPAR) 3828C 3829C------------------------------------------------------------------------ 3830C 3831C Purpose: Analyse 3 by 3 tensot and 3832C 3833C 1. calculate rotatinal invariants 3834C alfa**2 = ((TNSRxx+TNSRyy+TNSRzz)**2)/9 3835C beta**2 = [(TNSRxx-TNSRyy)**2 + 3836C (TNSRxx-TNSRzz)**2 + 3837C (TNSRyy-TNSRzz)**2 + 3838C +3(TNSRxy**2+TNSRxy**2+TNSRxy**2+ 3839C TNSRxy**2+TNSRxy**2+TNSRxy**2)]/2 3840C 3841C 2. Diagonal, block-diagonal, all elements differ. 3842C itst = 0, 2, 6 3843C itst = nr. of non-zero out of diagonal elements. 3844C 3. If diagonal then a. no symmetry. itst2 = 3 3845C b. cylinder symmetry. itst2 = 1 3846C c. Spherical symmetry.itst2 = 0 3847C 3848C 4. If not diagonal then diagonalize 3849C 3850C 3851C Written by Ove Christiansen 18-10-1996 3852C 3853C------------------------------------------------------------------------ 3854C 3855#include "implicit.h" 3856#include "priunit.h" 3857#include "maxorb.h" 3858#include "ccorb.h" 3859#include "iratdef.h" 3860#include "ccsdinp.h" 3861C 3862 PARAMETER (THR = 1.0D-08) 3863 DIMENSION TNSR(3,3),PVAL(3),PAXIS(3,3) 3864 DIMENSION AMAT(3,3),WI(3),V1(3),FV1(3) 3865 LOGICAL D12,D13,D23,D1122,D1133,D2233,LBD 3866C 3867 APAR = 0.0D0 3868 APEN = 0.0D0 3869 XKAPPA = 0.0D0 3870 XX = TNSR(1,1) 3871 YX = TNSR(2,1) 3872 ZX = TNSR(3,1) 3873 XY = TNSR(1,2) 3874 YY = TNSR(2,2) 3875 ZY = TNSR(3,2) 3876 XZ = TNSR(1,3) 3877 YZ = TNSR(2,3) 3878 ZZ = TNSR(3,3) 3879C 3880 ALFSQ = (XX+YY+ZZ)**2/9.0D0 3881 BETSQ = ((XX-YY)**2+(XX-ZZ)**2+(YY-ZZ)**2 + 3882 * 3*(XY**2+YX**2+XZ**2+XZ**2+YZ**2+ZY**2))/2.0D0 3883C 3884 IF ((ABS(XY-YX)+ABS(XZ-ZX)+ABS(YZ-ZY)).GT.THR) THEN 3885C 3886 WRITE(LUPRI,'(/,1X,A)') 3887 * 'Tensor is not symmetric on input in TNSRAN' 3888 WRITE(LUPRI,'(1X,A,/,1X,A)') 3889 * 'I will symmetrice it for you to get a real symmmetric ', 3890 * 'tensor according to: 2*AlfaXY(om) = <<X,Y>>(om)+<<X,Y>>(-om)' 3891 WRITE(LUPRI,'(1X,A)') 3892 * ' = <<X,Y>>(om)+<<Y,X>>(om) ' 3893 CALL POLSYM(TNSR,0.5D0) 3894 WRITE(LUPRI,'(1X,A)') 'Tensor is now: ' 3895 CALL OUTPUT(TNSR,1,3,1,3,3,3,1,LUPRI) 3896C 3897 ENDIF 3898C 3899 D12 = (ABS(XY) .GT. THR ) 3900 D13 = (ABS(XZ) .GT. THR ) 3901 D23 = (ABS(YZ) .GT. THR ) 3902C 3903 ITST = 0 3904 IF (D12) ITST = ITST + 1 3905 IF (D13) ITST = ITST + 1 3906 IF (D23) ITST = ITST + 1 3907C 3908 ITST = ITST*2 3909C 3910 IF ( ITST .EQ. 0 ) THEN 3911C 3912C------------------------------------ 3913C Section for diagonal tensor. 3914C------------------------------------ 3915C 3916 PVAL(1) = TNSR(1,1) 3917 PVAL(2) = TNSR(2,2) 3918 PVAL(3) = TNSR(3,3) 3919 CALL DUNIT(PAXIS,3) 3920C 3921C------------------------------------------------ 3922C determine number of equivalent elements. 3923C------------------------------------------------ 3924C 3925 D1122 = (ABS(XX-YY) .LT. THR ) 3926 D1133 = (ABS(XX-ZZ) .LT. THR ) 3927 D2233 = (ABS(YY-ZZ) .LT. THR ) 3928C 3929 ITST2 = 0 3930 IF (D1122) ITST2 = ITST2 + 1 3931 IF (D1133) ITST2 = ITST2 + 1 3932 IF (D2233) ITST2 = ITST2 + 1 3933C 3934 IF (ITST2 .EQ. 3) THEN 3935C 3936 IF (IPRINT .GT. 10) WRITE(LUPRI,'(/,1X,A,/)') 3937 * 'TNSRAN: Tensor is spherical symmetric.' 3938 APAR = ZZ 3939 APEN = XX 3940 IPAR = 8 3941C 3942 ELSE IF (ITST2 .EQ. 1) THEN 3943C 3944 IF (IPRINT .GT. 10) WRITE(LUPRI,'(/,1X,A,/)') 3945 * 'TNSRAN: Tensor has cylinder symmetry.' 3946 IF ( D1122 ) THEN 3947 APAR = ZZ 3948 APEN = XX 3949 IPAR = 3 3950 ENDIF 3951 IF ( D1133 ) THEN 3952 APAR = YY 3953 APEN = XX 3954 IPAR = 2 3955 ENDIF 3956 IF ( D2233 ) THEN 3957 APAR = XX 3958 APEN = YY 3959 IPAR = 1 3960 ENDIF 3961 XKAPPA = (APAR - APEN)/(3*SQRT(ALFSQ)) 3962C 3963 ELSE IF (ITST2 .EQ. 0) THEN 3964C 3965 IF (IPRINT .GT. 10) WRITE(LUPRI,'(/,1X,A,/)') 3966 * 'TNSRAN: Tensor is a diagonal asym. top.' 3967 IF (ABS(ZZ).LT.THR) IPAR=4 3968 IF (ABS(YY).LT.THR) IPAR=5 3969 IF (ABS(XX).LT.THR) IPAR=6 3970C 3971 ENDIF 3972C 3973 ELSE 3974 IF (IPRINT .GT. 10) WRITE(LUPRI,'(/,1X,A,I2,A,/)') 3975 * 'TNSRAN: Tensor has ',ITST, 3976 * ' out of diagonal elements' 3977C 3978 IF (ITST .EQ. 2) THEN 3979 LBD = .TRUE. 3980 IF (D12) ISPAC = 3 3981 IF (D13) ISPAC = 2 3982 IF (D23) ISPAC = 1 3983 IF (D12) IPAR = 4 3984 IF (D13) IPAR = 5 3985 IF (D23) IPAR = 6 3986 ENDIF 3987C 3988 MATZ = 1 3989 CALL DCOPY(3*3,TNSR,1,AMAT,1) 3990 CALL RG(3,3,AMAT,PVAL,WI,MATZ,PAXIS,V1,FV1,IERR) 3991 CALL RGORD(3,3,PVAL,WI,PAXIS,.FALSE.) 3992 ENDIF 3993C 3994C------------------------------------ 3995C A little Self consistency test. 3996C------------------------------------ 3997C 3998 XX = PVAL(1) 3999 YY = PVAL(2) 4000 ZZ = PVAL(3) 4001 ALFSQ2 = (XX+YY+ZZ)**2/9.0D0 4002 BETSQ2 = (((XX-YY)**2+(XX-ZZ)**2+(YY-ZZ)**2)/2.0D0) 4003C 4004 IF ((ABS(ALFSQ-ALFSQ2).GT.THR).OR.(ABS(ALFSQ-ALFSQ2).GT.THR)) 4005 * THEN 4006 WRITE(LUPRI,'(/,1X,A)') 'Rotational invariants before ' 4007 * //'and after diagonalization is ' 4008 WRITE(LUPRI,'(1X,A,2F15.10)') 'Alfa**2',ALFSQ,ALFSQ2 4009 WRITE(LUPRI,'(1X,A,2F15.10)') 'Beta**2',BETSQ,BETSQ2 4010 WRITE(LUPRI,'(1X,A)') 'Check the diagonalization' 4011 ENDIF 4012C 4013 IF ((ABS(XX).GT.THR).AND.(ABS(YY).GT.THR).AND.(ABS(ZZ).GT.THR)) 4014 * IPAR = 7 4015C 4016 END 4017c*DECK CC_PABCON 4018 SUBROUTINE CC_PABCON(LABELA,ISYMA,FREQA,LRLXA, 4019 * LABELB,ISYMB,FREQB,LRLXB, 4020 * PRP,WORK,LWORK) 4021C 4022C----------------------------------------------------------------------------- 4023C 4024C Purpose: Calculate T-barA(-omeg)*Tbar-B(omeg)*P contribution to LRF. 4025C 4026C Written by Ove Christiansen May 1998 - based on CC_FABCON 4027C (for that reason somethings are called R that really are L 4028C and F instead of P) 4029C 4030C----------------------------------------------------------------------------- 4031C 4032#include "implicit.h" 4033#include "maxorb.h" 4034#include "ccorb.h" 4035#include "iratdef.h" 4036#include "priunit.h" 4037#include "cclr.h" 4038#include "ccsdsym.h" 4039#include "ccsdio.h" 4040#include "ccsdinp.h" 4041#include "leinf.h" 4042C 4043 PARAMETER( TWO = 2.0D00,HALF=0.5D00,TOLFRQ=1.0D-08 ) 4044 DIMENSION WORK(LWORK) 4045 CHARACTER LABELA*8,LABELB*8,MODEL*10 4046 LOGICAL LRLXA,LRLXB 4047C 4048 IF ( IPRINT .GT. 10 ) THEN 4049 CALL AROUND( 'IN CC_PABCON: Calculating polarizabilty P-cont.') 4050 ENDIF 4051C 4052 NTAMPA = NT1AM(ISYMA) + NT2AM(ISYMA) 4053 IF ( CCS ) NTAMPA = NT1AM(ISYMA) 4054 NTAMPB = NT1AM(ISYMB) + NT2AM(ISYMB) 4055 IF ( CCS ) NTAMPB = NT1AM(ISYMB) 4056 IF (ISYMA .NE. ISYMB ) CALL QUIT('Symmetry mismatch in CC_PABCON') 4057C 4058C----------------------------------------------- 4059C Loop perturbations of this symmetry class. 4060C----------------------------------------------- 4061C 4062 KR1 = 1 4063 KEND1 = KR1 + NTAMPB 4064 LEND1 = LWORK - KEND1 4065C 4066C------------------------------ 4067C Get P-transformed vector. 4068C------------------------------ 4069C 4070 KR11 = KR1 4071 KR12 = KR1 + NT1AM(ISYMB) 4072C 4073 CALL DZERO(WORK(KR1),NTAMPB) 4074 CALL CC_PTB(WORK(KR1),LABELB,ISYMB,FREQB,LRLXB,WORK(KEND1),LEND1) 4075C 4076 IF (IPRINT .GT. 40 ) THEN 4077 CALL AROUND( 'In CC_EATB: P*RSP vector ' ) 4078 CALL CC_PRP(WORK(KR1),WORK(KR1+NT1AM(ISYMB)),ISYMB,1,1) 4079 ENDIF 4080C 4081 IF ( DEBUG ) THEN 4082 XLV = DDOT(NTAMPB, WORK(KR1),1,WORK(KR1),1) 4083 WRITE(LUPRI,1) 'Norm of P*Response vector: ',XLV 4084 ENDIF 4085C 4086 KR2 = KEND1 4087 KEND2 = KR2 + NTAMPA 4088 LEND2 = LWORK - KEND2 4089 IF (LEND2.LT.0) CALL QUIT('TOO LITTLE WORKSPACE IN CC_ABFCON-2') 4090C 4091C----------------------------------------------------------- 4092C Get response vectors and do the dot with the P*vector. 4093C----------------------------------------------------------- 4094C 4095 KR21 = KR2 4096 KR22 = KR2 + NT1AM(ISYMA) 4097 ILSTNR = IL1ZETA(LABELA,LRLXA,FREQA,ISYMA) 4098 IOPT = 3 4099 CALL CC_RDRSP('L1',ILSTNR,ISYMA,IOPT,MODEL,WORK(KR21), 4100 * WORK(KR22)) 4101 IF ( DEBUG ) THEN 4102 XLV = DDOT(NTAMPA, WORK(KR2),1,WORK(KR2),1) 4103 WRITE(LUPRI,1) 'Norm of Response vector: ',XLV 4104 ENDIF 4105C 4106 FABCON = DDOT(NTAMPA,WORK(KR1),1,WORK(KR2),1) 4107 IF ( IPRINT .GT. 9 ) THEN 4108 WRITE(LUPRI,*) ' Singles contribution:', 4109 * DDOT(NT1AM(ISYMA),WORK(KR1),1,WORK(KR2),1) 4110 IF (.NOT. CCS) WRITE(LUPRI,*) ' Doubles contribution:', 4111 * DDOT(NT2AM(ISYMA),WORK(KR1+NT1AM(ISYMA)),1, 4112 * WORK(KR2+NT1AM(ISYMA)),1) 4113 ENDIF 4114 IF (IPRINT .GT. 2 ) THEN 4115 WRITE(LUPRI,'(1X,A2,A8,A1,A8,A3,F10.6,A,F10.6)') 4116 * '<<',LABELA,',',LABELB,'>>(', 4117 * FREQB,') LA*LB*P cont. = ',FABCON 4118 ENDIF 4119 PRP = PRP - FABCON 4120C 4121 1 FORMAT(1x,A35,1X,E20.10) 4122 RETURN 4123 END 4124c*DECK CC_PRPC 4125 SUBROUTINE CC_PRPC(PROP,LABEL,NORD,LABX,LABY,LABZ,LABU, 4126 * FRQY,FRQZ,FRQU,ISYMIN,ISYMEX,ISPINEX,IEX) 4127C 4128C----------------------------------------------------------------------------- 4129C 4130C Purpose: Add response property to list of property information to be 4131C passed to numerical differentiation/averaging. 4132C 4133C Ove Christiansen August 1999. 4134C 4135C NORD = 1 exp. value 4136C 2 Linear response function 4137C 3 Quadratic response function 4138C 4 Cubic response function 4139C -1 ground - excited transition matrix element 4140C -2 excited - excited transition matrix element (not implemented yet) 4141C -3 ground - excited transition strength 4142C -4 excited - excited transition strength (not implemented yet) 4143C -11 First order excited state property 4144C----------------------------------------------------------------------------- 4145C 4146#include "implicit.h" 4147#include "maxorb.h" 4148C 4149#include "dummy.h" 4150#include "iratdef.h" 4151#include "priunit.h" 4152#include "cclr.h" 4153#include "ccorb.h" 4154#include "ccsdsym.h" 4155#include "ccsdio.h" 4156#include "ccsdinp.h" 4157#include "prpc.h" 4158#include "ccinftap.h" 4159C 4160 LOGICAL EXIST,L1,L2,L3,L4,LI1,LI2 4161 PARAMETER (TOLFRQ=1.0D-08,ONE=1.0D0,XMONE=-1.0D0,TOLEXCI =1.0D-02) 4162C 4163 CHARACTER LABEL*10, LABX*8, LABY*8, LABZ*8, LABU*8 4164C 4165C-------------------------------------------------- 4166C Test if this property is already on the list. 4167C In that case find address else update NPRPC 4168C-------------------------------------------------- 4169C 4170C 4171 IF (NOEONL .AND. (NORD.EQ.0)) THEN 4172C if energy and NOEONList = true then skip addition to list. 4173 RETURN 4174 ELSE 4175 EXIST = .FALSE. 4176 IF (EXIST) THEN 4177c IPRPC = IHIT 4178 ELSE 4179 NPRPC = NPRPC + 1 4180 IPRPC = NPRPC 4181 ENDIF 4182C 4183 WRITE(LUPRPC, 4184 * '(I5,I3,I4,1X,A10,E23.16,4(1X,A8),3E23.16,3I4)') 4185 * IPRPC,ISYMIN,NORD,LABEL,PROP, 4186 * LABX,LABY,LABZ,LABU,FRQY,FRQZ,FRQU,ISYMEX,ISPINEX,IEX 4187 ENDIF 4188C 4189 END 4190*---------------------------------------------------------------------* 4191 SUBROUTINE CC_AVE2(VALUE,IDLSTX,IDLSTY,WORK,LWORK) 4192C----------------------------------------------------------------------- 4193C Purpose: Calculate <HF|[[H,T^x],T^y]+[X,T^y]+[Y,T^x]|CC> 4194C contribution to second order property. 4195C IDLSTX,IDLSTY - indeces of first-order amplitudes 4196C Written by Christof Haettig, Mai 2003 4197C----------------------------------------------------------------------- 4198 IMPLICIT NONE 4199#include "priunit.h" 4200#include "dummy.h" 4201#include "maxorb.h" 4202#include "ccorb.h" 4203#include "ccsdsym.h" 4204#include "ccr1rsp.h" 4205 4206 INTEGER ISYM0 4207 PARAMETER ( ISYM0 = 1 ) 4208 4209 CHARACTER LISTR1*3, LISTR2*3, MODEL*10, LABELX*8, LABELY*8 4210 INTEGER IDLSTX, IDLSTY, LWORK 4211 4212#if defined (SYS_CRAY) 4213 REAL WORK(LWORK), VALUE, DDOT 4214 REAL ZERO, ONE, TWO 4215#else 4216 DOUBLE PRECISION WORK(LWORK), VALUE, DDOT 4217 DOUBLE PRECISION ZERO, ONE, TWO 4218#endif 4219 PARAMETER (ZERO=0.0D0, ONE=1.0D0, TWO=2.0D0) 4220 4221 INTEGER ISYMX, ISYMY, ISYMXY, KT1AM0, KLAMP0, KLAMH0, KT1AMX, 4222 & KT1AMY, KEND1, LWRK1, IOPT, KFOCKX, KXIA, KEND2, LWRK2, 4223 & KFOCKY, KYIA, KXIAJB, KT1AM, IRREP, ISYMM, IERR 4224 4225 4226 VALUE = ZERO 4227 4228 ISYMX = ISYLRT(IDLSTX) 4229 ISYMY = ISYLRT(IDLSTY) 4230 ISYMXY = MULD2H(ISYMX,ISYMY) 4231 4232 LABELX = LRTLBL(IDLSTX) 4233 LABELY = LRTLBL(IDLSTY) 4234 4235 IF (ISYMXY.NE.1) RETURN 4236C 4237 KT1AM0 = 1 4238 KLAMP0 = KT1AM0 + NT1AM(ISYM0) 4239 KLAMH0 = KLAMP0 + NLAMDT 4240 KT1AMX = KLAMH0 + NLAMDT 4241 KT1AMY = KT1AMX + NT1AM(ISYMX) 4242 KEND1 = KT1AMY + NT1AM(ISYMY) 4243 LWRK1 = LWORK - KEND1 4244 IF (LWRK1.LT.0)CALL QUIT(' Too little workspace in CC_AVE2') 4245 4246C ----------------------------------------------------------- 4247C read amplitudes: 4248C ----------------------------------------------------------- 4249 IOPT = 1 4250 CALL CC_RDRSP('R1',IDLSTX,ISYMX,IOPT,MODEL,WORK(KT1AMX),DUMMY) 4251 CALL CC_RDRSP('R1',IDLSTY,ISYMY,IOPT,MODEL,WORK(KT1AMY),DUMMY) 4252 4253 ! read zeroth-order singles amplitudes and compute Lambda 4254 IOPT = 1 4255 CALL CC_RDRSP('R0',0,ISYM0,IOPT,MODEL,WORK(KT1AM0),DUMMY) 4256 CALL LAMMAT(WORK(KLAMP0),WORK(KLAMH0),WORK(KT1AM0), 4257 * WORK(KEND1),LWRK1) 4258 4259C ----------------------------------------------------------- 4260C compute <HF|[X,T^Y]|HF> 4261C ----------------------------------------------------------- 4262 KFOCKX = KEND1 4263 KXIA = KFOCKX + N2BST(ISYMX) 4264 KEND2 = KXIA + NT1AM(ISYMX) 4265 LWRK2 = LWORK - KEND2 4266 IF (LWRK2.LT.0)CALL QUIT(' Too little workspace in CC_AVE2') 4267 4268 ! get X integrals: 4269 CALL CCPRPAO(LABELX,.TRUE.,WORK(KFOCKX),IRREP,ISYMM,IERR, 4270 & WORK(KEND2),LWRK2) 4271 IF ((IERR.GT.0) .OR. (IERR.EQ.0 .AND. IRREP.NE.ISYMX)) THEN 4272 CALL QUIT('CC_AVE2: error reading operator '//LABELX) 4273 ELSE IF (IERR.LT.0) THEN 4274 CALL DZERO(WORK(KFOCKX),N2BST(ISYMX)) 4275 END IF 4276 CALL CC_FCKMO(WORK(KFOCKX),WORK(KLAMP0),WORK(KLAMH0), 4277 & WORK(KEND2),LWRK2,ISYMX,1,1) 4278 CALL CC_FOCK_RESORT(DUMMY,.FALSE.,WORK(KXIA),.TRUE., 4279 & DUMMY,.FALSE.,DUMMY,.FALSE.,WORK(KFOCKX),ISYMX) 4280 4281 4282 VALUE = VALUE + TWO * 4283 & DDOT(NT1AM(ISYMX),WORK(KXIA),1,WORK(KT1AMY),1) 4284 4285C ----------------------------------------------------------- 4286C compute <HF|[Y,T^X]|HF> 4287C ----------------------------------------------------------- 4288 KFOCKY = KEND1 4289 KYIA = KFOCKY + N2BST(ISYMX) 4290 KEND2 = KYIA + NT1AM(ISYMX) 4291 LWRK2 = LWORK - KEND2 4292 IF (LWRK2.LT.0)CALL QUIT(' Too little workspace in CC_AVE2') 4293 4294 ! get Y integrals: 4295 CALL CCPRPAO(LABELY,.TRUE.,WORK(KFOCKY),IRREP,ISYMM,IERR, 4296 & WORK(KEND2),LWRK2) 4297 IF ((IERR.GT.0) .OR. (IERR.EQ.0 .AND. IRREP.NE.ISYMY)) THEN 4298 CALL QUIT('CC_AVE2: error reading operator '//LABELY) 4299 ELSE IF (IERR.LT.0) THEN 4300 CALL DZERO(WORK(KFOCKY),N2BST(ISYMY)) 4301 END IF 4302 CALL CC_FCKMO(WORK(KFOCKY),WORK(KLAMP0),WORK(KLAMH0), 4303 & WORK(KEND2),LWRK2,ISYMY,1,1) 4304 CALL CC_FOCK_RESORT(DUMMY,.FALSE.,WORK(KYIA),.TRUE., 4305 & DUMMY,.FALSE.,DUMMY,.FALSE.,WORK(KFOCKY),ISYMY) 4306 4307 VALUE = VALUE + TWO * 4308 & DDOT(NT1AM(ISYMX),WORK(KYIA),1,WORK(KT1AMX),1) 4309 4310C ----------------------------------------------------------- 4311C get packed L(ia,jb) integrals and evaluate the 4312C projection contribution <HF|[[H,T^X],T^Y]|CC> 4313C ----------------------------------------------------------- 4314 KXIAJB = KEND1 4315 KXIA = KXIAJB + NT2AM(ISYM0) 4316 KEND2 = KXIA + NT1AM(ISYMX) 4317 LWRK2 = LWORK - KEND2 4318 IF (LWRK2.LT.0)CALL QUIT(' Too little workspace in CC_AVE2') 4319 4320 CALL CCG_RDIAJB(WORK(KXIAJB),NT2AM(ISYM0)) 4321 4322 IOPT = 1 4323 Call CCSD_TCMEPK(WORK(KXIAJB),ONE,ISYM0,IOPT) 4324 4325 IOPT = 0 4326 CALL DZERO(WORK(KXIA),NT1AM(ISYMX)) 4327 CALL CCG_LXD(WORK(KXIA),ISYMX,WORK(KT1AMX),ISYMX, 4328 & WORK(KXIAJB),ISYM0,IOPT) 4329 4330 VALUE = VALUE + TWO * 4331 & DDOT(NT1AM(ISYMX),WORK(KXIA),1,WORK(KT1AMY),1) 4332 4333 RETURN 4334 END 4335*---------------------------------------------------------------------* 4336 SUBROUTINE CC_TSTAV2(IDLSTR2,VEC,WORK,LWORK,IOPTTST) 4337C---------------------------------------------------------------------- 4338C Purpose: Calculate second-order properties from the second-order 4339C amplitude response to test these 4340C Written by Christof Haettig, May 2003 4341C---------------------------------------------------------------------- 4342 IMPLICIT NONE 4343#include "priunit.h" 4344#include "dummy.h" 4345#include "maxorb.h" 4346#include "ccorb.h" 4347#include "ccsdinp.h" 4348#include "ccsdsym.h" 4349#include "ccr1rsp.h" 4350#include "ccr2rsp.h" 4351 4352 LOGICAL LOCDBG 4353 PARAMETER (LOCDBG = .FALSE.) 4354 4355 INTEGER IDLSTR2, LWORK, IOPTTST, ISYM0 4356 PARAMETER (ISYM0 = 1) 4357 4358#if defined (SYS_CRAY) 4359 REAL PROPAVE, PROPRSP, WORK(*), VEC(*), DDOT 4360#else 4361 DOUBLE PRECISION PROPAVE, PROPRSP, WORK(*), VEC(*), DDOT 4362#endif 4363 4364 LOGICAL LORX 4365 CHARACTER*10 MODEL 4366 INTEGER KETA, KEND1, LWRK1, IOPT, IDLSTX, IDLSTY, 4367 & IR1TAMP, NVAR 4368 4369 IF (CCS) THEN 4370 PROPRSP = 0.0D0 4371 ELSE 4372 NVAR = NT1AM(ISYM0) + NT2AM(ISYM0) 4373 IF (CCR12) THEN 4374 NVAR = NVAR + NTR12AM(ISYM0) 4375 ENDIF 4376 KETA = 1 4377 KEND1 = KETA + NVAR 4378 LWRK1 = LWORK - KEND1 4379 IF (LWRK1.LT.0) CALL QUIT('Too little workspace in CC_TSTAV2') 4380 IF (IOPTTST.EQ.0) THEN 4381 CALL CC_ETA(WORK(KETA),WORK(KEND1),LWRK1) 4382 ELSE IF (IOPTTST.EQ.1) THEN 4383 IOPT = 3 4384 CALL CC_RDRSP('L0 ',0,ISYM0,IOPT,MODEL,WORK(KETA), 4385 * WORK(KETA+NT1AM(ISYMOP))) 4386 IF (CCR12) THEN 4387 IOPT = 32 4388 CALL CC_RDRSP('L0 ',0,ISYMOP,IOPT,MODEL,DUMMY, 4389 * WORK(KETA+NT1AM(ISYMOP)+NT2AM(ISYMOP))) 4390 ENDIF 4391 ELSE 4392 WRITE(LUPRI,*) 'IOPTTST = ',IOPTTST 4393 CALL QUIT('ILLEGAL VALUE FOR IOPTTST IN CC_TSTAV2.') 4394 END IF 4395 PROPRSP = DDOT(NVAR,WORK(KETA),1,VEC,1) 4396 4397 IF (LOCDBG) THEN 4398 write(lupri,*) 'Input vector:' 4399 call cc_prp(vec,vec(nt1am(isymop)+1),isymop,1,1) 4400 if (CCR12) call cc_prpr12(vec(1+nt1am(isymop)+nt2am(isymop)), 4401 * isymop,1,.false.) 4402 write(lupri,*) 'L0/X0 vector:' 4403 call cc_prp(work(keta),work(keta+nt1am(isymop)),isymop,1,1) 4404 if (CCR12) call cc_prpr12(work(keta+nt1am(isymop)+ 4405 * nt2am(isymop)),isymop,1,.false.) 4406 write(lupri,*) 'PROPRSP:',PROPRSP 4407 END IF 4408 ENDIF 4409 4410 IDLSTX = IR1TAMP(LBLR2T(IDLSTR2,1),LORXR2T(IDLSTR2,1), 4411 & FRQR2T(IDLSTR2,1), ISYR2T(IDLSTR2,1)) 4412 IDLSTY = IR1TAMP(LBLR2T(IDLSTR2,2),LORXR2T(IDLSTR2,2), 4413 & FRQR2T(IDLSTR2,2), ISYR2T(IDLSTR2,2)) 4414 4415 LORX = LORXR2T(IDLSTR2,1) .OR. LORXR2T(IDLSTR2,2) 4416 4417 IF ( LORX ) THEN 4418 CALL QUIT('No relaxation implemented in CC_TSTAV2.') 4419 ELSE 4420 ! if it is a simple unrelaxed one-electron perturbation 4421 ! calculate the average value contribution in CC_AVE 4422 CALL CC_AVE2(PROPAVE,IDLSTX,IDLSTY,WORK,LWORK) 4423 END IF 4424 4425 WRITE(LUPRI,'(1X,3A)') 'Operators : ', 4426 * LBLR2T(IDLSTR2,1),LBLR2T(IDLSTR2,2) 4427 WRITE(LUPRI,'(1X,A,2F16.4)') 'Frequencies : ', 4428 * FRQR2T(IDLSTR2,1),FRQR2T(IDLSTR2,2) 4429 WRITE(LUPRI,'(1X,A,F16.10)') 'Average contribution: ', 4430 * PROPAVE 4431 WRITE(LUPRI,'(1X,A,F16.10)') 'Response contribution: ', 4432 * PROPRSP 4433 WRITE(LUPRI,'(1X,A,F16.10)') 'Total second-order property:', 4434 * PROPAVE + PROPRSP 4435 4436 RETURN 4437 END 4438*---------------------------------------------------------------------* 4439C /* Deck cc_rotpri */ 4440 SUBROUTINE CC_ROTPRI(RIN,STREN,EIGV,IEX,ISYM,MODEL,LCALC,LDIP, 4441 & LUOSC) 4442C 4443C Thomas Bondo Pedersen, January 2005. 4444C - based on CC_OSCPRI by Ove Christiansen. 4445C 4446C Purpose: Print rotatory strengths. 4447C 4448#include "implicit.h" 4449 DIMENSION RIN(3) 4450 CHARACTER*10 MODEL 4451 LOGICAL LCALC 4452#include "priunit.h" 4453#include "pgroup.h" 4454#include "codata.h" 4455#include "ccsdinp.h" 4456 4457 PARAMETER (RAUSI = FPEPS0*(HBAR**3)*1.0D55/(EMASS**2)) 4458 PARAMETER (RAUCGS = ECHARGE*ECHARGE*HBAR*XTANG*CCM*1.0D36/EMASS) 4459 4460 DIMENSION ROT(3), STR(3) 4461 INTEGER POL(3) 4462 CHARACTER*7 CDIP 4463 4464 PARAMETER (THRPOL = 1.0D-8) ! Same threshold as in TNSRAN for polarization... 4465 4466 DATA POL /1,10,100/ 4467 4468 IF ( IPRINT .GT. 10 ) THEN 4469 CALL AROUND( 'IN CC_ROTPRI: Output Rotatory Strengths ' ) 4470 END IF 4471 4472 IMULT = 1 ! force singlet spin symmetry... 4473 4474 IF (LCALC) THEN 4475 4476C-tbp: ANGMOM sign fixed here: 4477 CALL DSCAL(3,-1.0D0,RIN,1) 4478 4479 CALL DCOPY(3,RIN,1,ROT,1) 4480 4481 WRITE(LUPRI,'(//,1X,A6,A,I3,A,I2,/,A7,A,F11.8,/)') MODEL(1:6), 4482 & 'Rotatory strength for state nr.',IEX, 4483 & ' of symmetry',ISYM,MODEL(1:6),'excitation energy:',EIGV 4484 IF (LDIP .EQ. 1) THEN 4485 WRITE(LUPRI,'(3X,A)') 'Gauge: length' 4486 FACT = -0.5D0 4487 ELSE IF (LDIP .EQ. 2) THEN 4488 WRITE(LUPRI,'(3X,A)') 'Gauge: velocity' 4489 IF (ABS(EIGV) .LT. 1.0D-8) THEN 4490 FACT = -1.0D16 4491 ELSE 4492 FACT = -1.0D0/(2.0D0*EIGV) 4493 END IF 4494 ELSE 4495 WRITE(LUPRI,'(3X,A)') 'Gauge: UNKNOWN' 4496 WRITE(LUPRI,'(3X,A)') '- scaling factors will be incorrect!' 4497 FACT = 1.0D0 4498 ENDIF 4499 CALL DZERO(STR,3) 4500 CALL DSCAL(3,FACT,ROT,1) 4501 DO I = 1,3 4502 STR(1) = STR(1) + ROT(I) 4503 END DO 4504 STR(2) = RAUSI*STR(1) 4505 STR(3) = RAUCGS*STR(1) 4506 WRITE(LUPRI,'(/,3X,A)') 'Rotatory strength components (a.u.):' 4507 WRITE(LUPRI,'(10X,A1,15X,A1,15X,A1)') 'X','Y','Z' 4508 WRITE(LUPRI,'(3X,F15.10,1X,F15.10,1X,F15.10,/)') 4509 & ROT(1),ROT(2),ROT(3) 4510 WRITE(LUPRI,'(3X,A,F15.7,/,3X,A,F15.7,/,3X,A,F15.7)') 4511 & 'Total Rotatory Strength in Atomic Units : ',STR(1), 4512 & 'Total Rotatory Strength in 10-55 A^2 m^3 s : ',STR(2), 4513 & 'Total Rotatory Strength in 10-40 cm^5 g s^-2 : ',STR(3) 4514 4515 STREN = STR(1) 4516 4517 IPOL = 0 4518 DO I = 1,3 4519 IF (ABS(ROT(I)) .GT. THRPOL) IPOL = IPOL + POL(I) 4520 END DO 4521 IF (IPOL .EQ. 1) THEN 4522 CDIP = ' X ' 4523 ELSE IF (IPOL .EQ. 10) THEN 4524 CDIP = ' Y ' 4525 ELSE IF (IPOL .EQ. 100) THEN 4526 CDIP = ' Z ' 4527 ELSE IF (IPOL .EQ. 11) THEN 4528 CDIP = ' (X,Y) ' 4529 ELSE IF (IPOL .EQ. 101) THEN 4530 CDIP = ' (X,Z) ' 4531 ELSE IF (IPOL .EQ. 110) THEN 4532 CDIP = ' (Y,Z) ' 4533 ELSE IF (IPOL .EQ. 111) THEN 4534 CDIP = '(X,Y,Z)' 4535 ELSE 4536 CDIP = ' - ' 4537 ENDIF 4538 4539 WRITE(LUOSC,9988) IMULT,REP(ISYM-1),IEX,STR(2),STR(3),CDIP 4540 4541 CALL FLSHFO(LUPRI) 4542 4543 ELSE 4544 4545 CDIP = ' ? ' 4546 WRITE(LUOSC,9986) IMULT,REP(ISYM-1),IEX,'Not calculated', 4547 & 'Not calculated',CDIP 4548 4549 END IF 4550 4551 RETURN 4552 4553 9986 FORMAT(1X,'| ^',I1,A3,' | ',I4,' | ',A16,4X, 4554 * ' |',A15,5X,' | ',A7,' ',1X,' |') 4555 9987 FORMAT(1X,'| | ',I4,' | ',A16,4X, 4556 * ' |',A15,5X,' | ',A7,' ',1X,' |') 4557 9988 FORMAT(1X,'| ^',I1,A3,' | ',I4,' | ',F16.7,4X, 4558 * ' |',F15.7,5X,' | ',A7,' ',1X,' |') 4559 9989 FORMAT(1X,'| | ',I4,' | ',F16.7,4X, 4560 * ' |',F15.7,5X,' | ',A7,' ',1X,' |') 4561 4562 END 4563C /* Deck cc_rtqpri */ 4564 SUBROUTINE CC_RTQPRI(RQIN,RQOUT,EIGV,IEX,ISYM,MODEL,LCALC,LDIP, 4565 & LUOSC,NWAR) 4566C 4567C Thomas Bondo Pedersen, July 2003. 4568C 4569C Purpose: Print rotatory strength tensors, el. quadrupole contribution. 4570C 4571#include "implicit.h" 4572 DIMENSION RQIN(3,9), RQOUT(3,3) 4573 CHARACTER*10 MODEL 4574 LOGICAL LCALC 4575#include "priunit.h" 4576#include "pgroup.h" 4577#include "codata.h" 4578#include "ccsdinp.h" 4579 4580 PARAMETER (RAUSI = FPEPS0*(HBAR**3)*1.0D55/(EMASS**2)) 4581 PARAMETER (RAUCGS = ECHARGE*ECHARGE*HBAR*XTANG*CCM*1.0D36/EMASS) 4582 4583 CHARACTER*9 SECNAM 4584 PARAMETER (SECNAM = 'CC_RTQPRI') 4585 4586 DIMENSION SQ(3,3,3), AVE(3) 4587 DIMENSION RQ(3,3,3) 4588 CHARACTER*7 CDIP 4589 LOGICAL WARN 4590#if defined (SYS_CRAY) 4591 REAL LEVICI(3,3,3) 4592#else 4593 DOUBLE PRECISION LEVICI(3,3,3) 4594#endif 4595 4596 PARAMETER (TINY = 1.0D-12) 4597 4598 IF ( IPRINT .GT. 10 ) THEN 4599 CALL AROUND('IN CC_RTQPRI: El. Quadr. Rotatory' 4600 & //' Strength Tensors') 4601 END IF 4602 4603 IMULT = 1 ! force singlet spin symmetry... 4604 4605 IF (LCALC) THEN 4606 4607 CALL DCOPY(3*9,RQIN,1,SQ,1) 4608 4609 CALL DZERO(LEVICI,3*3*3) 4610 LEVICI(1,2,3) = 1.0D0 4611 LEVICI(2,1,3) = -1.0D0 4612 LEVICI(3,1,2) = 1.0D0 4613 LEVICI(1,3,2) = -1.0D0 4614 LEVICI(2,3,1) = 1.0D0 4615 LEVICI(3,2,1) = -1.0D0 4616 4617 WRITE(LUPRI,'(//,1X,A6,A,I3,A,I2,/,A7,A,F11.8,/)') MODEL(1:6), 4618 & 'El. quadr. rotatory strength tensor for state nr.',IEX, 4619 & ' of symmetry',ISYM,MODEL(1:6),'excitation energy:',EIGV 4620 IF (LDIP .EQ. 1) THEN 4621 WRITE(LUPRI,'(3X,A)') 'Gauge: length' 4622 FACT = -3.0D0*EIGV/4.0D0 4623 ELSE IF (LDIP .EQ. 2) THEN 4624 WRITE(LUPRI,'(3X,A)') 'Gauge: velocity' 4625 IF (ABS(EIGV) .LT. 1.0D-8) THEN 4626 FACT = -1.0D16 4627 ELSE 4628 FACT = 3.0D0/(4.0D0*EIGV) 4629 END IF 4630 ELSE 4631 WRITE(LUPRI,'(3X,A)') 'Gauge: UNKNOWN' 4632 WRITE(LUPRI,'(3X,A)') '- scaling factors will be incorrect!' 4633 FACT = 1.0D0 4634 ENDIF 4635 4636 IERR = 0 4637 DO I = 1,3 4638 JERR = 0 4639 DO J = 1,3 4640 DO K = 1,J 4641 JK = 3*(K - 1) + J 4642 KJ = 3*(J - 1) + K 4643 DIFF = ABS(RQIN(I,JK) - RQIN(I,KJ)) 4644 IF (DIFF .GT. 1.0D-14) JERR = JERR + 1 4645 END DO 4646 END DO 4647 IERR = IERR + JERR 4648 END DO 4649 IF (IERR .NE. 0) THEN 4650 WRITE(LUPRI,*) SECNAM,': non-symmetric rank-3 tensor', 4651 & ' on entry' 4652 WRITE(LUPRI,*) 'This will lead to non-zero average!!!' 4653 WRITE(LUPRI,*) 'Residues from input:' 4654 WRITE(LUPRI,'(1X,A,F12.8)') 'X,XX: ',RQIN(1,1) 4655 WRITE(LUPRI,'(1X,A,F12.8)') 'X,XY: ',RQIN(1,4) 4656 WRITE(LUPRI,'(1X,A,F12.8)') 'X,XZ: ',RQIN(1,7) 4657 WRITE(LUPRI,'(1X,A,F12.8)') 'X,YY: ',RQIN(1,5) 4658 WRITE(LUPRI,'(1X,A,F12.8)') 'X,YZ: ',RQIN(1,8) 4659 WRITE(LUPRI,'(1X,A,F12.8)') 'X,ZZ: ',RQIN(1,9) 4660 WRITE(LUPRI,'(1X,A,F12.8)') 'Y,XX: ',RQIN(2,1) 4661 WRITE(LUPRI,'(1X,A,F12.8)') 'Y,XY: ',RQIN(2,4) 4662 WRITE(LUPRI,'(1X,A,F12.8)') 'Y,XZ: ',RQIN(2,7) 4663 WRITE(LUPRI,'(1X,A,F12.8)') 'Y,YY: ',RQIN(2,5) 4664 WRITE(LUPRI,'(1X,A,F12.8)') 'Y,YZ: ',RQIN(2,8) 4665 WRITE(LUPRI,'(1X,A,F12.8)') 'Y,ZZ: ',RQIN(2,9) 4666 WRITE(LUPRI,'(1X,A,F12.8)') 'Z,XX: ',RQIN(3,1) 4667 WRITE(LUPRI,'(1X,A,F12.8)') 'Z,XY: ',RQIN(3,4) 4668 WRITE(LUPRI,'(1X,A,F12.8)') 'Z,XZ: ',RQIN(3,7) 4669 WRITE(LUPRI,'(1X,A,F12.8)') 'Z,YY: ',RQIN(3,5) 4670 WRITE(LUPRI,'(1X,A,F12.8)') 'Z,YZ: ',RQIN(3,8) 4671 WRITE(LUPRI,'(1X,A,F12.8)') 'Z,ZZ: ',RQIN(3,9) 4672 CALL QUIT('Error in '//SECNAM) 4673 END IF 4674 4675 CALL DSCAL(3*3*3,FACT,SQ,1) 4676 CALL DZERO(RQ,3*3*3) 4677 DO K = 1,3 4678 DO J = 1,3 4679 DO M = 1,3 4680 DO L = 1,3 4681 RQ(J,K,1) = RQ(J,K,1) 4682 & + LEVICI(L,M,J)*SQ(L,M,K) 4683 END DO 4684 END DO 4685 END DO 4686 END DO 4687 CALL POLSYM(RQ(1,1,1),0.5D0) 4688 CALL DAXPY(3*3,RAUSI,RQ(1,1,1),1,RQ(1,1,2),1) 4689 CALL DAXPY(3*3,RAUCGS,RQ(1,1,1),1,RQ(1,1,3),1) 4690 CALL DZERO(AVE,3) 4691 DO I = 1,3 4692 DO J = 1,3 4693 AVE(I) = AVE(I) + RQ(J,J,I) 4694 END DO 4695 AVE(I) = AVE(I)/3.0D0 4696 END DO 4697 WRITE(LUPRI,'(/,3X,A)') 4698 & 'Electric quadrupole rotatory strength tensor components (a.u.):' 4699 CALL OUTPUT(RQ(1,1,1),1,3,1,3,3,3,1,LUPRI) 4700 WRITE(LUPRI,'(3X,A,1P,D17.10)') 4701 & 'Orientational average: ',AVE(1) 4702 WRITE(LUPRI,'(/,3X,A,A)') 4703 & 'Electric quadrupole rotatory strength tensor components ', 4704 & '(D-55 SI):' 4705 CALL OUTPUT(RQ(1,1,2),1,3,1,3,3,3,1,LUPRI) 4706 WRITE(LUPRI,'(3X,A,1P,D17.10)') 4707 & 'Orientational average: ',AVE(2) 4708 WRITE(LUPRI,'(/,3X,A,A)') 4709 & 'Electric quadrupole rotatory strength tensor components ', 4710 & '(D-40 cgs):' 4711 CALL OUTPUT(RQ(1,1,3),1,3,1,3,3,3,1,LUPRI) 4712 WRITE(LUPRI,'(3X,A,1P,D17.10)') 4713 & 'Orientational average: ',AVE(3) 4714 DIFF = AVE(1) 4715 WARN = ABS(DIFF) .GT. TINY 4716 IF (WARN) THEN 4717 WRITE(LUPRI,9990) 4718 NWAR = NWAR + 1 4719 END IF 4720 4721 DO J = 1,3 4722 DO K = J,3 4723 CDIP = ' ? ' 4724 IF ((J.EQ.1) .AND. (K.EQ.1)) THEN 4725 CDIP = ' XX ' 4726 WRITE(LUOSC,9988) IMULT,REP(ISYM-1),IEX, 4727 & RQ(J,K,2),RQ(J,K,3),CDIP 4728 ELSE 4729 IF (J .EQ. 1) THEN 4730 IF (K .EQ. 2) THEN 4731 CDIP = ' XY ' 4732 ELSE IF (K .EQ. 3) THEN 4733 CDIP = ' XZ ' 4734 END IF 4735 ELSE IF (J .EQ. 2) THEN 4736 IF (K .EQ. 2) THEN 4737 CDIP = ' YY ' 4738 ELSE IF (K .EQ. 3) THEN 4739 CDIP = ' YZ ' 4740 END IF 4741 ELSE IF (J .EQ. 3) THEN 4742 IF (K .EQ. 3) THEN 4743 CDIP = ' ZZ ' 4744 END IF 4745 END IF 4746 WRITE(LUOSC,9987) RQ(J,K,2),RQ(J,K,3),CDIP 4747 END IF 4748 END DO 4749 END DO 4750 4751 CALL DCOPY(3*3,RQ(1,1,1),1,RQOUT,1) 4752 4753 ELSE 4754 4755 CDIP = ' ? ' 4756 WRITE(LUOSC,9986) IMULT,REP(ISYM-1),IEX,'Not calculated', 4757 & 'Not calculated',CDIP 4758 4759 END IF 4760 4761 RETURN 4762 4763 9986 FORMAT(1X,'| ^',I1,A3,' | ',I4,' | ',A16,4X, 4764 * ' |',A15,5X,' | ',A7,' ',1X,' |') 4765 9987 FORMAT(1X,'| ',' | ',' | ',F16.7,4X, 4766 * ' |',F15.7,5X,' | ',A7,' ',1X,' |') 4767 9988 FORMAT(1X,'| ^',I1,A3,' | ',I4,' | ',F16.7,4X, 4768 * ' |',F15.7,5X,' | ',A7,' ',1X,' |') 4769 9990 FORMAT(1X,'***WARNING*** Incorrect average!!!') 4770 4771 END 4772C /* Deck cc_rtmpri */ 4773 SUBROUTINE CC_RTMPRI(RMIN,RMOUT,EIGV,IEX,ISYM,MODEL,LCALC,LDIP, 4774 & LUOSC,CHKSTR,NWAR) 4775C 4776C Thomas Bondo Pedersen, July 2003. 4777C 4778C Purpose: Print rotatory strength tensors, magn. dipole contribution. 4779C 4780#include "implicit.h" 4781 DIMENSION RMIN(3,3), RMOUT(3,3) 4782 CHARACTER*10 MODEL 4783 LOGICAL LCALC 4784#include "priunit.h" 4785#include "pgroup.h" 4786#include "codata.h" 4787#include "ccsdinp.h" 4788 4789 PARAMETER (RAUSI = FPEPS0*(HBAR**3)*1.0D55/(EMASS**2)) 4790 PARAMETER (RAUCGS = ECHARGE*ECHARGE*HBAR*XTANG*CCM*1.0D36/EMASS) 4791 4792 DIMENSION SM(3,3), AVE(3) 4793 DIMENSION RM(3,3,3) 4794 CHARACTER*7 CDIP 4795 LOGICAL WARN 4796 4797 PARAMETER (TINY = 1.0D-12) 4798 4799 IF ( IPRINT .GT. 10 ) THEN 4800 CALL AROUND('IN CC_RTMPRI: Magn. Dip. Rotatory' 4801 & //' Strength Tensors') 4802 END IF 4803 4804 IMULT = 1 ! force singlet spin symmetry... 4805 4806 IF (LCALC) THEN 4807 4808C-tbp: ANGMOM sign fixed here: 4809 CALL DSCAL(3*3,-1.0D0,RMIN,1) 4810 4811 TRA = 0.0D0 4812 DO K = 1,3 4813 DO J = 1,3 4814 SM(J,K) = -RMIN(K,J) 4815 END DO 4816 TRA = TRA + RMIN(K,K) 4817 END DO 4818 4819 WRITE(LUPRI,'(//,1X,A6,A,I3,A,I2,/,A7,A,F11.8,/)') MODEL(1:6), 4820 & 'Magn. dip. rotatory strength tensor for state nr.',IEX, 4821 & ' of symmetry',ISYM,MODEL(1:6),'excitation energy:',EIGV 4822 IF (LDIP .EQ. 1) THEN 4823 WRITE(LUPRI,'(3X,A)') 'Gauge: length' 4824 FACT = -0.75D0 4825 ELSE IF (LDIP .EQ. 2) THEN 4826 WRITE(LUPRI,'(3X,A)') 'Gauge: velocity' 4827 IF (ABS(EIGV) .LT. 1.0D-8) THEN 4828 FACT = -1.0D16 4829 ELSE 4830 FACT = -3.0D0/(4.0D0*EIGV) 4831 END IF 4832 ELSE 4833 WRITE(LUPRI,'(3X,A)') 'Gauge: UNKNOWN' 4834 WRITE(LUPRI,'(3X,A)') '- scaling factors will be incorrect!' 4835 FACT = 1.0D0 4836 ENDIF 4837 TRA = TRA*FACT 4838 CALL DSCAL(3*3,FACT,SM,1) 4839 CALL DZERO(RM,3*3*3) 4840 DO K = 1,3 4841 DO J = 1,3 4842 RM(J,K,1) = SM(J,K) 4843 END DO 4844 RM(K,K,1) = RM(K,K,1) + TRA 4845 END DO 4846 CALL POLSYM(RM(1,1,1),0.5D0) 4847 CALL DAXPY(3*3,RAUSI,RM(1,1,1),1,RM(1,1,2),1) 4848 CALL DAXPY(3*3,RAUCGS,RM(1,1,1),1,RM(1,1,3),1) 4849 CALL DZERO(AVE,3) 4850 DO I = 1,3 4851 DO J = 1,3 4852 AVE(I) = AVE(I) + RM(J,J,I) 4853 END DO 4854 AVE(I) = AVE(I)/3.0D0 4855 END DO 4856 WRITE(LUPRI,'(/,3X,A)') 4857 & 'Magnetic dipole rotatory strength tensor components (a.u.):' 4858 CALL OUTPUT(RM(1,1,1),1,3,1,3,3,3,1,LUPRI) 4859 WRITE(LUPRI,'(3X,A,1P,D17.10)') 4860 & 'Orientational average: ',AVE(1) 4861 WRITE(LUPRI,'(/,3X,A,A)') 4862 & 'Magnetic dipole rotatory strength tensor components ', 4863 & '(D-55 SI):' 4864 CALL OUTPUT(RM(1,1,2),1,3,1,3,3,3,1,LUPRI) 4865 WRITE(LUPRI,'(3X,A,1P,D17.10)') 4866 & 'Orientational average: ',AVE(2) 4867 WRITE(LUPRI,'(/,3X,A,A)') 4868 & 'Magnetic dipole rotatory strength tensor components ', 4869 & '(D-40 cgs):' 4870 CALL OUTPUT(RM(1,1,3),1,3,1,3,3,3,1,LUPRI) 4871 WRITE(LUPRI,'(3X,A,1P,D17.10)') 4872 & 'Orientational average: ',AVE(3) 4873 DIFF = AVE(1) - CHKSTR 4874 WARN = ABS(DIFF) .GT. TINY 4875 IF (WARN) THEN 4876 WRITE(LUPRI,9990) 4877 NWAR = NWAR + 1 4878 END IF 4879 4880 DO J = 1,3 4881 DO K = J,3 4882 CDIP = ' ? ' 4883 IF ((J.EQ.1) .AND. (K.EQ.1)) THEN 4884 CDIP = ' XX ' 4885 WRITE(LUOSC,9988) IMULT,REP(ISYM-1),IEX, 4886 & RM(J,K,2),RM(J,K,3),CDIP 4887 ELSE 4888 IF (J .EQ. 1) THEN 4889 IF (K .EQ. 2) THEN 4890 CDIP = ' XY ' 4891 ELSE IF (K .EQ. 3) THEN 4892 CDIP = ' XZ ' 4893 END IF 4894 ELSE IF (J .EQ. 2) THEN 4895 IF (K .EQ. 2) THEN 4896 CDIP = ' YY ' 4897 ELSE IF (K .EQ. 3) THEN 4898 CDIP = ' YZ ' 4899 END IF 4900 ELSE IF (J .EQ. 3) THEN 4901 IF (K .EQ. 3) THEN 4902 CDIP = ' ZZ ' 4903 END IF 4904 END IF 4905 WRITE(LUOSC,9987) RM(J,K,2),RM(J,K,3),CDIP 4906 END IF 4907 END DO 4908 END DO 4909 4910 CALL DCOPY(3*3,RM(1,1,1),1,RMOUT,1) 4911 4912 ELSE 4913 4914 CDIP = ' ? ' 4915 WRITE(LUOSC,9986) IMULT,REP(ISYM-1),IEX,'Not calculated', 4916 & 'Not calculated',CDIP 4917 4918 END IF 4919 4920 RETURN 4921 4922 9986 FORMAT(1X,'| ^',I1,A3,' | ',I4,' | ',A16,4X, 4923 * ' |',A15,5X,' | ',A7,' ',1X,' |') 4924 9987 FORMAT(1X,'| ',' | ',' | ',F16.7,4X, 4925 * ' |',F15.7,5X,' | ',A7,' ',1X,' |') 4926 9988 FORMAT(1X,'| ^',I1,A3,' | ',I4,' | ',F16.7,4X, 4927 * ' |',F15.7,5X,' | ',A7,' ',1X,' |') 4928 9990 FORMAT(1X,'***WARNING*** Incorrect average!!!') 4929 4930 END 4931C /* Deck cc_rttpri */ 4932 SUBROUTINE CC_RTTPRI(RTIN,EIGV,IEX,ISYM,MODEL,LCALC,LDIP, 4933 & LUOSC,CHKSTR,NWAR) 4934C 4935C Thomas Bondo Pedersen, July 2003. 4936C 4937C Purpose: Print rotatory strength tensors, total. 4938C 4939#include "implicit.h" 4940 DIMENSION RTIN(3,3) 4941 CHARACTER*10 MODEL 4942 LOGICAL LCALC 4943#include "priunit.h" 4944#include "pgroup.h" 4945#include "codata.h" 4946#include "ccsdinp.h" 4947 4948 PARAMETER (RAUSI = FPEPS0*(HBAR**3)*1.0D55/(EMASS**2)) 4949 PARAMETER (RAUCGS = ECHARGE*ECHARGE*HBAR*XTANG*CCM*1.0D36/EMASS) 4950 4951 DIMENSION RTOT(3,3,3), AVE(3) 4952 CHARACTER*7 CDIP 4953 LOGICAL WARN 4954 4955 PARAMETER (TINY = 1.0D-12) 4956 4957 IMULT = 1 4958 4959 IF (LCALC) THEN 4960 4961 CALL DCOPY(3*3,RTIN,1,RTOT(1,1,1),1) 4962 CALL DZERO(RTOT(1,1,2),3*3) 4963 CALL DAXPY(3*3,RAUSI,RTOT(1,1,1),1,RTOT(1,1,2),1) 4964 CALL DZERO(RTOT(1,1,3),3*3) 4965 CALL DAXPY(3*3,RAUCGS,RTOT(1,1,1),1,RTOT(1,1,3),1) 4966 4967 CALL DZERO(AVE,3) 4968 DO I = 1,3 4969 DO J = 1,3 4970 AVE(I) = AVE(I) + RTOT(J,J,I) 4971 END DO 4972 AVE(I) = AVE(I)/3.0D0 4973 END DO 4974 4975 WRITE(LUPRI,'(//,1X,A6,A,I3,A,I2,/,A7,A,F11.8,/)') MODEL(1:6), 4976 & 'Total rotatory strength tensor for state nr.',IEX, 4977 & ' of symmetry',ISYM,MODEL(1:6),'excitation energy:',EIGV 4978 IF (LDIP .EQ. 1) THEN 4979 WRITE(LUPRI,'(3X,A)') 'Gauge: length' 4980 ELSE IF (LDIP .EQ. 2) THEN 4981 WRITE(LUPRI,'(3X,A)') 'Gauge: velocity' 4982 ELSE 4983 WRITE(LUPRI,'(3X,A)') 'Gauge: UNKNOWN' 4984 ENDIF 4985 WRITE(LUPRI,'(/,3X,A)') 4986 & 'Total rotatory strength tensor components (a.u.):' 4987 CALL OUTPUT(RTOT(1,1,1),1,3,1,3,3,3,1,LUPRI) 4988 WRITE(LUPRI,'(3X,A,1P,D17.10)') 'Scalar strength: ',AVE(1) 4989 WRITE(LUPRI,'(/,3X,A,A)') 4990 & 'Total rotatory strength tensor components ', 4991 & '(D-55 SI):' 4992 CALL OUTPUT(RTOT(1,1,2),1,3,1,3,3,3,1,LUPRI) 4993 WRITE(LUPRI,'(3X,A,1P,D17.10)') 'Scalar strength: ',AVE(2) 4994 WRITE(LUPRI,'(/,3X,A,A)') 4995 & 'Total rotatory strength tensor components ', 4996 & '(D-40 cgs):' 4997 CALL OUTPUT(RTOT(1,1,3),1,3,1,3,3,3,1,LUPRI) 4998 WRITE(LUPRI,'(3X,A,1P,D17.10)') 'Scalar strength: ',AVE(3) 4999 DIFF = AVE(1) - CHKSTR 5000 WARN = ABS(DIFF) .GT. TINY 5001 IF (WARN) THEN 5002 WRITE(LUPRI,9990) 5003 NWAR = NWAR + 1 5004 END IF 5005 5006 DO J = 1,3 5007 DO K = J,3 5008 CDIP = ' ? ' 5009 IF ((J.EQ.1) .AND. (K.EQ.1)) THEN 5010 CDIP = ' XX ' 5011 WRITE(LUOSC,9988) IMULT,REP(ISYM-1),IEX, 5012 & RTOT(J,K,2),RTOT(J,K,3),CDIP 5013 ELSE 5014 IF (J .EQ. 1) THEN 5015 IF (K .EQ. 2) THEN 5016 CDIP = ' XY ' 5017 ELSE IF (K .EQ. 3) THEN 5018 CDIP = ' XZ ' 5019 END IF 5020 ELSE IF (J .EQ. 2) THEN 5021 IF (K .EQ. 2) THEN 5022 CDIP = ' YY ' 5023 ELSE IF (K .EQ. 3) THEN 5024 CDIP = ' YZ ' 5025 END IF 5026 ELSE IF (J .EQ. 3) THEN 5027 IF (K .EQ. 3) THEN 5028 CDIP = ' ZZ ' 5029 END IF 5030 END IF 5031 WRITE(LUOSC,9987) RTOT(J,K,2),RTOT(J,K,3),CDIP 5032 END IF 5033 END DO 5034 END DO 5035 5036 ELSE 5037 5038 CDIP = ' ? ' 5039 WRITE(LUOSC,9986) IMULT,REP(ISYM-1),IEX,'Not calculated', 5040 & 'Not calculated',CDIP 5041 5042 END IF 5043 5044 RETURN 5045 5046 9986 FORMAT(1X,'| ^',I1,A3,' | ',I4,' | ',A16,4X, 5047 * ' |',A15,5X,' | ',A7,' ',1X,' |') 5048 9987 FORMAT(1X,'| ',' | ',' | ',F16.7,4X, 5049 * ' |',F15.7,5X,' | ',A7,' ',1X,' |') 5050 9988 FORMAT(1X,'| ^',I1,A3,' | ',I4,' | ',F16.7,4X, 5051 * ' |',F15.7,5X,' | ',A7,' ',1X,' |') 5052 9990 FORMAT(1X,'***WARNING*** Incorrect scalar strength!!!') 5053 5054 END 5055C /* Deck cc_sopr */ 5056 SUBROUTINE CC_SOPR(WORK,LWORK) 5057C 5058C Thomas Bondo Pedersen, January 2005. 5059C - based on CC_LRESID by Ove Christiansen. 5060C 5061C Purpose: Calculate linear response residues. 5062C The Eta and Ksi vectors are calculated only once. 5063C 5064C NOTE: it is probably better to use *CCOPA .... 5065C Added sum rules for stopping power. Sonia, 2012 5066C 5067#include "implicit.h" 5068 DIMENSION WORK(LWORK) 5069#include "priunit.h" 5070#include "codata.h" 5071#include "ccsdinp.h" 5072#include "ccorb.h" 5073#include "ccsdsym.h" 5074#include "cclres.h" 5075#include "ccrspprp.h" 5076#include "ccroper.h" 5077#include "ccexci.h" 5078#include "ccexcinf.h" 5079#include "dummy.h" 5080#include "ccinftap.h" 5081#include "ccsections.h" 5082 5083 PARAMETER (RAUSI = FPEPS0*(HBAR**3)*1.0D55/(EMASS**2)) 5084 PARAMETER (RAUCGS = ECHARGE*ECHARGE*HBAR*XTANG*CCM*1.0D36/EMASS) 5085 PARAMETER (ZERO = 0.0D0) 5086 5087 CHARACTER*7 SECNAM 5088 PARAMETER (SECNAM = 'CC_SOPR') 5089 5090 LOGICAL LOCDBG,LCALC 5091 PARAMETER (LOCDBG = .FALSE.) 5092 CHARACTER*16 DBGMSG 5093 PARAMETER (DBGMSG = 'CC_SOPR[debug]: ') 5094 5095 CHARACTER*8 LABELA, LABELB 5096 CHARACTER*10 MODEL, MODELP 5097 5098 INTEGER NLOCS(8) 5099 5100 INTEGER ILRES 5101 !SUMRULE sum rules and mean excitation energy (Sonia) 5102 DIMENSION DSSUML(-6:2,4),DLSUML(-6:2,4),DISUML(-6:2,4) 5103 5104 CALL QENTER(SECNAM) 5105 5106C Start timing. 5107C ------------- 5108 5109 TIMTOT = SECOND() 5110 5111C Initialize counter (# residues). 5112C -------------------------------- 5113 5114 NTOT = 0 5115 5116C Print header. 5117C ------------- 5118 5119 WRITE (LUPRI,'(7(/1X,2A),/)') 5120 & '************************************', 5121 & '*******************************', 5122 & '* ', 5123 & ' *', 5124 & '*-------- OUTPUT FROM COUPLED CLUST', 5125 & 'ER LINEAR RESPONSE ---------*', 5126 & '* ', 5127 & ' *', 5128 & '*-------- CALCULATION OF SECOND', 5129 & ' ORDER RESIDUES ---------*', 5130 & '* ', 5131 & ' *', 5132 & '************************************', 5133 & '*******************************' 5134 5135 MODEL = 'CCSD ' 5136 IF (CC2) THEN 5137 MODEL = 'CC2 ' 5138 END IF 5139 IF (MCC2) THEN 5140 MODEL = 'MCC2 ' 5141 END IF 5142 IF (CCS) THEN 5143 MODEL = 'CCS ' 5144 END IF 5145 IF (CC3 ) THEN 5146 MODEL = 'CC3 ' 5147 WRITE(LUPRI,'(/,1X,A)') 5148 * 'CC3 linear response residues not implemented yet' 5149 WRITE(LUPRI,'(/,1X,A)') 5150 * 'USE CC_OPAINP INSTEAD' 5151 RETURN 5152 END IF 5153 IF (CC1A) THEN 5154 MODEL = 'CCSDT-1a ' 5155 WRITE(LUPRI,'(/,1X,A)') 5156 * 'CC1A linear response residues not implemented yet' 5157 RETURN 5158 END IF 5159 IF (CCSD) THEN 5160 MODEL = 'CCSD ' 5161 END IF 5162 5163 IF (CIS) THEN 5164 MODELP = 'CIS ' 5165 ELSE 5166 MODELP = MODEL 5167 END IF 5168 5169 CALL AROUND(SECNAM//': Calculation of '//MODELP//' Residues') 5170 IF (IPRINT .GT. 10) THEN 5171 WRITE(LUPRI,*) SECNAM,': LWORK = ',LWORK 5172 END IF 5173 CALL FLSHFO(LUPRI) 5174 5175C Count number of selected states in each symmetry. 5176C ------------------------------------------------- 5177 5178 CALL IZERO(NLOCS,NSYM) 5179 DO IRSD = 1,NXLRSST 5180 ISTATE = ILRSST(IRSD) 5181 ISYME = ISYEXC(ISTATE) 5182 NLOCS(ISYME) = NLOCS(ISYME) + 1 5183 END DO 5184 5185 IF (LOCDBG) THEN 5186 WRITE(LUPRI,*) DBGMSG,'NLOCS: ',(NLOCS(I),I=1,NSYM) 5187 CALL FLSHFO(LUPRI) 5188 END IF 5189 5190C Check that any residues requested. 5191C ---------------------------------- 5192 5193 NTEST = NXLRSST*NLRSOP 5194 IF (NTEST .LE. 0) THEN 5195 WRITE(LUPRI,'(/,1X,A,A)') 5196 & SECNAM,': No residues requested.' 5197 WRITE(LUPRI,'(1X,A,I10,/,1X,A,I10,/)') 5198 & 'Number of selected excited states :',NXLRSST, 5199 & 'Number of requested operator doubles:',NLRSOP 5200 GO TO 999 5201 END IF 5202 5203C Allocation 1. 5204C ------------- 5205 5206 NTRMOM = NXLRSST*NPRLBL_CC 5207 5208 KRIGHT = 1 5209 KLEFT = KRIGHT + NTRMOM 5210 KEND1 = KLEFT + NTRMOM 5211 LWRK1 = LWORK - KEND1 + 1 5212 5213 IF (LWRK1 .LT. 0) THEN 5214 CALL QUIT('Insufficient memory in '//SECNAM//' [1]') 5215 END IF 5216 5217C Initialize transition moment arrays. 5218C ------------------------------------ 5219 5220 CALL DZERO(WORK(KRIGHT),NTRMOM) 5221 CALL DZERO(WORK(KLEFT),NTRMOM) 5222 5223C Loop through operators in PRPLBL_CC. 5224C --------------------------------- 5225 5226 DO IPRLBL = 1,NPRLBL_CC 5227 5228 LABELA = PRPLBL_CC(IPRLBL) 5229 5230C Check that the operator enters in at least 1 residue requested. 5231C --------------------------------------------------------------- 5232 5233 IAB = 1 5234 IOPER = ILRES(LABELA,'A') 5235 IF (IOPER .LE. 0) THEN 5236 IAB = 2 5237 IOPER = ILRES(LABELA,'B') 5238 END IF 5239 5240 IF (IOPER .GT. 0) THEN 5241 5242 IF (IAB .EQ. 1) THEN 5243 ISYMA = ISYOPR(IALRSOP(IOPER)) 5244 ELSE IF (IAB .EQ. 2) THEN 5245 ISYMA = ISYOPR(IBLRSOP(IOPER)) 5246 ELSE 5247 WRITE(LUPRI,*) SECNAM,': lllegal IAB: ',IAB 5248 CALL QUIT('Internal error in '//SECNAM//' [IAB 1]') 5249 END IF 5250 5251 IF (NLOCS(ISYMA) .GT. 0) THEN 5252 5253C Allocation 2. 5254C ------------- 5255 5256 NTAMP = NT1AM(ISYMA) 5257 IF (.NOT. CCS) NTAMP = NTAMP + NT2AM(ISYMA) 5258 5259 KETA = KEND1 5260 KEND2 = KETA + NTAMP 5261 LWRK2 = LWORK - KEND2 + 1 5262 5263 IF (LWRK2 .LT. 0) THEN 5264 CALL QUIT('Insufficient memory in '//SECNAM//' [2]') 5265 END IF 5266 5267C Offsets to right and left moments. 5268C ---------------------------------- 5269 5270 KOFFR = KRIGHT + NXLRSST*(IPRLBL - 1) 5271 KOFFL = KLEFT + NXLRSST*(IPRLBL - 1) 5272 5273C Calculate etaA vector. 5274C ---------------------- 5275 5276 if (EOMCCSD) then 5277 !EOM transition moment requested (SONIA) 5278 write(lupri,*)'EOM eta^X vector requested' 5279 CALL CCCI_ETAC(ISYMA,LABELA,WORK(KETA),'L0',1,0,DUMMY, 5280 & WORK(KEND2),LWRK2) 5281 write(lupri,*)'out of CCCI_ETAC' 5282C 5283C Calculate contribution to right (left) transition moment: 5284C etaA*RE for all excited states of matching symmetry. 5285C ---------------------------------------------------- 5286 else 5287 5288 CALL CC_ETAC(ISYMA,LABELA,WORK(KETA),'L0',1,0,DUMMY, 5289 & WORK(KEND2),LWRK2) 5290 end if 5291 5292C Calculate contribution to right (left) transition moment: 5293C etaA*RE for all excited states of matching symmetry. 5294C ---------------------------------------------------- 5295 5296 CALL CC_TRRETA(ISYMA,LABELA,WORK(KOFFR),WORK(KETA), 5297 & WORK(KEND2),LWRK2,MODEL) 5298 5299C Calculate contribution to right (sonia: left) transition moment: 5300C [F*tA(-wf)]*RE for all excited states of matching symmetry, 5301C if requested. 5302C ----------------------------------------------------------- 5303 5304 if (.not.EOMCCSD) then 5305 IF ((.NOT.CIS) .AND. (.NOT.LRS2N1)) THEN 5306 CALL CC_TRRFTA(ISYMA,LABELA,WORK(KOFFR), 5307 & WORK(KEND1),LWRK1,MODEL) 5308 END IF 5309 end if 5310 5311C Calculate ksiA vector. 5312C ---------------------- 5313 5314 KKSI = KETA 5315 CALL CC_XKSI(WORK(KKSI),LABELA,ISYMA,0,DUMMY, 5316 & WORK(KEND2),LWRK2) 5317 5318C Calculate left (sonia: right) transition moment: 5319C LE*ksiA for all excited states of matching symmetry. 5320C ---------------------------------------------------- 5321 5322 CALL CC_TRLKSI(ISYMA,LABELA,WORK(KOFFL),WORK(KKSI), 5323 & WORK(KEND2),LWRK2,MODEL) 5324 5325 if (EOMCCSD) then 5326 !Sonia: 5327 !compute the trivial contribution to left moment 5328 !-(tbar*RE)*(tbar*ksiA) 5329 !Done as (tbar*(tbar*RE))*ksiaA 5330 CALL CC_eomTRRKSI(ISYMA,LABELA,WORK(KOFFR),WORK(KKSI), 5331 & WORK(KEND2),LWRK2,MODEL) 5332 5333 else 5334 5335C Calculate contribution to right (left) transition moment: 5336C Mf(wf)*ksiA for all excited states of matching symmetry, 5337C if requested. 5338C -------------------------------------------------------- 5339 5340 IF ((.NOT.CIS) .AND. LRS2N1) THEN 5341 write(lupri,*)'Doing the Mf*CsiA' 5342 CALL CC_TRRKSI(ISYMA,LABELA,WORK(KOFFR),WORK(KKSI), 5343 & WORK(KEND2),LWRK2,MODEL) 5344 END IF 5345 end if 5346 5347 5348 END IF 5349 5350 END IF 5351 5352 END DO 5353 5354C Print right transition moments. 5355C ------------------------------- 5356 5357 WRITE(LUPRI,'(//,1X,A6,A)') MODELP(1:6), 5358 & 'Right transition moments in atomic units:' 5359 WRITE(LUPRI,'(1X,A,/)') 5360 & '-----------------------------------------------' 5361 5362 DO IPRLBL = 1,NPRLBL_CC 5363 5364 LABELA = PRPLBL_CC(IPRLBL) 5365 5366 IAB = 1 5367 IOPER = ILRES(LABELA,'A') 5368 IF (IOPER .LE. 0) THEN 5369 IAB = 2 5370 IOPER = ILRES(LABELA,'B') 5371 END IF 5372 5373 IF (IOPER .GT. 0) THEN 5374 5375 IF (IAB .EQ. 1) THEN 5376 ISYMA = ISYOPR(IALRSOP(IOPER)) 5377 ELSE IF (IAB .EQ. 2) THEN 5378 ISYMA = ISYOPR(IBLRSOP(IOPER)) 5379 ELSE 5380 WRITE(LUPRI,*) SECNAM,': lllegal IAB: ',IAB 5381 CALL QUIT('Internal error in '//SECNAM//' [IAB 2]') 5382 END IF 5383 5384 IF (NLOCS(ISYMA) .GT. 0) THEN 5385 DO IRSD = 1,NXLRSST 5386 ISTATE = ILRSST(IRSD) 5387 ISYME = ISYEXC(ISTATE) 5388 ISTSY = ISTATE - ISYOFE(ISYME) 5389 EIGV = EIGVAL(ISTATE) 5390 IF (ISYME .EQ. ISYMA) THEN 5391 KOFF = KRIGHT + NXLRSST*(IPRLBL - 1) + IRSD - 1 5392 WRITE(LUPRI,'(1X,I2,F15.6,2X,A1,A8,A6,1X,F15.8)') 5393 & ISTATE,EIGV,'<',LABELA,'|f> = ',WORK(KOFF) 5394 END IF 5395 END DO 5396 END IF 5397 5398 END IF 5399 5400 END DO 5401 5402C Print left transition moments. 5403C ------------------------------ 5404 5405 WRITE(LUPRI,'(//,1X,A6,A)') MODELP(1:6), 5406 & 'Left transition moments in atomic units:' 5407 WRITE(LUPRI,'(1X,A,/)') 5408 & '-----------------------------------------------' 5409 5410 DO IPRLBL = 1,NPRLBL_CC 5411 5412 LABELA = PRPLBL_CC(IPRLBL) 5413 5414 IAB = 1 5415 IOPER = ILRES(LABELA,'A') 5416 IF (IOPER .LE. 0) THEN 5417 IAB = 2 5418 IOPER = ILRES(LABELA,'B') 5419 END IF 5420 5421 IF (IOPER .GT. 0) THEN 5422 5423 IF (IAB .EQ. 1) THEN 5424 ISYMA = ISYOPR(IALRSOP(IOPER)) 5425 ELSE IF (IAB .EQ. 2) THEN 5426 ISYMA = ISYOPR(IBLRSOP(IOPER)) 5427 ELSE 5428 WRITE(LUPRI,*) SECNAM,': lllegal IAB: ',IAB 5429 CALL QUIT('Internal error in '//SECNAM//' [IAB 3]') 5430 END IF 5431 5432 IF (NLOCS(ISYMA) .GT. 0) THEN 5433 DO IRSD = 1,NXLRSST 5434 ISTATE = ILRSST(IRSD) 5435 ISYME = ISYEXC(ISTATE) 5436 ISTSY = ISTATE - ISYOFE(ISYME) 5437 EIGV = EIGVAL(ISTATE) 5438 IF (ISYME .EQ. ISYMA) THEN 5439 KOFF = KLEFT + NXLRSST*(IPRLBL - 1) + IRSD - 1 5440 WRITE(LUPRI,'(1X,I2,F15.6,2X,A3,A8,A4,1X,F15.8)') 5441 & ISTATE,EIGV,'<f|',LABELA,'> = ',WORK(KOFF) 5442 END IF 5443 END DO 5444 END IF 5445 5446 END IF 5447 5448 END DO 5449 5450 CALL FLSHFO(LUPRI) 5451 5452C Allocation 3. 5453C ------------- 5454 5455 IF (OSCSTR) THEN 5456 LOSCIL = NEXCI*3*3 5457 ELSE 5458 LOSCIL = 0 5459 END IF 5460 5461 IF (VELSTR) THEN 5462 LOSCIV = NEXCI*3*3 5463 ELSE 5464 LOSCIV = 0 5465 END IF 5466 5467 IF (MIXSTR) THEN 5468 LOSCIM = NEXCI*3*3 5469 ELSE 5470 LOSCIM = 0 5471 END IF 5472 5473 IF (ROTLEN) THEN 5474 LROTL = NEXCI*3 5475 LCHKL = NEXCI 5476 ELSE 5477 LROTL = 0 5478 LCHKL = 0 5479 ENDIF 5480 5481 IF (ROTVEL) THEN 5482 LROTV = NEXCI*3 5483 LCHKV = NEXCI 5484 ELSE 5485 LROTV = 0 5486 LCHKV = 0 5487 ENDIF 5488 5489 IF (RTNLEN) THEN 5490 LRQL = NEXCI*3*9 5491 LRML = NEXCI*3*3 5492 NWRL = 0 5493 ELSE 5494 LRQL = 0 5495 LRML = 0 5496 ENDIF 5497 5498 IF (RTNVEL) THEN 5499 LRQV = NEXCI*3*9 5500 LRMV = NEXCI*3*3 5501 NWRV = 0 5502 ELSE 5503 LRQV = 0 5504 LRMV = 0 5505 ENDIF 5506 5507 KOSCS2 = KEND1 5508 KTRS = KOSCS2 + LOSCIL 5509 KVELST = KTRS + LOSCIL 5510 KVELST2= KVELST + LOSCIV 5511 KMIXST = KVELST2 + LOSCIV 5512 KMIXST2= KMIXST + LOSCIM 5513 KROTL = KMIXST2 + LOSCIM 5514 KROTV = KROTL + LROTL 5515 KRQL = KROTV + LROTV 5516 KRML = KRQL + LRQL 5517 KRQL2 = KRML + LRML 5518 KRML2 = KRQL2 + LRML 5519 KRQV = KRML2 + LRML 5520 KRMV = KRQV + LRQV 5521 KRQV2 = KRMV + LRMV 5522 KRMV2 = KRQV2 + LRMV 5523 KCHKL = KRMV2 + LRMV 5524 KCHKV = KCHKL + LCHKL 5525 KEND3 = KCHKV + LCHKV 5526 LWRK3 = LWORK - KEND3 5527 5528 IF (LWRK3 .LT. 0) THEN 5529 CALL QUIT('Insufficient memory in '//SECNAM//' [3]') 5530 END IF 5531 5532 IF (OSCSTR) THEN 5533 CALL DZERO(WORK(KOSCS2),LOSCIL) 5534 CALL DZERO(WORK(KTRS),LOSCIL) 5535 END IF 5536 IF (VELSTR) THEN 5537 CALL DZERO(WORK(KVELST),LOSCIV) 5538 CALL DZERO(WORK(KVELST2),LOSCIV) 5539 END IF 5540 IF (MIXSTR) THEN 5541 CALL DZERO(WORK(KMIXST),LOSCIM) 5542 CALL DZERO(WORK(KMIXST2),LOSCIM) 5543 END IF 5544 IF (ROTLEN) THEN 5545 CALL DZERO(WORK(KROTL),LROTL) 5546 CALL DZERO(WORK(KROTL),LROTL) 5547 CALL DZERO(WORK(KCHKL),LCHKL) 5548 END IF 5549 IF (ROTVEL) THEN 5550 CALL DZERO(WORK(KROTV),LROTV) 5551 CALL DZERO(WORK(KROTV),LROTV) 5552 CALL DZERO(WORK(KCHKV),LCHKV) 5553 END IF 5554 IF (RTNLEN) THEN 5555 CALL DZERO(WORK(KRQL),LRQL) 5556 CALL DZERO(WORK(KRML),LRML) 5557 CALL DZERO(WORK(KRQL2),LRML) 5558 CALL DZERO(WORK(KRML2),LRML) 5559 END IF 5560 IF (RTNVEL) THEN 5561 CALL DZERO(WORK(KRQV),LRQV) 5562 CALL DZERO(WORK(KRMV),LRMV) 5563 CALL DZERO(WORK(KRQV2),LRMV) 5564 CALL DZERO(WORK(KRMV2),LRMV) 5565 END IF 5566 5567C Calculate linear response residues from transition moments, 5568C incl. symmetrization. 5569C ----------------------------------------------------------- 5570 5571 WRITE(LUPRI,'(//,1X,A6,A)') MODELP(1:6), 5572 & 'linear response residue property in atomic units:' 5573 WRITE(LUPRI,'(1X,A,/)') 5574 & '-------------------------------------------------------' 5575 5576 DO IOPER = 1,NLRSOP 5577 5578 ISYMA = ISYOPR(IALRSOP(IOPER)) 5579 ISYMB = ISYOPR(IBLRSOP(IOPER)) 5580 LABELA = LBLOPR(IALRSOP(IOPER)) 5581 LABELB = LBLOPR(IBLRSOP(IOPER)) 5582 5583 IPROPA = INDPRP_CC(LABELA) 5584 IPROPB = INDPRP_CC(LABELB) 5585 5586 DO IRSD = 1,NXLRSST 5587 5588 ISTATE = ILRSST(IRSD) 5589 ISYME = ISYEXC(ISTATE) 5590 ISTSY = ISTATE - ISYOFE(ISYME) 5591 EIGV = EIGVAL(ISTATE) 5592 ISYMEA = MULD2H(ISYME,ISYMA) 5593 5594 IF ((ISYME.EQ.ISYMA) .AND. (ISYME.EQ.ISYMB)) THEN 5595 5596 NTOT = NTOT + 1 5597 5598 KA = NXLRSST*(IPROPA - 1) + IRSD 5599 KB = NXLRSST*(IPROPB - 1) + IRSD 5600 5601 K1 = KRIGHT + KA - 1 5602 K2 = KLEFT + KB - 1 5603 K3 = KRIGHT + KB - 1 5604 K4 = KLEFT + KA - 1 5605 5606 IHERMA = ISYMAT(IALRSOP(IOPER)) 5607 IHERMB = ISYMAT(IBLRSOP(IOPER)) 5608 ISASB = IHERMA*IHERMB 5609 5610 IF (ISASB .EQ. 0) THEN 5611 WRITE(LUPRI,*) ' WARNING: operators ',LABELA,LABELB, 5612 & ' have undefined hermiticities: ', 5613 & IHERMA,IHERMB 5614 WRITE(LUPRI,*) 5615 & ' Residue not appropriately symmetrized..' 5616 SIGN = 1.0D0 5617 ELSE 5618 SIGN = DBLE(ISASB) 5619 ENDIF 5620 RESIDAB = WORK(K1)*WORK(K2) 5621 RESIDBA = WORK(K3)*WORK(K4) 5622 RESIDUE = 0.5D0*(RESIDAB + SIGN*RESIDBA) 5623 IF (RESIDUE.GE.0.0D0) THEN 5624 SQRRES=SQRT(RESIDUE) 5625 ELSE 5626 SQRRES=-SQRT(-RESIDUE) 5627 ENDIF 5628 WRITE(LUPRI,'(1X,A6,A8,A1,A8,A3,F9.6,A,F15.8,A,F12.8,A)') 5629 & 'RES{<<',LABELA,',',LABELB,'>>(',EIGV,')} =', 5630 & RESIDUE,' ( ',SQRRES,')' 5631 IF (BOTHLRS) THEN 5632 WRITE(LUPRI,'(1X,A,F12.8,A)') 5633 & ' (Unsymmetrized residue: ',RESIDAB,')' 5634 END IF 5635 5636 IF (OSCSTR) THEN ! Length gauge oscillator strength 5637 IF (LABELA(2:7).EQ.'DIPLEN' .AND. 5638 & LABELB(2:7).EQ.'DIPLEN') THEN 5639 IF (LABELA(1:5).EQ.'XDIPL') IADR1 = 1 5640 IF (LABELA(1:5).EQ.'YDIPL') IADR1 = 2 5641 IF (LABELA(1:5).EQ.'ZDIPL') IADR1 = 3 5642 IF (LABELB(1:5).EQ.'XDIPL') IADR2 = 1 5643 IF (LABELB(1:5).EQ.'YDIPL') IADR2 = 2 5644 IF (LABELB(1:5).EQ.'ZDIPL') IADR2 = 3 5645 IOSCS2 = 3*3*(ISTATE-1)+3*(IADR2-1)+IADR1+KOSCS2-1 5646 WORK(IOSCS2) = RESIDUE 5647 END IF 5648 END IF 5649 IF (VELSTR) THEN ! Velocity gauge oscillator strength 5650 IF (LABELA(2:7).EQ.'DIPVEL' .AND. 5651 & LABELB(2:7).EQ.'DIPVEL') THEN 5652 IF (LABELA(1:5).EQ.'XDIPV') IADR1 = 1 5653 IF (LABELA(1:5).EQ.'YDIPV') IADR1 = 2 5654 IF (LABELA(1:5).EQ.'ZDIPV') IADR1 = 3 5655 IF (LABELB(1:5).EQ.'XDIPV') IADR2 = 1 5656 IF (LABELB(1:5).EQ.'YDIPV') IADR2 = 2 5657 IF (LABELB(1:5).EQ.'ZDIPV') IADR2 = 3 5658 IOSCS2 = 3*3*(ISTATE-1)+3*(IADR2-1)+IADR1+KVELST-1 5659 WORK(IOSCS2) = RESIDUE 5660 END IF 5661 END IF 5662 IF (MIXSTR) THEN ! Mixed gauge oscillator strength 5663 IF (LABELA(2:7).EQ.'DIPLEN' .AND. 5664 & LABELB(2:7).EQ.'DIPVEL') THEN 5665 IF (LABELA(1:5).EQ.'XDIPL') IADR1 = 1 5666 IF (LABELA(1:5).EQ.'YDIPL') IADR1 = 2 5667 IF (LABELA(1:5).EQ.'ZDIPL') IADR1 = 3 5668 IF (LABELB(1:5).EQ.'XDIPV') IADR2 = 1 5669 IF (LABELB(1:5).EQ.'YDIPV') IADR2 = 2 5670 IF (LABELB(1:5).EQ.'ZDIPV') IADR2 = 3 5671 IOSCS2 = 3*3*(ISTATE-1)+3*(IADR2-1)+IADR1+KMIXST-1 5672 WORK(IOSCS2) = RESIDUE 5673 END IF 5674 END IF 5675 IF (ROTLEN) THEN ! Length gauge rotatory strength 5676 IF (LABELA(2:7) .EQ. 'DIPLEN' .AND. 5677 & LABELB(2:7) .EQ. 'ANGMOM') THEN 5678 IF (LABELA(1:5).EQ.'XDIPL') IADR1 = 1 5679 IF (LABELA(1:5).EQ.'YDIPL') IADR1 = 2 5680 IF (LABELA(1:5).EQ.'ZDIPL') IADR1 = 3 5681 IF (LABELB(1:5).EQ.'XANGM') IADR2 = 1 5682 IF (LABELB(1:5).EQ.'YANGM') IADR2 = 2 5683 IF (LABELB(1:5).EQ.'ZANGM') IADR2 = 3 5684 IF (IADR1 .EQ. IADR2) THEN 5685 IROTST = KROTL + 3*(ISTATE-1) + IADR1 - 1 5686 WORK(IROTST) = RESIDUE 5687 END IF 5688 END IF 5689 END IF 5690 IF (ROTVEL) THEN ! Velocity gauge rotatory strength 5691 IF (LABELA(2:7) .EQ. 'DIPVEL' .AND. 5692 & LABELB(2:7) .EQ. 'ANGMOM') THEN 5693 IF (LABELA(1:5).EQ.'XDIPV') IADR1 = 1 5694 IF (LABELA(1:5).EQ.'YDIPV') IADR1 = 2 5695 IF (LABELA(1:5).EQ.'ZDIPV') IADR1 = 3 5696 IF (LABELB(1:5).EQ.'XANGM') IADR2 = 1 5697 IF (LABELB(1:5).EQ.'YANGM') IADR2 = 2 5698 IF (LABELB(1:5).EQ.'ZANGM') IADR2 = 3 5699 IF (IADR1 .EQ. IADR2) THEN 5700 IROTST = KROTV + 3*(ISTATE-1) + IADR1 - 1 5701 WORK(IROTST) = RESIDUE 5702 END IF 5703 END IF 5704 END IF 5705 IF (RTNLEN) THEN 5706 IF (LABELA(2:7) .EQ. 'DIPLEN') THEN 5707 IF (LABELB(3:8) .EQ. 'SECMOM') THEN 5708 IADR1 = -999999 5709 IF (LABELA(1:5).EQ.'XDIPL') IADR1 = 1 5710 IF (LABELA(1:5).EQ.'YDIPL') IADR1 = 2 5711 IF (LABELA(1:5).EQ.'ZDIPL') IADR1 = 3 5712 IADR23 = -999999 5713 IADR32 = -999999 5714 IF (LABELB(1:5).EQ.'XXSEC') THEN 5715 IADR23 = 1 5716 IADR32 = 0 5717 ELSE IF (LABELB(1:5).EQ.'XYSEC') THEN 5718 IADR23 = 4 5719 IADR32 = 2 5720 ELSE IF (LABELB(1:5).EQ.'XZSEC') THEN 5721 IADR23 = 7 5722 IADR32 = 3 5723 ELSE IF (LABELB(1:5).EQ.'YYSEC') THEN 5724 IADR23 = 5 5725 IADR32 = 0 5726 ELSE IF (LABELB(1:5).EQ.'YZSEC') THEN 5727 IADR23 = 8 5728 IADR32 = 6 5729 ELSE IF (LABELB(1:5).EQ.'ZZSEC') THEN 5730 IADR23 = 9 5731 IADR32 = 0 5732 END IF 5733 IF ((IADR1.LT.0) .OR. (IADR23.LT.0) .OR. 5734 & (IADR32.LT.0)) THEN 5735 CALL QUIT('RQL error in '//SECNAM) 5736 END IF 5737 IRTEN = KRQL + 3*9*(ISTATE-1) 5738 & + 3*(IADR23-1) + IADR1 - 1 5739 WORK(IRTEN) = RESIDUE 5740 IF (IADR32 .NE. 0) THEN 5741 IRTEN = KRQL + 3*9*(ISTATE-1) 5742 & + 3*(IADR32-1) + IADR1 - 1 5743 WORK(IRTEN) = RESIDUE 5744 END IF 5745 ELSE IF (LABELB(2:7) .EQ. 'ANGMOM') THEN 5746 IF (LABELA(1:5).EQ.'XDIPL') IADR1 = 1 5747 IF (LABELA(1:5).EQ.'YDIPL') IADR1 = 2 5748 IF (LABELA(1:5).EQ.'ZDIPL') IADR1 = 3 5749 IF (LABELB(1:5).EQ.'XANGM') IADR2 = 1 5750 IF (LABELB(1:5).EQ.'YANGM') IADR2 = 2 5751 IF (LABELB(1:5).EQ.'ZANGM') IADR2 = 3 5752 IRTEN = KRML + 3*3*(ISTATE-1) 5753 & + 3*(IADR2-1) + IADR1 - 1 5754 WORK(IRTEN) = RESIDUE 5755 END IF 5756 END IF 5757 END IF 5758 IF (RTNVEL) THEN 5759 IF (LABELA(2:7) .EQ. 'DIPVEL') THEN 5760 IF (LABELB(3:8) .EQ. 'ROTSTR') THEN 5761 IF (LABELA(1:5).EQ.'XDIPV') IADR1 = 1 5762 IF (LABELA(1:5).EQ.'YDIPV') IADR1 = 2 5763 IF (LABELA(1:5).EQ.'ZDIPV') IADR1 = 3 5764 IF (LABELB(1:5).EQ.'XXROT') THEN 5765 IADR23 = 1 5766 IADR32 = 0 5767 ELSE IF (LABELB(1:5).EQ.'XYROT') THEN 5768 IADR23 = 4 5769 IADR32 = 2 5770 ELSE IF (LABELB(1:5).EQ.'XZROT') THEN 5771 IADR23 = 7 5772 IADR32 = 3 5773 ELSE IF (LABELB(1:5).EQ.'YYROT') THEN 5774 IADR23 = 5 5775 IADR32 = 0 5776 ELSE IF (LABELB(1:5).EQ.'YZROT') THEN 5777 IADR23 = 8 5778 IADR32 = 6 5779 ELSE IF (LABELB(1:5).EQ.'ZZROT') THEN 5780 IADR23 = 9 5781 IADR32 = 0 5782 END IF 5783 IRTEN = KRQV + 3*9*(ISTATE-1) 5784 & + 3*(IADR23-1) + IADR1 - 1 5785 WORK(IRTEN) = RESIDUE 5786 IF (IADR32 .NE. 0) THEN 5787 IRTEN = KRQV + 3*9*(ISTATE-1) 5788 & + 3*(IADR32-1) + IADR1 - 1 5789 WORK(IRTEN) = RESIDUE 5790 END IF 5791 ELSE IF (LABELB(2:7) .EQ. 'ANGMOM') THEN 5792 IF (LABELA(1:5).EQ.'XDIPV') IADR1 = 1 5793 IF (LABELA(1:5).EQ.'YDIPV') IADR1 = 2 5794 IF (LABELA(1:5).EQ.'ZDIPV') IADR1 = 3 5795 IF (LABELB(1:5).EQ.'XANGM') IADR2 = 1 5796 IF (LABELB(1:5).EQ.'YANGM') IADR2 = 2 5797 IF (LABELB(1:5).EQ.'ZANGM') IADR2 = 3 5798 IRTEN = KRMV + 3*3*(ISTATE-1) 5799 & + 3*(IADR2-1) + IADR1 - 1 5800 WORK(IRTEN) = RESIDUE 5801 END IF 5802 END IF 5803 END IF 5804 5805 ELSE 5806 5807 RESIDUE = 0.0D0 5808 SQRRES = 0.0D0 5809 5810 END IF 5811 5812 IF (LABELA .EQ. LABELB) THEN 5813 CALL WRIPRO(SQRRES,MODEL,-1, 5814 & LABELA,LABELB,LABELA,LABELB, 5815 & EIGV,EIGV,EIGV,ISYMEA,ISYME,1,ISTATE) 5816 OSCCON = EIGV*SQRRES*SQRRES 5817 CALL WRIPRO(OSCCON,MODEL,-21, 5818 & LABELA,LABELB,LABELA,LABELB, 5819 & EIGV,EIGV,EIGV,ISYMEA,ISYME,1,ISTATE) 5820 END IF 5821 5822 END DO 5823 5824 END DO 5825 5826 CALL FLSHFO(LUPRI) 5827 5828C Print summary on unit LURES. 5829C ---------------------------- 5830 5831 LUOSC = LURES 5832 5833 IF (OSCSTR) CALL DCOPY(LOSCIL,WORK(KOSCS2),1,WORK(KTRS),1) 5834 IF (VELSTR) CALL DCOPY(LOSCIV,WORK(KVELST),1,WORK(KVELST2),1) 5835 IF (MIXSTR) CALL DCOPY(LOSCIM,WORK(KMIXST),1,WORK(KMIXST2),1) 5836 5837 IF (OSCSTR .AND. (CCS.OR.CC2.OR.CCSD)) THEN 5838 5839 WRITE(LUOSC,'(//A)') 5840 & ' +==============================================' 5841 & //'===============================+' 5842 WRITE(LUOSC,'(1X,A26,A10,A)') 5843 & '| sym. | Exci. | ',MODELP,' Length Gauge Osci' 5844 & //'llator Strength |' 5845 WRITE(LUOSC,'(A)') 5846 & ' |(spin, | +-----------------------------' 5847 & //'-------------------------------+' 5848 WRITE(LUOSC,'(1X,A)') 5849 & '| spat) | | Dipole Strength(a.u.) | Oscillator stre' 5850 & //'ngth | Direction |' 5851 WRITE(LUOSC,'(A)') 5852 & ' +==============================================' 5853 & //'===============================+' 5854 5855 IF (SUMRULES) then 5856 !initialize to zero to start with 5857 CALL DZERO(DSSUML,36) 5858 CALL DZERO(DLSUML,36) 5859 CALL DZERO(DISUML,36) 5860 END IF 5861 5862 DO ISYM = 1, NSYM 5863 DO IEX = 1, NCCEXCI(ISYM,1) 5864 ISTATE = ISYOFE(ISYM) + IEX 5865 EIGV = EIGVAL(ISTATE) 5866 KOSCSI = KOSCS2 + 3*3*(ISTATE-1) 5867 KTRSI = KTRS + 3*3*(ISTATE-1) 5868 LCALC = .FALSE. 5869 LDIP = 1 5870 DO IRSD = 1, NXLRSST 5871 ISTATE = ILRSST(IRSD) 5872 ISYME = ISYEXC(ISTATE) 5873 ISTSY = ILRSST(IRSD)-ISYOFE(ISYME) 5874 IF ((ISYME.EQ.ISYM).AND.(IEX.EQ.ISTSY)) LCALC =.TRUE. 5875 END DO 5876 CALL CC_OSCPRI(WORK(KTRSI),WORK(KOSCSI),EIGV, 5877 & IEX,ISYM,WORK(KEND2),LEND2,MODELP,LCALC, 5878 & LDIP,LUOSC) 5879! 5880! SONIA/SPASAUER --- 5881! Sum rules and mean exc energy 5882! components already summed up inside oscpri 5883! 2/3*eigv prefactor is also already included 5884! therefore I reduce the exponent in the S(n) series 5885! Removed a factor 3 so TOTAL is just sum of individual 5886! components 5887! 5888 IF (SUMRULES) then 5889 5890 DO K = -6,2 5891 DO ICOM = 1,3 5892 DSSUML(K,ICOM) = DSSUML(K,ICOM) 5893 & + EIGV**(K) 5894 & * WORK(KOSCSI+3*(icom-1)+icom-1) 5895 DLSUML(K,ICOM) = DLSUML(K,ICOM) 5896 & + EIGV**(K) 5897 & * DLOG(EIGV) 5898 & * WORK(KOSCSI+3*(icom-1)+icom-1) 5899 if (DSSUML(K,ICOM).EQ.ZERO) then 5900 DISUML(K,ICOM) = ZERO 5901 else 5902 DISUML(K,ICOM) = DEXP(DLSUML(K,ICOM)/DSSUML(K,ICOM)) 5903 & *XTEV 5904 end if 5905 ENDDO 5906 DSSUML(K,4) = DSSUML(K,1)+DSSUML(K,2)+DSSUML(K,3) 5907 DLSUML(K,4) = DLSUML(K,1)+DLSUML(K,2)+DLSUML(K,3) 5908 if (DSSUML(K,4).EQ.ZERO) then 5909 DISUML(K,4) = ZERO 5910 else 5911 DISUML(K,4) = DEXP(DLSUML(K,4)/DSSUML(K,4)) 5912 & *XTEV 5913 end if 5914 ENDDO 5915 end if 5916! end of mean exc energy/sum rules. Sonia 5917 5918 END DO 5919 IF (.NOT.((ISYM .EQ. NSYM).OR.(NCCEXCI(ISYM,1).EQ.0))) THEN 5920 NREST = 0 5921 DO ISYM2 = ISYM+1,NSYM 5922 NREST = NREST + NCCEXCI(ISYM2,1) 5923 END DO 5924 IF (NREST.EQ.0) GOTO 9001 5925 WRITE(LUOSC,'(A)') 5926 & ' +----------------------------------------------' 5927 & //'-------------------------------+' 5928 END IF 5929 9001 CONTINUE 5930 END DO 5931 5932 WRITE(LUOSC,'(A)') 5933 & ' +==============================================' 5934 & //'===============================+' 5935 5936 END IF 5937 5938 IF (VELSTR .AND. (CCS.OR.CC2.OR.CCSD)) THEN 5939 5940 WRITE(LUOSC,'(//A)') 5941 & ' +==============================================' 5942 & //'===============================+' 5943 WRITE(LUOSC,'(1X,A26,A10,A)') 5944 & '| sym. | Exci. | ',MODELP,' Velocity Gauge Osci' 5945 & //'llator Strength |' 5946 WRITE(LUOSC,'(A)') 5947 & ' |(spin, | +-----------------------------' 5948 & //'-------------------------------+' 5949 WRITE(LUOSC,'(1X,A)') 5950 & '| spat) | | Dipole Strength(a.u.) | Oscillator stre' 5951 & //'ngth | Direction |' 5952 WRITE(LUOSC,'(A)') 5953 & ' +==============================================' 5954 & //'===============================+' 5955 5956 DO ISYM = 1, NSYM 5957 DO IEX = 1, NCCEXCI(ISYM,1) 5958 ISTATE = ISYOFE(ISYM) + IEX 5959 EIGV = EIGVAL(ISTATE) 5960 KOSCSI = KVELST + 3*3*(ISTATE-1) 5961 KTRSI = KVELST2+ 3*3*(ISTATE-1) 5962 LCALC = .FALSE. 5963 LDIP = 2 5964 DO IRSD = 1, NXLRSST 5965 ISTATE = ILRSST(IRSD) 5966 ISYME = ISYEXC(ISTATE) 5967 ISTSY = ILRSST(IRSD)-ISYOFE(ISYME) 5968 IF ((ISYME.EQ.ISYM).AND.(IEX.EQ.ISTSY)) LCALC =.TRUE. 5969 END DO 5970 CALL CC_OSCPRI(WORK(KTRSI),WORK(KOSCSI),EIGV, 5971 & IEX,ISYM,WORK(KEND2),LEND2,MODELP,LCALC, 5972 & LDIP,LUOSC) 5973 END DO 5974 IF (.NOT.((ISYM .EQ. NSYM).OR.(NCCEXCI(ISYM,1).EQ.0))) THEN 5975 NREST = 0 5976 DO ISYM2 = ISYM+1,NSYM 5977 NREST = NREST + NCCEXCI(ISYM2,1) 5978 END DO 5979 IF (NREST.EQ.0) GOTO 9005 5980 WRITE(LUOSC,'(A)') 5981 & ' +----------------------------------------------' 5982 & //'-------------------------------+' 5983 END IF 5984 9005 CONTINUE 5985 END DO 5986 5987 WRITE(LUOSC,'(A)') 5988 & ' +==============================================' 5989 & //'===============================+' 5990 5991 END IF 5992 5993 IF (MIXSTR .AND. (CCS.OR.CC2.OR.CCSD)) THEN 5994 5995 WRITE(LUOSC,'(//A)') 5996 & ' +==============================================' 5997 & //'===============================+' 5998 WRITE(LUOSC,'(1X,A26,A10,A)') 5999 & '| sym. | Exci. | ',MODELP,' Mixed Gauge Osci' 6000 & //'llator Strength |' 6001 WRITE(LUOSC,'(A)') 6002 & ' |(spin, | +-----------------------------' 6003 & //'-------------------------------+' 6004 WRITE(LUOSC,'(1X,A)') 6005 & '| spat) | | Dipole Strength(a.u.) | Oscillator stre' 6006 & //'ngth | Direction |' 6007 WRITE(LUOSC,'(A)') 6008 & ' +==============================================' 6009 & //'===============================+' 6010 6011 DO ISYM = 1, NSYM 6012 DO IEX = 1, NCCEXCI(ISYM,1) 6013 ISTATE = ISYOFE(ISYM) + IEX 6014 EIGV = EIGVAL(ISTATE) 6015 KOSCSI = KMIXST + 3*3*(ISTATE-1) 6016 KTRSI = KMIXST2+ 3*3*(ISTATE-1) 6017 LCALC = .FALSE. 6018 LDIP = 3 6019 DO IRSD = 1, NXLRSST 6020 ISTATE = ILRSST(IRSD) 6021 ISYME = ISYEXC(ISTATE) 6022 ISTSY = ILRSST(IRSD)-ISYOFE(ISYME) 6023 IF ((ISYME.EQ.ISYM).AND.(IEX.EQ.ISTSY)) LCALC =.TRUE. 6024 END DO 6025 CALL CC_OSCPRI(WORK(KTRSI),WORK(KOSCSI),EIGV, 6026 & IEX,ISYM,WORK(KEND2),LEND2,MODELP,LCALC, 6027 & LDIP,LUOSC) 6028 END DO 6029 IF (.NOT.((ISYM .EQ. NSYM).OR.(NCCEXCI(ISYM,1).EQ.0))) THEN 6030 NREST = 0 6031 DO ISYM2 = ISYM+1,NSYM 6032 NREST = NREST + NCCEXCI(ISYM2,1) 6033 END DO 6034 IF (NREST.EQ.0) GOTO 9008 6035 WRITE(LUOSC,'(A)') 6036 & ' +----------------------------------------------' 6037 & //'-------------------------------+' 6038 END IF 6039 9008 CONTINUE 6040 END DO 6041 6042 WRITE(LUOSC,'(A)') 6043 & ' +==============================================' 6044 & //'===============================+' 6045 6046 END IF 6047 6048 IF (ROTLEN .AND. (CCS.OR.CC2.OR.CCSD)) THEN 6049 6050 WRITE(LUOSC,'(//A)') 6051 & ' +==============================================' 6052 & //'===============================+' 6053 WRITE(LUOSC,'(1X,A26,A10,A)') 6054 & '| sym. | Exci. | ',MODELP,' Length Gauge Rota' 6055 & //'tory Strength |' 6056 WRITE(LUOSC,'(A)') 6057 & ' |(spin, | +-----------------------------' 6058 & //'-------------------------------+' 6059 WRITE(LUOSC,'(1X,A)') 6060 & '| spat) | | D-55 SI | D-40 cgs ' 6061 & //' | Direction |' 6062 WRITE(LUOSC,'(A)') 6063 & ' +==============================================' 6064 & //'===============================+' 6065 6066 DO ISYM = 1, NSYM 6067 DO IEX = 1, NCCEXCI(ISYM,1) 6068 ISTATE = ISYOFE(ISYM) + IEX 6069 EIGV = EIGVAL(ISTATE) 6070 KTRSI = KROTL + 3*(ISTATE-1) 6071 KSTREN = KCHKL + ISTATE - 1 6072 LCALC = .FALSE. 6073 LDIP = 1 6074 DO IRSD = 1, NXLRSST 6075 ISTATE = ILRSST(IRSD) 6076 ISYME = ISYEXC(ISTATE) 6077 ISTSY = ILRSST(IRSD)-ISYOFE(ISYME) 6078 IF ((ISYME.EQ.ISYM).AND.(IEX.EQ.ISTSY)) LCALC =.TRUE. 6079 END DO 6080 CALL CC_ROTPRI(WORK(KTRSI),WORK(KSTREN),EIGV,IEX,ISYM,MODELP, 6081 & LCALC,LDIP,LUOSC) 6082 6083 END DO 6084 6085 IF (.NOT.((ISYM .EQ. NSYM).OR.(NCCEXCI(ISYM,1).EQ.0))) THEN 6086 NREST = 0 6087 DO ISYM2 = ISYM+1,NSYM 6088 NREST = NREST + NCCEXCI(ISYM2,1) 6089 END DO 6090 IF (NREST.EQ.0) GOTO 9009 6091 WRITE(LUOSC,'(A)') 6092 & ' +----------------------------------------------' 6093 & //'-------------------------------+' 6094 END IF 6095 9009 CONTINUE 6096 END DO 6097 6098 WRITE(LUOSC,'(A)') 6099 & ' +==============================================' 6100 & //'===============================+' 6101 6102 END IF 6103 6104 IF (ROTVEL .AND. (CCS.OR.CC2.OR.CCSD)) THEN 6105 6106 WRITE(LUOSC,'(//A)') 6107 & ' +==============================================' 6108 & //'===============================+' 6109 WRITE(LUOSC,'(1X,A26,A10,A)') 6110 & '| sym. | Exci. | ',MODELP,' Velocity Gauge Rota' 6111 & //'tory Strength |' 6112 WRITE(LUOSC,'(A)') 6113 & ' |(spin, | +-----------------------------' 6114 & //'-------------------------------+' 6115 WRITE(LUOSC,'(1X,A)') 6116 & '| spat) | | D-55 SI | D-40 cgs ' 6117 & //' | Direction |' 6118 WRITE(LUOSC,'(A)') 6119 & ' +==============================================' 6120 & //'===============================+' 6121 6122 DO ISYM = 1, NSYM 6123 DO IEX = 1, NCCEXCI(ISYM,1) 6124 ISTATE = ISYOFE(ISYM) + IEX 6125 EIGV = EIGVAL(ISTATE) 6126 KTRSI = KROTV + 3*(ISTATE-1) 6127 KSTREN = KCHKV + ISTATE - 1 6128 LCALC = .FALSE. 6129 LDIP = 2 6130 DO IRSD = 1, NXLRSST 6131 ISTATE = ILRSST(IRSD) 6132 ISYME = ISYEXC(ISTATE) 6133 ISTSY = ILRSST(IRSD)-ISYOFE(ISYME) 6134 IF ((ISYME.EQ.ISYM).AND.(IEX.EQ.ISTSY)) LCALC =.TRUE. 6135 END DO 6136 CALL CC_ROTPRI(WORK(KTRSI),WORK(KSTREN),EIGV,IEX,ISYM,MODELP, 6137 & LCALC,LDIP,LUOSC) 6138 6139 END DO 6140 6141 IF (.NOT.((ISYM .EQ. NSYM).OR.(NCCEXCI(ISYM,1).EQ.0))) THEN 6142 NREST = 0 6143 DO ISYM2 = ISYM+1,NSYM 6144 NREST = NREST + NCCEXCI(ISYM2,1) 6145 END DO 6146 IF (NREST.EQ.0) GOTO 9010 6147 WRITE(LUOSC,'(A)') 6148 & ' +----------------------------------------------' 6149 & //'-------------------------------+' 6150 END IF 6151 9010 CONTINUE 6152 END DO 6153 6154 WRITE(LUOSC,'(A)') 6155 & ' +==============================================' 6156 & //'===============================+' 6157 6158 END IF 6159 6160 IF (RTNLEN .AND. (CCS.OR.CC2.OR.CCSD)) THEN 6161 6162 WRITE(LUOSC,'(//A)') 6163 & ' +==============================================' 6164 & //'===============================+' 6165 WRITE(LUOSC,'(1X,A26,A10,A)') 6166 & '| sym. | Exci. | ',MODELP,' Length Gauge Rot.' 6167 & //'Str. Tensor, El. Quad.|' 6168 WRITE(LUOSC,'(A)') 6169 & ' |(spin, | +-----------------------------' 6170 & //'-------------------------------+' 6171 WRITE(LUOSC,'(1X,A)') 6172 & '| spat) | | D-55 SI | D-40 cgs ' 6173 & //' | Component |' 6174 WRITE(LUOSC,'(A)') 6175 & ' +==============================================' 6176 & //'===============================+' 6177 6178 DO ISYM = 1, NSYM 6179 DO IEX = 1, NCCEXCI(ISYM,1) 6180 ISTATE = ISYOFE(ISYM) + IEX 6181 EIGV = EIGVAL(ISTATE) 6182 KOFFQ = KRQL + 3*9*(ISTATE-1) 6183 KOFQ2 = KRQL2 + 3*3*(ISTATE-1) 6184 LCALC = .FALSE. 6185 LDIP = 1 6186 DO IRSD = 1, NXLRSST 6187 ISTATE = ILRSST(IRSD) 6188 ISYME = ISYEXC(ISTATE) 6189 ISTSY = ILRSST(IRSD)-ISYOFE(ISYME) 6190 IF ((ISYME.EQ.ISYM).AND.(IEX.EQ.ISTSY)) LCALC =.TRUE. 6191 END DO 6192 CALL CC_RTQPRI(WORK(KOFFQ),WORK(KOFQ2),EIGV,IEX,ISYM,MODELP, 6193 & LCALC,LDIP,LUOSC,NWRL) 6194 6195 END DO 6196 6197 IF (.NOT.((ISYM .EQ. NSYM).OR.(NCCEXCI(ISYM,1).EQ.0))) THEN 6198 NREST = 0 6199 DO ISYM2 = ISYM+1,NSYM 6200 NREST = NREST + NCCEXCI(ISYM2,1) 6201 END DO 6202 IF (NREST.EQ.0) GOTO 9011 6203 WRITE(LUOSC,'(A)') 6204 & ' +----------------------------------------------' 6205 & //'-------------------------------+' 6206 END IF 6207 9011 CONTINUE 6208 END DO 6209 6210 WRITE(LUOSC,'(A)') 6211 & ' +==============================================' 6212 & //'===============================+' 6213 6214 WRITE(LUOSC,'(//A)') 6215 & ' +==============================================' 6216 & //'===============================+' 6217 WRITE(LUOSC,'(1X,A26,A10,A)') 6218 & '| sym. | Exci. | ',MODELP,' Length Gauge Rot.' 6219 & //'Str. Tensor, Mag. Dip.|' 6220 WRITE(LUOSC,'(A)') 6221 & ' |(spin, | +-----------------------------' 6222 & //'-------------------------------+' 6223 WRITE(LUOSC,'(1X,A)') 6224 & '| spat) | | D-55 SI | D-40 cgs ' 6225 & //' | Component |' 6226 WRITE(LUOSC,'(A)') 6227 & ' +==============================================' 6228 & //'===============================+' 6229 6230 DO ISYM = 1, NSYM 6231 DO IEX = 1, NCCEXCI(ISYM,1) 6232 ISTATE = ISYOFE(ISYM) + IEX 6233 EIGV = EIGVAL(ISTATE) 6234 KOFFM = KRML + 3*3*(ISTATE-1) 6235 KOFM2 = KRML2 + 3*3*(ISTATE-1) 6236 KSTREN = KCHKL + ISTATE - 1 6237 LCALC = .FALSE. 6238 LDIP = 1 6239 DO IRSD = 1, NXLRSST 6240 ISTATE = ILRSST(IRSD) 6241 ISYME = ISYEXC(ISTATE) 6242 ISTSY = ILRSST(IRSD)-ISYOFE(ISYME) 6243 IF ((ISYME.EQ.ISYM).AND.(IEX.EQ.ISTSY)) LCALC =.TRUE. 6244 END DO 6245 CALL CC_RTMPRI(WORK(KOFFM),WORK(KOFM2),EIGV,IEX,ISYM,MODELP, 6246 & LCALC,LDIP,LUOSC,WORK(KSTREN),NWRL) 6247 6248 END DO 6249 6250 IF (.NOT.((ISYM .EQ. NSYM).OR.(NCCEXCI(ISYM,1).EQ.0))) THEN 6251 NREST = 0 6252 DO ISYM2 = ISYM+1,NSYM 6253 NREST = NREST + NCCEXCI(ISYM2,1) 6254 END DO 6255 IF (NREST.EQ.0) GOTO 9012 6256 WRITE(LUOSC,'(A)') 6257 & ' +----------------------------------------------' 6258 & //'-------------------------------+' 6259 END IF 6260 9012 CONTINUE 6261 END DO 6262 6263 WRITE(LUOSC,'(A)') 6264 & ' +==============================================' 6265 & //'===============================+' 6266 6267 CALL DAXPY(LRML,1.0D0,WORK(KRQL2),1,WORK(KRML2),1) ! Get total tensor (in KRML2) 6268 6269 WRITE(LUOSC,'(//A)') 6270 & ' +==============================================' 6271 & //'===============================+' 6272 WRITE(LUOSC,'(1X,A26,A10,A)') 6273 & '| sym. | Exci. | ',MODELP,' Length Gauge Rot.' 6274 & //'Str. Tensor, Total |' 6275 WRITE(LUOSC,'(A)') 6276 & ' |(spin, | +-----------------------------' 6277 & //'-------------------------------+' 6278 WRITE(LUOSC,'(1X,A)') 6279 & '| spat) | | D-55 SI | D-40 cgs ' 6280 & //' | Component |' 6281 WRITE(LUOSC,'(A)') 6282 & ' +==============================================' 6283 & //'===============================+' 6284 6285 DO ISYM = 1, NSYM 6286 DO IEX = 1, NCCEXCI(ISYM,1) 6287 ISTATE = ISYOFE(ISYM) + IEX 6288 EIGV = EIGVAL(ISTATE) 6289 KOFM2 = KRML2 + 3*3*(ISTATE-1) 6290 KSTREN = KCHKL + ISTATE - 1 6291 LCALC = .FALSE. 6292 LDIP = 1 6293 DO IRSD = 1, NXLRSST 6294 ISTATE = ILRSST(IRSD) 6295 ISYME = ISYEXC(ISTATE) 6296 ISTSY = ILRSST(IRSD)-ISYOFE(ISYME) 6297 IF ((ISYME.EQ.ISYM).AND.(IEX.EQ.ISTSY)) LCALC =.TRUE. 6298 END DO 6299 CALL CC_RTTPRI(WORK(KOFM2),EIGV,IEX,ISYM,MODELP, 6300 & LCALC,LDIP,LUOSC,WORK(KSTREN),NWRL) 6301 6302 END DO 6303 6304 IF (.NOT.((ISYM .EQ. NSYM).OR.(NCCEXCI(ISYM,1).EQ.0))) THEN 6305 NREST = 0 6306 DO ISYM2 = ISYM+1,NSYM 6307 NREST = NREST + NCCEXCI(ISYM2,1) 6308 END DO 6309 IF (NREST.EQ.0) GOTO 9013 6310 WRITE(LUOSC,'(A)') 6311 & ' +----------------------------------------------' 6312 & //'-------------------------------+' 6313 END IF 6314 9013 CONTINUE 6315 END DO 6316 6317 WRITE(LUOSC,'(A)') 6318 & ' +==============================================' 6319 & //'===============================+' 6320 6321 IF (NWRL .NE. 0) THEN 6322 WRITE(LUOSC,'(//,1X,A,I4,A)') 6323 & '***NOTICE:',NWRL,' warnings issued for Rot. Str. Tensors.' 6324 WRITE(LUOSC,'(1X,A)') 6325 & ' Length gauge tensors are wrong!' 6326 END IF 6327 6328 END IF 6329 6330 IF (RTNVEL .AND. (CCS.OR.CC2.OR.CCSD)) THEN 6331 6332 WRITE(LUOSC,'(//A)') 6333 & ' +==============================================' 6334 & //'===============================+' 6335 WRITE(LUOSC,'(1X,A26,A10,A)') 6336 & '| sym. | Exci. | ',MODELP,' Velocity Gauge Rot.' 6337 & //'Str. Tensor, El. Quad.|' 6338 WRITE(LUOSC,'(A)') 6339 & ' |(spin, | +-----------------------------' 6340 & //'-------------------------------+' 6341 WRITE(LUOSC,'(1X,A)') 6342 & '| spat) | | D-55 SI | D-40 cgs ' 6343 & //' | Component |' 6344 WRITE(LUOSC,'(A)') 6345 & ' +==============================================' 6346 & //'===============================+' 6347 6348 DO ISYM = 1, NSYM 6349 DO IEX = 1, NCCEXCI(ISYM,1) 6350 ISTATE = ISYOFE(ISYM) + IEX 6351 EIGV = EIGVAL(ISTATE) 6352 KOFFQ = KRQV + 3*9*(ISTATE-1) 6353 KOFQ2 = KRQV2 + 3*3*(ISTATE-1) 6354 LCALC = .FALSE. 6355 LDIP = 2 6356 DO IRSD = 1, NXLRSST 6357 ISTATE = ILRSST(IRSD) 6358 ISYME = ISYEXC(ISTATE) 6359 ISTSY = ILRSST(IRSD)-ISYOFE(ISYME) 6360 IF ((ISYME.EQ.ISYM).AND.(IEX.EQ.ISTSY)) LCALC =.TRUE. 6361 END DO 6362 CALL CC_RTQPRI(WORK(KOFFQ),WORK(KOFQ2),EIGV,IEX,ISYM,MODELP, 6363 & LCALC,LDIP,LUOSC,NWRV) 6364 6365 END DO 6366 6367 IF (.NOT.((ISYM .EQ. NSYM).OR.(NCCEXCI(ISYM,1).EQ.0))) THEN 6368 NREST = 0 6369 DO ISYM2 = ISYM+1,NSYM 6370 NREST = NREST + NCCEXCI(ISYM2,1) 6371 END DO 6372 IF (NREST.EQ.0) GOTO 9014 6373 WRITE(LUOSC,'(A)') 6374 & ' +----------------------------------------------' 6375 & //'-------------------------------+' 6376 END IF 6377 9014 CONTINUE 6378 END DO 6379 6380 WRITE(LUOSC,'(A)') 6381 & ' +==============================================' 6382 & //'===============================+' 6383 6384 WRITE(LUOSC,'(//A)') 6385 & ' +==============================================' 6386 & //'===============================+' 6387 WRITE(LUOSC,'(1X,A26,A10,A)') 6388 & '| sym. | Exci. | ',MODELP,' Velocity Gauge Rot.' 6389 & //'Str. Tensor, Mag. Dip.|' 6390 WRITE(LUOSC,'(A)') 6391 & ' |(spin, | +-----------------------------' 6392 & //'-------------------------------+' 6393 WRITE(LUOSC,'(1X,A)') 6394 & '| spat) | | D-55 SI | D-40 cgs ' 6395 & //' | Component |' 6396 WRITE(LUOSC,'(A)') 6397 & ' +==============================================' 6398 & //'===============================+' 6399 6400 DO ISYM = 1, NSYM 6401 DO IEX = 1, NCCEXCI(ISYM,1) 6402 ISTATE = ISYOFE(ISYM) + IEX 6403 EIGV = EIGVAL(ISTATE) 6404 KOFFM = KRMV + 3*3*(ISTATE-1) 6405 KOFM2 = KRMV2 + 3*3*(ISTATE-1) 6406 KSTREN = KCHKV + ISTATE - 1 6407 LCALC = .FALSE. 6408 LDIP = 2 6409 DO IRSD = 1, NXLRSST 6410 ISTATE = ILRSST(IRSD) 6411 ISYME = ISYEXC(ISTATE) 6412 ISTSY = ILRSST(IRSD)-ISYOFE(ISYME) 6413 IF ((ISYME.EQ.ISYM).AND.(IEX.EQ.ISTSY)) LCALC =.TRUE. 6414 END DO 6415 CALL CC_RTMPRI(WORK(KOFFM),WORK(KOFM2),EIGV,IEX,ISYM,MODELP, 6416 & LCALC,LDIP,LUOSC,WORK(KSTREN),NWRV) 6417 6418 END DO 6419 6420 IF (.NOT.((ISYM .EQ. NSYM).OR.(NCCEXCI(ISYM,1).EQ.0))) THEN 6421 NREST = 0 6422 DO ISYM2 = ISYM+1,NSYM 6423 NREST = NREST + NCCEXCI(ISYM2,1) 6424 END DO 6425 IF (NREST.EQ.0) GOTO 9015 6426 WRITE(LUOSC,'(A)') 6427 & ' +----------------------------------------------' 6428 & //'-------------------------------+' 6429 END IF 6430 9015 CONTINUE 6431 END DO 6432 6433 WRITE(LUOSC,'(A)') 6434 & ' +==============================================' 6435 & //'===============================+' 6436 6437 CALL DAXPY(LRMV,1.0D0,WORK(KRQV2),1,WORK(KRMV2),1) ! Get total tensor (in KRMV2) 6438 6439 WRITE(LUOSC,'(//A)') 6440 & ' +==============================================' 6441 & //'===============================+' 6442 WRITE(LUOSC,'(1X,A26,A10,A)') 6443 & '| sym. | Exci. | ',MODELP,' Velocity Gauge Rot.' 6444 & //'Str. Tensor, Total |' 6445 WRITE(LUOSC,'(A)') 6446 & ' |(spin, | +-----------------------------' 6447 & //'-------------------------------+' 6448 WRITE(LUOSC,'(1X,A)') 6449 & '| spat) | | D-55 SI | D-40 cgs ' 6450 & //' | Component |' 6451 WRITE(LUOSC,'(A)') 6452 & ' +==============================================' 6453 & //'===============================+' 6454 6455 DO ISYM = 1, NSYM 6456 DO IEX = 1, NCCEXCI(ISYM,1) 6457 ISTATE = ISYOFE(ISYM) + IEX 6458 EIGV = EIGVAL(ISTATE) 6459 KOFM2 = KRMV2 + 3*3*(ISTATE-1) 6460 KSTREN = KCHKV + ISTATE - 1 6461 LCALC = .FALSE. 6462 LDIP = 2 6463 DO IRSD = 1, NXLRSST 6464 ISTATE = ILRSST(IRSD) 6465 ISYME = ISYEXC(ISTATE) 6466 ISTSY = ILRSST(IRSD)-ISYOFE(ISYME) 6467 IF ((ISYME.EQ.ISYM).AND.(IEX.EQ.ISTSY)) LCALC =.TRUE. 6468 END DO 6469 CALL CC_RTTPRI(WORK(KOFM2),EIGV,IEX,ISYM,MODELP, 6470 & LCALC,LDIP,LUOSC,WORK(KSTREN),NWRV) 6471 6472 END DO 6473 6474 IF (.NOT.((ISYM .EQ. NSYM).OR.(NCCEXCI(ISYM,1).EQ.0))) THEN 6475 NREST = 0 6476 DO ISYM2 = ISYM+1,NSYM 6477 NREST = NREST + NCCEXCI(ISYM2,1) 6478 END DO 6479 IF (NREST.EQ.0) GOTO 9016 6480 WRITE(LUOSC,'(A)') 6481 & ' +----------------------------------------------' 6482 & //'-------------------------------+' 6483 END IF 6484 9016 CONTINUE 6485 END DO 6486 6487 WRITE(LUOSC,'(A)') 6488 & ' +==============================================' 6489 & //'===============================+' 6490 6491 IF (NWRV .NE. 0) THEN 6492 WRITE(LUOSC,'(//,1X,A,I4,A)') 6493 & '***NOTICE:',NWRV,' warnings issued for Rot. Str. Tensors.' 6494 WRITE(LUOSC,'(1X,A)') 6495 & ' Velocity gauge tensors are wrong!' 6496 END IF 6497 6498 END IF 6499 6500 6501 IF (ROTLEN .OR. ROTVEL .OR. RTNLEN .OR. RTNVEL) THEN 6502 WRITE(LUOSC,'(/,1X,A)') 6503 & 'Conversion factors for rotatory strengths:' 6504 WRITE(LUOSC,'(3X,A,F15.10,A)') 6505 & 'SI units: 1 a.u. = ',RAUSI,'D-55 A^2 m^3 s' 6506 WRITE(LUOSC,'(3X,A,F15.10,A)') 6507 & 'cgs units: 1 a.u. = ',RAUCGS,'D-40 cm^5 g s^-2' 6508 END IF 6509!mean exc energy - stopping power - Sonia 6510 IF (SUMRULES) THEN 6511 CALL HEADER('CC Oscillator strength sum rules',30) 6512 WRITE (LUPRI,'(//,14X,A,/,6X,A,5X,A,3X,A,3X,A,6X,A,/)') 6513 & 'S(K) Sum Rules : Dipole Length Approximation in a.u.', 6514 & 'K','xx - component','yy - component','zz - component','total' 6515 WRITE (LUPRI,'(9(5X,I3,4(4X,G13.6)/))') 6516 & (K,(DSSUML(K,J),J=1,4),K=-6,2) 6517 WRITE (LUPRI,'(//,14X,A,/,6X,A,5X,A,3X,A,3X,A,6X,A,/)') 6518 & 'L(K) Sum Rules : Dipole Length Approximation in a.u.', 6519 & 'K','xx - component','yy - component','zz - component','total' 6520 WRITE (LUPRI,'(9(5X,I3,4(4X,G13.6)/))') 6521 & (K,(DLSUML(K,J),J=1,4),K=-6,2) 6522 WRITE (LUPRI,'(//,14X,A,/,6X,A,5X,A,3X,A,3X,A,6X,A,/)') 6523 & 'I(K) Sum Rules : Dipole Length Approximation in eV', 6524 & 'K','xx - component','yy - component','zz - component','total' 6525 WRITE (LUPRI,'(9(5X,I3,4(4X,G13.6)/))') 6526 & (K,(DISUML(K,J),J=1,4),K=-6,2) 6527 END IF 6528!end of mex 6529 6530C Print timings and exit. 6531C ----------------------- 6532 6533 999 TIMTOT = SECOND() - TIMTOT 6534 WRITE(LUPRI,'(/,1X,A,I7,A,F10.2,A)') 6535 & ' Total time for',NTOT,' linear response residues: ', 6536 & TIMTOT,' seconds.' 6537 CALL FLSHFO(LUPRI) 6538 6539 CALL QEXIT(SECNAM) 6540 6541 RETURN 6542 END 6543C /* Deck ilres */ 6544 INTEGER FUNCTION ILRES(LABEL,LIST) 6545C 6546C Thomas Bondo Pedersen, July 2003. 6547C 6548C Purpose: Find the first index of the operator LABEL on the residue 6549C list indicated by LIST ('A' or 'B') for which the total 6550C residue is symmetry--allowed. 6551C If LABEL is not on the list, ILRES = -1 6552C If LIST is illegal, ILRES = -2. 6553C 6554#include "implicit.h" 6555 CHARACTER*8 LABEL 6556 CHARACTER*1 LIST 6557#include "cclres.h" 6558#include "ccroper.h" 6559 6560 CHARACTER*8 LOCLAB 6561 6562 ILRES = -1 6563 6564 IF (LIST .EQ. 'A') THEN 6565 6566 DO IOPER = 1,NLRSOP 6567 LOCLAB = LBLOPR(IALRSOP(IOPER)) 6568 IF (LABEL(1:8) .EQ. LOCLAB(1:8)) THEN 6569 ISYMA = ISYOPR(IALRSOP(IOPER)) 6570 ISYMB = ISYOPR(IBLRSOP(IOPER)) 6571 IF (ISYMA .EQ. ISYMB) THEN 6572 ILRES = IOPER 6573 RETURN 6574 END IF 6575 END IF 6576 END DO 6577 6578 ELSE IF (LIST .EQ. 'B') THEN 6579 6580 DO IOPER = 1,NLRSOP 6581 LOCLAB = LBLOPR(IBLRSOP(IOPER)) 6582 IF (LABEL(1:8) .EQ. LOCLAB(1:8)) THEN 6583 ISYMA = ISYOPR(IALRSOP(IOPER)) 6584 ISYMB = ISYOPR(IBLRSOP(IOPER)) 6585 IF (ISYMA .EQ. ISYMB) THEN 6586 ILRES = IOPER 6587 RETURN 6588 END IF 6589 END IF 6590 END DO 6591 6592 ELSE 6593 6594 ILRES = -2 6595 6596 END IF 6597 6598 RETURN 6599 END 6600C /* Deck cc_trreta */ 6601 SUBROUTINE CC_TRRETA(ISYMA,LABELA,TRRMOM,ETA,WORK,LWORK,MODEL) 6602C 6603C Thomas Bondo Pedersen, July 2003. 6604C 6605C Purpose: Calculate etaA*RE contributions to right ground-excited 6606C state transition moments for all excited states of matching 6607C symmetry. 6608C 6609#include "implicit.h" 6610 DIMENSION TRRMOM(*), ETA(*), WORK(LWORK) 6611 CHARACTER*8 LABELA 6612 CHARACTER*10 MODEL 6613#include "ccorb.h" 6614#include "ccsdsym.h" 6615#include "ccsdinp.h" 6616#include "priunit.h" 6617#include "cclres.h" 6618#include "ccexci.h" 6619 6620 CHARACTER*9 SECNAM 6621 PARAMETER (SECNAM = 'CC_TRRETA') 6622 6623C Allocation. 6624C ----------- 6625 6626 NTAMP = NT1AM(ISYMA) 6627 IF (.NOT. CCS) NTAMP = NTAMP + NT2AM(ISYMA) 6628 6629 KRE1 = 1 6630 KRE2 = KRE1 + NT1AM(ISYMA) 6631 IF (CCS) THEN 6632 KEND = KRE2 6633 ELSE 6634 KEND = KRE2 + NT2AM(ISYMA) 6635 END IF 6636 LWRK = LWORK - KEND + 1 6637 6638 IF (LWRK .LT. 0) THEN 6639 CALL QUIT('Insufficient memory in '//SECNAM) 6640 END IF 6641 6642C Loop over requested excited states. 6643C ----------------------------------- 6644 6645 DO IRSD = 1,NXLRSST 6646 6647 ISTATE = ILRSST(IRSD) 6648 ISYME = ISYEXC(ISTATE) 6649 6650 IF (ISYME .EQ. ISYMA) THEN 6651 6652C Calculate contribution. 6653C ----------------------- 6654 6655 IOPT = 3 6656 CALL CC_RDRSP('RE',ISTATE,ISYMA,IOPT,MODEL,WORK(KRE1), 6657 & WORK(KRE2)) 6658 6659 CONTR = DDOT(NTAMP,ETA,1,WORK(KRE1),1) 6660 6661 TRRMOM(IRSD) = TRRMOM(IRSD) + CONTR 6662 6663 IF (IPRINT .GT. 2) THEN 6664 ISTSY = ISTATE - ISYOFE(ISYME) 6665 WRITE(LUPRI,'(1X,A1,A8,A3,A,F12.6,A,I3,A,I2,A)') 6666 & '<',LABELA,'|f>',' EtaA*RE cont. = ',CONTR, 6667 & ' (f:',ISTSY,' of sym.',ISYME,')' 6668 END IF 6669 6670 END IF 6671 6672 END DO 6673 6674 RETURN 6675 END 6676C /* Deck cc_trlksi */ 6677 SUBROUTINE CC_TRLKSI(ISYMA,LABELA,TRLMOM,XKSI,WORK,LWORK,MODEL) 6678C 6679C Thomas Bondo Pedersen, July 2003. 6680C 6681C Purpose: Calculate LE*ksiA contributions to left ground-excited 6682C state transition moments for all excited states of matching 6683C symmetry. 6684C 6685#include "implicit.h" 6686 DIMENSION TRLMOM(*), XKSI(*), WORK(LWORK) 6687 CHARACTER*8 LABELA 6688 CHARACTER*10 MODEL 6689#include "ccorb.h" 6690#include "ccsdsym.h" 6691#include "ccsdinp.h" 6692#include "priunit.h" 6693#include "cclres.h" 6694#include "ccexci.h" 6695 6696 CHARACTER*9 SECNAM 6697 PARAMETER (SECNAM = 'CC_TRLKSI') 6698 6699C Allocation. 6700C ----------- 6701 6702 NTAMP = NT1AM(ISYMA) 6703 IF (.NOT. CCS) NTAMP = NTAMP + NT2AM(ISYMA) 6704 6705 KLE1 = 1 6706 KLE2 = KLE1 + NT1AM(ISYMA) 6707 IF (CCS) THEN 6708 KEND = KLE2 6709 ELSE 6710 KEND = KLE2 + NT2AM(ISYMA) 6711 END IF 6712 LWRK = LWORK - KEND + 1 6713 6714 IF (LWRK .LT. 0) THEN 6715 CALL QUIT('Insufficient memory in '//SECNAM) 6716 END IF 6717 6718C Loop over requested excited states. 6719C ----------------------------------- 6720 6721 DO IRSD = 1,NXLRSST 6722 6723 ISTATE = ILRSST(IRSD) 6724 ISYME = ISYEXC(ISTATE) 6725 6726 IF (ISYME .EQ. ISYMA) THEN 6727 6728C Calculate contribution. 6729C ----------------------- 6730 6731 IOPT = 3 6732 CALL CC_RDRSP('LE',ISTATE,ISYMA,IOPT,MODEL,WORK(KLE1), 6733 & WORK(KLE2)) 6734 6735 CONTR = DDOT(NTAMP,WORK(KLE1),1,XKSI,1) 6736 6737 TRLMOM(IRSD) = TRLMOM(IRSD) + CONTR 6738 6739 IF (IPRINT .GT. 2) THEN 6740 ISTSY = ISTATE - ISYOFE(ISYME) 6741 WRITE(LUPRI,'(1X,A3,A8,A1,A,F12.6,A,I3,A,I2,A)') 6742 & '<f|',LABELA,'>',' LE*ksiA cont. = ',CONTR, 6743 & ' (f:',ISTSY,' of sym.',ISYME,')' 6744 END IF 6745 6746 END IF 6747 6748 END DO 6749 6750 RETURN 6751 END 6752C /* Deck cc_trrksi */ 6753 SUBROUTINE CC_TRRKSI(ISYMA,LABELA,TRRMOM,XKSI,WORK,LWORK,MODEL) 6754C 6755C Thomas Bondo Pedersen, July 2003. 6756C 6757C Purpose: Calculate Mf*ksiA contributions to right ground-excited 6758C state transition moments for all excited states of matching 6759C symmetry. 6760C 6761#include "implicit.h" 6762 DIMENSION TRRMOM(*), XKSI(*), WORK(LWORK) 6763 CHARACTER*8 LABELA 6764 CHARACTER*10 MODEL 6765#include "ccorb.h" 6766#include "ccsdsym.h" 6767#include "ccsdinp.h" 6768#include "priunit.h" 6769#include "cclres.h" 6770#include "ccexci.h" 6771 6772 CHARACTER*9 SECNAM 6773 PARAMETER (SECNAM = 'CC_TRRKSI') 6774 6775C Allocation. 6776C ----------- 6777 6778 NTAMP = NT1AM(ISYMA) 6779 IF (.NOT. CCS) NTAMP = NTAMP + NT2AM(ISYMA) 6780 6781 KMF1 = 1 6782 KMF2 = KMF1 + NT1AM(ISYMA) 6783 IF (CCS) THEN 6784 KEND = KMF2 6785 ELSE 6786 KEND = KMF2 + NT2AM(ISYMA) 6787 END IF 6788 LWRK = LWORK - KEND + 1 6789 6790 IF (LWRK .LT. 0) THEN 6791 CALL QUIT('Insufficient memory in '//SECNAM) 6792 END IF 6793 6794C Loop over requested excited states. 6795C ----------------------------------- 6796 6797 DO IRSD = 1,NXLRSST 6798 6799 ISTATE = ILRSST(IRSD) 6800 ISYME = ISYEXC(ISTATE) 6801 6802 IF (ISYME .EQ. ISYMA) THEN 6803 6804C Calculate contribution. 6805C ----------------------- 6806 6807 IOPT = 3 6808 ILSTNR = ILRMAMP(ISTATE,EIGVAL(ISTATE),ISYMA) 6809 CALL CC_RDRSP('M1',ILSTNR,ISYMA,IOPT,MODEL,WORK(KMF1), 6810 & WORK(KMF2)) 6811 6812 CONTR = DDOT(NTAMP,WORK(KMF1),1,XKSI,1) 6813 6814 TRRMOM(IRSD) = TRRMOM(IRSD) + CONTR 6815 6816 IF (IPRINT .GT. 2) THEN 6817 ISTSY = ISTATE - ISYOFE(ISYME) 6818 WRITE(LUPRI,'(1X,A1,A8,A3,A,F12.6,A,I3,A,I2,A)') 6819 & '<',LABELA,'|f>',' Mf*ksiA cont. = ',CONTR, 6820 & ' (f:',ISTSY,' of sym.',ISYME,')' 6821 END IF 6822 6823 END IF 6824 6825 END DO 6826 6827 RETURN 6828 END 6829C /* Deck cc_trrfta */ 6830 SUBROUTINE CC_TRRFTA(ISYMA,LABELA,TRRMOM,WORK,LWORK,MODEL) 6831C 6832C Thomas Bondo Pedersen, July 2003. 6833C 6834C Purpose: Calculate [F*tA(-wf)]*RE contributions to right ground-excited 6835C state transition moments for all excited states of matching 6836C symmetry. 6837C 6838#include "implicit.h" 6839 DIMENSION TRRMOM(*), WORK(LWORK) 6840 CHARACTER*8 LABELA 6841 CHARACTER*10 MODEL 6842#include "ccorb.h" 6843#include "ccsdsym.h" 6844#include "ccsdinp.h" 6845#include "priunit.h" 6846#include "cclres.h" 6847#include "ccexci.h" 6848 6849 CHARACTER*9 SECNAM 6850 PARAMETER (SECNAM = 'CC_TRRFTA') 6851 6852C Allocation. 6853C ----------- 6854 6855 NTAMP = NT1AM(ISYMA) 6856 IF (.NOT. CCS) NTAMP = NTAMP + NT2AM(ISYMA) 6857 6858 KFTA = 1 6859 KRE = KFTA + NTAMP 6860 KEND = KRE + NTAMP 6861 LWRK = LWORK - KEND + 1 6862 6863 IF (LWRK .LT. 0) THEN 6864 CALL QUIT('Insufficient memory in '//SECNAM) 6865 END IF 6866 6867 KFTA1 = KFTA 6868 KFTA2 = KFTA + NT1AM(ISYMA) 6869 KRE1 = KRE 6870 KRE2 = KRE + NT1AM(ISYMA) 6871 6872C Loop over requested excited states. 6873C ----------------------------------- 6874 6875 DO IRSD = 1,NXLRSST 6876 6877 ISTATE = ILRSST(IRSD) 6878 ISYME = ISYEXC(ISTATE) 6879 6880 IF (ISYME .EQ. ISYMA) THEN 6881 6882C Calculate contribution. 6883C ----------------------- 6884 6885 IOPT = 3 6886 ILSTNR = IR1TAMP(LABELA,.FALSE.,-EIGVAL(ISTATE),ISYMA) 6887 CALL CC_RDRSP('F1',ILSTNR,ISYMA,IOPT,MODEL,WORK(KFTA1), 6888 & WORK(KFTA2)) 6889 IOPT = 3 6890 CALL CC_RDRSP('RE',ISTATE,ISYMA,IOPT,MODEL,WORK(KRE1), 6891 & WORK(KRE2)) 6892 6893 CONTR = DDOT(NTAMP,WORK(KFTA),1,WORK(KRE),1) 6894 6895 TRRMOM(IRSD) = TRRMOM(IRSD) + CONTR 6896 6897 IF (IPRINT .GT. 2) THEN 6898 ISTSY = ISTATE - ISYOFE(ISYME) 6899 WRITE(LUPRI,'(1X,A1,A8,A3,A,F12.6,A,I3,A,I2,A)') 6900 & '<',LABELA,'|f>',' [F*tA(-wf)]*RE cont. = ',CONTR, 6901 & ' (f:',ISTSY,' of sym.',ISYME,')' 6902 END IF 6903 6904 END IF 6905 6906 END DO 6907 6908 RETURN 6909 END 6910c*DECK WRIPRO 6911 SUBROUTINE WRIPRO(PROP,LABEL,NORD,LABX,LABY,LABZ,LABU, 6912 * FRQY,FRQZ,FRQU,ISYMIN,ISYMEX,ISPINEX,IEX) 6913C 6914C----------------------------------------------------------------------------- 6915C 6916C Purpose: Add response property to list of property information to be 6917C passed to numerical differentiation/averaging. 6918C 6919C Ove Christiansen August 1999. 6920C 6921C NORD = 0 energy (ground or excited) 6922C 1 exp. value 6923C 2 Linear response function 6924C 3 Quadratic response function 6925C 4 Cubic response function 6926C -1 ground - excited transition matrix element, <0|x|i> 6927C -2 excited - excited transition matrix element, |<i|x|f>| 6928C -11 First order excited state property, <i|x|i> 6929C -20 <0|x|i><i|y|0> 6930C -21 w*<0|x|i><i|y|0> 6931C -22 (w_f - w_i)*|<i|x|f>|^2 6932C -30 D_pa 6933C -31 D_pe 6934C -32 D_pc 6935C -33 w1w2D_pa 6936C -34 w1w2D_pe 6937C -35 w1w2D_pc 6938C -400 oscillator strength 6939C 401 chemical shielding isotropic 6940C 402 chemical shielding tensor 6941C----------------------------------------------------------------------------- 6942C 6943#include "implicit.h" 6944#include "maxorb.h" 6945C 6946#include "dummy.h" 6947#include "iratdef.h" 6948#include "priunit.h" 6949#include "cclr.h" 6950#include "ccorb.h" 6951#include "ccsdsym.h" 6952#include "ccsdio.h" 6953#include "ccsdinp.h" 6954#include "prpc.h" 6955#include "inftap.h" 6956C 6957 LOGICAL EXIST,L1,L2,L3,L4,LI1,LI2 6958 PARAMETER (TOLFRQ=1.0D-08,ONE=1.0D0,XMONE=-1.0D0,TOLEXCI =1.0D-02) 6959C 6960 CHARACTER LABEL*10, LABX*8, LABY*8, LABZ*8, LABU*8 6961C 6962C-------------------------------------------------- 6963C 6964C 6965 IF (NOEONL .AND. (NORD.EQ.0)) THEN 6966C if energy and NOEONList = true then skip addition to list. 6967 RETURN 6968 ELSE 6969 EXIST = .FALSE. 6970 IF (EXIST) THEN 6971c IPRMI = IHIT 6972 ELSE 6973 NPRMI = NPRMI + 1 6974 IPRMI = NPRMI 6975 ENDIF 6976C 6977 WRITE(LUNDPF, 6978 * '(I5,I3,I4,1X,A10,E23.16,4(1X,A8),3E23.16,3I4)') 6979 * IPRMI,ISYMIN,NORD,LABEL,PROP, 6980 * LABX,LABY,LABZ,LABU,FRQY,FRQZ,FRQU,ISYMEX,ISPINEX,IEX 6981 WRITE(LUNMPF, 6982 * '(I5,I3,I4,1X,A10,E23.16,4(1X,A8),3E23.16,3I4)') 6983 * IPRMI,ISYMIN,NORD,LABEL,PROP, 6984 * LABX,LABY,LABZ,LABU,FRQY,FRQZ,FRQU,ISYMEX,ISPINEX,IEX 6985 ENDIF 6986C 6987 END 6988 SUBROUTINE stripblanks(tobestripped) 6989#include "priunit.h" 6990c 6991c mbh: transform nuclei string, e.g. 'C0 1' into 6992c 'C0_1 ' 6993c 6994 character tobestripped*8,helper*8,lastchar*1 6995 integer i,j,idx 6996c 6997 idx=1 6998 helper=' ' 6999 ! write(lupri,*)'String on input: "',tobestripped,'"' 7000c 7001c strip all blanks from beginning 7002c 7003 do 10 i=1,8 7004 if(tobestripped(i:i).ne.' ') goto 15 700510 continue 700615 continue 7007c 7008c add to helper until we hit a blank again 7009c 7010 do 20 j=i,8 7011 if(tobestripped(j:j).ne.' ') then 7012 helper(idx:idx)=tobestripped(j:j) 7013 else 7014 goto 25 7015 endif 7016 idx=idx+1 701720 continue 701825 continue 7019 helper(idx:idx)='_' 7020 lastchar='_' 7021 idx=idx+1 7022c 7023c strip all blanks from here to next 'item' 7024c 7025 do 30 i=j,8 7026 if(tobestripped(i:i).ne.' ') then 7027 helper(idx:idx)=tobestripped(i:i) 7028 lastchar=tobestripped(i:i) 7029 idx=idx+1 7030 endif 703130 continue 7032 if(lastchar.eq.'_') helper(idx-1:idx-1)=' ' 7033 ! write(lupri,*)'String on input: "',helper,'"' 7034 tobestripped=helper 7035 end 7036C-------------------------------------------------------------- 7037 7038C /* Deck cc_eomtrrksi */ 7039 SUBROUTINE CC_eomTRRKSI(ISYMA,LABELA,TRRMOM,XKSI,WORK,LWORK,MODEL) 7040C 7041C Sonia, 2016 7042C 7043C Purpose: Calculate (tbar0*RE)*(tbar0*ksiA) 7044C contributions to left ground-excited 7045C state EOM transition moments for all excited states of matching 7046C symmetry. 7047C 7048#include "implicit.h" 7049 DIMENSION TRRMOM(*), XKSI(*), WORK(LWORK) 7050 CHARACTER*8 LABELA 7051 CHARACTER*10 MODEL 7052#include "ccorb.h" 7053#include "ccsdsym.h" 7054#include "ccsdinp.h" 7055#include "priunit.h" 7056#include "cclres.h" 7057#include "ccexci.h" 7058 7059 CHARACTER*9 SECNAM 7060 PARAMETER (SECNAM = 'CC_eomTRRKSI') 7061 7062C Allocation. 7063C ----------- 7064 7065 NTAMP = NT1AM(ISYMA) 7066 IF (.NOT. CCS) NTAMP = NTAMP + NT2AM(ISYMA) 7067 7068 KTBAR01 = 1 7069 KTBAR02 = KTBAR01 + NT1AM(1) 7070 IF (CCS) THEN 7071 KEND = KTBAR02 7072 ELSE 7073 KEND = KTBAR02 + NT2AM(1) 7074 END IF 7075 KMF1 = KEND 7076 KMF2 = KMF1 + NT1AM(ISYMA) 7077 IF (CCS) THEN 7078 KEND = KMF2 7079 ELSE 7080 KEND = KMF2 + NT2AM(ISYMA) 7081 END IF 7082 LWRK = LWORK - KEND + 1 7083 7084 IF (LWRK .LT. 0) THEN 7085 CALL QUIT('Insufficient memory in '//SECNAM) 7086 END IF 7087 7088 IOPT = 3 7089 ILSTNR = 0 7090 CALL CC_RDRSP('L0',0,1,IOPT,MODEL,WORK(KTBAR01), 7091 & WORK(KTBAR02)) 7092! 7093! Loop over requested excited states. 7094! ----------------------------------- 7095 7096 DO IRSD = 1,NXLRSST 7097 7098 ISTATE = ILRSST(IRSD) 7099 ISYME = ISYEXC(ISTATE) 7100 7101 IF (ISYME .EQ. ISYMA) THEN 7102 7103C Calculate contribution. 7104C ----------------------- 7105 7106 IOPT = 3 7107 !ILSTNR = ILRMAMP(ISTATE,EIGVAL(ISTATE),ISYMA) 7108 ILSTNR = ISTATE 7109 CALL CC_RDRSP('RE',ILSTNR,ISYMA,IOPT,MODEL,WORK(KMF1), 7110 & WORK(KMF2)) 7111 7112 if (isyme.eq.1) then 7113 CONST = DDOT(NTAMP,WORK(KMF1),1,WORK(KTBAR01),1) 7114 !write(lupri,*)'The constant TB0*RE', CONST 7115 CONTR = DDOT(NTAMP,WORK(KTBAR01),1,XKSI,1) 7116 !write(lupri,*)'The TB0*Csi^A', CONTR 7117 !write(lupri,*)'TB0*Csi^A * TB0*RE', CONTR*CONST 7118 !write(lupri,*)'Final contrib', CONTR*CONST 7119 !write(lupri,*)'' 7120 else 7121 !call quit('CC_EOMTRRKSI: SYMMETRY NOT WORKING') 7122 contr=zero 7123 const=zero 7124 write(lupri,*)'TB0*Csi^A * TB0*RE zero for this irrep' 7125 end if 7126 !write(lupri,*)'TRRMOM before', TRRMOM(IRSD) 7127 TRRMOM(IRSD) = TRRMOM(IRSD) - CONTR*CONST 7128 !write(lupri,*)'TRRMOM after', TRRMOM(IRSD) 7129 7130 IF (IPRINT .GT. 2) THEN 7131 ISTSY = ISTATE - ISYOFE(ISYME) 7132 WRITE(LUPRI,'(1X,A1,A8,A3,A,F12.6,A,I3,A,I2,A)') 7133 & '<',LABELA,'|f>','(tb0*RE)(tb0*ksiA) cont. =',CONTR*CONST, 7134 & ' (f:',ISTSY,' of sym.',ISYME,')' 7135 END IF 7136 7137 END IF 7138 7139 END DO 7140 7141 RETURN 7142 END 7143