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 ccrspsym */ 20*=====================================================================* 21 SUBROUTINE CCRSPSYM(MOLGRD,WORK,LWRK) 22*---------------------------------------------------------------------* 23* 24* Purpose: symmetry checks for CC response calculations 25* 26* Written by Christof Haettig, October 1996. 27* (Linear response residue setup Ove Christiansen 8-11-1996) 28* (New Linear response residue setup Ove Christiansen 23-4-1997) 29* (PL1 vectors and relaxation in EL1, Sonia Coriani, March 2000) 30* 31*=====================================================================* 32#if defined (IMPLICIT_NONE) 33 IMPLICIT NONE 34#else 35# include "implicit.h" 36#endif 37#include "priunit.h" 38#include "maxorb.h" 39#include "maxaqn.h" 40#include "mxcent.h" 41#include "nuclei.h" 42#include "symmet.h" 43#include "ccsdinp.h" 44#include "ccsections.h" 45#include "ccorb.h" 46#include "ccrspprp.h" 47#include "cclrinf.h" 48#include "ccroper.h" 49#include "ccropr2.h" 50#include "ccexpfck.h" 51#include "cc1dxfck.h" 52#include "cclrmrsp.h" 53#include "ccer1rsp.h" 54#include "ccer2rsp.h" 55#include "ccel1rsp.h" 56#include "ccel2rsp.h" 57#include "ccr1rsp.h" 58#include "ccr2rsp.h" 59#include "ccr3rsp.h" 60#include "ccr4rsp.h" 61#include "ccl1rsp.h" 62#include "ccl2rsp.h" 63#include "ccl3rsp.h" 64#include "ccl4rsp.h" 65#include "ccx1rsp.h" 66#include "ccx2rsp.h" 67#include "ccx3rsp.h" 68#include "ccx4rsp.h" 69#include "cco1rsp.h" 70#include "cco2rsp.h" 71#include "cco3rsp.h" 72#include "cco4rsp.h" 73#include "ccrc1rsp.h" 74#include "cclc1rsp.h" 75#include "cccr2rsp.h" 76#include "ccco2rsp.h" 77#include "cccl2rsp.h" 78#include "cccx2rsp.h" 79#include "ccexgr.h" 80#include "ccn2rsp.h" 81#include "cclres.h" 82#include "ccpl1rsp.h" 83#include "ccexci.h" 84Cholesky 85#include "cclrcho.h" 86Cholesky 87 88* local parameters: 89 CHARACTER MSGDBG*(18) 90 PARAMETER (MSGDBG='[debug] CCRSPSYM> ') 91 CHARACTER SECNAM*(8) 92 PARAMETER (SECNAM='CCRSPSYM') 93 94 LOGICAL LOCDBG 95 PARAMETER (LOCDBG = .FALSE.) 96 97 REAL*8 ZERO, ONE, TWO, EIGHT 98 REAL*8 TINY 99 REAL*8 CKMXPR 100 PARAMETER (ZERO = 0.0d0, ONE = 1.0d0, TWO = 2.0d0, EIGHT = 8.0d0) 101 PARAMETER (TINY = 1.0d-5, CKMXPR = 1.0d-12) 102 103 104* variables: 105 LOGICAL LDUM, MOLGRD 106 CHARACTER*8 LABEL,CDUM 107 INTEGER I, IND, IIND, IIMAX, JIND, KSYMPT, IPRP, IERR, ISYM, IDX 108 INTEGER LWRK, IDUM, IL, INUM, J, IVEC, IMATRIX, ICAU,ICAU1,ICAU2 109 INTEGER KEND1,LEND1,KPROPAO,JSCOOR,ISCOOR,ICORSY,ICOOR,IATOM 110 INTEGER ISYM0 111 112 REAL*8 WORK(LWRK),RDUM 113 114* external functions: 115 INTEGER ILSTSYM 116 INTEGER INDPRP_CC 117 INTEGER IROPER 118 INTEGER IROPER2 119 INTEGER IETA1 120 INTEGER ICHI2 121 INTEGER ICHI3 122 INTEGER ICHI4 123 INTEGER IRHSR1 124 INTEGER IRHSR2 125 INTEGER IRHSR3 126 INTEGER IRHSR4 127 INTEGER IR1KAPPA 128 INTEGER IR1TAMP 129 INTEGER IR2TAMP 130 INTEGER IR3TAMP 131 INTEGER IR4TAMP 132 INTEGER IL1ZETA 133 INTEGER IL2ZETA 134 INTEGER IL3ZETA 135 INTEGER IL4ZETA 136 INTEGER IER1AMP 137 INTEGER IER2AMP 138 INTEGER IEL1AMP 139 INTEGER IEL2AMP 140 INTEGER ILRCAMP 141 INTEGER ILC1AMP 142 INTEGER ICR2AMP 143 INTEGER ICL2AMP 144 INTEGER IRHSCR2 145 INTEGER IETACL2 146 INTEGER IEFFFOCK 147 INTEGER IPL1ZETA 148 149* data: 150 LOGICAL FIRSTCALL 151 SAVE FIRSTCALL 152 DATA FIRSTCALL /.TRUE./ 153 154 155*---------------------------------------------------------------------* 156* print header: 157*---------------------------------------------------------------------* 158 WRITE (LUPRI,'(3X,A,/)') ' ' 159 WRITE (LUPRI,'(3X,A)') 160 *'*********************************************************'// 161 *'**********' 162 WRITE (LUPRI,'(3X,A)') 163 *'* '// 164 *' *' 165 WRITE (LUPRI,'(3X,A)') 166 *'*-------- OUTPUT FROM PROPERTY AND SYMMETRY ANALYSIS '// 167 *'---------*' 168 WRITE (LUPRI,'(3X,A)') 169 *'* '// 170 *' *' 171 WRITE (LUPRI,'(3X,A,/)') 172 *'*********************************************************'// 173 *'**********' 174 175*---------------------------------------------------------------------* 176* initializations 177*---------------------------------------------------------------------* 178* init number of response operators: 179 NRSOLBL = 0 180 NRSO2LBL = 0 181Cholesky 182* number of unique operators for Cholesky CC2-LR 183 CALL IZERO(NCHOPLR,NSYM) 184Cholesky 185 LOPROPN = .TRUE. ! open list for extension 186 LOPR2OPN = .TRUE. ! open list for extension 187 188* init number of ground state response equations for t and zeta: 189 NLRTLBL = 0 190 NR2TLBL = 0 191 NR3TLBL = 0 192 NR4TLBL = 0 193 NLRZLBL = 0 194 NL2LBL = 0 195 NL3LBL = 0 196 NL4LBL = 0 197 198* init number of groud state response equations for kappa: 199 NLRTHFLBL = 0 200 201* init number of ground state response equations for projected zeta: 202 NPL1LBL = 0 203 204* init number of cauchy equations: 205 NLRCLBL = 0 206 NLC1LBL = 0 207 NCR2LBL = 0 208 NCL2LBL = 0 209 210* init number of multipliers for oscillator strengths: 211 NLRM = 0 212 NQRN2 = 0 213 214* init number of rhs/chi vectors for ground state 215* response and Cauchy equations: 216 NO1LBL = 0 217 NO2LBL = 0 218 NO3LBL = 0 219 NO4LBL = 0 220 NX1LBL = 0 221 NX2LBL = 0 222 NX3LBL = 0 223 NX4LBL = 0 224 NCO2LBL = 0 225 NCX2LBL = 0 226 227* init number of left/right excited state vector response equations. 228 NER1LBL = 0 229 NER2LBL = 0 230 NEL1LBL = 0 231 NEL2LBL = 0 232 233* init number of effective Fock matrices from one-index transformed 234* integrals: 235 N1DXFLBL = 0 236 237* make sure that the zeroth-order Hamiltonian 'HAM0 ' is on our 238* operator list (might be needed for analytic derivatives): 239 INUM = INDPRP_CC('HAM0 ') 240 241* allocate work space for one set of property AO integrals 242 KPROPAO = 1 243 KEND1 = KPROPAO + N2BASX 244 LEND1 = LWRK - KEND1 245 246 IF (LEND1 .LT. 0) THEN 247 CALL QUIT('Insufficient work space in CCRSPSYM') 248 END IF 249 250*---------------------------------------------------------------------* 251* loop over property labels in the PRPLBL_CC list: 252*---------------------------------------------------------------------* 253 DO IPRP = 1, NPRLBL_CC 254 LABEL = PRPLBL_CC(IPRP) 255 256 IF (LABEL(1:5).EQ.'HAM0 ') THEN 257 IERR = 0 258 KSYMPT = 1 259 IMATRIX = 1 260 ELSE 261 CALL CCPRPAO(LABEL,.TRUE.,WORK(KPROPAO),KSYMPT,IMATRIX,IERR, 262 & WORK(KEND1),LEND1) 263 264 END IF 265 266 IF (IERR.EQ.0 .AND. KSYMPT.GT.0 .AND. KSYMPT.LE.NSYM) THEN 267 268C ------------------------------------------------------ 269C build a list with labels, symmetries and orbital 270C relaxation flags of requested AND available operators: 271C ------------------------------------------------------ 272 INUM = IROPER(LABEL,KSYMPT) 273 274C ---------------------------------------------------- 275C save symmetry of integral matrix: 276C (symmetric=+1 / antisymmetric=-1) 277C ---------------------------------------------------- 278 ISYMAT(INUM) = IMATRIX 279 280C ---------------------------------------------------- 281C decide whether basis set depends on the perturbation: 282C (default is no PDBS, at present we have PDBS only 283C for geometric first derivatives): 284C ---------------------------------------------------- 285 IF ( LABEL(1:5).EQ.'HAM0 ' ) THEN 286 LPDBSOP(INUM) = .TRUE. 287 ELSE IF ( LABEL(1:5).EQ.'1DHAM' ) THEN 288 LPDBSOP(INUM) = .TRUE. 289 ELSE IF ( LABEL(1:5).EQ.'dh/dB' ) THEN 290 LPDBSOP(INUM) = .TRUE. 291 ELSE 292 LPDBSOP(INUM) = .FALSE. 293 END IF 294 295C ---------------------------------------------------- 296C determine index of associate 'Atom': 297C ---------------------------------------------------- 298 IF ( LABEL(1:5).EQ.'1DHAM' .OR. LABEL(4:6).EQ.'DPG') THEN 299 IF (LABEL(1:5).EQ.'1DHAM') READ(LABEL,'(5X,I3)') JSCOOR 300 IF (LABEL(4:6).EQ.'DPG') READ(LABEL,'(I3)') JSCOOR 301 302 DO IATOM = 1, NUCIND 303 DO ICORSY = 1, NSYM 304 DO ICOOR = 1, 3 305 ISCOOR = IPTCNT(3*(IATOM-1)+ICOOR,ICORSY-1,1) 306 IF (ISCOOR.EQ.JSCOOR) THEN 307 IATOPR(INUM) = IATOM 308 END IF 309 END DO 310 END DO 311 END DO 312 313 ELSE 314 IATOPR(INUM) = 0 315 END IF 316 317 END IF 318 END DO 319 320 321* close list of operators for extension and sort it: 322 LOPROPN = .FALSE. ! close list for extension 323 LOPR2OPN = .FALSE. ! close list for extension 324 LQUIET = .FALSE. ! warn if problems in IROPER2 325 326 IF (LOCDBG .AND. NRSOLBL.GT.0) THEN 327 WRITE(LUPRI,'(/A)') ' UNSORTED LIST OF REQUIRED OPERATORS:' 328 DO I = 1, NRSOLBL 329 WRITE(LUPRI,'(I5,3X,A8,2I5,L3,I5)') I, LBLOPR(I), 330 & ISYOPR(I), ISYMAT(I), LPDBSOP(I), IATOPR(I) 331 END DO 332 END IF 333 334 CALL CCLSTSORT('o1 ',IDUM, IDUM, RDUM, ISYOPR,LBLOPR,RDUM,IDUM, 335 & LDUM, ISYOFO, NRSOLBL, MAXOLBL, LDUM ) 336 337*---------------------------------------------------------------------* 338* initialize list of expectation values/effective fock matrices 339*---------------------------------------------------------------------* 340 CALL CC_EXPFCK_INIT(MOLGRD) 341 342*---------------------------------------------------------------------* 343* set up the lists of response/cauchy equations to be solved: 344*---------------------------------------------------------------------* 345* open lists: 346 LR1OPN = .TRUE. 347 LL1OPN = .TRUE. 348 LX1OPN = .TRUE. 349 LO1OPN = .TRUE. 350 LR2OPN = .TRUE. 351 LL2OPN = .TRUE. 352 LX2OPN = .TRUE. 353 LO2OPN = .TRUE. 354 LR3OPN = .TRUE. 355 LL3OPN = .TRUE. 356 LX3OPN = .TRUE. 357 LO3OPN = .TRUE. 358 LR4OPN = .TRUE. 359 LL4OPN = .TRUE. 360 LX4OPN = .TRUE. 361 LO4OPN = .TRUE. 362 LN2OPN = .TRUE. 363 LER1OPN = .TRUE. 364 LER2OPN = .TRUE. 365 LEL1OPN = .TRUE. 366 LEL2OPN = .TRUE. 367 LRC1OPN = .TRUE. 368 LLC1OPN = .TRUE. 369 LCR2OPN = .TRUE. 370 LCO2OPN = .TRUE. 371 LCL2OPN = .TRUE. 372 LCX2OPN = .TRUE. 373 LEXPTOPN = .TRUE. 374 LEFCKOPN = .TRUE. 375 L1DXFOPN = .TRUE. 376 LPL1OPN = .TRUE. 377 378* linear response equations for R1 or M1 vectors required for linear 379* response residues (one-photon transition moments for ground 380* to excited state transitions) 381 CALL CC_LRSIND 382 IF (CCOPA) CALL CC_OPAIND 383 384* linear response equations for R1 or N2 vectors required for quadratic 385* response second residues (one-photon transition moments for 386* excited to excited state transitions) 387 IF (CCQR2R) CALL CC_QR2IND 388 IF (CCXOPA) CALL CC_XOPAIND 389 390* test input for excited state first-order property calculation. 391 IF (CCEXGR) CALL CC_EXGRIND 392 393* set equations for excited state second-order properties: 394 IF (CCEXLR) CALL CC_EXLRIND 395 396* set equations required for second-order transition moments: 397 IF (CCTPA) CALL CC_TPAIND 398 399* set equations required for third-order transition moments: 400 CALL CC_TMIND 401 402* set equations required for MCD section: 403 CALL CC_MCDIND(WORK,LWRK) 404 405* set equations required for polarizabilities and Cauchy moments: 406 CALL CC_LRIND(WORK,LWRK) 407 408* linear response equations for t amplitudes and zeta multipliers 409* required for the first hyperpolarizabilities 410 CALL CC_QRIND(WORK,LWRK) 411 412* linear and quadratic response equations for t amplitudes and 413* zeta multipliers required for the second hyperpolarizabilities 414 CALL CC_CRIND 415 416* linear and quadratic response equations for t amplitudes and 417* zeta multipliers required for the third hyperpolarizabilities 418 CALL CC_4RIND 419 420* first-, second- and third-order response equations for t amplitudes 421* and zeta multipliers required for the fourth hyperpolarizabilities 422 CALL CC_5RIND 423 424 425*=====================================================================* 426* make response/rhs vector lists consistent: 427* (uses a waterfall strategy, so the order is important!) 428*=====================================================================* 429 430*---------------------------------------------------------------------* 431* request fourth-order chi (X4) vectors for all entries in the 432* fourth-order zeta multiplier (L4) list: 433*---------------------------------------------------------------------* 434 DO IVEC = 1, NL4LBL 435 INUM = ICHI4(LBLL4(IVEC,1),FRQL4(IVEC,1),ISYL4(IVEC,1), 436 & LBLL4(IVEC,2),FRQL4(IVEC,2),ISYL4(IVEC,2), 437 & LBLL4(IVEC,3),FRQL4(IVEC,3),ISYL4(IVEC,3), 438 & LBLL4(IVEC,4),FRQL4(IVEC,4),ISYL4(IVEC,4) ) 439 END DO 440 441*---------------------------------------------------------------------* 442* request fourth-order amplitude (R4) vectors for all entries in the 443* fourth-order multiplier (L4) vector lists: 444*---------------------------------------------------------------------* 445 DO IVEC = 1, NL4LBL 446 INUM = IR4TAMP(LBLL4(IVEC,1),FRQL4(IVEC,1),ISYL4(IVEC,1), 447 & LBLL4(IVEC,2),FRQL4(IVEC,2),ISYL4(IVEC,2), 448 & LBLL4(IVEC,3),FRQL4(IVEC,3),ISYL4(IVEC,3), 449 & LBLL4(IVEC,4),FRQL4(IVEC,4),ISYL4(IVEC,4) ) 450 END DO 451 452*---------------------------------------------------------------------* 453* request third-order multipliers (L3) vectors for all entries in the 454* fourth-order chi (X4) vector list: 455*---------------------------------------------------------------------* 456 DO IVEC = 1, NX4LBL 457 INUM = IL3ZETA(LBLX4(IVEC,1),FRQX4(IVEC,1),ISYX4(IVEC,1), 458 & LBLX4(IVEC,2),FRQX4(IVEC,2),ISYX4(IVEC,2), 459 & LBLX4(IVEC,3),FRQX4(IVEC,3),ISYX4(IVEC,3)) 460 461 INUM = IL3ZETA(LBLX4(IVEC,1),FRQX4(IVEC,1),ISYX4(IVEC,1), 462 & LBLX4(IVEC,2),FRQX4(IVEC,2),ISYX4(IVEC,2), 463 & LBLX4(IVEC,4),FRQX4(IVEC,4),ISYX4(IVEC,4)) 464 465 INUM = IL3ZETA(LBLX4(IVEC,1),FRQX4(IVEC,1),ISYX4(IVEC,1), 466 & LBLX4(IVEC,3),FRQX4(IVEC,3),ISYX4(IVEC,3), 467 & LBLX4(IVEC,4),FRQX4(IVEC,4),ISYX4(IVEC,4)) 468 469 INUM = IL3ZETA(LBLX4(IVEC,2),FRQX4(IVEC,2),ISYX4(IVEC,2), 470 & LBLX4(IVEC,3),FRQX4(IVEC,3),ISYX4(IVEC,3), 471 & LBLX4(IVEC,4),FRQX4(IVEC,4),ISYX4(IVEC,4)) 472 END DO 473 474*---------------------------------------------------------------------* 475* request third-order chi (X3) vectors for all entries in the 476* third-order zeta multiplier (L3) vector list: 477*---------------------------------------------------------------------* 478 DO IVEC = 1, NL3LBL 479 INUM = ICHI3(LBLL3(IVEC,1),FRQL3(IVEC,1),ISYL3(IVEC,1), 480 & LBLL3(IVEC,2),FRQL3(IVEC,2),ISYL3(IVEC,2), 481 & LBLL3(IVEC,3),FRQL3(IVEC,3),ISYL3(IVEC,3)) 482 END DO 483 484*---------------------------------------------------------------------* 485* request third-order amplitude (R3) vectors for all entries in the 486* L3 and O4 lists: 487*---------------------------------------------------------------------* 488 DO IVEC = 1, NL3LBL 489 INUM = IR3TAMP(LBLL3(IVEC,1),FRQL3(IVEC,1),ISYL3(IVEC,1), 490 & LBLL3(IVEC,2),FRQL3(IVEC,2),ISYL3(IVEC,2), 491 & LBLL3(IVEC,3),FRQL3(IVEC,3),ISYL3(IVEC,3)) 492 END DO 493 494 DO IVEC = 1, NO4LBL 495 INUM = IR3TAMP(LBLO4(IVEC,1),FRQO4(IVEC,1),ISYO4(IVEC,1), 496 & LBLO4(IVEC,2),FRQO4(IVEC,2),ISYO4(IVEC,2), 497 & LBLO4(IVEC,3),FRQO4(IVEC,3),ISYO4(IVEC,3)) 498 499 INUM = IR3TAMP(LBLO4(IVEC,1),FRQO4(IVEC,1),ISYO4(IVEC,1), 500 & LBLO4(IVEC,2),FRQO4(IVEC,2),ISYO4(IVEC,2), 501 & LBLO4(IVEC,4),FRQO4(IVEC,4),ISYO4(IVEC,4)) 502 503 INUM = IR3TAMP(LBLO4(IVEC,1),FRQO4(IVEC,1),ISYO4(IVEC,1), 504 & LBLO4(IVEC,3),FRQO4(IVEC,3),ISYO4(IVEC,3), 505 & LBLO4(IVEC,4),FRQO4(IVEC,4),ISYO4(IVEC,4)) 506 507 INUM = IR3TAMP(LBLO4(IVEC,2),FRQO4(IVEC,2),ISYO4(IVEC,2), 508 & LBLO4(IVEC,3),FRQO4(IVEC,3),ISYO4(IVEC,3), 509 & LBLO4(IVEC,4),FRQO4(IVEC,4),ISYO4(IVEC,4)) 510 END DO 511 512*---------------------------------------------------------------------* 513* request third-order amplitude rhs (O3) vectors for all entries in 514* the third-order amplitude (R3) list: 515*---------------------------------------------------------------------* 516 DO IVEC = 1, NR3TLBL 517 INUM = IRHSR3(LBLR3T(IVEC,1),FRQR3T(IVEC,1),ISYR3T(IVEC,1), 518 & LBLR3T(IVEC,2),FRQR3T(IVEC,2),ISYR3T(IVEC,2), 519 & LBLR3T(IVEC,3),FRQR3T(IVEC,3),ISYR3T(IVEC,3)) 520 END DO 521 522*---------------------------------------------------------------------* 523* request second-order multiplier (L2) vectors for all entries in the 524* third-order chi (X3), static vectors for all entries in the CL2 525* list, and for all second-order left excited state (EL2) vectors: 526*---------------------------------------------------------------------* 527 DO IVEC = 1, NX3LBL 528 INUM = IL2ZETA(LBLX3(IVEC,1),FRQX3(IVEC,1),ISYX3(IVEC,1), 529 & LBLX3(IVEC,2),FRQX3(IVEC,2),ISYX3(IVEC,2)) 530 531 INUM = IL2ZETA(LBLX3(IVEC,1),FRQX3(IVEC,1),ISYX3(IVEC,1), 532 & LBLX3(IVEC,3),FRQX3(IVEC,3),ISYX3(IVEC,3)) 533 534 INUM = IL2ZETA(LBLX3(IVEC,2),FRQX3(IVEC,2),ISYX3(IVEC,2), 535 & LBLX3(IVEC,3),FRQX3(IVEC,3),ISYX3(IVEC,3)) 536 END DO 537 538 DO IVEC = 1, NCL2LBL 539 INUM = IL2ZETA(LBLCL2(IVEC,1),0.0d0,ISYCL2(IVEC,1), 540 & LBLCL2(IVEC,2),0.0d0,ISYCL2(IVEC,2)) 541 END DO 542 543 DO IVEC = 1, NEL2LBL 544 INUM = IL2ZETA(LBLEL2(IVEC,1),FRQEL2(IVEC,1),ISYOEL2(IVEC,1), 545 & LBLEL2(IVEC,2),FRQEL2(IVEC,2),ISYOEL2(IVEC,2)) 546 END DO 547 548*---------------------------------------------------------------------* 549* request second-order Cauchy eta (CX2) vectors for all entries in the 550* second-order left Cauchy (CL2) vector list: 551*---------------------------------------------------------------------* 552 DO IVEC = 1, NCL2LBL 553 INUM = IETACL2(LBLCL2(IVEC,1),ICL2CAU(IVEC,1),ISYCL2(IVEC,1), 554 & LBLCL2(IVEC,2),ICL2CAU(IVEC,2),ISYCL2(IVEC,2) ) 555 END DO 556 557*---------------------------------------------------------------------* 558* request second-order eta (X2) vectors for all entries in the 559* second-order zeta multiplier (L2) list, and static vectors for 560* all entries in the CX2 list: 561*---------------------------------------------------------------------* 562 DO IVEC = 1, NL2LBL 563 INUM = ICHI2(LBLAL2(IVEC),.FALSE.,FRQAL2(IVEC),ISYAL2(IVEC), 564 & LBLBL2(IVEC),.FALSE.,FRQBL2(IVEC),ISYBL2(IVEC) ) 565 END DO 566 567 DO IVEC = 1, NCX2LBL 568 INUM = ICHI2(LBLCX2(IVEC,1),.FALSE.,0.0d0,ISYCX2(IVEC,1), 569 & LBLCX2(IVEC,2),.FALSE.,0.0d0,ISYCX2(IVEC,2) ) 570 END DO 571*---------------------------------------------------------------------* 572* request second-order right Cauchy vectors for all entries in the 573* second-order left Cauchy vector list and for all entries in the 574* second-order right Cauchy vector list with higher cauchy order: 575*---------------------------------------------------------------------* 576 DO IVEC = 1, NCL2LBL 577 INUM = ICR2AMP(LBLCL2(IVEC,1),ICL2CAU(IVEC,1),ISYCL2(IVEC,1), 578 & LBLCL2(IVEC,2),ICL2CAU(IVEC,2),ISYCL2(IVEC,2) ) 579 END DO 580 581 DO IVEC = 1, NCR2LBL 582 DO ICAU1 = 0, ICR2CAU(IVEC,1) 583 DO ICAU2 = 0, ICR2CAU(IVEC,2) 584 IF ((ICAU1+ICAU2).GT.0) THEN 585 INUM = ICR2AMP(LBLCR2(IVEC,1),ICAU1,ISYCR2(IVEC,1), 586 & LBLCR2(IVEC,2),ICAU2,ISYCR2(IVEC,2)) 587 END IF 588 END DO 589 END DO 590 END DO 591 592*---------------------------------------------------------------------* 593* request second-order right Cauchy rhs (CO2) vectors for all entries 594* in the second-order right Cauchy (R2) list: 595*---------------------------------------------------------------------* 596 DO IVEC = 1, NCR2LBL 597 INUM = IRHSCR2(LBLCR2(IVEC,1),ICR2CAU(IVEC,1),ISYCR2(IVEC,1), 598 & LBLCR2(IVEC,2),ICR2CAU(IVEC,2),ISYCR2(IVEC,2) ) 599 END DO 600 601*---------------------------------------------------------------------* 602* request second-order amplitude (R2) vectors for all entries in the 603* second-order multiplier (L2), third-order rhs (O3) and second-order 604* right cauchy (CR2) and right excited state (ER2) vector lists: 605*---------------------------------------------------------------------* 606 DO IVEC = 1, NL2LBL 607 INUM=IR2TAMP(LBLAL2(IVEC),.FALSE.,FRQAL2(IVEC),ISYAL2(IVEC), 608 & LBLBL2(IVEC),.FALSE.,FRQBL2(IVEC),ISYBL2(IVEC) ) 609 END DO 610 611 DO IVEC = 1, NO3LBL 612 INUM=IR2TAMP(LBLO3(IVEC,1),.FALSE.,FRQO3(IVEC,1),ISYO3(IVEC,1), 613 & LBLO3(IVEC,2),.FALSE.,FRQO3(IVEC,2),ISYO3(IVEC,2)) 614 615 INUM=IR2TAMP(LBLO3(IVEC,1),.FALSE.,FRQO3(IVEC,1),ISYO3(IVEC,1), 616 & LBLO3(IVEC,3),.FALSE.,FRQO3(IVEC,3),ISYO3(IVEC,3)) 617 618 INUM=IR2TAMP(LBLO3(IVEC,2),.FALSE.,FRQO3(IVEC,2),ISYO3(IVEC,2), 619 & LBLO3(IVEC,3),.FALSE.,FRQO3(IVEC,3),ISYO3(IVEC,3)) 620 END DO 621 622 DO IVEC = 1, NCR2LBL 623 INUM=IR2TAMP(LBLCR2(IVEC,1),.FALSE.,0.0d0,ISYCR2(IVEC,1), 624 & LBLCR2(IVEC,2),.FALSE.,0.0d0,ISYCR2(IVEC,2)) 625 END DO 626 627 DO IVEC = 1, NER2LBL 628 INUM=IR2TAMP(LBLER2(IVEC,1),.FALSE.,FRQER2(IVEC,1), 629 & ISYOER2(IVEC,1), 630 & LBLER2(IVEC,2),.FALSE.,FRQER2(IVEC,2), 631 & ISYOER2(IVEC,2)) 632 END DO 633 634*---------------------------------------------------------------------* 635* request second-order rhs (O2) vectors for all entries in the 636* second-order amplitude (R2) list and static vectors for all entries 637* in the CO2 list: 638*---------------------------------------------------------------------* 639 DO IVEC = 1, NR2TLBL 640 INUM = IRHSR2(LBLAR2T(IVEC),.FALSE.,FRQAR2T(IVEC),ISYAR2T(IVEC), 641 & LBLBR2T(IVEC),.FALSE.,FRQBR2T(IVEC),ISYBR2T(IVEC)) 642 END DO 643 644 DO IVEC = 1, NCR2LBL 645 INUM = IRHSR2(LBLCR2(IVEC,1),.FALSE.,0.0d0,ISYCR2(IVEC,1), 646 & LBLCR2(IVEC,2),.FALSE.,0.0d0,ISYCR2(IVEC,2)) 647 END DO 648 649*---------------------------------------------------------------------* 650* request first-order left excited state response vectors (EL1) for 651* all entries in the second-order left excited state (EL2) list: 652*---------------------------------------------------------------------* 653 DO IVEC = 1, NEL2LBL 654 INUM = IEL1AMP(ISTEL2(IVEC), EIGEL2(IVEC), ISYSEL2(IVEC), 655 & LBLEL2(IVEC,1),FRQEL2(IVEC,1),ISYOEL2(IVEC,1), 656 & .FALSE.,LPREL2(IVEC) ) 657 INUM = IEL1AMP(ISTEL2(IVEC), EIGEL2(IVEC), ISYSEL2(IVEC), 658 & LBLEL2(IVEC,2),FRQEL2(IVEC,2),ISYOEL2(IVEC,2), 659 & .FALSE.,LPREL2(IVEC) ) 660 END DO 661 662*---------------------------------------------------------------------* 663* request first-order right excited state response vectors (ER1) for 664* all entries in the second-order right excited state (ER2) list: 665*---------------------------------------------------------------------* 666 DO IVEC = 1, NER2LBL 667 INUM = IER1AMP(ISTER2(IVEC), EIGER2(IVEC), ISYSER2(IVEC), 668 & LBLER2(IVEC,1),FRQER2(IVEC,1),ISYOER2(IVEC,1), 669 & LPRER2(IVEC) ) 670 INUM = IER1AMP(ISTER2(IVEC), EIGER2(IVEC), ISYSER2(IVEC), 671 & LBLER2(IVEC,2),FRQER2(IVEC,2),ISYOER2(IVEC,2), 672 & LPRER2(IVEC) ) 673 END DO 674 675*---------------------------------------------------------------------* 676* request left first-order cauchy vectors for all entries in the 677* second-order Cauchy (CL2) and second-order Cauchy eta (CX2) vectors 678* lists and all left Cauchy vectors with higher cauchy order: 679*---------------------------------------------------------------------* 680 DO IVEC = 1, NCL2LBL 681 IF (ICL2CAU(IVEC,1).GT.0) 682 & INUM = ILC1AMP(LBLCL2(IVEC,1),ICL2CAU(IVEC,1),ISYCL2(IVEC,1)) 683 IF (ICL2CAU(IVEC,2).GT.0) 684 & INUM = ILC1AMP(LBLCL2(IVEC,2),ICL2CAU(IVEC,2),ISYCL2(IVEC,2)) 685 END DO 686 687 DO IVEC = 1, NCX2LBL 688 IF (ICX2CAU(IVEC,1).GT.0) 689 & INUM = ILC1AMP(LBLCX2(IVEC,1),ICX2CAU(IVEC,1),ISYCX2(IVEC,1)) 690 IF (ICX2CAU(IVEC,2).GT.0) 691 & INUM = ILC1AMP(LBLCX2(IVEC,2),ICX2CAU(IVEC,2),ISYCX2(IVEC,2)) 692 END DO 693 694 DO IVEC = 1, NLC1LBL 695 DO ICAU = 1, ILC1CAU(IVEC)-1 696 INUM = ILC1AMP(LBLLC1(IVEC),ICAU,ISYLC1(IVEC)) 697 END DO 698 END DO 699 700*---------------------------------------------------------------------* 701* request first-order right Cauchy vectors for all entries in the 702* first-order left Cauchy vector and second-order right Cauchy vector 703* list, second-order Cauchy rhs vector list and for all entries in 704* the first-order right Cauchy vector list with higher cauchy order: 705*---------------------------------------------------------------------* 706 DO IVEC = 1, NLC1LBL 707 INUM = ILRCAMP(LBLLC1(IVEC),ILC1CAU(IVEC),ISYLC1(IVEC)) 708 END DO 709 710 DO IVEC = 1, NCR2LBL 711 IF (ICR2CAU(IVEC,1).GT.0) 712 & INUM = ILRCAMP(LBLCR2(IVEC,1),ICR2CAU(IVEC,1),ISYCR2(IVEC,1)) 713 IF (ICR2CAU(IVEC,2).GT.0) 714 & INUM = ILRCAMP(LBLCR2(IVEC,2),ICR2CAU(IVEC,2),ISYCR2(IVEC,2)) 715 END DO 716 717 DO IVEC = 1, NCO2LBL 718 IF (ICO2CAU(IVEC,1).GT.0) 719 & INUM = ILRCAMP(LBLCO2(IVEC,1),ICO2CAU(IVEC,1),ISYCO2(IVEC,1)) 720 IF (ICO2CAU(IVEC,2).GT.0) 721 & INUM = ILRCAMP(LBLCO2(IVEC,2),ICO2CAU(IVEC,2),ISYCO2(IVEC,2)) 722 END DO 723 724 DO IVEC = 1, NLRCLBL 725 DO ICAU = 1, ILRCAU(IVEC)-1 726 INUM = ILRCAMP(LRCLBL(IVEC),ICAU,ISYLRC(IVEC)) 727 END DO 728 END DO 729 730*---------------------------------------------------------------------* 731* request (unrelaxed) first-order multipliers for all entries in the 732* second-order eta (X2) and for all left cauchy vectors: 733*---------------------------------------------------------------------* 734 DO IVEC = 1, NX2LBL 735 INUM = IL1ZETA(LBLAX2(IVEC),.FALSE.,FRQAX2(IVEC),ISYAX2(IVEC)) 736 INUM = IL1ZETA(LBLBX2(IVEC),.FALSE.,FRQBX2(IVEC),ISYBX2(IVEC)) 737 END DO 738 739 DO IVEC = 1, NLC1LBL 740 INUM = IL1ZETA(LBLLC1(IVEC),.FALSE.,0.0d0,ISYLC1(IVEC)) 741 END DO 742 743*---------------------------------------------------------------------* 744* request (unrelaxed) first-order amplitude response for all entries in 745* the second-order rhs (O2), first-order multiplier (L1), first-order 746* left and right excited state (EL1/ER1), projected 1st-order 747* multipliers (PL1) and first-order right cauchy vector lists: 748*---------------------------------------------------------------------* 749 DO IVEC = 1, NO2LBL 750 INUM = IR1TAMP(LBLAO2(IVEC),.FALSE.,FRQAO2(IVEC),ISYAO2(IVEC)) 751 INUM = IR1TAMP(LBLBO2(IVEC),.FALSE.,FRQBO2(IVEC),ISYBO2(IVEC)) 752 END DO 753 754 DO IVEC = 1, NLRZLBL 755 INUM = IR1TAMP(LRZLBL(IVEC),LORXLRZ(IVEC), 756 & FRQLRZ(IVEC),ISYLRZ(IVEC)) 757 END DO 758 759 DO IVEC = 1, NER1LBL 760 INUM = IR1TAMP(LBLER1(IVEC),.FALSE.,FRQER1(IVEC),ISYOER1(IVEC)) 761 END DO 762 763 DO IVEC = 1, NEL1LBL 764 INUM = IR1TAMP(LBLEL1(IVEC),LORXEL1(IVEC),FRQEL1(IVEC), 765 & ISYOEL1(IVEC)) 766 END DO 767 768 DO IVEC = 1, NPL1LBL 769 INUM = IR1TAMP(LBLPL1(IVEC),LORXPL1(IVEC), 770 & FRQPL1(IVEC),ISYPL1(IVEC)) 771 END DO 772 773 DO IVEC = 1, NLRCLBL 774 INUM = IR1TAMP(LRCLBL(IVEC),.FALSE.,0.0d0,ISYLRC(IVEC)) 775 END DO 776 777*---------------------------------------------------------------------* 778* request right hand side vector for first-order Lagrangian multiplier 779* response equations for all entries in the L1 and PL1 lists: 780*---------------------------------------------------------------------* 781 DO IVEC = 1, NLRZLBL 782 INUM=IETA1(LRZLBL(IVEC),LORXLRZ(IVEC),FRQLRZ(IVEC),ISYLRZ(IVEC)) 783 END DO 784 DO IVEC = 1, NPL1LBL 785 INUM=IETA1(LBLPL1(IVEC),LORXPL1(IVEC),FRQPL1(IVEC),ISYPL1(IVEC)) 786 END DO 787 788*---------------------------------------------------------------------* 789* request right hand side vector for first-order amplitude response 790* equations for all entries in the R1 list: 791*---------------------------------------------------------------------* 792 DO IVEC = 1, NLRTLBL 793 INUM=IRHSR1(LRTLBL(IVEC),LORXLRT(IVEC),FRQLRT(IVEC),ISYLRT(IVEC)) 794 END DO 795 796*---------------------------------------------------------------------* 797* for all elements of the O1 and X1 lists request the corresponding 798* CPHF response equations: 799*---------------------------------------------------------------------* 800 DO IVEC = 1, NX1LBL 801 IF (LORXX1(IVEC)) THEN 802 INUM = IR1KAPPA(LBLX1(IVEC),FRQX1(IVEC),ISYX1(IVEC)) 803 END IF 804 END DO 805 806 DO IVEC = 1, NO1LBL 807 IF (LORXO1(IVEC)) THEN 808 INUM = IR1KAPPA(LBLO1(IVEC),FRQO1(IVEC),ISYO1(IVEC)) 809 END IF 810 END DO 811 812*---------------------------------------------------------------------* 813* for all CPHF equations request RHS vectors: 814*---------------------------------------------------------------------* 815 IF (NLRTHFLBL.GT.0) THEN 816 INUM = IEFFFOCK('HAM0 ',1,1) 817 END IF 818 819 DO IVEC = 1, NLRTHFLBL 820 INUM = IEFFFOCK(LRTHFLBL(IVEC),ISYLRTHF(IVEC),1) 821 END DO 822 823*=====================================================================* 824* close lists: 825 LR1OPN = .FALSE. 826 LL1OPN = .FALSE. 827 LO1OPN = .FALSE. 828 LX1OPN = .FALSE. 829 LR2OPN = .FALSE. 830 LX2OPN = .FALSE. 831 LL2OPN = .FALSE. 832 LO2OPN = .FALSE. 833 LR3OPN = .FALSE. 834 LX3OPN = .FALSE. 835 LL3OPN = .FALSE. 836 LO3OPN = .FALSE. 837 LR4OPN = .FALSE. 838 LX4OPN = .FALSE. 839 LL4OPN = .FALSE. 840 LO4OPN = .FALSE. 841 LN2OPN = .FALSE. 842 LER1OPN = .FALSE. 843 LER2OPN = .FALSE. 844 LEL1OPN = .FALSE. 845 LEL2OPN = .FALSE. 846 LRC1OPN = .FALSE. 847 LLC1OPN = .FALSE. 848 LCR2OPN = .FALSE. 849 LCO2OPN = .FALSE. 850 LCL2OPN = .FALSE. 851 LCX2OPN = .FALSE. 852 LEXPTOPN = .FALSE. 853 LEFCKOPN = .FALSE. 854 L1DXFOPN = .FALSE. 855 LPL1OPN = .FALSE. 856 857* sort lists: 858 CALL CCLSTSORT('O1 ',IDUM, IDUM, RDUM, ISYO1,LBLO1,FRQO1, IDUM, 859 & LORXO1, ISYOFO1, NO1LBL, MAXO1LBL, LDUM ) 860 861 CALL CCLSTSORT('R1 ',IDUM, IDUM, RDUM, ISYLRT,LRTLBL,FRQLRT, IDUM, 862 & LORXLRT, ISYOFT, NLRTLBL, MAXTLBL, LDUM ) 863 864 CALL CCLSTSORT('RC ',IDUM, IDUM, RDUM, ISYLRC,LRCLBL,RDUM,ILRCAU, 865 & LDUM, ISYOFC, NLRCLBL, MAXCLBL, LDUM ) 866 867 CALL CCLSTSORT('X1 ',IDUM, IDUM, RDUM, ISYX1,LBLX1,FRQX1, IDUM, 868 & LORXX1, ISYOFX1, NX1LBL, MAXX1LBL, LDUM ) 869 870 CALL CCLSTSORT('L1 ',IDUM, IDUM, RDUM, ISYLRZ,LRZLBL,FRQLRZ, IDUM, 871 & LORXLRZ, ISYOFZ, NLRZLBL, MAXZLBL, LDUM ) 872 873 CALL CCLSTSORT('LC ',IDUM, IDUM, RDUM, ISYLC1,LBLLC1,RDUM,ILC1CAU, 874 & LDUM, ISYOFLC1, NLC1LBL, MAXLC1LBL, LDUM ) 875 876 CALL CCLSTSORT('O2 ',IDUM, IDUM, RDUM, ISYO2, LBLO2, FRQO2, IDUM, 877 & LDUM, ISYOFO2, NO2LBL, MAXO2LBL, LDUM ) 878 879 CALL CCLSTSORT('CO2',IDUM,IDUM, RDUM, ISYCO2,LBLCO2,RDUM,ICO2CAU, 880 & LDUM, ISYOFCO2,NCO2LBL, MAXCO2LBL,LDUM ) 881 882 CALL CCLSTSORT('X2 ',IDUM, IDUM, RDUM, ISYX2, LBLX2, FRQX2, IDUM, 883 & LDUM, ISYOFX2, NX2LBL, MAXX2LBL, LDUM ) 884 885 CALL CCLSTSORT('CX2',IDUM,IDUM, RDUM, ISYCX2,LBLCX2,RDUM,ICX2CAU, 886 & LDUM, ISYOFCX2,NCX2LBL, MAXCX2LBL,LDUM ) 887 888 CALL CCLSTSORT('R2 ',IDUM, IDUM, RDUM, ISYR2T,LBLR2T,FRQR2T,IDUM, 889 & LDUM, ISYOFT2, NR2TLBL, MAXT2LBL, LDUM ) 890 891 CALL CCLSTSORT('CR2',IDUM,IDUM, RDUM, ISYCR2,LBLCR2,RDUM,ICR2CAU, 892 & LDUM, ISYOFCR2,NCR2LBL, MAXCR2LBL,LDUM ) 893 894 CALL CCLSTSORT('L2 ',IDUM, IDUM, RDUM, ISYL2, LBLL2, FRQL2, IDUM, 895 & LDUM, ISYOFL2, NL2LBL, MAXL2LBL, LDUM ) 896 897 CALL CCLSTSORT('CL2',IDUM,IDUM, RDUM, ISYCL2,LBLCL2,RDUM,ICL2CAU, 898 & LDUM, ISYOFCL2,NCL2LBL, MAXCL2LBL,LDUM ) 899 900 CALL CCLSTSORT('O3 ',IDUM, IDUM, RDUM, ISYO3, LBLO3, FRQO3, IDUM, 901 & LDUM, ISYOFO3, NO3LBL, MAXO3LBL, LDUM ) 902 903 CALL CCLSTSORT('X3 ',IDUM, IDUM, RDUM, ISYX3, LBLX3, FRQX3, IDUM, 904 & LDUM, ISYOFX3, NX3LBL, MAXX3LBL, LDUM ) 905 906 CALL CCLSTSORT('R3 ',IDUM, IDUM, RDUM, ISYR3T,LBLR3T,FRQR3T, IDUM, 907 & LDUM, ISYOFT3, NR3TLBL, MAXT3LBL, LDUM ) 908 909 CALL CCLSTSORT('L3 ',IDUM, IDUM, RDUM, ISYL3, LBLL3, FRQL3, IDUM, 910 & LDUM, ISYOFL3, NL3LBL, MAXL3LBL, LDUM ) 911 912 CALL CCLSTSORT('O4 ',IDUM, IDUM, RDUM, ISYO4, LBLO4, FRQO4, IDUM, 913 & LDUM, ISYOFO4, NO4LBL, MAXO4LBL, LDUM ) 914 915 CALL CCLSTSORT('X4 ',IDUM, IDUM, RDUM, ISYX4, LBLX4, FRQX4, IDUM, 916 & LDUM, ISYOFX4, NX4LBL, MAXX4LBL, LDUM ) 917 918 CALL CCLSTSORT('R4 ',IDUM, IDUM, RDUM, ISYR4T,LBLR4T,FRQR4T, IDUM, 919 & LDUM, ISYOFT4, NR4TLBL, MAXT4LBL, LDUM ) 920 921 CALL CCLSTSORT('L4 ',IDUM, IDUM, RDUM, ISYL4, LBLL4, FRQL4, IDUM, 922 & LDUM, ISYOFL4, NL4LBL, MAXL4LBL, LDUM ) 923 924 CALL CCLSTSORT('M1 ',ISYLRM, ILRM, FRQLRM, IDUM, CDUM, RDUM, IDUM, 925 & LDUM, ISYOFM, NLRM, MAXM, LDUM ) 926 927 CALL CCLSTSORT('N2 ',ISYSN2, ISTN2, EIGN2, IDUM, CDUM, RDUM, IDUM, 928 & LDUM, ISYOFN2, NQRN2, MAXQRN2, LDUM ) 929 930 CALL CCLSTSORT('ER1',ISYSER1, ISTER1, EIGER1, 931 & ISYOER1, LBLER1, FRQER1, IDUM, LDUM, 932 & ISYOFER1, NER1LBL, MAXER1LBL, LPRER1 ) 933 934 CALL CCLSTSORT('ER2',ISYSER2, ISTER2, EIGER2, 935 & ISYOER2, LBLER2, FRQER2, IDUM, LDUM, 936 & ISYOFER2, NER2LBL, MAXER2LBL, LPRER2 ) 937 938 CALL CCLSTSORT('EL1',ISYSEL1, ISTEL1, EIGEL1, 939 & ISYOEL1, LBLEL1, FRQEL1, IDUM, LORXEL1, 940 & ISYOFEL1, NEL1LBL, MAXEL1LBL, LPREL1 ) 941 942 CALL CCLSTSORT('EL2',ISYSEL2, ISTEL2, EIGEL2, 943 & ISYOEL2, LBLEL2, FRQEL2, IDUM, LDUM, 944 & ISYOFEL2, NEL2LBL, MAXEL2LBL, LPREL2 ) 945 946 CALL CCLSTSORT('PL1',ISYSPL1, ISTPL1, EIGPL1, 947 & ISYPL1, LBLPL1, FRQPL1, IDUM, LORXPL1, 948 & ISYOFPL1, NPL1LBL, MAXPL1LBL, LPRPL1) 949 950* print sorted lists to output: 951 IF (NRSOLBL.GT.0) THEN 952 CALL AROUND('REQUESTED PROPERTY OPERATORS:') 953 WRITE(LUPRI,'(13X,A,/,13X,50("-"))') 954 & 'Index Oper. Label Symmetry Transp. PDBS Atom' 955 DO I = 1, NRSOLBL 956 WRITE(LUPRI,'(12X,I5,5X,A8,4X,I5,4X,I5,4X,L3,2X,I5)') 957 & I, LBLOPR(I), ISYOPR(I), ISYMAT(I), LPDBSOP(I),IATOPR(I) 958 END DO 959 WRITE(LUPRI,'(13X,50("-"),//)') 960 END IF 961 962 IF (NEXPFCKLBL.GT.0) THEN 963 CALL AROUND('REQUESTED EXPECTATION VALUES:') 964 WRITE(LUPRI,'(23X,A,/,23X,29("-"))') 965 & 'Index Oper. Label Symmetry' 966 DO I = 1, NEXPFCKLBL 967 IF (LEXPFCK(1,I)) WRITE(LUPRI,'(22X,I5,5X,A8,4X,I5)') 968 & I, LBLEXPFCK(I), ISYEXPFCK(I) 969 END DO 970 WRITE(LUPRI,'(23X,29("-"),//)') 971 END IF 972 973 IF (NEXPFCKLBL.GT.0) THEN 974 CALL AROUND('REQUESTED EFFECTIVE FOCK MATRICES:') 975 WRITE(LUPRI,'(23X,A,/,23X,29("-"))') 976 & 'Index Oper. Label Symmetry' 977 DO I = 1, NEXPFCKLBL 978 IF (LEXPFCK(2,I)) WRITE(LUPRI,'(22X,I5,5X,A8,4X,I5)') 979 & I, LBLEXPFCK(I), ISYEXPFCK(I) 980 END DO 981 WRITE(LUPRI,'(23X,29("-"),//)') 982 END IF 983 984 IF (N1DXFLBL.GT.0) THEN 985 CALL AROUND('REQUESTED 1-IDX-TRAN EFF. FOCK M.:') 986 WRITE(LUPRI,'(22X,A,/,22X,32("-"))') 987 & 'Index Oper. Label Type Index' 988 DO I = 1, N1DXFLBL 989 WRITE(LUPRI,'(21X,I5,5X,A8,6X,A3,I5)') 990 & I, LBL1DXFCK(I), LST1DXFCK(I), IRELAX1DX(I) 991 END DO 992 WRITE(LUPRI,'(22X,32("-"),//)') 993 END IF 994 995 IF (NLRTHFLBL.GT.0) THEN 996 CALL AROUND('REQUESTED FIRST ORDER KAPPA VECTORS:') 997 WRITE(LUPRI,'(18X,A,/,18X,41("-"))') 998 & 'Index Oper. Label Sym. Frequency' 999 DO I = 1, NLRTHFLBL 1000 WRITE(LUPRI,'(18X,I4,6X,A8,I6,2X,1P,D15.6)') 1001 & I, LRTHFLBL(I), ISYLRTHF(I), FRQLRTHF(I) 1002 END DO 1003 WRITE(LUPRI,'(18X,41("-"),//)') 1004 END IF 1005 1006 IF (NO1LBL.GT.0) THEN 1007 CALL AROUND('REQUESTED FIRST ORDER XI VECTORS:') 1008 WRITE(LUPRI,'(13X,A,/,13X,50("-"))') 1009 & 'Index Oper. Label relaxed Sym. Frequency' 1010 DO I = 1, NO1LBL 1011 WRITE(LUPRI,'(13X,I4,6X,A8,5X,L3,I6,3X,1P,D15.6)') 1012 & I, LBLO1(I), LORXO1(I), ISYO1(I), FRQO1(I) 1013Cholesky 1014 NCHOPLR(ISYO1(I)) = NCHOPLR(ISYO1(I)) + 1 1015Cholesky 1016 END DO 1017 WRITE(LUPRI,'(13X,50("-"),//)') 1018 END IF 1019 1020 IF (NLRTLBL.GT.0) THEN 1021 CALL AROUND('REQUESTED FIRST ORDER T VECTORS:') 1022 WRITE(LUPRI,'(13X,A,/,13X,50("-"))') 1023 & 'Index Oper. Label relaxed Sym. Frequency' 1024 DO I = 1, NLRTLBL 1025 WRITE(LUPRI,'(13X,I4,6X,A8,5X,L3,I6,3X,1P,D15.6)') 1026 & I, LRTLBL(I), LORXLRT(I), ISYLRT(I), FRQLRT(I) 1027 END DO 1028 WRITE(LUPRI,'(13X,50("-"),//)') 1029 END IF 1030 1031 IF (NX1LBL.GT.0) THEN 1032 CALL AROUND('REQUESTED FIRST ORDER ETA VECTORS:') 1033 WRITE(LUPRI,'(13X,A,/,13X,50("-"))') 1034 & 'Index Oper. Label relaxed Sym. Frequency' 1035 DO I = 1, NX1LBL 1036 WRITE(LUPRI,'(13X,I4,6X,A8,5X,L3,I6,3X,1P,D15.6)') 1037 & I, LBLX1(I), LORXX1(I), ISYX1(I), FRQX1(I) 1038 END DO 1039 WRITE(LUPRI,'(13X,50("-"),//)') 1040 END IF 1041 1042 IF (NLRZLBL.GT.0) THEN 1043 CALL AROUND('REQUESTED FIRST ORDER ZETA VECTORS:') 1044 WRITE(LUPRI,'(13X,A,/,13X,50("-"))') 1045 & 'Index Oper. Label relaxed Sym. Frequency' 1046 DO I = 1, NLRZLBL 1047 WRITE(LUPRI,'(13X,I4,6X,A8,5X,L3,I6,3X,1P,D15.6)') 1048 & I, LRZLBL(I), LORXLRZ(I), ISYLRZ(I), FRQLRZ(I) 1049 END DO 1050 WRITE(LUPRI,'(13X,50("-"),//)') 1051 END IF 1052 1053 IF (NLRM.GT.0) THEN 1054 CALL AROUND('REQUESTED FIRST ORDER M-VECTORS:') 1055 WRITE(LUPRI,'(15X,A,/,15X,50("-"))') 1056 & 'Index State Symmetry Frequency' 1057 DO I = 1, NLRM 1058 WRITE(LUPRI,'(14X,I5,6X,I8,I5,2X,1P,D15.6)') 1059 & I, ILRM(I), ISYLRM(I), FRQLRM(I) 1060 END DO 1061 WRITE(LUPRI,'(15X,50("-"),//)') 1062 END IF 1063 1064 IF (NLRCLBL.GT.0) THEN 1065 CALL AROUND( 1066 & 'REQUESTED FIRST-ORDER RIGHT CAUCHY VECTORS:') 1067 WRITE(LUPRI,'(15X,A,/,15X,50("-"))') 1068 & 'Index Oper. Label Symmetry Cauchy Order' 1069 DO I = 1, NLRCLBL 1070 WRITE(LUPRI,'(14X,I5,6X,A8,I5,2X,1P,I5)') 1071 & I, LRCLBL(I), ISYLRC(I), ILRCAU(I) 1072 END DO 1073 WRITE(LUPRI,'(15X,50("-"),//)') 1074 END IF 1075 1076 IF (NLC1LBL.GT.0) THEN 1077 CALL AROUND( 1078 & 'REQUESTED FIRST-ORDER LEFT CAUCHY VECTORS:') 1079 WRITE(LUPRI,'(15X,A,/,15X,50("-"))') 1080 & 'Index Oper. Label Symmetry Cauchy Order' 1081 DO I = 1, NLC1LBL 1082 WRITE(LUPRI,'(14X,I5,6X,A8,I5,2X,1P,I5)') 1083 & I, LBLLC1(I), ISYLC1(I), ILC1CAU(I) 1084 END DO 1085 WRITE(LUPRI,'(15X,50("-"),//)') 1086 END IF 1087 1088 IF (NO2LBL.GT.0) THEN 1089 CALL AROUND('REQUESTED SECOND-ORDER XKSI VECTORS:') 1090 WRITE(LUPRI,'(5X,2A,/,5X,70("-"))') 1091 & 'Index Oper. Label Symmetry Frequency', 1092 & ' Oper. Label Symmetry Frequency Symmetry' 1093 DO I = 1, NO2LBL 1094 WRITE(LUPRI,'(I5,2(3X,A8,I3,2X,1P,D15.6),I3)') 1095 & I, LBLAO2(I), ISYAO2(I), FRQAO2(I), 1096 & LBLBO2(I), ISYBO2(I), FRQBO2(I), 1097 & MULD2H(ISYAO2(I),ISYBO2(I)) 1098 END DO 1099 WRITE(LUPRI,'(5X,70("-"),//)') 1100 END IF 1101 1102 IF (NX2LBL.GT.0) THEN 1103 CALL AROUND('REQUESTED SECOND-ORDER ETA VECTORS:') 1104 WRITE(LUPRI,'(5X,2A,/,5X,70("-"))') 1105 & 'Index Oper. Label Symmetry Frequency', 1106 & ' Oper. Label Symmetry Frequency Symmetry' 1107 DO I = 1, NX2LBL 1108 WRITE(LUPRI,'(I5,2(3X,A8,I3,2X,1P,D15.6),I3)') 1109 & I, LBLAX2(I), ISYAX2(I), FRQAX2(I), 1110 & LBLBX2(I), ISYBX2(I), FRQBX2(I), 1111 & MULD2H(ISYAX2(I),ISYBX2(I)) 1112 END DO 1113 WRITE(LUPRI,'(5X,70("-"),//)') 1114 END IF 1115 1116 IF (NR2TLBL.GT.0) THEN 1117 CALL AROUND('REQUESTED SECOND-ORDER T VECTORS:') 1118 WRITE(LUPRI,'(5X,2A,/,5X,70("-"))') 1119 & 'Index Oper. Label Symmetry Frequency', 1120 & ' Oper. Label Symmetry Frequency Symmetry' 1121 DO I = 1, NR2TLBL 1122 WRITE(LUPRI,'(I5,2(3X,A8,I3,2X,1P,D15.6),I3)') 1123 & I, LBLAR2T(I), ISYAR2T(I), FRQAR2T(I), 1124 & LBLBR2T(I), ISYBR2T(I), FRQBR2T(I), 1125 & MULD2H(ISYAR2T(I),ISYBR2T(I)) 1126 END DO 1127 WRITE(LUPRI,'(5X,70("-"),//)') 1128 END IF 1129 1130 IF (NL2LBL.GT.0) THEN 1131 CALL AROUND('REQUESTED SECOND-ORDER ZETA VECTORS:') 1132 WRITE(LUPRI,'(5X,2A,/,5X,70("-"))') 1133 & 'Index Oper. Label Symmetry Frequency', 1134 & ' Oper. Label Symmetry Frequency Symmetry' 1135 DO I = 1, NL2LBL 1136 WRITE(LUPRI,'(I5,2(3X,A8,I3,2X,1P,D15.6),I3)') 1137 & I, LBLAL2(I), ISYAL2(I), FRQAL2(I), 1138 & LBLBL2(I), ISYBL2(I), FRQBL2(I), 1139 & MULD2H(ISYAL2(I),ISYBL2(I)) 1140 END DO 1141 WRITE(LUPRI,'(5X,70("-"),//)') 1142 END IF 1143 1144 IF (NCR2LBL.GT.0) THEN 1145 CALL AROUND('REQUESTED SECOND-ORDER RIGHT'// 1146 & ' CAUCHY VECTORS:') 1147 WRITE(LUPRI,'(5X,3A,/,5X,70("-"))') 1148 & 'Index Oper. Label Symmetry Cauchy Order', 1149 & ' Oper. Label Symmetry Cauchy Order', 1150 & ' Symmetry Cauchy Order' 1151 DO I = 1, NCR2LBL 1152 WRITE(LUPRI,'(I5,2(3X,A8,I3,2X,1P,I5),I3)') 1153 & I, LBLCR2(I,1), ISYCR2(I,1), ICR2CAU(I,1), 1154 & LBLCR2(I,2), ISYCR2(I,2), ICR2CAU(I,2), 1155 & MULD2H(ISYCR2(I,1),ISYCR2(I,2)) 1156 END DO 1157 WRITE(LUPRI,'(5X,70("-"),//)') 1158 END IF 1159 1160 IF (NCO2LBL.GT.0) THEN 1161 CALL AROUND('REQUESTED SECOND-ORDER CAUCHY'// 1162 & ' XKSI VECTORS:') 1163 WRITE(LUPRI,'(5X,3A,/,5X,70("-"))') 1164 & 'Index Oper. Label Symmetry Cauchy Order', 1165 & ' Oper. Label Symmetry Cauchy Order', 1166 & ' Symmetry Cauchy Order' 1167 DO I = 1, NCO2LBL 1168 WRITE(LUPRI,'(I5,2(3X,A8,I3,2X,1P,I5),I3)') 1169 & I, LBLCO2(I,1), ISYCO2(I,1), ICO2CAU(I,1), 1170 & LBLCO2(I,2), ISYCO2(I,2), ICO2CAU(I,2), 1171 & MULD2H(ISYCO2(I,1),ISYCO2(I,2)) 1172 END DO 1173 WRITE(LUPRI,'(5X,70("-"),//)') 1174 END IF 1175 1176 IF (NCL2LBL.GT.0) THEN 1177 CALL AROUND('REQUESTED SECOND-ORDER LEFT'// 1178 & ' CAUCHY VECTORS:') 1179 WRITE(LUPRI,'(5X,3A,/,5X,70("-"))') 1180 & 'Index Oper. Label Symmetry Cauchy Order', 1181 & ' Oper. Label Symmetry Cauchy Order', 1182 & ' Symmetry Cauchy Order' 1183 DO I = 1, NCL2LBL 1184 WRITE(LUPRI,'(I5,2(3X,A8,I3,2X,1P,I5),I3)') 1185 & I, LBLCL2(I,1), ISYCL2(I,1), ICL2CAU(I,1), 1186 & LBLCL2(I,2), ISYCL2(I,2), ICL2CAU(I,2), 1187 & MULD2H(ISYCL2(I,1),ISYCL2(I,2)) 1188 END DO 1189 WRITE(LUPRI,'(5X,70("-"),//)') 1190 END IF 1191 1192 IF (NCX2LBL.GT.0) THEN 1193 CALL AROUND('REQUESTED SECOND-ORDER CAUCHY'// 1194 & ' ETA VECTORS:') 1195 WRITE(LUPRI,'(5X,3A,/,5X,70("-"))') 1196 & 'Index Oper. Label Symmetry Cauchy Order', 1197 & ' Oper. Label Symmetry Cauchy Order', 1198 & ' Symmetry Cauchy Order' 1199 DO I = 1, NCX2LBL 1200 WRITE(LUPRI,'(I5,2(3X,A8,I3,2X,1P,I5),I3)') 1201 & I, LBLCX2(I,1), ISYCX2(I,1), ICX2CAU(I,1), 1202 & LBLCX2(I,2), ISYCX2(I,2), ICX2CAU(I,2), 1203 & MULD2H(ISYCX2(I,1),ISYCX2(I,2)) 1204 END DO 1205 WRITE(LUPRI,'(5X,70("-"),//)') 1206 END IF 1207 1208 IF (NO3LBL.GT.0) THEN 1209 CALL AROUND('REQUESTED THIRD-ORDER XKSI VECTORS:') 1210 WRITE(LUPRI,'(5X,3A,/,5X,70("-"))') 1211 & 'Index Oper. Label Symmetry Frequency', 1212 & ' Oper. Label Symmetry Frequency', 1213 & ' Oper. Label Symmetry Frequency Symmetry' 1214 DO I = 1, NO3LBL 1215 WRITE(LUPRI,'(I5,3(3X,A8,I3,2X,1P,D15.6),I3)') 1216 & I, (LBLO3(I,J), ISYO3(I,J), FRQO3(I,J), J=1, 3), 1217 & ILSTSYM('O3',I) 1218 END DO 1219 WRITE(LUPRI,'(5X,70("-"),//)') 1220 END IF 1221 1222 IF (NR3TLBL.GT.0) THEN 1223 CALL AROUND('REQUESTED THIRD-ORDER T VECTORS:') 1224 WRITE(LUPRI,'(5X,3A,/,5X,70("-"))') 1225 & 'Index Oper. Label Symmetry Frequency', 1226 & ' Oper. Label Symmetry Frequency', 1227 & ' Oper. Label Symmetry Frequency Symmetry' 1228 DO I = 1, NR3TLBL 1229 WRITE(LUPRI,'(I5,3(3X,A8,I3,2X,1P,D15.6),I3)') 1230 & I, (LBLR3T(I,J), ISYR3T(I,J), FRQR3T(I,J), J=1, 3), 1231 & ILSTSYM('R3',I) 1232 END DO 1233 WRITE(LUPRI,'(5X,70("-"),//)') 1234 END IF 1235 1236 IF (NX3LBL.GT.0) THEN 1237 CALL AROUND('REQUESTED THIRD-ORDER ETA VECTORS:') 1238 WRITE(LUPRI,'(5X,3A,/,5X,70("-"))') 1239 & 'Index Oper. Label Symmetry Frequency', 1240 & ' Oper. Label Symmetry Frequency', 1241 & ' Oper. Label Symmetry Frequency Symmetry' 1242 DO I = 1, NX3LBL 1243 WRITE(LUPRI,'(I5,3(3X,A8,I3,2X,1P,D15.6),I3)') 1244 & I, (LBLX3(I,J), ISYX3(I,J), FRQX3(I,J), J=1, 3), 1245 & ILSTSYM('X3',I) 1246 END DO 1247 WRITE(LUPRI,'(5X,70("-"),//)') 1248 END IF 1249 1250 IF (NL3LBL.GT.0) THEN 1251 CALL AROUND('REQUESTED THIRD-ORDER ZETA VECTORS:') 1252 WRITE(LUPRI,'(5X,3A,/,5X,70("-"))') 1253 & 'Index Oper. Label Symmetry Frequency', 1254 & ' Oper. Label Symmetry Frequency', 1255 & ' Oper. Label Symmetry Frequency Symmetry' 1256 DO I = 1, NL3LBL 1257 WRITE(LUPRI,'(I5,3(3X,A8,I3,2X,1P,D15.6),I3)') 1258 & I, (LBLL3(I,J), ISYL3(I,J), FRQL3(I,J), J=1, 3), 1259 & ILSTSYM('L3',I) 1260 END DO 1261 WRITE(LUPRI,'(5X,70("-"),//)') 1262 END IF 1263 1264 IF (NER1LBL.GT.0) THEN 1265 CALL AROUND('REQUESTED FIRST-ORDER RIGHT'// 1266 & ' EIGENVECTOR RESPONSES:') 1267 WRITE (LUPRI,'(3x,69("-"),/3x,2A,/3x,69("-"))') 1268 & 'IDX STATE/SYM EXC. ENERGY OPE', 1269 & 'RATOR/SYM FREQUENCY SYM R P' 1270 DO I = 1, NER1LBL 1271 WRITE (LUPRI,'(I5,3X,I3,I3,2X,1P,D15.6,3X,A8,I3,2X,1P, 1272 & D15.6,I3,L3)') 1273 & I, ISTER1(I), ISYSER1(I), EIGER1(I), 1274 & LBLER1(I), ISYOER1(I), FRQER1(I), ILSTSYM('ER1',I), 1275 & LPRER1(I) 1276 END DO 1277 WRITE(LUPRI,'(3x,69("-"),//)') 1278 END IF 1279 1280 IF (NER2LBL.GT.0) THEN 1281 CALL AROUND('REQUESTED SECOND-ORDER RIGHT'// 1282 & ' EIGENVECTOR RESPONSES:') 1283 WRITE(LUPRI,'(3x,69("-"),/)') 1284 DO I = 1, NER2LBL 1285 WRITE (LUPRI,'(I5,3X,2I3,2X,1P,D15.6,2(3X,A8,I3,2X,1P, 1286 & D15.6),I3,L3)') 1287 & I,ISTER2(I), ISYSER2(I), EIGER2(I), 1288 & LBLER2(I,1),ISYOER2(I,1),FRQER2(I,1), 1289 & LBLER2(I,2),ISYOER2(I,2),FRQER2(I,2),ILSTSYM('ER2',I), 1290 & LPRER2(I) 1291 END DO 1292 WRITE(LUPRI,'(3x,69("-"),//)') 1293 END IF 1294 1295 IF (NEL1LBL.GT.0) THEN 1296 CALL AROUND('REQUESTED FIRST-ORDER LEFT'// 1297 & ' EIGENVECTOR RESPONSES:') 1298 WRITE (LUPRI,'(3x,69("-"),/3x,2A,/3x,69("-"))') 1299 & 'IDX STATE/SYM EXC. ENERGY OPE', 1300 & 'RATOR/SYM FREQUENCY SYM R P' 1301 DO I = 1, NEL1LBL 1302 WRITE (LUPRI,'(I5,3X,I3,I3,2X,1P,D15.6,3X,A8,I3,2X,1P, 1303 & D15.6,I3,2L3)') 1304 & I, ISTEL1(I), ISYSEL1(I), EIGEL1(I), 1305 & LBLEL1(I), ISYOEL1(I), FRQEL1(I), ILSTSYM('EL1',I), 1306 & LORXEL1(I),LPREL1(I) 1307 END DO 1308 WRITE(LUPRI,'(3x,69("-"),//)') 1309 END IF 1310 1311 IF (NEL2LBL.GT.0) THEN 1312 CALL AROUND('REQUESTED SECOND-ORDER LEFT'// 1313 & ' EIGENVECTOR RESPONSES:') 1314 WRITE(LUPRI,'(3x,69("-"))') 1315 DO I = 1, NEL2LBL 1316 WRITE (LUPRI,'(I5,3X,2I3,2X,1P,D15.6,2(3X,A8,I3,2X,1P, 1317 & D15.6),I3,L3)') 1318 & I,ISTEL2(I), ISYSEL2(I), EIGEL2(I), 1319 & LBLEL2(I,1),ISYOEL2(I,1),FRQEL2(I,1), 1320 & LBLEL2(I,2),ISYOEL2(I,2),FRQEL2(I,2),ILSTSYM('EL2',I), 1321 & LPREL2(I) 1322 END DO 1323 WRITE(LUPRI,'(3x,69("-"),//)') 1324 END IF 1325 1326 IF (NXGRST.GT.0) THEN 1327 WRITE(LUPRI,'(/A)')' LIST OF REQUIRED ZEROTH-ORDER E0 MULTIP.:' 1328 DO I = 1, NXGRST 1329 WRITE(LUPRI,'(I5,3X,I8,I5,2X,1P,D15.6)') 1330 & I, IXGRST(I), ISYEXC(IXGRST(I)), EIGVAL(IXGRST(I)) 1331 END DO 1332 END IF 1333 1334 IF (NQRN2.GT.0) THEN 1335 CALL AROUND('REQUESTED N(i,f) VECTORS:') 1336 WRITE(LUPRI,'(/3x,69("-"),/3x,2A,/3x,69("-"))') 1337 & 'IDX STATE/SYM EXC. ENERGY', 1338 & ' STATE/SYM EXC. ENERGY SYM' 1339 DO I = 1, NQRN2 1340 WRITE(LUPRI,'(I5,2(3X,I3,I3,2X,1P,D15.6),I3)') 1341 & I, IIN2(I), ISYIN2(I), FRQIN2(I), 1342 & IFN2(I), ISYFN2(I), FRQFN2(I), 1343 & MULD2H(ISYIN2(I),ISYFN2(I)) 1344 END DO 1345 WRITE(LUPRI,'(3x,69("-"),//)') 1346 END IF 1347 1348 IF (NPL1LBL.GT.0) THEN 1349 CALL AROUND('REQUESTED PROJECTED FIRST-ORDER ZETA VECTORS:') 1350 WRITE(LUPRI,'(3x,69("-"))') 1351 DO I = 1, NPL1LBL 1352 WRITE (LUPRI,'(I5,3X,I3,I3,2X,1P,D15.6,3X,A8,I3,2X,1P,D15.6, 1353 & I3,L3)') 1354 & I, ISTPL1(I), ISYSPL1(I), EIGPL1(I), 1355 & LBLPL1(I), ISYPL1(I), FRQPL1(I), ISYPL1(I), 1356 & LPRPL1(I) 1357 END DO 1358 WRITE(LUPRI,'(3x,69("-"),//)') 1359 END IF 1360 1361 RETURN 1362 END 1363*---------------------------------------------------------------------* 1364c /* deck cc_exgrind */ 1365*=====================================================================* 1366 SUBROUTINE CC_EXGRIND 1367*---------------------------------------------------------------------* 1368* 1369* Purpose: Control input and equations for calculation of 1370* excited state first order properties. 1371* 1372* OC April 1997 1373* 1374*=====================================================================* 1375#include "implicit.h" 1376#include "priunit.h" 1377#include "ccorb.h" 1378#include "cclrinf.h" 1379#include "ccrspprp.h" 1380#include "ccexci.h" 1381#include "ccexgr.h" 1382#include "ccsdinp.h" 1383#include "ccsdsym.h" 1384#include "cclr.h" 1385#include "ccroper.h" 1386 CHARACTER*8 LABEL,LABELA 1387 INTEGER ISYMA, INUM, IOP, ISYME 1388 1389 REAL*8 EIGV 1390C 1391 LOGICAL FIRSTCALL 1392 SAVE FIRSTCALL 1393 DATA FIRSTCALL /.TRUE./ 1394C 1395*------------------------------------------------------------------ 1396* test if operators are available and translate IAXGRO, 1397* arrays from the PRPLBL_CC list to the new list maintained by IROPER. 1398*------------------------------------------------------------------ 1399 IF (FIRSTCALL) THEN 1400 IOPER = 1 1401 DO WHILE (IOPER .LE. NAXGRO) 1402 LABELA = PRPLBL_CC(IAXGRO(IOPER)) 1403 IF (DEBUG) THEN 1404 WRITE(LUPRI,'(/2X,A,1X,A)') 1405 & 'CHECK EXGR OPERATOR:',LABELA 1406 ENDIF 1407 IF (IROPER(LABELA,ISYMA) .LT. 0) THEN 1408 WRITE(LUPRI,'(/2X,3A,/2X,2A)') 1409 & ' WARNING: THE OPERATOR WITH THE LABEL "', 1410 & LABELA,'" IS NOT AVAILABLE.', 1411 & ' LINEAR RESPONSE RESIDUE CALCULATION IS CANCELED FOR THIS', 1412 & ' OPERATOR.' 1413 DO IDX = IOPER, NAXGRO-1 1414 IAXGRO(IDX) = IAXGRO(IDX+1) 1415 END DO 1416 NAXGRO = NAXGRO - 1 1417 ELSE 1418 IF (DEBUG) THEN 1419 WRITE(LUPRI,'(/2X,A,1X,A,A)') 1420 & 'PUT :',LABELA,' ON THE LIST.' 1421 ENDIF 1422 IAXGRO(IOPER) = IROPER(LABELA,ISYMA) 1423 IOPER = IOPER + 1 1424 END IF 1425 END DO 1426 FIRSTCALL = .FALSE. 1427 END IF ! (FIRSTCALL) 1428C 1429 IF (DEBUG) THEN 1430 WRITE(LUPRI,'(/,A)') ' Updated list' 1431 DO IOPER = 1, NAXGRO 1432 WRITE(LUPRI,*) IOPER,IAXGRO(IOPER),' ', 1433 * LBLOPR(IAXGRO(IOPER)), 1434 * ISYOPR(IAXGRO(IOPER)) 1435 ENDDO 1436 ENDIF 1437C 1438C------------------------------------ 1439C Fill in equations to be solved. 1440C------------------------------------ 1441C 1442 NXGRST = 0 1443C 1444 DO 100 ISYME = 1, NSYM 1445 DO 200 IEX = 1, NCCEXCI(ISYME,1) 1446C 1447 IF (SELXGR) THEN 1448C 1449C Check state has been calculated. 1450C 1451 DO 300 I = 1,NSEXGR 1452 IF ((ISYME.EQ.ISEXGR(I,1)) 1453 * .AND.(IEX.EQ.ISEXGR(I,2))) THEN 1454 NXGRST = NXGRST + 1 1455 IXGRST(NXGRST) = ISYOFE(ISYME)+IEX 1456 GO TO 350 1457 ENDIF 1458 300 CONTINUE 1459C 1460C------------------------------------------------------------------------ 1461C This state is not requested in oscillator strength calculation. 1462C GOTO end of loop. 1463C------------------------------------------------------------------------ 1464C 1465 GO TO 200 1466 ELSE 1467 NXGRST = NXGRST + 1 1468 IF (NXGRST.GT.MXXGST) THEN 1469 WRITE(LUPRI,*) 'NXGRST =',NXGRST,'MXXGST= ',MXXGST 1470 CALL QUIT(' Too many states for residue calculation') 1471 ENDIF 1472 IXGRST(NXGRST) = ISYOFE(ISYME)+IEX 1473 ENDIF 1474 1475 350 CONTINUE 1476 200 CONTINUE 1477 100 CONTINUE 1478C 1479 ISYOFXG(1) = 0 1480 DO ISYM = 2, NSYM 1481 ISYOFXG(ISYM) = NXGRST 1482 END DO 1483C 1484 END 1485*---------------------------------------------------------------------* 1486c /* deck cc_opaind */ 1487*=====================================================================* 1488 SUBROUTINE CC_OPAIND 1489*---------------------------------------------------------------------* 1490* 1491* Purpose: Control input and equations for calculation of 1492* one-photon absorption strengths for ground to 1493* excited state transitions 1494* 1495* Christof Haettig, December 2002, Friedrichstal 1496* 1497*=====================================================================* 1498 IMPLICIT NONE 1499C#include "implicit.h" 1500C#include "cclrinf.h" 1501C#include "cclr.h" 1502C#include "ccsdsym.h" 1503#include "priunit.h" 1504#include "ccorb.h" 1505#include "ccexci.h" 1506#include "ccexcinf.h" 1507#include "ccrspprp.h" 1508#include "ccopainf.h" 1509#include "ccsdinp.h" 1510#include "ccroper.h" 1511 1512 LOGICAL LOCDBG 1513 PARAMETER (LOCDBG = .FALSE.) 1514 1515 CHARACTER*8 LABEL 1516 LOGICAL TAKE_STATE 1517 INTEGER ISYMO, INUM, ISTATE, ISYME, IOPER, IDX, IEX 1518 1519 REAL*8 EIGV 1520* functions: 1521 INTEGER IR1TAMP,ILRMAMP,IROPER 1522C 1523 LOGICAL FIRSTCALL 1524 SAVE FIRSTCALL 1525 DATA FIRSTCALL /.TRUE./ 1526 1527*------------------------------------------------------------------ 1528* test if operators are available and translate ILRSOP array 1529* from the PRPLBL_CC list to the new list maintained by IROPER: 1530*------------------------------------------------------------------ 1531 IF (FIRSTCALL) THEN 1532 IOPER = 1 1533 DO WHILE (IOPER .LE. NLRSOP) 1534 LABEL = PRPLBL_CC(ILRSOP(IOPER)) 1535 IF (DEBUG) WRITE(LUPRI,'(/2X,2A)') 'CHECK OPERATOR: ',LABEL 1536 IF (IROPER(LABEL,ISYMO) .LT. 0) THEN 1537 WRITE(LUPRI,'(/2X,3A,/2X,2A)') 1538 & ' WARNING: THE OPERATOR WITH THE LABEL "', 1539 & LABEL,'" IS NOT AVAILABLE.', 1540 & ' CALCULATION OF TRANSITION MOMENTS IS CANCELED FOR THIS', 1541 & ' OPERATOR.' 1542 DO IDX = IOPER, NLRSOP-1 1543 ILRSOP(IDX) = ILRSOP(IDX+1) 1544 END DO 1545 NLRSOP = NLRSOP - 1 1546 ELSE 1547 IF(DEBUG)WRITE(LUPRI,'(/2X,3A)')'PUT: ',LABEL,' ON THE LIST.' 1548 ILRSOP(IOPER) = IROPER(LABEL,ISYMO) 1549 IOPER = IOPER + 1 1550 END IF 1551 END DO 1552 FIRSTCALL = .FALSE. 1553 END IF ! (FIRSTCALL) 1554C 1555 IF (LOCDBG) THEN 1556 WRITE(LUPRI,'(/,A)') ' Updated list in CC_OPAIND:' 1557 DO IOPER = 1, NLRSOP 1558 WRITE(LUPRI,*) IOPER,ILRSOP(IOPER),' ', 1559 * LBLOPR(ILRSOP(IOPER)),ISYOPR(ILRSOP(IOPER)) 1560 ENDDO 1561 ENDIF 1562C 1563C------------------------------------ 1564C Fill in equations to be solved. 1565C------------------------------------ 1566C 1567 NXLRSST = 0 1568C 1569 DO ISYME = 1, NSYM 1570 DO IEX = 1, NCCEXCI(ISYME,1) 1571 ISTATE = ISYOFE(ISYME)+IEX 1572 EIGV = EIGVAL(ISTATE) 1573 1574 IF (SELLRS) THEN 1575 ! check, if state has been requested 1576 TAKE_STATE = .FALSE. 1577 DO IDX = 1,NSELRS 1578 IF (ISYME.EQ.ISELRSYM(IDX) .AND. IEX.EQ.ISELRSTA(IDX)) THEN 1579 TAKE_STATE = .TRUE. 1580 ENDIF 1581 END DO 1582 ELSE 1583 TAKE_STATE = .TRUE. 1584 ENDIF 1585 1586 IF (TAKE_STATE) THEN 1587 NXLRSST = NXLRSST + 1 1588 IF (NXLRSST.GT.MXLRSST) THEN 1589 WRITE(LUPRI,*) 'NXLRSST =',NXLRSST,'MXLRSST= ',MXLRSST 1590 CALL QUIT(' Too many states in CC_OPAIND') 1591 ENDIF 1592 ILRSST(NXLRSST) = ISTATE 1593 1594 IF (.NOT.CIS) THEN 1595 DO IOPER = 1, NLRSOP 1596 LABEL = LBLOPR(ILRSOP(IOPER)) 1597 ISYMO = ISYOPR(ILRSOP(IOPER)) 1598 IF (ISYME.EQ.ISYMO) THEN 1599 IF (.NOT.LRS2N1) THEN 1600 INUM = IR1TAMP(LABEL,.FALSE.,-EIGV,ISYMO) 1601 ELSE 1602 INUM = ILRMAMP(ISTATE,EIGV,ISYME) 1603 ENDIF 1604 ENDIF 1605 END DO 1606 ENDIF 1607 END IF ! (TAKE_STATE) 1608 1609 END DO 1610 END DO 1611C 1612 RETURN 1613 END 1614*---------------------------------------------------------------------* 1615c /* deck cc_xopaind */ 1616*=====================================================================* 1617 SUBROUTINE CC_XOPAIND 1618*---------------------------------------------------------------------* 1619* 1620* Purpose: Control input and equations for calculation of 1621* one-photon absorption strengths for excited to 1622* to excited state transitions 1623* 1624* Christof Haettig, October 2003, Friedrichstal 1625* 1626*=====================================================================* 1627 IMPLICIT NONE 1628#include "priunit.h" 1629#include "ccorb.h" 1630#include "ccexci.h" 1631#include "ccexcinf.h" 1632#include "ccrspprp.h" 1633#include "ccxopainf.h" 1634#include "ccsdinp.h" 1635#include "ccroper.h" 1636 1637 LOGICAL LOCDBG 1638 PARAMETER (LOCDBG = .FALSE.) 1639 1640 CHARACTER*8 LABEL 1641 LOGICAL TAKE_STATE_PAIR 1642 INTEGER ISYMO, INUM, ISYMI, ISYMF, ISTATEI, ISTATEF, IEXI, IEXF, 1643 & IDX, ISYMFI, IOPER, I, NSYMF, NEXF 1644 1645 REAL*8 EIGVI, EIGVF 1646* functions: 1647 INTEGER IROPER, IR1TAMP, IN2AMP 1648 1649 LOGICAL FIRSTCALL 1650 SAVE FIRSTCALL 1651 DATA FIRSTCALL /.TRUE./ 1652 1653*------------------------------------------------------------------ 1654* test if operators are available and translate IQR2OP array 1655* from the PRPLBL_CC list to the new list maintained by IROPER: 1656*------------------------------------------------------------------ 1657 IF (FIRSTCALL) THEN 1658 IOPER = 1 1659 DO WHILE (IOPER .LE. NQR2OP) 1660 LABEL = PRPLBL_CC(IQR2OP(IOPER)) 1661 IF (DEBUG) WRITE(LUPRI,'(/2X,2A)') 'CHECK OPERATOR: ',LABEL 1662 IF (IROPER(LABEL,ISYMO) .LT. 0) THEN 1663 WRITE(LUPRI,'(/2X,3A,/2X,2A)') 1664 & ' WARNING: THE OPERATOR WITH THE LABEL "', 1665 & LABEL,'" IS NOT AVAILABLE.', 1666 & ' CALCULATION OF TRANSITION MOMENTS IS CANCELED FOR THIS', 1667 & ' OPERATOR.' 1668 DO IDX = IOPER, NQR2OP-1 1669 IQR2OP(IDX) = IQR2OP(IDX+1) 1670 END DO 1671 NQR2OP = NQR2OP - 1 1672 ELSE 1673 IF(DEBUG)WRITE(LUPRI,'(/2X,3A)')'PUT: ',LABEL,' ON THE LIST.' 1674 IQR2OP(IOPER) = IROPER(LABEL,ISYMO) 1675 IOPER = IOPER + 1 1676 END IF 1677 END DO 1678 FIRSTCALL = .FALSE. 1679 END IF ! (FIRSTCALL) 1680C 1681 IF (LOCDBG) THEN 1682 WRITE(LUPRI,'(/,A)') ' Updated list in CC_XOPAIND:' 1683 DO IOPER = 1, NQR2OP 1684 WRITE(LUPRI,*) IOPER,IQR2OP(IOPER),' ', 1685 * LBLOPR(IQR2OP(IOPER)),ISYOPR(IQR2OP(IOPER)) 1686 ENDDO 1687 ENDIF 1688C 1689C------------------------------------ 1690C Fill in equations to be solved. 1691C------------------------------------ 1692C 1693 IF (LOCDBG) WRITE(LUPRI,*) 'SELQR2:',SELQR2 1694C 1695 NXQR2ST = 0 1696C 1697 DO ISYMI = 1, NSYM 1698 1699 NSYMF = NSYM 1700 IF (.NOT.SELQR2) NSYMF = ISYMI 1701 DO ISYMF = 1, NSYMF 1702 1703 DO IEXI = 1, NCCEXCI(ISYMI,1) + NCCEXCI(ISYMI,3) 1704 NEXF = NCCEXCI(ISYMF,1) + NCCEXCI(ISYMF,3) 1705 IF ((.NOT.SELQR2).AND.(ISYMI.EQ.ISYMF)) NEXF = IEXI - 1 1706 DO IEXF = 1, NEXF 1707 1708 IF (LOCDBG) THEN 1709 WRITE(LUPRI,*) 'check for:',ISYMI,IEXI,ISYMF,IEXF 1710 END IF 1711 1712 IF (SELQR2) THEN 1713 ! check, if state pair has been selected 1714 TAKE_STATE_PAIR = .FALSE. 1715 DO I = 1,NSEQR2 1716 IF (ISYMI.EQ.ISEQR2SYM(I,1).AND.IEXI.EQ.ISEQR2STA(I,1).AND. 1717 * ISYMF.EQ.ISEQR2SYM(I,2).AND.IEXF.EQ.ISEQR2STA(I,2) ) 1718 * THEN 1719 TAKE_STATE_PAIR = .TRUE. 1720 ENDIF 1721 END DO 1722 ELSE 1723 TAKE_STATE_PAIR = .TRUE. 1724 END IF 1725 1726 IF (LOCDBG) WRITE(LUPRI,*) 'TAKE_STATE_PAIR:',TAKE_STATE_PAIR 1727 1728 IF (TAKE_STATE_PAIR) THEN 1729 NXQR2ST = NXQR2ST + 1 1730 IF (NXQR2ST.GT.MXQR2ST) THEN 1731 WRITE(LUPRI,*) 'NXQR2ST =',NXQR2ST,'MXQR2ST= ',MXQR2ST 1732 CALL QUIT(' Too many states in CC_XOPAIND') 1733 ENDIF 1734 ISTATEI = ISYOFE(ISYMI)+IEXI 1735 ISTATEF = ISYOFE(ISYMF)+IEXF 1736 IQR2ST(NXQR2ST,1) = ISTATEI 1737 IQR2ST(NXQR2ST,2) = ISTATEF 1738 1739 IF (.NOT.CIS) THEN 1740 ISYMFI = MULD2H(ISYMI,ISYMF) 1741 EIGVI = EIGVAL(ISTATEI) 1742 EIGVF = EIGVAL(ISTATEF) 1743 1744 DO IOPER = 1, NQR2OP 1745 LABEL = LBLOPR(IQR2OP(IOPER)) 1746 ISYMO = ISYOPR(IQR2OP(IOPER)) 1747 IF (ISYMO.EQ.ISYMFI) THEN 1748 if (LSKIPLINEQ) then 1749 if (locdbg) then 1750 write(lupri,*)'SONIA XOPAIND WARNING' 1751 write(lupri,*)'XOPAIND: skip lin eqs' 1752 end if 1753 else 1754 IF (.NOT.QR22N1) THEN 1755 INUM=IR1TAMP(LABEL,.FALSE.,EIGVI-EIGVF,ISYMO) 1756 INUM=IR1TAMP(LABEL,.FALSE.,EIGVF-EIGVI,ISYMO) 1757 ELSE 1758 INUM=IN2AMP(ISTATEI,-EIGVI,ISYMI,ISTATEF,+EIGVF,ISYMF) 1759 INUM=IN2AMP(ISTATEF,-EIGVF,ISYMF,ISTATEI,+EIGVI,ISYMI) 1760 END IF 1761 end if 1762 END IF 1763 END DO 1764 END IF 1765 END IF 1766 1767 END DO 1768 END DO 1769 END DO 1770 END DO 1771C 1772 IF (LOCDBG) THEN 1773 WRITE(LUPRI,'(a,i3,a)') 1774 & 'Transition strengths will be computed for',NXQR2ST, 1775 & 'transitions' 1776 END IF 1777C 1778 RETURN 1779 END 1780*---------------------------------------------------------------------* 1781c /* deck cc_lrsind */ 1782*=====================================================================* 1783 SUBROUTINE CC_LRSIND 1784*---------------------------------------------------------------------* 1785* 1786* Purpose: Control input and equations for calculation of 1787* residues of the linear response function. 1788* 1789* OC 8-11-1996/Modified April 1997 1790* 1791*=====================================================================* 1792#include "implicit.h" 1793#include "priunit.h" 1794#include "ccorb.h" 1795#include "cclrinf.h" 1796#include "ccrspprp.h" 1797#include "ccexci.h" 1798#include "cclres.h" 1799#include "ccsdinp.h" 1800#include "ccsdsym.h" 1801#include "cclr.h" 1802#include "ccroper.h" 1803 CHARACTER*8 LABEL,LABELA,LABELB 1804 INTEGER ISYMB, ISYMA, IFRB, IFRA, INUM, IOP, ISYME 1805 1806 REAL*8 EIGV 1807* functions: 1808 INTEGER IR1TAMP,ILRMAMP 1809C 1810 LOGICAL FIRSTCALL 1811 SAVE FIRSTCALL 1812 DATA FIRSTCALL /.TRUE./ 1813C 1814C------------------------------------------------------------------ 1815C Add residue response equations to list to be solved for CCLR. 1816C------------------------------------------------------------------ 1817C 1818*------------------------------------------------------------------ 1819* test if operators are available and translate IALROP, IBLROP 1820* arrays from the PRPLBL_CC list to the new list maintained by IROPER. 1821*------------------------------------------------------------------ 1822 IF (FIRSTCALL) THEN 1823 IOPER = 1 1824 DO WHILE (IOPER .LE. NLRSOP) 1825 LABELA = PRPLBL_CC(IALRSOP(IOPER)) 1826 LABELB = PRPLBL_CC(IBLRSOP(IOPER)) 1827 IF (DEBUG) THEN 1828 WRITE(LUPRI,'(/2X,A,3(1X,A),A)') 1829 & 'CHECK LRSD DOUBLE:',LABELA, LABELB 1830 ENDIF 1831 IF ( (IROPER(LABELA,ISYMA) .LT. 0) 1832 & .OR. (IROPER(LABELB,ISYMB) .LT. 0) ) THEN 1833 WRITE(LUPRI,'(/2X,5A,/2X,2A)') 1834 & ' WARNING: ONE OF THE OPERATORS WITH THE LABELS "', 1835 & LABELA,'", "', LABELB,'" IS NOT AVAILABLE.', 1836 & ' LINEAR RESPONSE RESIDUE CALCULATION IS CANCELED FOR THIS', 1837 & ' OPERATOR DOUBLE.' 1838 DO IDX = IOPER, NLRSOP-1 1839 IALRSOP(IDX) = IALRSOP(IDX+1) 1840 IBLRSOP(IDX) = IBLRSOP(IDX+1) 1841 END DO 1842 NLRSOP = NLRSOP - 1 1843 ELSE 1844 IF (DEBUG) THEN 1845 WRITE(LUPRI,'(/2X,A,3(1X,A),A)') 1846 & 'PUT DOUBLE:',LABELA, LABELB,' ON THE LIST.' 1847 ENDIF 1848 IALRSOP(IOPER) = IROPER(LABELA,ISYMA) 1849 IBLRSOP(IOPER) = IROPER(LABELB,ISYMB) 1850 IOPER = IOPER + 1 1851 END IF 1852 END DO 1853 FIRSTCALL = .FALSE. 1854 END IF ! (FIRSTCALL) 1855C 1856 IF (DEBUG) THEN 1857 WRITE(LUPRI,'(/,A)') ' Updated list' 1858 DO IOPER = 1, NLRSOP 1859 WRITE(LUPRI,*) IOPER,IALRSOP(IOPER),' ', 1860 * LBLOPR(IALRSOP(IOPER)), 1861 * ISYOPR(IALRSOP(IOPER)),IBLRSOP(IOPER), 1862 * ' ',LBLOPR(IBLRSOP(IOPER)),ISYOPR(IBLRSOP(IOPER)) 1863 ENDDO 1864 ENDIF 1865C 1866C------------------------------------ 1867C Fill in equations to be solved. 1868C------------------------------------ 1869C 1870 NXLRSST = 0 1871C 1872 DO 100 ISYME = 1, NSYM 1873 DO 200 IEX = 1, NCCEXCI(ISYME,1) 1874C 1875 IF (SELLRS) THEN 1876C 1877C Check state has been calculated. 1878C 1879 DO 300 I = 1,NSELRS 1880 IF ((ISYME.EQ.ISELRS(I,1)) 1881 * .AND.(IEX.EQ.ISELRS(I,2))) THEN 1882 NXLRSST = NXLRSST + 1 1883 ILRSST(NXLRSST) = ISYOFE(ISYME)+IEX 1884 GO TO 350 1885 ENDIF 1886 300 CONTINUE 1887C 1888C------------------------------------------------------------------------ 1889C This state is not requested in oscillator strength calculation. 1890C GOTO end of loop. 1891C------------------------------------------------------------------------ 1892C 1893 GO TO 200 1894 ELSE 1895 NXLRSST = NXLRSST + 1 1896 IF (NXLRSST.GT.MXLRSST) THEN 1897 WRITE(LUPRI,*) 'NXLRSST =',NXLRSST,'MXLRSST= ',MXLRSST 1898 CALL QUIT(' Too many states for residue calculation') 1899 ENDIF 1900 ILRSST(NXLRSST) = ISYOFE(ISYME)+IEX 1901 ENDIF 1902 1903 350 CONTINUE 1904 1905 IF (.NOT.CIS) THEN 1906 DO 400 IOPER = 1, NLRSOP 1907 1908 ISYMA = ISYOPR(IALRSOP(IOPER)) 1909 ISYMB = ISYOPR(IBLRSOP(IOPER)) 1910 1911 IF ((ISYME.EQ.ISYMA).AND.(ISYME.EQ.ISYMB)) THEN 1912 1913 LABELA = LBLOPR(IALRSOP(IOPER)) 1914 LABELB = LBLOPR(IBLRSOP(IOPER)) 1915 if (SKIPLEQ) then 1916 !if (locdbg) then 1917 write(lupri,*)'SONIA LRESIND WARNING' 1918 write(lupri,*)'LRESIND: skip lin eqs' 1919 !end if 1920 else 1921 IF (.NOT.LRS2N1) THEN 1922 EIGV = -EIGVAL(ILRSST(NXLRSST)) 1923 INUM = IR1TAMP(LABELB,.FALSE.,EIGV,ISYMB) 1924 ELSE 1925 EIGV = EIGVAL(ILRSST(NXLRSST)) 1926 INUM = ILRMAMP(ILRSST(NXLRSST),EIGV,ISYMB) 1927 ENDIF 1928 end if 1929 1930 ENDIF 1931 400 CONTINUE 1932 ENDIF 1933 200 CONTINUE 1934 100 CONTINUE 1935C 1936 END 1937*---------------------------------------------------------------------* 1938c /* deck cc_qr2ind */ 1939*=====================================================================* 1940 SUBROUTINE CC_QR2IND 1941*---------------------------------------------------------------------* 1942* 1943* Purpose: Control input and equations for calculation of 1944* second residues of the quadratic response function. 1945* 1946* Ove Christiansen April 1997 1947* 1948*=====================================================================* 1949#include "implicit.h" 1950#include "priunit.h" 1951#include "ccorb.h" 1952#include "cclrinf.h" 1953#include "ccrspprp.h" 1954#include "ccexci.h" 1955#include "cclres.h" 1956#include "ccqr2r.h" 1957#include "ccn2rsp.h" 1958#include "ccsdinp.h" 1959#include "ccsdsym.h" 1960#include "cclr.h" 1961#include "ccroper.h" 1962 CHARACTER*8 LABEL,LABELA,LABELB 1963 INTEGER ISYMB, ISYMA, IFRB, IFRA, INUM, IOP, ISYMI, ISYMF 1964 1965 REAL*8 EIGV 1966 1967* functions: 1968 INTEGER IR1TAMP,IN2AMP 1969C 1970 LOGICAL FIRSTCALL 1971 SAVE FIRSTCALL 1972 DATA FIRSTCALL /.TRUE./ 1973C 1974C------------------------------------------------------------------ 1975C Add residue response equations to list to be solved for CCQR2 1976C------------------------------------------------------------------ 1977C 1978*------------------------------------------------------------------ 1979* test if operators are available and translate IALROP, IBLROP 1980* arrays from the PRPLBL_CC list to the new list maintained by IROPER. 1981*------------------------------------------------------------------ 1982 IF (FIRSTCALL) THEN 1983 IOPER = 1 1984 DO WHILE (IOPER .LE. NQR2OP) 1985 LABELA = PRPLBL_CC(IAQR2OP(IOPER)) 1986 LABELB = PRPLBL_CC(IBQR2OP(IOPER)) 1987 IF (DEBUG) THEN 1988 WRITE(LUPRI,'(/2X,A,3(1X,A),A)') 1989 & 'CHECK QR2R DOUBLE:',LABELA, LABELB 1990 ENDIF 1991 IF ( (IROPER(LABELA,ISYMA) .LT. 0) 1992 & .OR. (IROPER(LABELB,ISYMB) .LT. 0) ) THEN 1993 WRITE(LUPRI,'(/2X,5A,/2X,2A)') 1994 & ' WARNING: ONE OF THE OPERATORS WITH THE LABELS "', 1995 & LABELA,'", "', LABELB,'" IS NOT AVAILABLE.', 1996 & ' QUADRATIC RESPONSE 2. RESIDUE CALCULATION IS CANCELED ', 1997 & 'FOR THIS OPERATOR DOUBLE.' 1998 DO IDX = IOPER, NQR2OP-1 1999 IAQR2OP(IDX) = IAQR2OP(IDX+1) 2000 IBQR2OP(IDX) = IBQR2OP(IDX+1) 2001 END DO 2002 NQR2OP = NQR2OP - 1 2003 ELSE 2004 IF (DEBUG) THEN 2005 WRITE(LUPRI,'(/2X,A,3(1X,A),A)') 2006 & 'PUT DOUBLE:',LABELA, LABELB,' ON THE LIST.' 2007 ENDIF 2008 IAQR2OP(IOPER) = IROPER(LABELA,ISYMA) 2009 IBQR2OP(IOPER) = IROPER(LABELB,ISYMB) 2010 IOPER = IOPER + 1 2011 END IF 2012 END DO 2013 FIRSTCALL = .FALSE. 2014 END IF ! (FIRSTCALL) 2015C 2016 IF (DEBUG) THEN 2017 WRITE(LUPRI,'(/,A)') ' Updated list' 2018 DO IOPER = 1, NQR2OP 2019 WRITE(LUPRI,*) IOPER,IAQR2OP(IOPER),' ', 2020 * LBLOPR(IAQR2OP(IOPER)), 2021 * ISYOPR(IAQR2OP(IOPER)), 2022 * IBQR2OP(IOPER),' ', 2023 * LBLOPR(IBQR2OP(IOPER)), 2024 * ISYOPR(IBQR2OP(IOPER)) 2025 ENDDO 2026 ENDIF 2027C 2028C------------------------------------ 2029C Fill in equations to be solved. 2030C------------------------------------ 2031C 2032 NXQR2ST = 0 2033C 2034 DO 100 ISYMFI = 1, NSYM 2035 DO 200 ISYMF = 1, NSYM 2036 ISYMI = MULD2H(ISYMF,ISYMFI) 2037 IF ((.NOT.SELQR2).AND.(ISYMI.GT.ISYMF)) GOTO 200 2038 DO 300 IEXF = 1, NCCEXCI(ISYMF,1) 2039 NEXI = NCCEXCI(ISYMI,1) 2040 IF ((.NOT.SELQR2).AND.(ISYMI.EQ.ISYMF)) NEXI = IEXF - 1 2041 DO 400 IEXI = 1, NEXI 2042C 2043 IF (SELQR2) THEN 2044C 2045C Check state set has been selected and calculated. 2046C 2047 DO 500 I = 1,NSEQR2 2048 IF ((ISYMI.EQ.ISEQR2(I,1)) 2049 * .AND.(IEXI.EQ.ISEQR2(I,2)) 2050 * .AND.(ISYMF.EQ.ISEQR2(I,3)) 2051 * .AND.(IEXF.EQ.ISEQR2(I,4))) THEN 2052 NXQR2ST = NXQR2ST + 1 2053 IQR2STI(NXQR2ST) = ISYOFE(ISYMI)+IEXI 2054 IQR2STF(NXQR2ST) = ISYOFE(ISYMF)+IEXF 2055 GO TO 550 2056 ENDIF 2057 500 CONTINUE 2058C 2059C-------------------------------------------------------------------------- 2060C This state is not requested in oscillator strength calculation. 2061C GOTO end of loop. 2062C-------------------------------------------------------------------------- 2063C 2064 GO TO 400 2065 2066 ELSE 2067 NXQR2ST = NXQR2ST + 1 2068 IF (NXQR2ST.GT.MXQR2ST) THEN 2069 WRITE(LUPRI,*) 'NXQR2ST =',NXQR2ST,'MXQR2ST= ',MXQR2ST 2070 CALL QUIT(' Too many states for residue calculation') 2071 ENDIF 2072 IQR2STI(NXQR2ST) = ISYOFE(ISYMI)+IEXI 2073 IQR2STF(NXQR2ST) = ISYOFE(ISYMF)+IEXF 2074 ENDIF 2075 2076 550 CONTINUE 2077 2078 IF (.NOT.CIS) THEN 2079 DO 600 IOPER = 1, NQR2OP 2080 2081 ISYMA = ISYOPR(IAQR2OP(IOPER)) 2082 ISYMB = ISYOPR(IBQR2OP(IOPER)) 2083 ISYMAI = MULD2H(ISYMA,ISYMI) 2084 ISYMBF = MULD2H(ISYMB,ISYMF) 2085 IF ((ISYMAI.EQ.ISYMF).AND.(ISYMBF.EQ.ISYMI)) THEN 2086 LABELA = LBLOPR(IAQR2OP(IOPER)) 2087 LABELB = LBLOPR(IBQR2OP(IOPER)) 2088 IF (.NOT.QR22N1) THEN 2089 EIGVI = EIGVAL(IQR2STI(NXQR2ST)) 2090 EIGVF = EIGVAL(IQR2STF(NXQR2ST)) 2091 EIGV = EIGVI - EIGVF 2092 INUM = IR1TAMP(LABELB,.FALSE.,EIGV,ISYMB) 2093 EIGV = - EIGVI + EIGVF 2094 INUM = IR1TAMP(LABELA,.FALSE.,EIGV,ISYMA) 2095 ELSE 2096 EIGVI = EIGVAL(IQR2STI(NXQR2ST)) 2097 EIGVF = EIGVAL(IQR2STF(NXQR2ST)) 2098 INUM = IN2AMP(IQR2STI(NXQR2ST),-EIGVI,ISYMI, 2099 * IQR2STF(NXQR2ST),EIGVF,ISYMF) 2100 INUM = IN2AMP(IQR2STF(NXQR2ST),-EIGVF,ISYMF, 2101 * IQR2STI(NXQR2ST),EIGVI,ISYMI) 2102 ENDIF 2103 2104 ENDIF 2105 600 CONTINUE 2106 ENDIF 2107 400 CONTINUE 2108 300 CONTINUE 2109 200 CONTINUE 2110 100 CONTINUE 2111C 2112 END 2113*---------------------------------------------------------------------* 2114c /* deck cc_lrind */ 2115*=====================================================================* 2116 SUBROUTINE CC_LRIND(WORK,LWORK) 2117*---------------------------------------------------------------------* 2118* 2119* Purpose: determine which the response t amplitudes and zeta 2120* multipliers required for the dynamic polarizabilities 2121* 2122* Written by Christof Haettig, October 1996. 2123* 2124* OC 32-10-1996: ASYMSD option. 2125* OC dec. 1996: Cauchy moment section. 2126* CH oct. 1997: ASYMSD option for Cauchy moment section. 2127* CH nov. 1998: relaxed response. 2128* CH feb. 1999: missing (anti-)symmetrization in +/- w introduced. 2129* CH may. 1999: changes for first-order property gradients 2130* CH apr. 2002: changes for CC3 freq.-dep. polarizabilities 2131* 2132*=====================================================================* 2133 USE PELIB_INTERFACE, ONLY: USE_PELIB 2134#include "implicit.h" 2135#include "priunit.h" 2136#include "ccorb.h" 2137#include "cclrinf.h" 2138#include "ccrspprp.h" 2139#include "ccsdinp.h" 2140#include "ccsections.h" 2141#include "ccroper.h" 2142#include "mxcent.h" 2143#include "cclr.h" 2144 2145* local parameters: 2146 LOGICAL LOCDBG 2147 PARAMETER (LOCDBG = .FALSE.) 2148 2149* variables: 2150 CHARACTER*8 LABEL, LABELA, LABELB, LABSOP 2151 CHARACTER*3 LSTRLX 2152 LOGICAL SKIP_IT, LRLXA, LRLXB, LPDBSA, LPDBSB 2153 LOGICAL DIFDIP, SYM1ONLY 2154 INTEGER ISYMB,ISYMA,IFRB,IFRA,INUM,IOP,ICAUCH,ISYH0,IR1A,IR1B 2155 INTEGER ISYM0, ISYSOP, ISGNSOP 2156 2157 REAL*8 WORK(LWORK), FREQ 2158 2159* functions: 2160 INTEGER IR1TAMP 2161 INTEGER IL1ZETA 2162 INTEGER ILRCAMP 2163 INTEGER ILC1AMP 2164 INTEGER IROPER 2165 INTEGER IETA1 2166 2167 LOGICAL FIRSTCALL 2168 SAVE FIRSTCALL 2169 DATA FIRSTCALL /.TRUE./ 2170 2171*------------------------------------------------------------------ 2172* test if operators are available and translate IALROP, IBLROP 2173* arrays from the PRPLBL_CC list to the new list maintained by IROPER. 2174*------------------------------------------------------------------ 2175 IF (FIRSTCALL) THEN 2176 2177 IOPER = 1 2178 DO WHILE (IOPER .LE. NLROP) 2179 SKIP_IT = .FALSE. 2180 LABELA = PRPLBL_CC(IALROP(IOPER)) 2181 LABELB = PRPLBL_CC(IBLROP(IOPER)) 2182 IOPA = IROPER(LABELA,ISYMA) 2183 IOPB = IROPER(LABELB,ISYMB) 2184 2185 IF ( IOPA.LT.0 .OR. IOPB.LT.0 ) THEN 2186 WRITE(LUPRI,'(/2X,5A,/2X,2A)') 2187 & ' WARNING: ONE OF THE OPERATORS WITH THE LABELS "', 2188 & LABELA,'", "', LABELB,'" IS NOT AVAILABLE.', 2189 & ' LINEAR RESPONSE CALCULATION IS CANCELED FOR THIS', 2190 & ' OPERATOR PAIR.' 2191 SKIP_IT = .TRUE. 2192 END IF 2193 2194 IF (.NOT.SKIP_IT) THEN 2195 ! if we have field-dependent basis sets, we need also 2196 ! to check, if the second-derivative integrals for this 2197 ! perturbation pair are available 2198 IF (LPDBSOP(IOPA) .OR. LPDBSOP(IOPB)) THEN 2199 CALL CC_FIND_SO_OP(LABELA,LABELB,LABSOP,ISYSOP, 2200 & ISGNSOP,INUM,WORK,LWORK) 2201 IF (INUM.LT.0) SKIP_IT = .TRUE. 2202 END IF 2203 END IF 2204 2205 IF (SKIP_IT) THEN 2206 DO IDX = IOPER, NLROP-1 2207 IALROP(IDX) = IALROP(IDX+1) 2208 IBLROP(IDX) = IBLROP(IDX+1) 2209 LALORX(IDX) = LALORX(IDX+1) 2210 LBLORX(IDX) = LBLORX(IDX+1) 2211 END DO 2212 NLROP = NLROP - 1 2213 ELSE 2214 IALROP(IOPER) = IROPER(LABELA,ISYMA) 2215 IBLROP(IOPER) = IROPER(LABELB,ISYMB) 2216 IOPER = IOPER + 1 2217 END IF 2218 2219 END DO 2220 FIRSTCALL = .FALSE. 2221 END IF ! (FIRSTCALL) 2222 2223 2224*---------------------------------------------------------------------* 2225* set: a) linear response equations to be solved 2226* b) effective Fock operators to be calculated 2227* c) nuclear contributions to be calculated 2228*---------------------------------------------------------------------* 2229 DIFDIP = .FALSE. 2230 2231 DO IOPER = 1, NLROP 2232 LABELA = LBLOPR(IALROP(IOPER)) 2233 LABELB = LBLOPR(IBLROP(IOPER)) 2234 2235 ISYMA = ISYOPR(IALROP(IOPER)) 2236 ISYMB = ISYOPR(IBLROP(IOPER)) 2237 2238 LRLXA = LALORX(IOPER) 2239 LRLXB = LBLORX(IOPER) 2240 2241 LPDBSA = LPDBSOP(IALROP(IOPER)) 2242 LPDBSB = LPDBSOP(IBLROP(IOPER)) 2243 2244 IF ((LRLXA.OR.LRLXB.OR.LPDBSA.OR.LPDBSB) .AND. CC3) 2245 & CALL QUIT('Relaxed CC3 linear response no implemented.') 2246 2247 IF (ISYMA.EQ.ISYMB) THEN 2248 2249 IF (DEBUG) THEN 2250 WRITE(LUPRI,'(/2X,A,2(1X,A,2L1))') 2251 & 'require linear responses for double:', 2252 & LABELA, LRLXA, LPDBSA, LABELB, LRLXB, LPDBSB 2253 ENDIF 2254 DO IFREQ = 1, NBLRFR 2255 DO ISIGN = +1, -1, -2 2256 2257 SIGN = DBLE(ISIGN) 2258 FREQA = SIGN * ALRFR(IFREQ) 2259 FREQB = SIGN * BLRFR(IFREQ) 2260 2261 INUM = IR1TAMP(LABELB,LRLXB,FREQB,ISYMB) 2262 IF (LRLXB.OR.LPDBSB) INUM = IETA1(LABELB,LRLXB,FREQB,ISYMB) 2263 IF (CCSLV.OR.USE_PELIB()) 2264 & INUM = IL1ZETA(LABELB,LRLXB,FREQB,ISYMB) 2265 IF (.NOT. ASYMSD) THEN 2266 INUM = IR1TAMP(LABELA,LRLXA,FREQA,ISYMA) 2267 IF (LRLXA.OR.LPDBSA) INUM=IETA1(LABELA,LRLXA,FREQA,ISYMA) 2268 IF (CCSLV.OR.USE_PELIB()) 2269 & INUM=IL1ZETA(LABELA,LRLXA,FREQA,ISYMA) 2270 ELSE 2271 INUM = IL1ZETA(LABELB,LRLXB,FREQB,ISYMB) 2272 ENDIF 2273 2274 2275 IF (LRLXB .OR. LPDBSB) THEN 2276 INUM = IEFFFOCK(LABELA,ISYMA,1) 2277 INUM = IEXPECT(LABELA,ISYMA,1) 2278 END IF 2279 IF (LRLXA .OR. LPDBSA) THEN 2280 INUM = IEFFFOCK(LABELB,ISYMB,1) 2281 INUM = IEXPECT(LABELB,ISYMB,1) 2282 END IF 2283 IF ((LRLXB.OR.LPDBSB) .AND. (LRLXA.OR.LPDBSA)) THEN 2284 INUM = I1DXFCK('HAM0 ','R1 ',LABELA,FREQA,ISYMA) 2285 INUM = I1DXFCK('HAM0 ','R1 ',LABELB,FREQB,ISYMB) 2286 INUM = IEFFFOCK('HAM0 ',1,1) 2287 INUM = IEXPECT('HAM0 ',1,1) 2288 END IF 2289 2290 IF (LPDBSA .OR. LPDBSB) THEN 2291 CALL CC_FIND_SO_OP(LABELA,LABELB,LABSOP,ISYSOP, 2292 & ISGNSOP,INUM,WORK,LWORK) 2293 IF (INUM.LT.0) CALL QUIT('Operator error in CC_LRIND.') 2294 INUM = IEFFFOCK(LABSOP,ISYSOP,2) 2295 INUM = IEXPECT(LABSOP,ISYSOP,2) 2296 2297 IF (LABSOP(4:6).EQ.'DPG') THEN 2298 DIFDIP = .TRUE. 2299 ELSE IF (LABSOP(3:5).EQ.'QDG') THEN 2300 CONTINUE 2301 ELSE IF (LABSOP(3:5).EQ.'OCG') THEN 2302 CONTINUE 2303 ELSE IF (LABSOP(2:6).EQ.'-CM1 ') THEN 2304 CONTINUE 2305 ELSE IF (LABSOP(4:7).EQ.' NST') THEN 2306 CONTINUE 2307 ELSE 2308 WRITE (LUPRI,*) 2309 & 'Illegal or unknown label in CC_LRIND:',LABSOP 2310 CALL QUIT('Illegal or unknown label in CC_LRIND.') 2311 END IF 2312 END IF 2313 2314 END DO 2315 END DO 2316 END IF 2317 2318 END DO 2319C 2320C Note: this is required to get CAUCHY vectors in correct order. 2321C 2322 IF (CAUCHY) THEN 2323 2324 ! switch off a special treatment of cauchy vectors in the 2325 ! solver which cannot be used with CC3 2326 IF (CC3) NEWCAU = .FALSE. 2327 2328 DO ISYM = 1, NSYM 2329 DO ICAUCH = 1, NLRDISP 2330 DO IOPER = 1, NLROP 2331 LABELA = LBLOPR(IALROP(IOPER)) 2332 LABELB = LBLOPR(IBLROP(IOPER)) 2333 ISYMA = ISYOPR(IALROP(IOPER)) 2334 ISYMB = ISYOPR(IBLROP(IOPER)) 2335 LRLXA = LALORX(IOPER) 2336 LRLXB = LBLORX(IOPER) 2337 LPDBSA = LPDBSOP(IALROP(IOPER)) 2338 LPDBSB = LPDBSOP(IBLROP(IOPER)) 2339 2340 IF (LRLXA .OR. LRLXB) THEN 2341 WRITE (LUPRI,*) 2342 & 'Warning: orbital relaxation is ignored ', 2343 & 'in the calculation of Cauchy moments.' 2344 END IF 2345 2346 IF (LPDBSA .OR. LPDBSB) THEN 2347 WRITE (LUPRI,*) 2348 & 'Error: Cauchy moments not implemented', 2349 & 'for field-dependent basis sets.' 2350 CALL QUIT('No Cauchy moments for '// 2351 & 'field-dep. basis sets.') 2352 END IF 2353 2354 IF ((ISYMA.EQ.ISYMB).AND.(ISYM.EQ.ISYMA)) THEN 2355 INUM = ILRCAMP(LABELB,ICAUCH,ISYMB) 2356 IF (ASYMSD) THEN 2357 INUM = ILC1AMP(LABELB,ICAUCH,ISYMB) 2358 ELSE 2359 INUM = ILRCAMP(LABELA,ICAUCH,ISYMA) 2360 END IF 2361 END IF 2362 END DO 2363 END DO 2364 END DO 2365 END IF 2366C 2367C let abacus precalculate nuclear contributions: 2368C 2369 IF (DIFDIP) THEN 2370 KCSTRA = 1 2371 KSCTRA = KCSTRA + MXCOOR*MXCOOR 2372 KEND = KSCTRA + MXCOOR*MXCOOR 2373 LEND = LWORK - KEND 2374 2375 IF (LEND.LT.0) THEN 2376 CALL QUIT('Insufficient memory in CC_LRIND.') 2377 END IF 2378 2379 SYM1ONLY = .FALSE. 2380 CALL CC_SETDORPS('1DHAM ',SYM1ONLY,0) 2381 CALL DIPNUC(WORK(KCSTRA),WORK(KSCTRA),IPRINT,DIFDIP) 2382 2383 END IF 2384 2385 RETURN 2386 END 2387*---------------------------------------------------------------------* 2388c /* deck cc_qrind */ 2389*=====================================================================* 2390 SUBROUTINE CC_QRIND(WORK,LWORK) 2391*---------------------------------------------------------------------* 2392* 2393* Purpose: Determine which response t amplitudes and zeta 2394* multipliers required for the first hyperpolarizabilities 2395* and their dispersion coefficients 2396* 2397* Written by Christof Haettig, October 1996. 2398* Dispersion coefficients, October 1997 (Christof Haettig) 2399* Relaxed response for one of the operators, June 1999 (Ch. Haettig) 2400* 2401*=====================================================================* 2402#if defined (IMPLICIT_NONE) 2403 IMPLICIT NONE 2404#else 2405# include "implicit.h" 2406#endif 2407#include "priunit.h" 2408#include "ccorb.h" 2409#include "ccqrinf.h" 2410#include "ccrspprp.h" 2411#include "ccroper.h" 2412#include "ccsdinp.h" 2413 2414* local parameters: 2415 LOGICAL LOCDBG 2416 PARAMETER (LOCDBG = .FALSE.) 2417 2418* variables: 2419 CHARACTER*8 LABELA, LABELB, LABELC, LABSOP 2420 LOGICAL LORXA,LORXB,LORXC, LPDBSA,LPDBSB,LPDBSC, SKIP_IT 2421 LOGICAL LRELAX 2422 INTEGER ISYMB, ISYMC, ISYMA, IFREQ, IDISP, INUM, IOPER, IDX 2423 INTEGER ICA,ICB,ICC,ICTOT,ISACAU,ISAMA,ISAMB,ISAMC,ISAPROP 2424 INTEGER IOPA, IOPB, IOPC, NLORX, ISYSOP, LWORK, ISGNSOP 2425 2426 REAL*8 WORK 2427 REAL*8 FREQA, FREQB, FREQC 2428 2429* external functions: 2430 INTEGER IR1TAMP 2431 INTEGER IL1ZETA 2432 INTEGER IROPER 2433 INTEGER ILRCAMP 2434 INTEGER ILC1AMP 2435 INTEGER ICR2AMP 2436 INTEGER IR2TAMP 2437 2438* data: 2439 LOGICAL FIRSTCALL 2440 SAVE FIRSTCALL 2441 DATA FIRSTCALL /.TRUE./ 2442 CHARACTER*7 CISA(-1:1) 2443 DATA CISA /'odd ','unknown','even '/ 2444 2445 2446*---------------------------------------------------------------------* 2447* test if operators are available and translate IAQROP, IBQROP, ICQROP 2448* arrays from the PRPLBL_CC list to the new list maintained by IROPER. 2449*---------------------------------------------------------------------* 2450 IF (FIRSTCALL) THEN 2451 2452 IOPER = 1 2453 DO WHILE (IOPER .LE. NQROPER) 2454 2455 SKIP_IT = .FALSE. 2456 LABELA = PRPLBL_CC(IAQROP(IOPER)) 2457 LABELB = PRPLBL_CC(IBQROP(IOPER)) 2458 LABELC = PRPLBL_CC(ICQROP(IOPER)) 2459 IOPA = IROPER(LABELA,ISYMA) 2460 IOPB = IROPER(LABELB,ISYMB) 2461 IOPC = IROPER(LABELC,ISYMC) 2462 LORXA = LAQLRX(IOPER) 2463 LORXB = LBQLRX(IOPER) 2464 LORXC = LCQLRX(IOPER) 2465 2466 IF (LOCDBG) THEN 2467 WRITE(LUPRI,'(/2X,A,3(1X,A),A)') 2468 & 'CHECK TRIPLE:',LABELA, LABELB, LABELC 2469 END IF 2470 2471 IF ( IOPA.LT.0 .OR. IOPB.LT.0 .OR. IOPC.LT.0 ) THEN 2472 WRITE(LUPRI,'(/2X,7A,/2X,2A)') 2473 & ' WARNING: ONE OF THE OPERATORS WITH THE LABELS "', 2474 & LABELA,'", "', LABELB,'", "', LABELC,'" IS NOT AVAILABLE.', 2475 & ' HYPERPOLARIZABILITY CALCULATION IS CANCELED FOR THIS', 2476 & ' OPERATOR TRIPLE.' 2477 SKIP_IT = .TRUE. 2478 END IF 2479 2480 NLORX = 0 2481 IF (LORXA .OR. LPDBSOP(IOPA)) NLORX = NLORX + 1 2482 IF (LORXB .OR. LPDBSOP(IOPB)) NLORX = NLORX + 1 2483 IF (LORXC .OR. LPDBSOP(IOPC)) NLORX = NLORX + 1 2484 2485 IF (NLORX.GT.1) THEN 2486 WRITE(LUPRI,'(/2X,8A,/2X,A,/2X,A)') 2487 & ' WARNING: OPERATOR TRIPLETT "', 2488 & LABELA,'", "', LABELB,'", "', LABELC,'"', 2489 & ' WITH MORE THAN ONE FIELD WHICH', 2490 & ' INVOKES ORBITAL RELAXATION OR A PERTUR.-DEP. BASIS SET.', 2491 & ' CALCULATION IS CANCELED FOR THIS OPERATOR TRIPLE.' 2492 END IF 2493 2494 IF (USE_R2 .AND. NLORX.GT.0) THEN 2495 WRITE (LUPRI,*) 'Second-order response vectors not yet', 2496 & ' implemented for fields which invoke' 2497 WRITE(LUPRI,*) 2498 & 'orbital relaxation or perturb.-dep. basis sets.' 2499 WRITE(LUPRI,*) 'USE_R2 option turned off.' 2500 USE_R2 = .FALSE. 2501 END IF 2502 2503 IF (.NOT. SKIP_IT) THEN 2504 ! if we have field-dependent basis sets, we need also 2505 ! to check, if the second-derivative integrals for this 2506 ! perturbation pair are available 2507 IF (LPDBSOP(IOPA) .OR. LPDBSOP(IOPB)) THEN 2508 CALL CC_FIND_SO_OP(LABELA,LABELB,LABSOP,ISYSOP, 2509 & ISGNSOP,INUM,WORK,LWORK) 2510 IF (INUM.LT.0) SKIP_IT = .TRUE. 2511 END IF 2512 IF (LPDBSOP(IOPA) .OR. LPDBSOP(IOPC)) THEN 2513 CALL CC_FIND_SO_OP(LABELA,LABELC,LABSOP,ISYSOP, 2514 & ISGNSOP,INUM,WORK,LWORK) 2515 IF (INUM.LT.0) SKIP_IT = .TRUE. 2516 END IF 2517 IF (LPDBSOP(IOPB) .OR. LPDBSOP(IOPC)) THEN 2518 CALL CC_FIND_SO_OP(LABELB,LABELC,LABSOP,ISYSOP, 2519 & ISGNSOP,INUM,WORK,LWORK) 2520 IF (INUM.LT.0) SKIP_IT = .TRUE. 2521 END IF 2522 iF (SKIP_IT) THEN 2523 WRITE(LUPRI,'(/2X,7A,/2X,A,/2X,A)') 2524 & ' WARNING: FOR THE OPERATOR TRIPLETT "', 2525 & LABELA,'", "', LABELB,'", "', LABELC,'"', 2526 & ' A SEC. ORD. OPERATOR IS MISSING.', 2527 & ' CALCULATION IS IGNORED.' 2528 END IF 2529 END IF 2530 2531 IF (SKIP_IT) THEN 2532 DO IDX = IOPER, NQROPER-1 2533 IAQROP(IDX) = IAQROP(IDX+1) 2534 IBQROP(IDX) = IBQROP(IDX+1) 2535 ICQROP(IDX) = ICQROP(IDX+1) 2536 LAQLRX(IDX) = LAQLRX(IDX+1) 2537 LBQLRX(IDX) = LBQLRX(IDX+1) 2538 LCQLRX(IDX) = LCQLRX(IDX+1) 2539 END DO 2540 NQROPER = NQROPER - 1 2541 ELSE 2542 WRITE(LUPRI,'(/2X,A,3(1X,A),A)') 2543 & 'PUT TRIPLE:',LABELA, LABELB, LABELC,' ON THE LIST.' 2544 IAQROP(IOPER) = IROPER(LABELA,ISYMA) 2545 IBQROP(IOPER) = IROPER(LABELB,ISYMB) 2546 ICQROP(IOPER) = IROPER(LABELC,ISYMC) 2547 IOPER = IOPER + 1 2548 END IF 2549 2550 END DO 2551 2552 FIRSTCALL = .FALSE. 2553 2554 END IF ! (FIRSTCALL) 2555 2556*---------------------------------------------------------------------* 2557* set list entries for the required response vectors: 2558*---------------------------------------------------------------------* 2559 IF (CC3) THEN 2560 WRITE(LUPRI,'(/5x,A/)') 2561 & 'Prepare CC3 quadratic response calculation.' 2562 IF (NQRDISP.GT.0) THEN 2563 NQRDISP = 0 2564 WRITE(LUPRI,'(/5x,A//)') 2565 & 'Dispersion coefficients (.DISPCF) are switched off for CC3.' 2566 END IF 2567 IF (USE_R2) THEN 2568 WRITE(LUPRI,'(2(/5x,A),/)') 2569 & 'Note: .USE R2 option will for CC3 call noddy code routines,', 2570 & ' which keep triples amplitudes in memory!!!' 2571 END IF 2572 END IF 2573 2574 DO IOPER = 1, NQROPER 2575 LABELA = LBLOPR(IAQROP(IOPER)) 2576 LABELB = LBLOPR(IBQROP(IOPER)) 2577 LABELC = LBLOPR(ICQROP(IOPER)) 2578 2579 LPDBSA = LPDBSOP(IAQROP(IOPER)) 2580 LPDBSB = LPDBSOP(IBQROP(IOPER)) 2581 LPDBSC = LPDBSOP(ICQROP(IOPER)) 2582 2583 ISYMA = ISYOPR(IAQROP(IOPER)) 2584 ISYMB = ISYOPR(IBQROP(IOPER)) 2585 ISYMC = ISYOPR(ICQROP(IOPER)) 2586 2587 ISAMA = ISYMAT(IAQROP(IOPER)) 2588 ISAMB = ISYMAT(IBQROP(IOPER)) 2589 ISAMC = ISYMAT(ICQROP(IOPER)) 2590 2591 IOPA = IROPER(LABELA,ISYMA) 2592 IOPB = IROPER(LABELB,ISYMB) 2593 IOPC = IROPER(LABELC,ISYMC) 2594 2595 ISAPROP = ISAMA * ISAMB * ISAMC 2596 2597 LORXA = LAQLRX(IOPER) 2598 LORXB = LBQLRX(IOPER) 2599 LORXC = LCQLRX(IOPER) 2600 2601 LRELAX = LORXA.OR.LORXB.OR.LORXC.OR.LPDBSA.OR.LPDBSB.OR.LPDBSC 2602 IF (LRELAX.AND.CC3) CALL QUIT('No relaxed CC3 quadratic resp.') 2603 2604c WRITE(LUPRI,'(/2X,A,3(1X,A),A)') 2605c & 'require responses for triple:',LABELA, LABELB, LABELC 2606c WRITE(LUPRI,'(/2X,A,A)') 2607c & 'symmetry in the sign of the frequency is ',CISA(ISAPROP) 2608 2609 2610 IF (MULD2H(ISYMA,ISYMB).EQ.ISYMC) THEN 2611 2612* if we have field-dependent basis sets: 2613* -------------------------------------- 2614* we need to check, if the second-derivative integrals 2615* for the perturbation pair are available 2616 IF (LPDBSOP(IOPA) .OR. LPDBSOP(IOPB)) THEN 2617 CALL CC_FIND_SO_OP(LABELA,LABELB,LABSOP,ISYSOP, 2618 & ISGNSOP,INUM,WORK,LWORK) 2619 END IF 2620 IF (LPDBSOP(IOPA) .OR. LPDBSOP(IOPC)) THEN 2621 CALL CC_FIND_SO_OP(LABELA,LABELC,LABSOP,ISYSOP, 2622 & ISGNSOP,INUM,WORK,LWORK) 2623 END IF 2624 IF (LPDBSOP(IOPB) .OR. LPDBSOP(IOPC)) THEN 2625 CALL CC_FIND_SO_OP(LABELB,LABELC,LABSOP,ISYSOP, 2626 & ISGNSOP,INUM,WORK,LWORK) 2627 END IF 2628 2629* for frequency-dependent hyperpolarizabilities: 2630* ---------------------------------------------- 2631 DO IFREQ = 1, NQRFREQ 2632 FREQA = AQRFR(IFREQ) 2633 FREQB = BQRFR(IFREQ) 2634 FREQC = CQRFR(IFREQ) 2635 2636 2637* request (unrelaxed) first-order t response vectors: 2638 2639 INUM = IR1TAMP(LABELA,LORXA,+FREQA,ISYMA) 2640 INUM = IR1TAMP(LABELB,LORXB,+FREQB,ISYMB) 2641 INUM = IR1TAMP(LABELC,LORXC,+FREQC,ISYMC) 2642 INUM = IR1TAMP(LABELA,LORXA,-FREQA,ISYMA) 2643 INUM = IR1TAMP(LABELB,LORXB,-FREQB,ISYMB) 2644 INUM = IR1TAMP(LABELC,LORXC,-FREQC,ISYMC) 2645 2646 2647* request first-order zeta response vectors: 2648 2649 INUM = IL1ZETA(LABELA,LORXA,+FREQA,ISYMA) 2650 INUM = IL1ZETA(LABELB,LORXB,+FREQB,ISYMB) 2651 INUM = IL1ZETA(LABELC,LORXC,+FREQC,ISYMC) 2652 INUM = IL1ZETA(LABELA,LORXA,-FREQA,ISYMA) 2653 INUM = IL1ZETA(LABELB,LORXB,-FREQB,ISYMB) 2654 INUM = IL1ZETA(LABELC,LORXC,-FREQC,ISYMC) 2655 2656* second-order amplitude (R2) vectors: 2657 IF (USE_R2) THEN 2658 INUM = IR2TAMP(LABELA,.FALSE.,+FREQA,ISYMA, 2659 & LABELB,.FALSE.,+FREQB,ISYMB) 2660 INUM = IR2TAMP(LABELA,.FALSE.,+FREQA,ISYMA, 2661 & LABELC,.FALSE.,+FREQC,ISYMC) 2662 INUM = IR2TAMP(LABELB,.FALSE.,+FREQB,ISYMB, 2663 & LABELC,.FALSE.,+FREQC,ISYMC) 2664 INUM = IR2TAMP(LABELA,.FALSE.,-FREQA,ISYMA, 2665 & LABELB,.FALSE.,-FREQB,ISYMB) 2666 INUM = IR2TAMP(LABELA,.FALSE.,-FREQA,ISYMA, 2667 & LABELC,.FALSE.,-FREQC,ISYMC) 2668 INUM = IR2TAMP(LABELB,.FALSE.,-FREQB,ISYMB, 2669 & LABELC,.FALSE.,-FREQC,ISYMC) 2670 END IF 2671 2672 END DO 2673 2674 2675 IF (.NOT. LRELAX) THEN 2676 2677* for dispersion coefficients: 2678* ---------------------------- 2679* for T(0) = RC(0) vectors is taken care of seperately, 2680* they should not be put to the Cauchy vector list, before 2681* the equations for the T vectors have been solved. 2682 2683 DO IDISP = 1, NQRDISP 2684 ICA = IQCAUA(IDISP) 2685 ICB = IQCAUB(IDISP) 2686 ICC = IQCAUC(IDISP) 2687 2688 ICTOT = ICA + ICB + ICC 2689 ISACAU = 2*( (ICTOT/2)*2 - ICTOT ) + 1 2690 2691 IF (ISACAU.EQ.ISAPROP .OR. ISAPROP.EQ.0 .OR. ALLDSPCF) THEN 2692 2693* request first-order right Cauchy vectors: 2694 2695 IF (ICA.GT.0) INUM = ILRCAMP(LABELA,ICA,ISYMA) 2696 IF (ICB.GT.0) INUM = ILRCAMP(LABELB,ICB,ISYMB) 2697 IF (ICC.GT.0) INUM = ILRCAMP(LABELC,ICC,ISYMC) 2698 2699* request first order left Cauchy vectors: 2700 2701 IF (ICA.GT.0) INUM = ILC1AMP(LABELA,ICA,ISYMA) 2702 IF (ICB.GT.0) INUM = ILC1AMP(LABELB,ICB,ISYMB) 2703 IF (ICC.GT.0) INUM = ILC1AMP(LABELC,ICC,ISYMC) 2704 2705* second-order right Cauchy (CR2) vectors: 2706 IF (USE_R2) THEN 2707 IF ((ICA+ICB).GT.0) 2708 & INUM = ICR2AMP(LABELA,ICA,ISYMA,LABELB,ICB,ISYMB) 2709 IF ((ICA+ICC).GT.0) 2710 & INUM = ICR2AMP(LABELA,ICA,ISYMA,LABELC,ICC,ISYMC) 2711 IF ((ICB+ICC).GT.0) 2712 & INUM = ICR2AMP(LABELB,ICB,ISYMB,LABELC,ICC,ISYMC) 2713 END IF 2714 2715 END IF 2716 2717 END DO 2718 2719 END IF 2720 2721 END IF 2722 2723 END DO 2724 2725 2726 RETURN 2727 END 2728*---------------------------------------------------------------------* 2729c /* deck cc_crind */ 2730*=====================================================================* 2731 SUBROUTINE CC_CRIND 2732*---------------------------------------------------------------------* 2733* 2734* Purpose: Determine which response t amplitudes and zeta 2735* multipliers required for the second hyperpolarizabilities 2736* and their dispersion coefficients 2737* 2738* Written by Christof Haettig, October 1996. 2739* Dispersion coefficients Februar 1998 (Christof Haettig). 2740* 2741*=====================================================================* 2742#if defined (IMPLICIT_NONE) 2743 IMPLICIT NONE 2744#else 2745# include "implicit.h" 2746#endif 2747#include "priunit.h" 2748#include "ccorb.h" 2749#include "cccrinf.h" 2750#include "ccrspprp.h" 2751#include "ccroper.h" 2752#include "cccperm.h" 2753#include "ccsdinp.h" 2754 2755* local parameters: 2756 LOGICAL LOCDBG 2757 PARAMETER (LOCDBG = .FALSE.) 2758 2759* variables: 2760 CHARACTER*8 LABELA, LABELB, LABELC, LABELD 2761 CHARACTER*8 LABEL1, LABEL2, LABEL3, LABEL4 2762 INTEGER ISYMB, ISYMC, ISYMA, ISYMD, IFREQ, INUM, IOPER, IDX 2763 INTEGER ICAUA, ICAUB, ICAUC, ICAUD, IDISP, ISYM1, ISYM2 2764 INTEGER ICAU1, ICAU2, ICAU3, ICAU4, ISYM3, ISYM4, P 2765 2766 REAL*8 FREQA, FREQB, FREQC, FREQD 2767 2768* external functions: 2769 INTEGER IR2TAMP 2770 INTEGER IL2ZETA 2771 INTEGER IR1TAMP 2772 INTEGER IL1ZETA 2773 INTEGER IROPER 2774 INTEGER ICHI2 2775 INTEGER IRHSR3 2776 INTEGER IRHSR2 2777 INTEGER IR3TAMP 2778 INTEGER ILRCAMP 2779 INTEGER ILC1AMP 2780 INTEGER ICR2AMP 2781 INTEGER ICL2AMP 2782 INTEGER IETACL2 2783 INTEGER IRHSCR2 2784 2785* data: 2786 LOGICAL FIRSTCALL 2787 SAVE FIRSTCALL 2788 DATA FIRSTCALL /.TRUE./ 2789 2790 2791 IF (LOCDBG) THEN 2792 WRITE (LUPRI,*) 'DEBUG_CC_CRIND> NCROPER = ',NCROPER 2793 END IF 2794 2795*---------------------------------------------------------------------* 2796* test if operators are available and translate IACROP, IBCROP, ICCROP 2797* and IDCROP arrays from the PRPLBL_CC list to the new list maintained 2798* by IROPER. 2799*---------------------------------------------------------------------* 2800 IF (FIRSTCALL) THEN 2801 2802 IOPER = 1 2803 DO WHILE (IOPER .LE. NCROPER) 2804 2805 LABELA = PRPLBL_CC(IACROP(IOPER)) 2806 LABELB = PRPLBL_CC(IBCROP(IOPER)) 2807 LABELC = PRPLBL_CC(ICCROP(IOPER)) 2808 LABELD = PRPLBL_CC(IDCROP(IOPER)) 2809 2810 IF ( (IROPER(LABELA,ISYMA) .LT. 0) 2811 & .OR. (IROPER(LABELB,ISYMB) .LT. 0) 2812 & .OR. (IROPER(LABELC,ISYMC) .LT. 0) 2813 & .OR. (IROPER(LABELD,ISYMD) .LT. 0) ) THEN 2814 2815 WRITE(LUPRI,'(/2X,9A,/2X,2A)') 2816 & ' WARNING: ONE OF THE OPERATORS WITH THE LABELS "', 2817 & LABELA,'", "', LABELB,'", "', LABELC,'", "',LABELD, 2818 & '" IS NOT AVAILABLE.', 2819 & ' HYPERPOLARIZABILITY CALCULATION IS CANCELED FOR THIS', 2820 & ' OPERATOR QUADRUPLE.' 2821 2822 DO IDX = IOPER, NCROPER-1 2823 IACROP(IDX) = IACROP(IDX+1) 2824 IBCROP(IDX) = IBCROP(IDX+1) 2825 ICCROP(IDX) = ICCROP(IDX+1) 2826 IDCROP(IDX) = IDCROP(IDX+1) 2827 END DO 2828 2829 NCROPER = NCROPER - 1 2830 2831 ELSE 2832 IACROP(IOPER) = IROPER(LABELA,ISYMA) 2833 IBCROP(IOPER) = IROPER(LABELB,ISYMB) 2834 ICCROP(IOPER) = IROPER(LABELC,ISYMC) 2835 IDCROP(IOPER) = IROPER(LABELD,ISYMD) 2836 2837 IOPER = IOPER + 1 2838 END IF 2839 2840 END DO 2841 2842 FIRSTCALL = .FALSE. 2843 2844 END IF ! (FIRSTCALL) 2845 2846*---------------------------------------------------------------------* 2847* set list entries for the required response vectors: 2848*---------------------------------------------------------------------* 2849 IF (CC3) THEN 2850 WRITE(LUPRI,'(/5x,A/)')'Prepare CC3 cubic response calculation.' 2851 IF (USE_LBCD) THEN 2852 USE_LBCD = .FALSE. 2853 WRITE(LUPRI,'(/5x,A//)') 2854 & 'USE_LBCD flag (.L2 BCD) is switched off for CC3.' 2855 END IF 2856 IF (USE_L2BC) THEN 2857 USE_L2BC = .FALSE. 2858 WRITE(LUPRI,'(/5x,A//)') 2859 & 'USE_L2BC flag (.L2 BC ) is switched off for CC3.' 2860 END IF 2861 IF (L_USE_CHI2) THEN 2862 L_USE_CHI2 = .FALSE. 2863 WRITE(LUPRI,'(/5x,A//)') 2864 & 'L_USE_CHI2 flag (.USECHI) is switched off for CC3.' 2865 END IF 2866 IF (L_USE_XKS3) THEN 2867 L_USE_XKS3 = .FALSE. 2868 WRITE(LUPRI,'(/5x,A//)') 2869 & 'L_USE_XKS3 flag (.USEXKS) is switched off for CC3.' 2870 END IF 2871 IF (NCRDISP.GT.0) THEN 2872 NCRDISP = 0 2873 WRITE(LUPRI,'(/5x,A//)') 2874 & 'Dispersion coefficients (.DISPCF) are switched off for CC3.' 2875 END IF 2876 END IF 2877 2878 IF (LOCDBG) THEN 2879 WRITE (LUPRI,*) 'USE_L2BC:',USE_L2BC 2880 WRITE (LUPRI,*) 'USE_LBCD:',USE_LBCD 2881 IF (USE_LBCD) THEN 2882 WRITE (LUPRI,*) 'use L2(BC),L2(BD),L2(CD) to eliminate the' 2883 WRITE (LUPRI,*) 'R2(AD),R2(AC),R2(AB) vectors...' 2884 ELSE IF (USE_L2BC) THEN 2885 WRITE (LUPRI,*) 'use L2(BC) to eliminate R2(AD)...' 2886 ELSE 2887 WRITE (LUPRI,*) 'use symmetric 2n+1/2n+2 rule formula...' 2888 END IF 2889 END IF 2890 2891 DO IOPER = 1, NCROPER 2892 LABELA = LBLOPR(IACROP(IOPER)) 2893 LABELB = LBLOPR(IBCROP(IOPER)) 2894 LABELC = LBLOPR(ICCROP(IOPER)) 2895 LABELD = LBLOPR(IDCROP(IOPER)) 2896 2897 ISYMA = ISYOPR(IACROP(IOPER)) 2898 ISYMB = ISYOPR(IBCROP(IOPER)) 2899 ISYMC = ISYOPR(ICCROP(IOPER)) 2900 ISYMD = ISYOPR(IDCROP(IOPER)) 2901 2902 2903 IF (MULD2H(ISYMA,ISYMB).EQ.MULD2H(ISYMC,ISYMD)) THEN 2904 2905* for frequency-dependent hyperpolarizabilities: 2906* ---------------------------------------------- 2907 DO IFREQ = 1, NCRFREQ 2908 FREQA = ACRFR(IFREQ) 2909 FREQB = BCRFR(IFREQ) 2910 FREQC = CCRFR(IFREQ) 2911 FREQD = DCRFR(IFREQ) 2912 2913 IF (LOCDBG) THEN 2914 WRITE (LUPRI,*) 'CC_CRIND> put on the list:', 2915 & LABELA,'(',FREQA,'), ', LABELB,'(',FREQB,'), ', 2916 & LABELC,'(',FREQC,'), ', LABELD,'(',FREQD,')' 2917 END IF 2918 2919* request second-order l and t response vectors: 2920 2921 IF (USE_LBCD) THEN 2922 INUM=IL2ZETA(LABELB,+FREQB,ISYMB,LABELC,+FREQC,ISYMC)!B,C 2923 INUM=IL2ZETA(LABELB,+FREQB,ISYMB,LABELD,+FREQD,ISYMD)!B,D 2924 INUM=IL2ZETA(LABELC,+FREQC,ISYMC,LABELD,+FREQD,ISYMD)!C,D 2925 2926 INUM=IL2ZETA(LABELB,-FREQB,ISYMB,LABELC,-FREQC,ISYMC)!B,C 2927 INUM=IL2ZETA(LABELB,-FREQB,ISYMB,LABELD,-FREQD,ISYMD)!B,D 2928 INUM=IL2ZETA(LABELC,-FREQC,ISYMC,LABELD,-FREQD,ISYMD)!C,D 2929 2930 INUM=IRHSR2(LABELA,.FALSE.,+FREQA,ISYMA, 2931 & LABELB,.FALSE.,+FREQB,ISYMB)!A,B 2932 INUM=IRHSR2(LABELA,.FALSE.,+FREQA,ISYMA, 2933 & LABELC,.FALSE.,+FREQC,ISYMC)!A,C 2934 INUM=IRHSR2(LABELA,.FALSE.,+FREQA,ISYMA, 2935 & LABELD,.FALSE.,+FREQD,ISYMD)!A,D 2936 2937 INUM=IRHSR2(LABELA,.FALSE.,-FREQA,ISYMA, 2938 & LABELB,.FALSE.,-FREQB,ISYMB)!A,B 2939 INUM=IRHSR2(LABELA,.FALSE.,-FREQA,ISYMA, 2940 & LABELC,.FALSE.,-FREQC,ISYMC)!A,C 2941 INUM=IRHSR2(LABELA,.FALSE.,-FREQA,ISYMA, 2942 & LABELD,.FALSE.,-FREQD,ISYMD)!A,D 2943 ELSE IF (USE_L2BC) THEN 2944 INUM=IL2ZETA(LABELB, +FREQB,ISYMB, 2945 & LABELC, +FREQC,ISYMC)!B,C 2946 INUM=IL2ZETA(LABELB, -FREQB,ISYMB, 2947 & LABELC, -FREQC,ISYMC)!B,C 2948 2949 INUM=IR2TAMP(LABELA,.FALSE.,+FREQA,ISYMA, 2950 & LABELB,.FALSE.,+FREQB,ISYMB)!A,B 2951 INUM=IR2TAMP(LABELA,.FALSE.,+FREQA,ISYMA, 2952 & LABELC,.FALSE.,+FREQC,ISYMC)!A,C 2953 2954 INUM=IR2TAMP(LABELA,.FALSE.,-FREQA,ISYMA, 2955 & LABELB,.FALSE.,-FREQB,ISYMB)!A,B 2956 INUM=IR2TAMP(LABELA,.FALSE.,-FREQA,ISYMA, 2957 & LABELC,.FALSE.,-FREQC,ISYMC)!A,C 2958 2959 INUM=IRHSR2(LABELA,.FALSE.,+FREQA,ISYMA, 2960 & LABELD,.FALSE.,+FREQD,ISYMD)!A,D 2961 INUM=IRHSR2(LABELA,.FALSE.,-FREQA,ISYMA, 2962 & LABELD,.FALSE.,-FREQD,ISYMD)!A,D 2963 ELSE 2964 INUM=IR2TAMP(LABELA,.FALSE.,+FREQA,ISYMA, 2965 & LABELB,.FALSE.,+FREQB,ISYMB)!A,B 2966 INUM=IR2TAMP(LABELA,.FALSE.,+FREQA,ISYMA, 2967 & LABELC,.FALSE.,+FREQC,ISYMC)!A,C 2968 INUM=IR2TAMP(LABELA,.FALSE.,+FREQA,ISYMA, 2969 & LABELD,.FALSE.,+FREQD,ISYMD)!A,D 2970 2971 INUM=IR2TAMP(LABELA,.FALSE.,-FREQA,ISYMA, 2972 & LABELB,.FALSE.,-FREQB,ISYMB)!A,B 2973 INUM=IR2TAMP(LABELA,.FALSE.,-FREQA,ISYMA, 2974 & LABELC,.FALSE.,-FREQC,ISYMC)!A,C 2975 INUM=IR2TAMP(LABELA,.FALSE.,-FREQA,ISYMA, 2976 & LABELD,.FALSE.,-FREQD,ISYMD)!A,D 2977 END IF 2978 2979 INUM=IR2TAMP(LABELB,.FALSE.,+FREQB,ISYMB, 2980 & LABELC,.FALSE.,+FREQC,ISYMC)!B,C 2981 INUM=IR2TAMP(LABELB,.FALSE.,+FREQB,ISYMB, 2982 & LABELD,.FALSE.,+FREQD,ISYMD)!B,D 2983 INUM=IR2TAMP(LABELC,.FALSE.,+FREQC,ISYMC, 2984 & LABELD,.FALSE.,+FREQD,ISYMD)!C,D 2985 2986 INUM=IR2TAMP(LABELB,.FALSE.,-FREQB,ISYMB, 2987 & LABELC,.FALSE.,-FREQC,ISYMC)!B,C 2988 INUM=IR2TAMP(LABELB,.FALSE.,-FREQB,ISYMB, 2989 & LABELD,.FALSE.,-FREQD,ISYMD)!B,D 2990 INUM=IR2TAMP(LABELC,.FALSE.,-FREQC,ISYMC, 2991 & LABELD,.FALSE.,-FREQD,ISYMD)!C,D 2992 2993* request second-order chi vectors: 2994 2995 IF (L_USE_CHI2) THEN 2996c INUM = ICHI2(LABELA,.FALSE.,+FREQA,ISYMA, 2997c & LABELB,.FALSE.,+FREQB,ISYMB)!A,B 2998c INUM = ICHI2(LABELA,.FALSE.,+FREQA,ISYMA, 2999c & LABELC,.FALSE.,+FREQC,ISYMC)!A,C 3000c INUM = ICHI2(LABELA,.FALSE.,+FREQA,ISYMA, 3001c & LABELD,.FALSE.,+FREQD,ISYMD)!A,D 3002c INUM = ICHI2(LABELB,.FALSE.,+FREQB,ISYMB, 3003c & LABELC,.FALSE.,+FREQC,ISYMC)!B,C 3004c INUM = ICHI2(LABELB,.FALSE.,+FREQB,ISYMB, 3005c & LABELD,.FALSE.,+FREQD,ISYMD)!B,D 3006c INUM = ICHI2(LABELC,.FALSE.,+FREQC,ISYMC, 3007c & LABELD,.FALSE.,+FREQD,ISYMD)!C,D 3008 3009c INUM = ICHI2(LABELA,.FALSE.,-FREQA,ISYMA, 3010c & LABELB,.FALSE.,-FREQB,ISYMB)!A,B 3011c INUM = ICHI2(LABELA,.FALSE.,-FREQA,ISYMA, 3012c & LABELC,.FALSE.,-FREQC,ISYMC)!A,C 3013c INUM = ICHI2(LABELA,.FALSE.,-FREQA,ISYMA, 3014c & LABELD,.FALSE.,-FREQD,ISYMD)!A,D 3015c INUM = ICHI2(LABELB,.FALSE.,-FREQB,ISYMB, 3016c & LABELC,.FALSE.,-FREQC,ISYMC)!B,C 3017c INUM = ICHI2(LABELB,.FALSE.,-FREQB,ISYMB, 3018c & LABELD,.FALSE.,-FREQD,ISYMD)!B,D 3019c INUM = ICHI2(LABELC,.FALSE.,-FREQC,ISYMC, 3020c & LABELD,.FALSE.,-FREQD,ISYMD)!C,D 3021 3022 INUM = IL2ZETA(LABELA,+FREQA,ISYMA, 3023 & LABELB,+FREQB,ISYMB)!A,B 3024 INUM = IL2ZETA(LABELA,+FREQA,ISYMA, 3025 & LABELC,+FREQC,ISYMC)!A,C 3026 INUM = IL2ZETA(LABELA,+FREQA,ISYMA, 3027 & LABELD,+FREQD,ISYMD)!A,D 3028 INUM = IL2ZETA(LABELB,+FREQB,ISYMB, 3029 & LABELC,+FREQC,ISYMC)!B,C 3030 INUM = IL2ZETA(LABELB,+FREQB,ISYMB, 3031 & LABELD,+FREQD,ISYMD)!B,D 3032 INUM = IL2ZETA(LABELC,+FREQC,ISYMC, 3033 & LABELD,+FREQD,ISYMD)!C,D 3034 3035 INUM = IL2ZETA(LABELA,-FREQA,ISYMA, 3036 & LABELB,-FREQB,ISYMB)!A,B 3037 INUM = IL2ZETA(LABELA,-FREQA,ISYMA, 3038 & LABELC,-FREQC,ISYMC)!A,C 3039 INUM = IL2ZETA(LABELA,-FREQA,ISYMA, 3040 & LABELD,-FREQD,ISYMD)!A,D 3041 INUM = IL2ZETA(LABELB,-FREQB,ISYMB, 3042 & LABELC,-FREQC,ISYMC)!B,C 3043 INUM = IL2ZETA(LABELB,-FREQB,ISYMB, 3044 & LABELD,-FREQD,ISYMD)!B,D 3045 INUM = IL2ZETA(LABELC,-FREQC,ISYMC, 3046 & LABELD,-FREQD,ISYMD)!C,D 3047 END IF 3048 3049* request third-order amplitude rhs vectors: 3050 3051 IF (L_USE_XKS3) THEN 3052 INUM = IR3TAMP(LABELA,+FREQA,ISYMA, LABELB,+FREQB,ISYMB, 3053 & LABELC,+FREQC,ISYMC) ! A,B,C 3054 INUM = IR3TAMP(LABELA,+FREQA,ISYMA, LABELB,+FREQB,ISYMB, 3055 & LABELD,+FREQD,ISYMD) ! A,B,D 3056 INUM = IR3TAMP(LABELA,+FREQA,ISYMA, LABELC,+FREQC,ISYMC, 3057 & LABELD,+FREQD,ISYMD) ! A,C,D 3058 INUM = IR3TAMP(LABELB,+FREQB,ISYMB, LABELC,+FREQC,ISYMC, 3059 & LABELD,+FREQD,ISYMD) ! B,C,D 3060 3061 INUM = IR3TAMP(LABELA,-FREQA,ISYMA, LABELB,-FREQB,ISYMB, 3062 & LABELC,-FREQC,ISYMC) ! A,B,C 3063 INUM = IR3TAMP(LABELA,-FREQA,ISYMA, LABELB,-FREQB,ISYMB, 3064 & LABELD,-FREQD,ISYMD) ! A,B,D 3065 INUM = IR3TAMP(LABELA,-FREQA,ISYMA, LABELC,-FREQC,ISYMC, 3066 & LABELD,-FREQD,ISYMD) ! A,C,D 3067 INUM = IR3TAMP(LABELB,-FREQB,ISYMB, LABELC,-FREQC,ISYMC, 3068 & LABELD,-FREQD,ISYMD) ! B,C,D 3069 END IF 3070 3071* request (unrelaxed) first-order t response vectors: 3072 3073 INUM = IR1TAMP(LABELA,.FALSE.,+FREQA,ISYMA) 3074 INUM = IR1TAMP(LABELB,.FALSE.,+FREQB,ISYMB) 3075 INUM = IR1TAMP(LABELC,.FALSE.,+FREQC,ISYMC) 3076 INUM = IR1TAMP(LABELD,.FALSE.,+FREQD,ISYMD) 3077 INUM = IR1TAMP(LABELA,.FALSE.,-FREQA,ISYMA) 3078 INUM = IR1TAMP(LABELB,.FALSE.,-FREQB,ISYMB) 3079 INUM = IR1TAMP(LABELC,.FALSE.,-FREQC,ISYMC) 3080 INUM = IR1TAMP(LABELD,.FALSE.,-FREQD,ISYMD) 3081 3082 3083* request first order zeta response vectors: 3084 3085 INUM = IL1ZETA(LABELA,.FALSE.,+FREQA,ISYMA) 3086 INUM = IL1ZETA(LABELB,.FALSE.,+FREQB,ISYMB) 3087 INUM = IL1ZETA(LABELC,.FALSE.,+FREQC,ISYMC) 3088 INUM = IL1ZETA(LABELD,.FALSE.,+FREQD,ISYMD) 3089 INUM = IL1ZETA(LABELA,.FALSE.,-FREQA,ISYMA) 3090 INUM = IL1ZETA(LABELB,.FALSE.,-FREQB,ISYMB) 3091 INUM = IL1ZETA(LABELC,.FALSE.,-FREQC,ISYMC) 3092 INUM = IL1ZETA(LABELD,.FALSE.,-FREQD,ISYMD) 3093 END DO 3094 3095* for dispersion coefficients : 3096* ----------------------------- 3097* RC(0), CR2(0,0) and CL2(0,0) vectors are calculated 3098* as R1(0), R2(0,0) and L2(0,0)... the identification 3099* with the cauchy vectors with these response vectors it 3100* ensured later by the CC_RDRSP routine... but here we a 3101* must no put them on the Cauchy lists but on the response 3102* vector lists... 3103 3104 DO IDISP = 1, NCRDISP 3105 ICAUA = ICCAUA(IDISP) 3106 ICAUB = ICCAUB(IDISP) 3107 ICAUC = ICCAUC(IDISP) 3108 ICAUD = ICCAUD(IDISP) 3109 3110* request first-order right Cauchy vectors: 3111 3112 IF (ICAUA.GT.0) INUM = ILRCAMP(LABELA,ICAUA,ISYMA) 3113 IF (ICAUA.EQ.0) INUM = IR1TAMP(LABELA,.FALSE.,0.0d0,ISYMA) 3114 3115 IF (ICAUB.GT.0) INUM = ILRCAMP(LABELB,ICAUB,ISYMB) 3116 IF (ICAUB.EQ.0) INUM = IR1TAMP(LABELB,.FALSE.,0.0d0,ISYMB) 3117 3118 IF (ICAUC.GT.0) INUM = ILRCAMP(LABELC,ICAUC,ISYMC) 3119 IF (ICAUC.EQ.0) INUM = IR1TAMP(LABELC,.FALSE.,0.0d0,ISYMC) 3120 3121 IF (ICAUD.GT.0) INUM = ILRCAMP(LABELD,ICAUD,ISYMD) 3122 IF (ICAUD.EQ.0) INUM = IR1TAMP(LABELD,.FALSE.,0.0d0,ISYMD) 3123 3124* request first-order left Cauchy vectors: 3125 3126 IF (ICAUA.GT.0) INUM = ILC1AMP(LABELA,ICAUA,ISYMA) 3127 IF (ICAUA.EQ.0) INUM = IL1ZETA(LABELA,.FALSE.,0.0d0,ISYMA) 3128 3129 IF (ICAUB.GT.0) INUM = ILC1AMP(LABELB,ICAUB,ISYMB) 3130 IF (ICAUB.EQ.0) INUM = IL1ZETA(LABELB,.FALSE.,0.0d0,ISYMB) 3131 3132 IF (ICAUC.GT.0) INUM = ILC1AMP(LABELC,ICAUC,ISYMC) 3133 IF (ICAUC.EQ.0) INUM = IL1ZETA(LABELC,.FALSE.,0.0d0,ISYMC) 3134 3135 IF (ICAUD.GT.0) INUM = ILC1AMP(LABELD,ICAUD,ISYMD) 3136 IF (ICAUD.EQ.0) INUM = IL1ZETA(LABELD,.FALSE.,0.0d0,ISYMD) 3137 3138 3139* request second-order right Cauchy vectors: 3140 3141 IF ( NO_2NP1_RULE ) THEN 3142* ... if we do not use the 2N+1 rule for the second-order 3143* Cauchy intermediates, we need for all pair of 3144* operator and accompanied Cauchy order the 3145* second-order amplitude Cauchy vectors "CR2" 3146 3147* .... (A,B) pair ... 3148 IF (ICAUA.GT.0 .OR. ICAUB.GT.0) THEN 3149 INUM = ICR2AMP(LABELA,ICAUA,ISYMA,LABELB,ICAUB,ISYMB) 3150 ELSE 3151 INUM = IR2TAMP(LABELA,.FALSE.,0.0d0,ISYMA, 3152 & LABELB,.FALSE.,0.0d0,ISYMB) 3153 END IF 3154 3155* .... (A,C) pair ... 3156 IF (ICAUA.GT.0 .OR. ICAUC.GT.0) THEN 3157 INUM = ICR2AMP(LABELA,ICAUA,ISYMA,LABELC,ICAUC,ISYMC) 3158 ELSE 3159 INUM = IR2TAMP(LABELA,.FALSE.,0.0d0,ISYMA, 3160 & LABELC,.FALSE.,0.0d0,ISYMC) 3161 END IF 3162 3163* .... (A,D) pair ... 3164 IF (ICAUA.GT.0 .OR. ICAUD.GT.0) THEN 3165 INUM = ICR2AMP(LABELA,ICAUA,ISYMA,LABELD,ICAUD,ISYMD) 3166 ELSE 3167 INUM = IR2TAMP(LABELA,.FALSE.,0.0d0,ISYMA, 3168 & LABELD,.FALSE.,0.0d0,ISYMD) 3169 END IF 3170 3171* .... (B,C) pair ... 3172 IF (ICAUB.GT.0 .OR. ICAUC.GT.0) THEN 3173 INUM = ICR2AMP(LABELB,ICAUB,ISYMB,LABELC,ICAUC,ISYMC) 3174 ELSE 3175 INUM = IR2TAMP(LABELB,.FALSE.,0.0d0,ISYMB, 3176 & LABELC,.FALSE.,0.0d0,ISYMC) 3177 END IF 3178 3179* .... (B,D) pair ... 3180 IF (ICAUB.GT.0 .OR. ICAUD.GT.0) THEN 3181 INUM = ICR2AMP(LABELB,ICAUB,ISYMB,LABELD,ICAUD,ISYMD) 3182 ELSE 3183 INUM = IR2TAMP(LABELB,.FALSE.,0.0d0,ISYMB, 3184 & LABELD,.FALSE.,0.0d0,ISYMD) 3185 END IF 3186 3187* .... (C,D) pair ... 3188 IF (ICAUC.GT.0 .OR. ICAUD.GT.0) THEN 3189 INUM = ICR2AMP(LABELC,ICAUC,ISYMC,LABELD,ICAUD,ISYMD) 3190 ELSE 3191 INUM = IR2TAMP(LABELC,.FALSE.,0.0d0,ISYMC, 3192 & LABELD,.FALSE.,0.0d0,ISYMD) 3193 END IF 3194 3195 ELSE 3196* ... if we use the 2n+1/2n+2 rules for the second-order 3197* Cauchy intermediates we have more sophisticated 3198* settings with a three-fold case switch for each of 3199* the three different couples of pairs 3200* [(A,B)/(C,D)], [(A,D)/(B,C)] and [(A,C)/(D,B)] 3201 3202 DO P = 1, 3 3203 LABEL1 = LBLOPR(ICROP(IOPER,I1(P))) 3204 LABEL2 = LBLOPR(ICROP(IOPER,I2(P))) 3205 LABEL3 = LBLOPR(ICROP(IOPER,I3(P))) 3206 LABEL4 = LBLOPR(ICROP(IOPER,I4(P))) 3207 ICAU1 = ICCAU(IDISP,I1(P)) 3208 ICAU2 = ICCAU(IDISP,I2(P)) 3209 ICAU3 = ICCAU(IDISP,I3(P)) 3210 ICAU4 = ICCAU(IDISP,I4(P)) 3211 ISYM1 = ISYOPR(ICROP(IOPER,I1(P))) 3212 ISYM2 = ISYOPR(ICROP(IOPER,I2(P))) 3213 ISYM3 = ISYOPR(ICROP(IOPER,I3(P))) 3214 ISYM4 = ISYOPR(ICROP(IOPER,I4(P))) 3215 3216 IF ( (ICAU1+ICAU2) .GT. (ICAU3+ICAU4) )THEN 3217 INUM = IETACL2(LABEL1,ICAU1,ISYM1,LABEL2,ICAU2,ISYM2) 3218 INUM = IRHSCR2(LABEL1,ICAU1,ISYM1,LABEL2,ICAU2,ISYM2) 3219 IF ( (ICAU3+ICAU4).GT.0 ) THEN 3220 INUM=ICL2AMP(LABEL3,ICAU3,ISYM3,LABEL4,ICAU4,ISYM4) 3221 INUM=ICR2AMP(LABEL3,ICAU3,ISYM3,LABEL4,ICAU4,ISYM4) 3222 ELSE 3223 INUM=IL2ZETA(LABEL3,0.0d0,ISYM3,LABEL4,0.0d0,ISYM4) 3224 INUM=IR2TAMP(LABEL3,.FALSE.,0.0d0,ISYM3, 3225 & LABEL4,.FALSE.,0.0d0,ISYM4) 3226 END IF 3227 ELSE IF ( (ICAU1+ICAU2) .EQ. (ICAU3+ICAU4) )THEN 3228 3229 IF ( (ICAU1+ICAU2).GT.0 ) THEN 3230 INUM=IETACL2(LABEL1,ICAU1,ISYM1,LABEL2,ICAU2,ISYM2) 3231 INUM=ICR2AMP(LABEL1,ICAU1,ISYM1,LABEL2,ICAU2,ISYM2) 3232 ELSE 3233 INUM=ICHI2( LABEL1,.FALSE.,0.0d0,ISYM1, 3234 & LABEL2,.FALSE.,0.0d0,ISYM2) 3235 INUM=IR2TAMP(LABEL1,.FALSE.,0.0d0,ISYM1, 3236 & LABEL2,.FALSE.,0.0d0,ISYM2) 3237 END IF 3238 IF ( (ICAU3+ICAU4).GT.0 ) THEN 3239 INUM=IETACL2(LABEL3,ICAU3,ISYM3,LABEL4,ICAU4,ISYM4) 3240 INUM=ICR2AMP(LABEL3,ICAU3,ISYM3,LABEL4,ICAU4,ISYM4) 3241 ELSE 3242 INUM=ICHI2( LABEL3,.FALSE.,0.0d0,ISYM3, 3243 & LABEL4,.FALSE.,0.0d0,ISYM4) 3244 INUM=IR2TAMP(LABEL3,.FALSE.,0.0d0,ISYM3, 3245 & LABEL4,.FALSE.,0.0d0,ISYM4) 3246 END IF 3247 IF (ICAU1.EQ.1 .AND. ICAU2.EQ.0) THEN 3248 INUM=IL2ZETA(LABEL1,0.0d0,ISYM1,LABEL2,0.0d0,ISYM2) 3249 ELSE IF (ICAU1.GT.0 ) THEN 3250 INUM=ICL2AMP(LABEL1,ICAU1-1,ISYM1,LABEL2,ICAU2,ISYM2) 3251 END IF 3252 IF (ICAU2.EQ.1 .AND. ICAU1.EQ.0) THEN 3253 INUM=IL2ZETA(LABEL1,0.0d0,ISYM1,LABEL2,0.0d0,ISYM2) 3254 ELSE IF (ICAU2.GT.0 ) THEN 3255 INUM=ICL2AMP(LABEL1,ICAU1,ISYM1,LABEL2,ICAU2-1,ISYM2) 3256 END IF 3257 IF (ICAU3.EQ.1 .AND. ICAU4.EQ.0) THEN 3258 INUM=IL2ZETA(LABEL3,0.0d0,ISYM3,LABEL4,0.0d0,ISYM4) 3259 ELSE IF (ICAU3.GT.0 ) THEN 3260 INUM=ICL2AMP(LABEL3,ICAU3-1,ISYM3,LABEL4,ICAU4,ISYM4) 3261 END IF 3262 IF (ICAU4.EQ.1 .AND. ICAU3.EQ.0) THEN 3263 INUM=IL2ZETA(LABEL3,0.0d0,ISYM3,LABEL4,0.0d0,ISYM4) 3264 ELSE IF (ICAU4.GT.0 ) THEN 3265 INUM=ICL2AMP(LABEL3,ICAU3,ISYM3,LABEL4,ICAU4-1,ISYM4) 3266 END IF 3267 3268 ELSE IF ( (ICAU1+ICAU2) .LT. (ICAU3+ICAU4) )THEN 3269 3270 INUM = IETACL2(LABEL3,ICAU3,ISYM3,LABEL4,ICAU4,ISYM4) 3271 INUM = IRHSCR2(LABEL3,ICAU3,ISYM3,LABEL4,ICAU4,ISYM4) 3272 IF ( (ICAU1+ICAU2).GT.0 ) THEN 3273 INUM=ICL2AMP(LABEL1,ICAU1,ISYM1,LABEL2,ICAU2,ISYM2) 3274 INUM=ICR2AMP(LABEL1,ICAU1,ISYM1,LABEL2,ICAU2,ISYM2) 3275 ELSE 3276 INUM=IL2ZETA(LABEL1,0.0d0,ISYM1,LABEL2,0.0d0,ISYM2) 3277 INUM=IR2TAMP(LABEL1,.FALSE.,0.0d0,ISYM1, 3278 & LABEL2,.FALSE.,0.0d0,ISYM2) 3279 END IF 3280 3281 END IF 3282 3283 END DO ! IPAIRS 3284 3285 END IF ! (NO_2NP1_RULE) 3286 3287 END DO 3288 END IF 3289 3290 END DO 3291 3292 3293 RETURN 3294 END 3295*---------------------------------------------------------------------* 3296c /* deck CC_4RIND */ 3297*=====================================================================* 3298 SUBROUTINE CC_4RIND 3299*---------------------------------------------------------------------* 3300* 3301* Purpose: Determine which response t amplitudes and zeta 3302* multipliers required for the third hyperpolarizabilities 3303* 3304* Written by Christof Haettig, April 1997. 3305* 3306*=====================================================================* 3307#if defined (IMPLICIT_NONE) 3308 IMPLICIT NONE 3309#else 3310# include "implicit.h" 3311#endif 3312#include "priunit.h" 3313#include "ccorb.h" 3314#include "cc4rinf.h" 3315#include "ccrspprp.h" 3316#include "ccroper.h" 3317#include "ccl2rsp.h" 3318 3319* local parameters: 3320 LOGICAL LOCDBG 3321 PARAMETER (LOCDBG = .FALSE.) 3322 3323* variables: 3324 CHARACTER*8 LABELA, LABELB, LABELC, LABELD, LABELE 3325 INTEGER ISYMB, ISYMC, ISYMA, ISYMD, ISYME 3326 INTEGER IFREQ, INUM, IOPER, IDX 3327 3328 REAL*8 FREQA, FREQB, FREQC, FREQD, FREQE 3329 3330* external functions: 3331 INTEGER IR2TAMP 3332 INTEGER IR1TAMP 3333 INTEGER IL1ZETA 3334 INTEGER IL2ZETA 3335 INTEGER IROPER 3336 INTEGER ICHI3 3337 3338* data: 3339 LOGICAL FIRSTCALL 3340 SAVE FIRSTCALL 3341 DATA FIRSTCALL /.TRUE./ 3342 3343 3344 IF (LOCDBG) THEN 3345 WRITE (LUPRI,*) 'DEBUG_CC_4RIND> N4ROPER = ',N4ROPER 3346 WRITE (LUPRI,*) 'LL2OPN:',LL2OPN 3347 END IF 3348 3349*---------------------------------------------------------------------* 3350* test if operators are available and translate IA4ROP, IB4ROP, etc. 3351* arrays from the PRPLBL_CC list to the new list maintained by IROPER. 3352*---------------------------------------------------------------------* 3353 IF (FIRSTCALL) THEN 3354 3355 IOPER = 1 3356 DO WHILE (IOPER .LE. N4ROPER) 3357 3358 LABELA = PRPLBL_CC(IA4ROP(IOPER)) 3359 LABELB = PRPLBL_CC(IB4ROP(IOPER)) 3360 LABELC = PRPLBL_CC(IC4ROP(IOPER)) 3361 LABELD = PRPLBL_CC(ID4ROP(IOPER)) 3362 LABELE = PRPLBL_CC(IE4ROP(IOPER)) 3363 3364 IF ( (IROPER(LABELA,ISYMA) .LT. 0) 3365 & .OR. (IROPER(LABELB,ISYMB) .LT. 0) 3366 & .OR. (IROPER(LABELC,ISYMC) .LT. 0) 3367 & .OR. (IROPER(LABELD,ISYMD) .LT. 0) 3368 & .OR. (IROPER(LABELE,ISYME) .LT. 0) ) THEN 3369 3370 WRITE(LUPRI,'(/2X,9A,/2X,2A)') 3371 & ' WARNING: ONE OF THE OPERATORS WITH THE LABELS "', 3372 & LABELA,'", "', LABELB,'", "', LABELC,'", "',LABELD, 3373 & '", "',LABELE,'" IS NOT AVAILABLE.', 3374 & ' HYPERPOLARIZABILITY CALCULATION IS CANCELED FOR THIS', 3375 & ' OPERATOR QUINTUPLE.' 3376 3377 DO IDX = IOPER, N4ROPER-1 3378 IA4ROP(IDX) = IA4ROP(IDX+1) 3379 IB4ROP(IDX) = IB4ROP(IDX+1) 3380 IC4ROP(IDX) = IC4ROP(IDX+1) 3381 ID4ROP(IDX) = ID4ROP(IDX+1) 3382 IE4ROP(IDX) = IE4ROP(IDX+1) 3383 END DO 3384 3385 N4ROPER = N4ROPER - 1 3386 3387 ELSE 3388 IA4ROP(IOPER) = IROPER(LABELA,ISYMA) 3389 IB4ROP(IOPER) = IROPER(LABELB,ISYMB) 3390 IC4ROP(IOPER) = IROPER(LABELC,ISYMC) 3391 ID4ROP(IOPER) = IROPER(LABELD,ISYMD) 3392 IE4ROP(IOPER) = IROPER(LABELE,ISYME) 3393 3394 IOPER = IOPER + 1 3395 END IF 3396 3397 END DO 3398 3399 FIRSTCALL = .FALSE. 3400 3401 END IF ! (FIRSTCALL) 3402 3403*---------------------------------------------------------------------* 3404* set list entries for the required response vectors: 3405*---------------------------------------------------------------------* 3406 DO IOPER = 1, N4ROPER 3407 LABELA = LBLOPR(IA4ROP(IOPER)) 3408 LABELB = LBLOPR(IB4ROP(IOPER)) 3409 LABELC = LBLOPR(IC4ROP(IOPER)) 3410 LABELD = LBLOPR(ID4ROP(IOPER)) 3411 LABELE = LBLOPR(IE4ROP(IOPER)) 3412 3413 ISYMA = ISYOPR(IA4ROP(IOPER)) 3414 ISYMB = ISYOPR(IB4ROP(IOPER)) 3415 ISYMC = ISYOPR(IC4ROP(IOPER)) 3416 ISYMD = ISYOPR(ID4ROP(IOPER)) 3417 ISYME = ISYOPR(IE4ROP(IOPER)) 3418 3419 3420 IF (MULD2H(ISYMA,ISYMB).EQ.MULD2H(MULD2H(ISYMC,ISYMD),ISYME) 3421 & ) THEN 3422 3423 DO IFREQ = 1, N4RFREQ 3424 FREQA = A4RFR(IFREQ) 3425 FREQB = B4RFR(IFREQ) 3426 FREQC = C4RFR(IFREQ) 3427 FREQD = D4RFR(IFREQ) 3428 FREQE = E4RFR(IFREQ) 3429 3430 IF (LOCDBG) THEN 3431 WRITE (LUPRI,*) 'CC_4RIND> put on the list:', 3432 & LABELA,'(',FREQA,'), ', LABELB,'(',FREQB,'), ', 3433 & LABELC,'(',FREQC,'), ', LABELD,'(',FREQD,'), ', 3434 & LABELE,'(',FREQE,')' 3435 END IF 3436 3437* request second-order t response vectors: 3438 3439 INUM = IR2TAMP(LABELA,.FALSE.,+FREQA,ISYMA, 3440 & LABELB,.FALSE.,+FREQB,ISYMB)!A,B 3441 INUM = IR2TAMP(LABELA,.FALSE.,+FREQA,ISYMA, 3442 & LABELC,.FALSE.,+FREQC,ISYMC)!A,C 3443 INUM = IR2TAMP(LABELA,.FALSE.,+FREQA,ISYMA, 3444 & LABELD,.FALSE.,+FREQD,ISYMD)!A,D 3445 INUM = IR2TAMP(LABELA,.FALSE.,+FREQA,ISYMA, 3446 & LABELE,.FALSE.,+FREQE,ISYME)!A,E 3447 INUM = IR2TAMP(LABELB,.FALSE.,+FREQB,ISYMB, 3448 & LABELC,.FALSE.,+FREQC,ISYMC)!B,C 3449 INUM = IR2TAMP(LABELB,.FALSE.,+FREQB,ISYMB, 3450 & LABELD,.FALSE.,+FREQD,ISYMD)!B,D 3451 INUM = IR2TAMP(LABELB,.FALSE.,+FREQB,ISYMB, 3452 & LABELE,.FALSE.,+FREQE,ISYME)!B,E 3453 INUM = IR2TAMP(LABELC,.FALSE.,+FREQC,ISYMC, 3454 & LABELD,.FALSE.,+FREQD,ISYMD)!C,D 3455 INUM = IR2TAMP(LABELC,.FALSE.,+FREQC,ISYMC, 3456 & LABELE,.FALSE.,+FREQE,ISYME)!C,E 3457 INUM = IR2TAMP(LABELD,.FALSE.,+FREQD,ISYMD, 3458 & LABELE,.FALSE.,+FREQE,ISYME)!D,E 3459 3460 INUM = IR2TAMP(LABELA,.FALSE.,-FREQA,ISYMA, 3461 & LABELB,.FALSE.,-FREQB,ISYMB)!A,B 3462 INUM = IR2TAMP(LABELA,.FALSE.,-FREQA,ISYMA, 3463 & LABELC,.FALSE.,-FREQC,ISYMC)!A,C 3464 INUM = IR2TAMP(LABELA,.FALSE.,-FREQA,ISYMA, 3465 & LABELD,.FALSE.,-FREQD,ISYMD)!A,D 3466 INUM = IR2TAMP(LABELA,.FALSE.,-FREQA,ISYMA, 3467 & LABELE,.FALSE.,-FREQE,ISYME)!A,E 3468 INUM = IR2TAMP(LABELB,.FALSE.,-FREQB,ISYMB, 3469 & LABELC,.FALSE.,-FREQC,ISYMC)!B,C 3470 INUM = IR2TAMP(LABELB,.FALSE.,-FREQB,ISYMB, 3471 & LABELD,.FALSE.,-FREQD,ISYMD)!B,D 3472 INUM = IR2TAMP(LABELB,.FALSE.,-FREQB,ISYMB, 3473 & LABELE,.FALSE.,-FREQE,ISYME)!B,E 3474 INUM = IR2TAMP(LABELC,.FALSE.,-FREQC,ISYMC, 3475 & LABELD,.FALSE.,-FREQD,ISYMD)!C,D 3476 INUM = IR2TAMP(LABELC,.FALSE.,-FREQC,ISYMC, 3477 & LABELE,.FALSE.,-FREQE,ISYME)!C,E 3478 INUM = IR2TAMP(LABELD,.FALSE.,-FREQD,ISYMD, 3479 & LABELE,.FALSE.,-FREQE,ISYME)!D,E 3480 3481* request second-order zeta response vectors: 3482 3483 INUM = IL2ZETA(LABELA,+FREQA,ISYMA,LABELB,+FREQB,ISYMB)!A,B 3484 INUM = IL2ZETA(LABELA,+FREQA,ISYMA,LABELC,+FREQC,ISYMC)!A,C 3485 INUM = IL2ZETA(LABELA,+FREQA,ISYMA,LABELD,+FREQD,ISYMD)!A,D 3486 INUM = IL2ZETA(LABELA,+FREQA,ISYMA,LABELE,+FREQE,ISYME)!A,E 3487 INUM = IL2ZETA(LABELB,+FREQB,ISYMB,LABELC,+FREQC,ISYMC)!B,C 3488 INUM = IL2ZETA(LABELB,+FREQB,ISYMB,LABELD,+FREQD,ISYMD)!B,D 3489 INUM = IL2ZETA(LABELB,+FREQB,ISYMB,LABELE,+FREQE,ISYME)!B,E 3490 INUM = IL2ZETA(LABELC,+FREQC,ISYMC,LABELD,+FREQD,ISYMD)!C,D 3491 INUM = IL2ZETA(LABELC,+FREQC,ISYMC,LABELE,+FREQE,ISYME)!C,E 3492 INUM = IL2ZETA(LABELD,+FREQD,ISYMD,LABELE,+FREQE,ISYME)!D,E 3493 3494 INUM = IL2ZETA(LABELA,-FREQA,ISYMA,LABELB,-FREQB,ISYMB)!A,B 3495 INUM = IL2ZETA(LABELA,-FREQA,ISYMA,LABELC,-FREQC,ISYMC)!A,C 3496 INUM = IL2ZETA(LABELA,-FREQA,ISYMA,LABELD,-FREQD,ISYMD)!A,D 3497 INUM = IL2ZETA(LABELA,-FREQA,ISYMA,LABELE,-FREQE,ISYME)!A,E 3498 INUM = IL2ZETA(LABELB,-FREQB,ISYMB,LABELC,-FREQC,ISYMC)!B,C 3499 INUM = IL2ZETA(LABELB,-FREQB,ISYMB,LABELD,-FREQD,ISYMD)!B,D 3500 INUM = IL2ZETA(LABELB,-FREQB,ISYMB,LABELE,-FREQE,ISYME)!B,E 3501 INUM = IL2ZETA(LABELC,-FREQC,ISYMC,LABELD,-FREQD,ISYMD)!C,D 3502 INUM = IL2ZETA(LABELC,-FREQC,ISYMC,LABELE,-FREQE,ISYME)!C,E 3503 INUM = IL2ZETA(LABELD,-FREQD,ISYMD,LABELE,-FREQE,ISYME)!D,E 3504 3505* request third-order chi vectors: 3506 IF (L_USE_CHI3) THEN 3507 3508 INUM = ICHI3(LABELC,+FREQC,ISYMC, LABELD,+FREQD,ISYMD, 3509 & LABELE,+FREQE,ISYME) 3510 INUM = ICHI3(LABELB,+FREQB,ISYMB, LABELD,+FREQD,ISYMD, 3511 & LABELE,+FREQE,ISYME) 3512 INUM = ICHI3(LABELB,+FREQB,ISYMB, LABELC,+FREQC,ISYMC, 3513 & LABELE,+FREQE,ISYME) 3514 INUM = ICHI3(LABELB,+FREQB,ISYMB, LABELC,+FREQC,ISYMC, 3515 & LABELD,+FREQD,ISYMD) 3516 INUM = ICHI3(LABELA,+FREQA,ISYMA, LABELD,+FREQD,ISYMD, 3517 & LABELE,+FREQE,ISYME) 3518 INUM = ICHI3(LABELA,+FREQA,ISYMA, LABELC,+FREQC,ISYMC, 3519 & LABELE,+FREQE,ISYME) 3520 INUM = ICHI3(LABELA,+FREQA,ISYMA, LABELC,+FREQC,ISYMC, 3521 & LABELD,+FREQD,ISYMD) 3522 INUM = ICHI3(LABELA,+FREQA,ISYMA, LABELB,+FREQB,ISYMB, 3523 & LABELE,+FREQE,ISYME) 3524 INUM = ICHI3(LABELA,+FREQA,ISYMA, LABELB,+FREQB,ISYMB, 3525 & LABELD,+FREQD,ISYMD) 3526 INUM = ICHI3(LABELA,+FREQA,ISYMA, LABELB,+FREQB,ISYMB, 3527 & LABELC,+FREQC,ISYMC) 3528 3529 INUM = ICHI3(LABELC,-FREQC,ISYMC, LABELD,-FREQD,ISYMD, 3530 & LABELE,-FREQE,ISYME) 3531 INUM = ICHI3(LABELB,-FREQB,ISYMB, LABELD,-FREQD,ISYMD, 3532 & LABELE,-FREQE,ISYME) 3533 INUM = ICHI3(LABELB,-FREQB,ISYMB, LABELC,-FREQC,ISYMC, 3534 & LABELE,-FREQE,ISYME) 3535 INUM = ICHI3(LABELB,-FREQB,ISYMB, LABELC,-FREQC,ISYMC, 3536 & LABELD,-FREQD,ISYMD) 3537 INUM = ICHI3(LABELA,-FREQA,ISYMA, LABELD,-FREQD,ISYMD, 3538 & LABELE,-FREQE,ISYME) 3539 INUM = ICHI3(LABELA,-FREQA,ISYMA, LABELC,-FREQC,ISYMC, 3540 & LABELE,-FREQE,ISYME) 3541 INUM = ICHI3(LABELA,-FREQA,ISYMA, LABELC,-FREQC,ISYMC, 3542 & LABELD,-FREQD,ISYMD) 3543 INUM = ICHI3(LABELA,-FREQA,ISYMA, LABELB,-FREQB,ISYMB, 3544 & LABELE,-FREQE,ISYME) 3545 INUM = ICHI3(LABELA,-FREQA,ISYMA, LABELB,-FREQB,ISYMB, 3546 & LABELD,-FREQD,ISYMD) 3547 INUM = ICHI3(LABELA,-FREQA,ISYMA, LABELB,-FREQB,ISYMB, 3548 & LABELC,-FREQC,ISYMC) 3549 3550 END IF 3551 3552 3553* request (unrelaxed) first-order t response vectors: 3554 3555 INUM = IR1TAMP(LABELA,.FALSE.,+FREQA,ISYMA) 3556 INUM = IR1TAMP(LABELB,.FALSE.,+FREQB,ISYMB) 3557 INUM = IR1TAMP(LABELC,.FALSE.,+FREQC,ISYMC) 3558 INUM = IR1TAMP(LABELD,.FALSE.,+FREQD,ISYMD) 3559 INUM = IR1TAMP(LABELE,.FALSE.,+FREQD,ISYME) 3560 3561 INUM = IR1TAMP(LABELA,.FALSE.,-FREQA,ISYMA) 3562 INUM = IR1TAMP(LABELB,.FALSE.,-FREQB,ISYMB) 3563 INUM = IR1TAMP(LABELC,.FALSE.,-FREQC,ISYMC) 3564 INUM = IR1TAMP(LABELD,.FALSE.,-FREQD,ISYMD) 3565 INUM = IR1TAMP(LABELE,.FALSE.,-FREQE,ISYME) 3566 3567 3568* request (unrelaxed) first-order zeta response vectors: 3569 3570 INUM = IL1ZETA(LABELA,.FALSE.,+FREQA,ISYMA) 3571 INUM = IL1ZETA(LABELB,.FALSE.,+FREQB,ISYMB) 3572 INUM = IL1ZETA(LABELC,.FALSE.,+FREQC,ISYMC) 3573 INUM = IL1ZETA(LABELD,.FALSE.,+FREQD,ISYMD) 3574 INUM = IL1ZETA(LABELE,.FALSE.,+FREQE,ISYME) 3575 3576 INUM = IL1ZETA(LABELA,.FALSE.,-FREQA,ISYMA) 3577 INUM = IL1ZETA(LABELB,.FALSE.,-FREQB,ISYMB) 3578 INUM = IL1ZETA(LABELC,.FALSE.,-FREQC,ISYMC) 3579 INUM = IL1ZETA(LABELD,.FALSE.,-FREQD,ISYMD) 3580 INUM = IL1ZETA(LABELE,.FALSE.,-FREQE,ISYME) 3581 END DO 3582 3583 END IF 3584 3585 END DO 3586 3587 3588 RETURN 3589 END 3590*---------------------------------------------------------------------* 3591c /* deck CC_5RIND */ 3592*=====================================================================* 3593 SUBROUTINE CC_5RIND 3594*---------------------------------------------------------------------* 3595* 3596* Purpose: Determine which response t amplitudes and zeta 3597* multipliers required for the fourth hyperpolarizabilities 3598* (pentic response function) 3599* 3600* Written by Christof Haettig, Maj 1997. 3601* 3602*=====================================================================* 3603#if defined (IMPLICIT_NONE) 3604 IMPLICIT NONE 3605#else 3606# include "implicit.h" 3607#endif 3608#include "priunit.h" 3609#include "ccorb.h" 3610#include "cc5rinf.h" 3611#include "cc5perm.h" 3612#include "ccrspprp.h" 3613#include "ccroper.h" 3614 3615* local parameters: 3616 LOGICAL LOCDBG 3617 PARAMETER (LOCDBG = .FALSE.) 3618 3619* variables: 3620 CHARACTER*8 LABEL(6) 3621 INTEGER ISYM(6) 3622 INTEGER IFREQ, INUM, IOPER, IDX, IDXA, IDXB, IDXC, JDX, ISYMTOT 3623 3624 REAL*8 FREQ(6) 3625 3626* external functions: 3627 INTEGER IR3TAMP 3628 INTEGER ICHI3 3629 INTEGER IROPER 3630 3631* data: 3632 LOGICAL FIRSTCALL 3633 SAVE FIRSTCALL 3634 DATA FIRSTCALL /.TRUE./ 3635 3636 3637*---------------------------------------------------------------------* 3638* test if operators are available and translate I5ROP array 3639* from the PRPLBL_CC list to the new list maintained by IROPER. 3640*---------------------------------------------------------------------* 3641 IF (FIRSTCALL) THEN 3642 3643 IOPER = 1 3644 DO WHILE (IOPER .LE. N5ROPER) 3645 3646 DO IDX = 1, 6 3647 LABEL(IDX) = PRPLBL_CC(I5ROP(IOPER,IDX)) 3648 END DO 3649 3650 IF ( IROPER(LABEL(A),ISYM(A)) .LT. 0 3651 & .OR. IROPER(LABEL(B),ISYM(B)) .LT. 0 3652 & .OR. IROPER(LABEL(C),ISYM(C)) .LT. 0 3653 & .OR. IROPER(LABEL(D),ISYM(D)) .LT. 0 3654 & .OR. IROPER(LABEL(E),ISYM(E)) .LT. 0 3655 & .OR. IROPER(LABEL(F),ISYM(F)) .LT. 0 ) THEN 3656 3657 WRITE(LUPRI,'(/2X,9A,/2X,2A)') 3658 & ' WARNING: ONE OF THE OPERATORS WITH THE LABELS "', 3659 & LABEL(A),'", "', LABEL(B),'", "', LABEL(C),'", "',LABEL(D), 3660 & '", "',LABEL(E), '", "',LABEL(F),'" IS NOT AVAILABLE.', 3661 & ' HYPERPOLARIZABILITY CALCULATION IS CANCELED FOR THIS', 3662 & ' OPERATOR HEXTUPLE.' 3663 3664C WRITE (LUPRI,*) 'I5ROP:',(I5ROP(IOPER,IDX),IDX=1,6) 3665 3666 DO JDX = IOPER, N5ROPER-1 3667 DO IDX = 1, 6 3668 I5ROP(JDX,IDX) = I5ROP(JDX+1,IDX) 3669 END DO 3670 END DO 3671 3672 N5ROPER = N5ROPER - 1 3673 3674 ELSE 3675 DO IDX = 1, 6 3676 I5ROP(IOPER,IDX) = IROPER(LABEL(IDX),ISYM(IDX)) 3677 END DO 3678 3679 IOPER = IOPER + 1 3680 END IF 3681 3682 END DO 3683 3684 FIRSTCALL = .FALSE. 3685 3686 END IF ! (FIRSTCALL) 3687 3688*---------------------------------------------------------------------* 3689* set list entries for the required response vectors: 3690*---------------------------------------------------------------------* 3691 DO IOPER = 1, N5ROPER 3692 ISYMTOT = 1 3693 DO IDX = 1, 6 3694 LABEL(IDX) = LBLOPR(I5ROP(IOPER,IDX)) 3695 ISYM(IDX) = ISYOPR(I5ROP(IOPER,IDX)) 3696 ISYMTOT = MULD2H(ISYMTOT,ISYM(IDX)) 3697 END DO 3698 3699 IF ( ISYMTOT.EQ.1 ) THEN 3700 3701 DO IFREQ = 1, N5RFREQ 3702 DO IDX = 1, 6 3703 FREQ(IDX) = FREQ5(IFREQ,IDX) 3704 END DO 3705 3706 IF (LOCDBG) THEN 3707 WRITE (LUPRI,*) 'CC_5RIND> put on the list:', 3708 & LABEL(A),'(',FREQ(A),'), ', LABEL(B),'(',FREQ(B),'), ', 3709 & LABEL(C),'(',FREQ(C),'), ', LABEL(D),'(',FREQ(D),'), ', 3710 & LABEL(E),'(',FREQ(E),'), ', LABEL(F),'(',FREQ(F),')' 3711 END IF 3712 3713* request third-order t response vectors and third-order 3714* chi vectors (which implies, that the second-order 3715* Lagrangian multipliers will be computed): 3716 DO IDXA = 1, 6 3717 DO IDXB = IDXA+1, 6 3718 DO IDXC = IDXB+1, 6 3719 INUM = IR3TAMP(LABEL(IDXA),+FREQ(IDXA),ISYM(IDXA), 3720 & LABEL(IDXB),+FREQ(IDXB),ISYM(IDXB), 3721 & LABEL(IDXC),+FREQ(IDXC),ISYM(IDXC) ) 3722 3723 INUM = IR3TAMP(LABEL(IDXA),-FREQ(IDXA),ISYM(IDXA), 3724 & LABEL(IDXB),-FREQ(IDXB),ISYM(IDXB), 3725 & LABEL(IDXC),-FREQ(IDXC),ISYM(IDXC) ) 3726 3727 INUM = ICHI3(LABEL(IDXA),+FREQ(IDXA),ISYM(IDXA), 3728 & LABEL(IDXB),+FREQ(IDXB),ISYM(IDXB), 3729 & LABEL(IDXC),+FREQ(IDXC),ISYM(IDXC) ) 3730 3731 INUM = ICHI3(LABEL(IDXA),-FREQ(IDXA),ISYM(IDXA), 3732 & LABEL(IDXB),-FREQ(IDXB),ISYM(IDXB), 3733 & LABEL(IDXC),-FREQ(IDXC),ISYM(IDXC) ) 3734 END DO 3735 END DO 3736 END DO 3737 3738 END DO 3739 END IF 3740 END DO 3741 3742 3743 RETURN 3744 END 3745*---------------------------------------------------------------------* 3746c /* deck cc_tpaind */ 3747*=====================================================================* 3748 SUBROUTINE CC_TPAIND 3749*---------------------------------------------------------------------* 3750* 3751* Purpose: Determine which vectors are needed for the calculation 3752* of two-photon absorption strength 3753* 3754*=====================================================================* 3755 USE PELIB_INTERFACE, ONLY: USE_PELIB 3756#if defined (IMPLICIT_NONE) 3757 IMPLICIT NONE 3758#else 3759# include "implicit.h" 3760#endif 3761#include "priunit.h" 3762#include "ccorb.h" 3763#include "cctpainf.h" 3764#include "ccrspprp.h" 3765#include "ccexci.h" 3766#include "ccexcinf.h" 3767#include "ccroper.h" 3768#include "ccsdinp.h" 3769#include "ccsections.h" 3770#include "ccslvinf.h" 3771 3772* local parameters: 3773 LOGICAL LOCDBG 3774 PARAMETER (LOCDBG = .FALSE.) 3775 3776* variables: 3777 CHARACTER*8 LABELA, LABELB 3778 INTEGER ISYMB, ISYMA, ISYMAB, ISYME 3779 INTEGER INUM, IOPPAIR, IDX, ISTATE, IEXCI, IRSD 3780 3781 REAL*8 FREQA, FREQB, EIGV 3782 3783* external functions: 3784 INTEGER IROPER 3785 INTEGER ICHI2 3786 INTEGER IRHSR2 3787 INTEGER IR1TAMP 3788 INTEGER ILRMAMP 3789 INTEGER IL1ZETA 3790 3791* data: 3792 LOGICAL FIRSTCALL 3793 SAVE FIRSTCALL 3794 DATA FIRSTCALL /.TRUE./ 3795 3796 3797 IF (LOCDBG) THEN 3798 WRITE (LUPRI,*) 'DEBUG_CC_TPAIND> NSMOPER = ',NSMOPER 3799 END IF 3800 3801*---------------------------------------------------------------------* 3802* test if operators are available and translate IASMOP, IBSMOP, ICSMOP 3803* and IDSMOP arrays from the PRPLBL_CC list to the new list maintained 3804* by IROPER. 3805*---------------------------------------------------------------------* 3806 IF (FIRSTCALL) THEN 3807 3808 IOPPAIR = 1 3809 DO WHILE (IOPPAIR .LE. NSMOPER) 3810 3811 LABELA = PRPLBL_CC(IASMOP(IOPPAIR)) 3812 LABELB = PRPLBL_CC(IBSMOP(IOPPAIR)) 3813 3814 IF ( (IROPER(LABELA,ISYMA) .LT. 0) 3815 & .OR. (IROPER(LABELB,ISYMB) .LT. 0) ) THEN 3816 WRITE(LUPRI,'(/2X,5A,/2X,2A)') 3817 & ' WARNING: ONE OF THE OPERATORS WITH THE LABELS "', 3818 & LABELA,'", "', LABELB,'" IS NOT AVAILABLE.', 3819 & ' SECOND MOMENT CROSS SECTION CALCULATION IS CANCELED ', 3820 & ' FOR THIS OPERATOR PAIR.' 3821 DO IDX = IOPPAIR, NSMOPER-1 3822 IASMOP(IDX) = IASMOP(IDX+1) 3823 IBSMOP(IDX) = IBSMOP(IDX+1) 3824 END DO 3825 NSMOPER = NSMOPER - 1 3826 ELSE 3827 IASMOP(IOPPAIR) = IROPER(LABELA,ISYMA) 3828 IBSMOP(IOPPAIR) = IROPER(LABELB,ISYMB) 3829 IOPPAIR = IOPPAIR + 1 3830 END IF 3831 3832 END DO 3833 3834 FIRSTCALL = .FALSE. 3835 3836 END IF ! (FIRSTCALL) 3837 3838*---------------------------------------------------------------------* 3839* if no states were selected use by default all states: 3840*---------------------------------------------------------------------* 3841 IF ( .NOT. SELSMST ) THEN 3842 NSMSEL = 0 3843 DO ISYME = 1, NSYM 3844 DO IEXCI = 1, NCCEXCI(ISYME,1) 3845 NSMSEL = NSMSEL + 1 3846 ISMSEL(NSMSEL,1) = ISYME 3847 ISMSEL(NSMSEL,2) = IEXCI 3848 END DO 3849 END DO 3850 END IF 3851 3852*---------------------------------------------------------------------* 3853* if HALFFR flag is given, set here the laser frequency: 3854*---------------------------------------------------------------------* 3855 IF ( HALFFR .OR. (.NOT. SELSMST) ) THEN 3856 DO IRSD = 1, NSMSEL 3857 ISYME = ISMSEL(IRSD,1) 3858 IEXCI = ISMSEL(IRSD,2) 3859 EIGV = EIGVAL(ISYOFE(ISYME) + IEXCI) 3860 3861 BSMFR(IRSD) = 0.5d0 * EIGV 3862 END DO 3863 END IF 3864 3865*---------------------------------------------------------------------* 3866* for CC3 we can switch off LTPA_USE_O2 & LTPA_USE_X2: 3867*---------------------------------------------------------------------* 3868 IF (CC3 .AND. LTPA_USE_O2) THEN 3869 WRITE(LUPRI,*) 'Info: the .USE O2 option cannot be use for ' 3870 WRITE(LUPRI,*) ' in *CCTPA for CC3... it is turned off' 3871 LTPA_USE_O2 = .FALSE. 3872 END IF 3873 3874 IF (CC3 .AND. LTPA_USE_X2) THEN 3875 WRITE(LUPRI,*) 'Info: the .USE X2 option cannot be use for ' 3876 WRITE(LUPRI,*) ' in *CTPA for CC3... it is turned off' 3877 LTPA_USE_X2 = .FALSE. 3878 END IF 3879 3880*---------------------------------------------------------------------* 3881* set list entries for the required response vectors: 3882* note that for S^0f_AB,AB(w_B) we need M^AB_0f(-w_B) and M^AB_f0(w_B) 3883*---------------------------------------------------------------------* 3884 DO IOPPAIR = 1, NSMOPER 3885 LABELA = LBLOPR(IASMOP(IOPPAIR)) 3886 LABELB = LBLOPR(IBSMOP(IOPPAIR)) 3887 3888 ISYMA = ISYOPR(IASMOP(IOPPAIR)) 3889 ISYMB = ISYOPR(IBSMOP(IOPPAIR)) 3890 ISYMAB = MULD2H(ISYMA,ISYMB) 3891 3892 DO IRSD = 1, NSMSEL 3893 3894 ISYME = ISMSEL(IRSD,1) ! irrep 3895 3896 IF (ISYME.EQ.ISYMAB) THEN 3897 3898 IEXCI = ISMSEL(IRSD,2) ! state number within irrep 3899 ISTATE = ISYOFE(ISYME) + IEXCI ! number over all irreps 3900 EIGV = EIGVAL(ISTATE) ! excitation energie 3901 3902 FREQB = BSMFR(IRSD) ! frequency for field B 3903 FREQA = EIGV-FREQB ! frequency for field A 3904 3905 IF (LOCDBG) THEN 3906 WRITE (LUPRI,*) 'CC_TPAIND> put on the list:', 3907 & LABELA,'(',FREQA,'), ', LABELB,'(',FREQB,'), ', 3908 & ISTATE,EIGV 3909 END IF 3910 3911 IF (LTPA_USE_X2) THEN 3912* request second order chi vectors: 3913 INUM = ICHI2(LABELA,.FALSE.,-FREQA,ISYMA, 3914 & LABELB,.FALSE.,-FREQB,ISYMB) 3915 END IF 3916 3917 IF (LTPA_USE_O2) THEN 3918* request second-order rhs vectors 3919 INUM =IRHSR2(LABELA,.FALSE.,-FREQA,ISYMA, 3920 & LABELB,.FALSE.,-FREQB,ISYMB) 3921 INUM =IRHSR2(LABELA,.FALSE.,+FREQA,ISYMA, 3922 & LABELB,.FALSE.,+FREQB,ISYMB) 3923 END IF 3924 3925* request first order t response vectors: 3926 INUM = IR1TAMP(LABELA,.FALSE.,-FREQA,ISYMA) 3927 INUM = IR1TAMP(LABELB,.FALSE.,-FREQB,ISYMB) 3928 INUM = IR1TAMP(LABELB,.FALSE.,+FREQB,ISYMB) 3929 INUM = IR1TAMP(LABELA,.FALSE.,+FREQA,ISYMA) 3930 3931 3932* request unrelaxed first order zeta response vectors: 3933 IF (CCSLV.OR.USE_PELIB()) THEN 3934 INUM = IL1ZETA(LABELA,.FALSE.,-FREQA,ISYMA) 3935 INUM = IL1ZETA(LABELB,.FALSE.,-FREQB,ISYMB) 3936 INUM = IL1ZETA(LABELA,.FALSE.,FREQA,ISYMA) 3937 INUM = IL1ZETA(LABELB,.FALSE.,FREQB,ISYMB) 3938 ELSE 3939 INUM = IL1ZETA(LABELA,.FALSE.,-FREQA,ISYMA) 3940 INUM = IL1ZETA(LABELB,.FALSE.,-FREQB,ISYMB) 3941 END IF 3942 3943* request M1 lagrangian multipliers: 3944 INUM = ILRMAMP(ISTATE,EIGV,ISYME) 3945 3946 END IF 3947 END DO 3948 END DO 3949 3950 RETURN 3951 END 3952*---------------------------------------------------------------------* 3953c /* deck cc_tmind */ 3954*=====================================================================* 3955 SUBROUTINE CC_TMIND 3956*---------------------------------------------------------------------* 3957* 3958* Purpose: Determine which vectors are needed in third moment 3959* calculations, flags are set for the following : 3960* chi vectors , second order rhs vectors, 3961* first order t respons vectors, m vectors 3962* 3963*=====================================================================* 3964#if defined (IMPLICIT_NONE) 3965 IMPLICIT NONE 3966#else 3967# include "implicit.h" 3968#endif 3969#include "priunit.h" 3970#include "ccorb.h" 3971#include "cctm.h" 3972#include "cctminf.h" 3973#include "ccrspprp.h" 3974#include "ccexci.h" 3975#include "ccroper.h" 3976 3977* local parameters: 3978 LOGICAL LOCDBG 3979 PARAMETER (LOCDBG = .FALSE.) 3980 3981* variables: 3982 CHARACTER*8 LABELA, LABELB, LABELC, 3983 * LABELD, LABELE, LABELF 3984 INTEGER ISYMB, ISYMC, ISYMA, ISYMD, ISYME, ISYMF, ISYMABC 3985 INTEGER IFREQ, INUM, IOPER, IDX, IOFFST, I 3986 3987 REAL*8 FREQEX, FREQB, FREQC, EIGV 3988 3989* external functions: 3990 INTEGER IROPER 3991 INTEGER ICHI3 3992 INTEGER ILRMAMP 3993 INTEGER IRHSR3 3994 3995* data: 3996 LOGICAL FIRSTCALL 3997 SAVE FIRSTCALL 3998 DATA FIRSTCALL /.TRUE./ 3999 4000 4001 IF (LOCDBG) THEN 4002 WRITE (LUPRI,*) 'DEBUG_CC_TMIND> NTMOPER = ',NTMOPER 4003 END IF 4004 4005 IF (FIRSTCALL) THEN 4006 4007*---------------------------------------------------------------------* 4008* test if operators are available and translate IATMOP, IBTMOP, ICTMOP 4009* IDTMOP, IETMOP and IFTMOP arrays from the PRPLBL_CC 4010* list to the new list maintained by IROPER. 4011*---------------------------------------------------------------------* 4012 IOPER = 1 4013 DO WHILE (IOPER .LE. NTMOPER) 4014 4015 LABELA = PRPLBL_CC(IATMOP(IOPER)) 4016 LABELB = PRPLBL_CC(IBTMOP(IOPER)) 4017 LABELC = PRPLBL_CC(ICTMOP(IOPER)) 4018 LABELD = PRPLBL_CC(IDTMOP(IOPER)) 4019 LABELE = PRPLBL_CC(IETMOP(IOPER)) 4020 LABELF = PRPLBL_CC(IFTMOP(IOPER)) 4021 4022 IF ( (IROPER(LABELA,ISYMA) .LT. 0) 4023 & .OR. (IROPER(LABELB,ISYMB) .LT. 0) 4024 & .OR. (IROPER(LABELC,ISYMC) .LT. 0) 4025 & .OR. (IROPER(LABELD,ISYMD) .LT. 0) 4026 & .OR. (IROPER(LABELE,ISYME) .LT. 0) 4027 & .OR. (IROPER(LABELF,ISYMF) .LT. 0) ) THEN 4028 4029 WRITE(LUPRI,'(/2X,A, /2X,7A/2X,4A)') 4030 & ' WARNING: ONE OF THE OPERATORS WITH THE LABELS "', 4031 & LABELA,'", "', LABELB,'", "', LABELC,'","', 4032 & LABELD,'", "', LABELE,'", "', LABELF, 4033 & '" IS NOT AVAILABLE.', 4034 & ' THIRD MOMENT CROSS SECTION CALCULATION IS CANCELED ', 4035 & ' FOR THIS OPERATOR SIXTUPLE.' 4036 4037 DO IDX = IOPER, NTMOPER-1 4038 IATMOP(IDX) = IATMOP(IDX+1) 4039 IBTMOP(IDX) = IBTMOP(IDX+1) 4040 ICTMOP(IDX) = ICTMOP(IDX+1) 4041 IDTMOP(IDX) = IDTMOP(IDX+1) 4042 IETMOP(IDX) = IETMOP(IDX+1) 4043 IFTMOP(IDX) = IFTMOP(IDX+1) 4044 END DO 4045 4046 NTMOPER = NTMOPER - 1 4047 4048 ELSE 4049 IATMOP(IOPER) = IROPER(LABELA,ISYMA) 4050 IBTMOP(IOPER) = IROPER(LABELB,ISYMB) 4051 ICTMOP(IOPER) = IROPER(LABELC,ISYMC) 4052 IDTMOP(IOPER) = IROPER(LABELD,ISYMD) 4053 IETMOP(IOPER) = IROPER(LABELE,ISYME) 4054 IFTMOP(IOPER) = IROPER(LABELF,ISYMF) 4055 4056 IOPER = IOPER + 1 4057 END IF 4058 4059 END DO 4060 4061 FIRSTCALL = .FALSE. 4062 4063 END IF ! (FIRSTCALL) 4064 4065*--------------------------------------------------------------------* 4066* sort list of selected states according to symmetry and canonical 4067* order within each symmetry 4068*--------------------------------------------------------------------* 4069 4070 CALL CC_TMSORT 4071 4072*---------------------------------------------------------------------* 4073* set list entries for the required response vectors: 4074*---------------------------------------------------------------------* 4075 DO IOPER = 1, NTMOPER 4076 LABELA = LBLOPR(IATMOP(IOPER)) 4077 LABELB = LBLOPR(IBTMOP(IOPER)) 4078 LABELC = LBLOPR(ICTMOP(IOPER)) 4079 LABELD = LBLOPR(IDTMOP(IOPER)) 4080 LABELE = LBLOPR(IETMOP(IOPER)) 4081 LABELF = LBLOPR(IFTMOP(IOPER)) 4082 4083 ISYMA = ISYOPR(IATMOP(IOPER)) 4084 ISYMB = ISYOPR(IBTMOP(IOPER)) 4085 ISYMC = ISYOPR(ICTMOP(IOPER)) 4086 ISYMD = ISYOPR(IDTMOP(IOPER)) 4087 ISYME = ISYOPR(IETMOP(IOPER)) 4088 ISYMF = ISYOPR(IFTMOP(IOPER)) 4089 4090 ISYMABC = MULD2H(MULD2H(ISYMA,ISYMB),ISYMC) 4091 IF (ISYMABC. EQ. MULD2H( MULD2H(ISYMD,ISYMF),ISYME) ) THEN 4092 DO I = 1, NTMSELX(ISYMABC) 4093 IFREQ = ITMSELX(ISYMABC) + I 4094 FREQEX = EXTMFR(IFREQ) 4095 FREQB = BTMFR(IFREQ) 4096 FREQC = CTMFR(IFREQ) 4097 IF (LOCDBG) THEN 4098 WRITE (LUPRI,*) 'CC_TMIND> put on the list:', 4099 & LABELA,'(',FREQEX,'), ', LABELB,'(',FREQB,'), ', 4100 & LABELC,'(',FREQC,'), ', 4101 & IFREQ,FREQEX 4102 END IF 4103 4104 4105* request third order chi vectors: 4106 4107 INUM = ICHI3(LABELA,-FREQEX+FREQB+FREQC,ISYMA, 4108 & LABELB,-FREQB,ISYMB,LABELC,-FREQC,ISYMC) 4109 INUM = ICHI3(LABELD,-FREQEX+FREQB+FREQC,ISYMD, 4110 & LABELE,-FREQB,ISYME,LABELF,-FREQC,ISYMF) 4111 4112 4113* request third order rhs vectors 4114 4115 INUM = IRHSR3(LABELA,-FREQEX+FREQB+FREQC,ISYMA, 4116 & LABELB,-FREQB,ISYMB,LABELC,-FREQC,ISYMC) 4117 INUM = IRHSR3(LABELA,+FREQEX-FREQB-FREQC,ISYMA, 4118 & LABELB,+FREQB,ISYMB,LABELC,+FREQC,ISYMC) 4119 INUM = IRHSR3(LABELD,-FREQEX+FREQB+FREQC,ISYMD, 4120 & LABELE,-FREQB,ISYME,LABELF,-FREQC,ISYMF) 4121 INUM = IRHSR3(LABELD,+FREQEX-FREQB-FREQC,ISYMD, 4122 & LABELE,+FREQB,ISYME,LABELF,+FREQC,ISYMF) 4123 4124* request m vectors for different excitation energies 4125 4126 4127 IOFFST = ISYOFE(ISYMABC) + ITMSEL(IFREQ,2) 4128 EIGV = EIGVAL(IOFFST) 4129 INUM = ILRMAMP(IOFFST,EIGV,ISYMABC) 4130 CALL FLSHFO(LUPRI) 4131c WRITE(LUPRI,*) ' ioffst,eigv,inum,isymabc,ifreq' 4132c CALL FLSHFO(LUPRI) 4133c WRITE (LUPRI,*) ioffst,eigv,inum,isymabc,ifreq 4134 4135 END DO 4136 4137 END IF 4138 4139 END DO 4140 4141 4142 RETURN 4143 END 4144*---------------------------------------------------------------------* 4145c /* deck cc_mcdind */ 4146*=====================================================================* 4147 SUBROUTINE CC_MCDIND(WORK,LWORK) 4148*---------------------------------------------------------------------* 4149* Purpose: Determine which vectors are needed in magnetic circular 4150* dichroism calculations 4151* Flags are set for: 2nd-order rhs vectors for T^AB, 4152* 1st-order T^X (w_X) response amplitudes 4153* M^f(w_f) lagrangian vectors, 4154* eigenvectors responses E^fX, Ebar^fX 4155* 1st order rhs vectors for Tbar^A (eta part) 4156* projected Tbar^A (PL1) 4157* 4158* Written by Sonia Coriani 4159* Version: 04/04-2000 4160*=====================================================================* 4161#if defined (IMPLICIT_NONE) 4162 IMPLICIT NONE 4163#else 4164# include "implicit.h" 4165#endif 4166#include "priunit.h" 4167#include "ccorb.h" 4168#include "ccmcdinf.h" 4169#include "ccrspprp.h" 4170#include "ccexcinf.h" 4171#include "ccexci.h" 4172#include "ccroper.h" 4173 4174* local parameters: 4175 LOGICAL LOCDBG 4176 PARAMETER (LOCDBG = .FALSE.) 4177 4178* variables: 4179 CHARACTER*8 LABELA, LABELB, LABELC, LABSOP 4180 INTEGER IOPA,IOPB,IOPC 4181 LOGICAL LORXA,LORXB,LORXC, LPDBSA,LPDBSB,LPDBSC, SKIP_IT, LRELAX 4182 INTEGER ISYMA, ISYMB, ISYMC, ISYMAB, ISYMS_F, ISYMS, ISTATE 4183 INTEGER IEIGV_F, ISTAT_F, IEXCI_F, INUM, IOPER, IDX, IDXS 4184 INTEGER ISGNSOP,ISYSOP,NLORX,LWORK 4185 LOGICAL LPROJ 4186 4187 REAL*8 EIGVA_F, ZERO, WORK(LWORK) 4188 4189 PARAMETER ( ZERO = 0.0d0 ) 4190 4191* external functions: 4192 INTEGER IROPER 4193 INTEGER IRHSR1 4194 INTEGER IRHSR2 4195 INTEGER IR1TAMP 4196 INTEGER IL1ZETA 4197 INTEGER ILRMAMP 4198 INTEGER IER1AMP 4199 INTEGER IEL1AMP 4200 INTEGER IETA1 4201 INTEGER IPL1ZETA 4202 4203* data: 4204 LOGICAL FIRSTCALL 4205 SAVE FIRSTCALL 4206 DATA FIRSTCALL /.TRUE./ 4207 4208*----------------------------------------------------------------------* 4209* Begin 4210*----------------------------------------------------------------------* 4211 4212 IF (LOCDBG) THEN 4213 WRITE (LUPRI,*) 'DEBUG_CC_MCDIND> NMCDOPER = ',NMCDOPER 4214 END IF 4215 4216*----------------------------------------------------------------------* 4217* test if operators are available and translate IAMCDOP,IBMCDOP,ICMCDOP 4218* arrays from the PRPLBL_CC list to the new list maintained by IROPER. 4219* Note that NMCDOPER is the number of operator-triples (r,L,r) 4220*----------------------------------------------------------------------* 4221 4222 LPROJ = .FALSE. 4223 4224 IF (FIRSTCALL) THEN 4225 4226 IOPER = 1 4227 DO WHILE (IOPER .LE. NMCDOPER) 4228 4229 SKIP_IT = .FALSE. 4230 LABELA = PRPLBL_CC(IAMCDOP(IOPER)) 4231 LABELB = PRPLBL_CC(IBMCDOP(IOPER)) 4232 LABELC = PRPLBL_CC(ICMCDOP(IOPER)) 4233 LORXA = LAMCDRX(IOPER) 4234 LORXB = LBMCDRX(IOPER) 4235 LORXC = LCMCDRX(IOPER) 4236 IOPA = IROPER(LABELA,ISYMA) 4237 IOPB = IROPER(LABELB,ISYMB) 4238 IOPC = IROPER(LABELC,ISYMC) 4239 4240 WRITE(LUPRI,'(/2X,A,3(1X,A),A)') 4241 & 'CHECK TRIPLET:',LABELA, LABELB, LABELC 4242 CALL FLSHFO(LUPRI) 4243 4244 4245 IF ( (IOPA.LT.0) .OR. (IOPB.LT.0) .OR. (IOPC.LT.0) ) THEN 4246 4247 WRITE(LUPRI,'(/2X,7A,/2X,2A)') 4248 & ' WARNING: ONE OF THE OPERATORS WITH THE LABELS "', 4249 & LABELA,'", "', LABELB,'", "', LABELC,'" IS NOT AVAILABLE.', 4250 & ' MAGNE.CIRCUL.DICHR. CALCULATION IS CANCELED FOR THIS', 4251 & ' OPERATOR TRIPLET.' 4252 4253 SKIP_IT = .TRUE. 4254 END IF 4255 4256 NLORX = 0 4257 IF (LORXA .OR. LPDBSOP(IOPA)) NLORX = NLORX + 1 4258 IF (LORXB .OR. LPDBSOP(IOPB)) NLORX = NLORX + 1 4259 IF (LORXC .OR. LPDBSOP(IOPC)) NLORX = NLORX + 1 4260 4261 IF (NLORX.GT.1) THEN 4262 WRITE(LUPRI,'(/2X,8A,/2X,A,/2X,A)') 4263 & ' WARNING: OPERATOR TRIPLET "', 4264 & LABELA,'", "', LABELB,'", "', LABELC,'"', 4265 & ' WITH MORE THAN ONE FIELD WHICH', 4266 & ' INVOKES ORBITAL RELAXATION OR A PERTUR.-DEP. BASIS SET.', 4267 & ' CALCULATION IS CANCELED FOR THIS OPERATOR TRIPLE.' 4268 END IF 4269 IF (.NOT. SKIP_IT) THEN 4270 ! if we have field-dependent basis sets, we need also 4271 ! to check, if the second-derivative integrals for this 4272 ! perturbation pair are available 4273 IF (LPDBSOP(IOPA) .OR. LPDBSOP(IOPB)) THEN 4274 CALL CC_FIND_SO_OP(LABELA,LABELB,LABSOP,ISYSOP, 4275 & ISGNSOP,INUM,WORK,LWORK) 4276 IF (INUM.LT.0) SKIP_IT = .TRUE. 4277 END IF 4278 IF (LPDBSOP(IOPA) .OR. LPDBSOP(IOPC)) THEN 4279 CALL CC_FIND_SO_OP(LABELA,LABELC,LABSOP,ISYSOP, 4280 & ISGNSOP,INUM,WORK,LWORK) 4281 IF (INUM.LT.0) SKIP_IT = .TRUE. 4282 END IF 4283 IF (LPDBSOP(IOPB) .OR. LPDBSOP(IOPC)) THEN 4284 CALL CC_FIND_SO_OP(LABELB,LABELC,LABSOP,ISYSOP, 4285 & ISGNSOP,INUM,WORK,LWORK) 4286 IF (INUM.LT.0) SKIP_IT = .TRUE. 4287 END IF 4288 IF (SKIP_IT) THEN 4289 WRITE(LUPRI,'(/2X,7A,/2X,A,/2X,A)') 4290 & ' WARNING: FOR THE OPERATOR TRIPLET "', 4291 & LABELA,'", "', LABELB,'", "', LABELC,'"', 4292 & ' A SEC. ORD. OPERATOR IS MISSING.', 4293 & ' CALCULATION IS IGNORED.' 4294 END IF 4295 END IF 4296 4297 4298 4299 IF (SKIP_IT) THEN 4300 DO IDX = IOPER, NMCDOPER-1 4301 IAMCDOP(IDX) = IAMCDOP(IDX+1) 4302 IBMCDOP(IDX) = IBMCDOP(IDX+1) 4303 ICMCDOP(IDX) = ICMCDOP(IDX+1) 4304 LAMCDRX(IDX) = LAMCDRX(IDX+1) 4305 LBMCDRX(IDX) = LBMCDRX(IDX+1) 4306 LCMCDRX(IDX) = LCMCDRX(IDX+1) 4307 END DO 4308 NMCDOPER = NMCDOPER - 1 !decrease # of triplets 4309 ELSE 4310 WRITE(LUPRI,'(/2X,A,3(1X,A),A)') 4311 & 'PUT TRIPLET:',LABELA, LABELB, LABELC,' ONTO THE LIST.' 4312 4313 IAMCDOP(IOPER) = IROPER(LABELA,ISYMA) 4314 IBMCDOP(IOPER) = IROPER(LABELB,ISYMB) 4315 ICMCDOP(IOPER) = IROPER(LABELC,ISYMC) 4316 IOPER = IOPER + 1 4317 END IF 4318 4319 END DO 4320 4321 FIRSTCALL = .FALSE. 4322 4323 END IF ! end if (FIRSTCALL) 4324* 4325*--------------------------------------------------------------------* 4326* set/check now symmetries and indices of the excited states 4327*--------------------------------------------------------------------* 4328* 4329 IF (SELMCDST) THEN 4330 4331* check if all required states available, if not remove them from the list: 4332 4333 IDXS = 1 4334 DO WHILE (IDXS .LE. NMCDST) 4335 IF ( IMCDSTNR(IDXS).GT.NCCEXCI(IMCDSTSY(IDXS),1)) THEN 4336 WRITE(LUPRI,'(/2X,A,I2,A,I2,A,/2X,A)') 4337 & ' WARNING: THE STATE WITH SYMMETRY ',IMCDSTSY(IDXS), 4338 & ' AND INDEX ',IMCDSTNR(IDXS) , 4339 & ' IS NOT AVAILABLE.', 4340 & ' B TERM CALCULATION IS CANCELED FOR THIS STATE.' 4341 DO IDX = IDXS, NMCDST-1 4342 IMCDSTNR(IDX) = IMCDSTNR(IDX+1) !move next index 4343 IMCDSTSY(IDX) = IMCDSTSY(IDX+1) !one step back 4344 END DO 4345 NMCDST = NMCDST - 1 4346 ELSE 4347 IDXS = IDXS + 1 4348 END IF 4349 END DO 4350 4351 ELSE 4352 4353* Use default: MCD for all states specified in *CCEXCI 4354 4355 DO ISYMS = 1, NSYM 4356 DO ISTATE = 1, NCCEXCI(ISYMS,1) 4357 IF (NMCDST.LT.MXMCDST) THEN 4358 NMCDST = NMCDST + 1 4359 IMCDSTSY(NMCDST) = ISYMS 4360 IMCDSTNR(NMCDST) = ISTATE 4361 END IF 4362 END DO 4363 END DO 4364 4365 4366 END IF 4367 4368* 4369*--------------------------------------------------------------------* 4370* set list entries for all the required response vectors: 4371* NMCDOPER is # of operator triples (A,B,C) 4372*--------------------------------------------------------------------* 4373* 4374 DO 100 IOPER = 1, NMCDOPER 4375 4376 LPROJ = .FALSE. 4377 4378 LABELA = LBLOPR(IAMCDOP(IOPER)) !get labels back 4379 LABELB = LBLOPR(IBMCDOP(IOPER)) 4380 LABELC = LBLOPR(ICMCDOP(IOPER)) 4381 4382 LPDBSA = LPDBSOP(IAMCDOP(IOPER)) 4383 LPDBSB = LPDBSOP(IBMCDOP(IOPER)) 4384 LPDBSC = LPDBSOP(ICMCDOP(IOPER)) 4385 4386 LORXA = LAMCDRX(IOPER) 4387 LORXB = LBMCDRX(IOPER) 4388 LORXC = LCMCDRX(IOPER) 4389 4390 ISYMA = ISYOPR(IAMCDOP(IOPER)) !get symmetries back 4391 ISYMB = ISYOPR(IBMCDOP(IOPER)) 4392 ISYMC = ISYOPR(ICMCDOP(IOPER)) 4393 4394 ISYMAB = MULD2H(ISYMA,ISYMB) 4395 4396 LRELAX = LORXA.OR.LORXB.OR.LORXC.OR.LPDBSA.OR.LPDBSB.OR.LPDBSC 4397 4398 WRITE(LUPRI,'(/2X,A,3(1X,A),A)') 4399 & 'require responses for op. triplet:',LABELA, LABELB, LABELC 4400 call flshfo(6) 4401 4402 IF (ISYMAB.EQ.ISYMC) THEN 4403 4404 DO 101 IDX = 1, NMCDST 4405 ISYMS_F = IMCDSTSY(IDX) !symmetry of excited state 4406 ISTAT_F = IMCDSTNR(IDX) !index of exc.state within symmetry 4407 !absolute index of the exc. state (pointer) 4408 IEXCI_F = ISYOFE(ISYMS_F) + ISTAT_F 4409 EIGVA_F = EIGVAL(IEXCI_F) !excitation energy 4410 4411 IF (ISYMS_F.EQ.ISYMC) THEN 4412 4413 IF (LOCDBG) THEN 4414 WRITE (LUPRI,*) 'CC_MCDIND> put onto the list:', 4415 & LABELA,'(',-EIGVA_F,'), ', LABELB,'(',ZERO,'), ', 4416 & IEXCI_F,EIGVA_F 4417 END IF 4418 4419 INUM = IR1TAMP(LABELA,LORXA,-EIGVA_F,ISYMA) 4420 INUM = IR1TAMP(LABELB,LORXB,ZERO,ISYMB) 4421 INUM = ILRMAMP(IEXCI_F,EIGVA_F,ISYMC) 4422 INUM = IER1AMP(IEXCI_F,EIGVA_F,ISYMC, 4423 & LABELA,-EIGVA_F,ISYMA,.FALSE.) 4424 INUM = IETA1(LABELB,LORXB,ZERO,ISYMB) 4425 IF (ISYMB .EQ. 1) LPROJ = .TRUE. 4426 INUM = IEL1AMP(IEXCI_F,EIGVA_F,ISYMC, 4427 & LABELB, ZERO,ISYMB,LORXB,LPROJ) 4428 IF (.NOT.LUSE2N1) THEN 4429 INUM = IR1TAMP(LABELC,LORXC,-EIGVA_F,ISYMC) 4430 END IF 4431 INUM = IRHSR1(LABELC,LORXC,EIGVA_F,ISYMC) 4432 INUM = IETA1(LABELC,LORXC,EIGVA_F,ISYMC) 4433 4434 IF (LUSEPL1) THEN 4435 IF (ISYMB .EQ. 1) LPROJ = .TRUE. 4436 INUM = IPL1ZETA(LABELA,LORXA,-EIGVA_F,ISYMA, 4437 & LPROJ,IEXCI_F, EIGVA_F,ISYMC) 4438 ELSE 4439 4440 INUM = IRHSR2(LABELA,LORXA,-EIGVA_F,ISYMA, 4441 & LABELB,LORXB,ZERO,ISYMB) 4442 IF (ISYMB .EQ. 1) LPROJ = .TRUE. 4443 INUM = IER1AMP(IEXCI_F,EIGVA_F,ISYMC, 4444 & LABELB,ZERO,ISYMB,LPROJ) 4445 INUM = IETA1(LABELA,LORXA,-EIGVA_F,ISYMA) 4446 END IF 4447 4448 END IF 4449 101 CONTINUE 4450 END IF 4451 100 CONTINUE 4452 CALL FLSHFO(LUPRI) 4453 4454 RETURN 4455 END 4456*---------------------------------------------------------------------* 4457c /* deck cc_exlrind */ 4458*=====================================================================* 4459 SUBROUTINE CC_EXLRIND 4460*---------------------------------------------------------------------* 4461* 4462* Purpose: setup of the equations that have to be solved for 4463* the excited state linear response properties 4464* 4465* Written by Christof Haettig, July 1997. 4466* 4467*=====================================================================* 4468#if defined (IMPLICIT_NONE) 4469 IMPLICIT NONE 4470#else 4471# include "implicit.h" 4472#endif 4473#include "priunit.h" 4474#include "ccorb.h" 4475#include "ccexlrinf.h" 4476#include "ccrspprp.h" 4477#include "ccroper.h" 4478#include "cclr.h" 4479#include "ccexci.h" 4480#include "ccsdinp.h" 4481 4482* local parameters: 4483 LOGICAL LOCDBG 4484 PARAMETER (LOCDBG = .FALSE.) 4485 4486* variables: 4487 CHARACTER*8 LABELA, LABELB 4488 LOGICAL LPRJ 4489 INTEGER ISYMB, ISYMA, IFREQ, INUM, IOPER, ISYMS, ISTATE 4490 INTEGER IDX, IEXCII, ISTATI, IEXCIF, ISTATF, IDXS, ISYMSI, ISYMSF 4491 4492 REAL*8 HALF, FREQA, FREQB, EIGVI, EIGVF 4493 4494 PARAMETER ( HALF = 0.5d0 ) 4495 4496 4497* external functions: 4498 INTEGER IER1AMP 4499 INTEGER IEL1AMP 4500 INTEGER IROPER 4501 INTEGER IRHSR2 4502 INTEGER IN2AMP 4503 4504* data: 4505 LOGICAL FIRSTCALL 4506 SAVE FIRSTCALL 4507 DATA FIRSTCALL /.TRUE./ 4508 4509*---------------------------------------------------------------------* 4510* test if operators are available and translate IAQROP, IBQROP, ICQROP 4511* arrays from the PRPLBL_CC list to the new list maintained by IROPER. 4512*---------------------------------------------------------------------* 4513 IF (FIRSTCALL) THEN 4514 WRITE (LUPRI,*) 'CC_EXLRIND> NEXLROPER = ',NEXLROPER 4515 4516 IOPER = 1 4517 DO WHILE (IOPER .LE. NEXLROPER) 4518 4519 WRITE(LUPRI,'(/2X,A,3I5)') 4520 & 'IOPER,IAEXLROP,IBEXLROP:',IOPER,IAEXLROP(IOPER),IBEXLROP(IOPER) 4521 LABELA = PRPLBL_CC(IAEXLROP(IOPER)) 4522 LABELB = PRPLBL_CC(IBEXLROP(IOPER)) 4523 WRITE(LUPRI,'(/2X,A,2(1X,A),A)') 'CHECK PAIR:',LABELA, LABELB 4524 4525 IF ( (IROPER(LABELA,ISYMA) .LT. 0) 4526 & .OR. (IROPER(LABELB,ISYMB) .LT. 0) ) THEN 4527 4528 WRITE(LUPRI,'(/2X,5A,/2X,2A)') 4529 & ' WARNING: ONE OF THE OPERATORS WITH THE LABELS "', 4530 & LABELA,'", "', LABELB,'" IS NOT AVAILABLE.', 4531 & ' POLARIZABILITY CALCULATION IS CANCELED FOR THIS', 4532 & ' OPERATOR PAIR.' 4533 4534 DO IDX = IOPER, NEXLROPER-1 4535 IAEXLROP(IDX) = IAEXLROP(IDX+1) 4536 IBEXLROP(IDX) = IBEXLROP(IDX+1) 4537 END DO 4538 4539 NEXLROPER = NEXLROPER - 1 4540 4541 ELSE 4542 WRITE(LUPRI,'(/2X,A,2(1X,A),A)') 4543 & 'PUT PAIR:',LABELA, LABELB,' ONT THE LIST.' 4544 IAEXLROP(IOPER) = IROPER(LABELA,ISYMA) 4545 IBEXLROP(IOPER) = IROPER(LABELB,ISYMB) 4546 4547 IOPER = IOPER + 1 4548 END IF 4549 4550 END DO 4551 4552 FIRSTCALL = .FALSE. 4553 4554 END IF ! (FIRSTCALL) 4555 4556*---------------------------------------------------------------------* 4557* process the excited state information 4558*---------------------------------------------------------------------* 4559 IF (ALLSTATES) THEN 4560 4561* set now symmetries and indeces of the excited states: 4562* (diagonal cases, i.e., excited state response functions, only) 4563 DO ISYMS = 1, NSYM 4564 DO ISTATE = 1, NCCEXCI(ISYMS,1) 4565 IF (NEXLRST.LT.MXEXLRST) THEN 4566 NEXLRST = NEXLRST + 1 4567 IELRSYM(NEXLRST,1) = ISYMS 4568 IELRSTA(NEXLRST,1) = ISTATE 4569 IELRSYM(NEXLRST,2) = ISYMS 4570 IELRSTA(NEXLRST,2) = ISTATE 4571 END IF 4572 END DO 4573 END DO 4574 4575 ELSE 4576 4577* check if all states available, if not remove them from the list: 4578 IDXS = 1 4579 DO WHILE (IDXS .LE. NEXLRST) 4580 IF ( IELRSTA(IDXS,1).GT.NCCEXCI(IELRSYM(IDXS,1),1) 4581 & .OR. IELRSTA(IDXS,2).GT.NCCEXCI(IELRSYM(IDXS,2),1) ) THEN 4582 WRITE(LUPRI,'(2(/2X,A,I2,A,I2),A,/2X,A)') 4583 & ' WARNING: THE STATE WITH SYMMETRY ',IELRSYM(IDXS,1), 4584 & ' AND INDEX ',IELRSTA(IDXS,1) , 4585 & ' OR THE STATE WITH SYMMETRY ',IELRSYM(IDXS,2), 4586 & ' AND INDEX ',IELRSTA(IDXS,2) , 4587 & ' IS NOT AVAILABLE.', 4588 & ' POLARIZABILITY CALCULATION IS CANCELED FOR THIS STATE.' 4589 DO IDX = IDXS, NEXLRST-1 4590 IELRSTA(IDX,1) = IELRSTA(IDX+1,1) 4591 IELRSYM(IDX,1) = IELRSYM(IDX+1,1) 4592 IELRSTA(IDX,2) = IELRSTA(IDX+1,2) 4593 IELRSYM(IDX,2) = IELRSYM(IDX+1,2) 4594 END DO 4595 NEXLRST = NEXLRST - 1 4596 ELSE 4597 IDXS = IDXS + 1 4598 END IF 4599 END DO 4600 4601 END IF 4602 4603*---------------------------------------------------------------------* 4604* check for HALFFR option: 4605*---------------------------------------------------------------------* 4606 IF ( HALFFR .AND. NEXLRFREQ.NE.1 ) THEN 4607 WRITE (LUPRI,*) 'error in CC_EXLRIND: HALFFR option is', 4608 & ' incompatible with a frequency list.' 4609 CALL QUIT('error in CC_EXLRIND.') 4610 END IF 4611 4612*---------------------------------------------------------------------* 4613* for CC3 we can switch off USE_O2/USE_EL1 since it can not be used: 4614*---------------------------------------------------------------------* 4615 IF (CC3 .AND. USE_O2) THEN 4616 WRITE(LUPRI,*) 'Info: the .USE O2 option cannot be use for ' 4617 WRITE(LUPRI,*) ' in *CCEXLR for CC3... it is turned off' 4618 USE_O2 = .FALSE. 4619 END IF 4620 4621 IF (CC3 .AND. USE_EL1) THEN 4622 WRITE(LUPRI,*) 'Info: the .USELEF option cannot be use for ' 4623 WRITE(LUPRI,*) ' in *CCEXLR for CC3... it is turned off' 4624 USE_EL1 = .FALSE. 4625 END IF 4626 4627*---------------------------------------------------------------------* 4628* set list entries for the required response vectors: 4629*---------------------------------------------------------------------* 4630 DO IOPER = 1, NEXLROPER 4631 LABELA = LBLOPR(IAEXLROP(IOPER)) 4632 LABELB = LBLOPR(IBEXLROP(IOPER)) 4633 4634 ISYMA = ISYOPR(IAEXLROP(IOPER)) 4635 ISYMB = ISYOPR(IBEXLROP(IOPER)) 4636 4637C WRITE(LUPRI,'(/2X,A,3(1X,A),A)') 4638C & 'require responses for pair:',LABELA, LABELB 4639 4640 4641 4642 DO IDXS = 1, NEXLRST 4643 ISYMSI = IELRSYM(IDXS,1) 4644 ISTATI = IELRSTA(IDXS,1) 4645 ISYMSF = IELRSYM(IDXS,2) 4646 ISTATF = IELRSTA(IDXS,2) 4647 IEXCII = ISYOFE(ISYMSI) + ISTATI 4648 EIGVI = EIGVAL(IEXCII) 4649 IEXCIF = ISYOFE(ISYMSF) + ISTATF 4650 EIGVF = EIGVAL(IEXCIF) 4651 4652 IF (MULD2H(ISYMA,ISYMB) .EQ. MULD2H(ISYMSI,ISYMSF) ) THEN 4653 4654 DO IFREQ = 1, NEXLRFREQ 4655 FREQB = BEXLRFR(IFREQ) 4656 IF (IEXCII.EQ.IEXCIF) THEN 4657 FREQA = -FREQB 4658 LPRJ = .NOT. NOPROJ 4659 ELSE 4660 IF ( HALFFR ) FREQB = HALF * (EIGVI-EIGVF) 4661 FREQA = EIGVI - EIGVF -FREQB 4662 LPRJ = .FALSE. 4663 END IF 4664 4665* request first order right excited state response vectors: 4666 IF (.NOT. USE_EL1) THEN 4667 INUM=IER1AMP(IEXCIF,EIGVF,ISYMSF,LABELA,+FREQA,ISYMA,LPRJ) 4668 INUM=IER1AMP(IEXCIF,EIGVF,ISYMSF,LABELB,+FREQB,ISYMB,LPRJ) 4669 INUM=IER1AMP(IEXCII,EIGVI,ISYMSI,LABELA,-FREQA,ISYMA,LPRJ) 4670 INUM=IER1AMP(IEXCII,EIGVI,ISYMSI,LABELB,-FREQB,ISYMB,LPRJ) 4671 END IF 4672 4673* request first order left excited state response vectors: 4674 IF (USE_EL1) THEN 4675 INUM=IEL1AMP(IEXCII,EIGVI,ISYMSI, 4676 & LABELA,+FREQA,ISYMA,.FALSE.,LPRJ) 4677 INUM=IEL1AMP(IEXCII,EIGVI,ISYMSI, 4678 & LABELB,+FREQB,ISYMB,.FALSE.,LPRJ) 4679 INUM=IEL1AMP(IEXCIF,EIGVF,ISYMSF, 4680 & LABELA,-FREQA,ISYMA,.FALSE.,LPRJ) 4681 INUM=IEL1AMP(IEXCIF,EIGVF,ISYMSF, 4682 & LABELB,-FREQB,ISYMB,.FALSE.,LPRJ) 4683 END IF 4684 4685* request zeroth-order excited state lagrange vectors: 4686 INUM = IN2AMP(IEXCII,-EIGVI,ISYMSI,IEXCIF,EIGVF,ISYMSF) 4687 INUM = IN2AMP(IEXCIF,-EIGVF,ISYMSF,IEXCII,EIGVI,ISYMSI) 4688 4689* request right hand side vector for T2: 4690 IF (USE_O2) THEN 4691 INUM = IRHSR2(LABELA,.FALSE.,+FREQA,ISYMA, 4692 & LABELB,.FALSE.,+FREQB,ISYMB) 4693 INUM = IRHSR2(LABELA,.FALSE.,-FREQA,ISYMA, 4694 & LABELB,.FALSE.,-FREQB,ISYMB) 4695 END IF 4696 4697 END DO 4698 END IF 4699 END DO 4700 4701 END DO 4702 4703 4704 RETURN 4705 END 4706*---------------------------------------------------------------------* 4707*=====================================================================* 4708C /* Deck iroper */ 4709*=====================================================================* 4710 INTEGER FUNCTION IROPER(NEWLBL,ISYM) 4711*---------------------------------------------------------------------* 4712* 4713* maintain the list of operators labels for the response calculations 4714* the operators are specified by a character*8 label (NEWLBL) 4715* 4716* in difference to the list maintained by the INDPRP_CC function, 4717* the list maintained by IROPER is ordered (see routine CCLSTSORT). 4718* 4719* Christof Haettig, November 1996, modified Januar 97: 4720* 4721* if NEWLBL is on the list return list index and set ISYM, 4722* if NEWLBL is NOT on the list: 4723* LOPROPN=.true. --> extend list, and return index 4724* LOPROPN=.false. --> return -1 4725* 4726*=====================================================================* 4727 IMPLICIT NONE 4728#include "ccroper.h" 4729#include "priunit.h" 4730C 4731 LOGICAL LOCDBG 4732 PARAMETER (LOCDBG = .FALSE.) 4733 4734 CHARACTER*8 NEWLBL 4735 INTEGER I, ISYM 4736 4737 IF (LOCDBG) THEN 4738 WRITE (LUPRI,*) 'IROPER>',NEWLBL,ISYM 4739 CALL FLSHFO(LUPRI) 4740 END IF 4741 4742 DO I = 1,NRSOLBL 4743 IF ( NEWLBL .EQ. LBLOPR(I) ) THEN 4744 IROPER = I 4745 ISYM = ISYOPR(IROPER) 4746 IF (LOCDBG) 4747 & WRITE(LUPRI,*) 'IROPER>',IROPER,LBLOPR(IROPER), 4748 & ISYOPR(IROPER) 4749 RETURN 4750 END IF 4751 END DO 4752 4753 IF (LOPROPN) THEN 4754 NRSOLBL = NRSOLBL + 1 4755 4756 IF (NRSOLBL.GT.MAXOLBL) THEN 4757 WRITE(LUPRI,'(A,/A,I5,A,I5)') 4758 * ' NUMBER OF SPECIFIED OPERATORS EXCEED THE MAXIMUM ALLOWED', 4759 * ' MAXOLBL =',MAXOLBL,' NRSOLBL= ',NRSOLBL 4760 CALL QUIT(' IROPER: TOO MANY OPERATORS SPECIFIED') 4761 END IF 4762 4763 LBLOPR(NRSOLBL) = NEWLBL 4764 ISYOPR(NRSOLBL) = ISYM 4765 IROPER = NRSOLBL 4766 4767 ELSE 4768 WRITE(LUPRI,'(/3A)') 4769 * ' WARNING: OPERATOR WITH LABEL "',NEWLBL,'" NOT AVAILABLE.' 4770 IROPER = -1 4771 END IF 4772 4773 IF (LOCDBG) 4774 & WRITE (LUPRI,*) 4775 & 'IROPER>', IROPER, LBLOPR(IROPER), ISYOPR(IROPER) 4776 4777 RETURN 4778 END 4779*=====================================================================* 4780C /* Deck ir2tamp */ 4781 INTEGER FUNCTION IR2TAMP(NEWLBLA,LORXA,FRQANEW,ISYMA, 4782 * NEWLBLB,LORXB,FRQBNEW,ISYMB ) 4783*---------------------------------------------------------------------* 4784C 4785C maintain the list of second order right response vectors 4786C 4787C if vector is on the list return list index and set ISYMA,ISYMB 4788C if vector is NOT on the list: 4789C LR2OPN=.true. --> extend list, and return index 4790C LR2OPN=.false. --> return -1 4791C 4792C NEWLBLA / NEWLBLB -- operator labels 4793C LORXA / LORXB -- flags for orbital relaxation 4794C FRQANEW / FRQBNEW -- frequencies 4795C ISYMA / ISYMB -- symmetries 4796C 4797C Christof Haettig, Februar 97 4798C LORXA, LORXB flags introduced in July 1999 4799*---------------------------------------------------------------------* 4800 IMPLICIT NONE 4801#include "ccr2rsp.h" 4802#include "priunit.h" 4803C 4804 LOGICAL LORXA, LORXB 4805 INTEGER ISYMA, ISYMB 4806 REAL*8 FRQANEW,FRQBNEW,TOL 4807 4808 PARAMETER(TOL=1.0D-12) 4809 4810 CHARACTER*8 NEWLBLA, NEWLBLB 4811 INTEGER I 4812 4813 DO I = 1,NR2TLBL 4814 IF ( NEWLBLA.EQ.LBLAR2T(I).AND. NEWLBLB.EQ.LBLBR2T(I) 4815 * .AND. (LORXA .EQV. LORXAR2T(I)) 4816 * .AND. (LORXB .EQV. LORXBR2T(I)) 4817 * .AND. (ABS(FRQANEW-FRQAR2T(I)).LT.TOL) 4818 * .AND. (ABS(FRQBNEW-FRQBR2T(I)).LT.TOL) 4819 * ) THEN 4820 IR2TAMP = I 4821 ISYMA = ISYAR2T(IR2TAMP) 4822 ISYMB = ISYBR2T(IR2TAMP) 4823 RETURN 4824 END IF 4825 IF ( NEWLBLB.EQ.LBLAR2T(I).AND. NEWLBLA.EQ.LBLBR2T(I) 4826 * .AND. (LORXB .EQV. LORXAR2T(I)) 4827 * .AND. (LORXA .EQV. LORXBR2T(I)) 4828 * .AND. (ABS(FRQBNEW-FRQAR2T(I)).LT.TOL) 4829 * .AND. (ABS(FRQANEW-FRQBR2T(I)).LT.TOL) 4830 * ) THEN 4831 IR2TAMP = I 4832 ISYMB = ISYAR2T(IR2TAMP) 4833 ISYMA = ISYBR2T(IR2TAMP) 4834 RETURN 4835 END IF 4836 END DO 4837 4838 IF (LR2OPN) THEN 4839 NR2TLBL = NR2TLBL + 1 4840 4841 IF (NR2TLBL.GT.MAXT2LBL) THEN 4842 WRITE(LUPRI,'(A,/A,I5,A,I5)') 4843 * '@ NUMBER OF SPECIFIED EQUATIONS EXCEED THE MAXIMUM ALLOWED', 4844 * '@ MAXT2LBL =',MAXT2LBL,' NR2TLBL= ',NR2TLBL 4845 CALL QUIT(' IR2TAMP: TOO MANY EQUATIONS SPECIFIED') 4846 END IF 4847 4848 LBLAR2T(NR2TLBL) = NEWLBLA 4849 LBLBR2T(NR2TLBL) = NEWLBLB 4850 LORXAR2T(NR2TLBL) = LORXA 4851 LORXBR2T(NR2TLBL) = LORXB 4852 FRQAR2T(NR2TLBL) = FRQANEW 4853 FRQBR2T(NR2TLBL) = FRQBNEW 4854 ISYAR2T(NR2TLBL) = ISYMA 4855 ISYBR2T(NR2TLBL) = ISYMB 4856 IR2TAMP = NR2TLBL 4857 4858 ELSE 4859 WRITE(LUPRI,'(3A,L2,A,1P,D12.5,3A,L2,A,1P,D12.5,2A)') 4860 * '@ WARNING: R2 VECTOR FOR ', 4861 * NEWLBLA,'(',LORXA,',',FRQANEW,'), ', 4862 * NEWLBLB,'(',LORXB,',',FRQBNEW,')', 4863 * ' IS NOT AVAILABLE.' 4864 IR2TAMP = -1 4865 END IF 4866 4867 RETURN 4868 END 4869*=====================================================================* 4870C /* Deck ir1tamp */ 4871 INTEGER FUNCTION IR1TAMP(NEWLBL,LORX,FRQNEW,ISYM) 4872*---------------------------------------------------------------------* 4873C 4874C maintain the list of first order t amplitude responses 4875C 4876C if vector is on the list return list index and set ISYM 4877C if vector is NOT on the list: 4878C LR1OPN=.true. --> extend list, and return index 4879C LR1OPN=.false. --> return -1 4880C 4881C NEWLBL -- operator label 4882C LORX -- flag for orbital relaxation 4883C FRQNEW -- frequency (ignored for unrelaxed orbitals) 4884C ISYM -- symmetry 4885C 4886C Christof Haettig, Oktober 1996 4887C LORX flag introduced and some clean up in Juni 1998 4888C 4889*---------------------------------------------------------------------* 4890 IMPLICIT NONE 4891#include "ccr1rsp.h" 4892#include "priunit.h" 4893 4894 LOGICAL LORX, LORXI 4895 INTEGER ISYM 4896 REAL*8 FRQNEW,TOL 4897 4898 PARAMETER(TOL=1.0D-12) 4899 4900 CHARACTER*8 NEWLBL 4901 INTEGER I 4902 4903 DO I = 1,NLRTLBL 4904 IF ( NEWLBL .EQ. LRTLBL(I) .AND. (LORX .EQV. LORXLRT(I)) .AND. 4905 * (ABS(FRQNEW-FRQLRT(I)) .LT. TOL) ) THEN 4906 IR1TAMP = I 4907 ISYM = ISYLRT(IR1TAMP) 4908 RETURN 4909 END IF 4910 END DO 4911 4912 IF (LR1OPN) THEN 4913 NLRTLBL = NLRTLBL + 1 4914 4915 IF (NLRTLBL.GT.MAXTLBL) THEN 4916 WRITE(LUPRI,'(A,/A,I5,A,I5)') 4917 * '@ NUMBER OF SPECIFIED EQUATIONS EXCEED THE MAXIMUM ALLOWED', 4918 * '@ MAXTLBL =',MAXTLBL,' NLRTLBL= ',NLRTLBL 4919 CALL QUIT(' IR1TAMP: TOO MANY EQUATIONS SPECIFIED') 4920 END IF 4921 4922 LRTLBL(NLRTLBL) = NEWLBL 4923 LORXLRT(NLRTLBL) = LORX 4924 FRQLRT(NLRTLBL) = FRQNEW 4925 ISYLRT(NLRTLBL) = ISYM 4926 IR1TAMP = NLRTLBL 4927 4928 ELSE 4929 WRITE(LUPRI,'(/3A,L2,A,1P,D12.5,2A)') 4930 * '@ WARNING: R1 VECTOR FOR ',NEWLBL,'(',LORX,',',FRQNEW,')', 4931 * ' IS NOT AVAILABLE.' 4932 WRITE(LUPRI,'(/A)') ' LIST OF FIRST-ORDER T VECTORS:' 4933 DO I = 1, NLRTLBL 4934 WRITE(LUPRI,'(I5,3X,A8,L3,I5,2X,1P,D15.6)') 4935 & I, LRTLBL(I), LORXLRT(I), ISYLRT(I), FRQLRT(I) 4936 WRITE (LUPRI,*) 4937 & ' NEWLBL .EQ. LRTLBL(I):', NEWLBL .EQ. LRTLBL(I) 4938 WRITE (LUPRI,*) 4939 & '(LORX .EQV. LORXLRT(I)):',(LORX .EQV. LORXLRT(I)) 4940 WRITE (LUPRI,*) 4941 & 'FRQNEW=FRQLRT:',(ABS(FRQNEW-FRQLRT(I)) .LT. TOL) 4942 END DO 4943 IR1TAMP = -1 4944 END IF 4945 4946 RETURN 4947 END 4948*=====================================================================* 4949C /* Deck ir1kappa */ 4950 INTEGER FUNCTION IR1KAPPA(NEWLBL,FRQNEW,ISYM) 4951*---------------------------------------------------------------------* 4952C 4953C maintain the list of first order orbital responses 4954C 4955C if vector is on the list return list index and set ISYM 4956C if vector is NOT on the list: 4957C LR1OPN=.true. --> extend list, and return index 4958C LR1OPN=.false. --> return -1 4959C 4960C NEWLBL -- operator label 4961C FRQNEW -- frequency (ignored for unrelaxed orbitals) 4962C ISYM -- symmetry 4963C 4964C Note that this list shares common block with IR1TAMP list 4965C 4966C Christof Haettig, July 2003 4967C 4968*---------------------------------------------------------------------* 4969 IMPLICIT NONE 4970#include "ccr1rsp.h" 4971#include "priunit.h" 4972 4973 INTEGER ISYM 4974 REAL*8 FRQNEW,TOL 4975 4976 PARAMETER(TOL=1.0D-12) 4977 4978 CHARACTER*8 NEWLBL 4979 INTEGER I 4980 4981 DO I = 1,NLRTHFLBL 4982 IF ( NEWLBL .EQ. LRTHFLBL(I) .AND. 4983 * (ABS(FRQNEW-FRQLRTHF(I)) .LT. TOL) ) THEN 4984 IR1KAPPA = I 4985 ISYM = ISYLRTHF(IR1KAPPA) 4986 RETURN 4987 END IF 4988 END DO 4989 4990 IF (LR1OPN) THEN 4991 NLRTHFLBL = NLRTHFLBL + 1 4992 4993 IF (NLRTHFLBL.GT.MAXTLBL) THEN 4994 WRITE(LUPRI,'(A,/A,I5,A,I5)') 4995 * '@ NUMBER OF SPECIFIED EQUATIONS EXCEED THE MAXIMUM ALLOWED', 4996 * '@ MAXTLBL =',MAXTLBL,' NLRTHFLBL= ',NLRTHFLBL 4997 CALL QUIT(' IR1KAPPA: TOO MANY EQUATIONS SPECIFIED') 4998 END IF 4999 5000 LRTHFLBL(NLRTHFLBL) = NEWLBL 5001 FRQLRTHF(NLRTHFLBL) = FRQNEW 5002 ISYLRTHF(NLRTHFLBL) = ISYM 5003 IR1KAPPA = NLRTHFLBL 5004 5005 ELSE 5006 WRITE(LUPRI,'(/3A,1P,D12.5,2A)') 5007 * '@ WARNING: R1 KAPPA VECTOR FOR ',NEWLBL,'(',FRQNEW,')', 5008 * ' IS NOT AVAILABLE.' 5009 WRITE(LUPRI,'(/A)') ' LIST OF FIRST-ORDER KAPPA VECTORS:' 5010 DO I = 1, NLRTHFLBL 5011 WRITE(LUPRI,'(I5,3X,A8,I5,2X,1P,D15.6)') 5012 & I, LRTHFLBL(I), ISYLRTHF(I), FRQLRTHF(I) 5013 END DO 5014 IR1KAPPA = -1 5015 END IF 5016 5017 RETURN 5018 END 5019*=====================================================================* 5020*=====================================================================* 5021C /* Deck ilrcamp */ 5022 INTEGER FUNCTION ILRCAMP(NEWLBL,ICAUCH,ISYM) 5023*---------------------------------------------------------------------* 5024C 5025C maintain the list of right cauchy vectors. 5026C 5027C if vector is on the list return list index and set symmetry 5028C if vector is NOT on the list, then 5029C if LRC1OPN = .true. --> extend list and return index 5030C if LRC1OPN = .false. --> return -1 5031C 5032C Christof Haettig, october 1997 5033*---------------------------------------------------------------------* 5034 IMPLICIT NONE 5035#include "ccrc1rsp.h" 5036#include "priunit.h" 5037C 5038 INTEGER ISYM,ICAUCH 5039 5040 CHARACTER*8 NEWLBL 5041 INTEGER I 5042 5043 DO I = 1,NLRCLBL 5044 IF ( NEWLBL .EQ. LRCLBL(I).AND. 5045 * (ICAUCH.EQ.ILRCAU(I))) THEN 5046 ILRCAMP = I 5047 ISYM = ISYLRC(ILRCAMP) 5048 RETURN 5049 END IF 5050 END DO 5051 5052 IF (LRC1OPN) THEN 5053 NLRCLBL = NLRCLBL + 1 5054 5055 IF (NLRCLBL.GT.MAXCLBL) THEN 5056 WRITE(LUPRI,'(A,/A,I5,A,I5)') 5057 * '@ NUMBER OF SPECIFIED EQUATIONS EXCEED THE MAXIMUM ALLOWED', 5058 * '@ MAXCLBL =',MAXCLBL,' NLRCLBL= ',NLRCLBL 5059 CALL QUIT(' ILRCAMP: TOO MANY EQUATIONS SPECIFIED') 5060 END IF 5061 5062 LRCLBL(NLRCLBL) = NEWLBL 5063 ILRCAU(NLRCLBL) = ICAUCH 5064 ISYLRC(NLRCLBL) = ISYM 5065 ILRCAMP = NLRCLBL 5066 ELSE 5067 WRITE(LUPRI,'(3A,I3,A)') 5068 * '@ WARNING: RC1 VECTOR FOR ',NEWLBL, 5069 * ' CAUCHY ORDER',ICAUCH,' IS NOT AVAILABLE.' 5070 ILRCAMP = -1 5071 END IF 5072 5073 RETURN 5074 END 5075*---------------------------------------------------------------------* 5076*=====================================================================* 5077C /* Deck ILC1AMP */ 5078 INTEGER FUNCTION ILC1AMP(NEWLBL,ICAUCH,ISYM) 5079*---------------------------------------------------------------------* 5080C 5081C maintain the list of left cauchy vectors. 5082C 5083C if vector is on the list return list index and set symmetry 5084C if vector is NOT on the list, then 5085C if LLC1OPN = .true. --> extend list and return index 5086C if LLC1OPN = .false. --> return -1 5087C 5088C Christof Haettig, october 1997 5089*---------------------------------------------------------------------* 5090 IMPLICIT NONE 5091#include "cclc1rsp.h" 5092#include "priunit.h" 5093C 5094 INTEGER ISYM,ICAUCH 5095 5096 CHARACTER*8 NEWLBL 5097 INTEGER I 5098 5099 DO I = 1,NLC1LBL 5100 IF ( NEWLBL.EQ.LBLLC1(I) .AND. ICAUCH.EQ.ILC1CAU(I) ) THEN 5101 ILC1AMP = I 5102 ISYM = ISYLC1(ILC1AMP) 5103 RETURN 5104 END IF 5105 END DO 5106 5107 IF (LLC1OPN) THEN 5108 NLC1LBL = NLC1LBL + 1 5109 5110 IF (NLC1LBL.GT.MAXLC1LBL) THEN 5111 WRITE(LUPRI,'(A,/A,I5,A,I5)') 5112 * '@ NUMBER OF SPECIFIED EQUATIONS EXCEED THE MAXIMUM ALLOWED', 5113 * '@ MAXLC1LBL =',MAXLC1LBL,' NLC1LBL= ',NLC1LBL 5114 CALL QUIT(' ILC1AMP: TOO MANY EQUATIONS SPECIFIED') 5115 END IF 5116 5117 LBLLC1(NLC1LBL) = NEWLBL 5118 ILC1CAU(NLC1LBL) = ICAUCH 5119 ISYLC1(NLC1LBL) = ISYM 5120 ILC1AMP = NLC1LBL 5121 ELSE 5122 WRITE(LUPRI,'(3A,I3,A)') 5123 * '@ WARNING: LC1 VECTOR FOR ',NEWLBL, 5124 * ' CAUCHY ORDER',ICAUCH,' IS NOT AVAILABLE.' 5125 ILC1AMP = -1 5126 END IF 5127 5128 RETURN 5129 END 5130*---------------------------------------------------------------------* 5131*=====================================================================* 5132C /* Deck il1zeta */ 5133 INTEGER FUNCTION IL1ZETA(NEWLBL,LORX,FRQNEW,ISYM) 5134*---------------------------------------------------------------------* 5135C 5136C maintain the list of first order zeta amplitude responses 5137C 5138C if vector is on the list return list index and set ISYMA,ISYMB 5139C if vector is NOT on the list: 5140C LL1OPN=.true. --> extend list, and return index 5141C LL1OPN=.false. --> return -1 5142C 5143C NEWLBL -- operator label 5144C LORX -- flag for orbital relaxation 5145C FRQNEW -- frequency (ignored for unrelaxed orbitals) 5146C ISYM -- symmetry 5147C 5148C Christof Haettig, Oktober 1996 5149C LORX flag introduced and some clean up in Juni 1998 5150C 5151*---------------------------------------------------------------------* 5152 IMPLICIT NONE 5153#include "ccl1rsp.h" 5154#include "priunit.h" 5155C 5156 5157 LOGICAL LORX 5158 INTEGER ISYM, I 5159 REAL*8 FRQNEW, TOL 5160 5161 PARAMETER(TOL=1.0D-12) 5162 5163 5164 CHARACTER*8 NEWLBL 5165 5166 DO I = 1,NLRZLBL 5167 IF ( NEWLBL .EQ. LRZLBL(I).AND. (LORX .EQV. LORXLRZ(I)) .AND. 5168 * (ABS(FRQNEW-FRQLRZ(I)).LT.TOL)) THEN 5169 IL1ZETA = I 5170 ISYM = ISYLRZ(IL1ZETA) 5171 RETURN 5172 END IF 5173 END DO 5174 5175 IF (LL1OPN) THEN 5176 NLRZLBL = NLRZLBL + 1 5177 5178 IF (NLRZLBL.GT.MAXZLBL) THEN 5179 WRITE(LUPRI,'(A,/A,I5,A,I5)') 5180 * '@ NUMBER OF SPECIFIED EQUATIONS EXCEED THE MAXIMUM ALLOWED', 5181 * '@ MAXZLBL =',MAXZLBL,' NLRZLBL= ',NLRZLBL 5182 CALL QUIT(' IL1ZETA: TOO MANY EQUATIONS SPECIFIED') 5183 END IF 5184 5185 LRZLBL(NLRZLBL) = NEWLBL 5186 LORXLRZ(NLRZLBL) = LORX 5187 FRQLRZ(NLRZLBL) = FRQNEW 5188 ISYLRZ(NLRZLBL) = ISYM 5189 IL1ZETA = NLRZLBL 5190 5191 ELSE 5192 WRITE(LUPRI,'(3A,L2,A,1P,D12.5,2A)') 5193 * '@ WARNING: L1 VECTOR FOR ',NEWLBL,'(',LORX,',',FRQNEW,')', 5194 * ' IS NOT AVAILABLE.' 5195 IL1ZETA = -1 5196 END IF 5197 5198 RETURN 5199 END 5200*=====================================================================* 5201*---------------------------------------------------------------------* 5202 INTEGER FUNCTION ILRMAMP(IEXCI,FRQNEW,ISYM) 5203C 5204C maintain the list of transition moment lagrangian multipliers 5205C 5206C Ove Christiansen April 1997 5207C 5208 IMPLICIT NONE 5209#include "cclrmrsp.h" 5210#include "priunit.h" 5211C 5212 INTEGER ISYM,IEXCI,I 5213 REAL*8 FRQNEW,TOL 5214 5215 PARAMETER(TOL=1.0D-12) 5216 5217 DO I = 1,NLRM 5218 IF ( IEXCI .EQ. ILRM(I).AND. 5219 * (ABS(FRQNEW-FRQLRM(I)).LT.TOL)) THEN 5220 ILRMAMP = I 5221 ISYM = ISYLRM(ILRMAMP) 5222 RETURN 5223 END IF 5224 END DO 5225 5226 NLRM = NLRM + 1 5227 5228 IF (NLRM .GT.MAXM ) THEN 5229 WRITE(LUPRI,'(A,/A,I5,A,I5)') 5230 * '@ NUMBER OF SPECIFIED EQUATIONS EXCEED THE MAXIMUM ALLOWED', 5231 * '@ MAXM =',MAXM ,' NLRM = ',NLRM 5232 CALL QUIT(' ILRMAMP: TOO MANY EQUATIONS SPECIFIED') 5233 END IF 5234 5235 ILRM(NLRM) = IEXCI 5236 FRQLRM(NLRM) = FRQNEW 5237 ISYLRM(NLRM) = ISYM 5238 ILRMAMP = NLRM 5239 5240 RETURN 5241 END 5242*---------------------------------------------------------------------* 5243C /* Deck cclstsort */ 5244*=====================================================================* 5245 SUBROUTINE CCLSTSORT (TYPE, 5246 & ISYMS, ISTAT, EIGVAL, 5247 & ISYMO, LABEL, FREQ, ICAU, LORX, 5248 & ISYOF, NVEC, MAXVEC, LPROJ ) 5249*---------------------------------------------------------------------* 5250* 5251* PURPOSE: sort list of vectors/equations according: 5252* 5253* 1.) over-all symmetry (obtained by calling ILSTSYM) 5254* 2.) individual symmetries of the states (ISYMS) 5255* 3.) state indeces (ISTAT) 5256* 4.) projection flag (LPROJ) 5257* 5.) over-all cauchy order (ICAU) 5258* 6.) individual symmetries of the first operators (ISYMO) 5259* 7.) operator labels (LABEL) 5260* 8.) frequencies (FREQ) 5261* 9.) individual cauchy orders (ICAU) 5262* 10.) orbital relaxation (LORX) 5263* 5264* sets up symmetry offsets ISYOF 5265* 5266* print sorted lists to output 5267* 5268* number of operators (sym., labels, freqs, istat) used 5269* depends on TYPE (see subroutines CCLSTCMP and CCLSTSWAP). 5270* EIGVAL array is not used for comparison, but is sorted 5271* with the list. 5272* 5273* implemented: o1, 5274* O1, O2, O3, 5275* R1, R2, R3, 5276* X1, X2, X3, 5277* L1, L2, L3, 5278* CO2 5279* RC, CR2 5280* CX2 5281* LC, CL2 5282* M1 5283* N2 5284* ER1, ER2 5285* EL1, EL2 5286* PL1 5287* QL (Lanczos) 5288* 5289* not tested for RE, LE, E0 5290* 5291* 5292* Christof Haettig, October 1996 5293* generalized for open ended strategy may 1997 5294* projection flag 1998 5295* orbital relaxation flag 1999 5296* PL1 vectors, Sonia march 2000 5297* QL (Lanczos), Sonia 2010-2012 5298* 5299Cholesky 5300* Swapped sorting order so that LABEL sort is done 5301* after FREQ sort by modifying CCLSTCMP 5302* tbp 2003. Only tested for linear response! 5303Cholesky 5304* 5305*=====================================================================* 5306 IMPLICIT NONE 5307#include "priunit.h" 5308 LOGICAL LOCDBG 5309 PARAMETER (LOCDBG = .FALSE.) 5310 5311 INTEGER NVEC, MAXVEC, NSTAT, ORDER, JSYM, I 5312 LOGICAL LPROJ(MAXVEC), LORX(MAXVEC,*) 5313 CHARACTER*(8) LABEL(MAXVEC,*) 5314 INTEGER ISYMO(MAXVEC,*), ISTAT(MAXVEC,*), ISYOF(8) 5315 INTEGER ISYMS(MAXVEC,*), ICAU(MAXVEC,*) 5316 CHARACTER*(*) TYPE 5317 5318 REAL*8 FREQ(MAXVEC,*) 5319 REAL*8 EIGVAL(MAXVEC,*) 5320 5321 LOGICAL CHANGES 5322 INTEGER IVEC 5323 5324* external functions: 5325 LOGICAL CCLSTCMP 5326 INTEGER ILSTSYM 5327 5328* check TYPE and determine number of states involved and resp. order: 5329 IF ( TYPE(1:2).EQ.'R1' .OR. TYPE(1:2).EQ.'L1' 5330 & .OR. TYPE(1:3).EQ.'O1 '.OR. TYPE(1:3).EQ.'X1 ' 5331 & .OR. TYPE(1:2).EQ.'RC' .OR. TYPE(1:2).EQ.'LC' 5332 & .or. TYPE(1:2).EQ.'QL' 5333 & .OR. TYPE(1:2).EQ.'o1' ) THEN 5334 NSTAT = 0 5335 ORDER = 1 5336 ELSE IF ( TYPE(1:2).EQ.'R2' .OR. TYPE(1:2).EQ.'L2' 5337 & .OR. TYPE(1:2).EQ.'O2' .OR. TYPE(1:2).EQ.'X2' 5338 & .OR. TYPE(1:3).EQ.'CR2'.OR. TYPE(1:3).EQ.'CL2' 5339 & .OR. TYPE(1:3).EQ.'CO2'.OR. TYPE(1:3).EQ.'CX2' ) THEN 5340 NSTAT = 0 5341 ORDER = 2 5342 ELSE IF ( TYPE(1:2).EQ.'R3' .OR. TYPE(1:2).EQ.'L3' 5343 & .OR. TYPE(1:2).EQ.'O3' .OR. TYPE(1:2).EQ.'X3' ) THEN 5344 NSTAT = 0 5345 ORDER = 3 5346 ELSE IF ( TYPE(1:2).EQ.'R4' .OR. TYPE(1:2).EQ.'L4' 5347 & .OR. TYPE(1:2).EQ.'O4' .OR. TYPE(1:2).EQ.'X4' ) THEN 5348 NSTAT = 0 5349 ORDER = 4 5350 ELSE IF ( TYPE(1:2).EQ.'RE' .OR. TYPE(1:2).EQ.'LE' 5351 & .OR. TYPE(1:2).EQ.'E0' .OR. TYPE(1:2).EQ.'M1' ) THEN 5352 NSTAT = 1 5353 ORDER = 0 5354 ELSE IF ( TYPE(1:2).EQ.'N2' ) THEN 5355 NSTAT = 2 5356 ORDER = 0 5357 ELSE IF ( TYPE(1:3).EQ.'ER1'.OR. TYPE(1:3).EQ.'EL1') THEN 5358 NSTAT = 1 5359 ORDER = 1 5360 ELSE IF ( TYPE(1:3).EQ.'ER2'.OR. TYPE(1:3).EQ.'EL2') THEN 5361 NSTAT = 1 5362 ORDER = 2 5363 ELSE IF ( TYPE(1:3).EQ.'PL1') THEN 5364 NSTAT = 1 5365 ORDER = 1 5366 ELSE 5367 WRITE (LUPRI,*) 'unknown list ',TYPE,' in CCLSTSORT.' 5368 CALL QUIT('unknown list TYPE in CCLSTSORT.') 5369 END IF 5370 5371* bubble sort: 5372 CHANGES = .TRUE. 5373 5374 DO WHILE (CHANGES) 5375 CHANGES = .FALSE. 5376 5377 DO IVEC = 1, NVEC-1 5378 IF( CCLSTCMP(TYPE,NSTAT,ORDER,IVEC,ISYMS,ISTAT, 5379 & ISYMO,LABEL,FREQ,ICAU,LORX,MAXVEC,LPROJ) ) THEN 5380 5381 CALL CCLSTSWAP(TYPE,NSTAT,ORDER,IVEC, ISYMS,ISTAT,EIGVAL, 5382 & ISYMO,LABEL,FREQ,ICAU,LORX,MAXVEC,LPROJ) 5383 5384 CHANGES = .TRUE. 5385 5386 END IF 5387 END DO 5388 5389 IF (LOCDBG .AND. (TYPE(2:2).NE.'C'.AND.TYPE(1:1).NE.'C')) THEN 5390 DO IVEC = 1, NVEC 5391 WRITE(LUPRI,'(I5,I3,2(3X,A8,I3,2X,1P,D15.6))') 5392 & IVEC, ILSTSYM(TYPE,IVEC), 5393 & (ISYMS(IVEC,I),ISTAT(IVEC,I),EIGVAL(IVEC,I),I=1,NSTAT), 5394 & (LABEL(IVEC,I),ISYMO(IVEC,I),FREQ(IVEC,I),I=1,ORDER) 5395 END DO 5396 ELSE IF ( LOCDBG .AND. (TYPE(2:2).EQ.'C'.OR.TYPE(1:1).EQ.'C') 5397 & ) THEN 5398 WRITE(LUPRI,'(3A)') 'sorted ',TYPE,' list:' 5399 DO IVEC = 1, NVEC 5400 JSYM = ILSTSYM(TYPE,IVEC) 5401 WRITE(LUPRI,'(I5,I3,2(3X,A8,I3,2X,I3))') 5402 & IVEC, JSYM, 5403 & (LABEL(IVEC,I),ISYMO(IVEC,I),ICAU(IVEC,I),I=1,ORDER) 5404 END DO 5405 CALL FLSHFO(LUPRI) 5406 END IF 5407 5408 END DO 5409 5410 IVEC = 0 5411 DO JSYM = 1, 8 5412 ISYOF(JSYM) = IVEC 5413 IF (NVEC.GT.0) THEN 5414 DO WHILE(IVEC.LT.NVEC .AND. 5415 & ILSTSYM(TYPE,MIN(IVEC+1,NVEC)).EQ.JSYM) 5416 IVEC = IVEC + 1 5417 END DO 5418 END IF 5419 END DO 5420 5421 RETURN 5422 END 5423*=====================================================================* 5424* END OF SUBROUTINE CCLSTSORT * 5425*=====================================================================* 5426C /* Deck cclstcmp */ 5427*=====================================================================* 5428 LOGICAL FUNCTION CCLSTCMP(TYPE,NSTAT,ORDER,IVEC,ISYMS,ISTAT, 5429 & ISYMO,LABEL,FREQ,ICAU,LORX,MAXVEC,LPROJ) 5430*---------------------------------------------------------------------* 5431* PURPOSE: do comparison for CCLSTSORT according to: 5432* 5433* 1.) over-all symmetry 5434* 2.) individual symmetries of the states (ISYMS) 5435* 3.) state indeces (ISTAT) 5436* 4.) projection flag (LPROJ) 5437* 5.) over-all cauchy order 5438* 6.) individual symmetries of the first operators (ISYMO) 5439* 7.) operator labels (LABEL) 5440* 8.) frequencies (FREQ) 5441* 9.) individual cauchy orders (ICAU) 5442* 10.) orbital relaxation flags (LORX) 5443* 5444* cauchy orders only used for 5445* 'RC', 'LC', 'CRn', 'COn', 'CLn', 'CXn' 5446* 5447* orbital relaxation flags LORX only used for 5448* 'o1 ', 'O1 ', 'R1 ', 'X1 ', 'L1 ' ,'PL1 ', 'EL1 ' 5449* 5450* special treatments: 5451* 'o1 ' -- no frequency and no orbital relaxation 5452* 5453* 5454* Christof Haettig, October 1996, 5455* generalized for an open ended strategy in may 1997 5456* PL1 vectors, LORX in EL1 ... Sonia Coriani 2000 5457*=====================================================================* 5458 IMPLICIT NONE 5459#include "priunit.h" 5460Cholesky 5461#include "maxorb.h" 5462#include "ccdeco.h" 5463Cholesky 5464 LOGICAL LOCDBG 5465 PARAMETER (LOCDBG = .FALSE.) 5466 5467 INTEGER NSTAT, ORDER, MAXVEC,IVEC, I, IDX, NCAU, NCAU1, NSTAT1 5468 LOGICAL LPROJ(MAXVEC), LORX(MAXVEC,ORDER) 5469 CHARACTER*(8) LABEL(MAXVEC,ORDER) 5470 INTEGER ISYMS(MAXVEC,NSTAT), ISTAT(MAXVEC,NSTAT) 5471 INTEGER ISYMO(MAXVEC,ORDER), ICAU(MAXVEC,ORDER) 5472 CHARACTER*(*) TYPE 5473 5474 REAL*8 FREQ(MAXVEC,ORDER) 5475 5476* external function: 5477 INTEGER ILSTSYM 5478 5479*---------------------------------------------------------------------* 5480* compare over-all symmetry: 5481*---------------------------------------------------------------------* 5482 IF ( ILSTSYM(TYPE,IVEC) .GT. ILSTSYM(TYPE,IVEC+1) ) THEN 5483 IF (LOCDBG) WRITE (LUPRI,*) 'swap because of overall symmetry.' 5484 CCLSTCMP = .TRUE. 5485 RETURN 5486 ELSE IF ( ILSTSYM(TYPE,IVEC) .LT. ILSTSYM(TYPE,IVEC+1) ) THEN 5487 CCLSTCMP = .FALSE. 5488 RETURN 5489 END IF 5490 5491*---------------------------------------------------------------------* 5492* compare the symmetries of the individual states involved: 5493*---------------------------------------------------------------------* 5494* we have already sorted according to the over-all symmetry, so for 5495* zeroth-order vectors we can only sort after NSTAT-1 state symmetries 5496* 5497 NSTAT1 = NSTAT 5498 IF (ORDER.EQ.0) NSTAT1 = NSTAT - 1 5499 5500 DO IDX = 1, NSTAT1 5501 IF ( ISYMS(IVEC,IDX) .GT. ISYMS(IVEC+1,IDX) ) THEN 5502 IF (LOCDBG) WRITE (LUPRI,*) 5503 & 'swap because of state symmetries.' 5504 CCLSTCMP = .TRUE. 5505 RETURN 5506 ELSE IF ( ISYMS(IVEC,IDX) .LT. ISYMS(IVEC+1,IDX) ) THEN 5507 CCLSTCMP = .FALSE. 5508 RETURN 5509 END IF 5510 END DO 5511 5512*---------------------------------------------------------------------* 5513* compare the indices of the individual states involved: 5514*---------------------------------------------------------------------* 5515 DO IDX = 1, NSTAT 5516 IF ( ISTAT(IVEC,IDX) .GT. ISTAT(IVEC+1,IDX) ) THEN 5517 IF (LOCDBG) WRITE (LUPRI,*) 'swap because of state indices.' 5518 CCLSTCMP = .TRUE. 5519 RETURN 5520 ELSE IF ( ISTAT(IVEC,IDX) .LT. ISTAT(IVEC+1,IDX) ) THEN 5521 CCLSTCMP = .FALSE. 5522 RETURN 5523 END IF 5524 END DO 5525 5526*---------------------------------------------------------------------* 5527* for excited state response vectors or projected response multipliers 5528* compare projection flag: 5529*---------------------------------------------------------------------* 5530 IF (TYPE(1:2).EQ.'ER' .OR. TYPE(1:2).EQ.'EL' 5531 & .OR. TYPE(1:3).EQ.'PL1') THEN 5532 IF ( (.NOT.LPROJ(IVEC)) .AND. LPROJ(IVEC+1) ) THEN 5533 IF (LOCDBG) WRITE (LUPRI,*) 'swap because of projection flag.' 5534 CCLSTCMP = .TRUE. 5535 RETURN 5536 ELSE IF ( LPROJ(IVEC) .AND. (.NOT.LPROJ(IVEC+1)) ) THEN 5537 CCLSTCMP = .FALSE. 5538 RETURN 5539 END IF 5540 END IF 5541*---------------------------------------------------------------------* 5542* for cauchy vectors compare over-all cauchy order: 5543*---------------------------------------------------------------------* 5544 IF (TYPE(1:2).EQ.'RC' .OR. TYPE(1:2).EQ.'LC' .OR. 5545 & TYPE(1:2).EQ.'CR' .OR. TYPE(1:2).EQ.'CL' .OR. 5546 & TYPE(1:2).EQ.'CO' .OR. TYPE(1:2).EQ.'CX' ) THEN 5547 5548 NCAU = 0 5549 NCAU1 = 0 5550 DO IDX = 1, ORDER 5551 NCAU = NCAU + ICAU(IVEC,IDX) 5552 NCAU1 = NCAU1 + ICAU(IVEC+1,IDX) 5553 END DO 5554 5555 IF ( NCAU .GT. NCAU1 ) THEN 5556 IF (LOCDBG) WRITE (LUPRI,*) 5557 & 'swap because of overall cauchy order.' 5558 CCLSTCMP = .TRUE. 5559 RETURN 5560 ELSE IF ( NCAU .LT. NCAU1 ) THEN 5561 CCLSTCMP = .FALSE. 5562 RETURN 5563 END IF 5564 5565 END IF 5566 5567*---------------------------------------------------------------------* 5568* compare the symmetries of the ORDER-1 first operators 5569*---------------------------------------------------------------------* 5570 DO IDX = 1, ORDER-1 5571 IF ( ISYMO(IVEC,IDX) .GT. ISYMO(IVEC+1,IDX) ) THEN 5572 IF (LOCDBG) WRITE (LUPRI,*) 5573 & 'swap because of operator symmetries.' 5574 CCLSTCMP = .TRUE. 5575 RETURN 5576 ELSE IF ( ISYMO(IVEC,IDX) .LT. ISYMO(IVEC+1,IDX) ) THEN 5577 CCLSTCMP = .FALSE. 5578 RETURN 5579 END IF 5580 END DO 5581 5582* If Cholesky, sort before after frequencies 5583 5584 IF (.NOT. CHOINT) THEN 5585 5586*---------------------------------------------------------------------* 5587* compare the labels 5588*---------------------------------------------------------------------* 5589 DO IDX = 1, ORDER 5590 DO I = 1, 8 5591 IF ( LGT(LABEL(IVEC,IDX)(I:I),LABEL(IVEC+1,IDX)(I:I)) ) THEN 5592 IF (LOCDBG) WRITE (LUPRI,*) 5593 & 'swap because of operator labels.' 5594 CCLSTCMP = .TRUE. 5595 RETURN 5596 END IF 5597 IF ( LLT(LABEL(IVEC,IDX)(I:I),LABEL(IVEC+1,IDX)(I:I)) ) THEN 5598 CCLSTCMP = .FALSE. 5599 RETURN 5600 END IF 5601 END DO 5602 END DO 5603 5604 END IF ! Cholesky 5605 5606*---------------------------------------------------------------------* 5607* compare the frequencies 5608*---------------------------------------------------------------------* 5609 IF ( TYPE(1:2).NE.'RC' .AND. TYPE(1:2).NE.'LC' .AND. 5610 & TYPE(1:2).NE.'CR' .AND. TYPE(1:2).NE.'CL' .AND. 5611 & TYPE(1:2).NE.'CO' .AND. TYPE(1:2).NE.'CX' .AND. 5612 & TYPE(1:2).NE.'o1' ) THEN 5613 5614 DO IDX = 1, ORDER 5615 IF ( FREQ(IVEC,IDX) .GT. FREQ(IVEC+1,IDX) ) THEN 5616 IF (LOCDBG) WRITE (LUPRI,*) 'swap because of frequencies.' 5617 CCLSTCMP = .TRUE. 5618 RETURN 5619 ELSE IF ( FREQ(IVEC,IDX) .LT. FREQ(IVEC+1,IDX) ) THEN 5620 CCLSTCMP = .FALSE. 5621 RETURN 5622 END IF 5623 END DO 5624 5625 END IF 5626 5627* If Cholesky, sort now after frequencies 5628 5629 IF (CHOINT) THEN 5630 5631*---------------------------------------------------------------------* 5632* compare the labels 5633*---------------------------------------------------------------------* 5634 DO IDX = 1, ORDER 5635 DO I = 1, 8 5636 IF ( LGT(LABEL(IVEC,IDX)(I:I),LABEL(IVEC+1,IDX)(I:I)) ) THEN 5637 IF (LOCDBG) WRITE (LUPRI,*) 5638 & 'swap because of operator labels.' 5639 CCLSTCMP = .TRUE. 5640 RETURN 5641 END IF 5642 IF ( LLT(LABEL(IVEC,IDX)(I:I),LABEL(IVEC+1,IDX)(I:I)) ) THEN 5643 CCLSTCMP = .FALSE. 5644 RETURN 5645 END IF 5646 END DO 5647 END DO 5648 5649 END IF ! Cholesky 5650 5651*---------------------------------------------------------------------* 5652* compare the cauchy orders: 5653*---------------------------------------------------------------------* 5654 IF (TYPE(1:2).EQ.'RC' .OR. TYPE(1:2).EQ.'LC' .OR. 5655 & TYPE(1:2).EQ.'CR' .OR. TYPE(1:2).EQ.'CL' .OR. 5656 & TYPE(1:2).EQ.'CO' .OR. TYPE(1:2).EQ.'CX' ) THEN 5657 5658 DO IDX = 1, ORDER 5659 IF ( ICAU(IVEC,IDX) .GT. ICAU(IVEC+1,IDX) ) THEN 5660 IF (LOCDBG) WRITE (LUPRI,*) 'swap because of cauchy orders.' 5661 CCLSTCMP = .TRUE. 5662 RETURN 5663 ELSE IF ( ICAU(IVEC,IDX) .LT. ICAU(IVEC+1,IDX) ) THEN 5664 CCLSTCMP = .FALSE. 5665 RETURN 5666 END IF 5667 END DO 5668 5669 END IF 5670 5671*---------------------------------------------------------------------* 5672* compare orbital relaxation flags: 5673*---------------------------------------------------------------------* 5674 IF (TYPE(1:3).EQ.'O1 '.OR. TYPE(1:2).EQ.'R1' .OR. 5675 & TYPE(1:3).EQ.'X1 '.OR. TYPE(1:2).EQ.'L1' .OR. 5676 & TYPE(1:3).EQ.'PL1'.OR. TYPE(1:3).EQ.'EL1' ) THEN 5677 5678 DO IDX = 1, ORDER 5679 IF ( (.NOT.LORX(IVEC,IDX)) .AND. LORX(IVEC+1,IDX) ) THEN 5680 IF (LOCDBG) WRITE (LUPRI,*) 5681 & 'swap because of orb. relax. flag.' 5682 CCLSTCMP = .TRUE. 5683 RETURN 5684 ELSE IF (LORX(IVEC,IDX) .AND. (.NOT.LORX(IVEC+1,IDX))) THEN 5685 CCLSTCMP = .FALSE. 5686 RETURN 5687 END IF 5688 END DO 5689 5690 END IF 5691 5692*---------------------------------------------------------------------* 5693* both entries are the same??? 5694*---------------------------------------------------------------------* 5695 WRITE (LUPRI,'(1X,4A)') 'WARNING FROM CCLSTCMP: ', 5696 & 'The ',TYPE(1:2),' list contains a redundant entry.' 5697 WRITE (LUPRI,'(1X,A,I2,A,I2,A)') 'Entries ',IVEC,' AND ',IVEC+1, 5698 & ' are the same.' 5699 5700 CCLSTCMP = .FALSE. 5701 5702 RETURN 5703 END 5704*=====================================================================* 5705* END OF SUBROUTINE CCLSTCMP * 5706*=====================================================================* 5707C /* Deck cclstswap */ 5708*=====================================================================* 5709 SUBROUTINE CCLSTSWAP(TYPE,NSTAT,ORDER,IVEC, ISYMS,ISTAT,EIGVAL, 5710 & ISYMO,LABEL,FREQ,ICAU,LORX,MXVEC,LPROJ) 5711*---------------------------------------------------------------------* 5712* 5713* PURPOSE: swap two list elements for CCLSTSORT: 5714* 5715* swaps in general ORDER operators symmetries, labels and 5716* frequencies or cauchy orders, and NSTAT state symmetries, 5717* state indeces and eigenvalues 5718* 5719* cauchy orders only used for 5720* 'RC', 'LC', 'CRn', 'COn', 'CLn', 'CXn' 5721* 5722* orbital relaxation flags LORX only used for 5723* 'o1 ', 'O1 ', 'R1 ', 'X1 ', 'L1 ', 'PL1 ', 'EL1 ' 5724* 5725* for 'ELn' and 'ERn' and 'PL1' also the projection 5726* flag is swapped 5727* 5728* special treatment: 5729* o1 -- no frequency and no orbital relaxation, but 5730* we swap in addition: ISYMAT, IATOPR, LPDBSOP 5731* 5732* 5733* Christof Haettig, October 1996 5734* generalized for an open ended strategy in may 1997 5735* Sonia Coriani: PL1 and LORX for EL1 5736*=====================================================================* 5737 IMPLICIT NONE 5738#include "priunit.h" 5739#include "ccroper.h" 5740 5741 LOGICAL LOCDBG 5742 PARAMETER (LOCDBG = .FALSE.) 5743 5744 INTEGER IVEC, MXVEC, ORDER, IDX, NSTAT, ISWAP 5745 LOGICAL LPROJ(MXVEC), LORX(MXVEC,ORDER), LSWAP 5746 CHARACTER*(8) LABEL(MXVEC,ORDER), LBLSWAP 5747 INTEGER ISYMO(MXVEC,ORDER) 5748 INTEGER ICAU(MXVEC,ORDER) 5749 INTEGER ISYMS(MXVEC,NSTAT) 5750 INTEGER ISTAT(MXVEC,NSTAT) 5751 CHARACTER*(*) TYPE 5752 5753 REAL*8 FREQ(MXVEC,ORDER), EIGVAL(MXVEC,NSTAT), RSWAP 5754 5755*---------------------------------------------------------------------* 5756* swap symmetries: 5757*---------------------------------------------------------------------* 5758 DO IDX = 1, ORDER 5759 ISWAP = ISYMO(IVEC,IDX) 5760 ISYMO(IVEC,IDX) = ISYMO(IVEC+1,IDX) 5761 ISYMO(IVEC+1,IDX) = ISWAP 5762 END DO 5763 5764 DO IDX = 1, NSTAT 5765 ISWAP = ISYMS(IVEC,IDX) 5766 ISYMS(IVEC,IDX) = ISYMS(IVEC+1,IDX) 5767 ISYMS(IVEC+1,IDX) = ISWAP 5768 END DO 5769 5770*---------------------------------------------------------------------* 5771* swap state indices and eigenvalues: 5772*---------------------------------------------------------------------* 5773 DO IDX = 1, NSTAT 5774 ISWAP = ISTAT(IVEC,IDX) 5775 ISTAT(IVEC,IDX) = ISTAT(IVEC+1,IDX) 5776 ISTAT(IVEC+1,IDX) = ISWAP 5777 END DO 5778 5779 DO IDX = 1, NSTAT 5780 RSWAP = EIGVAL(IVEC,IDX) 5781 EIGVAL(IVEC,IDX) = EIGVAL(IVEC+1,IDX) 5782 EIGVAL(IVEC+1,IDX) = RSWAP 5783 END DO 5784 5785*---------------------------------------------------------------------* 5786* swap projection flag: 5787*---------------------------------------------------------------------* 5788 IF (TYPE(1:2).EQ.'ER' .OR. TYPE(1:2).EQ.'EL' 5789 & .OR. TYPE(1:3).EQ.'PL1') THEN 5790 LSWAP = LPROJ(IVEC) 5791 LPROJ(IVEC) = LPROJ(IVEC+1) 5792 LPROJ(IVEC+1) = LSWAP 5793 END IF 5794 5795*---------------------------------------------------------------------* 5796* swap labels: 5797*---------------------------------------------------------------------* 5798 DO IDX = 1, ORDER 5799 LBLSWAP = LABEL(IVEC,IDX) 5800 LABEL(IVEC,IDX) = LABEL(IVEC+1,IDX) 5801 LABEL(IVEC+1,IDX) = LBLSWAP 5802 END DO 5803 5804*---------------------------------------------------------------------* 5805* swap frequencies: 5806*---------------------------------------------------------------------* 5807 IF ( TYPE(1:2).NE.'RC' .AND. TYPE(1:2).NE.'LC' .AND. 5808 & TYPE(1:2).NE.'CR' .AND. TYPE(1:2).NE.'CO' .AND. 5809 & TYPE(1:2).NE.'CL' .AND. TYPE(1:2).NE.'CX' .AND. 5810 & TYPE(1:2).NE.'o1' ) THEN 5811 DO IDX = 1, ORDER 5812 RSWAP = FREQ(IVEC,IDX) 5813 FREQ(IVEC,IDX) = FREQ(IVEC+1,IDX) 5814 FREQ(IVEC+1,IDX) = RSWAP 5815 END DO 5816 END IF 5817 5818*---------------------------------------------------------------------* 5819* swap cauchy orders: 5820*---------------------------------------------------------------------* 5821 IF (TYPE(1:2).EQ.'RC' .OR. TYPE(1:2).EQ.'LC' .OR. 5822 & TYPE(1:2).EQ.'CR' .OR. TYPE(1:2).EQ.'CL' .OR. 5823 & TYPE(1:2).EQ.'CO' .OR. TYPE(1:2).EQ.'CX' ) THEN 5824 DO IDX = 1, ORDER 5825 ISWAP = ICAU(IVEC,IDX) 5826 ICAU(IVEC,IDX) = ICAU(IVEC+1,IDX) 5827 ICAU(IVEC+1,IDX) = ISWAP 5828 END DO 5829 END IF 5830 5831*---------------------------------------------------------------------* 5832* swap orbital relaxation flags: 5833*---------------------------------------------------------------------* 5834 IF (TYPE(1:3).EQ.'O1 '.OR. TYPE(1:2).EQ.'R1' .OR. 5835 & TYPE(1:3).EQ.'X1 '.OR. TYPE(1:2).EQ.'L1' .OR. 5836 & TYPE(1:3).EQ.'PL1'.OR. TYPE(1:3).EQ.'EL1' ) THEN 5837 DO IDX = 1, ORDER 5838 LSWAP = LORX(IVEC,IDX) 5839 LORX(IVEC,IDX) = LORX(IVEC+1,IDX) 5840 LORX(IVEC+1,IDX) = LSWAP 5841 END DO 5842 END IF 5843 5844*---------------------------------------------------------------------* 5845* for 'o1' list swap in addition: ISYMAT, IATOPR, LPDBSOP 5846*---------------------------------------------------------------------* 5847 IF (TYPE(1:2).EQ.'o1') THEN 5848 ISWAP = ISYMAT(IVEC) 5849 ISYMAT(IVEC) = ISYMAT(IVEC+1) 5850 ISYMAT(IVEC+1) = ISWAP 5851 5852 ISWAP = IATOPR(IVEC) 5853 IATOPR(IVEC) = IATOPR(IVEC+1) 5854 IATOPR(IVEC+1) = ISWAP 5855 5856 LSWAP = LPDBSOP(IVEC) 5857 LPDBSOP(IVEC) = LPDBSOP(IVEC+1) 5858 LPDBSOP(IVEC+1) = LSWAP 5859 END IF 5860 5861*---------------------------------------------------------------------* 5862* return: 5863*---------------------------------------------------------------------* 5864 RETURN 5865 5866 END 5867*=====================================================================* 5868* END OF SUBROUTINE CCLSTSWAP * 5869*=====================================================================* 5870*=====================================================================* 5871C /* Deck ilstsym */ 5872*=====================================================================* 5873 INTEGER FUNCTION ILSTSYM(LIST_in, INDEX) 5874*---------------------------------------------------------------------* 5875* PURPOSE: get symmetry for vector on list 5876* 5877* LIST : list type 5878* INDEX: index of the vector on the list 5879* 5880* Christof Haettig, November 1996 5881* PL1 introduced Sonia 5882* QL (Lanczos) introduced Sonia 2010 5883*=====================================================================* 5884 IMPLICIT NONE 5885#include "priunit.h" 5886#include "ccorb.h" 5887#include "ccroper.h" 5888#include "cclrmrsp.h" 5889#include "ccer1rsp.h" 5890#include "ccer2rsp.h" 5891#include "ccel1rsp.h" 5892#include "ccel2rsp.h" 5893#include "ccr1rsp.h" 5894#include "ccr2rsp.h" 5895#include "ccr3rsp.h" 5896#include "ccr4rsp.h" 5897#include "ccx1rsp.h" 5898#include "ccx2rsp.h" 5899#include "ccx3rsp.h" 5900#include "ccx4rsp.h" 5901#include "cco1rsp.h" 5902#include "cco2rsp.h" 5903#include "cco3rsp.h" 5904#include "cco4rsp.h" 5905#include "ccl1rsp.h" 5906#include "ccl2rsp.h" 5907#include "ccl3rsp.h" 5908#include "ccl4rsp.h" 5909#include "ccn2rsp.h" 5910#include "ccrc1rsp.h" 5911#include "cclc1rsp.h" 5912#include "cccr2rsp.h" 5913#include "ccco2rsp.h" 5914#include "cccx2rsp.h" 5915#include "cccl2rsp.h" 5916#include "ccexci.h" 5917#include "ccpl1rsp.h" 5918!Lanczos 5919#include "ccqlrlcz.h" 5920 5921 CHARACTER*(*) LIST_In 5922 INTEGER INDEX 5923 CHARACTER*(3) LIST 5924 LOGICAL LEOOR 5925 5926 LEOOR = .FALSE. 5927 5928! Make sure LIST is defined for 3 characters; 5929! in some calls of ILSTSYM the LIST_in is only 2 characters. /hjaaj-May-2018 5930 LIST = LIST_in 5931 5932* begin: 5933 IF (LIST(1:2).EQ.'o1') THEN 5934 IF (INDEX.LE.0 .OR. INDEX.GT.NRSOLBL) LEOOR = .TRUE. 5935 ILSTSYM = ISYOPR(INDEX) 5936 ELSE IF (LIST(1:3).EQ.'O1 '.OR.LIST(1:3).EQ.'O1e') THEN 5937 IF (INDEX.LE.0 .OR. INDEX.GT.NO1LBL) LEOOR = .TRUE. 5938 ILSTSYM = ISYO1(INDEX) 5939 ELSE IF (LIST(1:2).EQ.'O2' ) THEN 5940 IF (INDEX.LE.0 .OR. INDEX.GT.NO2LBL) LEOOR = .TRUE. 5941 ILSTSYM = MULD2H(ISYAO2(INDEX),ISYBO2(INDEX)) 5942 ELSE IF (LIST(1:2).EQ.'O3' ) THEN 5943 IF (INDEX.LE.0 .OR. INDEX.GT.NO3LBL) LEOOR = .TRUE. 5944 ILSTSYM = MULD2H(ISYO3(INDEX,1),ISYO3(INDEX,2)) 5945 ILSTSYM = MULD2H(ILSTSYM,ISYO3(INDEX,3)) 5946 ELSE IF (LIST(1:2).EQ.'O4' ) THEN 5947 IF (INDEX.LE.0 .OR. INDEX.GT.NO4LBL) LEOOR = .TRUE. 5948 ILSTSYM = MULD2H(ISYO4(INDEX,1),ISYO4(INDEX,2)) 5949 ILSTSYM = MULD2H(ILSTSYM,ISYO4(INDEX,3)) 5950 ILSTSYM = MULD2H(ILSTSYM,ISYO4(INDEX,4)) 5951 ELSE IF (LIST(1:3).EQ.'CO2') THEN 5952 IF (INDEX.LE.0 .OR. INDEX.GT.NCO2LBL) LEOOR = .TRUE. 5953 ILSTSYM = MULD2H(ISYCO2(INDEX,1),ISYCO2(INDEX,2)) 5954 ELSE IF (LIST(1:3).EQ.'X1 '.OR.LIST(1:3).EQ.'X1e') THEN 5955 IF (INDEX.LE.0 .OR. INDEX.GT.NX1LBL) LEOOR = .TRUE. 5956 ILSTSYM = ISYX1(INDEX) 5957 ELSE IF (LIST(1:2).EQ.'X2' ) THEN 5958 IF (INDEX.LE.0 .OR. INDEX.GT.NX2LBL) LEOOR = .TRUE. 5959 ILSTSYM = MULD2H(ISYAX2(INDEX),ISYBX2(INDEX)) 5960 ELSE IF (LIST(1:2).EQ.'X3' ) THEN 5961 IF (INDEX.LE.0 .OR. INDEX.GT.NX3LBL) LEOOR = .TRUE. 5962 ILSTSYM = MULD2H(ISYX3(INDEX,1),ISYX3(INDEX,2)) 5963 ILSTSYM = MULD2H(ILSTSYM,ISYX3(INDEX,3)) 5964 ELSE IF (LIST(1:2).EQ.'X4' ) THEN 5965 IF (INDEX.LE.0 .OR. INDEX.GT.NX4LBL) LEOOR = .TRUE. 5966 ILSTSYM = MULD2H(ISYX4(INDEX,1),ISYX4(INDEX,2)) 5967 ILSTSYM = MULD2H(ILSTSYM,ISYX4(INDEX,3)) 5968 ILSTSYM = MULD2H(ILSTSYM,ISYX4(INDEX,4)) 5969 ELSE IF (LIST(1:3).EQ.'CX2') THEN 5970 IF (INDEX.LE.0 .OR. INDEX.GT.NCX2LBL) LEOOR = .TRUE. 5971 ILSTSYM = MULD2H(ISYCX2(INDEX,1),ISYCX2(INDEX,2)) 5972C 5973Cholesky 5974C 5975 ELSE IF (LIST(1:3).EQ.'d00') THEN 5976 ILSTSYM = 1 5977C 5978Cholesky 5979C 5980 ELSE IF (LIST(1:2).EQ.'L0' .OR. LIST(1:2).EQ.'R0') THEN 5981 ILSTSYM = 1 5982 ELSE IF (LIST(1:2).EQ.'D0') THEN 5983 ILSTSYM = 1 5984 ELSE IF (LIST(1:2).EQ.'E0' .OR. LIST(1:2).EQ.'BE') THEN 5985 ILSTSYM = 1 5986 ELSE IF (LIST(1:2).EQ.'LE' .OR. LIST(1:2).EQ.'RE') THEN 5987 ILSTSYM = ISYEXC(INDEX) 5988 ELSE IF (LIST(1:3).EQ.'ER1'.OR.LIST(1:3).EQ.'EO1') THEN 5989 IF (INDEX.LE.0 .OR. INDEX.GT.NER1LBL) LEOOR = .TRUE. 5990 ILSTSYM = MULD2H(ISYSER1(INDEX),ISYOER1(INDEX)) 5991 ELSE IF (LIST(1:3).EQ.'ER2'.OR.LIST(1:3).EQ.'EO2') THEN 5992 IF (INDEX.LE.0 .OR. INDEX.GT.NER2LBL) LEOOR = .TRUE. 5993 ILSTSYM = MULD2H(ISYSER2(INDEX),ISYOER2(INDEX,1)) 5994 ILSTSYM = MULD2H(ILSTSYM,ISYOER2(INDEX,2)) 5995 ELSE IF (LIST(1:3).EQ.'EL1'.OR.LIST(1:3).EQ.'EX1') THEN 5996 IF (INDEX.LE.0 .OR. INDEX.GT.NEL1LBL) LEOOR = .TRUE. 5997 ILSTSYM = MULD2H(ISYSEL1(INDEX),ISYOEL1(INDEX)) 5998 ELSE IF (LIST(1:3).EQ.'EL2'.OR.LIST(1:3).EQ.'EX2') THEN 5999 IF (INDEX.LE.0 .OR. INDEX.GT.NEL2LBL) LEOOR = .TRUE. 6000 ILSTSYM = MULD2H(ISYSEL2(INDEX),ISYOEL2(INDEX,1)) 6001 ILSTSYM = MULD2H(ILSTSYM,ISYOEL2(INDEX,2)) 6002 ELSE IF (LIST(1:2).EQ.'L1'.OR.LIST(1:3).EQ.'X1B') THEN 6003 IF (INDEX.LE.0 .OR. INDEX.GT.NLRZLBL) LEOOR = .TRUE. 6004 ILSTSYM = ISYLRZ(INDEX) 6005 ELSE IF (LIST(1:2).EQ.'M1'.OR.LIST(1:2).EQ.'FR') THEN 6006 IF (INDEX.LE.0 .OR. INDEX.GT.NLRM ) LEOOR = .TRUE. 6007 ILSTSYM = ISYLRM(INDEX) 6008Cholesky 6009Chol ELSE IF (LIST(1:2).EQ.'R1' .OR. LIST(1:2).EQ.'F1') THEN 6010 ELSE IF (LIST(1:2).EQ.'R1' .OR. LIST(1:2).EQ.'F1' .OR. 6011 & LIST(1:3).EQ.'XF1' .OR. LIST(1:3).EQ.'d01' .OR. 6012 & LIST(1:3).EQ.'eO1') THEN 6013Cholesky 6014 IF (INDEX.LE.0 .OR. INDEX.GT.NLRTLBL) LEOOR = .TRUE. 6015 ILSTSYM = ISYLRT(INDEX) 6016 ELSE IF ((LIST(1:2).EQ.'RC').OR.(LIST(1:2).EQ.'FC')) THEN 6017 IF (INDEX.LE.0 .OR. INDEX.GT.NLRCLBL) LEOOR = .TRUE. 6018 ILSTSYM = ISYLRC(INDEX) 6019 ELSE IF ((LIST(1:2).EQ.'LC').OR.(LIST(1:2).EQ.'XC')) THEN 6020 IF (INDEX.LE.0 .OR. INDEX.GT.NLC1LBL) LEOOR = .TRUE. 6021 ILSTSYM = ISYLC1(INDEX) 6022 ELSE IF (LIST(1:3).EQ.'CR2'.OR.LIST(1:3).EQ.'CF2') THEN 6023 IF (INDEX.LE.0 .OR. INDEX.GT.NCR2LBL) LEOOR = .TRUE. 6024 ILSTSYM = MULD2H(ISYCR2(INDEX,1),ISYCR2(INDEX,2)) 6025 ELSE IF (LIST(1:2).EQ.'R2' .OR. LIST(1:2).EQ.'F2') THEN 6026 IF (INDEX.LE.0 .OR. INDEX.GT.NR2TLBL) LEOOR = .TRUE. 6027 ILSTSYM = MULD2H(ISYAR2T(INDEX),ISYBR2T(INDEX)) 6028 ELSE IF (LIST(1:2).EQ.'R3' .OR. LIST(1:2).EQ.'F3') THEN 6029 IF (INDEX.LE.0 .OR. INDEX.GT.NR3TLBL) LEOOR = .TRUE. 6030 ILSTSYM = MULD2H(ISYR3T(INDEX,1),ISYR3T(INDEX,2)) 6031 ILSTSYM = MULD2H(ILSTSYM,ISYR3T(INDEX,3)) 6032 ELSE IF (LIST(1:2).EQ.'R4' .OR. LIST(1:2).EQ.'F4') THEN 6033 IF (INDEX.LE.0 .OR. INDEX.GT.NR4TLBL) LEOOR = .TRUE. 6034 ILSTSYM = MULD2H(ISYR4T(INDEX,1),ISYR4T(INDEX,2)) 6035 ILSTSYM = MULD2H(ILSTSYM,ISYR4T(INDEX,3)) 6036 ILSTSYM = MULD2H(ILSTSYM,ISYR4T(INDEX,4)) 6037 ELSE IF (LIST(1:2).EQ.'L2') THEN 6038 IF (INDEX.LE.0 .OR. INDEX.GT.NL2LBL) LEOOR = .TRUE. 6039 ILSTSYM = MULD2H(ISYAL2(INDEX),ISYBL2(INDEX)) 6040 ELSE IF (LIST(1:2).EQ.'L3') THEN 6041 IF (INDEX.LE.0 .OR. INDEX.GT.NL3LBL) LEOOR = .TRUE. 6042 ILSTSYM = MULD2H(ISYL3(INDEX,1),ISYL3(INDEX,2)) 6043 ILSTSYM = MULD2H(ILSTSYM,ISYL3(INDEX,3)) 6044 ELSE IF (LIST(1:2).EQ.'L4') THEN 6045 IF (INDEX.LE.0 .OR. INDEX.GT.NL4LBL) LEOOR = .TRUE. 6046 ILSTSYM = MULD2H(ISYL4(INDEX,1),ISYL4(INDEX,2)) 6047 ILSTSYM = MULD2H(ILSTSYM,ISYL4(INDEX,3)) 6048 ILSTSYM = MULD2H(ILSTSYM,ISYL4(INDEX,4)) 6049 ELSE IF (LIST(1:3).EQ.'CL2') THEN 6050 IF (INDEX.LE.0 .OR. INDEX.GT.NCL2LBL) LEOOR = .TRUE. 6051 ILSTSYM = MULD2H(ISYCL2(INDEX,1),ISYCL2(INDEX,2)) 6052 ELSE IF (LIST(1:2).EQ.'N2' .OR. LIST(1:2).EQ.'BR') THEN 6053 IF (INDEX.LE.0 .OR. INDEX.GT.NQRN2 ) LEOOR = .TRUE. 6054 ILSTSYM = MULD2H(ISYIN2(INDEX),ISYFN2(INDEX)) 6055 ELSE IF (LIST(1:3).EQ.'PL1') THEN 6056 IF (INDEX.LE.0 .OR. INDEX.GT.NPL1LBL) LEOOR = .TRUE. 6057 ILSTSYM = ISYPL1(INDEX) 6058!Lanczos (Sonia): QL and FQL vectors 6059 ELSE IF (LIST(1:2).EQ.'QL'.OR. LIST(1:2).EQ.'FQ') THEN 6060 IF (INDEX.LE.0 .OR. INDEX.GT.NQLLBL) LEOOR = .TRUE. 6061 ILSTSYM = ISYQL(INDEX) 6062 ELSE 6063 WRITE(LUPRI,*) 'Unknown LIST in ILSTSYM:"',LIST(1:3),'"' 6064C to force a core dump: 6065C WRITE (LUPRI,*) LIST(999999:999999) 6066 CALL QUIT('Unknown LIST in ILSTSYM.') 6067 END IF 6068 6069 IF (LEOOR) THEN 6070 WRITE (LUPRI,*) 'INDEX out of range in ILSTSYM:' 6071 WRITE (LUPRI,*) 'LIST,INDEX:',LIST(1:3),INDEX 6072C to force a core dump: 6073C WRITE (LUPRI,*) LIST(-999999:-999999) 6074 CALL QUIT('INDEX out of range in ILSTSYM.') 6075 END IF 6076 6077 IF (ILSTSYM.LT.1 .OR. ILSTSYM.GT.NSYM) THEN 6078 NWARN = NWARN + 1 6079 WRITE (LUPRI,*) 'WARNING from ILSTSYM: symmetry out of range:' 6080 WRITE (LUPRI,*) 'LIST,INDEX,ILSTSYM:',LIST(1:3),INDEX,ILSTSYM 6081 END IF 6082 6083 RETURN 6084 END 6085*=====================================================================* 6086*=====================================================================* 6087C /* Deck ilstsymrlx */ 6088*=====================================================================* 6089 INTEGER FUNCTION ILSTSYMRLX(LIST,INDEX) 6090*---------------------------------------------------------------------* 6091* PURPOSE: get symmetry for orbital relaxation vector on list 6092* 6093* LIST : list type 6094* INDEX: index of the vector on the list 6095* 6096* Christof Haettig, November 1996 6097* PL1 introduced Sonia 6098*=====================================================================* 6099 IMPLICIT NONE 6100#include "priunit.h" 6101#include "ccorb.h" 6102#include "ccr1rsp.h" 6103 6104 CHARACTER*(3) LIST 6105 INTEGER INDEX 6106 LOGICAL LEOOR 6107 6108 LEOOR = .FALSE. 6109 6110* begin: 6111 IF (LIST(1:2).EQ.'o1') THEN 6112 CALL QUIT('Illegal list in ILSTSYMRLX.') 6113 ELSE IF (LIST(1:2).EQ.'R1') THEN 6114 IF (INDEX.LE.0 .OR. INDEX.GT.NLRTHFLBL) LEOOR = .TRUE. 6115 ILSTSYMRLX = ISYLRTHF(INDEX) 6116 ELSE 6117 WRITE(LUPRI,*) 'Unknown LIST in ILSTSYM:"',LIST(1:3),'"' 6118C to force a core dump: 6119C WRITE (LUPRI,*) LIST(999999:999999) 6120 CALL QUIT('Unknown LIST in ILSTSYM.') 6121 END IF 6122 6123 IF (LEOOR) THEN 6124 WRITE (LUPRI,*) 'INDEX out of range in ILSTSYMRLX:' 6125 WRITE (LUPRI,*) 'LIST,INDEX:',LIST(1:3),INDEX 6126C to force a core dump: 6127C WRITE (LUPRI,*) LIST(-999999:-999999) 6128 CALL QUIT('INDEX out of range in ILSTSYMRLX.') 6129 END IF 6130 6131 IF (ILSTSYMRLX.LT.1 .OR. ILSTSYMRLX.GT.NSYM) THEN 6132 NWARN = NWARN + 1 6133 WRITE (LUPRI,*) 6134 & 'WARNING from ILSTSYMRLX: symmetry out of range:' 6135 WRITE (LUPRI,*) 'LIST,INDEX,ILSTSYMRLX:', 6136 & LIST(1:3),INDEX,ILSTSYMRLX 6137 END IF 6138 6139 RETURN 6140 END 6141*=====================================================================* 6142*=====================================================================* 6143C /* Deck freqlst */ 6144*=====================================================================* 6145 REAL*8 FUNCTION FREQLST(LIST, INDEX) 6146*---------------------------------------------------------------------* 6147* PURPOSE: return frequency for vector on list 6148* 6149* LIST : list type 6150* INDEX: index of the vector on the list 6151* 6152* Christof Haettig, April 2002 6153*---------------------------------------------------------------------* 6154 IMPLICIT NONE 6155#include "priunit.h" 6156#include "ccorb.h" 6157#include "ccroper.h" 6158#include "cclrmrsp.h" 6159#include "ccer1rsp.h" 6160#include "ccer2rsp.h" 6161#include "ccel1rsp.h" 6162#include "ccel2rsp.h" 6163#include "ccr1rsp.h" 6164#include "ccr2rsp.h" 6165#include "ccr3rsp.h" 6166#include "ccr4rsp.h" 6167#include "ccx1rsp.h" 6168#include "ccx2rsp.h" 6169#include "ccx3rsp.h" 6170#include "ccx4rsp.h" 6171#include "cco1rsp.h" 6172#include "cco2rsp.h" 6173#include "cco3rsp.h" 6174#include "cco4rsp.h" 6175#include "ccl1rsp.h" 6176#include "ccl2rsp.h" 6177#include "ccl3rsp.h" 6178#include "ccl4rsp.h" 6179#include "ccn2rsp.h" 6180#include "ccrc1rsp.h" 6181#include "cclc1rsp.h" 6182#include "cccr2rsp.h" 6183#include "ccco2rsp.h" 6184#include "cccx2rsp.h" 6185#include "cccl2rsp.h" 6186#include "ccexci.h" 6187#include "ccpl1rsp.h" 6188 6189 CHARACTER*(3) LIST 6190 INTEGER INDEX 6191 LOGICAL LEOOR 6192 6193 LEOOR = .FALSE. 6194 6195* begin: 6196 IF (LIST(1:2).EQ.'o1') THEN 6197 IF (INDEX.LE.0 .OR. INDEX.GT.NRSOLBL) LEOOR = .TRUE. 6198 CALL QUIT('Illegal list in function FREQLST: '//LIST) 6199 ELSE IF (LIST(1:3).EQ.'O1 ') THEN 6200 IF (INDEX.LE.0 .OR. INDEX.GT.NO1LBL) LEOOR = .TRUE. 6201 FREQLST = FRQO1(INDEX) 6202 ELSE IF (LIST(1:2).EQ.'O2' ) THEN 6203 IF (INDEX.LE.0 .OR. INDEX.GT.NO2LBL) LEOOR = .TRUE. 6204 FREQLST = FRQO2(INDEX,1) + FRQO2(INDEX,2) 6205 ELSE IF (LIST(1:2).EQ.'O3' ) THEN 6206 IF (INDEX.LE.0 .OR. INDEX.GT.NO3LBL) LEOOR = .TRUE. 6207 FREQLST = FRQO3(INDEX,1) + FRQO3(INDEX,2) + FRQO3(INDEX,3) 6208 ELSE IF (LIST(1:2).EQ.'O4' ) THEN 6209 IF (INDEX.LE.0 .OR. INDEX.GT.NO4LBL) LEOOR = .TRUE. 6210 FREQLST = FRQO4(INDEX,1) + FRQO4(INDEX,2) + 6211 & FRQO4(INDEX,3) + FRQO4(INDEX,4) 6212 ELSE IF (LIST(1:3).EQ.'CO2') THEN 6213 IF (INDEX.LE.0 .OR. INDEX.GT.NCO2LBL) LEOOR = .TRUE. 6214 FREQLST = 0.0D0 6215 ELSE IF (LIST(1:3).EQ.'X1 ') THEN 6216 IF (INDEX.LE.0 .OR. INDEX.GT.NX1LBL) LEOOR = .TRUE. 6217 FREQLST = FRQX1(INDEX) 6218 ELSE IF (LIST(1:2).EQ.'X2' ) THEN 6219 IF (INDEX.LE.0 .OR. INDEX.GT.NX2LBL) LEOOR = .TRUE. 6220 FREQLST = FRQX2(INDEX,1) + FRQX2(INDEX,2) 6221 ELSE IF (LIST(1:2).EQ.'X3' ) THEN 6222 IF (INDEX.LE.0 .OR. INDEX.GT.NX3LBL) LEOOR = .TRUE. 6223 FREQLST = FRQX3(INDEX,1) + FRQX3(INDEX,2) + FRQX3(INDEX,3) 6224 ELSE IF (LIST(1:2).EQ.'X4' ) THEN 6225 IF (INDEX.LE.0 .OR. INDEX.GT.NX4LBL) LEOOR = .TRUE. 6226 FREQLST = FRQX4(INDEX,1) + FRQX4(INDEX,2) + 6227 & FRQX4(INDEX,3) + FRQX4(INDEX,4) 6228 ELSE IF (LIST(1:3).EQ.'CX2') THEN 6229 IF (INDEX.LE.0 .OR. INDEX.GT.NCX2LBL) LEOOR = .TRUE. 6230 FREQLST = 0.0D0 6231 ELSE IF (LIST(1:2).EQ.'L0' .OR. LIST(1:2).EQ.'R0') THEN 6232 FREQLST = 0.0D0 6233 ELSE IF (LIST(1:2).EQ.'D0') THEN 6234 CALL QUIT('Illegal list in function FREQLST: '//LIST) 6235 ELSE IF (LIST(1:2).EQ.'E0' .OR. LIST(1:2).EQ.'BE') THEN 6236 FREQLST = 0.0D0 6237 ELSE IF (LIST(1:2).EQ.'LE') THEN 6238 FREQLST = -EIGVAL(INDEX) 6239 ELSE IF (LIST(1:2).EQ.'RE') THEN 6240 FREQLST = +EIGVAL(INDEX) 6241 ELSE IF (LIST(1:3).EQ.'ER1'.OR.LIST(1:3).EQ.'EO1') THEN 6242 IF (INDEX.LE.0 .OR. INDEX.GT.NER1LBL) LEOOR = .TRUE. 6243 FREQLST = EIGER1(INDEX) + FRQER1(INDEX) 6244 WRITE(LUPRI,*)'FUNCTION FREQLST NOT DEBUGED FOR "ER1" VECTORS' 6245 ELSE IF (LIST(1:3).EQ.'ER2'.OR.LIST(1:3).EQ.'EO2') THEN 6246 IF (INDEX.LE.0 .OR. INDEX.GT.NER2LBL) LEOOR = .TRUE. 6247 FREQLST = EIGER2(INDEX) + FRQER2(INDEX,1) + FRQER2(INDEX,2) 6248 WRITE(LUPRI,*)'FUNCTION FREQLST NOT DEBUGED FOR "ER2" VECTORS' 6249 ELSE IF (LIST(1:3).EQ.'EL1'.OR.LIST(1:3).EQ.'EX1') THEN 6250 IF (INDEX.LE.0 .OR. INDEX.GT.NEL1LBL) LEOOR = .TRUE. 6251 FREQLST = EIGEL1(INDEX) + FRQEL1(INDEX) 6252 WRITE(LUPRI,*)'FUNCTION FREQLST NOT DEBUGED FOR "EL1" VECTORS' 6253 ELSE IF (LIST(1:3).EQ.'EL2'.OR.LIST(1:3).EQ.'EX2') THEN 6254 IF (INDEX.LE.0 .OR. INDEX.GT.NEL2LBL) LEOOR = .TRUE. 6255 FREQLST = EIGEL2(INDEX) + FRQEL2(INDEX,1) + FRQEL2(INDEX,2) 6256 WRITE(LUPRI,*)'FUNCTION FREQLST NOT DEBUGED FOR "EL2" VECTORS' 6257 ELSE IF (LIST(1:2).EQ.'L1'.OR.LIST(1:3).EQ.'X1B') THEN 6258 IF (INDEX.LE.0 .OR. INDEX.GT.NLRZLBL) LEOOR = .TRUE. 6259 FREQLST = FRQLRZ(INDEX) 6260 ELSE IF (LIST(1:2).EQ.'M1'.OR.LIST(1:2).EQ.'FR') THEN 6261 IF (INDEX.LE.0 .OR. INDEX.GT.NLRM ) LEOOR = .TRUE. 6262 FREQLST = FRQLRM(INDEX) 6263 WRITE(LUPRI,*)'FUNCTION FREQLST NOT DEBUGED FOR "M1 " VECTORS' 6264 ELSE IF (LIST(1:2).EQ.'R1' .OR. LIST(1:2).EQ.'F1') THEN 6265 IF (INDEX.LE.0 .OR. INDEX.GT.NLRTLBL) LEOOR = .TRUE. 6266 FREQLST = FRQLRT(INDEX) 6267 ELSE IF ((LIST(1:2).EQ.'RC').OR.(LIST(1:2).EQ.'FC')) THEN 6268 IF (INDEX.LE.0 .OR. INDEX.GT.NLRCLBL) LEOOR = .TRUE. 6269 FREQLST = 0.0D0 6270 ELSE IF ((LIST(1:2).EQ.'LC').OR.(LIST(1:2).EQ.'XC')) THEN 6271 IF (INDEX.LE.0 .OR. INDEX.GT.NLC1LBL) LEOOR = .TRUE. 6272 FREQLST = 0.0D0 6273 ELSE IF (LIST(1:3).EQ.'CR2'.OR.LIST(1:3).EQ.'CF2') THEN 6274 IF (INDEX.LE.0 .OR. INDEX.GT.NCR2LBL) LEOOR = .TRUE. 6275 FREQLST = 0.0D0 6276 ELSE IF (LIST(1:2).EQ.'R2' .OR. LIST(1:2).EQ.'F2') THEN 6277 IF (INDEX.LE.0 .OR. INDEX.GT.NR2TLBL) LEOOR = .TRUE. 6278 FREQLST = FRQR2T(INDEX,1) + FRQR2T(INDEX,2) 6279 ELSE IF (LIST(1:2).EQ.'R3' .OR. LIST(1:2).EQ.'F3') THEN 6280 IF (INDEX.LE.0 .OR. INDEX.GT.NR3TLBL) LEOOR = .TRUE. 6281 FREQLST = FRQR3T(INDEX,1) + FRQR3T(INDEX,2) + FRQR3T(INDEX,3) 6282 ELSE IF (LIST(1:2).EQ.'R4' .OR. LIST(1:2).EQ.'F4') THEN 6283 IF (INDEX.LE.0 .OR. INDEX.GT.NR4TLBL) LEOOR = .TRUE. 6284 FREQLST = FRQR4T(INDEX,1) + FRQR4T(INDEX,2) + 6285 & FRQR4T(INDEX,3) + FRQR4T(INDEX,4) 6286 ELSE IF (LIST(1:2).EQ.'L2') THEN 6287 IF (INDEX.LE.0 .OR. INDEX.GT.NL2LBL) LEOOR = .TRUE. 6288 FREQLST = FRQL2(INDEX,1) + FRQL2(INDEX,2) 6289 ELSE IF (LIST(1:2).EQ.'L3') THEN 6290 IF (INDEX.LE.0 .OR. INDEX.GT.NL3LBL) LEOOR = .TRUE. 6291 FREQLST = FRQL3(INDEX,1) + FRQL3(INDEX,2) + FRQL3(INDEX,3) 6292 ELSE IF (LIST(1:2).EQ.'L4') THEN 6293 IF (INDEX.LE.0 .OR. INDEX.GT.NL4LBL) LEOOR = .TRUE. 6294 FREQLST = FRQL4(INDEX,1) + FRQL4(INDEX,2) + 6295 & FRQL4(INDEX,3) + FRQL4(INDEX,4) 6296 ELSE IF (LIST(1:3).EQ.'CL2') THEN 6297 IF (INDEX.LE.0 .OR. INDEX.GT.NCL2LBL) LEOOR = .TRUE. 6298 FREQLST = 0.0D0 6299 ELSE IF (LIST(1:2).EQ.'N2' .OR. LIST(1:2).EQ.'BR') THEN 6300 IF (INDEX.LE.0 .OR. INDEX.GT.NQRN2 ) LEOOR = .TRUE. 6301 FREQLST = -EIGN2(INDEX,1) - EIGN2(INDEX,2) 6302 WRITE(LUPRI,*)'FUNCTION FREQLST NOT DEBUGGED FOR "N2 " VECTORS' 6303 ELSE IF (LIST(1:3).EQ.'PL1') THEN 6304 IF (INDEX.LE.0 .OR. INDEX.GT.NPL1LBL) LEOOR = .TRUE. 6305 FREQLST = FRQPL1(INDEX) 6306 ELSE 6307 WRITE(LUPRI,*) 'Unknown LIST in FREQLST:"',LIST(1:3),'"' 6308C to force a core dump: 6309C WRITE (LUPRI,*) LIST(999999:999999) 6310 CALL QUIT('Unknown LIST in function FREQLST: '//LIST) 6311 END IF 6312 6313 IF (LEOOR) THEN 6314 WRITE (LUPRI,*) 'INDEX out of range in FREQLST:' 6315 WRITE (LUPRI,*) 'LIST,INDEX: ',LIST(1:3),INDEX 6316C to force a core dump: 6317C WRITE (LUPRI,*) LIST(-999999:-999999) 6318 CALL QUIT('INDEX out of range in FREQLST.') 6319 END IF 6320 6321 RETURN 6322 END 6323*=====================================================================* 6324*=====================================================================* 6325C /* Deck idxsym */ 6326*=====================================================================* 6327 INTEGER FUNCTION IDXSYM(LIST,ISYM,INDEX) 6328*---------------------------------------------------------------------* 6329* PURPOSE: Get symmetry for vector on list and calculate the nr. 6330* relative to the offset. Make new list 6331* 6332* LIST : list type 6333* INDEX: index of the vector on the list 6334* SYM: Symmetry of vectors 6335* IDXSYM:Index of the vector on the list 6336* reduced by symmetry offset. 6337* 6338* Christof Haettig, November 1996(ILSTSYM), Ove Christiansen Feb. 1997 6339* PL1 vectors, Sonia 2000 6340* Cholesky CC2 vectors, tbp 2003 6341* Lanczos QL vectors, Sonia 2010 6342*=====================================================================* 6343 IMPLICIT NONE 6344#include "ccorb.h" 6345#include "ccroper.h" 6346#include "ccer1rsp.h" 6347#include "ccer2rsp.h" 6348#include "ccel1rsp.h" 6349#include "ccel2rsp.h" 6350#include "ccr1rsp.h" 6351#include "ccr2rsp.h" 6352#include "ccr3rsp.h" 6353#include "ccr4rsp.h" 6354#include "ccx1rsp.h" 6355#include "ccx2rsp.h" 6356#include "ccx3rsp.h" 6357#include "ccx4rsp.h" 6358#include "ccl1rsp.h" 6359#include "ccl2rsp.h" 6360#include "ccl3rsp.h" 6361#include "ccl4rsp.h" 6362#include "cco1rsp.h" 6363#include "cco2rsp.h" 6364#include "cco3rsp.h" 6365#include "cco4rsp.h" 6366#include "ccn2rsp.h" 6367#include "cclrmrsp.h" 6368#include "ccrc1rsp.h" 6369#include "cclc1rsp.h" 6370#include "cccr2rsp.h" 6371#include "ccco2rsp.h" 6372#include "cccl2rsp.h" 6373#include "cccx2rsp.h" 6374#include "ccexci.h" 6375#include "ccpl1rsp.h" 6376#include "priunit.h" 6377!Lanczos 6378#include "ccqlrlcz.h" 6379 6380 CHARACTER*(*) LIST 6381 INTEGER INDEX,ISYM 6382 LOGICAL LEOOR 6383 6384 LEOOR = .FALSE. 6385 6386* begin: 6387 IF (LIST(1:2).EQ.'L0' .OR. LIST(1:2).EQ.'R0') THEN 6388 IDXSYM = 1 6389 ELSE IF (LIST(1:2).EQ.'D0') THEN 6390 IDXSYM = 1 6391Cholesky 6392 ELSE IF (LIST(1:3).EQ.'d00') THEN 6393 IDXSYM = 1 6394Chol ELSE IF (LIST(1:2).EQ.'R1' .OR. LIST(1:2).EQ.'F1') THEN 6395 ELSE IF (LIST(1:2).EQ.'R1' .OR. LIST(1:2).EQ.'F1' .OR. 6396 & LIST(1:3).EQ.'XF1' .OR. LIST(1:3).EQ.'d01' .OR. 6397 & LIST(1:3).EQ.'eO1') THEN 6398Cholesky 6399 IF (INDEX.LT.0 .OR. INDEX.GT.NLRTLBL) LEOOR = .TRUE. 6400 IDXSYM = INDEX - ISYOFT(ISYM) 6401 ELSE IF (LIST(1:2).EQ.'R2' .OR. LIST(1:2).EQ.'F2') THEN 6402 IF (INDEX.LT.0 .OR. INDEX.GT.NR2TLBL) LEOOR = .TRUE. 6403 IDXSYM = INDEX - ISYOFT2(ISYM) 6404 ELSE IF (LIST(1:2).EQ.'R3' .OR. LIST(1:2).EQ.'F3') THEN 6405 IF (INDEX.LT.0 .OR. INDEX.GT.NR3TLBL) LEOOR = .TRUE. 6406 IDXSYM = INDEX - ISYOFT3(ISYM) 6407 ELSE IF (LIST(1:2).EQ.'R4' .OR. LIST(1:2).EQ.'F4') THEN 6408 IF (INDEX.LT.0 .OR. INDEX.GT.NR4TLBL) LEOOR = .TRUE. 6409 IDXSYM = INDEX - ISYOFT4(ISYM) 6410 ELSE IF (LIST(1:3).EQ.'O1 '.OR.LIST(1:3).EQ.'O1e') THEN 6411 IF (INDEX.LT.0 .OR. INDEX.GT.NO1LBL) LEOOR = .TRUE. 6412 IDXSYM = INDEX - ISYOFO1(ISYM) 6413 ELSE IF (LIST(1:2).EQ.'O2') THEN 6414 IF (INDEX.LT.0 .OR. INDEX.GT.NO2LBL) LEOOR = .TRUE. 6415 IDXSYM = INDEX - ISYOFO2(ISYM) 6416 ELSE IF (LIST(1:2).EQ.'O3') THEN 6417 IF (INDEX.LT.0 .OR. INDEX.GT.NO3LBL) LEOOR = .TRUE. 6418 IDXSYM = INDEX - ISYOFO3(ISYM) 6419 ELSE IF (LIST(1:2).EQ.'O4') THEN 6420 IF (INDEX.LT.0 .OR. INDEX.GT.NO4LBL) LEOOR = .TRUE. 6421 IDXSYM = INDEX - ISYOFO4(ISYM) 6422 ELSE IF (LIST(1:3).EQ.'CO2') THEN 6423 IF (INDEX.LE.0 .OR. INDEX.GT.NCO2LBL) LEOOR = .TRUE. 6424 IDXSYM = INDEX - ISYOFCO2(ISYM) 6425 ELSE IF (LIST(1:3).EQ.'X1 '.OR.LIST(1:3).EQ.'X1e') THEN 6426 IF (INDEX.LT.0 .OR. INDEX.GT.NX1LBL) LEOOR = .TRUE. 6427 IDXSYM = INDEX - ISYOFX1(ISYM) 6428 ELSE IF (LIST(1:2).EQ.'X2') THEN 6429 IF (INDEX.LT.0 .OR. INDEX.GT.NX2LBL) LEOOR = .TRUE. 6430 IDXSYM = INDEX - ISYOFX2(ISYM) 6431 ELSE IF (LIST(1:2).EQ.'X3') THEN 6432 IF (INDEX.LT.0 .OR. INDEX.GT.NX3LBL) LEOOR = .TRUE. 6433 IDXSYM = INDEX - ISYOFX3(ISYM) 6434 ELSE IF (LIST(1:2).EQ.'X4') THEN 6435 IF (INDEX.LT.0 .OR. INDEX.GT.NX4LBL) LEOOR = .TRUE. 6436 IDXSYM = INDEX - ISYOFX4(ISYM) 6437 ELSE IF (LIST(1:3).EQ.'CX2') THEN 6438 IF (INDEX.LE.0 .OR. INDEX.GT.NCX2LBL) LEOOR = .TRUE. 6439 IDXSYM = INDEX - ISYOFCX2(ISYM) 6440 ELSE IF (LIST(1:2).EQ.'L1') THEN 6441 IF (INDEX.LT.0 .OR. INDEX.GT.NLRZLBL) LEOOR = .TRUE. 6442 IDXSYM = INDEX - ISYOFZ(ISYM) 6443 ELSE IF (LIST(1:2).EQ.'L2') THEN 6444 IF (INDEX.LT.0 .OR. INDEX.GT.NL2LBL) LEOOR = .TRUE. 6445 IDXSYM = INDEX - ISYOFL2(ISYM) 6446 ELSE IF (LIST(1:2).EQ.'L3') THEN 6447 IF (INDEX.LT.0 .OR. INDEX.GT.NL3LBL) LEOOR = .TRUE. 6448 IDXSYM = INDEX - ISYOFL3(ISYM) 6449 ELSE IF (LIST(1:2).EQ.'L4') THEN 6450 IF (INDEX.LT.0 .OR. INDEX.GT.NL4LBL) LEOOR = .TRUE. 6451 IDXSYM = INDEX - ISYOFL4(ISYM) 6452 ELSE IF (LIST(1:3).EQ.'CL2') THEN 6453 IF (INDEX.LE.0 .OR. INDEX.GT.NCL2LBL) LEOOR = .TRUE. 6454 IDXSYM = INDEX - ISYOFCL2(ISYM) 6455 ELSE IF (LIST(1:2).EQ.'E0' .OR. LIST(1:2).EQ.'BE') THEN 6456 IDXSYM = INDEX 6457 ELSE IF (LIST(1:2).EQ.'LE' .OR. LIST(1:2).EQ.'RE') THEN 6458 IF (INDEX.LT.0 .OR. INDEX.GT.NEXCI) LEOOR = .TRUE. 6459 IDXSYM = INDEX - ISYOFE(ISYM) 6460 ELSE IF (LIST(1:3).EQ.'ER1'.OR.LIST(1:3).EQ.'EO1') THEN 6461 IF (INDEX.LT.0 .OR. INDEX.GT.NER1LBL) LEOOR = .TRUE. 6462 IDXSYM = INDEX - ISYOFER1(ISYM) 6463 ELSE IF (LIST(1:3).EQ.'ER2'.OR.LIST(1:3).EQ.'EO2') THEN 6464 IF (INDEX.LT.0 .OR. INDEX.GT.NER2LBL) LEOOR = .TRUE. 6465 IDXSYM = INDEX - ISYOFER2(ISYM) 6466 ELSE IF (LIST(1:3).EQ.'EL1'.OR.LIST(1:3).EQ.'EX1') THEN 6467 IF (INDEX.LT.0 .OR. INDEX.GT.NEL1LBL) LEOOR = .TRUE. 6468 IDXSYM = INDEX - ISYOFEL1(ISYM) 6469 ELSE IF (LIST(1:3).EQ.'EL2'.OR.LIST(1:3).EQ.'EX2') THEN 6470 IF (INDEX.LT.0 .OR. INDEX.GT.NEL2LBL) LEOOR = .TRUE. 6471 IDXSYM = INDEX - ISYOFEL2(ISYM) 6472 ELSE IF (LIST(1:2).EQ.'M1' .OR. LIST(1:2).EQ.'FR') THEN 6473 IF (INDEX.LT.0 .OR. INDEX.GT.NLRM ) LEOOR = .TRUE. 6474 IDXSYM = INDEX - ISYOFM(ISYM) 6475 ELSE IF (LIST(1:2).EQ.'RC' .OR. LIST(1:2).EQ.'FC') THEN 6476 IF (INDEX.LT.0 .OR. INDEX.GT.NLRCLBL) LEOOR = .TRUE. 6477 IDXSYM = INDEX - ISYOFC(ISYM) 6478 ELSE IF (LIST(1:2).EQ.'LC') THEN 6479 IF (INDEX.LT.0 .OR. INDEX.GT.NLC1LBL) LEOOR = .TRUE. 6480 IDXSYM = INDEX - ISYOFLC1(ISYM) 6481 ELSE IF (LIST(1:3).EQ.'CR2'.OR.LIST(1:3).EQ.'CF2') THEN 6482 IF (INDEX.LE.0 .OR. INDEX.GT.NCR2LBL) LEOOR = .TRUE. 6483 IDXSYM = INDEX - ISYOFCR2(ISYM) 6484 ELSE IF (LIST(1:2).EQ.'N2'.OR.LIST(1:2).EQ.'BR') THEN 6485 IF (INDEX.LT.0 .OR. INDEX.GT.NQRN2 ) LEOOR = .TRUE. 6486 IDXSYM = INDEX - ISYOFN2(ISYM) 6487!PL1 vectors indices within symmetry class (Sonia) 6488 ELSE IF (LIST(1:3).EQ.'PL1') THEN 6489 IF (INDEX.LT.0 .OR. INDEX.GT.NPL1LBL) LEOOR = .TRUE. 6490 IDXSYM = INDEX - ISYOFPL1(ISYM) 6491!Lanczos QL/FQL vectors indices within symmetry class (Sonia) 6492 ELSE IF (LIST(1:2).EQ.'QL' .OR. LIST(1:2).EQ.'FQ') THEN 6493 IF (INDEX.LT.0 .OR. INDEX.GT.NQLLBL) LEOOR = .TRUE. 6494 IDXSYM = INDEX - ISYOFQL(ISYM) 6495 ELSE 6496 WRITE (LUPRI,*) 'Unknown LIST in IDXSYM:"',LIST(1:3),'".' 6497C to force a core dump: 6498 WRITE (LUPRI,*) 'core dump:',LIST(9999999:9999999) 6499 CALL QUIT('Unknown LIST in IDXSYM.') 6500 END IF 6501 6502 IF (LEOOR) THEN 6503 WRITE (LUPRI,*) 'INDEX out of range in IDXSYM:' 6504 WRITE (LUPRI,*) 'LIST,INDEX:',LIST,INDEX 6505 CALL QUIT('INDEX out of range in IDXSYM.') 6506 END IF 6507 6508C write(LUPRI,*) 'index,idxsym',index,idxsym 6509 6510 RETURN 6511 END 6512*=====================================================================* 6513C /* Deck irhsr2 */ 6514 INTEGER FUNCTION IRHSR2(NEWLBLA,LORXA,FRQANEW,ISYMA, 6515 * NEWLBLB,LORXB,FRQBNEW,ISYMB ) 6516*---------------------------------------------------------------------* 6517C 6518C maintain the list right hand side vectors for the 6519C second-order coupled cluster amplitude equations 6520C 6521C if vector is on the list return list index and set ISYMA,ISYMB 6522C if vector is NOT on the list: 6523C LO2OPN=.true. --> extend list, and return index 6524C LO2OPN=.false. --> return -1 6525C 6526C NEWLBLA / NEWLBLB -- operator labels 6527C LORXA / LORXB -- flags for orbital relaxation 6528C FRQANEW / FRQBNEW -- frequencies 6529C ISYMA / ISYMB -- symmetries 6530C 6531C Christof Haettig, April 97 6532C LORXA, LORXB flags introduced in July 1999 6533*---------------------------------------------------------------------* 6534 IMPLICIT NONE 6535#include "cco2rsp.h" 6536#include "priunit.h" 6537C 6538 INTEGER ISYMA, ISYMB 6539 REAL*8 FRQANEW,FRQBNEW,TOL 6540 6541 PARAMETER(TOL=1.0D-12) 6542 6543 CHARACTER*8 NEWLBLA, NEWLBLB 6544 LOGICAL LORXA, LORXB 6545 INTEGER I 6546 6547 DO I = 1,NO2LBL 6548 IF ( NEWLBLA.EQ.LBLAO2(I).AND. NEWLBLB.EQ.LBLBO2(I) 6549 * .AND. (LORXA .EQV. LORXAO2(I)) 6550 * .AND. (LORXB .EQV. LORXBO2(I)) 6551 * .AND. (ABS(FRQANEW-FRQAO2(I)).LT.TOL) 6552 * .AND. (ABS(FRQBNEW-FRQBO2(I)).LT.TOL) 6553 * ) THEN 6554 IRHSR2 = I 6555 ISYMA = ISYAO2(IRHSR2) 6556 ISYMB = ISYBO2(IRHSR2) 6557 RETURN 6558 END IF 6559 IF ( NEWLBLB.EQ.LBLAO2(I).AND. NEWLBLA.EQ.LBLBO2(I) 6560 * .AND. (LORXB .EQV. LORXAO2(I)) 6561 * .AND. (LORXA .EQV. LORXBO2(I)) 6562 * .AND. (ABS(FRQBNEW-FRQAO2(I)).LT.TOL) 6563 * .AND. (ABS(FRQANEW-FRQBO2(I)).LT.TOL) 6564 * ) THEN 6565 IRHSR2 = I 6566 ISYMB = ISYAO2(IRHSR2) 6567 ISYMA = ISYBO2(IRHSR2) 6568 RETURN 6569 END IF 6570 END DO 6571 6572 IF (LO2OPN) THEN 6573 NO2LBL = NO2LBL + 1 6574 6575 IF (NO2LBL.GT.MAXO2LBL) THEN 6576 WRITE(LUPRI,'(A,/A,I5,A,I5)') 6577 * '@ NUMBER OF SPECIFIED VECTORS EXCEED THE MAXIMUM ALLOWED', 6578 * '@ MAXO2LBL =',MAXO2LBL,' NO2LBL= ',NO2LBL 6579 CALL QUIT(' IRHSR2: TOO MANY VECTORS SPECIFIED') 6580 END IF 6581 6582 LBLAO2(NO2LBL) = NEWLBLA 6583 LBLBO2(NO2LBL) = NEWLBLB 6584 LORXAO2(NO2LBL) = LORXA 6585 LORXBO2(NO2LBL) = LORXB 6586 FRQAO2(NO2LBL) = FRQANEW 6587 FRQBO2(NO2LBL) = FRQBNEW 6588 ISYAO2(NO2LBL) = ISYMA 6589 ISYBO2(NO2LBL) = ISYMB 6590 IRHSR2 = NO2LBL 6591 6592 ELSE 6593 WRITE(LUPRI,'(3A,L2,A,1P,D12.5,3A,L2,A,1P,D12.5,2A)') 6594 * '@ WARNING: RHSR2 VECTOR FOR ', 6595 * NEWLBLA,'(',LORXA,',',FRQANEW,'), ', 6596 * NEWLBLB,'(',LORXB,',',FRQBNEW,')', 6597 * ' IS NOT AVAILABLE.' 6598 IRHSR2 = -1 6599 END IF 6600 6601 RETURN 6602 END 6603*=====================================================================* 6604*=====================================================================* 6605C /* Deck ichi2 */ 6606 INTEGER FUNCTION ICHI2(NEWLBLA,LORXA,FRQANEW,ISYMA, 6607 * NEWLBLB,LORXB,FRQBNEW,ISYMB ) 6608*---------------------------------------------------------------------* 6609C 6610C maintain the list of second-order chi vectors: 6611C 6612C if vector is on the list return list index and set ISYMA,ISYMB 6613C if vector is NOT on the list: 6614C LX2OPN=.true. --> extend list, and return index 6615C LX2OPN=.false. --> return -1 6616C 6617C Christof Haettig, April 97 6618*---------------------------------------------------------------------* 6619 IMPLICIT NONE 6620#include "ccx2rsp.h" 6621#include "priunit.h" 6622C 6623 INTEGER ISYMA, ISYMB 6624 LOGICAL LORXA, LORXB 6625 REAL*8 FRQANEW,FRQBNEW,TOL 6626 6627 PARAMETER(TOL=1.0D-12) 6628 6629 CHARACTER*8 NEWLBLA, NEWLBLB 6630 INTEGER I 6631 6632 DO I = 1,NX2LBL 6633 IF ( NEWLBLA.EQ.LBLAX2(I).AND. NEWLBLB.EQ.LBLBX2(I) 6634 * .AND. (LORXA .EQV. LORXAX2(I)) 6635 * .AND. (LORXB .EQV. LORXBX2(I)) 6636 * .AND. (ABS(FRQANEW-FRQAX2(I)).LT.TOL) 6637 * .AND. (ABS(FRQBNEW-FRQBX2(I)).LT.TOL) 6638 * ) THEN 6639 ICHI2 = I 6640 ISYMA = ISYAX2(ICHI2) 6641 ISYMB = ISYBX2(ICHI2) 6642 RETURN 6643 END IF 6644 IF ( NEWLBLB.EQ.LBLAX2(I).AND. NEWLBLA.EQ.LBLBX2(I) 6645 * .AND. (LORXB .EQV. LORXAX2(I)) 6646 * .AND. (LORXA .EQV. LORXBX2(I)) 6647 * .AND. (ABS(FRQBNEW-FRQAX2(I)).LT.TOL) 6648 * .AND. (ABS(FRQANEW-FRQBX2(I)).LT.TOL) 6649 * ) THEN 6650 ICHI2 = I 6651 ISYMB = ISYAX2(ICHI2) 6652 ISYMA = ISYBX2(ICHI2) 6653 RETURN 6654 END IF 6655 END DO 6656 6657 IF (LX2OPN) THEN 6658 NX2LBL = NX2LBL + 1 6659 6660 IF (NX2LBL.GT.MAXX2LBL) THEN 6661 WRITE(LUPRI,'(A,/A,I5,A,I5)') 6662 * '@ NUMBER OF SPECIFIED VECTORS EXCEED THE MAXIMUM ALLOWED', 6663 * '@ MAXX2LBL =',MAXX2LBL,' NX2LBL= ',NX2LBL 6664 CALL QUIT(' ICHI2: TOO MANY VECTORS SPECIFIED') 6665 END IF 6666 6667 LBLAX2(NX2LBL) = NEWLBLA 6668 LBLBX2(NX2LBL) = NEWLBLB 6669 LORXAX2(NX2LBL) = LORXA 6670 LORXBX2(NX2LBL) = LORXB 6671 FRQAX2(NX2LBL) = FRQANEW 6672 FRQBX2(NX2LBL) = FRQBNEW 6673 ISYAX2(NX2LBL) = ISYMA 6674 ISYBX2(NX2LBL) = ISYMB 6675 ICHI2 = NX2LBL 6676 6677 ELSE 6678 WRITE(LUPRI,'(3A,L2,A,1P,D12.5,3A,L2,A,1P,D12.5,2A)') 6679 * '@ WARNING: X2 VECTOR FOR ', 6680 * NEWLBLA,'(',LORXA,',',FRQANEW,'), ', 6681 * NEWLBLB,'(',LORXB,',',FRQBNEW,')', 6682 * ' IS NOT AVAILABLE.' 6683 ICHI2 = -1 6684 END IF 6685 6686 RETURN 6687 END 6688*=====================================================================* 6689*=====================================================================* 6690C /* Deck il2zeta */ 6691 INTEGER FUNCTION IL2ZETA(NEWLBLA,FRQANEW,ISYMA, 6692 * NEWLBLB,FRQBNEW,ISYMB ) 6693*---------------------------------------------------------------------* 6694C 6695C maintain the list of second-order lagrangian multiplier vectors: 6696C 6697C if vector is on the list return list index and set ISYMA,ISYMB 6698C if vector is NOT on the list: 6699C LL2OPN=.true. --> extend list, and return index 6700C LL2OPN=.false. --> return -1 6701C 6702C Christof Haettig, April 97 6703*---------------------------------------------------------------------* 6704 IMPLICIT NONE 6705#include "ccl2rsp.h" 6706#include "priunit.h" 6707C 6708 INTEGER ISYMA, ISYMB 6709 REAL*8 FRQANEW,FRQBNEW,TOL 6710 6711 PARAMETER(TOL=1.0D-12) 6712 6713 CHARACTER*8 NEWLBLA, NEWLBLB 6714 INTEGER I 6715 6716 DO I = 1,Nl2LBL 6717 IF ( NEWLBLA.EQ.LBLAL2(I).AND. NEWLBLB.EQ.LBLBL2(I) 6718 * .AND. (ABS(FRQANEW-FRQAL2(I)).LT.TOL) 6719 * .AND. (ABS(FRQBNEW-FRQBL2(I)).LT.TOL) 6720 * ) THEN 6721 IL2ZETA = I 6722 ISYMA = ISYAL2(IL2ZETA) 6723 ISYMB = ISYBL2(IL2ZETA) 6724 RETURN 6725 END IF 6726 IF ( NEWLBLB.EQ.LBLAL2(I).AND. NEWLBLA.EQ.LBLBL2(I) 6727 * .AND. (ABS(FRQBNEW-FRQAL2(I)).LT.TOL) 6728 * .AND. (ABS(FRQANEW-FRQBL2(I)).LT.TOL) 6729 * ) THEN 6730 IL2ZETA = I 6731 ISYMB = ISYAL2(IL2ZETA) 6732 ISYMA = ISYBL2(IL2ZETA) 6733 RETURN 6734 END IF 6735 END DO 6736 6737 IF (LL2OPN) THEN 6738 NL2LBL = NL2LBL + 1 6739 6740 IF (NL2LBL.GT.MAXL2LBL) THEN 6741 WRITE(LUPRI,'(A,/A,I5,A,I5)') 6742 * '@ NUMBER OF SPECIFIED VECTORS EXCEED THE MAXIMUM ALLOWED', 6743 * '@ MAXL2LBL =',MAXL2LBL,' NL2LBL= ',NL2LBL 6744 CALL QUIT(' IL2ZETA: TOO MANY VECTORS SPECIFIED') 6745 END IF 6746 6747 LBLAL2(NL2LBL) = NEWLBLA 6748 LBLBL2(NL2LBL) = NEWLBLB 6749 FRQAL2(NL2LBL) = FRQANEW 6750 FRQBL2(NL2LBL) = FRQBNEW 6751 ISYAL2(NL2LBL) = ISYMA 6752 ISYBL2(NL2LBL) = ISYMB 6753 IL2ZETA = NL2LBL 6754 6755 ELSE 6756 WRITE(LUPRI,'(3A,1P,D12.5,3A,1P,D12.5,2A)') 6757 * '@ WARNING: L2 VECTOR FOR ',NEWLBLA,'(',FRQANEW,'), ', 6758 * NEWLBLB,'(',FRQBNEW,')', 6759 * ' IS NOT AVAILABLE.' 6760 IL2ZETA = -1 6761 END IF 6762 6763 RETURN 6764 END 6765*=====================================================================* 6766*=====================================================================* 6767C /* Deck iveclist */ 6768 INTEGER FUNCTION IVECLIST(LABELN,FREQN,ISYMN, 6769 * LABELL,FREQL,ISYML, 6770 * TYPE,ORDER,MAXLIST,NLIST,LOPEN) 6771*---------------------------------------------------------------------* 6772C maintain a list of response vectors: 6773C 6774C new vector specified by LABELN, FREQN, ISYMN 6775C vector list LABELL, FREQL, ISYML 6776C 6777C if vector is on the list return list index 6778C if vector is NOT on the list: 6779C LOPEN=.true. --> extend list, and return index 6780C LOPEN=.false. --> do not extend the list, but return -1 6781C 6782C Christof Haettig, maj 97 6783*---------------------------------------------------------------------* 6784 IMPLICIT NONE 6785#include "priunit.h" 6786C 6787 LOGICAL LOPEN, CHANGES, SWAP, NOSWAP, LFOUND 6788 CHARACTER*(*) TYPE 6789 INTEGER ORDER, MAXLIST, NLIST, IERR, ILIST, ISY, IOP 6790 INTEGER ISYMN(ORDER), ISYML(MAXLIST,ORDER) 6791 REAL*8 FREQN(ORDER), FREQL(MAXLIST,ORDER), FRQ 6792 6793 CHARACTER*8 LABELN(ORDER), LABELL(MAXLIST,ORDER), LBL 6794 INTEGER I 6795 6796*---------------------------------------------------------------------* 6797* sort after labels, frequencies and symmetries: 6798*---------------------------------------------------------------------* 6799 CHANGES = .TRUE. 6800 DO WHILE (CHANGES) 6801 6802 CHANGES = .FALSE. 6803 6804 DO IOP = 1, ORDER-1 6805 6806 SWAP = .FALSE. 6807 NOSWAP = .FALSE. 6808 6809 DO I = 1, 8 6810 IF (LGT(LABELN(IOP)(I:I),LABELN(IOP+1)(I:I)) 6811 & .AND. .NOT. NOSWAP) SWAP = .TRUE. 6812 IF (LLT(LABELN(IOP)(I:I),LABELN(IOP+1)(I:I)) 6813 & .AND. .NOT. SWAP) NOSWAP = .TRUE. 6814 END DO 6815 6816 IF (FREQN(IOP).GT.FREQN(IOP+1) 6817 & .AND. .NOT. NOSWAP) SWAP = .TRUE. 6818 IF (FREQN(IOP).LT.FREQN(IOP+1) 6819 & .AND. .NOT. SWAP) NOSWAP = .TRUE. 6820 6821 IF (ISYMN(IOP).GT.ISYMN(IOP+1) 6822 & .AND. .NOT. NOSWAP) SWAP = .TRUE. 6823 IF (ISYMN(IOP).LT.ISYMN(IOP+1) 6824 & .AND. .NOT. SWAP) NOSWAP = .TRUE. 6825 6826 IF (SWAP) THEN 6827 CHANGES = .TRUE. 6828 LBL = LABELN(IOP) 6829 LABELN(IOP) = LABELN(IOP+1) 6830 LABELN(IOP+1) = LBL 6831 FRQ = FREQN(IOP) 6832 FREQN(IOP) = FREQN(IOP+1) 6833 FREQN(IOP+1) = FRQ 6834 ISY = ISYMN(IOP) 6835 ISYMN(IOP) = ISYMN(IOP+1) 6836 ISYMN(IOP+1) = ISY 6837 END IF 6838 6839 END DO 6840 END DO 6841 6842*---------------------------------------------------------------------* 6843* search list for vector: 6844*---------------------------------------------------------------------* 6845 DO ILIST = 1, NLIST 6846 6847 LFOUND = .TRUE. 6848 DO IOP = 1, ORDER 6849 IF ( LABELN(IOP) .NE. LABELL(ILIST,IOP) ) LFOUND = .FALSE. 6850 IF ( FREQN(IOP) .NE. FREQL(ILIST,IOP) ) LFOUND = .FALSE. 6851 END DO 6852 6853 IF (LFOUND) THEN 6854 DO IOP = 1, ORDER 6855 ISYMN(IOP) = ISYML(ILIST,IOP) 6856 END DO 6857 IVECLIST = ILIST 6858 IERR = 0 6859 RETURN 6860 END IF 6861 6862 END DO 6863 6864 IF (LOPEN) THEN 6865 NLIST = NLIST + 1 6866 6867 IF (NLIST.GT.MAXLIST) THEN 6868 WRITE(LUPRI,'(4A,/A,I5,A,I5)') 6869 * 'NUMBER OF SPECIFIED VECTORS FOR THE ',TYPE,'-VECTOR LIST ', 6870 * 'EXCEED THE ALLOWED MAXIMUM.', 6871 * 'MAXIMUM =',MAXLIST,' --- SPECIFIED = ',NLIST 6872 CALL QUIT(' IVECLIST: TOO MANY '//TYPE(1:3) 6873 * //'-VECTORS SPECIFIED') 6874 END IF 6875 6876 DO IOP = 1, ORDER 6877 ISYML(NLIST,IOP) = ISYMN(IOP) 6878 FREQL(NLIST,IOP) = FREQN(IOP) 6879 LABELL(NLIST,IOP) = LABELN(IOP) 6880 END DO 6881 6882 IVECLIST = NLIST 6883 IERR = 0 6884 6885 ELSE 6886 6887 WRITE(LUPRI,'(2A,2(3A,1P,D12.5))') 6888 * 'WARNING: ',TYPE,'-VECTOR FOR ', 6889 * (LABELN(IOP), '(', FREQN(IOP), '), ', IOP=1, ORDER) 6890 WRITE(LUPRI,'(A)') ' IS NOT AVAILABLE.' 6891 IVECLIST = -1 6892 6893 END IF 6894 6895 RETURN 6896 END 6897*=====================================================================* 6898*=====================================================================* 6899C /* Deck il4zeta */ 6900 INTEGER FUNCTION IL4ZETA(LBLA,FRQA,ISYA,LBLB,FRQB,ISYB, 6901 * LBLC,FRQC,ISYC,LBLD,FRQD,ISYD) 6902*---------------------------------------------------------------------* 6903C maintain the list of fourth-order lagrangian multiplier vectors 6904C Christof Haettig, maj 97 6905*---------------------------------------------------------------------* 6906 IMPLICIT NONE 6907#include "ccl4rsp.h" 6908 CHARACTER*2 TYPE 6909 INTEGER ORDER 6910 PARAMETER (TYPE='L4', ORDER=4) 6911 6912 INTEGER ISYA, ISYB, ISYC, ISYD 6913 INTEGER ISYM(4) 6914 REAL*8 FRQA,FRQB,FRQC,FRQD 6915 REAL*8 FREQ(4) 6916 CHARACTER*8 LBLA, LBLB, LBLC, LBLD 6917 CHARACTER*8 LABEL(4) 6918 6919* external function: 6920 INTEGER IVECLIST 6921 6922 ISYM(1) = ISYA 6923 ISYM(2) = ISYB 6924 ISYM(3) = ISYC 6925 ISYM(4) = ISYD 6926 6927 FREQ(1) = FRQA 6928 FREQ(2) = FRQB 6929 FREQ(3) = FRQC 6930 FREQ(4) = FRQD 6931 6932 LABEL(1) = LBLA 6933 LABEL(2) = LBLB 6934 LABEL(3) = LBLC 6935 LABEL(4) = LBLD 6936 6937 IL4ZETA = IVECLIST(LABEL,FREQ,ISYM,LBLL4,FRQL4,ISYL4, 6938 & TYPE,ORDER,MAXL4LBL,NL4LBL,LL4OPN) 6939 6940 RETURN 6941 END 6942*=====================================================================* 6943*=====================================================================* 6944C /* Deck ir4tamp */ 6945 INTEGER FUNCTION IR4TAMP(LBLA,FRQA,ISYA,LBLB,FRQB,ISYB, 6946 * LBLC,FRQC,ISYC,LBLD,FRQD,ISYD) 6947*---------------------------------------------------------------------* 6948C maintain the list of fourth-order amplitude response vectors 6949C Christof Haettig, maj 97 6950*---------------------------------------------------------------------* 6951 IMPLICIT NONE 6952#include "ccr4rsp.h" 6953 CHARACTER*2 TYPE 6954 INTEGER ORDER 6955 PARAMETER (TYPE='R4',ORDER=4) 6956 6957 INTEGER ISYA, ISYB, ISYC, ISYD 6958 INTEGER ISYM(4) 6959 REAL*8 FRQA,FRQB,FRQC,FRQD 6960 REAL*8 FREQ(4) 6961 CHARACTER*8 LBLA, LBLB, LBLC, LBLD 6962 CHARACTER*8 LABEL(4) 6963 6964* external function: 6965 INTEGER IVECLIST 6966 6967 ISYM(1) = ISYA 6968 ISYM(2) = ISYB 6969 ISYM(3) = ISYC 6970 ISYM(4) = ISYD 6971 6972 FREQ(1) = FRQA 6973 FREQ(2) = FRQB 6974 FREQ(3) = FRQC 6975 FREQ(4) = FRQD 6976 6977 LABEL(1) = LBLA 6978 LABEL(2) = LBLB 6979 LABEL(3) = LBLC 6980 LABEL(4) = LBLD 6981 6982 IR4TAMP = IVECLIST(LABEL,FREQ,ISYM,LBLR4T,FRQR4T,ISYR4T, 6983 & TYPE,ORDER,MAXT4LBL,NR4TLBL,LR4OPN) 6984 6985 RETURN 6986 END 6987*=====================================================================* 6988*=====================================================================* 6989C /* Deck irhsr4 */ 6990 INTEGER FUNCTION IRHSR4(LBLA,FRQA,ISYA,LBLB,FRQB,ISYB, 6991 * LBLC,FRQC,ISYC,LBLD,FRQD,ISYD) 6992*---------------------------------------------------------------------* 6993C maintain the list of fourth-order amplitude right hand side vectors 6994C Christof Haettig, maj 97 6995*---------------------------------------------------------------------* 6996 IMPLICIT NONE 6997#include "cco4rsp.h" 6998 CHARACTER*2 TYPE 6999 INTEGER ORDER 7000 PARAMETER (TYPE='O4',ORDER=4) 7001 7002 INTEGER ISYA, ISYB, ISYC, ISYD 7003 INTEGER ISYM(4) 7004 REAL*8 FRQA,FRQB,FRQC,FRQD 7005 REAL*8 FREQ(4) 7006 CHARACTER*8 LBLA, LBLB, LBLC, LBLD 7007 CHARACTER*8 LABEL(4) 7008 7009* external function: 7010 INTEGER IVECLIST 7011 7012 ISYM(1) = ISYA 7013 ISYM(2) = ISYB 7014 ISYM(3) = ISYC 7015 ISYM(4) = ISYD 7016 7017 FREQ(1) = FRQA 7018 FREQ(2) = FRQB 7019 FREQ(3) = FRQC 7020 FREQ(4) = FRQD 7021 7022 LABEL(1) = LBLA 7023 LABEL(2) = LBLB 7024 LABEL(3) = LBLC 7025 LABEL(4) = LBLD 7026 7027 IRHSR4 = IVECLIST(LABEL,FREQ,ISYM,LBLO4,FRQO4,ISYO4, 7028 & TYPE,ORDER,MAXO4LBL,NO4LBL,LO4OPN) 7029 7030 RETURN 7031 END 7032*=====================================================================* 7033*=====================================================================* 7034C /* Deck ichi4 */ 7035 INTEGER FUNCTION ICHI4(LBLA,FRQA,ISYA,LBLB,FRQB,ISYB, 7036 * LBLC,FRQC,ISYC,LBLD,FRQD,ISYD) 7037*---------------------------------------------------------------------* 7038C maintain the list of fourth-order chi vectors 7039C Christof Haettig, maj 97 7040*---------------------------------------------------------------------* 7041 IMPLICIT NONE 7042#include "ccx4rsp.h" 7043 CHARACTER*2 TYPE 7044 INTEGER ORDER 7045 PARAMETER (TYPE='X4',ORDER=4) 7046 7047 INTEGER ISYA, ISYB, ISYC, ISYD 7048 INTEGER ISYM(4) 7049 REAL*8 FRQA,FRQB,FRQC,FRQD 7050 REAL*8 FREQ(4) 7051 CHARACTER*8 LBLA, LBLB, LBLC, LBLD 7052 CHARACTER*8 LABEL(4) 7053 7054* external function: 7055 INTEGER IVECLIST 7056 7057 ISYM(1) = ISYA 7058 ISYM(2) = ISYB 7059 ISYM(3) = ISYC 7060 ISYM(4) = ISYD 7061 7062 FREQ(1) = FRQA 7063 FREQ(2) = FRQB 7064 FREQ(3) = FRQC 7065 FREQ(4) = FRQD 7066 7067 LABEL(1) = LBLA 7068 LABEL(2) = LBLB 7069 LABEL(3) = LBLC 7070 LABEL(4) = LBLD 7071 7072 ICHI4 = IVECLIST(LABEL,FREQ,ISYM,LBLX4,FRQX4,ISYX4, 7073 & TYPE,ORDER,MAXX4LBL,NX4LBL,LX4OPN) 7074 7075 RETURN 7076 END 7077*=====================================================================* 7078*=====================================================================* 7079C /* Deck il3zeta */ 7080 INTEGER FUNCTION IL3ZETA(LBLA,FRQA,ISYA,LBLB,FRQB,ISYB, 7081 * LBLC,FRQC,ISYC) 7082*---------------------------------------------------------------------* 7083C maintain the list of third-order lagrangian multiplier vectors 7084C Christof Haettig, maj 97 7085*---------------------------------------------------------------------* 7086 IMPLICIT NONE 7087#include "ccl3rsp.h" 7088 CHARACTER*2 TYPE 7089 INTEGER ORDER 7090 PARAMETER (TYPE='L3', ORDER=3) 7091 7092 INTEGER ISYA, ISYB, ISYC 7093 INTEGER ISYM(ORDER) 7094 REAL*8 FRQA,FRQB,FRQC 7095 REAL*8 FREQ(ORDER) 7096 CHARACTER*8 LBLA, LBLB, LBLC 7097 CHARACTER*8 LABEL(ORDER) 7098 7099* external function: 7100 INTEGER IVECLIST 7101 7102 ISYM(1) = ISYA 7103 ISYM(2) = ISYB 7104 ISYM(3) = ISYC 7105 7106 FREQ(1) = FRQA 7107 FREQ(2) = FRQB 7108 FREQ(3) = FRQC 7109 7110 LABEL(1) = LBLA 7111 LABEL(2) = LBLB 7112 LABEL(3) = LBLC 7113 7114 IL3ZETA = IVECLIST(LABEL,FREQ,ISYM,LBLL3,FRQL3,ISYL3, 7115 & TYPE,ORDER,MAXL3LBL,NL3LBL,LL3OPN) 7116 7117 RETURN 7118 END 7119*=====================================================================* 7120*=====================================================================* 7121C /* Deck ir3tamp */ 7122 INTEGER FUNCTION IR3TAMP(LBLA,FRQA,ISYA,LBLB,FRQB,ISYB, 7123 * LBLC,FRQC,ISYC) 7124*---------------------------------------------------------------------* 7125C maintain the list of fourth-order amplitude response vectors 7126C Christof Haettig, maj 97 7127*---------------------------------------------------------------------* 7128 IMPLICIT NONE 7129#include "ccr3rsp.h" 7130 CHARACTER*2 TYPE 7131 INTEGER ORDER 7132 PARAMETER (TYPE='R3',ORDER=3) 7133 7134 INTEGER ISYA, ISYB, ISYC 7135 INTEGER ISYM(ORDER) 7136 REAL*8 FRQA,FRQB,FRQC 7137 REAL*8 FREQ(ORDER) 7138 CHARACTER*8 LBLA, LBLB, LBLC 7139 CHARACTER*8 LABEL(ORDER) 7140 7141* external function: 7142 INTEGER IVECLIST 7143 7144 ISYM(1) = ISYA 7145 ISYM(2) = ISYB 7146 ISYM(3) = ISYC 7147 7148 FREQ(1) = FRQA 7149 FREQ(2) = FRQB 7150 FREQ(3) = FRQC 7151 7152 LABEL(1) = LBLA 7153 LABEL(2) = LBLB 7154 LABEL(3) = LBLC 7155 7156 IR3TAMP = IVECLIST(LABEL,FREQ,ISYM,LBLR3T,FRQR3T,ISYR3T, 7157 & TYPE,ORDER,MAXT3LBL,NR3TLBL,LR3OPN) 7158 7159 RETURN 7160 END 7161*=====================================================================* 7162*=====================================================================* 7163C /* Deck irhsr3 */ 7164 INTEGER FUNCTION IRHSR3(LBLA,FRQA,ISYA,LBLB,FRQB,ISYB, 7165 * LBLC,FRQC,ISYC) 7166*---------------------------------------------------------------------* 7167C maintain the list of third-order amplitude right hand side vectors 7168C Christof Haettig, maj 97 7169*---------------------------------------------------------------------* 7170 IMPLICIT NONE 7171#include "cco3rsp.h" 7172 CHARACTER*2 TYPE 7173 INTEGER ORDER 7174 PARAMETER (TYPE='O3',ORDER=3) 7175 7176 INTEGER ISYA, ISYB, ISYC 7177 INTEGER ISYM(ORDER) 7178 REAL*8 FRQA,FRQB,FRQC 7179 REAL*8 FREQ(ORDER) 7180 CHARACTER*8 LBLA, LBLB, LBLC 7181 CHARACTER*8 LABEL(ORDER) 7182 7183* external function: 7184 INTEGER IVECLIST 7185 7186 ISYM(1) = ISYA 7187 ISYM(2) = ISYB 7188 ISYM(3) = ISYC 7189 7190 FREQ(1) = FRQA 7191 FREQ(2) = FRQB 7192 FREQ(3) = FRQC 7193 7194 LABEL(1) = LBLA 7195 LABEL(2) = LBLB 7196 LABEL(3) = LBLC 7197 7198 IRHSR3 = IVECLIST(LABEL,FREQ,ISYM,LBLO3,FRQO3,ISYO3, 7199 & TYPE,ORDER,MAXO3LBL,NO3LBL,LO3OPN) 7200 7201 RETURN 7202 END 7203*=====================================================================* 7204*=====================================================================* 7205C /* Deck ichi3 */ 7206 INTEGER FUNCTION ICHI3(LBLA,FRQA,ISYA,LBLB,FRQB,ISYB, 7207 * LBLC,FRQC,ISYC) 7208*---------------------------------------------------------------------* 7209C maintain the list of fourth-order chi vectors 7210C Christof Haettig, maj 97 7211*---------------------------------------------------------------------* 7212 IMPLICIT NONE 7213#include "ccx3rsp.h" 7214 CHARACTER*2 TYPE 7215 INTEGER ORDER 7216 PARAMETER (TYPE='X3',ORDER=3) 7217 7218 INTEGER ISYA, ISYB, ISYC 7219 INTEGER ISYM(ORDER) 7220 REAL*8 FRQA,FRQB,FRQC 7221 REAL*8 FREQ(ORDER) 7222 CHARACTER*8 LBLA, LBLB, LBLC 7223 CHARACTER*8 LABEL(ORDER) 7224 7225* external function: 7226 INTEGER IVECLIST 7227 7228 ISYM(1) = ISYA 7229 ISYM(2) = ISYB 7230 ISYM(3) = ISYC 7231 7232 FREQ(1) = FRQA 7233 FREQ(2) = FRQB 7234 FREQ(3) = FRQC 7235 7236 LABEL(1) = LBLA 7237 LABEL(2) = LBLB 7238 LABEL(3) = LBLC 7239 7240 ICHI3 = IVECLIST(LABEL,FREQ,ISYM,LBLX3,FRQX3,ISYX3, 7241 & TYPE,ORDER,MAXX3LBL,NX3LBL,LX3OPN) 7242 7243 RETURN 7244 END 7245*=====================================================================* 7246*=====================================================================* 7247C /* Deck ier1amp */ 7248 INTEGER FUNCTION IER1AMP(IEXCI, EIGVNEW,ISYMS, 7249 * NEWLBLA,FRQANEW,ISYMA, LPROJ ) 7250*---------------------------------------------------------------------* 7251C 7252C maintain the list of first-order right excited state vectors: 7253C 7254C if vector is on the list return list index and set ISYMS,ISYMA 7255C if vector is NOT on the list: 7256C LER1OPN=.true. --> extend list, and return index 7257C LER1OPN=.false. --> return -1 7258C 7259C Christof Haettig, july 97 7260*---------------------------------------------------------------------* 7261 IMPLICIT NONE 7262#include "ccer1rsp.h" 7263#include "priunit.h" 7264C 7265 LOGICAL LPROJ, LPROJ1 7266 INTEGER ISYMA, ISYMS, IEXCI 7267 REAL*8 FRQANEW,EIGVNEW,TOL 7268 7269 PARAMETER(TOL=1.0D-12) 7270 7271 CHARACTER*8 NEWLBLA 7272 INTEGER I 7273 7274 LPROJ1 = LPROJ 7275 7276* for non-total symmetric operators we can ignore projection 7277 IF (ISYMA.NE.1) LPROJ1 = .FALSE. 7278 7279 DO I = 1,NER1LBL 7280 IF ( (NEWLBLA.EQ.LBLER1(I)) .AND. (IEXCI.EQ.ISTER1(I)) 7281 * .AND. (ABS(FRQANEW-FRQER1(I)).LT.TOL) 7282 * .AND. (ABS(EIGVNEW-EIGER1(I)).LT.TOL) 7283 * .AND. (LPROJ1.EQV.LPRER1(I)) 7284 * ) THEN 7285 IER1AMP = I 7286 ISYMS = ISYSER1(IER1AMP) 7287 ISYMA = ISYOER1(IER1AMP) 7288 RETURN 7289 END IF 7290 END DO 7291 7292 IF (LER1OPN) THEN 7293 NER1LBL = NER1LBL + 1 7294 7295 IF (NER1LBL.GT.MAXER1LBL) THEN 7296 WRITE(LUPRI,'(A,/A,I5,A,I5)') 7297 * '@ NUMBER OF SPECIFIED VECTORS EXCEED THE MAXIMUM ALLOWED', 7298 * '@ MAXER1LBL =',MAXER1LBL,' NER1LBL= ',NER1LBL 7299 CALL QUIT(' IER1AMP: TOO MANY VECTORS SPECIFIED') 7300 END IF 7301 7302 ISTER1(NER1LBL) = IEXCI 7303 EIGER1(NER1LBL) = EIGVNEW 7304 ISYSER1(NER1LBL)= ISYMS 7305 LBLER1(NER1LBL) = NEWLBLA 7306 FRQER1(NER1LBL) = FRQANEW 7307 ISYOER1(NER1LBL)= ISYMA 7308 LPRER1(NER1LBL) = LPROJ1 7309 IER1AMP = NER1LBL 7310 7311 ELSE 7312 WRITE(LUPRI,'(A,I3,A,1P,D12.5,3A,1P,D12.5,2A)') 7313 * '@ WARNING: ER1 VECTOR FOR',IEXCI,'(',EIGVNEW,'), ', 7314 * NEWLBLA,'(',FRQANEW,')', 7315 * ' IS NOT AVAILABLE.' 7316 IER1AMP = -1 7317 END IF 7318 7319 RETURN 7320 END 7321*=====================================================================* 7322*=====================================================================* 7323C /* Deck ier2amp */ 7324 INTEGER FUNCTION IER2AMP(IEXCI, EIGVNEW,ISYMS, 7325 * NEWLBLA,FRQANEW,ISYMA, 7326 * NEWLBLB,FRQBNEW,ISYMB, LPROJ ) 7327*---------------------------------------------------------------------* 7328C 7329C maintain the list of second-order right excited state vectors: 7330C 7331C if vector is on the list return list index and set symmetries 7332C if vector is NOT on the list: 7333C LER2OPN=.true. --> extend list, and return index 7334C LER2OPN=.false. --> return -1 7335C 7336C Christof Haettig, july 97 7337*---------------------------------------------------------------------* 7338 IMPLICIT NONE 7339#include "ccer2rsp.h" 7340#include "priunit.h" 7341C 7342 LOGICAL LPROJ, LPROJ1 7343 INTEGER ISYMA, ISYMB, ISYMS, IEXCI 7344 REAL*8 FRQANEW,FRQBNEW,EIGVNEW,TOL 7345 7346 PARAMETER(TOL=1.0D-12) 7347 7348 CHARACTER*8 NEWLBLA, NEWLBLB 7349 INTEGER I 7350 7351 LPROJ1 = LPROJ 7352 7353* for non-total symmetric operators we ignore projection 7354 IF (ISYMA.NE.1 .AND. ISYMB.NE.1 .AND. ISYMB.NE.ISYMA) THEN 7355 LPROJ1 = .FALSE. 7356 END IF 7357 7358 DO I = 1,NER2LBL 7359 IF ( (IEXCI.EQ.ISTER2(I)) .AND. (ABS(EIGVNEW-EIGER2(I)).LT.TOL) 7360 * .AND. (NEWLBLA.EQ.LBLER2(I,1)) 7361 * .AND. (ABS(FRQANEW-FRQER2(I,1)).LT.TOL) 7362 * .AND. (NEWLBLA.EQ.LBLER2(I,2)) 7363 * .AND. (ABS(FRQBNEW-FRQER2(I,2)).LT.TOL) 7364 * .AND. (LPROJ1.EQV.LPRER2(I)) 7365 * ) THEN 7366 IER2AMP = I 7367 ISYMS = ISYSER2(IER2AMP) 7368 ISYMA = ISYOER2(IER2AMP,1) 7369 ISYMB = ISYOER2(IER2AMP,2) 7370 RETURN 7371 END IF 7372 IF ( (IEXCI.EQ.ISTER2(I)) .AND. (ABS(EIGVNEW-EIGER2(I)).LT.TOL) 7373 * .AND. (NEWLBLA.EQ.LBLER2(I,2)) 7374 * .AND. (ABS(FRQANEW-FRQER2(I,2)).LT.TOL) 7375 * .AND. (NEWLBLA.EQ.LBLER2(I,1)) 7376 * .AND. (ABS(FRQBNEW-FRQER2(I,1)).LT.TOL) 7377 * .AND. (LPROJ1.EQV.LPRER2(I)) 7378 * ) THEN 7379 IER2AMP = I 7380 ISYMS = ISYSER2(IER2AMP) 7381 ISYMA = ISYOER2(IER2AMP,2) 7382 ISYMB = ISYOER2(IER2AMP,1) 7383 RETURN 7384 END IF 7385 END DO 7386 7387 IF (LER2OPN) THEN 7388 NER2LBL = NER2LBL + 1 7389 7390 IF (NER2LBL.GT.MAXER2LBL) THEN 7391 WRITE(LUPRI,'(A,/A,I5,A,I5)') 7392 * '@ NUMBER OF SPECIFIED VECTORS EXCEED THE MAXIMUM ALLOWED', 7393 * '@ MAXER2LBL =',MAXER2LBL,' NER2LBL= ',NER2LBL 7394 CALL QUIT(' IER2AMP: TOO MANY VECTORS SPECIFIED') 7395 END IF 7396 7397 ISTER2(NER2LBL) = IEXCI 7398 EIGER2(NER2LBL) = EIGVNEW 7399 ISYSER2(NER2LBL) = ISYMS 7400 LBLER2(NER2LBL,1) = NEWLBLA 7401 FRQER2(NER2LBL,1) = FRQANEW 7402 ISYOER2(NER2LBL,1)= ISYMA 7403 LBLER2(NER2LBL,2) = NEWLBLB 7404 FRQER2(NER2LBL,2) = FRQBNEW 7405 ISYOER2(NER2LBL,2)= ISYMB 7406 LPRER2(NER2LBL) = LPROJ1 7407 IER2AMP = NER2LBL 7408 7409 ELSE 7410 WRITE(LUPRI,'(A,I3,A,1P,D12.5,2(3A,1P,D12.5),2A)') 7411 * '@ WARNING: ER2 VECTOR FOR',IEXCI,'(',EIGVNEW,'), ', 7412 * NEWLBLA,'(',FRQANEW,')', NEWLBLB,'(',FRQBNEW,')', 7413 * ' IS NOT AVAILABLE.' 7414 IER2AMP = -1 7415 END IF 7416 7417 RETURN 7418 END 7419*=====================================================================* 7420*=====================================================================* 7421C /* Deck iel1amp */ 7422 INTEGER FUNCTION IEL1AMP(IEXCI, EIGVNEW,ISYMS, 7423 * NEWLBLA,FRQANEW,ISYMA,LORXA,LPROJ ) 7424*---------------------------------------------------------------------* 7425C 7426C maintain the list of first-order right excited state vectors: 7427C 7428C if vector is on the list return list index and set ISYMS,ISYMA 7429C if vector is NOT on the list: 7430C LEL1OPN=.true. --> extend list, and return index 7431C LEL1OPN=.false. --> return -1 7432C 7433C Christof Haettig, july 97 7434C LORXA flag introduced, Sonia Coriani april 2000 7435*---------------------------------------------------------------------* 7436 IMPLICIT NONE 7437#include "ccel1rsp.h" 7438#include "priunit.h" 7439C 7440 LOGICAL LPROJ, LPROJ1, LORXA 7441 INTEGER ISYMA, ISYMS, IEXCI 7442 REAL*8 FRQANEW,EIGVNEW,TOL 7443 7444 PARAMETER(TOL=1.0D-12) 7445 7446 CHARACTER*8 NEWLBLA 7447 INTEGER I 7448 7449 LPROJ1 = LPROJ 7450 7451* for non-total symmetric operators we can ignore projection 7452 IF (ISYMA.NE.1) LPROJ1 = .FALSE. 7453 7454 DO I = 1,NEL1LBL 7455 IF ( (NEWLBLA.EQ.LBLEL1(I)) .AND. (IEXCI.EQ.ISTEL1(I)) 7456 * .AND. (LORXA .EQV. LORXEL1(I)) 7457 * .AND. (ABS(FRQANEW-FRQEL1(I)).LT.TOL) 7458 * .AND. (ABS(EIGVNEW-EIGEL1(I)).LT.TOL) 7459 * .AND. (LPROJ1.EQV.LPREL1(I)) 7460 * ) THEN 7461 IEL1AMP = I 7462 ISYMS = ISYSEL1(IEL1AMP) 7463 ISYMA = ISYOEL1(IEL1AMP) 7464 RETURN 7465 END IF 7466 END DO 7467 7468 IF (LEL1OPN) THEN 7469 NEL1LBL = NEL1LBL + 1 7470 7471 IF (NEL1LBL.GT.MAXEL1LBL) THEN 7472 WRITE(LUPRI,'(A,/A,I5,A,I5)') 7473 * '@ NUMBER OF SPECIFIED VECTORS EXCEED THE MAXIMUM ALLOWED', 7474 * '@ MAXEL1LBL =',MAXEL1LBL,' NEL1LBL= ',NEL1LBL 7475 CALL QUIT(' IEL1AMP: TOO MANY VECTORS SPECIFIED') 7476 END IF 7477 7478 ISTEL1(NEL1LBL) = IEXCI 7479 EIGEL1(NEL1LBL) = EIGVNEW 7480 ISYSEL1(NEL1LBL)= ISYMS 7481 LBLEL1(NEL1LBL) = NEWLBLA 7482 LORXEL1(NEL1LBL) = LORXA 7483 FRQEL1(NEL1LBL) = FRQANEW 7484 ISYOEL1(NEL1LBL)= ISYMA 7485 LPREL1(NEL1LBL) = LPROJ1 7486 IEL1AMP = NEL1LBL 7487 7488 ELSE 7489 WRITE(LUPRI,'(A,I3,A,1P,D12.5,3A,L2,A,1P,D12.5,2A)') 7490 & '@ WARNING: EL1 VECTOR FOR',IEXCI,'(',EIGVNEW,'), ', 7491 & NEWLBLA,'(',LORXA,',',FRQANEW,')', 7492 & ' IS NOT AVAILABLE.' 7493 IEL1AMP = -1 7494 END IF 7495 7496 RETURN 7497 END 7498*=====================================================================* 7499*=====================================================================* 7500C /* Deck iel2amp */ 7501 INTEGER FUNCTION IEL2AMP(IEXCI, EIGVNEW,ISYMS, 7502 * NEWLBLA,FRQANEW,ISYMA, 7503 * NEWLBLB,FRQBNEW,ISYMB,LPROJ ) 7504*---------------------------------------------------------------------* 7505C 7506C maintain the list of second-order left excited state vectors: 7507C 7508C if vector is on the list return list index and set symmetries 7509C if vector is NOT on the list: 7510C LEL2OPN=.true. --> extend list, and return index 7511C LEL2OPN=.false. --> return -1 7512C 7513C Christof Haettig, july 97 7514*---------------------------------------------------------------------* 7515 IMPLICIT NONE 7516#include "ccel2rsp.h" 7517#include "priunit.h" 7518C 7519 LOGICAL LPROJ, LPROJ1 7520 INTEGER ISYMA, ISYMB, ISYMS, IEXCI 7521 REAL*8 FRQANEW,FRQBNEW,EIGVNEW,TOL 7522 7523 PARAMETER(TOL=1.0D-12) 7524 7525 CHARACTER*8 NEWLBLA, NEWLBLB 7526 INTEGER I 7527 7528 LPROJ1 = LPROJ 7529 7530* for non-total symmetric operators we ignore projection 7531 IF (ISYMA.NE.1 .AND. ISYMB.NE.1 .AND. ISYMB.NE.ISYMA) THEN 7532 LPROJ1 = .FALSE. 7533 END IF 7534 7535 DO I = 1,NEL2LBL 7536 IF ((IEXCI.EQ.ISTEL2(I)) .AND. (ABS(EIGVNEW-EIGEL2(I)).LT.TOL) 7537 * .AND. (NEWLBLA.EQ.LBLEL2(I,1)) 7538 * .AND. (ABS(FRQANEW-FRQEL2(I,1)).LT.TOL) 7539 * .AND. (NEWLBLA.EQ.LBLEL2(I,2)) 7540 * .AND. (ABS(FRQBNEW-FRQEL2(I,2)).LT.TOL) 7541 * .AND. (LPROJ1.EQV.LPREL2(I)) 7542 * ) THEN 7543 IEL2AMP = I 7544 ISYMS = ISYSEL2(IEL2AMP) 7545 ISYMA = ISYOEL2(IEL2AMP,1) 7546 ISYMB = ISYOEL2(IEL2AMP,2) 7547 RETURN 7548 END IF 7549 IF ((IEXCI.EQ.ISTEL2(I)) .AND. (ABS(EIGVNEW-EIGEL2(I)).LT.TOL) 7550 * .AND. (NEWLBLA.EQ.LBLEL2(I,2)) 7551 * .AND. (ABS(FRQANEW-FRQEL2(I,2)).LT.TOL) 7552 * .AND. (NEWLBLA.EQ.LBLEL2(I,1)) 7553 * .AND. (ABS(FRQBNEW-FRQEL2(I,1)).LT.TOL) 7554 * .AND. (LPROJ1.EQV.LPREL2(I)) 7555 * ) THEN 7556 IEL2AMP = I 7557 ISYMS = ISYSEL2(IEL2AMP) 7558 ISYMA = ISYOEL2(IEL2AMP,2) 7559 ISYMB = ISYOEL2(IEL2AMP,1) 7560 RETURN 7561 END IF 7562 END DO 7563 7564 IF (LEL2OPN) THEN 7565 NEL2LBL = NEL2LBL + 1 7566 7567 IF (NEL2LBL.GT.MAXEL2LBL) THEN 7568 WRITE(LUPRI,'(A,/A,I5,A,I5)') 7569 * '@ NUMBER OF SPECIFIED VECTORS EXCEED THE MAXIMUM ALLOWED', 7570 * '@ MAXEL2LBL =',MAXEL2LBL,' NEL2LBL= ',NEL2LBL 7571 CALL QUIT(' IEL2AMP: TOO MANY VECTORS SPECIFIED') 7572 END IF 7573 7574 ISTEL2(NEL2LBL) = IEXCI 7575 EIGEL2(NEL2LBL) = EIGVNEW 7576 ISYSEL2(NEL2LBL) = ISYMS 7577 LBLEL2(NEL2LBL,1) = NEWLBLA 7578 FRQEL2(NEL2LBL,1) = FRQANEW 7579 ISYOEL2(NEL2LBL,1)= ISYMA 7580 LBLEL2(NEL2LBL,2) = NEWLBLB 7581 FRQEL2(NEL2LBL,2) = FRQBNEW 7582 ISYOEL2(NEL2LBL,2)= ISYMB 7583 LPREL2(NEL2LBL) = LPROJ1 7584 IEL2AMP = NEL2LBL 7585 7586 ELSE 7587 WRITE(LUPRI,'(A,I3,A,1P,D12.5,2(3A,1P,D12.5),2A)') 7588 * '@ WARNING: EL2 VECTOR FOR',IEXCI,'(',EIGVNEW,'), ', 7589 * NEWLBLA,'(',FRQANEW,')', NEWLBLB,'(',FRQBNEW,')', 7590 * ' IS NOT AVAILABLE.' 7591 IEL2AMP = -1 7592 END IF 7593 7594 RETURN 7595 END 7596*=====================================================================* 7597C /* Deck In2amp */ 7598 INTEGER FUNCTION IN2AMP(IIEX,FRQINEW,ISYMI, 7599 * IFEX,FRQFNEW,ISYMF ) 7600*---------------------------------------------------------------------* 7601C 7602C maintain the list of N(if)(omegai,omegaf) multipliers for calculation 7603C of quadratic response function residues. 7604C 7605C if vector is on the list return list index and set ISYMI,ISYMF 7606C if vector is NOT on the list: 7607C LN2OPN=.true. --> extend list, and return index 7608C LN2OPN=.false. --> return -1 7609C 7610C Ove Christiansen, April 97 7611*---------------------------------------------------------------------* 7612 IMPLICIT NONE 7613#include "ccn2rsp.h" 7614#include "priunit.h" 7615C 7616 INTEGER ISYMI, ISYMF 7617 REAL*8 FRQINEW,FRQFNEW,TOL 7618 7619 PARAMETER(TOL=1.0D-12) 7620 7621 INTEGER I,IIEX,IFEX 7622 7623 DO I = 1,NQRN2 7624 IF (IIEX.EQ.IIN2(I).AND. IFEX.EQ.IFN2(I) 7625 * .AND. (ABS(FRQINEW-FRQIN2(I)).LT.TOL) 7626 * .AND. (ABS(FRQFNEW-FRQFN2(I)).LT.TOL)) THEN 7627 IN2AMP = I 7628 ISYMI = ISYIN2(IN2AMP) 7629 ISYMF = ISYFN2(IN2AMP) 7630 RETURN 7631 END IF 7632 IF (IFEX.EQ.IIN2(I).AND. IIEX.EQ.IFN2(I) 7633 * .AND. (ABS(FRQFNEW-FRQIN2(I)).LT.TOL) 7634 * .AND. (ABS(FRQINEW-FRQFN2(I)).LT.TOL)) THEN 7635 IN2AMP = I 7636 ISYMF = ISYIN2(IN2AMP) 7637 ISYMI = ISYFN2(IN2AMP) 7638 RETURN 7639 END IF 7640 END DO 7641 7642 IF (LN2OPN) THEN 7643 NQRN2 = NQRN2 + 1 7644 7645 IF (NQRN2 .GT.MAXQRN2 ) THEN 7646 WRITE(LUPRI,'(A,/A,I5,A,I5)') 7647 * '@ NUMBER OF SPECIFIED VECTORS EXCEED THE MAXIMUM ALLOWED', 7648 * '@ MAXQRN2 =',MAXQRN2 ,' NQRN2 = ',NQRN2 7649 CALL QUIT(' IN2AMP: TOO MANY VECTORS SPECIFIED') 7650 END IF 7651 7652 IIN2(NQRN2 ) = IIEX 7653 IFN2(NQRN2 ) = IFEX 7654 FRQIN2(NQRN2 ) = FRQINEW 7655 FRQFN2(NQRN2 ) = FRQFNEW 7656 ISYIN2(NQRN2 ) = ISYMI 7657 ISYFN2(NQRN2 ) = ISYMF 7658 IN2AMP = NQRN2 7659 7660 ELSE 7661 WRITE(LUPRI,'(1A,I3,A,1P,D12.5,A,I3,A,1P,D12.5,2A)') 7662 * '@ WARNING: N2 VECTOR FOR ',IIEX,'(',FRQINEW,'), ', 7663 * IFEX,'(',FRQFNEW,')', 7664 * ' IS NOT AVAILABLE.' 7665 IN2AMP = -1 7666 END IF 7667 7668 RETURN 7669 END 7670*=====================================================================* 7671*=====================================================================* 7672C /* Deck ICL2AMP */ 7673 INTEGER FUNCTION ICL2AMP(NEWLBLA,ICAUA,ISYMA, 7674 * NEWLBLB,ICAUB,ISYMB ) 7675*---------------------------------------------------------------------* 7676C 7677C maintain the list of second-order left Cauchy vectors: 7678C 7679C if vector is on the list return list index and set ISYMA,ISYMB 7680C if vector is NOT on the list: 7681C LCL2OPN=.true. --> extend list, and return index 7682C LCL2OPN=.false. --> return -1 7683C 7684C Christof Haettig, March 98 7685*---------------------------------------------------------------------* 7686 IMPLICIT NONE 7687#include "cccl2rsp.h" 7688#include "priunit.h" 7689C 7690 LOGICAL LOCDBG 7691 PARAMETER (LOCDBG = .FALSE.) 7692C 7693 CHARACTER*8 NEWLBLA, NEWLBLB 7694 INTEGER ICAUA, ICAUB, I 7695 INTEGER ISYMA, ISYMB 7696 7697 IF (LOCDBG) THEN 7698 WRITE (LUPRI,*) '[DEBUG] ICL2AMP> entered with input:' 7699 WRITE (LUPRI,*) '[DEBUG] ICL2AMP> LABELS :',NEWLBLA,NEWLBLB 7700 WRITE (LUPRI,*) '[DEBUG] ICL2AMP> SYMMETRIES:',ISYMA,ISYMB 7701 WRITE (LUPRI,*) '[DEBUG] ICL2AMP> CAUCHY ORD:',ICAUA,ICAUB 7702 END IF 7703 7704 DO I = 1,NCL2lBL 7705 IF ( NEWLBLA.EQ.LBLCL2(I,1) .AND. NEWLBLB.EQ.LBLCL2(I,2) 7706 * .AND. ICAUA.EQ.ICL2CAU(I,1) .AND. ICAUB.EQ.ICL2CAU(I,2) 7707 * ) THEN 7708 ICL2AMP = I 7709 ISYMA = ISYCL2(ICL2AMP,1) 7710 ISYMB = ISYCL2(ICL2AMP,2) 7711 IF (LOCDBG) THEN 7712 WRITE (LUPRI,*) 7713 & '[DEBUG] ICL2AMP> entry found on the list:' 7714 WRITE (LUPRI,*) '[DEBUG] ICL2AMP> INDEX :',ICL2AMP 7715 WRITE (LUPRI,*) '[DEBUG] ICL2AMP> SYMMETRIES:',ISYMA,ISYMB 7716 END IF 7717 RETURN 7718 END IF 7719 IF ( NEWLBLA.EQ.LBLCL2(I,2) .AND. NEWLBLB.EQ.LBLCL2(I,1) 7720 * .AND. ICAUA.EQ.ICL2CAU(I,2) .AND. ICAUB.EQ.ICL2CAU(I,1) 7721 * ) THEN 7722 ICL2AMP = I 7723 ISYMB = ISYCL2(ICL2AMP,1) 7724 ISYMA = ISYCL2(ICL2AMP,2) 7725 IF (LOCDBG) THEN 7726 WRITE (LUPRI,*) 7727 & '[DEBUG] ICL2AMP> entry found on the list:' 7728 WRITE (LUPRI,*) '[DEBUG] ICL2AMP> INDEX :',ICL2AMP 7729 WRITE (LUPRI,*) '[DEBUG] ICL2AMP> SYMMETRIES:',ISYMA,ISYMB 7730 END IF 7731 RETURN 7732 END IF 7733 END DO 7734 7735 IF (LCL2OPN) THEN 7736 NCL2lBL = NCL2lBL + 1 7737 7738 IF (NCL2lBL.GT.MAXCL2LBL) THEN 7739 WRITE(LUPRI,'(A,/A,I5,A,I5)') 7740 * '@ NUMBER OF SPECIFIED VECTORS EXCEED THE MAXIMUM ALLOWED', 7741 * '@ MAXCL2LBL =',MAXCL2LBL,' NCL2lBL= ',NCL2lBL 7742 CALL QUIT(' ICL2AMP: TOO MANY VECTORS SPECIFIED') 7743 END IF 7744 7745 LBLCL2(NCL2lBL,1) = NEWLBLA 7746 LBLCL2(NCL2lBL,2) = NEWLBLB 7747 ICL2CAU(NCL2lBL,1) = ICAUA 7748 ICL2CAU(NCL2lBL,2) = ICAUB 7749 ISYCL2(NCL2lBL,1) = ISYMA 7750 ISYCL2(NCL2lBL,2) = ISYMB 7751 ICL2AMP = NCL2lBL 7752 7753 IF (LOCDBG) THEN 7754 WRITE (LUPRI,*) '[DEBUG] ICL2AMP> put entry on the list:' 7755 WRITE (LUPRI,*) '[DEBUG] ICL2AMP> INDEX :',ICL2AMP 7756 END IF 7757 ELSE 7758 WRITE(LUPRI,'(3A,I2,3A,I2,2A)') 7759 * '@ WARNING: CL2 VECTOR FOR ',NEWLBLA,'(',ICAUA,'), ', 7760 * NEWLBLB,'(',ICAUB,')', 7761 * ' IS NOT AVAILABLE.' 7762 ICL2AMP = -1 7763 END IF 7764 7765 RETURN 7766 END 7767*=====================================================================* 7768*=====================================================================* 7769C /* Deck icr2amp */ 7770 INTEGER FUNCTION ICR2AMP(NEWLBLA,ICAUA,ISYMA, 7771 * NEWLBLB,ICAUB,ISYMB ) 7772*---------------------------------------------------------------------* 7773C 7774C maintain the list of second-order right Cauchy vectors: 7775C 7776C if vector is on the list return list index and set ISYMA,ISYMB 7777C if vector is NOT on the list: 7778C LCR2OPN=.true. --> extend list, and return index 7779C LCR2OPN=.false. --> return -1 7780C 7781C Christof Haettig, March 98 7782*---------------------------------------------------------------------* 7783 IMPLICIT NONE 7784#include "cccr2rsp.h" 7785#include "priunit.h" 7786C 7787 LOGICAL LOCDBG 7788 PARAMETER (LOCDBG = .FALSE.) 7789C 7790 CHARACTER*8 NEWLBLA, NEWLBLB 7791 INTEGER ICAUA, ICAUB, I 7792 INTEGER ISYMA, ISYMB 7793 7794 IF (LOCDBG) THEN 7795 WRITE (LUPRI,*) '[DEBUG] ICR2AMP> entered with input:' 7796 WRITE (LUPRI,*) '[DEBUG] ICR2AMP> LABELS :',NEWLBLA,NEWLBLB 7797 WRITE (LUPRI,*) '[DEBUG] ICR2AMP> SYMMETRIES:',ISYMA,ISYMB 7798 WRITE (LUPRI,*) '[DEBUG] ICR2AMP> CAUCHY ORD:',ICAUA,ICAUB 7799 END IF 7800 7801 DO I = 1,NCR2LBL 7802 IF ( NEWLBLA.EQ.LBLCR2(I,1) .AND. NEWLBLB.EQ.LBLCR2(I,2) 7803 * .AND. ICAUA.EQ.ICR2CAU(I,1) .AND. ICAUB.EQ.ICR2CAU(I,2) 7804 * ) THEN 7805 ICR2AMP = I 7806 ISYMA = ISYCR2(ICR2AMP,1) 7807 ISYMB = ISYCR2(ICR2AMP,2) 7808 IF (LOCDBG) THEN 7809 WRITE (LUPRI,*) 7810 & '[DEBUG] ICR2AMP> entry found on the list:' 7811 WRITE (LUPRI,*) '[DEBUG] ICR2AMP> INDEX :',ICR2AMP 7812 WRITE (LUPRI,*) '[DEBUG] ICR2AMP> SYMMETRIES:',ISYMA,ISYMB 7813 END IF 7814 RETURN 7815 END IF 7816 IF ( NEWLBLA.EQ.LBLCR2(I,2) .AND. NEWLBLB.EQ.LBLCR2(I,1) 7817 * .AND. ICAUA.EQ.ICR2CAU(I,2) .AND. ICAUB.EQ.ICR2CAU(I,1) 7818 * ) THEN 7819 ICR2AMP = I 7820 ISYMB = ISYCR2(ICR2AMP,1) 7821 ISYMA = ISYCR2(ICR2AMP,2) 7822 IF (LOCDBG) THEN 7823 WRITE (LUPRI,*) 7824 & '[DEBUG] ICR2AMP> entry found on the list:' 7825 WRITE (LUPRI,*) '[DEBUG] ICR2AMP> INDEX :',ICR2AMP 7826 WRITE (LUPRI,*) '[DEBUG] ICR2AMP> SYMMETRIES:',ISYMA,ISYMB 7827 END IF 7828 RETURN 7829 END IF 7830 END DO 7831 7832 IF (LCR2OPN) THEN 7833 NCR2LBL = NCR2LBL + 1 7834 7835 IF (NCR2LBL.GT.MAXCR2LBL) THEN 7836 WRITE(LUPRI,'(A,/A,I5,A,I5)') 7837 * '@ NUMBER OF SPECIFIED VECTORS EXCEED THE MAXIMUM ALLOWED', 7838 * '@ MAXCR2LBL =',MAXCR2LBL,' NCR2LBL= ',NCR2LBL 7839 CALL QUIT(' ICR2AMP: TOO MANY VECTORS SPECIFIED') 7840 END IF 7841 7842 LBLCR2(NCR2LBL,1) = NEWLBLA 7843 LBLCR2(NCR2LBL,2) = NEWLBLB 7844 ICR2CAU(NCR2LBL,1) = ICAUA 7845 ICR2CAU(NCR2LBL,2) = ICAUB 7846 ISYCR2(NCR2LBL,1) = ISYMA 7847 ISYCR2(NCR2LBL,2) = ISYMB 7848 ICR2AMP = NCR2LBL 7849 7850 IF (LOCDBG) THEN 7851 WRITE (LUPRI,*) '[DEBUG] ICR2AMP> put entry on the list:' 7852 WRITE (LUPRI,*) '[DEBUG] ICR2AMP> INDEX :',ICR2AMP 7853 END IF 7854 ELSE 7855 WRITE(LUPRI,'(3A,I2,3A,I2,2A)') 7856 * '@ WARNING: CR2 VECTOR FOR ',NEWLBLA,'(',ICAUA,'), ', 7857 * NEWLBLB,'(',ICAUB,')', 7858 * ' IS NOT AVAILABLE.' 7859 ICR2AMP = -1 7860 END IF 7861 7862 RETURN 7863 END 7864*=====================================================================* 7865*=====================================================================* 7866C /* Deck IETACL2 */ 7867 INTEGER FUNCTION IETACL2(NEWLBLA,ICAUA,ISYMA, 7868 * NEWLBLB,ICAUB,ISYMB ) 7869*---------------------------------------------------------------------* 7870C 7871C maintain the list of second-order right Cauchy vectors: 7872C 7873C if vector is on the list return list index and set ISYMA,ISYMB 7874C if vector is NOT on the list: 7875C LCX2OPN=.true. --> extend list, and return index 7876C LCX2OPN=.false. --> return -1 7877C 7878C Christof Haettig, March 98 7879*---------------------------------------------------------------------* 7880 IMPLICIT NONE 7881#include "cccx2rsp.h" 7882#include "priunit.h" 7883C 7884 LOGICAL LOCDBG 7885 PARAMETER (LOCDBG = .FALSE.) 7886C 7887 CHARACTER*8 NEWLBLA, NEWLBLB 7888 INTEGER ICAUA, ICAUB, I 7889 INTEGER ISYMA, ISYMB 7890 7891 IF (LOCDBG) THEN 7892 WRITE (LUPRI,*) '[DEBUG] IETACL2> entered with input:' 7893 WRITE (LUPRI,*) '[DEBUG] IETACL2> LABELS :',NEWLBLA,NEWLBLB 7894 WRITE (LUPRI,*) '[DEBUG] IETACL2> SYMMETRIES:',ISYMA,ISYMB 7895 WRITE (LUPRI,*) '[DEBUG] IETACL2> CAUCHY ORD:',ICAUA,ICAUB 7896 END IF 7897 7898 DO I = 1,NCX2LBL 7899 IF ( NEWLBLA.EQ.LBLCX2(I,1) .AND. NEWLBLB.EQ.LBLCX2(I,2) 7900 * .AND. ICAUA.EQ.ICX2CAU(I,1) .AND. ICAUB.EQ.ICX2CAU(I,2) 7901 * ) THEN 7902 IETACL2 = I 7903 ISYMA = ISYCX2(IETACL2,1) 7904 ISYMB = ISYCX2(IETACL2,2) 7905 IF (LOCDBG) THEN 7906 WRITE (LUPRI,*) 7907 & '[DEBUG] IETACL2> entry found on the list:' 7908 WRITE (LUPRI,*) '[DEBUG] IETACL2> INDEX :',IETACL2 7909 WRITE (LUPRI,*) '[DEBUG] IETACL2> SYMMETRIES:',ISYMA,ISYMB 7910 END IF 7911 RETURN 7912 END IF 7913 IF ( NEWLBLA.EQ.LBLCX2(I,2) .AND. NEWLBLB.EQ.LBLCX2(I,1) 7914 * .AND. ICAUA.EQ.ICX2CAU(I,2) .AND. ICAUB.EQ.ICX2CAU(I,1) 7915 * ) THEN 7916 IETACL2 = I 7917 ISYMB = ISYCX2(IETACL2,1) 7918 ISYMA = ISYCX2(IETACL2,2) 7919 IF (LOCDBG) THEN 7920 WRITE (LUPRI,*) 7921 & '[DEBUG] IETACL2> entry found on the list:' 7922 WRITE (LUPRI,*) '[DEBUG] IETACL2> INDEX :',IETACL2 7923 WRITE (LUPRI,*) '[DEBUG] IETACL2> SYMMETRIES:',ISYMA,ISYMB 7924 END IF 7925 RETURN 7926 END IF 7927 END DO 7928 7929 IF (LCX2OPN) THEN 7930 NCX2LBL = NCX2LBL + 1 7931 7932 IF (NCX2LBL.GT.MAXCX2LBL) THEN 7933 WRITE(LUPRI,'(A,/A,I5,A,I5)') 7934 * '@ NUMBER OF SPECIFIED VECTORS EXCEED THE MAXIMUM ALLOWED', 7935 * '@ MAXCX2LBL =',MAXCX2LBL,' NCX2LBL= ',NCX2LBL 7936 CALL QUIT(' IETACL2: TOO MANY VECTORS SPECIFIED') 7937 END IF 7938 7939 LBLCX2(NCX2LBL,1) = NEWLBLA 7940 LBLCX2(NCX2LBL,2) = NEWLBLB 7941 ICX2CAU(NCX2LBL,1) = ICAUA 7942 ICX2CAU(NCX2LBL,2) = ICAUB 7943 ISYCX2(NCX2LBL,1) = ISYMA 7944 ISYCX2(NCX2LBL,2) = ISYMB 7945 IETACL2 = NCX2LBL 7946 7947 IF (LOCDBG) THEN 7948 WRITE (LUPRI,*) '[DEBUG] IETACL2> put entry on the list:' 7949 WRITE (LUPRI,*) '[DEBUG] IETACL2> INDEX :',IETACL2 7950 END IF 7951 ELSE 7952 WRITE(LUPRI,'(3A,I2,3A,I2,2A)') 7953 * '@ WARNING: CX2 VECTOR FOR ',NEWLBLA,'(',ICAUA,'), ', 7954 * NEWLBLB,'(',ICAUB,')', 7955 * ' IS NOT AVAILABLE.' 7956 IETACL2 = -1 7957 END IF 7958 7959 RETURN 7960 END 7961*=====================================================================* 7962*=====================================================================* 7963C /* Deck IRHSCR2 */ 7964 INTEGER FUNCTION IRHSCR2(NEWLBLA,ICAUA,ISYMA, 7965 * NEWLBLB,ICAUB,ISYMB ) 7966*---------------------------------------------------------------------* 7967C 7968C maintain the list of rhs vectors for second-order 7969C right Cauchy vector equations: 7970C 7971C if vector is on the list return list index and set ISYMA,ISYMB 7972C if vector is NOT on the list: 7973C LCO2OPN=.true. --> extend list, and return index 7974C LCO2OPN=.false. --> return -1 7975C 7976C Christof Haettig, March 98 7977*---------------------------------------------------------------------* 7978 IMPLICIT NONE 7979#include "ccco2rsp.h" 7980#include "priunit.h" 7981C 7982 LOGICAL LOCDBG 7983 PARAMETER (LOCDBG = .FALSE.) 7984C 7985 CHARACTER*8 NEWLBLA, NEWLBLB 7986 INTEGER ICAUA, ICAUB, I 7987 INTEGER ISYMA, ISYMB 7988 7989 IF (LOCDBG) THEN 7990 WRITE (LUPRI,*) '[DEBUG] IRHSCR2> entered with input:' 7991 WRITE (LUPRI,*) '[DEBUG] IRHSCR2> LABELS :',NEWLBLA,NEWLBLB 7992 WRITE (LUPRI,*) '[DEBUG] IRHSCR2> SYMMETRIES:',ISYMA,ISYMB 7993 WRITE (LUPRI,*) '[DEBUG] IRHSCR2> CAUCHY ORD:',ICAUA,ICAUB 7994 END IF 7995 7996 DO I = 1,NCO2LBL 7997 IF ( NEWLBLA.EQ.LBLCO2(I,1) .AND. NEWLBLB.EQ.LBLCO2(I,2) 7998 * .AND. ICAUA.EQ.ICO2CAU(I,1) .AND. ICAUB.EQ.ICO2CAU(I,2) 7999 * ) THEN 8000 IRHSCR2 = I 8001 ISYMA = ISYCO2(IRHSCR2,1) 8002 ISYMB = ISYCO2(IRHSCR2,2) 8003 IF (LOCDBG) THEN 8004 WRITE (LUPRI,*) 8005 & '[DEBUG] IRHSCR2> entry found on the list:' 8006 WRITE (LUPRI,*) '[DEBUG] IRHSCR2> INDEX :',IRHSCR2 8007 WRITE (LUPRI,*) '[DEBUG] IRHSCR2> SYMMETRIES:',ISYMA,ISYMB 8008 END IF 8009 RETURN 8010 END IF 8011 IF ( NEWLBLA.EQ.LBLCO2(I,2) .AND. NEWLBLB.EQ.LBLCO2(I,1) 8012 * .AND. ICAUA.EQ.ICO2CAU(I,2) .AND. ICAUB.EQ.ICO2CAU(I,1) 8013 * ) THEN 8014 IRHSCR2 = I 8015 ISYMB = ISYCO2(IRHSCR2,1) 8016 ISYMA = ISYCO2(IRHSCR2,2) 8017 IF (LOCDBG) THEN 8018 WRITE (LUPRI,*) 8019 & '[DEBUG] IRHSCR2> entry found on the list:' 8020 WRITE (LUPRI,*) '[DEBUG] IRHSCR2> INDEX :',IRHSCR2 8021 WRITE (LUPRI,*) '[DEBUG] IRHSCR2> SYMMETRIES:',ISYMA,ISYMB 8022 END IF 8023 RETURN 8024 END IF 8025 END DO 8026 8027 IF (LCO2OPN) THEN 8028 NCO2LBL = NCO2LBL + 1 8029 8030 IF (NCO2LBL.GT.MAXCO2LBL) THEN 8031 WRITE(LUPRI,'(A,/A,I5,A,I5)') 8032 * '@ NUMBER OF SPECIFIED VECTORS EXCEED THE MAXIMUM ALLOWED', 8033 * '@ MAXCO2LBL =',MAXCO2LBL,' NCO2LBL= ',NCO2LBL 8034 CALL QUIT(' IRHSCR2: TOO MANY VECTORS SPECIFIED') 8035 END IF 8036 8037 LBLCO2(NCO2LBL,1) = NEWLBLA 8038 LBLCO2(NCO2LBL,2) = NEWLBLB 8039 ICO2CAU(NCO2LBL,1) = ICAUA 8040 ICO2CAU(NCO2LBL,2) = ICAUB 8041 ISYCO2(NCO2LBL,1) = ISYMA 8042 ISYCO2(NCO2LBL,2) = ISYMB 8043 IRHSCR2 = NCO2LBL 8044 8045 IF (LOCDBG) THEN 8046 WRITE (LUPRI,*) '[DEBUG] IRHSCR2> put entry on the list:' 8047 WRITE (LUPRI,*) '[DEBUG] IRHSCR2> INDEX :',IRHSCR2 8048 END IF 8049 ELSE 8050 WRITE(LUPRI,'(3A,I2,3A,I2,2A)') 8051 * '@ WARNING: CO2 VECTOR FOR ',NEWLBLA,'(',ICAUA,'), ', 8052 * NEWLBLB,'(',ICAUB,')', 8053 * ' IS NOT AVAILABLE.' 8054 IRHSCR2 = -1 8055 END IF 8056 8057 RETURN 8058 END 8059*=====================================================================* 8060*=====================================================================* 8061C /* Deck irshr1 */ 8062 INTEGER FUNCTION IRHSR1(NEWLBL,LORX,FRQINP,ISYM) 8063*---------------------------------------------------------------------* 8064C 8065C maintain the list of right hand side vectors for 8066C first-order t amplitude responses 8067C 8068C if vector is on the list return list index and set ISYM 8069C if vector is NOT on the list: 8070C LO1OPN=.true. --> extend list, and return index 8071C LO1OPN=.false. --> return -1 8072C 8073C NEWLBL -- operator label 8074C LORX -- flag for orbital relaxation 8075C FRQINP -- frequency (ignored for unrelaxed orbitals) 8076C ISYM -- symmetry 8077C 8078C Christof Haettig, Juni 1998 8079*---------------------------------------------------------------------* 8080 IMPLICIT NONE 8081#include "cco1rsp.h" 8082#include "priunit.h" 8083#include "ccsdinp.h" 8084 8085 LOGICAL LORX 8086 INTEGER ISYM 8087 8088 REAL*8 FRQNEW,TOL, FRQINP 8089 8090 PARAMETER(TOL=1.0D-12) 8091 8092 CHARACTER*8 NEWLBL 8093 INTEGER I 8094 8095* if LORX false ignore frequency (set to zero internally): 8096 IF (LORX.OR.CCSDT) THEN 8097 FRQNEW = FRQINP 8098 ELSE 8099 FRQNEW = 0.0d0 8100 END IF 8101 8102 DO I = 1,NO1LBL 8103 IF ( (NEWLBL .EQ. LBLO1(I)) .AND. (LORX .EQV. LORXO1(I)) .AND. 8104 & (ABS(FRQNEW-FRQO1(I)).LT.TOL)) THEN 8105 IRHSR1 = I 8106 ISYM = ISYO1(IRHSR1) 8107 RETURN 8108 END IF 8109 END DO 8110 8111 IF (LO1OPN) THEN 8112 NO1LBL = NO1LBL + 1 8113 8114 IF (NO1LBL.GT.MAXO1LBL) THEN 8115 WRITE(LUPRI,'(A,/A,I5,A,I5)') 8116 * '@ NUMBER OF SPECIFIED EQUATIONS EXCEED THE MAXIMUM ALLOWED', 8117 * '@ MAXO1LBL =',MAXO1LBL,' NO1LBL= ',NO1LBL 8118 CALL QUIT(' IRHSR1: TOO MANY EQUATIONS SPECIFIED') 8119 END IF 8120 8121 LBLO1(NO1LBL) = NEWLBL 8122 ISYO1(NO1LBL) = ISYM 8123 LORXO1(NO1LBL) = LORX 8124 FRQO1(NO1LBL) = FRQNEW 8125 IRHSR1 = NO1LBL 8126 8127 ELSE 8128 WRITE(LUPRI,'(3A,L2,A,1P,D12.5,2A)') 8129 * '@ WARNING: RHSR1 VECTOR FOR ',NEWLBL,'(',LORX,',',FRQNEW,')', 8130 * ' IS NOT AVAILABLE.' 8131 IRHSR1 = -1 8132 END IF 8133 8134 RETURN 8135 END 8136*=====================================================================* 8137*=====================================================================* 8138C /* Deck ieta1 */ 8139 INTEGER FUNCTION IETA1(NEWLBL,LORX,FRQINP,ISYM) 8140*---------------------------------------------------------------------* 8141C 8142C maintain the list of right hand side vectors for 8143C first-order lagrangian multiplier responses 8144C 8145C if vector is on the list return list index and set ISYM 8146C if vector is NOT on the list: 8147C LX1OPN=.true. --> extend list, and return index 8148C LX1OPN=.false. --> return -1 8149C 8150C NEWLBL -- operator label 8151C LORX -- flag for orbital relaxation 8152C FRQINP -- frequency (ignored for unrelaxed orbitals) 8153C ISYM -- symmetry 8154C 8155C Christof Haettig, Juni 1998 8156*---------------------------------------------------------------------* 8157 IMPLICIT NONE 8158#include "ccx1rsp.h" 8159#include "priunit.h" 8160#include "ccsdinp.h" 8161 8162 LOGICAL LORX, LORX1 8163 INTEGER ISYM 8164 8165 REAL*8 FRQNEW,TOL, FRQINP 8166 8167 PARAMETER(TOL=1.0D-12) 8168 8169 CHARACTER*8 NEWLBL 8170 INTEGER I 8171 8172* if LORX false and CCSDT false ignore frequency by setting it 8173* to zero internally: 8174 IF (LORX.OR.CCSDT) THEN 8175 FRQNEW = FRQINP 8176 ELSE 8177 FRQNEW = 0.0d0 8178 END IF 8179 8180 8181 DO I = 1,NX1LBL 8182 ! the following crappy comparison of LORX with LORXX1 was 8183 ! necessary to get it through the XLF compilers 8184 LORX1 = (LORX.AND.LORXX1(I)) .OR. 8185 & ((.NOT.LORX).AND.(.NOT.LORXX1(I))) 8186 IF ( (NEWLBL .EQ. LBLX1(I)) .AND. LORX1 .AND. 8187 & (ABS(FRQNEW-FRQX1(I)).LT.TOL)) THEN 8188 IETA1 = I 8189 ISYM = ISYX1(IETA1) 8190 RETURN 8191 END IF 8192 END DO 8193 8194 IF (LX1OPN) THEN 8195 NX1LBL = NX1LBL + 1 8196 8197 IF (NX1LBL.GT.MAXX1LBL) THEN 8198 WRITE(LUPRI,'(A,/A,I5,A,I5)') 8199 * '@ NUMBER OF SPECIFIED EQUATIONS EXCEED THE MAXIMUM ALLOWED', 8200 * '@ MAXX1LBL =',MAXX1LBL,' NX1LBL= ',NX1LBL 8201 CALL QUIT(' IETA1: TOO MANY EQUATIONS SPECIFIED') 8202 END IF 8203 8204 LBLX1(NX1LBL) = NEWLBL 8205 ISYX1(NX1LBL) = ISYM 8206 LORXX1(NX1LBL) = LORX 8207 FRQX1(NX1LBL) = FRQNEW 8208 IETA1 = NX1LBL 8209 8210 ELSE 8211 WRITE(LUPRI,'(3A,L2,A,1P,D12.5,2A)') 8212 * '@ WARNING: ETA1 VECTOR FOR ',NEWLBL,'(',LORX,',',FRQNEW,')', 8213 * ' IS NOT AVAILABLE.' 8214 IETA1 = -1 8215 END IF 8216 8217 RETURN 8218 END 8219*=====================================================================* 8220*=====================================================================* 8221C /* Deck ipl1zeta */ 8222 INTEGER FUNCTION IPL1ZETA(NEWLBLA,LORXA,FRQANEW,ISYMA,LPROJ, 8223 & IEXCI,EIGVNEW,ISYMS) 8224*---------------------------------------------------------------------* 8225C 8226C maintain the list of projected first order zeta amplitude responses 8227C onto the orthogonal complement of E^f 8228C 8229C if vector is on the list return list index and set ISYMS,ISYMA 8230C 8231C if vector is NOT on the list: 8232C LPL1OPN=.true. --> extend list, and return index IPL1ZETA 8233C LPL1OPN=.false. --> return -1 8234C 8235C NEWLBLA -- operator A label 8236C LORXA -- flag for orbital relaxation 8237C FRQANEW -- frequency 8238C ISYMA -- symmetry of operator A and of projected PL1 8239C LPROJ -- flag for projection 8240C 8241C IEXCI -- index for the excited state 8242C EIGVNEW -- its eigenvalue (exc. energy) 8243C ISYMS -- its symmetry 8244C 8245C Sonia Coriani, March 2000 8246C based of IL1ZETA and IEL1AMP 8247*---------------------------------------------------------------------* 8248 IMPLICIT NONE 8249#include "ccpl1rsp.h" 8250#include "priunit.h" 8251 8252 LOGICAL LORXA, LPROJ, LPROJ1 8253 INTEGER ISYMA, ISYMS, IEXCI, I 8254 REAL*8 FRQANEW, EIGVNEW, TOL 8255 8256 PARAMETER(TOL=1.0D-12) 8257 8258 CHARACTER*8 NEWLBLA 8259 8260 8261 LPROJ1 = LPROJ 8262* 8263* Projection might only be necessary if ISYMA = ISYMS 8264* 8265 IF (ISYMA.NE.ISYMS) THEN 8266 LPROJ1 = .FALSE. 8267* WRITE(LUPRI,*) ' Inside IPL1ZETA: LPROJ1 reset to FALSE' 8268 END IF 8269* 8270 DO I = 1,NPL1LBL 8271 IF ( (NEWLBLA .EQ. LBLPL1(I)) .AND. 8272 & (LORXA .EQV. LORXPL1(I)) .AND. 8273 & (ABS(FRQANEW-FRQPL1(I)).LT.TOL) .AND. 8274 & (IEXCI .EQ. ISTPL1(I)) .AND. 8275 & (ABS(EIGVNEW-EIGPL1(I)).LT.TOL) .AND. 8276 & (LPROJ1 .EQV. LPRPL1(I)) ) THEN 8277 8278 IPL1ZETA = I 8279 ISYMA = ISYPL1(IPL1ZETA) 8280 ISYMS = ISYSPL1(IPL1ZETA) 8281 RETURN 8282 END IF 8283 END DO 8284 8285 IF (LPL1OPN) THEN 8286 NPL1LBL = NPL1LBL + 1 8287 8288 IF (NPL1LBL.GT.MAXPL1LBL) THEN 8289 WRITE(LUPRI,'(A,/A,I5,A,I5)') 8290 * '@ NUMBER OF SPECIFIED EQUATIONS EXCEED THE MAXIMUM ALLOWED', 8291 * '@ MAXPL1LBL =',MAXPL1LBL,' NPL1LBL= ',NPL1LBL 8292 CALL QUIT(' IPL1ZETA: TOO MANY EQUATIONS SPECIFIED') 8293 END IF 8294 8295 !the A-operator-for-response infos 8296 LBLPL1(NPL1LBL) = NEWLBLA 8297 LORXPL1(NPL1LBL) = LORXA 8298 FRQPL1(NPL1LBL) = FRQANEW 8299 ISYPL1(NPL1LBL) = ISYMA 8300 !the excitated-state-for-projection infos 8301 ISTPL1(NPL1LBL) = IEXCI 8302 ISYSPL1(NPL1LBL) = ISYMS 8303 EIGPL1(NPL1LBL) = EIGVNEW 8304 !the PL^A-vector extra infos 8305 LPRPL1(NPL1LBL) = LPROJ1 8306 IPL1ZETA = NPL1LBL 8307 8308 ELSE 8309 WRITE(LUPRI,'(3A,L2,A,1P,D12.5,2A)') 8310 * '@ WARNING: PL1 VECTOR FOR ',NEWLBLA,'(',LORXA,',',FRQANEW,')', 8311 * ' IS NOT AVAILABLE.' 8312 IPL1ZETA = -1 8313 END IF 8314 8315 RETURN 8316 END 8317*=====================================================================* 8318C /* Deck iqllist */ 8319 INTEGER FUNCTION IQLLIST(NEWLBL,LORX,ICHAIN,FRQINP,ISYM) 8320*---------------------------------------------------------------------* 8321C 8322C maintain the list of Q vectors in Lanczos chain (aka 'QL') 8323C 8324C if vector is on the list return list index and set ISYM 8325C if vector is NOT on the list: 8326C LQLOPN=.true. --> extend list, and return index 8327C LQLOPN=.false. --> return -1 8328C 8329C NEWLBL -- operator label 8330C LORX -- flag for orbital relaxation 8331C FRQINP -- frequency (ignored for unrelaxed orbitals) 8332C ISYM -- symmetry 8333C ICHAIN -- index of given Q vector in the chain 8334C Sonia & Kristian, August 2010 8335*---------------------------------------------------------------------* 8336 IMPLICIT NONE 8337#include "ccqlrlcz.h" 8338#include "priunit.h" 8339#include "ccsdinp.h" 8340 LOGICAL LORX, LOCDBG 8341 PARAMETER (LOCDBG=.false.) 8342 INTEGER ISYM, ICHAIN 8343 8344#if defined (SYS_CRAY) 8345 REAL FRQNEW,TOL, FRQINP 8346#else 8347 DOUBLE PRECISION FRQNEW,TOL, FRQINP 8348#endif 8349 PARAMETER(TOL=1.0D-12) 8350 8351 CHARACTER*8 NEWLBL 8352 INTEGER I 8353 8354* if LORX false ignore frequency (set to zero internally): 8355 IF (LORX.OR.CCSDT) THEN 8356 FRQNEW = FRQINP 8357 ELSE 8358 FRQNEW = 0.0d0 8359 END IF 8360 8361 if (locdbg) then 8362 write(lupri,*)'FUNCTION IQLLST at entry' 8363 write(lupri,*)'NQLLBL: ', NQLLBL 8364 write(lupri,*)'NEWLBL: ', NEWLBL, ' ? LBLQL:', LBLQL(1) 8365 write(lupri,*)'LORX: ', LORX, ' ? LORXQL:', LORXQL(1) 8366 write(lupri,*)'ABS(FRQNEW-FRQQL(1)): ', ABS(FRQNEW-FRQQL(1)) 8367 write(lupri,*)'ICHAIN: ', ICHAIN, 'IDXQL(1):', IDXQL(1) 8368 end if 8369 DO I = 1,NQLLBL 8370 IF ( (NEWLBL .EQ. LBLQL(I)) .AND. (LORX .EQV. LORXQL(I)) .AND. 8371 & (ABS(FRQNEW-FRQQL(I)).LT.TOL) .AND. 8372 & (ICHAIN .EQ. IDXQL(I))) THEN 8373 IQLLIST = I 8374 ISYM = ISYQL(IQLLIST) 8375 RETURN 8376 END IF 8377 END DO 8378 IF (LQLOPN) THEN 8379 NQLLBL = NQLLBL + 1 8380 IF (NQLLBL.GT.MAXQLLBL) THEN 8381 WRITE(LUPRI,'(A,/A,I5,A,I5)') 8382 * '@ NUMBER OF SPECIFIED QL EXCEED THE MAXIMUM ALLOWED', 8383 * '@ MAXQLLBL =',MAXQLLBL,' NQLLBL= ',NQLLBL 8384 CALL QUIT(' IQLLIST: TOO MANY EQUATIONS SPECIFIED') 8385 END IF 8386 8387 LBLQL(NQLLBL) = NEWLBL 8388 ISYQL(NQLLBL) = ISYM 8389 LORXQL(NQLLBL) = LORX 8390 FRQQL(NQLLBL) = FRQNEW 8391 IDXQL(NQLLBL) = ICHAIN 8392 IQLLIST = NQLLBL 8393 8394 ELSE 8395 WRITE(LUPRI,'(3A,L2,A,1P,D12.5,2A)') 8396 * '@ WARNING: Q VECTOR FOR ',NEWLBL, 8397 * '(',LORX,',',FRQNEW,')', 8398 * ' IS NOT AVAILABLE.' 8399 IQLLIST = -1 8400 END IF 8401 8402 RETURN 8403 END 8404 8405 8406