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 ccexlr */ 20*=====================================================================* 21 SUBROUTINE CC_EXLR(WORK,LWORK) 22*---------------------------------------------------------------------* 23* 24* Excited state linear response section: 25* 26* -- excited state linear response properties 27* -- two-photon transition moments between two excited states 28* 29 30* Written by Christof Haettig summer 1997. 31* Some restructuring and updates for CC3, october 2003, C. Haettig 32* 33*=====================================================================* 34#if defined (IMPLICIT_NONE) 35 IMPLICIT NONE 36#else 37# include "implicit.h" 38#endif 39#include "priunit.h" 40#include "dummy.h" 41#include "ccsdinp.h" 42#include "ccorb.h" 43#include "ccsdsym.h" 44#include "ccexlrinf.h" 45#include "ccroper.h" 46#include "ccr1rsp.h" 47#include "ccer1rsp.h" 48#include "ccel1rsp.h" 49#include "ccn2rsp.h" 50#include "cco2rsp.h" 51#include "cclists.h" 52#include "second.h" 53 54* local parameters: 55 CHARACTER*(16) MSGDBG 56 PARAMETER (MSGDBG = '[debug] CCEXLR> ') 57 LOGICAL LOCDBG 58 PARAMETER (LOCDBG = .FALSE. ) 59 60 INTEGER LWORK 61 62#if defined (SYS_CRAY) 63 REAL WORK(LWORK) 64 REAL TIM0, TIM1, TIMG, TIMF, TIMB 65 REAL TIMFA, TIMAA, TIMEA, TIMO 66 REAL ZERO 67#else 68 DOUBLE PRECISION WORK(LWORK) 69 DOUBLE PRECISION TIM0, TIM1, TIMG, TIMF, TIMB 70 DOUBLE PRECISION TIMFA, TIMAA, TIMEA, TIMO 71 DOUBLE PRECISION ZERO 72#endif 73 PARAMETER ( ZERO = 0.0d0 ) 74 75 INTEGER NBEXLR, MXTRAN, MXVEC 76 INTEGER MXGTRAN, MXFTRAN, MXF1TRAN, MXFATRAN, MXEATRAN, MXOTRAN 77 INTEGER MXGDOTS, MXFDOTS, MXF1DOTS, MXFADOTS, MXEADOTS, MXODOTS 78 INTEGER NGTRAN, NFTRAN, NF1TRAN, NFATRAN, NEATRAN, NOTRAN 79 INTEGER KGTRAN, KFTRAN, KF1TRAN, KFATRAN, KEATRAN, KOTRAN 80 INTEGER KGDOTS, KFDOTS, KF1DOTS, KFADOTS, KEADOTS, KODOTS 81 INTEGER KGCONS, KFCONS, KF1CONS, KFACONS, KEACONS, KOCONS 82 INTEGER NAATRAN, KAATRAN, KAADOTS, KAACONS 83 INTEGER KEND0, LEND0, KEXLRPRP, IOPT, IORDER 84 85* external functions 86 87*---------------------------------------------------------------------* 88* print header for hyperpolarizability section 89*---------------------------------------------------------------------* 90 WRITE (LUPRI,'(7(/1X,2A),/)') 91 & '************************************', 92 & '*******************************', 93 & '* ', 94 & ' *', 95 & '*-------- OUTPUT FROM COUPLED CLU', 96 & 'STER EXCITED STATE ---------*', 97 & '* ', 98 & ' *', 99 & '*-------- LINEAR RESPONSE', 100 & ' SECTION ---------*', 101 & '* ', 102 & ' *', 103 & '************************************', 104 & '*******************************' 105 106*---------------------------------------------------------------------* 107 IF (.NOT. (CCS .OR. CC2 .OR. CCSD .OR. CC3) ) THEN 108 CALL QUIT('CCEXLR called for unknown Coupled Cluster.') 109 END IF 110 111* print some debug/info output 112 IF (IPRINT .GT. 10) WRITE(LUPRI,*) 'CCEXLR Workspace:',LWORK 113 114 TIM0 = SECOND() 115*---------------------------------------------------------------------* 116* allocate & initialize work space for polarizabilities 117*---------------------------------------------------------------------* 118 NBEXLR = 2 * NEXLRST * NEXLROPER * NEXLRFREQ 119 120 MXTRAN = NLRTLBL * MAX(NLRTLBL,NER1LBL,NEL1LBL,NQRN2) 121 MXVEC = MAX(NLRTLBL,NER1LBL,NEL1LBL,NO2LBL,NQRN2) 122 123 MXGTRAN = MXDIM_GTRAN * MXTRAN 124 MXFTRAN = MXDIM_FTRAN * MXTRAN 125 MXF1TRAN = MXDIM_FTRAN * MXTRAN 126 MXFATRAN = MXDIM_FATRAN * MXTRAN 127 MXEATRAN = MXDIM_XEVEC * MXTRAN 128 MXOTRAN = 1 * MXTRAN 129 130 MXGDOTS = MXVEC * MXTRAN 131 MXFDOTS = MXVEC * MXTRAN 132 MXF1DOTS = MXVEC * MXTRAN 133 MXFADOTS = MXVEC * MXTRAN 134 MXEADOTS = MXVEC * MXTRAN 135 MXODOTS = MXVEC * MXTRAN 136 137 KEXLRPRP= 1 138 KGTRAN = KEXLRPRP+ 2 * NBEXLR 139 KGDOTS = KGTRAN + MXGTRAN 140 KGCONS = KGDOTS + MXGDOTS 141 KFTRAN = KGCONS + MXGDOTS 142 KFDOTS = KFTRAN + MXFTRAN 143 KFCONS = KFDOTS + MXFDOTS 144 KF1TRAN = KFCONS + MXFDOTS 145 KF1DOTS = KF1TRAN + MXF1TRAN 146 KF1CONS = KF1DOTS + MXF1DOTS 147 KFATRAN = KF1CONS + MXF1DOTS 148 KFADOTS = KFATRAN + MXFATRAN 149 KFACONS = KFADOTS + MXFADOTS 150 KAATRAN = KFACONS + MXFADOTS 151 KAADOTS = KAATRAN + MXTRAN * MXDIM_XEVEC 152 KAACONS = KAADOTS + MXVEC * MXTRAN 153 KEATRAN = KAACONS + MXVEC * MXTRAN 154 KEADOTS = KEATRAN + MXEATRAN 155 KEACONS = KEADOTS + MXEADOTS 156 KOTRAN = KEACONS + MXEADOTS 157 KODOTS = KOTRAN + MXOTRAN 158 KOCONS = KODOTS + MXODOTS 159 KEND0 = KOCONS + MXODOTS 160 LEND0 = LWORK - KEND0 161 162 IF (LEND0.LT.0) THEN 163 WRITE (LUPRI,*) 'KEND0,LEND0:',KEND0,LEND0 164 CALL QUIT('Insufficient memory in CCEXLR.') 165 END IF 166 167 CALL DZERO(WORK,KEND0-1) 168 169*---------------------------------------------------------------------* 170* set up lists for G, F, F{A} transformations etc.: 171*---------------------------------------------------------------------* 172 CALL CCEXLR_SETUP(MXTRAN, MXVEC, 173 & WORK(KGTRAN), WORK(KGDOTS), WORK(KGCONS), NGTRAN, 174 & WORK(KFTRAN), WORK(KFDOTS), WORK(KFCONS), NFTRAN, 175 & WORK(KF1TRAN),WORK(KF1DOTS),WORK(KF1CONS),NF1TRAN, 176 & WORK(KFATRAN),WORK(KFADOTS),WORK(KFACONS),NFATRAN, 177 & WORK(KAATRAN),WORK(KAADOTS),WORK(KAACONS),NAATRAN, 178 & WORK(KEATRAN),WORK(KEADOTS),WORK(KEACONS),NEATRAN, 179 & WORK(KOTRAN), WORK(KODOTS), WORK(KOCONS), NOTRAN, 180 & WORK(KEXLRPRP),NBEXLR, .FALSE. ) 181 182*---------------------------------------------------------------------* 183* calculate G matrix contributions: 184*---------------------------------------------------------------------* 185 TIM1 = SECOND() 186 187 IOPT = 5 188 CALL CC_GMATRIX('LE ','R1 ','RE ','R1 ',NGTRAN, MXVEC, 189 & WORK(KGTRAN),WORK(KGDOTS),WORK(KGCONS), 190 & WORK(KEND0), LEND0, IOPT ) 191 192 TIMG = SECOND() - TIM1 193 194 WRITE (LUPRI,'(/A,I5,A,F12.2," seconds.")') 195 & ' Time used for',NGTRAN,' G matrix transformations:',TIMG 196 CALL FLSHFO(LUPRI) 197 198*---------------------------------------------------------------------* 199* calculate F matrix contributions: 200*---------------------------------------------------------------------* 201 TIM1 = SECOND() 202 203 IF (.NOT. USE_EL1) THEN 204 IOPT = 5 205 CALL CC_FMATRIX(WORK(KFTRAN),NFTRAN,'LE ','ER1',IOPT,'R1 ', 206 & WORK(KFDOTS),WORK(KFCONS),MXVEC, 207 & WORK(KEND0), LEND0) 208 ELSE 209 IOPT = 5 210 CALL CC_FMATRIX(WORK(KFTRAN),NFTRAN,'EL1','RE ',IOPT,'R1 ', 211 & WORK(KFDOTS),WORK(KFCONS),MXVEC, 212 & WORK(KEND0), LEND0) 213 END IF 214 215 TIMF = SECOND() - TIM1 216 217 WRITE (LUPRI,'(/A,I5,A,F12.2," seconds.")') 218 & ' Time used for',NFTRAN,' F matrix transformations:',TIMF 219 CALL FLSHFO(LUPRI) 220 221*---------------------------------------------------------------------* 222* calculate more F matrix contributions: 223*---------------------------------------------------------------------* 224 TIMB = ZERO 225 226 IF (.NOT. USE_O2) THEN 227 TIM1 = SECOND() 228 229 IOPT = 5 230 CALL CC_FMATRIX(WORK(KF1TRAN),NF1TRAN,'N2 ','R1 ',IOPT,'R1 ', 231 & WORK(KF1DOTS),WORK(KF1CONS),MXVEC, 232 & WORK(KEND0), LEND0) 233 234 TIMB = SECOND() - TIM1 235 236 WRITE (LUPRI,'(/A,I5,A,F12.2," seconds.")') 237 & ' Time used for',NF1TRAN,' F matrix transformations:',TIMB 238 CALL FLSHFO(LUPRI) 239 END IF 240 241*---------------------------------------------------------------------* 242* calculate F{O} matrix contributions: 243*---------------------------------------------------------------------* 244 TIM1 = SECOND() 245 246 CALL CCQR_FADRV('LE ','o1 ','RE ','R1 ',NFATRAN, MXVEC, 247 & WORK(KFATRAN),WORK(KFADOTS),WORK(KFACONS), 248 & WORK(KEND0), LEND0, 'DOTP' ) 249 250 TIMFA = SECOND() - TIM1 251 252 WRITE (LUPRI,'(/A,I5,A,F12.2," seconds.")') 253 & ' Time used for',NFATRAN,' F{O} matrix transformat.:',TIMFA 254 CALL FLSHFO(LUPRI) 255 256*---------------------------------------------------------------------* 257* calculate A{O} matrix contributions: 258*---------------------------------------------------------------------* 259 TIMAA = ZERO 260 261 IF (.NOT. USE_O2) THEN 262 TIM1 = SECOND() 263 264 IOPT = 5 265 IORDER = 1 266 CALL CC_XIETA(WORK(KAATRAN), NAATRAN, IOPT, IORDER, 'N2 ', 267 & '---',IDUMMY, DUMMY, 268 & 'R1 ',WORK(KAADOTS),WORK(KAACONS), 269 & .FALSE.,MXVEC, WORK(KEND0), LEND0 ) 270 271 TIMAA = SECOND() - TIM1 272 273 WRITE (LUPRI,'(/A,I5,A,F12.2," seconds.")') 274 & ' Time used for',NAATRAN,' A{O} matrix transformat.:',TIMAA 275 CALL FLSHFO(LUPRI) 276 END IF 277 278*---------------------------------------------------------------------* 279* calculate ETA{O} vector contributions: 280*---------------------------------------------------------------------* 281 TIM1 = SECOND() 282 283 IF (.NOT. USE_EL1) THEN 284 IOPT = 5 285 IORDER = 1 286 CALL CC_XIETA( WORK(KEATRAN), NEATRAN, IOPT, IORDER, 'LE ', 287 & '---',IDUMMY, DUMMY, 288 & 'ER1',WORK(KEADOTS),WORK(KEACONS), 289 & .FALSE.,MXVEC, WORK(KEND0), LEND0 ) 290 ELSE 291 IOPT = 5 292 IORDER = 1 293 CALL CC_XIETA( WORK(KEATRAN), NEATRAN, IOPT, IORDER, 'EL1', 294 & '---',IDUMMY, DUMMY, 295 & 'RE ',WORK(KEADOTS),WORK(KEACONS), 296 & .FALSE.,MXVEC, WORK(KEND0), LEND0 ) 297 END IF 298 299 TIMEA = SECOND() - TIM1 300 WRITE (LUPRI,'(/A,I5,A,F12.2," seconds.")') 301 & ' Time used for',NEATRAN,' ETA{O} vector calculat.: ',TIMEA 302 CALL FLSHFO(LUPRI) 303*---------------------------------------------------------------------* 304* calculate N2 x O2 dot products: 305*---------------------------------------------------------------------* 306 TIMO = ZERO 307 308 IF (USE_O2) THEN 309 TIM1 = SECOND() 310 311 CALL CC_DOTDRV('N2 ','O2 ',NOTRAN,MXVEC, 312 & WORK(KOTRAN), WORK(KODOTS), WORK(KOCONS), 313 & WORK(KEND0), LEND0 ) 314 315 TIMO = SECOND() - TIM1 316 WRITE (LUPRI,'(/A,I5,A,F12.2," seconds.")') 317 & ' Time used for',NOTRAN,' N2 x O2 dot products: ', TIMO 318 CALL FLSHFO(LUPRI) 319 END IF 320 321*---------------------------------------------------------------------* 322* collect contributions and add them excited state LR properties 323*---------------------------------------------------------------------* 324 CALL CCEXLR_SETUP(MXTRAN, MXVEC, 325 & WORK(KGTRAN), WORK(KGDOTS), WORK(KGCONS), NGTRAN, 326 & WORK(KFTRAN), WORK(KFDOTS), WORK(KFCONS), NFTRAN, 327 & WORK(KF1TRAN),WORK(KF1DOTS),WORK(KF1CONS),NF1TRAN, 328 & WORK(KFATRAN),WORK(KFADOTS),WORK(KFACONS),NFATRAN, 329 & WORK(KAATRAN),WORK(KAADOTS),WORK(KAACONS),NAATRAN, 330 & WORK(KEATRAN),WORK(KEADOTS),WORK(KEACONS),NEATRAN, 331 & WORK(KOTRAN), WORK(KODOTS), WORK(KOCONS), NOTRAN, 332 & WORK(KEXLRPRP),NBEXLR, .TRUE. ) 333 334 335*---------------------------------------------------------------------* 336* print timing: 337*---------------------------------------------------------------------* 338 WRITE (LUPRI,'(/A,I4,A,F12.2," seconds.")') ' Total time for', 339 & NBEXLR,' excited state linear response func.:', SECOND() - TIM0 340 341*---------------------------------------------------------------------* 342* print output & return: 343*---------------------------------------------------------------------* 344 345 CALL CCEXLRPRT(WORK(KEXLRPRP)) 346 347 RETURN 348 END 349 350*=====================================================================* 351* END OF SUBROUTINE CC_HYPPOL * 352*=====================================================================* 353 354c /* deck ccexlrprt */ 355*=====================================================================* 356 SUBROUTINE CCEXLRPRT(EXLRPRP) 357*---------------------------------------------------------------------* 358* 359* Purpose: print output for excited state linear response section 360* 361* 362* Written by Christof Haettig in Juli 1997. 363* 364*=====================================================================* 365#if defined (IMPLICIT_NONE) 366 IMPLICIT NONE 367#else 368# include "implicit.h" 369#endif 370#include "priunit.h" 371#include "ccorb.h" 372#include "ccsdinp.h" 373#include "ccexlrinf.h" 374#include "ccexci.h" 375#include "ccroper.h" 376 377 378 CHARACTER*5 BLANKS 379 CHARACTER*80 STRING 380 LOGICAL LTWOPHOT 381 INTEGER ISYMA, ISYMB, ISYMSI, ISYMSF, ISTATI, ISTATF 382 INTEGER IFREQ, IOPER, IDXS, IEXCII, IEXCIF 383 384 385#if defined (SYS_CRAY) 386 REAL EXLRPRP(NEXLRFREQ,NEXLROPER,NEXLRST,2) 387 REAL HALF, FREQA, FREQB, EIGVI, EIGVF 388#else 389 DOUBLE PRECISION EXLRPRP(NEXLRFREQ,NEXLROPER,NEXLRST,2) 390 DOUBLE PRECISION HALF, FREQA, FREQB, EIGVI, EIGVF 391#endif 392 PARAMETER (HALF = 0.5d0) 393 394*---------------------------------------------------------------------* 395* initialize flag for two photon transition moments: 396*---------------------------------------------------------------------* 397 LTWOPHOT = .FALSE. 398 399*---------------------------------------------------------------------* 400* print header for excited state polarizabilities: 401*---------------------------------------------------------------------* 402 BLANKS = ' ' 403 STRING =' RESULTS FOR EXCITED STATES LINEAR RESPONSE PROPERTIES ' 404 405 IF (CCS) THEN 406 CALL AROUND( BLANKS//'FINAL CCS'//STRING(1:55)//BLANKS ) 407 ELSE IF (CC2) THEN 408 CALL AROUND( BLANKS//'FINAL CC2'//STRING(1:55)//BLANKS ) 409 ELSE IF (CCSD) THEN 410 CALL AROUND( BLANKS//'FINAL CCSD'//STRING(1:55)//BLANKS ) 411 ELSE IF (CC3) THEN 412 CALL AROUND( BLANKS//'FINAL CC3'//STRING(1:55)//BLANKS ) 413 ELSE 414 CALL QUIT('CCEXLRPRT called for an unknown '// 415 & 'Coupled Cluster model.') 416 END IF 417 418 DO IDXS = 1, NEXLRST 419 ISYMSI = IELRSYM(IDXS,1) 420 ISYMSF = IELRSYM(IDXS,2) 421 ISTATI = IELRSTA(IDXS,1) 422 ISTATF = IELRSTA(IDXS,2) 423 IEXCII = ISYOFE(ISYMSI) + ISTATI 424 IEXCIF = ISYOFE(ISYMSF) + ISTATF 425 EIGVI = EIGVAL(IEXCII) 426 EIGVF = EIGVAL(IEXCIF) 427 428 IF (IEXCII.NE.IEXCIF) THEN 429 430 LTWOPHOT = .TRUE. 431 432 ELSE 433C IF (IEXCII.EQ.IEXCIF) THEN 434 WRITE(STRING,'(A,I2,A,I2,3X,A,F12.8,A)') 435 & ' State number',ISTATI, 436 & ' in symmetry class',ISYMSI, 437 & ' (excitation energy: ',EIGVI,')' 438 CALL AROUND(STRING(1:72)) 439 440 IF (IPREXLR.GT.5) THEN 441 WRITE(LUPRI,'(/1X,2(1X,A,7X),5X,A,10X,A,/,95("-"))') 442 & 'A operator','B operator',' alpha','(asy. Resp.)' 443 ELSE 444 WRITE(LUPRI,'(/1X,2(1X,A,7X),4X,A,/,60("-"))') 445 & 'A operator','B operator',' alpha' 446 END IF 447 448 DO IOPER = 1, NEXLROPER 449 ISYMA = ISYOPR(IAEXLROP(IOPER)) 450 ISYMB = ISYOPR(IBEXLROP(IOPER)) 451 452 IFREQ = 1 453 IF (ISYMA.EQ.ISYMB) THEN 454 IF (IPREXLR.GT.5) THEN 455 WRITE(LUPRI,'(/2X,2(A8,F7.4,3X),G18.10," (",G18.10,")")') 456 & LBLOPR(IAEXLROP(IOPER)),-BEXLRFR(IFREQ), 457 & LBLOPR(IBEXLROP(IOPER)),+BEXLRFR(IFREQ), 458 & -HALF*(EXLRPRP(IFREQ,IOPER,IDXS,1) 459 & +EXLRPRP(IFREQ,IOPER,IDXS,2)), 460 & -HALF*(EXLRPRP(IFREQ,IOPER,IDXS,1) 461 & -EXLRPRP(IFREQ,IOPER,IDXS,2)) 462 ELSE 463 WRITE(LUPRI,'(/2X,2(A8,F7.4,3X),G16.8)') 464 & LBLOPR(IAEXLROP(IOPER)),-BEXLRFR(IFREQ), 465 & LBLOPR(IBEXLROP(IOPER)),+BEXLRFR(IFREQ), 466 & -HALF*(EXLRPRP(IFREQ,IOPER,IDXS,1) 467 & +EXLRPRP(IFREQ,IOPER,IDXS,2)) 468 ENDIF 469 ELSE 470 IF (IPREXLR.GT.5) THEN 471 WRITE(LUPRI,'(/2X,2(A8,F7.4,3X),7X,A,8X," (",9X,A,10X,")")') 472 & LBLOPR(IAEXLROP(IOPER)),-BEXLRFR(IFREQ), 473 & LBLOPR(IBEXLROP(IOPER)),+BEXLRFR(IFREQ), 474 & '---', 475 & '---' 476 ELSE 477 WRITE(LUPRI,'(/2X,2(A8,F7.4,3X),6X,A,7X)') 478 & LBLOPR(IAEXLROP(IOPER)),-BEXLRFR(IFREQ), 479 & LBLOPR(IBEXLROP(IOPER)),+BEXLRFR(IFREQ), 480 & '---' 481 END IF 482 END IF 483 484 DO IFREQ = 2, NEXLRFREQ 485 IF (ISYMA.EQ.ISYMB) THEN 486 IF (IPREXLR.GT.5) THEN 487 WRITE(LUPRI,'(2X,2(8X,F7.4,3X),G18.10," (",G18.10,")")') 488 & -BEXLRFR(IFREQ), BEXLRFR(IFREQ), 489 & -HALF*(EXLRPRP(IFREQ,IOPER,IDXS,1) 490 & +EXLRPRP(IFREQ,IOPER,IDXS,2)), 491 & -HALF*(EXLRPRP(IFREQ,IOPER,IDXS,1) 492 & -EXLRPRP(IFREQ,IOPER,IDXS,2)) 493 ELSE 494 WRITE(LUPRI,'(2X,2(8X,F7.4,3X),G16.8)') 495 & -BEXLRFR(IFREQ), BEXLRFR(IFREQ), 496 & -HALF*(EXLRPRP(IFREQ,IOPER,IDXS,1) 497 & +EXLRPRP(IFREQ,IOPER,IDXS,2)) 498 END IF 499 END IF 500 END DO 501 502 END DO 503 END IF 504 END DO 505 506 IF (.NOT.LTWOPHOT) RETURN 507 508*---------------------------------------------------------------------* 509* print header for two-photon matrix elements between excited states: 510*---------------------------------------------------------------------* 511 BLANKS = ' ' 512 STRING =' RESULTS FOR TWO-PHOTON TRANSITION MATRIX ELEMENTS ' 513 514 IF (CCS) THEN 515 CALL AROUND( BLANKS//'FINAL CCS'//STRING(1:51)//BLANKS ) 516 ELSE IF (CC2) THEN 517 CALL AROUND( BLANKS//'FINAL CC2'//STRING(1:51)//BLANKS ) 518 ELSE IF (CCSD) THEN 519 CALL AROUND( BLANKS//'FINAL CCSD'//STRING(1:51)//BLANKS ) 520 ELSE IF (CC3) THEN 521 CALL AROUND( BLANKS//'FINAL CC3'//STRING(1:55)//BLANKS ) 522 ELSE 523 CALL QUIT('CCEXLRPRT called for an unknown '// 524 & 'Coupled Cluster model.') 525 END IF 526 527 IF ( HALFFR .AND. NEXLRFREQ.NE.1 ) THEN 528 WRITE(LUPRI,*) 'error in CCEXLRPRT: HALFFR option is ', 529 & 'incompatible with a frequency list.' 530 CALL QUIT('error in CCEXLRPRT.') 531 END IF 532 533 WRITE(LUPRI,'(/,/,"+",112("-"),"+")') 534 WRITE(LUPRI,'(3A,/,"|",112(" "),"|",/,3A)') 535 & '| STATE I STATE F ', 536 & ' OPERATOR A OPERATOR B ', 537 & ' MOMENTS |', 538 & '| SYM IDX EIGVAL SYM IDX EIGVAL', 539 & ' LABEL FREQ LABEL FREQ ', 540 & ' M{i<-f}(w_B) M{f<-i}(-w_B) M{if}*M{fi} |' 541 WRITE(LUPRI,'("+",112("-"),"+")') 542 543 DO IDXS = 1, NEXLRST 544 ISYMSI = IELRSYM(IDXS,1) 545 ISYMSF = IELRSYM(IDXS,2) 546 ISTATI = IELRSTA(IDXS,1) 547 ISTATF = IELRSTA(IDXS,2) 548 IEXCII = ISYOFE(ISYMSI) + ISTATI 549 IEXCIF = ISYOFE(ISYMSF) + ISTATF 550 EIGVI = EIGVAL(IEXCII) 551 EIGVF = EIGVAL(IEXCIF) 552 553 554 IF (IEXCII.NE.IEXCIF) THEN 555 WRITE(LUPRI,'("|",112(" "),"|")') 556 557 DO IOPER = 1, NEXLROPER 558 ISYMA = ISYOPR(IAEXLROP(IOPER)) 559 ISYMB = ISYOPR(IBEXLROP(IOPER)) 560 561 IFREQ = 1 562 FREQB = BEXLRFR(IFREQ) 563 IF ( HALFFR ) FREQB = HALF * (EIGVI-EIGVF) 564 FREQA = EIGVI - EIGVF - FREQB 565 IF (MULD2H(ISYMA,ISYMB).EQ.MULD2H(ISYMSI,ISYMSF)) THEN 566 IF (IOPER.EQ.1) THEN 567 WRITE(LUPRI, '("|",2(I3,1X,I3,F11.4,1X), 568 & (A7,F11.4,2X),(A7,F11.4,1X),3(1X,G15.8),"|")') 569 & ISYMSI,ISTATI,EIGVI,ISYMSF,ISTATF,EIGVF, 570 & LBLOPR(IAEXLROP(IOPER)),FREQA, 571 & LBLOPR(IBEXLROP(IOPER)),FREQB, 572 & EXLRPRP(IFREQ,IOPER,IDXS,1),EXLRPRP(IFREQ,IOPER,IDXS,2), 573 & EXLRPRP(IFREQ,IOPER,IDXS,1)*EXLRPRP(IFREQ,IOPER,IDXS,2) 574 ELSE 575 WRITE(LUPRI, '("|",2(3X,1X,3X,9X,1X), 576 & (A7,F11.4,2X),(A7,F11.4,1X),3(1X,G15.8),"|")') 577 & LBLOPR(IAEXLROP(IOPER)),FREQA, 578 & LBLOPR(IBEXLROP(IOPER)),FREQB, 579 & EXLRPRP(IFREQ,IOPER,IDXS,1),EXLRPRP(IFREQ,IOPER,IDXS,2), 580 & EXLRPRP(IFREQ,IOPER,IDXS,1)*EXLRPRP(IFREQ,IOPER,IDXS,2) 581 END IF 582 ELSE 583 IF (IOPER.EQ.1) THEN 584 WRITE(LUPRI, '("|",2(I3,1X,I3,F11.4,1X), 585 & (A7,F11.4,2X),(A7,F11.4,1X),3A14," |")') 586 & ISYMSI,ISTATI,EIGVI,ISYMSF,ISTATF,EIGVF, 587 & LBLOPR(IAEXLROP(IOPER)),FREQA, 588 & LBLOPR(IBEXLROP(IOPER)),FREQB, 589 & ' --- ', ' --- ',' --- ' 590 ELSE 591 WRITE(LUPRI, '("|",2(3X,1X,3X,9X,1X), 592 & (A7,F11.4,2X),(A7,F11.4,1X),3A14," |")') 593 & LBLOPR(IAEXLROP(IOPER)),FREQA, 594 & LBLOPR(IBEXLROP(IOPER)),FREQB, 595 & ' --- ', ' --- ',' --- ' 596 END IF 597 END IF 598 599 DO IFREQ = 2, NEXLRFREQ 600 FREQB = BEXLRFR(IFREQ) 601 FREQA = EIGVI - EIGVF - FREQB 602 IF (MULD2H(ISYMA,ISYMB).EQ.MULD2H(ISYMSI,ISYMSF)) THEN 603 WRITE(LUPRI, '("| ",32X, 604 & (7X,F11.4,2X),(7X,F11.4,1X),3(1X,G15.8),"|")') 605 & FREQA, FREQB, 606 & EXLRPRP(IFREQ,IOPER,IDXS,1),EXLRPRP(IFREQ,IOPER,IDXS,2), 607 & EXLRPRP(IFREQ,IOPER,IDXS,1)*EXLRPRP(IFREQ,IOPER,IDXS,2) 608 END IF 609 END DO 610 611 END DO 612 END IF 613 END DO 614 615 WRITE(LUPRI,'("|",112(" "),"|")') 616 WRITE(LUPRI,'("+",112("-"),"+")') 617 618 RETURN 619 END 620*---------------------------------------------------------------------* 621* END OF SUBROUTINE CCEXLRPRT * 622*---------------------------------------------------------------------* 623c /* deck ccexlr_setup */ 624*=====================================================================* 625 SUBROUTINE CCEXLR_SETUP(MXTRAN, MXVEC, 626 & IGTRAN, IGDOTS, WG, NGTRAN, 627 & IFTRAN, IFDOTS, WF, NFTRAN, 628 & IF1TRAN, IF1DOTS, F1CONS, NF1TRAN, 629 & IFATRAN, IFADOTS, WFA, NFATRAN, 630 & IAATRAN, IAADOTS, WAA, NAATRAN, 631 & IEATRAN, IEADOTS, WEA, NEATRAN, 632 & IOTRAN, IODOTS, WO, NOTRAN, 633 & EXLRPRP, MXPROP, LADD ) 634*---------------------------------------------------------------------* 635* 636* Purpose: set up for CCEXLR section 637* - list of G matrix transformations 638* - list of F matrix transformations 639* - list of F{O} matrix transformations 640* - list of ETA{O} vector calculations 641* - list of dot products of N2 and O2 vectors 642* 643* LADD = .FALSE. --> build lists of contributions 644* LADD = .TRUE. --> add contributions up to properties 645* 646* Written by Christof Haettig, july 1997. 647* Some restructuring and updates for CC3, october 2003, C. Haettig 648*=====================================================================* 649#if defined (IMPLICIT_NONE) 650 IMPLICIT NONE 651#else 652# include "implicit.h" 653#endif 654#include "priunit.h" 655#include "ccorb.h" 656#include "ccexlrinf.h" 657#include "ccexci.h" 658#include "ccroper.h" 659#include "cclists.h" 660 661* local parameters: 662 CHARACTER*(22) MSGDBG 663 PARAMETER (MSGDBG = '[debug] CCEXLR_SETUP> ') 664 LOGICAL LOCDBG 665 PARAMETER (LOCDBG = .FALSE.) 666 667 LOGICAL LADD 668 669 INTEGER MXVEC, MXTRAN, MXPROP 670 671 INTEGER IGTRAN(MXDIM_GTRAN,MXTRAN) 672 INTEGER IGDOTS(MXVEC,MXTRAN) 673 674 INTEGER IFTRAN(MXDIM_FTRAN,MXTRAN) 675 INTEGER IFDOTS(MXVEC,MXTRAN) 676 677 INTEGER IF1TRAN(MXDIM_FTRAN,MXTRAN) 678 INTEGER IF1DOTS(MXVEC,MXTRAN) 679 680 INTEGER IFATRAN(MXDIM_FATRAN,MXTRAN) 681 INTEGER IFADOTS(MXVEC,MXTRAN) 682 683 INTEGER IAATRAN(MXDIM_XEVEC,MXTRAN) 684 INTEGER IAADOTS(MXVEC,MXTRAN) 685 686 INTEGER IEATRAN(MXDIM_XEVEC,MXTRAN) 687 INTEGER IEADOTS(MXVEC,MXTRAN) 688 689 INTEGER IOTRAN(MXTRAN) 690 INTEGER IODOTS(MXVEC,MXTRAN) 691 692 INTEGER NGTRAN, NFTRAN, NFATRAN, NEATRAN, NOTRAN, NEXLRPROP, 693 & NF1TRAN, NAATRAN 694 695 CHARACTER*(8) LABELA, LABELB 696 697 LOGICAL LPRJ 698 699 INTEGER ISYMA,ISYMB,ISYMSI,ISYMSF,ISTATI,ISTATF,IEXCII,IEXCIF 700 INTEGER IFREQ, IOPER, ISIGN, IDXS 701 702 INTEGER IOPA,IOPB,ITA,ITB,IERA,IERB,IER,IEL,IN2,IO2,IELA,IELB 703 INTEGER IVEC, ITRAN, I, IDX 704 705 INTEGER MXG, MXF, MXFA, MXEA, MXO, MXF1VEC, MXAA 706 707#if defined (SYS_CRAY) 708 REAL EIGVI, EIGVF, FREQA, FREQB 709 REAL EXLRPRP(2*MXPROP) 710 REAL WG(MXVEC,MXTRAN) 711 REAL WF(MXVEC,MXTRAN) 712 REAL F1CONS(MXVEC,MXTRAN) 713 REAL WFA(MXVEC,MXTRAN) 714 REAL WAA(MXVEC,MXTRAN) 715 REAL WEA(MXVEC,MXTRAN) 716 REAL WO(MXVEC,MXTRAN) 717 REAL GCON, FCON1, FCON2, FACON1, FACON2 718 REAL EACON1, EACON2, OCON, F1CON, AACON1, AACON2 719 REAL HALF, ZERO 720#else 721 DOUBLE PRECISION EIGVI, EIGVF, FREQA, FREQB 722 DOUBLE PRECISION EXLRPRP(2*MXPROP) 723 DOUBLE PRECISION WG(MXVEC,MXTRAN) 724 DOUBLE PRECISION WF(MXVEC,MXTRAN) 725 DOUBLE PRECISION F1CONS(MXVEC,MXTRAN) 726 DOUBLE PRECISION WFA(MXVEC,MXTRAN) 727 DOUBLE PRECISION WAA(MXVEC,MXTRAN) 728 DOUBLE PRECISION WEA(MXVEC,MXTRAN) 729 DOUBLE PRECISION WO(MXVEC,MXTRAN) 730 DOUBLE PRECISION GCON, FCON1, FCON2, FACON1, FACON2 731 DOUBLE PRECISION EACON1, EACON2, OCON, F1CON, AACON1, AACON2 732 DOUBLE PRECISION HALF, ZERO 733#endif 734 PARAMETER ( HALF = 0.5d0, ZERO = 0.0d0 ) 735 736 737* external functions: 738 INTEGER IR1TAMP 739 INTEGER IER1AMP 740 INTEGER IEL1AMP 741 INTEGER IN2AMP 742 INTEGER IRHSR2 743 744 745*---------------------------------------------------------------------* 746* initializations: 747*---------------------------------------------------------------------* 748 IF (.NOT. LADD) THEN 749 NGTRAN = 0 750 NFTRAN = 0 751 NF1TRAN = 0 752 NFATRAN = 0 753 NAATRAN = 0 754 NEATRAN = 0 755 NOTRAN = 0 756 757 DO ITRAN = 1, MXTRAN 758 DO I = 1, MXDIM_XEVEC 759 IEATRAN(I,ITRAN) = 0 760 IAATRAN(I,ITRAN) = 0 761 END DO 762 IEATRAN(3,ITRAN) = -1 763 IEATRAN(4,ITRAN) = -1 764 IAATRAN(3,ITRAN) = -1 765 IAATRAN(4,ITRAN) = -1 766 END DO 767 END IF 768 769 MXG = 0 770 MXF = 0 771 MXF1VEC = 0 772 MXFA = 0 773 MXAA = 0 774 MXEA = 0 775 MXO = 0 776 777 NEXLRPROP = 0 778 779 IF ( HALFFR .AND. NEXLRFREQ.NE.1 ) THEN 780 WRITE (LUPRI,*) 'error in CCEXLR_SETUP: HALFFR option is', 781 & ' incompatible with a frequency list.' 782 CALL QUIT('error in CCEXLR_SETUP.') 783 END IF 784 785*---------------------------------------------------------------------* 786* start loop over all excited state linear response properties 787*---------------------------------------------------------------------* 788 789 DO IOPER = 1, NEXLROPER 790 IOPA = IAEXLROP(IOPER) 791 IOPB = IBEXLROP(IOPER) 792 793 LABELA = LBLOPR(IOPA) 794 LABELB = LBLOPR(IOPB) 795 796 ISYMA = ISYOPR(IOPA) 797 ISYMB = ISYOPR(IOPB) 798 799 DO IDXS = 1, NEXLRST 800 ISYMSI = IELRSYM(IDXS,1) 801 ISYMSF = IELRSYM(IDXS,2) 802 ISTATI = IELRSTA(IDXS,1) 803 ISTATF = IELRSTA(IDXS,2) 804 IEXCII = ISYOFE(ISYMSI) + ISTATI 805 IEXCIF = ISYOFE(ISYMSF) + ISTATF 806 EIGVI = EIGVAL(IEXCII) 807 EIGVF = EIGVAL(IEXCIF) 808 809 IF ( MULD2H(ISYMA,ISYMB) .EQ. MULD2H(ISYMSI,ISYMSF) ) THEN 810 811 DO IFREQ = 1, NEXLRFREQ 812 FREQB = BEXLRFR(IFREQ) 813 IF (IEXCII.EQ.IEXCIF) THEN 814 FREQA = -FREQB 815 LPRJ = .NOT. NOPROJ 816 ELSE 817 IF ( HALFFR ) FREQB = HALF * (EIGVI-EIGVF) 818 FREQA = EIGVI - EIGVF -FREQB 819 LPRJ = .FALSE. 820 END IF 821 822 NEXLRPROP = NEXLRPROP + 1 823 824 DO ISIGN = +1, -1, -2 825 826 IF (ISIGN.EQ.1) THEN 827 828 ITA = IR1TAMP(LABELA,.FALSE.,+FREQA,ISYMA) 829 ITB = IR1TAMP(LABELB,.FALSE.,+FREQB,ISYMB) 830 IER = IEXCIF 831 IEL = IEXCII 832 IN2 = IN2AMP(IEXCII,-EIGVI,ISYMSI,IEXCIF,EIGVF,ISYMSF) 833 IF (USE_O2) THEN 834 IO2 = IRHSR2(LABELA,.FALSE.,+FREQA,ISYMA, 835 & LABELB,.FALSE.,+FREQB,ISYMB) 836 END IF 837 IF (.NOT. USE_EL1) THEN 838 IERA = IER1AMP(IEXCIF,EIGVF,ISYMSF,LABELA,+FREQA,ISYMA,LPRJ) 839 IERB = IER1AMP(IEXCIF,EIGVF,ISYMSF,LABELB,+FREQB,ISYMB,LPRJ) 840 ELSE 841 IELA = IEL1AMP(IEXCII,EIGVI,ISYMSI, 842 & LABELA,+FREQA,ISYMA,.FALSE.,LPRJ) 843 IELB = IEL1AMP(IEXCII,EIGVI,ISYMSI, 844 & LABELB,+FREQB,ISYMB,.FALSE.,LPRJ) 845 END IF 846 847 ELSE ! switch states indices and signs of the frequencies 848 849 ITA = IR1TAMP(LABELA,.FALSE.,-FREQA,ISYMA) 850 ITB = IR1TAMP(LABELB,.FALSE.,-FREQB,ISYMB) 851 IER = IEXCII 852 IEL = IEXCIF 853 IN2 = IN2AMP(IEXCIF,-EIGVF,ISYMSF,IEXCII,EIGVI,ISYMSI) 854 IF (USE_O2) THEN 855 IO2 = IRHSR2(LABELA,.FALSE.,-FREQA,ISYMA, 856 & LABELB,.FALSE.,-FREQB,ISYMB) 857 END IF 858 IF (.NOT. USE_EL1) THEN 859 IERA = IER1AMP(IEXCII,EIGVI,ISYMSI,LABELA,-FREQA,ISYMA,LPRJ) 860 IERB = IER1AMP(IEXCII,EIGVI,ISYMSI,LABELB,-FREQB,ISYMB,LPRJ) 861 ELSE 862 IELA = IEL1AMP(IEXCIF,EIGVF,ISYMSF, 863 & LABELA,-FREQA,ISYMA,.FALSE.,LPRJ) 864 IELB = IEL1AMP(IEXCIF,EIGVF,ISYMSF, 865 & LABELB,-FREQB,ISYMB,.FALSE.,LPRJ) 866 END IF 867 868 END IF 869 870 871*---------------------------------------------------------------------* 872* set up list of G matrix transformations, 1 permutation 873*---------------------------------------------------------------------* 874 CALL CC_SETG212(IGTRAN,IGDOTS,MXTRAN,MXVEC, 875 & IEL,ITA,IER,ITB,ITRAN,IVEC) 876 NGTRAN = MAX(NGTRAN,ITRAN) 877 MXG = MAX(MXG,IVEC) 878 GCON = WG(IVEC,ITRAN) 879 880*---------------------------------------------------------------------* 881* set up list of F matrix transformations, 2 permutations 882*---------------------------------------------------------------------* 883 IF (.NOT. USE_EL1) THEN 884 CALL CC_SETF12(IFTRAN,IFDOTS,MXTRAN,MXVEC, 885 & IEL,IERA,ITB,ITRAN,IVEC) 886 ELSE 887 CALL CC_SETF12(IFTRAN,IFDOTS,MXTRAN,MXVEC, 888 & IELA,IER,ITB,ITRAN,IVEC) 889 END IF 890 NFTRAN = MAX(NFTRAN,ITRAN) 891 MXF = MAX(MXF,IVEC) 892 FCON1 = WF(IVEC,ITRAN) 893 894 IF (.NOT. USE_EL1) THEN 895 CALL CC_SETF12(IFTRAN,IFDOTS,MXTRAN,MXVEC, 896 & IEL,IERB,ITA,ITRAN,IVEC) 897 ELSE 898 CALL CC_SETF12(IFTRAN,IFDOTS,MXTRAN,MXVEC, 899 & IELB,IER,ITA,ITRAN,IVEC) 900 END IF 901 NFTRAN = MAX(NFTRAN,ITRAN) 902 MXF = MAX(MXF,IVEC) 903 FCON2 = WF(IVEC,ITRAN) 904 905*---------------------------------------------------------------------* 906* set up list of F{O} matrix transformations, 2 permutations 907*---------------------------------------------------------------------* 908 CALL CC_SETFA12(IFATRAN,IFADOTS,MXTRAN,MXVEC, 909 & IEL,IOPA,IER,ITB,ITRAN,IVEC) 910 NFATRAN = MAX(NFATRAN,ITRAN) 911 MXFA = MAX(MXFA,IVEC) 912 FACON1 = WFA(IVEC,ITRAN) 913 914 CALL CC_SETFA12(IFATRAN,IFADOTS,MXTRAN,MXVEC, 915 & IEL,IOPB,IER,ITA,ITRAN,IVEC) 916 NFATRAN = MAX(NFATRAN,ITRAN) 917 MXFA = MAX(MXFA,IVEC) 918 FACON2 = WFA(IVEC,ITRAN) 919 920*---------------------------------------------------------------------* 921* set up list of generalized ETA{O} vector calculations, 2 permutations 922*---------------------------------------------------------------------* 923 IF (.NOT. USE_EL1) THEN 924 CALL CC_SETXE('Eta',IEATRAN,IEADOTS,MXTRAN,MXVEC, 925 & IEL,IOPA,0,0,0,0,IERB,ITRAN,IVEC) 926 ELSE 927 CALL CC_SETXE('Eta',IEATRAN,IEADOTS,MXTRAN,MXVEC, 928 & IELB,IOPA,0,0,0,0,IER,ITRAN,IVEC) 929 END IF 930 NEATRAN = MAX(NEATRAN,ITRAN) 931 MXEA = MAX(MXEA,IVEC) 932 EACON1 = WEA(IVEC,ITRAN) 933 934 IF (.NOT. USE_EL1) THEN 935 CALL CC_SETXE('Eta',IEATRAN,IEADOTS,MXTRAN,MXVEC, 936 & IEL,IOPB,0,0,0,0,IERA,ITRAN,IVEC) 937 ELSE 938 CALL CC_SETXE('Eta',IEATRAN,IEADOTS,MXTRAN,MXVEC, 939 & IELA,IOPB,0,0,0,0,IER,ITRAN,IVEC) 940 END IF 941 NEATRAN = MAX(NEATRAN,ITRAN) 942 MXEA = MAX(MXEA,IVEC) 943 EACON2 = WEA(IVEC,ITRAN) 944 945*---------------------------------------------------------------------* 946* set up list of N2 x O2 dot products, 1 permutation 947*---------------------------------------------------------------------* 948 OCON = ZERO 949 950 IF (USE_O2) THEN 951 CALL CC_SETDOT(IOTRAN,IODOTS,MXTRAN,MXVEC, 952 & IN2,IO2,ITRAN,IVEC) 953 NOTRAN = MAX(NOTRAN,ITRAN) 954 MXO = MAX(MXO,IVEC) 955 OCON = WO(IVEC,ITRAN) 956 END IF 957 958*---------------------------------------------------------------------* 959* set up list of F matrix transformations, 1 permutation 960*---------------------------------------------------------------------* 961 F1CON = ZERO 962 963 IF (.NOT. USE_O2) THEN 964 CALL CC_SETF12(IF1TRAN,IF1DOTS,MXTRAN,MXVEC, 965 & IN2,ITB,ITA,ITRAN,IVEC) 966 NF1TRAN = MAX(NF1TRAN,ITRAN) 967 MXF1VEC = MAX(MXF1VEC,IVEC) 968 F1CON = F1CONS(IVEC,ITRAN) 969 END IF 970 971*---------------------------------------------------------------------* 972* set up list of generalized Eta{O} vector calculations, 2 permutation 973*---------------------------------------------------------------------* 974 AACON1 = ZERO 975 AACON2 = ZERO 976 977 IF (.NOT. USE_O2) THEN 978 CALL CC_SETXE('Eta',IAATRAN,IAADOTS,MXTRAN,MXVEC, 979 & IN2,IOPA,0,0,0,0,ITB,ITRAN,IVEC) 980 NAATRAN = MAX(NAATRAN,ITRAN) 981 MXAA = MAX(MXAA,IVEC) 982 AACON1 = WAA(IVEC,ITRAN) 983 984 CALL CC_SETXE('Eta',IAATRAN,IAADOTS,MXTRAN,MXVEC, 985 & IN2,IOPB,0,0,0,0,ITA,ITRAN,IVEC) 986 NAATRAN = MAX(NAATRAN,ITRAN) 987 MXAA = MAX(MXAA,IVEC) 988 AACON2 = WAA(IVEC,ITRAN) 989 END IF 990 991*---------------------------------------------------------------------* 992* add contributions up to excited state linear response property: 993*---------------------------------------------------------------------* 994 IF (LADD) THEN 995 IDX =(IDXS-1)*NEXLROPER*NEXLRFREQ+(IOPER-1)*NEXLRFREQ+IFREQ 996 IF (ISIGN.EQ.-1) IDX = IDX + NEXLRST*NEXLROPER*NEXLRFREQ 997 998 EXLRPRP(IDX) = GCON + FCON1 + FCON2 + FACON1 + FACON2 + 999 & EACON1 + EACON2 + OCON + F1CON + AACON1 + AACON2 1000 1001 IF (LOCDBG) THEN 1002 WRITE (LUPRI,*) 1003 WRITE (LUPRI,*) MSGDBG, 'IOPER:',IOPER 1004 WRITE (LUPRI,*) MSGDBG, 'LABELA, LABELB:',LABELA, LABELB 1005 WRITE (LUPRI,*) MSGDBG, 'FREQA, FREQB:',FREQA,FREQB 1006 WRITE (LUPRI,*) MSGDBG, 'ISYMSI,ISTATI,EIGVI:',ISYMSI, 1007 & ISTATI,EIGVI 1008 WRITE (LUPRI,*) MSGDBG, 'ISYMSF,ISTATF,EIGVF:',ISYMSF, 1009 & ISTATF,EIGVF 1010 WRITE (LUPRI,*) MSGDBG, 'IDX: ',IDX 1011 WRITE (LUPRI,*) MSGDBG, 'EXLRPRP: ',EXLRPRP(IDX) 1012 WRITE (LUPRI,*) MSGDBG, 'GCON:',GCON 1013 WRITE (LUPRI,*) MSGDBG, 'FCON:',FCON1,FCON2 1014 WRITE (LUPRI,*) MSGDBG, 'FACON:',FACON1,FACON2 1015 WRITE (LUPRI,*) MSGDBG, 'EACON:',EACON1,EACON2 1016 WRITE (LUPRI,*) MSGDBG, 'OCON:',OCON 1017 WRITE (LUPRI,*) MSGDBG, 'F1CON:',F1CON 1018 WRITE (LUPRI,*) MSGDBG, 'AACON:',AACON1,AACON2 1019 WRITE (LUPRI,*) MSGDBG, 'SUM:', 1020 & GCON+FCON1+FCON2+FACON1+FACON2+EACON1+EACON2+OCON+ 1021 & F1CON+AACON1+AACON2 1022 WRITE (LUPRI,*) 1023 END IF 1024 END IF 1025 1026*---------------------------------------------------------------------* 1027* end loop over all requested excited state linear response properties 1028*---------------------------------------------------------------------* 1029 END DO 1030 END DO 1031 END IF 1032 END DO 1033 END DO 1034 1035*---------------------------------------------------------------------* 1036* print the lists: 1037*---------------------------------------------------------------------* 1038* general statistics: 1039 IF (.NOT. LADD) THEN 1040 WRITE(LUPRI,'(/,/3X,A,I3,A)') 'For the requested',NEXLRPROP, 1041 & ' excited state linear response properties ' 1042 WRITE(LUPRI,'((8X,A,I3,A))') 1043 & ' - ',NGTRAN, ' generalized G matrix transformations ', 1044 & ' - ',NFTRAN, ' generalized F matrix transformations ', 1045 & ' - ',NF1TRAN, ' generalized F matrix transformations ', 1046 & ' - ',NFATRAN, ' generalized F{O} matrix transformations ', 1047 & ' - ',NAATRAN, ' generalized ETA{O} vecotr calculations ', 1048 & ' - ',NEATRAN, ' generalized ETA{O} vector calculations ', 1049 & ' - ',NOTRAN, ' N2 x O2 dot products calculations ' 1050 WRITE(LUPRI,'(3X,A,/,/)') 'will be performed.' 1051 END IF 1052 1053 1054* G matrix transformations: 1055 IF (LOCDBG .AND. .NOT.LADD) THEN 1056 WRITE (LUPRI,*) MSGDBG, 'List of G matrix transformations:' 1057 DO ITRAN = 1, NGTRAN 1058 WRITE(LUPRI,'(A,3I5,5X,(12I5,20X))') MSGDBG, 1059 & (IGTRAN(I,ITRAN),I=1,3),(IGDOTS(I,ITRAN),I=1,MXG) 1060 END DO 1061 WRITE (LUPRI,*) 1062 END IF 1063 1064* F matrix transformations: 1065 IF (LOCDBG .AND. .NOT.LADD) THEN 1066 WRITE (LUPRI,*) MSGDBG, 'List of F matrix transformations:' 1067 DO ITRAN = 1, NFTRAN 1068 WRITE(LUPRI,'(A,2I5,5X,(12I5,20X))') MSGDBG, 1069 & (IFTRAN(I,ITRAN),I=1,2),(IFDOTS(I,ITRAN),I=1,MXF) 1070 END DO 1071 WRITE (LUPRI,*) 1072 END IF 1073 1074* more F matrix transformations: 1075 IF (LOCDBG .AND. .NOT.LADD) THEN 1076 WRITE (LUPRI,*) MSGDBG, 'List of F matrix transformations:' 1077 DO ITRAN = 1, NF1TRAN 1078 WRITE(LUPRI,'(A,2I5,5X,(12I5,20X))') MSGDBG, 1079 & (IF1TRAN(I,ITRAN),I=1,2),(IF1DOTS(I,ITRAN),I=1,MXF1VEC) 1080 END DO 1081 WRITE (LUPRI,*) 1082 END IF 1083 1084* F{O} matrix transformations: 1085 IF (LOCDBG .AND. .NOT.LADD) THEN 1086 WRITE (LUPRI,*) MSGDBG, 'List of F{O} matrix transformations:' 1087 DO ITRAN = 1, NFATRAN 1088 WRITE(LUPRI,'(A,5I5,5X,(12I5,20X))') MSGDBG, 1089 & (IFATRAN(I,ITRAN),I=1,5),(IFADOTS(I,ITRAN),I=1,MXFA) 1090 END DO 1091 WRITE (LUPRI,*) 1092 END IF 1093 1094* more ETA{O} vectors calculations: 1095 IF (LOCDBG .AND. .NOT.LADD) THEN 1096 WRITE (LUPRI,*) MSGDBG, 'List of ETA{O} vector calculations:' 1097 DO ITRAN = 1, NAATRAN 1098 WRITE(LUPRI,'(A,5I5,5X,(12I5,20X))') MSGDBG, 1099 & (IAATRAN(I,ITRAN),I=1,5),(IAADOTS(I,ITRAN),I=1,MXAA) 1100 END DO 1101 WRITE (LUPRI,*) 1102 END IF 1103 1104* ETA{O} vector calculations: 1105 IF (LOCDBG .AND. .NOT.LADD) THEN 1106 WRITE (LUPRI,*) MSGDBG, 'List of ETA{O} vector calculations:' 1107 DO ITRAN = 1, NEATRAN 1108 WRITE(LUPRI,'(A,2I5,5X,(12I5,20X))') MSGDBG, 1109 & (IEATRAN(I,ITRAN),I=1,2),(IEADOTS(I,ITRAN),I=1,MXEA) 1110 END DO 1111 WRITE (LUPRI,*) 1112 END IF 1113 1114* N2 x O2 vector dot products: 1115 IF (LOCDBG .AND. .NOT.LADD) THEN 1116 WRITE (LUPRI,*) MSGDBG, 'List of N2 x O2 dot products:' 1117 DO ITRAN = 1, NOTRAN 1118 WRITE(LUPRI,'(A,I5,5X,(12I5,20X))') MSGDBG, 1119 & IOTRAN(ITRAN),(IODOTS(I,ITRAN),I=1,MXO) 1120 END DO 1121 WRITE (LUPRI,*) 1122 END IF 1123 1124 1125 RETURN 1126 END 1127 1128*---------------------------------------------------------------------* 1129* END OF SUBROUTINE CCEXLR_SETUP * 1130*---------------------------------------------------------------------* 1131