1! 2! Dalton, a molecular electronic structure program 3! Copyright (C) by the authors of Dalton. 4! 5! This program is free software; you can redistribute it and/or 6! modify it under the terms of the GNU Lesser General Public 7! License version 2.1 as published by the Free Software Foundation. 8! 9! This program is distributed in the hope that it will be useful, 10! but WITHOUT ANY WARRANTY; without even the implied warranty of 11! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12! Lesser General Public License for more details. 13! 14! If a copy of the GNU LGPL v2.1 was not distributed with this 15! code, you can obtain one at https://www.gnu.org/licenses/old-licenses/lgpl-2.1.en.html. 16! 17! 18C 19C /* Deck cc_input */ 20 SUBROUTINE CC_INPUT(WORD,IREST,MSYM) 21C 22C------------------------------------------------- 23C 24C 30-May 1994 Written by Henrik Koch 25C 26C Input sections for the coupled cluster code. 27C 28C------------------------------------------------------------- 29C 30C 1994-96 input flags by Ove Christiansen 31C for excitation energies, linear response 32C and various CC models; 33C Keywords have been added for R12 method (WK/UniKA/04-11-2002). 34C 35C Overview over all keywords: 36C 37C Model Keywords: 38C =============== 39C 40C CCS, CC2, CCSD, CC3, 41C CCR(3), CCR(A), CCR(B), CCR(T) (CCSDR()variants) 42C CC(2)(gives CIS(D) excitation energies) 43C CC(3), CC(T)(gives CCSD(T) energy) 44C CC1A, CC1B (for CCSDT-1a and CCSDT-1b models) 45C CCD, MP2 46c rCCD, drCCD, rTCCD 47C 48C 49C Frozen core and finite diff. Keywords: 50C ====================================== 51C 52C FROIMP, FROEXP 53C FCORE, FSECON (obsolete) 54C FIELD 55C 56C Control Keywords for energy: 57C ============================ 58C 59C SKIP, PRINT, DIRECT (the three original) 60C RESTART, NOCCIT, NOT2TC 61C THRENR, THRLEQ, NSIMLE 62C MAXITE, MXDIIS, MAXRED, MXLRV 63C MINSCR, MINMEM 64C 65C------------------------------------------------------------- 66C 67#include "implicit.h" 68#include "priunit.h" 69#include "dummy.h" 70#include "r12int.h" 71#include "maxorb.h" 72#include "mxcent.h" 73#include "ccorb.h" 74#include "ccsdsym.h" 75#include "ccsdinp.h" 76#include "ccsections.h" 77#include "inftap.h" 78#include "ccfield.h" 79#include "cclr.h" 80#include "ccfop.h" 81#include "leinf.h" 82#include "gnrinf.h" 83#include "ccrspprp.h" 84#include "ccpack.h" 85#include "eribuf.h" 86#include "cbieri.h" 87#include "ccroper.h" 88#include "cch2d.h" 89#include "soppinf.h" 90Cholesky 91#include "cc_cho.h" 92#include "ccdeco.h" 93#include "chodbg.h" 94#include "chomp2.h" 95#include "chocc2.h" 96C 97#include "center.h" 98Cholesky 99C 100 PARAMETER (NTABLE = 128) 101 LOGICAL SET, NEWDEF, SIRFF 102 CHARACTER PROMPT*1, WORD*7, TABLE(NTABLE)*7, WORD1*7 103 CHARACTER*(80) LINE 104C 105 SAVE SET 106CSONIA/FRAN/TBPEDERSEN 107CNew method keywords ring-CCD (rCCD), direct ring CCD (drCCD), 108Cring-CCD for triplet (rTCCD), and SOSEX added 109 110 DATA TABLE /'.SKIP ','.PRINT ','.DIRECT','.RESTAR','.CC3 ', 111 & '*CCEXCI','*CCLRSD','.CCSTST','.NSYM ','.MAXRED', 112 & '*CCEXGR','.R1SKIP','.L1SKIP','.RESKIP','.LESKIP', 113 & '.F1SKIP','.MAX IT','*CCXOPA','.E0SKIP','.L0SKIP', 114 & '.LISKIP','.CC2 ','.MP2 ','.CC(2) ','.CC1B ', 115 & '.CC(T) ','.CC(3) ','.CCS ','.FCORE ','.FSECON', 116 & '.CCD ','.CC1A ','.CIS ','.THRENR','.NOCCIT', 117 & '.IMSKIP','.M1SKIP','.FRSKIP','.MINSCR','.MINMEM', 118 & '.BESKIP','.NEWCAU','.NOT2TC','*CCGR ','.FROEXP', 119 & '.FROIMP','.MXDIIS','.CCSD ','.CCR(A)','.CCR(B)', 120 & '*CCFOP ','.SOPPA(','.CCR(3)','.CCR(T)','.FIELD ', 121 & '.DEBUG ','*CCQR2R','.HERDIR','.BUFLEN','*CCLR ', 122 & '*CCEXLR','.NSIMLE','.THRLEQ','.MXLRV ','*CCTM ', 123 & '*CCLRLA','*CC5R ','*CC4R ','*CCQR ','*CCCR ', 124 & '.O2SKIP','.R2SKIP','.X2SKIP','.F2SKIP','.L2SKIP', 125 & '*CCMCD ','.ANAAOD','.PACK ','.CONNEC','.THRLDP', 126 & '.RCSKIP','.FCSKIP','.LCSKIP','.CO2SKI','.CX2SKI', 127 & '.CR2SKI','.CF2SKI','.CL2SKI','*DERIVA','.N2SKIP', 128 & '.BRSKIP','.FREEZE','*CCSLV ','*R12 ','*R12 IN', 129 & '.PAIRS ','.ETAPTI','.DKABAR','*CCOPA ','*NODDY ', 130 & '.NOEONL','.DIRDER','*CCTPA ','.INT4V ','.ONLYMO', 131 & '.THRVEC','.MTRIP ','.SOPPA2','.AO-SOP','.NOSORT', 132 & '.KEPAOI','*CHO(T)','*CHOCC2','*CHOMP2','*CHODBG', 133 & '.D01SKI','.CHO(T)','.T2UPDA','.RCCD ','.RTCCD ', 134 & '.DRCCD ','.SOSEX ','.T2STAR','.HURWIT','.DCPT2 ', 135 & '*MLCC3 ','*MLCCPT','*PECC'/ 136 137 DATA SET/.FALSE./ 138C 139 IF (SET) RETURN 140 SET = .TRUE. 141C 142CSPAS:8/11-13: Initialization of CCSDINP, CCLR, CCSDSYM 143C and other common blocks is moved to a new routine 144C CCSD_INIT0, because the initialization has to be done 145C also in the AO-SOPPA module. 146C 147C Initialize /CCSDINP/ ,/CCLR / and /CCSDSYM/ 148C 149 CALL CCSD_INIT0(WORD) 150C 151 MSYMS = MSYM 152C 153CKeinSPASmehr 154C 155C If this is a restart run, we read MSYM from SIRIFC 156C 157 IF (IREST .EQ. 1) THEN 158 CALL GPOPEN(LUSIFC,'SIRIFC','OLD',' ','UNFORMATTED',IDUMMY, 159 & .FALSE.) 160 REWIND LUSIFC 161C 162 CALL MOLLAB('TRCCINT ',LUSIFC,LUPRI) 163 READ (LUSIFC) MSYM 164 CALL GPCLOSE(LUSIFC,'KEEP') 165C 166 END IF 167C----------------------------------------------- 168C SIRIUS values for field is transferred if 169C there is any. 170C----------------------------------------------- 171C 172 SIRFF = .FALSE. 173 NONHF = .FALSE. 174 CALL CC_FSIR(MXFELT,NFIELD,LFIELD,EFIELD,NHFFIELD) 175 IF (NFIELD .GT. 0) NONHF = .FALSE. 176 IF (NFIELD .GT. 0) SIRFF = .TRUE. 177C 178C----------------------------------------------- 179C of default section. 180C default set after input for minscr and minmem. 181C----------------------------------------------- 182C 183 ICHANG = 0 184C 185 NEWDEF = (WORD .EQ. '*CC INP' .OR. WORD .EQ. '**CC '.OR. 186 * WORD .EQ. '*CC ') 187 IF (NEWDEF) THEN 188 WORD1 = WORD 189 1000 CONTINUE 190 READ (LUCMD, '(A7)') WORD 191 CALL UPCASE(WORD) 192 193C 194 PROMPT = WORD(1:1) 195 IF (PROMPT .EQ. '!' .OR. PROMPT .EQ. '#') THEN 196 GO TO 1000 197 ELSE IF (PROMPT .EQ. '.' .OR. PROMPT .EQ. '*') THEN 198 ICHANG = ICHANG + 1 199 DO 200 I = 1, NTABLE 200 IF (TABLE(I) .EQ. WORD) THEN 201 GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, 202 * 17,18,19,20,21,22,23,24,25,26,27,28,29,30,31, 203 * 32,33,34,35,36,37,38,39,40,41,42,43,44,45,46, 204 * 47,48,49,50,51,52,53,54,55,56,57,58,59,60,61, 205 * 62,63,64,65,66,67,68,69,70,71,72,73,74,75,76, 206 * 77,78,79,80,81,82,83,84,85,86,87,88,89,90,91, 207 * 92,93,94,95,96,97,98,99,100,101,102,103,104, 208 * 105,106,107,108,109,110,111,112,113,114,115, 209 * 116,117,118,119,120,121,122,123,124,125,126, 210 * 127,128), I 211 END IF 212 200 CONTINUE 213 IF (WORD .EQ. '.OPTION') THEN 214 CALL PRTAB(NTABLE,TABLE,WORD1//' input keywords',LUPRI) 215 GO TO 1000 216 END IF 217 IF (WORD(1:1) .EQ. '*') THEN 218 219 ! either '*END OF' for '**CC ' section or a sirius 220 ! keyword. in the former case read next input line 221 IF (WORD.EQ.'*END OF' .AND. WORD1.EQ.'**CC ') THEN 222 READ (LUCMD, '(A7)') WORD 223 CALL UPCASE(WORD) 224 END IF 225 226 GO TO 300 227 228 ELSE 229 WRITE (LUPRI,'(/3A,/)') ' Keyword "',WORD, 230 * '" not recognized in CCSD_INPUT.' 231 CALL PRTAB(NTABLE,TABLE,WORD1//' input keywords',LUPRI) 232 CALL QUIT('Illegal keyword in CCSD_INPUT.') 233 END IF 234 235 1 CONTINUE 236 SKIP = .TRUE. 237 GO TO 1000 238 2 CONTINUE 239 READ (LUCMD,*) IPRINT 240 GO TO 1000 241 3 CONTINUE 242 DIRECT = .TRUE. 243 GO TO 1000 244 4 CONTINUE 245 CCRSTR = .TRUE. 246 GO TO 1000 247 5 CONTINUE 248 CC3 = .TRUE. 249 CCSDT = .TRUE. 250 GO TO 1000 251 6 CONTINUE 252 CALL CC_EXCINP(WORD,MSYM) 253 GO TO 1000 254 7 CONTINUE 255c filip, 21.10.2013 256c In case of CC3 the ground state-excited state 257c transition moments are calculated via the CC_OPAINP 258c module, hence: 259 IF (CC3) THEN 260 WORD = '*CCOPA ' 261 GOTO 99 262 ELSE 263 CALL CC_LRSINP(WORD,MSYM) 264 ENDIF 265 GO TO 1000 266 8 CONTINUE 267 CCSTST = .TRUE. 268 GO TO 1000 269 9 CONTINUE 270 READ (LUCMD,*) MSYM2 271 IF (((MSYM.LT.8).AND.(MSYM.GT.0)) 272 * .AND.(MSYM2.NE.MSYM)) THEN 273 CALL QUIT(' Symmetry mismatch in input') 274 ELSE 275 MSYM = MSYM2 276 ENDIF 277 GO TO 1000 278 10 CONTINUE 279 READ (LUCMD, *) MAXRED 280 GO TO 1000 281 11 CONTINUE 282 CALL CC_EXGRIN(WORD,MSYM) 283 GO TO 1000 284 12 CONTINUE 285 R1SKIP = .TRUE. 286 GO TO 1000 287 13 CONTINUE 288 L1SKIP = .TRUE. 289 GO TO 1000 290 14 CONTINUE 291 RESKIP = .TRUE. 292 GO TO 1000 293 15 CONTINUE 294 LESKIP = .TRUE. 295 GO TO 1000 296 16 CONTINUE 297 F1SKIP = .TRUE. 298 GO TO 1000 299 17 CONTINUE 300 READ (LUCMD,*) MAXITE 301 GO TO 1000 302 18 CONTINUE 303C '*CCXOPA' 304 CALL CC_OPAINP(WORD,MSYM) 305 GO TO 1000 306 19 CONTINUE 307 E0SKIP = .TRUE. 308 GO TO 1000 309 20 CONTINUE 310 L0SKIP = .TRUE. 311 GO TO 1000 312 21 CONTINUE 313 LISKIP = .TRUE. 314 GO TO 1000 315 22 CONTINUE 316 CC2 = .TRUE. 317 GO TO 1000 318 23 CONTINUE 319 MP2 = .TRUE. 320 GO TO 1000 321 24 CONTINUE 322 CCP2 = .TRUE. 323 GO TO 1000 324 25 CONTINUE 325 CCSDT = .TRUE. 326 CC1B = .TRUE. 327 GO TO 1000 328 26 CONTINUE 329 CCPT = .TRUE. 330 GO TO 1000 331 27 CONTINUE 332 CCP3 = .TRUE. 333 GO TO 1000 334 28 CONTINUE 335 CCS = .TRUE. 336 GO TO 1000 337 29 CONTINUE 338 LCOR = .TRUE. 339 READ (LUCMD,*) (ICOR(ISYM),ISYM=1,MSYM) 340 GO TO 1000 341 30 CONTINUE 342 LSEC = .TRUE. 343 READ (LUCMD,*) (ISEC(ISYM),ISYM=1,MSYM) 344 GO TO 1000 345 31 CONTINUE 346 CCD = .TRUE. 347 GO TO 1000 348 32 CONTINUE 349 CCSDT = .TRUE. 350 CC1A = .TRUE. 351 GO TO 1000 352 33 CONTINUE 353 CIS = .TRUE. 354 GO TO 1000 355 34 CONTINUE 356 READ (LUCMD, *) THRENR 357 GO TO 1000 358 35 CONTINUE 359 NOCCIT = .TRUE. 360 GO TO 1000 361 36 CONTINUE 362 IMSKIP = .TRUE. 363 GO TO 1000 364 37 CONTINUE 365 M1SKIP = .TRUE. 366 GO TO 1000 367 38 CONTINUE 368 FRSKIP = .TRUE. 369 GO TO 1000 370 39 CONTINUE 371 READ (LUCMD, *) MINSCR 372 ITEST = ITEST + 1 373 GO TO 1000 374 40 CONTINUE 375 READ (LUCMD, *) MINMEM 376 ITEST = ITEST + 1 377 GO TO 1000 378 41 CONTINUE 379 BESKIP = .TRUE. 380 GO TO 1000 381 42 CONTINUE 382 NEWCAU = .TRUE. 383 GO TO 1000 384 43 CONTINUE 385 T2TCOR = .FALSE. 386 GO TO 1000 387 44 CONTINUE 388 CALL CC_GRIN(WORD,MSYM) 389 GO TO 1000 390 45 CONTINUE 391 FROEXP = .TRUE. 392 IF (FROIMP) FROIMP = .FALSE. 393 IF (FREEZE) CALL QUIT(' Only one of FREEZE - FROEXP') 394 READ(LUCMD,*) (NRHFFR(I),I=1,MSYM) 395 DO 451 ISYM = 1,MSYM 396 IF (NRHFFR(ISYM) .NE. 0) THEN 397 IF (NRHFFR(ISYM) .GT. MAXFRO) THEN 398 WRITE(LUPRI,'(1X,2A,I4)') 399 * 'ERROR: Maximum number of frozen ', 400 * 'orbitals per symmetry is:',MAXFRO 401 CALL QUIT('Too many frozen orbitals') 402 END IF 403 READ(LUCMD,*) (KFRRHF(J,ISYM),J=1,NRHFFR(ISYM)) 404 END IF 405 451 CONTINUE 406 READ(LUCMD,*) (NVIRFR(I),I=1,MSYM) 407 DO 452 ISYM = 1,MSYM 408 IF (NVIRFR(ISYM) .NE. 0) THEN 409 IF (NVIRFR(ISYM) .GT. MAXFRO) THEN 410 WRITE(LUPRI,'(1X,2A,I4)') 411 * 'ERROR: Maximum number of frozen ', 412 * 'orbitals per symmetry is:',MAXFRO 413 CALL QUIT('Too many frozen orbitals') 414 END IF 415 READ(LUCMD,*) (KFRVIR(J,ISYM),J=1,NVIRFR(ISYM)) 416 END IF 417 452 CONTINUE 418 GO TO 1000 419 46 CONTINUE 420 FROIMP = .TRUE. 421 IF (FROEXP) FROEXP = .FALSE. 422 IF (FREEZE) CALL QUIT(' Only one of FREEZE - FROEXP') 423 READ(LUCMD,*) (NRHFFR(I),I=1,MSYM) 424 READ(LUCMD,*) (NVIRFR(I),I=1,MSYM) 425 GO TO 1000 426 47 CONTINUE 427 READ(LUCMD,*) MXDIIS 428 GO TO 1000 429 48 CONTINUE 430 CCSD = .TRUE. 431 GO TO 1000 432 49 CONTINUE 433 CCR1A = .TRUE. 434 GO TO 1000 435 50 CONTINUE 436 CCR1B = .TRUE. 437 GO TO 1000 438 51 CONTINUE 439 CALL CC_FOPINP(WORD) 440 GO TO 1000 441 52 CONTINUE 442 SIRSOP = .TRUE. 443 CCSD = .TRUE. 444 KEEPAOTWO = MAX(KEEPAOTWO,2) 445 GO TO 1000 446 53 CONTINUE 447 CCR3 = .TRUE. 448 CCSD = .TRUE. 449 GO TO 1000 450 54 CONTINUE 451 CCRT = .TRUE. 452 GO TO 1000 453 55 CONTINUE 454 NFIELD = NFIELD + 1 455 IF (NFIELD .LE. MXFELT) THEN 456 READ(LUCMD,*) EFIELD(NFIELD) 457 READ(LUCMD,*) LFIELD(NFIELD) 458 NHFFIELD(NFIELD) = .TRUE. 459 ELSE 460 WRITE(LUPRI,*) 'Too many fields in cc input' 461 CALL QUIT('Too many fields !') 462 ENDIF 463 NONHF = .TRUE. 464 IF (SIRFF ) THEN 465 WRITE(LUPRI,*) ' FF not allowed in ' 466 * //'both Hartree Fock and CC input' 467 CALL QUIT('FF not allowed in both HF and CC input' ) 468 ENDIF 469 GO TO 1000 470 56 CONTINUE 471 DEBUG = .TRUE. 472 GO TO 1000 473 57 CONTINUE 474c filip, 21.10.2013 475c In case of CC3 the transition moments 476c between two excited state are calculated 477c via the CC_OPAINP module, hence: 478 IF (CC3) THEN 479 WORD = '*CCXOPA' 480 GOTO 18 481 ELSE 482 CALL CC_QR2RINP(WORD) 483 ENDIF 484 GO TO 1000 485 58 CONTINUE 486 HERDIR = .TRUE. 487 GO TO 1000 488 59 CONTINUE 489 READ (LUCMD, *) LBUF 490 GO TO 1000 491 60 CONTINUE 492 CALL CC_LRINP(WORD) 493 GO TO 1000 494 61 CONTINUE 495 CALL CC_EXLRINP(WORD) 496 GO TO 1000 497 62 CONTINUE 498 READ (LUCMD, *) NSIMLE 499 GO TO 1000 500 63 CONTINUE 501 READ (LUCMD, *) THRLEQ 502 GO TO 1000 503 64 CONTINUE 504 READ (LUCMD, *) MXLRV 505 GO TO 1000 506 65 CONTINUE 507 CALL CC_TMINP(WORD) 508 GO TO 1000 509 66 CONTINUE 510 !Lanczos linear response 511 !*CCLRLANCZOS 512 CALL CC_LANCZOS_LRINP(WORD) 513 GO TO 1000 514 67 CONTINUE 515 CALL CC_5RINP(WORD) 516 GO TO 1000 517 68 CONTINUE 518 CALL CC_4RINP(WORD) 519 GO TO 1000 520 69 CONTINUE 521 CALL CC_QRINP(WORD) 522 GO TO 1000 523 70 CONTINUE 524 CALL CC_CRINP(WORD) 525 GO TO 1000 526 71 CONTINUE 527 O2SKIP = .TRUE. 528 GO TO 1000 529 72 CONTINUE 530 R2SKIP = .TRUE. 531 GO TO 1000 532 73 CONTINUE 533 X2SKIP = .TRUE. 534 GO TO 1000 535 74 CONTINUE 536 F2SKIP = .TRUE. 537 GO TO 1000 538 75 CONTINUE 539 L2SKIP = .TRUE. 540 GO TO 1000 541 76 CONTINUE 542 CALL CC_MCDINP(WORD) 543 GO TO 1000 544 77 CONTINUE 545 ANAAOD = .TRUE. 546 GO TO 1000 547 78 CONTINUE 548C '.PACK ' 549 LPACKINT = .TRUE. 550 READ (LUCMD, *) THRPCKINT 551 GO TO 1000 552 79 CONTINUE 553C '.CONNEC' 554c CONNECTION = 'SYMMETR' / 'NATURAL' 555 READ (LUCMD, '(A7)') CONNECTION 556 GO TO 1000 557 80 CONTINUE 558C '.THRLDP' 559 READ (LUCMD, *) THRLDPHF 560 GO TO 1000 561 81 CONTINUE 562C '.RCSKIP' 563 RCSKIP = .TRUE. 564 GO TO 1000 565 82 CONTINUE 566C '.FCSKIP' 567 FCSKIP = .TRUE. 568 GO TO 1000 569 83 CONTINUE 570C '.LCSKIP' 571 LCSKIP = .TRUE. 572 GO TO 1000 573 84 CONTINUE 574C '.CO2SKI' 575 CO2SKIP = .TRUE. 576 GO TO 1000 577 85 CONTINUE 578C '.CX2SKI' 579 CX2SKIP = .TRUE. 580 GO TO 1000 581 86 CONTINUE 582C '.CR2SKI' 583 CR2SKIP = .TRUE. 584 GO TO 1000 585 87 CONTINUE 586C '.CF2SKI' 587 CF2SKIP = .TRUE. 588 GO TO 1000 589 88 CONTINUE 590C '.CL2SKI' 591 CL2SKIP = .TRUE. 592 GO TO 1000 593 89 CONTINUE 594C '*DERIVA' 595 CCDERI = .TRUE. 596 RELORB = .TRUE. 597 GO TO 1000 598 90 CONTINUE 599C '.N2SKIP' 600 N2SKIP = .TRUE. 601 GO TO 1000 602 91 CONTINUE 603C '.BRSKIP' 604 BRSKIP = .TRUE. 605 GO TO 1000 606 92 CONTINUE 607C '.FREEZE' 608 FREEZE = .TRUE. 609 IF (FROIMP.OR.FROEXP) 610 * CALL QUIT(' Only one of FREEZE - FROEXP - FROIMP') 611 READ(LUCMD,*) NFC,NFV 612 FROIMP = .TRUE. 613 GO TO 1000 614 93 CONTINUE 615C '*CCSLV ' 616 CALL CC_SLVINP(WORD) 617 GO TO 1000 618 94 CONTINUE 619 95 CONTINUE 620C '*R12 ' OR '*R12 IN' 621 CALL CC_R12IN(WORD) 622 GO TO 1000 623 96 CONTINUE 624C '.PAIRS ' 625 CCPAIR = .TRUE. 626 GO TO 1000 627 97 CONTINUE 628C '.ETAPTI', extra integrals for CCSD(T) geopt (redundant!) 629 ETACCPT = .TRUE. 630 GO TO 1000 631 98 CONTINUE 632C '.DKABAR', direct KappaBar calculation in nondir CC 633 DIRKAPB = .TRUE. 634 GO TO 1000 635 99 CONTINUE 636C '*CCOPA ' one-photon absorption strengths 637 CALL CC_OPAINP(WORD,MSYM) 638 GO TO 1000 639 100 CONTINUE 640C '*NODDY ' 641 CALL CC_NODINP(WORD,.FALSE.) 642 GO TO 1000 643 101 CONTINUE 644 NOEONL = .TRUE. 645 GO TO 1000 646 102 CONTINUE 647C '.DIRDER' direct calculation of derivative integrals 648 DIRGRD = .TRUE. 649 GO TO 1000 650 103 CONTINUE 651C '.CCTPA ' two-photon absorption strengths 652 CALL CC_OPAINP(WORD,MSYM) 653 GO TO 1000 654 104 CONTINUE 655C '.INT4V ' use VVVV integrals in CC3 left transformation 656 LVVVV = .TRUE. 657 GO TO 1000 658 105 CONTINUE 659 ONLYMO = .TRUE. 660 GO TO 1000 661 106 CONTINUE 662C '.THRVEC' convergence threshold for norm of vector function 663 READ(LUCMD,*) RDTHVC 664 IF (RDTHVC .GT. 0.0D0) THRVEC = RDTHVC 665 GO TO 1000 666 107 CONTINUE 667 MTRIP = .TRUE. 668 GO TO 1000 669 108 CONTINUE 670 SIRSOP = .TRUE. 671 CC2 = .TRUE. 672 KEEPAOTWO = MAX(KEEPAOTWO,2) 673 GO TO 1000 674 109 CONTINUE 675C '.AO-SOPPA' 676 AOSOPPA = .TRUE. 677 KEEPAOIN = .TRUE. 678 GO TO 1000 679 110 CONTINUE 680C 'NOSORT' 681 NOSORT = .TRUE. 682 GO TO 1000 683 111 CONTINUE 684C 'KEPAOI' 685 KEEPAOIN = .TRUE. 686 GO TO 1000 687 112 CONTINUE 688C '*CHO(T)' 689 CHOPT = .TRUE. 690 CCPT = .TRUE. 691 CALL CC_CHOPTINP(WORD) 692 GO TO 1000 693 113 CONTINUE 694C '*CHOCC2' 695 CALL CC_CHOCC2INP(WORD) 696 GO TO 1000 697 114 CONTINUE 698C '*CHOMP2' 699 CALL CC_CHOMP2INP(WORD) 700 GO TO 1000 701 115 CONTINUE 702C '*CHODBG' 703 CALL CC_CHODBINP(WORD) 704 GO TO 1000 705 116 CONTINUE 706C '.D01SKI' 707 D01SKIP = .TRUE. 708 GO TO 1000 709 117 CONTINUE 710C '.CHO(T)' 711 CHOPT = .TRUE. 712 CCPT = .TRUE. 713 GO TO 1000 714 118 CONTINUE 715! '.T2UPDATE' 716 READ (LUCMD, *) IT2UPD 717 IF (IT2UPD.LT.0) THEN 718 IT2UPD=0 719 ELSE IF (IT2UPD.GT.1) THEN 720 IT2UPD=1 721 END IF 722 GO TO 1000 723 119 CONTINUE 724 !SONIA/FRAN 725 RCCD = .TRUE. 726C write(lupri,*)'FRAN: activated ring CCD' 727 GO TO 1000 728 120 CONTINUE 729! '.RTCCD' 730 RTCCD = .TRUE. 731C write(lupri,*)'SONIA: activated triplet-ring CCD' 732 GO TO 1000 733 121 CONTINUE 734! '.DRCCD' 735 DRCCD = .TRUE. 736C write(lupri,*)'FRAN: activated direct-ring CCD' 737 GO TO 1000 738 122 CONTINUE 739! '.SOSEX ' 740 DRCCD=.TRUE. 741 SOSEX=.TRUE. 742C write(lupri,*)'SONIA: activated SOSEX (DRCCD)' 743 GO TO 1000 744 123 CONTINUE 745! '.T2START' 746 READ (LUCMD, *) IT2START 747 IF (IT2START.LT.-1) THEN 748 IT2START=0 749 ELSE IF (IT2START.GT.1) THEN 750 IT2START=1 751 END IF 752 IF (IT2START.EQ.1) THEN 753 WRITE(LUPRI,*)'Using New Initial T2 Guess' 754 ELSE IF (IT2START.EQ.0) THEN 755 WRITE(LUPRI,*)'Using Standard MP2 Initial T2 Guess' 756 ELSE IF (IT2START.EQ.-1) THEN 757 WRITE(LUPRI,*)'Using DEC-Style Initial T2 Guess (=0)' 758 ENDIF 759 GO TO 1000 760 124 CONTINUE 761! '.HURWITZ' 762 HURWITZ_CHECK=.TRUE. 763 WRITE(LUPRI,*)'HURWITZ_CHECK activated in input' 764 GO TO 1000 765 125 CONTINUE 766! '.DCPT2' 767 DCPT2 = .TRUE. 768 write(lupri,*)'DCPT2 Calculation.' 769 WRITE(LUPRI,*)'See Assfeld, Almlof and Truhlar, ' 770 WRITE(LUPRI,*)'CPL 241, 438 (1995)' 771 GO TO 1000 772 126 CONTINUE 773C '*MLCC3 ' 774C Multi-Level CC3 775 MLCC3 = .TRUE. 776 call mlcc3_input(word,lucmd) 777 GO TO 1000 778 127 CONTINUE 779C '*MLCCPT ' 780C Multi-Level CCSD(T) 781 MLCCSDPT = .TRUE. 782 call mlccsdpt_input(word,lucmd) 783 GO TO 1000 784 128 CONTINUE 785C Polarizable Embedding Coupled Cluster with the PElib implementation 786C Summer 2016 787 CALL CC_PEINP(WORD) 788 GO TO 1000 789 ELSE 790 WRITE (LUPRI,'(/3A,/)') ' Prompt "',WORD, 791 * '" not recognized in CC2INP.' 792 CALL PRTAB(NTABLE,TABLE,WORD1//' input keywords',LUPRI) 793 CALL QUIT('Illegal prompt in CC2INP.') 794 END IF 795 END IF 796 300 CONTINUE 797 798#ifdef VAR_MPI 799 IF (NEWDEF.AND.PARCAL) THEN 800CRF moved this to after the input is read 801C 802C Beyer 803C SOPPA runs in parallel now and needs Coupled Cluster 804C Amplitudes. Hard coding a stop in parallel CC code will break all 805C parallel SOPPA routines. 806C 807C When CC runs in parallel you can remove this check and the #include "soppinf.h" 808C from the list of COMMON block inclusions. 809 IF ( (.NOT. AOSOPPA) ) THEN 810 WRITE(LUPRI,*) "WARNING: CC is not MPI parallelized!" 811 WRITE(LUPRI,*) 812 & "For parallelization speedup, e.g. use parallel MKL" 813 CALL PARQUIT("CC ") 814 ENDIF 815C End Beyer 816 ENDIF 817#endif 818C 819C--------------------------------------------------- 820C set some defaults... 821C--------------------------------------------------- 822C 823 MSYM = MSYMS 824 IF (ITEST .EQ. 0 ) THEN 825 MINSCR = .TRUE. 826 IF (DIRECT) MINSCR = .FALSE. 827 MINMEM = .FALSE. 828 IF (DIRECT) MINMEM = .FALSE. 829Casm 830 IF (CHEXDI) MINSCR = .TRUE. 831Casm 832 ENDIF 833 IF ( .NOT. MINSCR ) MINMEM = .TRUE. 834 835 DIRGRD = ( DIRGRD .OR. DIRECT ) 836 837 !Sonia: replace ETAPTI keyword.... 838 ETACCPT = ( (OPTNEW.OR.CCDERI).AND.(CCPT) ) 839 840Cho 841 IF (CHOINT) IPRINT = MAX(IPRINT,1) 842 IF (CHOINT) THRVEC = THRENR*1.0D2 843Cho 844 RETURN 845 END 846C /* Deck CC_PRTINP */ 847 SUBROUTINE CC_PRTINP(IWUNIT) 848 USE PELIB_INTERFACE, ONLY: USE_PELIB 849C 850C K.Ruud, Jan.-96. Split from CC_INPUT in order to place CC output more 851C adequatly in SIRIUS Print of input processing 852C 853#include "implicit.h" 854#include "priunit.h" 855#include "cclrinf.h" 856#include "cclr.h" 857#include "ccfop.h" 858#include "ccsdinp.h" 859#include "ccsections.h" 860#include "cclres.h" 861#include "ccqr2r.h" 862#include "ccfield.h" 863#include "ccsdsym.h" 864C 865 IF (ICHANG .GT. 0) THEN 866 IF (IWUNIT .eq. LUPRI) THEN 867 CALL HEADER('Changes of defaults for CC:',0) 868 ELSE 869 WRITE(IWUNIT,'(//10X,A/10X,A/)') 870 & 'Changes of defaults for CC:', 871 & '---------------------------' 872 END IF 873 IF (SKIP) THEN 874 WRITE (IWUNIT,'(A)') ' -CCSD skipped in this run.' 875 ELSE 876C 877 IF (DIRECT) WRITE (IWUNIT,'(/A/A)') 878 * ' -This is a direct atomic orbital integral based', 879 * ' calculation for coupled cluster wave function' 880C 881 IF (CCSDT) WRITE (IWUNIT,'(/A)') 882 * ' -Iterative triple excitations included ' 883C 884 IF (FROIMP) WRITE(IWUNIT,'(/A)') 885 * ' -Implicit frozen core calculation' 886C 887 IF (FROEXP) WRITE(IWUNIT,'(/A)') 888 * ' -Explicit frozen core calculation' 889C 890 IF (.NOT. T2TCOR) WRITE(IWUNIT,'(/A)') 891 * ' -Transposed t2-amplitudes not hold in core' 892C 893 IF (NFIELD.GT.0) THEN 894 WRITE(IWUNIT,'(A)') ' -Calculation with finite fields:' 895 DO IF = 1, NFIELD 896 WRITE(IWUNIT,'(A,F10.6,A,A8)') 897 * ' Field strength: ',EFIELD(IF), 898 * 'Field Label: ',LFIELD(IF) 899 END DO 900 CALL CC_FIELD_PRTINP(IWUNIT) 901 IF (CCSDT.AND.NONHF) THEN 902 IF (.NOT. CC3) THEN 903 WRITE(IWUNIT,*)'No triples unrelaxed FF possibility' 904 CALL QUIT('No triples unrelaxed FF possibility') 905 ENDIF 906 ENDIF 907 IF (CCS.AND.NONHF) THEN 908 WRITE(IWUNIT,*) 'No CCS unrelaxed FF possibility ' 909 WRITE(IWUNIT,*) 'Use instead CC2 with CCSTST option.' 910 CALL QUIT('No CCS unrelaxed FF possibility') 911 ENDIF 912 IF (NONHF .AND. RELORB) THEN 913 WRITE(IWUNIT,*) 'Inconsistency: Non HF reference and ' 914 * //'relaxed derivative requested' 915 CALL QUIT('Inconsistency: in FF '// 916 & 'and relaxed derivative') 917 ENDIF 918 ! put operators for "unrelaxed" fields on common CCRSPOP 919 ! (needed for CCR12 with unrelaxed finite fields) 920 IF (NONHF) THEN 921 DO IFIELD = 1, NFIELD 922 IDX = INDPRP_CC(LFIELD(IFIELD)) 923 END DO 924 END IF 925 END IF 926C 927 IF (LHTR.AND.((CCLRSD).OR. 928 * (CCR3.OR.CCRT.OR.CCR1A.OR.CC1B.OR.CC1A.OR.CC1B))) 929 * THEN 930 WRITE(IWUNIT,*) 'Input inconsistent due to LHTR ' 931 CALL QUIT('Do not use LHTR for this '// 932 & 'type of calculation ') 933 ENDIF 934C 935 IF ((CCSLV.OR.USE_PELIB()).AND.CCTPA) THEN 936 IF (CCLR.OR.CCQR.OR.CCCR) THEN 937 WRITE(IQUNIT,*) 938 & 'For embedding calcs. avoid TPA and LR/QR/CR simul' 939 CALL QUIT('FOR CCSLV/PE-CC dont do TPA and '// 940 & 'LR/QR/CR at the same time - avoid '// 941 & 'confusion') 942 END IF 943 END IF 944C 945 IF ( DEBUG ) WRITE(IWUNIT,'(A)') 946 * ' -Debug printout activated ' 947 IF ( CCEXCI ) WRITE(IWUNIT,'(A)') 948 * ' -Excitation energies calculated' 949 IF ( CCLRSD .OR. CCOPA) WRITE(IWUNIT,'(A)') 950 * ' -One-photon absorption strengths will be calculated' 951 IF ( CCTPA ) WRITE(IWUNIT,'(A)') 952 * ' -Two-photon absorption strengths will be calculated' 953 IF ( JACTST ) WRITE(IWUNIT,'(A)') 954 * ' -Jacobian tested agains finite difference Jacobian' 955 IF ( JACEXP ) WRITE(IWUNIT,'(A)') 956 * ' -Jacobian constructed explicit' 957 IF ( FDEXCI ) WRITE(IWUNIT,'(A)') 958 * ' -Excitation energies of finite diff. Jacobian calc.' 959 IF ( CCLR ) WRITE(IWUNIT,'(A)') 960 * ' -Linear response properties calculated' 961 IF ( CAUCHY) WRITE(IWUNIT,'(A)') 962 * ' -Dispersion coefficients for linear response calc.' 963 IF ( CCLRLCZ ) WRITE(IWUNIT,'(A)') 964 * ' -Damped Linear Response via Lanczos algorithm' 965 IF ( CCQR ) WRITE(IWUNIT,'(A)') 966 * ' -Quadratic response properties calculated' 967 IF ( CCCR ) WRITE(IWUNIT,'(A)') 968 * ' -Cubic response properties calculated' 969 IF ( OSCSTR) WRITE(IWUNIT,'(A)') 970 * ' -Oscillator strengths calculated' 971 IF ( CCQR2R .OR. CCXOPA) WRITE(IWUNIT,'(A)') 972 * ' -Transition strengths between two excited states '// 973 * 'calculated.' 974 IF (CCEXGR) WRITE(IWUNIT,'(A)') 975 * ' -Excited state properties calculated' 976 IF ( CCMCD ) WRITE(IWUNIT,'(A)') 977 * ' -Magnetic circular dichroism B calculated' 978 IF (DIPMOM) WRITE(IWUNIT,'(A)') 979 * ' -Dipole moment calculated' 980 IF (QUADRU) WRITE(IWUNIT,'(A)') 981 * ' -Traceless quadrupole moment calculated' 982 IF (NQCC) WRITE(IWUNIT,'(A)') 983 * ' -Electric field gradient calculated' 984 IF (RELCOR) WRITE(IWUNIT,'(A)') 985 * ' -Relativistic corrections to energy calculated' 986 IF (SECMOM) WRITE(IWUNIT,'(A)') 987 * ' -Electronic second moment of charge calculated' 988 IF (DAR2EL) WRITE(IWUNIT,'(A)') 989 * ' -Relativistic two-electron Darwin term calculated' 990 IF (DPTECO) WRITE(IWUNIT,'(A)') 991 * ' -First-order DPT energy corrections calculated' 992 IF (SIRSOP .AND. CCSD) WRITE (IWUNIT,'(A)') 993 * ' -CCSD Amplitudes appended to Sirius interface'// 994 * ' for SOPPA(CCSD)' 995 IF (SIRSOP .AND. CC2) WRITE (IWUNIT,'(A)') 996 * ' -CC2 Amplitudes appended to Sirius interface'// 997 * ' for SOPPA(CC2)' 998 IF (AOSOPPA) WRITE (IWUNIT,'(/A,A)') 999 * ' MP2 Amplitudes written for atom integral direct', 1000 * ' SOPPA calculations' 1001C 1002 END IF 1003 WRITE (IWUNIT,'(A)') ' ' 1004 END IF 1005C 1006 RETURN 1007 END 1008c /* deck CC_FIELD_PRTINP */ 1009 SUBROUTINE CC_FIELD_PRTINP(IWUNIT) 1010C 1011C Calculate nuclear contribution to energy in electric field 1012C 1013C The dipole moment origin is the center of charge. 1014C It is assumed that the molecule is properly oriented. 1015C 1016C ASM & JCh February 1996 1017C 1018#include "implicit.h" 1019#include "priunit.h" 1020#include "maxaqn.h" 1021#include "mxcent.h" 1022#include "maxorb.h" 1023#include "nuclei.h" 1024#include "symmet.h" 1025#include "ccfield.h" 1026#include "ccorb.h" 1027C 1028 PARAMETER (ZERO = 0.0D0) 1029C 1030 DIMENSION GEOM(3,MXCENT), QCHAR(MXCENT), ELEFLD(3) 1031C 1032 CHARACTER*6 FLDTYP 1033 CHARACTER*1 FLDDIR 1034C 1035 1036C 1037C---------------------------------------------- 1038C Calculate total electric field. 1039C---------------------------------------------- 1040C 1041 CALL DZERO(ELEFLD,3) 1042C 1043 DO 200 I = 1,NFIELD 1044C 1045 FLDTYP = LFIELD(I)(2:7) 1046 FLDDIR = LFIELD(I)(1:1) 1047C 1048 IF (FLDTYP .EQ. 'DIPLEN') THEN 1049C 1050 IF (FLDDIR .EQ. 'X') THEN 1051 JDIR = 1 1052 ELSE IF (FLDDIR .EQ. 'Y') THEN 1053 JDIR = 2 1054 ELSE 1055 JDIR = 3 1056 END IF 1057C 1058 ELEFLD(JDIR) = ELEFLD(JDIR) + EFIELD(I) 1059C 1060 END IF 1061C 1062 200 CONTINUE 1063C 1064 ELFLNR = DSQRT(DDOT(3,ELEFLD,1,ELEFLD,1)) 1065C 1066 IF (ELFLNR .NE. 0.0D0) THEN 1067C 1068 WRITE(IWUNIT,'(/A,3F14.8/A,F14.8)') 1069 & ' Electric field: ',(ELEFLD(I),I=1,3), 1070 & ' Total norm: ',ELFLNR 1071C 1072 END IF 1073C 1074C---------------------------------------------- 1075C Cartesian coordinates of dependent atoms. 1076C---------------------------------------------- 1077C 1078 JATOM = 0 1079 DO 300 ICENT = 1, NUCIND 1080C 1081 MULCNT = ISTBNU(ICENT) 1082C 1083 IF (MULT(MULCNT) .EQ. 1) THEN 1084C 1085 JATOM = JATOM + 1 1086C 1087 QCHAR(JATOM) = CHARGE(ICENT) 1088C 1089 DO 310 I = 1,3 1090 GEOM(I,JATOM) = CORD(I,ICENT) 1091 310 CONTINUE 1092C 1093 ELSE 1094C 1095 DO 320 ISYOPR = 0,MAXOPR 1096 IF (IAND(ISYOPR,MULCNT) .EQ. 0) THEN 1097C 1098 JATOM = JATOM + 1 1099C 1100 QCHAR(JATOM) = CHARGE(ICENT) 1101C 1102 DO 330 I = 1,3 1103C 1104 PTAT = PT(IAND(ISYMAX(I,1),ISYOPR)) 1105 GEOM(I,JATOM) = PTAT*CORD(I,ICENT) 1106C 1107 330 CONTINUE 1108C 1109 END IF 1110 320 CONTINUE 1111C 1112 END IF 1113C 1114 300 CONTINUE 1115C 1116C----------------------------------------- 1117C Coordinates of the center of charge. 1118C----------------------------------------- 1119C 1120 XCQ = ZERO 1121 YCQ = ZERO 1122 ZCQ = ZERO 1123 SUMQ = ZERO 1124C 1125 DO 400 I = 1,NUCDEP 1126C 1127 XCQ = XCQ + GEOM(1,I)*QCHAR(I) 1128 YCQ = YCQ + GEOM(2,I)*QCHAR(I) 1129 ZCQ = ZCQ + GEOM(3,I)*QCHAR(I) 1130 SUMQ = SUMQ + QCHAR(I) 1131C 1132 400 CONTINUE 1133C 1134 CORR = -(XCQ*ELEFLD(1) + YCQ*ELEFLD(2) + ZCQ*ELEFLD(3)) 1135C 1136 XCQ = XCQ/SUMQ 1137 YCQ = YCQ/SUMQ 1138 ZCQ = ZCQ/SUMQ 1139C 1140C----------------------------------------------- 1141C Contribution relative to center of charge. 1142C----------------------------------------------- 1143C 1144C QTOT = DFLOAT(NRHFTS*2) 1145C CORR = -QTOT*(XCQ*ELEFLD(1) + YCQ*ELEFLD(2) + ZCQ*ELEFLD(3)) 1146C 1147 WRITE(IWUNIT,'(A,3F14.8)') 'Center of charge:',XCQ,YCQ,ZCQ 1148 WRITE(IWUNIT,'(2A,F14.8)') 'Charge correction to interaction ', 1149 * 'with electric field:', CORR 1150 WRITE(IWUNIT,*) 1151C 1152 RETURN 1153 END 1154 SUBROUTINE CC_FSIR(MXFEL,NFIEL,LFIEL,EFIEL,NHFFIELD) 1155C 1156C If field was set in Hartree-Fock transfer to CC. 1157C 1158C Ove Christiansen 11-6-1996 1159C 1160#include "implicit.h" 1161#include "priunit.h" 1162#include "maxorb.h" 1163#include "infinp.h" 1164C 1165 DIMENSION EFIEL(MXFEL) 1166 CHARACTER*8 LFIEL(MXFEL) 1167 LOGICAL NHFFIELD(MXFEL) 1168C 1169 IF (NFIELD .GT. 0 ) THEN 1170 IF (NFIELD.GT.MXFEL) THEN 1171 WRITE (LUPRI,*) 1172 * 'CC_FSIR: Too many fields added in Hartree Fock.' 1173 CALL QUIT('CC_FSIR: Too many fields added in Hartree Fock.') 1174 END IF 1175 NFIEL = NFIELD 1176 DO IF = 1, NFIELD 1177 LFIEL(IF) = LFIELD(IF) 1178 EFIEL(IF) = EFIELD(IF) 1179 NHFFIELD(IF) = .FALSE. 1180 END DO 1181 ENDIF 1182C 1183 RETURN 1184 END 1185c /* deck cc_excinp */ 1186C=====================================================================* 1187 SUBROUTINE CC_EXCINP(WORD,MSYM) 1188C---------------------------------------------------------------------* 1189C 1190C Purpose: Read input for CC excited state calculations. 1191C 1192C if (WORD .eq '*CCEXCI ') read & process input and set defaults, 1193C else set only defaults 1194C 1195C Ove Christiansen 24-10 1996 1196C Kasper Hald & Christof Haettig 12-08-99, changes for triplet 1197C Sonia Coriani 2015, input for core-valence separation and 1198C ionization 1199C 1200C=====================================================================* 1201#include "implicit.h" 1202#include "priunit.h" 1203#include "ccsdinp.h" 1204#include "ccsections.h" 1205#include "ccsdsym.h" 1206#include "cclr.h" 1207#include "cclres.h" 1208#include "leinf.h" 1209#include "cclrinf.h" 1210#include "ccrspprp.h" 1211#include "ccexci.h" 1212!SONIA: CVS and IONISATION 1213#include "ccexcicvs.h" 1214 1215#include "maxorb.h" 1216#include "ccdeco.h" 1217 1218* local parameters: 1219 CHARACTER SECNAM*(9) 1220 PARAMETER (SECNAM='CC_EXCINP') 1221 1222 LOGICAL LSTVEC 1223 INTEGER NTABLE 1224 PARAMETER (NTABLE = 29) 1225 1226 DIMENSION NSTAR(8) 1227 1228* variables: 1229 LOGICAL SET 1230 SAVE SET 1231 1232 CHARACTER WORD*(7) 1233 CHARACTER TABLE(NTABLE)*(8) 1234 1235 INTEGER IJUMP, NTRIP 1236 1237* data: 1238 DATA SET /.FALSE./ 1239 DATA TABLE /'.NCCEXC','.R3DIIS','.FDJAC ','.FDEXCI','.JACEXP', 1240 * '.JACTST','.LHTR ','.NOSCOM','.STSD ','.TOLSC ', 1241 * '.OMEINP','.STVEC ','.STOLD ','.CCTREN','.THREXC', 1242 * '.CCSPIC','.CC2PIC','.CCSDPI','.MARGIN','.SQROVL', 1243 * '.ANALYS','.CVSEPA','.IONISA','.CVSPER','.RMCORE', 1244 * '.CHEXDI','.DV4DIS','.JACEXT','.XXXXXX'/ 1245 1246*---------------------------------------------------------------------* 1247* begin: 1248*---------------------------------------------------------------------* 1249 IF (SET) RETURN 1250 SET = .TRUE. 1251 1252*---------------------------------------------------------------------* 1253* initializations & defaults: 1254*---------------------------------------------------------------------* 1255C 1256 CCSDT_DIIS = .FALSE. 1257 FDJAC = .FALSE. 1258 FDEXCI = .FALSE. 1259 JACEXP = .FALSE. 1260 JACEXT = .FALSE. 1261 JACTST = .FALSE. 1262 LHTR = .FALSE. 1263 OMESC = .TRUE. 1264 STSD = .FALSE. 1265 TOLSC = 1.0D-04 1266 STVEC = .FALSE. 1267 STOLD = .FALSE. 1268 THREXC = 1.0D-04 1269 CCSPIC = .FALSE. 1270 CC2PIC = .FALSE. 1271 CCSDPI = .FALSE. 1272 OMPCCS = 0.0D0 1273 OMPCC2 = 0.0D0 1274 OMPCCSD= 0.0D0 1275 MARGIN = .FALSE. 1276 EXCI_CONT = .FALSE. 1277 XMARGIN = 1.0 1278C 1279 CHEXDI = .FALSE. 1280 DV4DIS = .FALSE. 1281C 1282 SQROVLP = .FALSE. 1283 CCSDTRENRM = .FALSE. 1284C 1285 CALL IZERO(NCCEXCI,3*8) 1286 CALL IZERO(NOMINP,3*8) 1287C 1288C Other initializations 1289C 1290 NSIDE = 1 1291 STCCS = .FALSE. 1292C 1293C Core-valence separation and ionisation 1294C within CCEXCI 1295C Sonia 1296C 1297 LCVSEXCI = .FALSE. 1298 LIONIZEXCI = .FALSE. 1299 LBOTHEXCI = .FALSE. 1300 CALL IZERO(NRHFCORE,8) 1301 CALL IZERO(IRHFCORE,8*MAXCORE) 1302 CALL IZERO(NVIRION,8) 1303 CALL IZERO(IVIRION,8*MAXION) 1304 !for the time being I am assuming to compute the correction for all 1305 !requested excitations 1306 LCVSPTEXCI = .FALSE. 1307 LRMCORE = .FALSE. 1308*---------------------------------------------------------------------* 1309* read input: 1310*---------------------------------------------------------------------* 1311 IF (WORD(1:7) .EQ. '*CCEXCI') THEN 1312 1313100 CONTINUE 1314 1315* get new input line: 1316 READ (LUCMD,'(A7)') WORD 1317 CALL UPCASE(WORD) 1318 DO WHILE ( WORD(1:1) .EQ. '!' .OR. WORD(1:1) .EQ. '#' ) 1319 READ (LUCMD,'(A7)') WORD 1320 CALL UPCASE(WORD) 1321 END DO 1322 1323 IF (WORD(1:1) .EQ. '.') THEN 1324 1325c table look up: 1326 IJUMP = 1 1327 DO WHILE ( IJUMP .LE. NTABLE .AND. TABLE(IJUMP) .NE. WORD) 1328 IJUMP = IJUMP + 1 1329 END DO 1330 1331c jump to the appropriate input section: 1332 IF (IJUMP .LE. NTABLE) THEN 1333 ICHANG = ICHANG + 1 1334 GOTO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20, 1335 * 21,22,23,24,25,26,27,28,29),IJUMP 1336 CALL QUIT('Illegal address in computed GOTO in CC_EXCINP.') 1337 1338C ------------------------------------------- 1339C .NCCEXC # excitation energies to solve for: 1340C ------------------------------------------- 13411 CONTINUE 1342 ! read # singlet states 1343 READ (LUCMD,*) (NCCEXCI(ISYM,1),ISYM=1,MSYM) 1344 1345 WRITE (LUPRI,'(A,8I5)') 'NCCEXCI for singlet:', 1346 & (NCCEXCI(ISYM,1),ISYM=1,MSYM) 1347 1348 ! check for further excitation energy input: 1349 READ (LUCMD,'(A7)') WORD 1350 CALL UPCASE(WORD) 1351 BACKSPACE(LUCMD) 1352 IF (WORD(1:1).NE.'.' .AND. WORD(1:1).NE.'*' 1353 & .AND. WORD(1:1).NE.'!' ) THEN 1354 1355 ! read # triplet states 1356 READ (LUCMD,*) (NCCEXCI(ISYM,3),ISYM=1,MSYM) 1357 WRITE (LUPRI,'(A,8I5)') 'NCCEXCI for triplet:', 1358 & (NCCEXCI(ISYM,3),ISYM=1,MSYM) 1359 END IF 1360 GO TO 100 1361 1362C 1363C--------------------------------------------------------------- 1364C .R3DIIS use CCDIIS_SOL for iterative triples models 1365C--------------------------------------------------------------- 1366C 13672 CONTINUE 1368 CCSDT_DIIS = .TRUE. 1369 GO TO 100 1370 1371C 1372C-------------------------------------------------------- 1373C .FDJAC Calculate Finited difference jacobian: 1374C-------------------------------------------------------- 1375C 13763 CONTINUE 1377 FDJAC = .TRUE. 1378 GO TO 100 1379 1380C 1381C---------------------------------------------------------- 1382C .FDEXCI Diagonalize finite difference jacobian: 1383C---------------------------------------------------------- 1384C 13854 CONTINUE 1386 FDEXCI = .TRUE. 1387 GO TO 100 1388 1389C 1390C------------------------------------------------- 1391C .JACEXP : Construct jacobian explicit: 1392C------------------------------------------------- 1393C 13945 CONTINUE 1395 JACEXP = .TRUE. 1396 GO TO 100 1397C 1398C------------------------- 1399C .JACTST : Jacobian test. 1400C------------------------- 1401C 14026 CONTINUE 1403 JACTST = .TRUE. 1404 GO TO 100 1405C 1406C --------------------------------------------------- 1407C .LHTR : Use left hand transformation in calculation 1408C of excitation energies. 1409C --------------------------------------------------- 1410C 14117 CONTINUE 1412 LHTR = .TRUE. 1413 GO TO 100 1414C 1415C --------------------------------------------- 1416C .NOSCOM : Do not solve self-consistently for 1417C triples excitation energies. 1418C --------------------------------------------- 14198 CONTINUE 1420 OMESC = .FALSE. 1421 GO TO 100 1422C 1423C ---------------------------------------------------- 1424C .STSD Start with calculation of singles and doubles 1425C excitation energies with triples amplitudes. 1426C ---------------------------------------------------- 14279 CONTINUE 1428 STSD = .TRUE. 1429 GO TO 100 1430C 1431C-------------------------------------------------------------- 1432C .TOLSC : Set threshold for solving selfconsitently. 1433C-------------------------------------------------------------- 1434C 143510 CONTINUE 1436 READ (LUCMD, *) TOLSC 1437 GO TO 100 1438C 1439C---------------------------------------------------------- 1440C .OMEINP : Readin omega for triples calculation. 1441C---------------------------------------------------------- 1442C 144311 CONTINUE 1444C Read the singlet states 1445 READ (LUCMD,*) (NOMINP(ISYM,1),ISYM=1,MSYM) 1446 OMEINP = .TRUE. 1447 DO 131 ISYM = 1, MSYM 1448 DO 132 IOM = 1, NOMINP(ISYM,1) 1449 READ (LUCMD,*) IOMINP(IOM,ISYM,1), 1450 * EOMINP(IOM,ISYM,1) 1451 132 CONTINUE 1452 131 CONTINUE 1453C 1454C Check for further excitation energy input: 1455 READ(LUCMD,'(A7)') WORD 1456 CALL UPCASE(WORD) 1457 BACKSPACE(LUCMD) 1458 IF (WORD(1:1).NE.'.' .AND. WORD(1:1).NE.'*' 1459 * .AND. WORD(1:1).NE.'#' .AND. WORD(1:1).NE.'!' ) THEN 1460C 1461C Readin for the triplet states 1462 READ (LUCMD,*) (NOMINP(ISYM,3),ISYM=1,MSYM) 1463 DO 133 ISYM = 1, MSYM 1464 DO 134 IOM = 1, NOMINP(ISYM,3) 1465 READ (LUCMD,*) IOMINP(IOM,ISYM,3), 1466 * EOMINP(IOM,ISYM,3) 1467 134 CONTINUE 1468 133 CONTINUE 1469 END IF 1470C 1471 GO TO 100 1472C 1473C-------------------------------- 1474C .STVEC : Choose start vectors. 1475C-------------------------------- 1476C 147712 CONTINUE 1478 STVEC = .TRUE. 1479 READ (LUCMD,*) (NSTAR(ISYM),ISYM=1,MSYM) 1480 DO 331 ISYM = 1, MSYM 1481 READ (LUCMD,*) (ISTVEC(K,ISYM),K=1,NSTAR(ISYM)) 1482 331 CONTINUE 1483 GO TO 100 1484C 1485C 1486C-------------------------------------------------- 1487C .STOLD : Start from old vectors on file. 1488C-------------------------------------------------- 1489C 149013 CONTINUE 1491 STOLD = .TRUE. 1492 GO TO 100 1493C----------------------------------------------------------------------- 1494C .CCTREN : normalize right eigenvectors for triples methods 1495C such that ( RE S+D+T | RE S+D+T ) = 1, default is 1496C to normalize as ( RE S+D | RE S+D ) = 1 1497C (see routine CCEXNORM) 1498C----------------------------------------------------------------------- 1499C 150014 CONTINUE 1501 CCSDTRENRM = .TRUE. 1502 GO TO 100 1503C 1504C------------------------------------------------------------------------ 1505C .THREXC Set threshold for calculation of excitation energies. 1506C------------------------------------------------------------------------ 1507C 150815 CONTINUE 1509 READ (LUCMD, *) THREXC 1510 GO TO 100 1511C 1512C--------------------------------------------------------------- 1513C .CCSPIC Pick istate with right CCS excitation energy 1514C--------------------------------------------------------------- 1515C 1516 151716 CONTINUE 1518 CCSPIC = .TRUE. 1519 READ(LUCMD,*) OMPCCS 1520 GO TO 100 1521C 1522C--------------------------------------------------------------- 1523C .CC2PIC Pick istate with right CC2 excitation energy 1524C--------------------------------------------------------------- 1525C 152617 CONTINUE 1527 CC2PIC = .TRUE. 1528 READ(LUCMD,*) OMPCC2 1529 GO TO 100 1530C 1531C----------------------------------------------------------------- 1532C .CCSDPIC Pick istate with right CCSD excitation energy 1533C----------------------------------------------------------------- 1534C 153518 CONTINUE 1536 CCSDPI = .TRUE. 1537 READ(LUCMD,*) OMPCCSD 1538 GO TO 100 1539C 1540C------------------------------------------------------------ 1541C .MARGIN; Give margin in the 'picking' of states. 1542C------------------------------------------------------------ 1543C 154419 CONTINUE 1545 MARGIN = .TRUE. 1546 READ(LUCMD,*) XMARGIN 1547 GO TO 100 1548C 1549C---------------------------------------------------------------- 1550C .SQROVL Compute full overlap matrix for eigenvectors 1551C (test option, see subroutine CCEXNORM) 1552C---------------------------------------------------------------- 1553C 155420 CONTINUE 1555 SQROVLP = .TRUE. 1556 GO TO 100 1557C 1558C---------------------------------------------------------------- 1559C .ANALYS unused 1560C---------------------------------------------------------------- 1561C 156221 CONTINUE 1563 EXCI_CONT = .TRUE. 1564 GO TO 100 1565C 1566C---------------------------------------------------------------- 1567C Core-Valence Separation (CVS) - freeze valence excs 1568C---------------------------------------------------------------- 1569C 157022 CONTINUE 1571 LCVSEXCI = .TRUE. 1572 WRITE(LUPRI,*)'CCSD_INPUT: core-val requested' 1573 !how many per symmetry 1574 READ(LUCMD,*) (NRHFCORE(I),I=1,MSYM) 1575 !which ones 1576 DO I = 1, MSYM 1577 IF (NRHFCORE(I) .GT. MAXCORE) THEN 1578 WRITE(LUPRI,*) 1579 WRITE(LUPRI,*) 'Too many requested cores' 1580 WRITE(LUPRI,*) 'Symmetry: ', I 1581 WRITE(LUPRI,*) 'Requested cores: ', NRHFCORE(I) 1582 WRITE(LUPRI,*) 'MAXCORE: ', MAXCORE 1583 WRITE(LUPRI,*) 1584 CALL QUIT('Too many requested cores in CC_EXCINP') 1585 END IF 1586 READ(LUCMD,*) (IRHFCORE(J,I),J=1,NRHFCORE(I)) 1587 END DO 1588 WRITE(LUPRI,*)'Requested number of core orbs per sym' 1589 write(lupri,*) (NRHFCORE(I),I=1,MSYM) 1590 WRITE(LUPRI,*)'Indices of requested core orbs' 1591 DO I = 1, MSYM 1592 write(LUpri,*) (IRHFCORE(J,I),J=1,NRHFCORE(I)) 1593 END DO 1594 GO TO 100 1595C 1596C---------------------------------------------------------------- 1597C .IONISATION 1598C---------------------------------------------------------------- 1599C 160023 CONTINUE 1601 LIONIZEXCI = .TRUE. 1602 WRITE(LUPRI,*)'CCSD_INPUT: core-val requested' 1603 !how many per symmetry 1604 READ(LUCMD,*) (NVIRION(I),I=1,MSYM) 1605 !which ones 1606 DO I = 1, MSYM 1607 IF (NVIRION(I) .GT. MAXION) THEN 1608 WRITE(LUPRI,*) 1609 WRITE(LUPRI,*) 'Too many requested ion orbitals' 1610 WRITE(LUPRI,*) 'Symmetry: ', I 1611 WRITE(LUPRI,*) 'Requested orbitals: ', NVIRION(I) 1612 WRITE(LUPRI,*) 'MAXION: ', MAXION 1613 WRITE(LUPRI,*) 1614 CALL QUIT('Too many ion orbitals in CC_EXCINP') 1615 END IF 1616 READ(LUCMD,*) (IVIRION(J,I),J=1,NVIRION(I)) 1617 END DO 1618 WRITE(LUPRI,*)'Requested number of virtual orbs per sym' 1619 write(lupri,*) (NVIRION(I),I=1,MSYM) 1620 WRITE(LUPRI,*)'Indices of requested virtual orbs' 1621 DO I = 1, MSYM 1622 write(LUpri,*) (IVIRION(J,I),J=1,NVIRION(I)) 1623 END DO 1624C---------------------------------------------------------------- 1625CDISABLED .CVSPERTurbation correction 1626C---------------------------------------------------------------- 1627C 162824 CONTINUE 1629 !LCVSPTEXCI = .true. 1630 GO TO 100 1631C 1632C---------------------------------------------------------------- 1633C .RMCORE remove the core excitations 1634C---------------------------------------------------------------- 1635C 163625 CONTINUE 1637 LRMCORE = .TRUE. 1638 WRITE(LUPRI,*)'CCSD_INPUT: core removal requested' 1639 !how many per symmetry 1640 READ(LUCMD,*) (NRHFCORE(I),I=1,MSYM) 1641 !which ones 1642 DO I = 1, MSYM 1643 READ(LUCMD,*) (IRHFCORE(J,I),J=1,NRHFCORE(I)) 1644 END DO 1645 WRITE(LUPRI,*)'Requested number of core orbs per sym' 1646 write(lupri,*) (NRHFCORE(I),I=1,MSYM) 1647 WRITE(LUPRI,*)'Indices of requested core orbs' 1648 DO I = 1, MSYM 1649 write(LUpri,*) (IRHFCORE(J,I),J=1,NRHFCORE(I)) 1650 END DO 1651 GO TO 100 1652 1653C 1654C---------------------------------------------------------------- 1655C .CHEXDI Use DIIS solver for Cholesky CC2 excitations 1656C---------------------------------------------------------------- 1657C 165826 CONTINUE 1659 CHEXDI = .TRUE. 1660 MINSCR = .TRUE. 1661 GO TO 100 1662C 1663C---------------------------------------------------------------- 1664C .DV4DIS Use Davidson with omega=zero before CC2/DIIS 1665C---------------------------------------------------------------- 1666C 166727 CONTINUE 1668 DV4DIS = .TRUE. 1669 GO TO 100 1670C---------------------------------------------------------------- 1671C .JACEXT Explicitly calculate the Jacobian for triplet 1672C---------------------------------------------------------------- 1673C 167428 CONTINUE 1675 JACEXP = .TRUE. 1676 JACEXT = .TRUE. 1677 GO TO 100 1678C 1679C---------------------------------------------------------------- 1680C .XXXXXX unused 1681C---------------------------------------------------------------- 1682C 168329 CONTINUE 1684 GO TO 100 1685C 1686 ELSE 1687 WRITE (LUPRI,'(/5A/)') ' Prompt "',WORD, 1688 & '" not recognized in ',SECNAM,'.' 1689 CALL PRTAB(NTABLE,TABLE,SECNAM//' input keywords',LUPRI) 1690 CALL QUIT('Illegal Keyword in '//SECNAM//'.') 1691 END IF 1692 1693 ELSE IF (WORD(1:1) .NE. '*') THEN 1694 WRITE (LUPRI,'(/5A/)') 'PROMPT "',WORD, 1695 & '" NOT RECOGNIZED IN ',SECNAM,'.' 1696 CALL QUIT('Illegal prompt in '//SECNAM//'.') 1697 1698 ELSE IF (WORD(1:1) .EQ.'*') THEN 1699 BACKSPACE (LUCMD) 1700 GO TO 200 1701 END IF 1702 1703 END IF 1704 1705200 CONTINUE 1706 1707*---------------------------------------------------------------------* 1708* post processing: consistency check, symmetry set up, etc: 1709*---------------------------------------------------------------------* 1710 1711C ------------------------------------------------------------ 1712C number of start vectors must equal to the number of required 1713C excitation energies... (why?! why does a mix not work?) 1714C ------------------------------------------------------------ 1715 IF (STVEC ) THEN 1716 LSTVEC = .TRUE. 1717 DO ISYM = 1, MSYM 1718 IF (NSTAR(ISYM).NE.(NCCEXCI(ISYM,1)+NCCEXCI(ISYM,3))) THEN 1719 LSTVEC=.FALSE. 1720 END IF 1721 END DO 1722 1723 IF (.NOT. LSTVEC) THEN 1724 CALL QUIT('Inconsistent input in *CCEXCI : '// 1725 & 'NSTAR .ne. NCCEXCI ') 1726 END IF 1727 ENDIF 1728 1729C ------------------------------------------------------------ 1730C omega for triples calculation must be specified for all 1731C states (singlet or triplet at the moment) 1732C ------------------------------------------------------------ 1733 DO IMULT = 1, 3, 2 1734C 1735 NOME = 0 1736 DO ISYM = 1, MSYM 1737 NOME = NOME + NOMINP(ISYM,IMULT) 1738 IF (NOMINP(ISYM,IMULT) .GT. NCCEXCI(ISYM,IMULT)) THEN 1739 WRITE(LUPRI,*) ' NOMINP .GT. NCCEXCI for symmetry ',ISYM 1740 WRITE(LUPRI,*) ' and multiplicity ',IMULT 1741 CALL QUIT(' NOMINP .GT. NCCEXCI') 1742 ENDIF 1743 END DO 1744C 1745 IF ((OMESC.OR.(CCRT.OR.CCR3.OR.CCR1A.OR.CCR1B)) 1746 * .AND.(NOME .EQ. 0)) THEN 1747 MXTOMN = .TRUE. 1748 DO ISYM = 1, MSYM 1749 NOMINP(ISYM,IMULT) = NCCEXCI(ISYM,IMULT) 1750 DO IOM = 1, NOMINP(ISYM,IMULT) 1751 IOMINP(IOM,ISYM,IMULT) = NOMINP(ISYM,IMULT) + 1 - IOM 1752 EOMINP(IOM,ISYM,IMULT) = 0.0 1753 END DO 1754 END DO 1755C 1756 ENDIF 1757C 1758 ENDDO 1759C 1760C ---------------------------- 1761C set up symmetry information: 1762C ---------------------------- 1763 NEXCI = 0 1764 NTRIP = 0 1765 DO ISYM = 1,MSYM 1766 ISYOFE(ISYM) = NEXCI 1767 ITROFE(ISYM) = ISYOFE(ISYM) + NCCEXCI(ISYM,1) 1768 NEXCI = ITROFE(ISYM) + NCCEXCI(ISYM,3) 1769 NTRIP = NTRIP + NCCEXCI(ISYM,3) 1770 DO IEX = ISYOFE(ISYM)+1, NEXCI 1771 ISYEXC(IEX) = ISYM 1772 END DO 1773 DO IEX = ISYOFE(ISYM)+1, ITROFE(ISYM) 1774 IMULTE(IEX) = 1 1775 END DO 1776 DO IEX = ITROFE(ISYM)+1, NEXCI 1777 IMULTE(IEX) = 3 1778 END DO 1779 END DO 1780C 1781 IF (IPRINT.GT.15) THEN 1782 WRITE(LUPRI,*) 'IN CC_EXCINP: ' 1783 WRITE(LUPRI,*) 'NEXCI: ',NEXCI 1784 WRITE(LUPRI,*) 'Singlet: ',(NCCEXCI(J,1),J=1,MSYM) 1785 WRITE(LUPRI,*) 'Triplet: ',(NCCEXCI(J,3),J=1,MSYM) 1786 WRITE(LUPRI,*) 'ISYOFE:',(ISYOFE(J), J=1,MSYM) 1787 WRITE(LUPRI,*) 'ITROFE:',(ISYOFE(J), J=1,MSYM) 1788 WRITE(LUPRI,*) 'ISYEXC:',(ISYEXC(J), J=1,NEXCI) 1789 WRITE(LUPRI,*) 'IMULTE:',(IMULTE(J), J=1,NEXCI) 1790 WRITE(LUPRI,*) 'EIGVAL:',(EIGVAL(J), J=1,NEXCI) 1791 ENDIF 1792C 1793C --------------------------------------------------------------- 1794C if we are going for triplett states set flag for intermediates: 1795C --------------------------------------------------------------- 1796C 1797 IF (NTRIP.GT.0.OR.JACEXT) TRIPIM = .TRUE. 1798C 1799C ---------------------------------------------------------- 1800C initialize eigenvalues with (non-degenerate) dummy values: 1801C ---------------------------------------------------------- 1802 DO IEXCI = 1, NEXCI 1803 EIGVAL(IEXCI) = 1.0D6 + NEXCI 1804 END DO 1805C 1806C--------------------------------------------------------------------- 1807C Finally if we are to calculate anything at all, put CCEXCI true. 1808C--------------------------------------------------------------------- 1809C 1810 CCEXCI = ((NEXCI.GT.0).OR.JACTST.OR.JACEXP.OR.FDJAC.OR.FDEXCI) 1811 IF (LCVSEXCI.AND.LIONIZEXCI) LBOTHEXCI=.true. 1812 IF (CCEXCI) RSPIM = .TRUE. 1813 IF (NEXCI .EQ. 0) THEN 1814 OSCSTR = .FALSE. 1815 NINFO = NINFO + 1 1816 WRITE(LUPRI,'(/A)') '@ INFO: No excitation energy requested'// 1817 & ' even though CCEXCI is set - right?' 1818 END IF 1819C 1820 RETURN 1821 END 1822C=====================================================================* 1823c/* deck cc_lrsinp */ 1824 SUBROUTINE CC_LRSINP(WORD,MSYM) 1825C---------------------------------------------------------------------* 1826C 1827C Purpose: Read input for CC excited state calculations. 1828C 1829C if (WORD .eq '*CCLRSD ') read & process input and set defaults, 1830C else set only defaults 1831C 1832C Ove Christiansen 24-10 1996 1833C 1834C=====================================================================* 1835#include "implicit.h" 1836#include "priunit.h" 1837#include "ccsdinp.h" 1838#include "ccsections.h" 1839#include "ccsdsym.h" 1840#include "cclr.h" 1841#include "leinf.h" 1842#include "cclrinf.h" 1843#include "ccrspprp.h" 1844#include "ccexci.h" 1845#include "cclres.h" 1846 1847* local parameters: 1848 CHARACTER SECNAM*(9) 1849 PARAMETER (SECNAM='CC_LRSINP') 1850 1851 INTEGER NTABLE 1852 PARAMETER (NTABLE = 20) 1853 1854* variables: 1855 LOGICAL SET 1856 SAVE SET 1857 1858 CHARACTER WORD*(7) 1859 CHARACTER LABELA*(8),LABELB*(8),LABHELP*70 1860 CHARACTER TABLE(NTABLE)*(8) 1861 1862 INTEGER IJUMP,IDIP(3),IANG(3),IQUA(6) 1863* data: 1864 DATA SET /.FALSE./ 1865 DATA TABLE /'.DIPOLE','.ECDLEN','.DIPLEN','.NO2N+1','.OPERAT', 1866 * '.SELEXC','.DIPVEL','.DIPMIX','.ECDVEL','.OECDLE', 1867 * '.OECDVE','.OLD_LR','.BOTHLR','.NEW_LR','.ECD ', 1868 * '.OECD ','.SUMRUL','.EOMTMO','.SKIPLE','.XXXXXX'/ 1869 1870*--------------------------------------------------------------------* 1871* begin: 1872*---------------------------------------------------------------------* 1873 IF (SET) RETURN 1874 SET = .TRUE. 1875 1876*---------------------------------------------------------------------* 1877* initializations & defaults: 1878*---------------------------------------------------------------------* 1879C 1880 OSCSTR = .FALSE. 1881 VELSTR = .FALSE. 1882 MIXSTR = .FALSE. 1883 ROTLEN = .FALSE. 1884 ROTVEL = .FALSE. 1885 RTNLEN = .FALSE. 1886 RTNVEL = .FALSE. 1887 LRS2N1 = .TRUE. 1888 SELLRS = .FALSE. 1889 OLDLRS = .FALSE. 1890 BOTHLRS = .FALSE. 1891 SUMRULES = .false. 1892 EOMCCSD = .false. 1893 SKIPLEQ = .false. 1894C 1895 NSELRS = 0 1896 NLRSOP = 0 1897C 1898C Other initializations 1899C 1900 1901 ICHANG = 0 1902 1903*---------------------------------------------------------------------* 1904* read input: 1905*---------------------------------------------------------------------* 1906 IF (WORD(1:7) .EQ. '*CCLRSD') THEN 1907 1908100 CONTINUE 1909 1910* get new input line: 1911 READ (LUCMD,'(A7)') WORD 1912 CALL UPCASE(WORD) 1913 DO WHILE ( WORD(1:1) .EQ. '!' .OR. WORD(1:1) .EQ. '#' ) 1914 READ (LUCMD,'(A7)') WORD 1915 CALL UPCASE(WORD) 1916 END DO 1917 1918 IF (WORD(1:1) .EQ. '.') THEN 1919 1920c table look up: 1921 IJUMP = 1 1922 DO WHILE ( IJUMP .LE. NTABLE .AND. TABLE(IJUMP) .NE. WORD) 1923 IJUMP = IJUMP + 1 1924 END DO 1925 1926c jump to the appropriate input section: 1927 IF (IJUMP .LE. NTABLE) THEN 1928 ICHANG = ICHANG + 1 1929 GOTO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20), 1930 & IJUMP 1931 CALL QUIT('Illegal address in computed GOTO in CC_LRRINP.') 1932 1933C 1934C------------------------------------------------- 1935C Calculate dipole oscillator strengths. 1936C------------------------------------------------- 1937C 19381 CONTINUE 1939 IF (OSCSTR) GO TO 100 1940 OSCSTR = .TRUE. 1941 IF (NLRSOP+9 .GT. MXLRSO) THEN 1942 WRITE(LUPRI,'(2(/A,I5))') 1943 & ' NO. OF OPERATOR DOUBLES SPECIFIED : ',NLRSOP+9, 1944 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXLRSO 1945 CALL QUIT('TOO MANY OPERATOR DOUBLES IN CCLRSD.') 1946 END IF 1947 IDIP(1) = INDPRP_CC('XDIPLEN ') 1948 IDIP(2) = INDPRP_CC('YDIPLEN ') 1949 IDIP(3) = INDPRP_CC('ZDIPLEN ') 1950 DO IDXA=1,3 1951 DO IDXB=1,3 1952 IDX = NLRSOP + (IDXA-1)*3+IDXB 1953 IALRSOP(IDX) = IDIP(IDXA) 1954 IBLRSOP(IDX) = IDIP(IDXB) 1955 END DO 1956 END DO 1957 NLRSOP = NLRSOP + 9 1958 GO TO 100 1959C 1960C-------------------------------------------------------------- 1961C .ECDLEN: calculate length gauge rotatory strengths. 1962C-------------------------------------------------------------- 1963C 19642 CONTINUE 1965 IF (ROTLEN) GO TO 100 1966 ROTLEN = .TRUE. 1967 IF (NLRSOP+3 .GT. MXLRSO) THEN 1968 WRITE(LUPRI,'(2(/A,I5))') 1969 & ' NO. OF OPERATOR DOUBLES SPECIFIED : ',NLRSOP+3, 1970 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXLRSO 1971 CALL QUIT('TOO MANY OPERATOR DOUBLES IN CCLRSD.') 1972 END IF 1973 IDIP(1) = INDPRP_CC('XDIPLEN ') 1974 IDIP(2) = INDPRP_CC('YDIPLEN ') 1975 IDIP(3) = INDPRP_CC('ZDIPLEN ') 1976 IANG(1) = INDPRP_CC('XANGMOM ') 1977 IANG(2) = INDPRP_CC('YANGMOM ') 1978 IANG(3) = INDPRP_CC('ZANGMOM ') 1979 DO IDXAB=1,3 1980 IDX = NLRSOP + IDXAB 1981 IALRSOP(IDX) = IDIP(IDXAB) 1982 IBLRSOP(IDX) = IANG(IDXAB) 1983 END DO 1984 NLRSOP = NLRSOP + 3 1985 GO TO 100 1986C 1987C------------------------------------- 1988C .DIPLEN: alias for .DIPOLE 1989C------------------------------------- 1990C 19913 CONTINUE 1992 IF (OSCSTR) GO TO 100 1993 GO TO 1 1994c GO TO 100 1995C 1996C-------------------------------------------------------------------------- 1997C Do NOT Use 2n+1 rule expression for transition matrix elements. 1998C-------------------------------------------------------------------------- 1999C 20004 CONTINUE 2001 LRS2N1 = .FALSE. 2002 GO TO 100 2003C 2004C--------------------------- 2005C Input OPERATors. 2006C--------------------------- 2007C 20085 CONTINUE 2009 READ (LUCMD,'(2A)') LABELA, LABELB 2010 DO WHILE (LABELA(1:1).NE.'.' .AND. LABELA(1:1).NE.'*') 2011 IF (LABELA(1:1).NE.'!') THEN 2012 IF (NLRSOP.LT.MXLRSO) THEN 2013 NLRSOP = NLRSOP + 1 2014 IALRSOP(NLRSOP) = INDPRP_CC(LABELA) 2015 IBLRSOP(NLRSOP) = INDPRP_CC(LABELB) 2016 ELSE 2017 WRITE(LUPRI,'(/2A,I5)') 2018 & ' NO. OF OPERATOR DOUBLES SPECIFIED', 2019 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXLRSO 2020 CALL QUIT('TOO MANY OPERATOR DOUBLES IN CCLRSD.') 2021 END IF 2022 END IF 2023 READ (LUCMD,'(2A)') LABELA, LABELB 2024 END DO 2025 BACKSPACE(LUCMD) 2026 GO TO 100 2027C 2028C------------------------- 2029C Select states. 2030C------------------------- 2031C 20326 CONTINUE 2033 SELLRS =.TRUE. 2034 READ (LUCMD,'(A70)') LABHELP 2035 DO WHILE (LABHELP(1:1).NE.'.' .AND. LABHELP(1:1).NE.'*') 2036 IF (LABHELP(1:1).NE.'!') THEN 2037 READ(LABHELP,*) IXSYM,IXST 2038 IF (NSELRS.LT.MXLRSST) THEN 2039 NSELRS = NSELRS + 1 2040 ISELRS(NSELRS,1) = IXSYM 2041 ISELRS(NSELRS,2) = IXST 2042 ELSE 2043 WRITE(LUPRI,'(/2A,I5)') 2044 & ' NO. OF STATES SPECIFIED', 2045 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXLRSST 2046 CALL QUIT('TOO MANY STATES IN CCLRS.') 2047 END IF 2048 END IF 2049 READ (LUCMD,'(A70)') LABHELP 2050 END DO 2051 BACKSPACE(LUCMD) 2052 GO TO 100 2053C 2054C--------------------------------------------------------- 2055C Calculate velocity gauge oscillator strengths. 2056C--------------------------------------------------------- 2057C 20587 CONTINUE 2059 IF (VELSTR) GO TO 100 2060 VELSTR = .TRUE. 2061 IF (NLRSOP+9 .GT. MXLRSO) THEN 2062 WRITE(LUPRI,'(2(/A,I5))') 2063 & ' NO. OF OPERATOR DOUBLES SPECIFIED : ',NLRSOP+9, 2064 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXLRSO 2065 CALL QUIT('TOO MANY OPERATOR DOUBLES IN CCLRSD.') 2066 END IF 2067 IDIP(1) = INDPRP_CC('XDIPVEL ') 2068 IDIP(2) = INDPRP_CC('YDIPVEL ') 2069 IDIP(3) = INDPRP_CC('ZDIPVEL ') 2070 DO IDXA=1,3 2071 DO IDXB=1,3 2072 IDX = NLRSOP + (IDXA-1)*3+IDXB 2073 IALRSOP(IDX) = IDIP(IDXA) 2074 IBLRSOP(IDX) = IDIP(IDXB) 2075 END DO 2076 END DO 2077 NLRSOP = NLRSOP + 9 2078 GO TO 100 2079C 2080C--------------------------------------------------------------- 2081C .DIPMIX: calculate mixed gauge oscillator strengths. 2082C--------------------------------------------------------------- 2083C 20848 CONTINUE 2085 IF (MIXSTR) GO TO 100 2086 MIXSTR = .TRUE. 2087 IF (NLRSOP+9 .GT. MXLRSO) THEN 2088 WRITE(LUPRI,'(2(/A,I5))') 2089 & ' NO. OF OPERATOR DOUBLES SPECIFIED : ',NLRSOP+9, 2090 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXLRSO 2091 CALL QUIT('TOO MANY OPERATOR DOUBLES IN CCLRSD.') 2092 END IF 2093 IDIP(1) = INDPRP_CC('XDIPLEN ') 2094 IDIP(2) = INDPRP_CC('YDIPLEN ') 2095 IDIP(3) = INDPRP_CC('ZDIPLEN ') 2096 IANG(1) = INDPRP_CC('XDIPVEL ') 2097 IANG(2) = INDPRP_CC('YDIPVEL ') 2098 IANG(3) = INDPRP_CC('ZDIPVEL ') 2099 DO IDXA=1,3 2100 DO IDXB=1,3 2101 IDX = NLRSOP + (IDXA-1)*3+IDXB 2102 IALRSOP(IDX) = IDIP(IDXA) 2103 IBLRSOP(IDX) = IANG(IDXB) 2104 END DO 2105 END DO 2106 NLRSOP = NLRSOP + 9 2107 GO TO 100 2108C 2109C---------------------------------------------------------------- 2110C .ECDVEL: calculate velocity gauge rotatory strengths. 2111C---------------------------------------------------------------- 2112C 21139 CONTINUE 2114 IF (ROTVEL) GO TO 100 2115 ROTVEL = .TRUE. 2116 IF (NLRSOP+3 .GT. MXLRSO) THEN 2117 WRITE(LUPRI,'(2(/A,I5))') 2118 & ' NO. OF OPERATOR DOUBLES SPECIFIED : ',NLRSOP+3, 2119 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXLRSO 2120 CALL QUIT('TOO MANY OPERATOR DOUBLES IN CCLRSD.') 2121 END IF 2122 IDIP(1) = INDPRP_CC('XDIPVEL ') 2123 IDIP(2) = INDPRP_CC('YDIPVEL ') 2124 IDIP(3) = INDPRP_CC('ZDIPVEL ') 2125 IANG(1) = INDPRP_CC('XANGMOM ') 2126 IANG(2) = INDPRP_CC('YANGMOM ') 2127 IANG(3) = INDPRP_CC('ZANGMOM ') 2128 DO IDXAB=1,3 2129 IDX = NLRSOP + IDXAB 2130 IALRSOP(IDX) = IDIP(IDXAB) 2131 IBLRSOP(IDX) = IANG(IDXAB) 2132 END DO 2133 NLRSOP = NLRSOP + 3 2134 GO TO 100 2135C 2136C--------------------------------------------------------------------- 2137C .OECDLE: calculate length gauge rotatory strength tensors. 2138C--------------------------------------------------------------------- 2139C 214010 CONTINUE 2141 IF (RTNLEN) GO TO 100 2142 RTNLEN = .TRUE. 2143 ROTLEN = .TRUE. 2144 IF (NLRSOP+27 .GT. MXLRSO) THEN 2145 WRITE(LUPRI,'(2(/A,I5))') 2146 & ' NO. OF OPERATOR DOUBLES SPECIFIED : ',NLRSOP+27, 2147 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXLRSO 2148 CALL QUIT('TOO MANY OPERATOR DOUBLES IN CCLRSD.') 2149 END IF 2150 IDIP(1) = INDPRP_CC('XDIPLEN ') 2151 IDIP(2) = INDPRP_CC('YDIPLEN ') 2152 IDIP(3) = INDPRP_CC('ZDIPLEN ') 2153 IQUA(1) = INDPRP_CC('XXSECMOM') 2154 IQUA(2) = INDPRP_CC('XYSECMOM') 2155 IQUA(3) = INDPRP_CC('XZSECMOM') 2156 IQUA(4) = INDPRP_CC('YYSECMOM') 2157 IQUA(5) = INDPRP_CC('YZSECMOM') 2158 IQUA(6) = INDPRP_CC('ZZSECMOM') 2159 IANG(1) = INDPRP_CC('XANGMOM ') 2160 IANG(2) = INDPRP_CC('YANGMOM ') 2161 IANG(3) = INDPRP_CC('ZANGMOM ') 2162 DO IDXA=1,3 2163 DO IDXB=1,6 2164 IDX = NLRSOP + (IDXA-1)*6+IDXB 2165 IALRSOP(IDX) = IDIP(IDXA) 2166 IBLRSOP(IDX) = IQUA(IDXB) 2167 END DO 2168 END DO 2169 NLRSOP = NLRSOP + 18 2170 DO IDXA=1,3 2171 DO IDXB=1,3 2172 IDX = NLRSOP + (IDXA-1)*3+IDXB 2173 IALRSOP(IDX) = IDIP(IDXA) 2174 IBLRSOP(IDX) = IANG(IDXB) 2175 END DO 2176 END DO 2177 NLRSOP = NLRSOP + 9 2178 GO TO 100 2179C 2180C----------------------------------------------------------------------- 2181C .OECDVE: calculate velocity gauge rotatory strength tensors. 2182C----------------------------------------------------------------------- 2183C 218411 CONTINUE 2185 IF (RTNVEL) GO TO 100 2186 RTNVEL = .TRUE. 2187 ROTVEL = .TRUE. 2188 IF (NLRSOP+27 .GT. MXLRSO) THEN 2189 WRITE(LUPRI,'(2(/A,I5))') 2190 & ' NO. OF OPERATOR DOUBLES SPECIFIED : ',NLRSOP+27, 2191 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXLRSO 2192 CALL QUIT('TOO MANY OPERATOR DOUBLES IN CCLRSD.') 2193 END IF 2194 IDIP(1) = INDPRP_CC('XDIPVEL ') 2195 IDIP(2) = INDPRP_CC('YDIPVEL ') 2196 IDIP(3) = INDPRP_CC('ZDIPVEL ') 2197 IQUA(1) = INDPRP_CC('XXROTSTR') 2198 IQUA(2) = INDPRP_CC('XYROTSTR') 2199 IQUA(3) = INDPRP_CC('XZROTSTR') 2200 IQUA(4) = INDPRP_CC('YYROTSTR') 2201 IQUA(5) = INDPRP_CC('YZROTSTR') 2202 IQUA(6) = INDPRP_CC('ZZROTSTR') 2203 IANG(1) = INDPRP_CC('XANGMOM ') 2204 IANG(2) = INDPRP_CC('YANGMOM ') 2205 IANG(3) = INDPRP_CC('ZANGMOM ') 2206 DO IDXA=1,3 2207 DO IDXB=1,6 2208 IDX = NLRSOP + (IDXA-1)*6+IDXB 2209 IALRSOP(IDX) = IDIP(IDXA) 2210 IBLRSOP(IDX) = IQUA(IDXB) 2211 END DO 2212 END DO 2213 NLRSOP = NLRSOP + 18 2214 DO IDXA=1,3 2215 DO IDXB=1,3 2216 IDX = NLRSOP + (IDXA-1)*3+IDXB 2217 IALRSOP(IDX) = IDIP(IDXA) 2218 IBLRSOP(IDX) = IANG(IDXB) 2219 END DO 2220 END DO 2221 NLRSOP = NLRSOP + 9 2222 GO TO 100 2223C 2224C----------------------------------------------------- 2225C .OLD_LR: use "old" LR residue program. 2226C - "new" code differs only in the number 2227C of evaluations of the transition moments 2228C and, in particular, eta and ksi vectors. 2229C----------------------------------------------------- 2230C 223112 CONTINUE 2232 OLDLRS = .TRUE. 2233 GO TO 100 2234C 2235C-------------------------------------------------------------------- 2236C .BOTHLR: use both the OLDLR and new codes (debug option). 2237C-------------------------------------------------------------------- 2238C 223913 CONTINUE 2240 BOTHLRS = .TRUE. 2241 GO TO 100 2242C 2243C----------------------------------------------------- 2244C .NEW_LR: use "new" LR residue program. 2245C - "new" code differs only in the number 2246C of evaluations of the transition moments 2247C and, in particular, eta and ksi vectors. 2248C----------------------------------------------------- 2249C 225014 CONTINUE 2251 OLDLRS = .FALSE. 2252 GO TO 100 2253C 2254C---------------------------------------------------------------- 2255C .ECD : calculate length and velocity gauge rotatory 2256C strengths. 2257C---------------------------------------------------------------- 2258C 225915 CONTINUE 2260 IF (.NOT.ROTLEN) THEN 2261 ROTLEN = .TRUE. 2262 IF (NLRSOP+3 .GT. MXLRSO) THEN 2263 WRITE(LUPRI,'(2(/A,I5))') 2264 & ' NO. OF OPERATOR DOUBLES SPECIFIED : ',NLRSOP+3, 2265 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXLRSO 2266 CALL QUIT('TOO MANY OPERATOR DOUBLES IN CCLRSD.') 2267 END IF 2268 IDIP(1) = INDPRP_CC('XDIPLEN ') 2269 IDIP(2) = INDPRP_CC('YDIPLEN ') 2270 IDIP(3) = INDPRP_CC('ZDIPLEN ') 2271 IANG(1) = INDPRP_CC('XANGMOM ') 2272 IANG(2) = INDPRP_CC('YANGMOM ') 2273 IANG(3) = INDPRP_CC('ZANGMOM ') 2274 DO IDXAB=1,3 2275 IDX = NLRSOP + IDXAB 2276 IALRSOP(IDX) = IDIP(IDXAB) 2277 IBLRSOP(IDX) = IANG(IDXAB) 2278 END DO 2279 NLRSOP = NLRSOP + 3 2280 END IF 2281 IF (.NOT.ROTVEL) THEN 2282 ROTVEL = .TRUE. 2283 IF (NLRSOP+3 .GT. MXLRSO) THEN 2284 WRITE(LUPRI,'(2(/A,I5))') 2285 & ' NO. OF OPERATOR DOUBLES SPECIFIED : ',NLRSOP+3, 2286 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXLRSO 2287 CALL QUIT('TOO MANY OPERATOR DOUBLES IN CCLRSD.') 2288 END IF 2289 IDIP(1) = INDPRP_CC('XDIPVEL ') 2290 IDIP(2) = INDPRP_CC('YDIPVEL ') 2291 IDIP(3) = INDPRP_CC('ZDIPVEL ') 2292 IANG(1) = INDPRP_CC('XANGMOM ') 2293 IANG(2) = INDPRP_CC('YANGMOM ') 2294 IANG(3) = INDPRP_CC('ZANGMOM ') 2295 DO IDXAB=1,3 2296 IDX = NLRSOP + IDXAB 2297 IALRSOP(IDX) = IDIP(IDXAB) 2298 IBLRSOP(IDX) = IANG(IDXAB) 2299 END DO 2300 NLRSOP = NLRSOP + 3 2301 END IF 2302 GO TO 100 2303C 2304C---------------------------------------------------------------- 2305C .OECD : calculate length and velocity gauge rotatory 2306C strength tensors. 2307C---------------------------------------------------------------- 2308C 230916 CONTINUE 2310 IF (.NOT.RTNLEN) THEN 2311 RTNLEN = .TRUE. 2312 ROTLEN = .TRUE. 2313 IF (NLRSOP+27 .GT. MXLRSO) THEN 2314 WRITE(LUPRI,'(2(/A,I5))') 2315 & ' NO. OF OPERATOR DOUBLES SPECIFIED : ',NLRSOP+27, 2316 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXLRSO 2317 CALL QUIT('TOO MANY OPERATOR DOUBLES IN CCLRSD.') 2318 END IF 2319 IDIP(1) = INDPRP_CC('XDIPLEN ') 2320 IDIP(2) = INDPRP_CC('YDIPLEN ') 2321 IDIP(3) = INDPRP_CC('ZDIPLEN ') 2322 IQUA(1) = INDPRP_CC('XXSECMOM') 2323 IQUA(2) = INDPRP_CC('XYSECMOM') 2324 IQUA(3) = INDPRP_CC('XZSECMOM') 2325 IQUA(4) = INDPRP_CC('YYSECMOM') 2326 IQUA(5) = INDPRP_CC('YZSECMOM') 2327 IQUA(6) = INDPRP_CC('ZZSECMOM') 2328 IANG(1) = INDPRP_CC('XANGMOM ') 2329 IANG(2) = INDPRP_CC('YANGMOM ') 2330 IANG(3) = INDPRP_CC('ZANGMOM ') 2331 DO IDXA=1,3 2332 DO IDXB=1,6 2333 IDX = NLRSOP + (IDXA-1)*6+IDXB 2334 IALRSOP(IDX) = IDIP(IDXA) 2335 IBLRSOP(IDX) = IQUA(IDXB) 2336 END DO 2337 END DO 2338 NLRSOP = NLRSOP + 18 2339 DO IDXA=1,3 2340 DO IDXB=1,3 2341 IDX = NLRSOP + (IDXA-1)*3+IDXB 2342 IALRSOP(IDX) = IDIP(IDXA) 2343 IBLRSOP(IDX) = IANG(IDXB) 2344 END DO 2345 END DO 2346 NLRSOP = NLRSOP + 9 2347 END IF 2348 IF (.NOT.RTNVEL) THEN 2349 RTNVEL = .TRUE. 2350 ROTVEL = .TRUE. 2351 IF (NLRSOP+27 .GT. MXLRSO) THEN 2352 WRITE(LUPRI,'(2(/A,I5))') 2353 & ' NO. OF OPERATOR DOUBLES SPECIFIED : ',NLRSOP+27, 2354 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXLRSO 2355 CALL QUIT('TOO MANY OPERATOR DOUBLES IN CCLRSD.') 2356 END IF 2357 IDIP(1) = INDPRP_CC('XDIPVEL ') 2358 IDIP(2) = INDPRP_CC('YDIPVEL ') 2359 IDIP(3) = INDPRP_CC('ZDIPVEL ') 2360 IQUA(1) = INDPRP_CC('XXROTSTR') 2361 IQUA(2) = INDPRP_CC('XYROTSTR') 2362 IQUA(3) = INDPRP_CC('XZROTSTR') 2363 IQUA(4) = INDPRP_CC('YYROTSTR') 2364 IQUA(5) = INDPRP_CC('YZROTSTR') 2365 IQUA(6) = INDPRP_CC('ZZROTSTR') 2366 IANG(1) = INDPRP_CC('XANGMOM ') 2367 IANG(2) = INDPRP_CC('YANGMOM ') 2368 IANG(3) = INDPRP_CC('ZANGMOM ') 2369 DO IDXA=1,3 2370 DO IDXB=1,6 2371 IDX = NLRSOP + (IDXA-1)*6+IDXB 2372 IALRSOP(IDX) = IDIP(IDXA) 2373 IBLRSOP(IDX) = IQUA(IDXB) 2374 END DO 2375 END DO 2376 NLRSOP = NLRSOP + 18 2377 DO IDXA=1,3 2378 DO IDXB=1,3 2379 IDX = NLRSOP + (IDXA-1)*3+IDXB 2380 IALRSOP(IDX) = IDIP(IDXA) 2381 IBLRSOP(IDX) = IANG(IDXB) 2382 END DO 2383 END DO 2384 NLRSOP = NLRSOP + 9 2385 END IF 2386 GO TO 100 2387C 2388C------------------------------------ 2389C .SUMRULES (stopping power) 2390C------------------------------------ 2391C 239217 CONTINUE 2393 !oscstr = .true. 2394 sumrules = .true. 2395 GO TO 100 2396C 2397C------------------------------------ 2398C .EOMTMO: Compute transition 2399C moments according to EOM recipe 2400C------------------------------------ 2401C 240218 CONTINUE 2403 eomccsd = .true. 2404 skipleq = .true. 2405 GO TO 100 2406C 2407C---------------------------------------------- 2408C .SKIPLE: skip solving for M vectors 2409C (introduced mainly for EOM) 2410C---------------------------------------------- 241119 CONTINUE 2412 skipleq = .true. 2413 GO TO 100 2414C 2415C------------------------------------ 2416C .XXXXXX: unused 2417C------------------------------------ 241820 CONTINUE 2419 GO TO 100 2420 2421 ELSE 2422 WRITE (LUPRI,'(/5A/)') ' Prompt "',WORD, 2423 & '" not recognized in ',SECNAM,'.' 2424 CALL PRTAB(NTABLE,TABLE,SECNAM//' input keywords',LUPRI) 2425 CALL QUIT('Illegal Keyword in '//SECNAM//'.') 2426 END IF 2427 2428 ELSE IF (WORD(1:1) .NE. '*') THEN 2429 WRITE (LUPRI,'(/5A/)') 'PROMPT "',WORD, 2430 & '" NOT RECOGNIZED IN ',SECNAM,'.' 2431 CALL QUIT('Illegal prompt in '//SECNAM//'.') 2432 2433 ELSE IF (WORD(1:1) .EQ.'*') THEN 2434 BACKSPACE (LUCMD) 2435 GO TO 200 2436 END IF 2437 2438 END IF 2439 2440200 CONTINUE 2441*---------------------------------------------------------------------* 2442* check, if input consistent. 2443*---------------------------------------------------------------------* 2444C 2445 IF (SELLRS.AND.(NSELRS.EQ.0)) WRITE(LUPRI,'(/A)') '@ INFO: '// 2446 & '(*CCLRSD input is strange - no states is requested.)' 2447 IF (NLRSOP .EQ.0) WRITE(LUPRI,'(/A)') '@ INFO: '// 2448 & '(*CCLRSD input ignored, because no operators requested.)' 2449C 2450C--------------------------------------------------------------------- 2451C Finally if we are to calculate anything at all, put CCLRSD true. 2452C--------------------------------------------------------------------- 2453C 2454 CCLRSD = (NLRSOP.GT.0) 2455C 2456 RETURN 2457 END 2458c/* deck cc_opainp */ 2459 SUBROUTINE CC_OPAINP(WORD,MSYM) 2460C---------------------------------------------------------------------* 2461C 2462C Purpose: Read input for absorption strenghts 2463C WORD='*CCOPA ' ground to ex. state one-photon transit. 2464C WORD='*CCTPA ' ground to ex. state two-photon transit. 2465C WORD='*CCXOPA' excited to ex. state one-photon transit. 2466C 2467C Christof Haettig, Dec 2002 / Oct 2003 2468C 2469C=====================================================================* 2470 IMPLICIT NONE 2471#include "priunit.h" 2472#include "ccsections.h" 2473#include "ccrspprp.h" 2474#include "ccopainf.h" 2475#include "cctpainf.h" 2476#include "ccxopainf.h" 2477!sonia 2478#include "ccxscvs.h" 2479 2480* local parameters: 2481 CHARACTER SECNAM*(9) 2482 PARAMETER (SECNAM='CC_OPAINP') 2483 2484 INTEGER NTABLE 2485 PARAMETER (NTABLE = 22) 2486 2487* variables: 2488 LOGICAL SETGSTOPA, SETGSTTPA, SETXSTOPA 2489 SAVE SETGSTOPA, SETGSTTPA, SETXSTOPA 2490 2491 CHARACTER WORD*(7) 2492 CHARACTER LABEL*(8), LABHELP*(80), LABELA*(8), LABELB*(8) 2493 CHARACTER TABLE(NTABLE)*(8) 2494 2495 LOGICAL GSTOPA, GSTTPA, XSTOPA 2496 INTEGER IXSYM, IXSTATE, IXSYM2, IXSTATE2, IJUMP 2497 INTEGER INDPRP_CC, MSYM, I, J 2498 2499#if defined (SYS_CRAY) 2500 REAL SMFREQ 2501#else 2502 DOUBLE PRECISION SMFREQ 2503#endif 2504 2505* data: 2506 DATA SETGSTOPA /.FALSE./ 2507 DATA SETGSTTPA /.FALSE./ 2508 DATA SETXSTOPA /.FALSE./ 2509 DATA TABLE / '.SELEXC','.NO2N+1','.OPERAT','.DIPLEN','.DIPVEL', 2510 * '.ANGMOM','.HALFFR','.PRINT ','.USE X2','.USE O2', 2511 * '.SELSTA','.STATES','.TRANSI','.SECMOM','.ROTSTR', 2512 * '.DIPOLE','.XCVSEP','.XRMCOR','.SKIPLE','.EOMXTM', 2513 & '.OPADEN','.TPOLDW'/ 2514 2515*---------------------------------------------------------------------* 2516* begin: 2517*---------------------------------------------------------------------* 2518 LOPADEN = .FALSE. 2519 2520 IF (WORD(1:7) .EQ. '*CCOPA ') THEN 2521 GSTOPA = .TRUE. 2522 GSTTPA = .FALSE. 2523 XSTOPA = .FALSE. 2524 IF (SETGSTOPA) RETURN 2525 SETGSTOPA = .TRUE. 2526 ELSE IF (WORD(1:7) .EQ. '*CCXOPA') THEN 2527 GSTOPA = .FALSE. 2528 GSTTPA = .FALSE. 2529 XSTOPA = .TRUE. 2530 IF (SETXSTOPA) RETURN 2531 SETXSTOPA = .TRUE. 2532 ELSE IF (WORD(1:7) .EQ. '*CCTPA ') THEN 2533 GSTTPA = .TRUE. 2534 GSTOPA = .FALSE. 2535 XSTOPA = .FALSE. 2536 IF (SETGSTTPA) RETURN 2537 SETGSTTPA = .TRUE. 2538 TPOLDW = .FALSE. 2539 ELSE 2540 CALL QUIT('CC_OPAINP called for wrong section:'//WORD(1:7)) 2541 END IF 2542 2543*---------------------------------------------------------------------* 2544* initializations & defaults: 2545*---------------------------------------------------------------------* 2546 IF (GSTOPA) THEN 2547 SELLRS = .FALSE. 2548 LRS2N1 = .TRUE. 2549 NSELRS = 0 2550 NLRSOP = 0 2551 ELSE IF (XSTOPA) THEN 2552 SELQR2 = .FALSE. 2553 QR22N1 = .TRUE. 2554 NSEQR2 = 0 2555 NQR2OP = 0 2556 !sonia 2557 LXSCVS = .false. 2558 LXRMCORE = .false. 2559 LSKIPLINEQ = .false. 2560 LEOMXOPA = .false. 2561 CALL IZERO(NXCORE,8) 2562 CALL IZERO(IXCORE,8*MXCORE) 2563 ELSE IF (GSTTPA) THEN 2564 NSMSEL = 0 2565 NSMOPER = 0 2566 IPRSM = 0 2567 HALFFR = .FALSE. 2568 SELSMST = .FALSE. 2569 LTPA_USE_X2 = .FALSE. 2570 LTPA_USE_O2 = .FALSE. 2571 END IF 2572 2573*---------------------------------------------------------------------* 2574* read input: 2575*---------------------------------------------------------------------* 2576 2577100 CONTINUE 2578 2579! get new input line: 2580 READ (LUCMD,'(A7)') WORD 2581 CALL UPCASE(WORD) 2582 DO WHILE ( WORD(1:1) .EQ. '!' .OR. WORD(1:1) .EQ. '#' ) 2583 READ (LUCMD,'(A7)') WORD 2584 CALL UPCASE(WORD) 2585 END DO 2586 2587 IF (WORD(1:1) .EQ. '.') THEN 2588 2589c table look up: 2590 IJUMP = 1 2591 DO WHILE ( IJUMP .LE. NTABLE .AND. TABLE(IJUMP) .NE. WORD) 2592 IJUMP = IJUMP + 1 2593 END DO 2594 2595c jump to the appropriate input section: 2596 IF (IJUMP .LE. NTABLE) THEN 2597 GOTO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17, 2598 & 18,19,20,21,22), IJUMP 2599 CALL QUIT('Illegal address in computed GOTO in CC_OPAINP.') 2600 2601C --------------------------------------------------------- 2602C .SELEXC, .SELSTA, .STATES, .TRANSI: 2603C select excited states / transitions 2604C --------------------------------------------------------- 26051 CONTINUE 260611 CONTINUE 260712 CONTINUE 260813 CONTINUE 2609 2610 IF (GSTOPA) THEN 2611 ! ground to excited state one-photon transition: 2612 ! READ IXSYM, IXSTATE 2613 ! IXSYM : symmetry class 2614 ! IXSTATE : state number within symmetry class 2615 SELLRS = .TRUE. 2616 READ (LUCMD,'(A80)') LABHELP 2617 DO WHILE (LABHELP(1:1).NE.'.' .AND. LABHELP(1:1).NE.'*') 2618 IF (LABHELP(1:1).NE.'!') THEN 2619 READ(LABHELP,*) IXSYM,IXSTATE 2620 IF (NSELRS.LT.MXLRSST) THEN 2621 NSELRS = NSELRS + 1 2622 ISELRSYM(NSELRS) = IXSYM 2623 ISELRSTA(NSELRS) = IXSTATE 2624 ELSE 2625 NWARN = NWARN + 1 2626 WRITE(LUPRI,'(/2A,I5//A,2I5/)') 2627 & '@ WARNING: NO. OF STATES SPECIFIED', 2628 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXLRSST, 2629 & '@ IGNORE STATE',IXSYM,IXSTATE 2630 END IF 2631 END IF 2632 READ (LUCMD,'(A80)') LABHELP 2633 END DO 2634 ELSE IF (XSTOPA) THEN 2635 ! excited to excited state one-photon transition: 2636 ! READ IXSYM, IXSTATE, IXSYM2, IXSTATE2 2637 ! IXSYM, IXSYM2 : symmetry classes 2638 ! IXSTATE, IXSTATE2 : state numbers within sym. classes 2639 SELQR2 = .TRUE. 2640 READ (LUCMD,'(A80)') LABHELP 2641 DO WHILE (LABHELP(1:1).NE.'.' .AND. LABHELP(1:1).NE.'*') 2642 IF (LABHELP(1:1).NE.'!') THEN 2643 READ(LABHELP,*) IXSYM,IXSTATE,IXSYM2,IXSTATE2 2644 IF (NSEQR2.LT.MXQR2ST) THEN 2645 NSEQR2 = NSEQR2 + 1 2646 ISEQR2SYM(NSEQR2,1) = IXSYM 2647 ISEQR2STA(NSEQR2,1) = IXSTATE 2648 ISEQR2SYM(NSEQR2,2) = IXSYM2 2649 ISEQR2STA(NSEQR2,2) = IXSTATE2 2650 ELSE 2651 NWARN = NWARN + 1 2652 WRITE(LUPRI,'(/2A,I5//A,2I5,I10,I5/)') 2653 & '@ WARNING: NO. OF STATE PAIRS SPECIFIED', 2654 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXQR2ST, 2655 & '@ IGNORE STATE PAIR', 2656 & IXSYM,IXSTATE,IXSYM2,IXSTATE2 2657 END IF 2658 END IF 2659 READ (LUCMD,'(A80)') LABHELP 2660 END DO 2661 ELSE IF (GSTTPA) THEN 2662 ! ground to excited state two-photon transition: 2663 ! READ IXSYM, IXSTATE, SMFREQ 2664 ! IXSYM : symmetry class 2665 ! IXSTATE : state number within symmetry class 2666 ! SMFREQ : photon energies associated with 2. operators 2667 SELSMST =.TRUE. 2668 READ (LUCMD,'(A70)') LABHELP 2669 DO WHILE (LABHELP(1:1).NE.'.' .AND. LABHELP(1:1).NE.'*') 2670 IF (LABHELP(1:1).NE.'!') THEN 2671 READ(LABHELP,*) IXSYM,IXSTATE,SMFREQ 2672 IF (NSMSEL.LT.MXSMSEL) THEN 2673 NSMSEL = NSMSEL + 1 2674 ISMSEL(NSMSEL,1) = IXSYM 2675 ISMSEL(NSMSEL,2) = IXSTATE 2676 BSMFR(NSMSEL) = SMFREQ 2677 ELSE 2678 WRITE(LUPRI,'(/A,I5)') 2679 & ' NO. OF STATES SPECIFIED'// 2680 & ' IS GREATER THAN THE ALLOWED NUMBER : ' ,MXSMSEL 2681 CALL QUIT('TOO MANY STATES SPECIFIED BY .SELSTA') 2682 END IF 2683 END IF 2684 READ (LUCMD,'(A70)') LABHELP 2685 END DO 2686 END IF 2687 2688 BACKSPACE(LUCMD) 2689 GO TO 100 2690 2691C ----------------------------- 2692C .NO2N+1: do NOT use 2n+1 rule 2693C ----------------------------- 26942 CONTINUE 2695 IF (GSTOPA) LRS2N1 = .FALSE. 2696 IF (XSTOPA) QR22N1 = .FALSE. 2697 IF (GSTTPA) CONTINUE 2698 GO TO 100 2699 2700C ------------------------ 2701C .OPERAT: operator labels 2702C ------------------------ 27033 CONTINUE 2704 IF ( GSTOPA .OR. XSTOPA ) THEN 2705 READ (LUCMD,'(A)') LABEL 2706 DO WHILE (LABEL(1:1).NE.'.' .AND. LABEL(1:1).NE.'*') 2707 IF (LABEL(1:1).NE.'!') THEN 2708 2709 IF (GSTOPA) THEN 2710 IF (NLRSOP.LT.MXLRSO) THEN 2711 NLRSOP = NLRSOP + 1 2712 ILRSOP(NLRSOP) = INDPRP_CC(LABEL) 2713 ELSE 2714 WRITE(LUPRI,'(/2A,I5)') 2715 & ' NO. OF OPERATORS SPECIFIED', 2716 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXLRSO 2717 CALL QUIT('TOO MANY OPERATORS IN CC_OPAINP.') 2718 END IF 2719 ELSE IF (XSTOPA) THEN 2720 IF (NQR2OP.LT.MXQR2O) THEN 2721 NQR2OP = NQR2OP + 1 2722 IQR2OP(NQR2OP) = INDPRP_CC(LABEL) 2723 ELSE 2724 WRITE(LUPRI,'(/2A,I5)') 2725 & ' NO. OF OPERATORS SPECIFIED', 2726 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXQR2O 2727 CALL QUIT('TOO MANY OPERATORS IN CC_OPAINP.') 2728 END IF 2729 END IF 2730 2731 END IF 2732 READ (LUCMD,'(A)') LABEL 2733 END DO 2734 ELSE IF (GSTTPA) THEN 2735 READ (LUCMD,'(2A)') LABELA, LABELB 2736 DO WHILE (LABELA(1:1).NE.'.' .AND. LABELA(1:1).NE.'*') 2737 IF (LABELA(1:1).NE.'!') THEN 2738 IF (NSMOPER.LT.MXSMOP) THEN 2739 NSMOPER = NSMOPER + 1 2740 IASMOP(NSMOPER) = INDPRP_CC(LABELA) 2741 IBSMOP(NSMOPER) = INDPRP_CC(LABELB) 2742 ELSE 2743 WRITE(LUPRI,'(/2A,I5)') 2744 & ' NO. OF OPERATOR PAIRS SPECIFIED', 2745 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXSMOP 2746 CALL QUIT('TOO MANY OPERATOR PAIRS IN CC_OPAINP.') 2747 END IF 2748 END IF 2749 READ (LUCMD,'(2A)') LABELA, LABELB 2750 END DO 2751 ELSE 2752 CALL QUIT('Error in CC_OPAINP.') 2753 END IF 2754 BACKSPACE(LUCMD) 2755 GO TO 100 2756 2757C ----------------------------------------------------- 2758C .DIPLEN: calculate complete dipole transition vectors 2759C in length gauge 2760C ----------------------------------------------------- 27614 CONTINUE 2762 IF (GSTOPA) THEN 2763 CALL CC_PUT1OP(ILRSOP,NLRSOP,MXLRSO,'DIPLEN','CC_OPAINP') 2764 ELSE IF (XSTOPA) THEN 2765 CALL CC_PUT1OP(IQR2OP,NQR2OP,MXQR2O,'DIPLEN','CC_OPAINP') 2766 ELSE IF (GSTTPA) THEN 2767 CALL CC_PUT2OP(IASMOP,IBSMOP,NSMOPER,MXSMOP, 2768 & 'DIPLEN','CC_OPAINP') 2769 END IF 2770 GO TO 100 2771 2772C ----------------------------------------------------- 2773C .DIPVEL: calculate complete dipole transition vectors 2774C in velocity gauge 2775C ----------------------------------------------------- 27765 CONTINUE 2777 IF (GSTOPA) THEN 2778 CALL CC_PUT1OP(ILRSOP,NLRSOP,MXLRSO,'DIPVEL','CC_OPAINP') 2779 ELSE IF (XSTOPA) THEN 2780 CALL CC_PUT1OP(IQR2OP,NQR2OP,MXQR2O,'DIPVEL','CC_OPAINP') 2781 ELSE IF (GSTTPA) THEN 2782 CALL CC_PUT2OP(IASMOP,IBSMOP,NSMOPER,MXSMOP, 2783 & 'DIPVEL','CC_OPAINP') 2784 END IF 2785 GO TO 100 2786 2787C ------------------------------------------------------ 2788C .ANGMOM: calculate complete magnetic dipole transition 2789C vectors and if possible rotatory strenghts 2790C ------------------------------------------------------ 27916 CONTINUE 2792 IF (GSTOPA) THEN 2793 CALL CC_PUT1OP(ILRSOP,NLRSOP,MXLRSO,'ANGMOM','CC_OPAINP') 2794 ELSE IF (XSTOPA) THEN 2795 CALL CC_PUT1OP(IQR2OP,NQR2OP,MXQR2O,'ANGMOM','CC_OPAINP') 2796 ELSE IF (GSTTPA) THEN 2797 CALL CC_PUT2OP(IASMOP,IBSMOP,NSMOPER,MXSMOP, 2798 & 'ANGMOM','CC_OPAINP') 2799 END IF 2800 GO TO 100 2801 2802C ------------------------------------------------ 2803C .HALFFR : impose condition of equal frequencies 2804C for the two lasers 2805C ------------------------------------------------ 28067 CONTINUE 2807 IF (GSTTPA) THEN 2808 HALFFR =.TRUE. 2809 ELSE 2810 WRITE(LUPRI,*) 'No .HALFFR keyword in section ',WORD 2811 WRITE(LUPRI,*) 'input will be ignored...' 2812 END IF 2813 GO TO 100 2814 2815C ------------ 2816C .PRINT 2817C ------------ 28188 CONTINUE 2819 IF (GSTTPA) THEN 2820 READ (LUCMD,*) IPRSM 2821 ELSE 2822 WRITE(LUPRI,*) 'No .PRINT keyword in section ',WORD 2823 WRITE(LUPRI,*) 'input will be ignored...' 2824 END IF 2825 GO TO 100 2826 2827C ------------ 2828C .USE X2 2829C ------------ 28309 CONTINUE 2831 IF (GSTTPA) THEN 2832 LTPA_USE_X2 = .TRUE. 2833 ELSE 2834 WRITE(LUPRI,*) 'No .USE X2 keyword in section ',WORD 2835 WRITE(LUPRI,*) 'input will be ignored...' 2836 END IF 2837 GO TO 100 2838 2839C ------------ 2840C .USE O2 2841C ------------ 284210 CONTINUE 2843 IF (GSTTPA) THEN 2844 LTPA_USE_O2 = .TRUE. 2845 ELSE 2846 WRITE(LUPRI,*) 'No .USE O2 keyword in section ',WORD 2847 WRITE(LUPRI,*) 'input will be ignored...' 2848 END IF 2849 GO TO 100 2850 2851C ------------------------------------------------------------ 2852C .SECMOM: calculate complete length gauge electric quadrupole 2853C transition vectors and if possible rotatory 2854C strength tensors. 2855C ------------------------------------------------------------ 285614 CONTINUE 2857 IF (GSTOPA) THEN 2858 CALL CC_PUT1OP(ILRSOP,NLRSOP,MXLRSO,'SECMOM','CC_OPAINP') 2859 ELSE IF (XSTOPA) THEN 2860 CALL CC_PUT1OP(IQR2OP,NQR2OP,MXQR2O,'SECMOM','CC_OPAINP') 2861 ELSE IF (GSTTPA) THEN 2862 WRITE(LUPRI,*) 'No .SECMOM keyword in section ',WORD 2863 WRITE(LUPRI,*) 'input will be ignored...' 2864 END IF 2865 GO TO 100 2866 2867 2868C ------------------------------------------------------ 2869C .ROTSTR: calculate complete velocity gauge electric 2870C quadrupole transition vectors and if possible 2871C rotatory strength tensors. 2872C ------------------------------------------------------ 287315 CONTINUE 2874 IF (GSTOPA) THEN 2875 CALL CC_PUT1OP(ILRSOP,NLRSOP,MXLRSO,'ROTSTR','CC_OPAINP') 2876 ELSE IF (XSTOPA) THEN 2877 CALL CC_PUT1OP(IQR2OP,NQR2OP,MXQR2O,'ROTSTR','CC_OPAINP') 2878 ELSE IF (GSTTPA) THEN 2879 WRITE(LUPRI,*) 'No .ROTSTR keyword in section ',WORD 2880 WRITE(LUPRI,*) 'input will be ignored...' 2881 END IF 2882 GO TO 100 2883C ------------------------------------------------------ 2884C .DIPOLE is the synonym of .DIPLEN. 2885C ------------------------------------------------------ 288616 CONTINUE 2887 GO TO 4 2888C ------------------------------------------------------ 2889C .XSCVSEP 2890C ------------------------------------------------------ 289117 CONTINUE 2892 LXSCVS = .true. 2893 WRITE(LUPRI,*)'CCSD_INPUT: core-val requested' 2894 !how many per symmetry 2895 READ(LUCMD,*) (NXCORE(I),I=1,MSYM) 2896 !which ones 2897 DO I = 1, MSYM 2898 READ(LUCMD,*) (IXCORE(J,I),J=1,NXCORE(I)) 2899 END DO 2900 WRITE(LUPRI,*)'XOPA: # active core orbs per sym' 2901 write(lupri,*) (NXCORE(I),I=1,MSYM) 2902 WRITE(LUPRI,*)'Indices of requested core orbs' 2903 DO I = 1, MSYM 2904 write(LUpri,*) (IXCORE(J,I),J=1,NXCORE(I)) 2905 END DO 2906 2907 GO TO 100 2908C ------------------------------------------------------ 2909C .XRMCORE 2910C ------------------------------------------------------ 291118 CONTINUE 2912 LXRMCORE = .true. 2913 WRITE(LUPRI,*)'CCSD_INPUT: core-val requested' 2914 !how many per symmetry 2915 READ(LUCMD,*) (NXCORE(I),I=1,MSYM) 2916 !which ones 2917 DO I = 1, MSYM 2918 READ(LUCMD,*) (IXCORE(J,I),J=1,NXCORE(I)) 2919 END DO 2920 WRITE(LUPRI,*)'XOPA: # frozen core orbs per sym' 2921 write(lupri,*) (NXCORE(I),I=1,MSYM) 2922 WRITE(LUPRI,*)'Indices of requested core orbs' 2923 DO I = 1, MSYM 2924 write(LUpri,*) (IXCORE(J,I),J=1,NXCORE(I)) 2925 END DO 2926 2927 GO TO 100 2928C 2929C ------------------------------------------------------ 2930C .SKIPLEquation: skip calculation of the term involving 2931C linear equations 2932C ------------------------------------------------------ 293319 CONTINUE 2934 LSKIPLINEQ = .true. 2935 WRITE(LUPRI,*)'CCSD_INPUT: skip Nij*xksi or TX*B' 2936 GO TO 100 2937C 2938C ------------------------------------------------------ 2939C .EOMXTMO: XOPA in EOM framework 2940C linear equations 2941C ------------------------------------------------------ 294220 CONTINUE 2943 LSKIPLINEQ = .true. 2944 LEOMXOPA = .true. 2945 QR22N1 = .false. 2946 2947 WRITE(LUPRI,*)'CCSD_INPUT: skip Nij*xksi or TX*B' 2948 WRITE(LUPRI,*)'CCSD_INPUT: Add EOM extra term ' 2949 GO TO 100 2950C 2951C ------------------------------------------------------ 2952C .OPADEN: use density based implementation of transition 2953C moments 2954C ------------------------------------------------------ 295521 CONTINUE 2956 LOPADEN = .true. 2957 2958 WRITE(LUPRI,*)'CCSD_INPUT: You requested the density 2959 & implementation of TMoms' 2960 GO TO 100 2961C ------------------------------------------------------ 2962C .TPOLDW 2963C ------------------------------------------------------ 296422 CONTINUE 2965 TPOLDW = .TRUE. 2966 GO TO 100 2967C 2968 ELSE 2969 WRITE (LUPRI,'(/5A/)') ' Prompt "',WORD, 2970 & '" not recognized in ',SECNAM,'.' 2971 CALL PRTAB(NTABLE,TABLE,SECNAM//' input keywords',LUPRI) 2972 CALL QUIT('Illegal Keyword in '//SECNAM//'.') 2973 END IF 2974 2975 ELSE IF (WORD(1:1) .NE. '*') THEN 2976 WRITE (LUPRI,'(/5A/)') 'PROMPT "',WORD, 2977 & '" NOT RECOGNIZED IN ',SECNAM,'.' 2978 CALL QUIT('Illegal prompt in '//SECNAM//'.') 2979 2980 ELSE IF (WORD(1:1) .EQ.'*') THEN 2981 BACKSPACE (LUCMD) 2982 GO TO 200 2983 END IF 2984 2985 2986200 CONTINUE 2987*---------------------------------------------------------------------* 2988* warning if for GSTTPA both .SELST AND .SELHLF are specified 2989*---------------------------------------------------------------------* 2990 IF (GSTTPA .AND. SELSMST .AND. HALFFR) THEN 2991 WRITE (LUPRI,*) 2992 & ' WARNING: BOTH .SELST and .HALFFR are specified' 2993 WRITE (LUPRI,*) ' .HALFFR is used to obtain frequences' 2994 END IF 2995 2996*----------------------------------------------------------------------* 2997* check, if any operator labels specified: 2998* if not, use default: dipole length and velocity, angular momentum, and 2999* electric dipole length and velocity. 3000*----------------------------------------------------------------------* 3001 IF (GSTOPA .AND. NLRSOP.EQ.0) THEN 3002 3003 IF (NLRSOP+3 .LE. MXLRSO) 3004 & CALL CC_PUT1OP(ILRSOP,NLRSOP,MXLRSO,'DIPLEN','CC_OPAINP') 3005 IF (NLRSOP+3 .LE. MXLRSO) 3006 & CALL CC_PUT1OP(ILRSOP,NLRSOP,MXLRSO,'DIPVEL','CC_OPAINP') 3007 IF (NLRSOP+3 .LE. MXLRSO) 3008 & CALL CC_PUT1OP(ILRSOP,NLRSOP,MXLRSO,'ANGMOM','CC_OPAINP') 3009 IF (NLRSOP+6 .LE. MXLRSO) 3010 & CALL CC_PUT1OP(ILRSOP,NLRSOP,MXLRSO,'SECMOM','CC_OPAINP') 3011 IF (NLRSOP+6 .LE. MXLRSO) 3012 & CALL CC_PUT1OP(ILRSOP,NLRSOP,MXLRSO,'ROTSTR','CC_OPAINP') 3013 3014 ELSE IF (XSTOPA .AND. NQR2OP.EQ.0) THEN 3015 3016 IF (NQR2OP+3 .LE. MXQR2O) 3017 & CALL CC_PUT1OP(IQR2OP,NQR2OP,MXQR2O,'DIPLEN','CC_OPAINP') 3018 IF (NQR2OP+3 .LE. MXQR2O) 3019 & CALL CC_PUT1OP(IQR2OP,NQR2OP,MXQR2O,'DIPVEL','CC_OPAINP') 3020 IF (NQR2OP+3 .LE. MXQR2O) 3021 & CALL CC_PUT1OP(IQR2OP,NQR2OP,MXQR2O,'ANGMOM','CC_OPAINP') 3022 IF (NQR2OP+6 .LE. MXQR2O) 3023 & CALL CC_PUT1OP(IQR2OP,NQR2OP,MXQR2O,'SECMOM','CC_OPAINP') 3024 IF (NQR2OP+6 .LE. MXQR2O) 3025 & CALL CC_PUT1OP(IQR2OP,NQR2OP,MXQR2O,'ROTSTR','CC_OPAINP') 3026 3027 3028 ELSE IF (GSTTPA .AND. NSMOPER.EQ.0) THEN 3029 3030 IF (NSMOPER+9 .LE. MXSMOP) 3031 & CALL CC_PUT2OP(IASMOP,IBSMOP,NSMOPER,MXSMOP, 3032 & 'DIPLEN','CC_OPAINP') 3033 3034 END IF 3035 3036*---------------------------------------------------------------------* 3037* set CCOPA flag and return: 3038*---------------------------------------------------------------------* 3039 IF (GSTOPA) CCOPA = .TRUE. 3040 IF (GSTTPA) CCTPA = .TRUE. 3041 IF (XSTOPA) CCXOPA = .TRUE. 3042 3043 RETURN 3044 END 3045C=====================================================================* 3046C END OF SUBROUTINE CC_OPAINP 3047C=====================================================================* 3048 SUBROUTINE CC_NODINP(WORD,INIT_ONLY) 3049C---------------------------------------------------------------------* 3050C 3051C Purpose: read flags for different CC3 noddy code options 3052C 3053C Christof Haettig, Jan 2003 3054C 3055C=====================================================================* 3056 IMPLICIT NONE 3057#include "priunit.h" 3058#include "ccnoddy.h" 3059 3060* local parameters: 3061 CHARACTER SECNAM*(9) 3062 PARAMETER (SECNAM='CC_NODINP') 3063 3064 INTEGER NTABLE 3065 PARAMETER (NTABLE = 20) 3066 3067* variables: 3068 LOGICAL SET 3069 SAVE SET 3070 3071 LOGICAL INIT_ONLY 3072 CHARACTER WORD*(7) 3073 CHARACTER LABEL*(8), LABHELP*(80) 3074 CHARACTER TABLE(NTABLE)*(8) 3075 INTEGER IJUMP 3076 3077* data: 3078 DATA SET /.FALSE./ 3079 DATA TABLE /'.XI ','.XIDEN ','.ETA ','.ETADEN','.FMAT ', 3080 * '.FNOALT','.OVLP ','.OMEGA ','.LHTR ','.RHTR ', 3081 * '.FOPDEN','.FINDIF','.FAMAT ','.GMAT ','.BMAT ', 3082 * '.AAMAT ','.HMAT ','.FADEN ','.XXXXXX','.XXXXXX'/ 3083 3084*---------------------------------------------------------------------* 3085* set defaults: 3086*---------------------------------------------------------------------* 3087 NODDY_INIT = .FALSE. 3088 3089 NODDY_OMEGA = .FALSE. 3090 NODDY_RHTR = .FALSE. 3091 NODDY_LHTR = .FALSE. 3092 NODDY_DEN = .FALSE. 3093 NODDY_BMAT = .FALSE. 3094 NODDY_FMAT = .FALSE. 3095 NODDY_GMAT = .FALSE. 3096 NODDY_HMAT = .FALSE. 3097 3098 NODDY_XI = .FALSE. 3099 NODDY_ETA = .FALSE. 3100 NODDY_AAMAT = .FALSE. 3101 NODDY_FAMAT = .FALSE. 3102 3103 NODDY_XI_ALTER = .FALSE. 3104 NODDY_ETA_ALTER = .FALSE. 3105 NODDY_FA_ALTER = .FALSE. 3106 3107 CCSDT_F_ALTER = .TRUE. 3108 3109 NODDY_OVLP = .FALSE. 3110 3111 IF (INIT_ONLY) RETURN 3112 3113*---------------------------------------------------------------------* 3114* begin: 3115*---------------------------------------------------------------------* 3116 IF (WORD(1:7) .NE. '*NODDY') CALL 3117 & QUIT('CC_NODINP was call for wrong input section:'//WORD(1:7)) 3118 3119 IF (SET) RETURN 3120 SET = .TRUE. 3121 3122 NODDY_INIT = .TRUE. ! triggers precalculation of integrals etc. 3123 3124*---------------------------------------------------------------------* 3125* read input: 3126*---------------------------------------------------------------------* 3127100 CONTINUE 3128! get new input line: 3129 READ (LUCMD,'(A7)') WORD 3130 CALL UPCASE(WORD) 3131 DO WHILE ( WORD(1:1) .EQ. '!' .OR. WORD(1:1) .EQ. '#' ) 3132 READ (LUCMD,'(A7)') WORD 3133 CALL UPCASE(WORD) 3134 END DO 3135 IF (WORD(1:1) .EQ. '.') THEN 3136 3137c table look up: 3138 IJUMP = 1 3139 DO WHILE ( IJUMP .LE. NTABLE .AND. TABLE(IJUMP) .NE. WORD) 3140 IJUMP = IJUMP + 1 3141 END DO 3142 3143c jump to the appropriate input section: 3144 IF (IJUMP .LE. NTABLE) THEN 3145 GOTO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20), 3146 & IJUMP 3147 CALL QUIT('Illegal address in computed GOTO in CC_NODINP.') 3148 3149C --------------------------------------- 3150C .XI : use noddy code for Xksi vector 3151C --------------------------------------- 31521 CONTINUE 3153 NODDY_XI = .TRUE. 3154 GO TO 100 3155 3156C ------------------------------------ 3157C .XIDEN : use noddy Xksi density code 3158C ------------------------------------ 31592 CONTINUE 3160 NODDY_XI_ALTER = .TRUE. 3161 GO TO 100 3162 3163C --------------------------------------- 3164C .ETA : use noddy code for Xksi vector 3165C --------------------------------------- 31663 CONTINUE 3167 NODDY_ETA = .TRUE. 3168 GO TO 100 3169 3170C --------------------------------------- 3171C .ETADEN: use noddy for Eta density code 3172C --------------------------------------- 31734 CONTINUE 3174 NODDY_ETA_ALTER = .TRUE. 3175 GO TO 100 3176 3177C ------------------------------------------------------ 3178C .FMAT : use noddy version for F matrix transformation 3179C ------------------------------------------------------ 31805 CONTINUE 3181 NODDY_FMAT = .TRUE. 3182 GO TO 100 3183 3184C ------------------------------------------------------ 3185C .FNOALT: don't use alternative noddy code for F matrix 3186C which does triples as B matrix contraction 3187C ------------------------------------------------------ 31886 CONTINUE 3189 NODDY_FMAT = .TRUE. 3190 CCSDT_F_ALTER = .FALSE. 3191 GO TO 100 3192 3193C ------------------------------------------------------- 3194C .OVLP : use noddy code for (LE|RE) and (RE|RE) overlap 3195C ------------------------------------------------------- 31967 CONTINUE 3197 NODDY_OVLP = .TRUE. 3198 GO TO 100 3199 3200C ------------------------------------------- 3201C .OMEGA : use noddy code for vector function 3202C ------------------------------------------- 32038 CONTINUE 3204 NODDY_OMEGA = .TRUE. 3205 GO TO 100 3206 3207C -------------------------------------------------------- 3208C .LHTR : use noddy code for jacobian left transformation 3209C -------------------------------------------------------- 32109 CONTINUE 3211 NODDY_LHTR = .TRUE. 3212 GO TO 100 3213 3214C --------------------------------------------------------- 3215C .RHTR : use noddy code for jacobian right transformation 3216C --------------------------------------------------------- 321710 CONTINUE 3218 NODDY_RHTR = .TRUE. 3219 GO TO 100 3220C 3221C ------------------------------------------------ 3222C .FOPDEN: use noddy code for ground state density 3223C ------------------------------------------------ 322411 CONTINUE 3225 NODDY_DEN = .TRUE. 3226 GO TO 100 3227C 3228C -------------------------------------------------------- 3229C .FINDIF: set flags appropriate for CC3 finite difference 3230C calculations 3231C -------------------------------------------------------- 323212 CONTINUE 3233 NODDY_OMEGA = .TRUE. 3234 NODDY_RHTR = .TRUE. 3235 NODDY_LHTR = .TRUE. 3236 NODDY_DEN = .TRUE. 3237 NODDY_OVLP = .TRUE. 3238 NODDY_ETA = .TRUE. 3239 NODDY_XI = .TRUE. 3240 NODDY_FMAT = .TRUE. 3241 NODDY_FAMAT = .TRUE. 3242 NODDY_GMAT = .TRUE. 3243 NODDY_HMAT = .TRUE. 3244 NODDY_BMAT = .TRUE. 3245 NODDY_AAMAT = .TRUE. 3246 3247 NODDY_XI_ALTER = .FALSE. 3248 NODDY_ETA_ALTER = .FALSE. 3249 NODDY_FA_ALTER = .FALSE. 3250 GO TO 100 3251C 3252C ------------------------------------------------ 3253C .FAMAT: use noddy code for F{A} matrix 3254C ------------------------------------------------ 325513 CONTINUE 3256 NODDY_FAMAT = .TRUE. 3257 GO TO 100 3258C 3259C ------------------------------------------------ 3260C .GMAT : use noddy code for G matrix 3261C ------------------------------------------------ 326214 CONTINUE 3263 NODDY_GMAT = .TRUE. 3264 GO TO 100 3265C 3266C ------------------------------------------------ 3267C .BMAT : use noddy code for B matrix 3268C ------------------------------------------------ 326915 CONTINUE 3270 NODDY_BMAT = .TRUE. 3271 GO TO 100 3272C 3273C ------------------------------------------------ 3274C .AAMAT : use noddy code for A{A} matrix 3275C ------------------------------------------------ 327616 CONTINUE 3277 NODDY_AAMAT = .TRUE. 3278 GO TO 100 3279C 3280C ------------------------------------------------ 3281C .HMAT : use noddy code for H matrix 3282C ------------------------------------------------ 328317 CONTINUE 3284 NODDY_HMAT = .TRUE. 3285 GO TO 100 3286C 3287C ------------------------------------------------ 3288C .FADEN : use noddy code for F{A} densities 3289C ------------------------------------------------ 329018 CONTINUE 3291 NODDY_FA_ALTER = .TRUE. 3292 GO TO 100 3293C 3294C ------------------------------------------------ 3295C .XXXXXX: unused 3296C ------------------------------------------------ 329719 CONTINUE 3298 GO TO 100 3299C 3300C ------------------------------------------------ 3301C .XXXXXX: unused 3302C ------------------------------------------------ 330320 CONTINUE 3304 GO TO 100 3305C 3306 ELSE 3307 WRITE (LUPRI,'(/5A/)') ' Prompt "',WORD, 3308 & '" not recognized in ',SECNAM,'.' 3309 CALL PRTAB(NTABLE,TABLE,SECNAM//' input keywords',LUPRI) 3310 CALL QUIT('Illegal Keyword in '//SECNAM//'.') 3311 END IF 3312 3313 ELSE IF (WORD(1:1) .NE. '*') THEN 3314 WRITE (LUPRI,'(/5A/)') 'PROMPT "',WORD, 3315 & '" NOT RECOGNIZED IN ',SECNAM,'.' 3316 CALL QUIT('Illegal prompt in '//SECNAM//'.') 3317 3318 ELSE IF (WORD(1:1) .EQ.'*') THEN 3319 BACKSPACE (LUCMD) 3320 GO TO 200 3321 END IF 3322 3323200 CONTINUE 3324*---------------------------------------------------------------------* 3325* Check flags for consistency and print some output: 3326*---------------------------------------------------------------------* 3327 IF (NODDY_XI_ALTER) NODDY_XI = .TRUE. 3328 IF (NODDY_ETA_ALTER) NODDY_ETA = .TRUE. 3329 IF (NODDY_FA_ALTER) NODDY_FAMAT = .TRUE. 3330 3331 WRITE(LUPRI,*) 'The Triples section in the response will use '// 3332 & 'the following modules:' 3333 3334 WRITE(LUPRI,'(/a)') ' in CCRHSN:' 3335 IF (NODDY_OMEGA) THEN 3336 WRITE(LUPRI,*) 'vector function calculation: CCSD_TRIPLE' 3337 ELSE 3338 WRITE(LUPRI,*) 'vector function calculation: CC3_OMEG' 3339 END IF 3340 3341 WRITE(LUPRI,'(/a)') ' in CC_RHTR:' 3342 IF (NODDY_RHTR) THEN 3343 WRITE(LUPRI,*) ' A right transformation : CC_RHTR_NODDY' 3344 ELSE 3345 WRITE(LUPRI,*) ' A right transformation : CC3_OMEG' 3346 END IF 3347 3348 WRITE(LUPRI,'(/a)') ' in CC_LHTR:' 3349 IF (NODDY_LHTR) THEN 3350 WRITE(LUPRI,*) ' A left transformation : CC_LHTR_NODDY' 3351 ELSE 3352 WRITE(LUPRI,*) ' A left transformation : CC3_T3/L3_LHTR' 3353 END IF 3354 3355 WRITE(LUPRI,'(/a)') ' in CC_FOP:' 3356 IF (NODDY_DEN) THEN 3357 WRITE(LUPRI,*) ' for one-electron density: CCSDT_XI_CONT_NODDY' 3358 ELSE 3359 WRITE(LUPRI,*) ' for one-electron density: CCSDPT_DENS2' 3360 END IF 3361 3362 WRITE(LUPRI,'(/a)') ' in CCEXNORM:' 3363 IF (NODDY_OVLP) THEN 3364 WRITE(LUPRI,*) ' for (LE|RE) overlapp : CCOVLPT_NODDY ' 3365 ELSE 3366 WRITE(LUPRI,*) ' for (LE|RE) overlapp : CC3_LR_OVLP' 3367 END IF 3368 3369 3370 WRITE(LUPRI,'(/a)') ' in CC_XIETA:' 3371 3372 IF (NODDY_XI) THEN 3373 WRITE(LUPRI,*) ' xi vector calculation: CCSDT_XI_NODDY' 3374 IF (NODDY_XI_ALTER) THEN 3375 WRITE(LUPRI,*) ' xi contraction: CCSDT_XI_DEN_NODDY' 3376 ELSE 3377 WRITE(LUPRI,*) ' xi contraction: CCSDT_XI_NODDY' 3378 END IF 3379 ELSE 3380 WRITE(LUPRI,*) ' xi vector calculation: CC3_XI' 3381 WRITE(LUPRI,*) ' xi contraction: CC3_XI_DEN' 3382 END IF 3383 3384 IF (NODDY_ETA) THEN 3385 WRITE(LUPRI,*)' eta vector calculation: CCSDT_ETA_NODDY' 3386 WRITE(LUPRI,*)' L A{O} transformation : CCSDT_ETA_NODDY' 3387 IF (NODDY_ETA_ALTER) THEN 3388 WRITE(LUPRI,*)' eta contraction: CCSDT_ETA_DEN' 3389 WRITE(LUPRI,*)' L A{O} contraction: CCSDT_A_DEN_NODDY' 3390 ELSE 3391 WRITE(LUPRI,*)' eta contraction: CCSDT_ETA_NODDY' 3392 WRITE(LUPRI,*)' L A{O} contraction: CCSDT_ETA_NODDY' 3393 END IF 3394 ELSE 3395 WRITE(LUPRI,*) ' eta vector calculation: CC3_ETASD' 3396 WRITE(LUPRI,*) ' L A{O} transformation : CC3_ETASD' 3397 WRITE(LUPRI,*) ' eta contraction: CCSDT_ETA_DEN' 3398 WRITE(LUPRI,*) ' L A{O} contraction: CCSDT_ETA_DEN' 3399 END IF 3400 3401 WRITE(LUPRI,'(/a)') ' in CC_FMAT:' 3402 IF (NODDY_FMAT) THEN 3403 WRITE(LUPRI,*) ' F matrix transformation: CCSDT_FMAT_NODDY' 3404 WRITE(LUPRI,*) ' F matrix contraction : CCSDT_FMAT_NODDY'// 3405 & ' and CCSDT_FBC_NODDY' 3406 ELSE 3407 WRITE(LUPRI,*) ' F matrix transformation: CC3_FMAT'// 3408 & ' and CC3_FT3B and CC3_FMATSD' 3409 WRITE(LUPRI,*) ' F matrix contraction : CC3_FMAT'// 3410 & ' and CCSDT_FBMAT' 3411 END IF 3412 3413 WRITE(LUPRI,'(/a)') ' in CCQR_FADRV/CC_FAMAT:' 3414 IF (NODDY_FAMAT) THEN 3415 WRITE(LUPRI,*) ' F{A} matrix transform. : CCSDT_FAMAT_NODDY' 3416 IF (NODDY_FA_ALTER) THEN 3417 WRITE(LUPRI,*) ' F{A} matrix contraction : CCSDT_FA_DEN/noddy' 3418 ELSE 3419 WRITE(LUPRI,*) ' F{A} matrix contraction : CCSDT_FAMAT_NODDY' 3420 END IF 3421 ELSE 3422 WRITE(LUPRI,*) ' F{A} matrix transform. : CCSDT_FAMAT_NODDY' 3423 WRITE(LUPRI,*) ' F{A} matrix contraction : CCSDT_FA_DEN' 3424 END IF 3425 3426 IF (NODDY_GMAT) THEN 3427 WRITE(LUPRI,*)' G matrix calculation: CCSDT_GMAT_NODDY' 3428 ELSE 3429 WRITE(LUPRI,*)' G matrix calculation: CC3_GMAT' 3430 END IF 3431 3432 IF (NODDY_BMAT) THEN 3433 WRITE(LUPRI,*)' B matrix calculation: CCSDT_BMAT_NODDY' 3434 ELSE 3435 WRITE(LUPRI,*)' B matrix calculation: CC3_BMAT' 3436 END IF 3437 3438 IF (NODDY_AAMAT) THEN 3439 WRITE(LUPRI,*)' A{A} matrix calculation: CCSDT_AAMAT_NODDY' 3440 ELSE 3441 WRITE(LUPRI,*)' A{A} matrix calculation: CC3_AAMAT' 3442 END IF 3443 3444 IF (NODDY_HMAT) THEN 3445 WRITE(LUPRI,*)' H matrix calculation: CCSDT_HMAT_NODDY' 3446 ELSE 3447 WRITE(LUPRI,*)' H matrix calculation: CC3_HMAT' 3448 END IF 3449 3450 RETURN 3451 END 3452C=====================================================================* 3453C END OF SUBROUTINE CC_NODINP 3454C=====================================================================* 3455c/* deck cc_qr2rinp */ 3456C=====================================================================* 3457 SUBROUTINE CC_QR2RINP(WORD) 3458C---------------------------------------------------------------------* 3459C 3460C Purpose: Read input for CC excitec state calculations. 3461C 3462C if (WORD .eq '*CCQR2R ') read & process input and set defaults, 3463C else set only defaults 3464C 3465C Ove Christiansen April 1997 3466C 3467C=====================================================================* 3468#include "implicit.h" 3469#include "priunit.h" 3470#include "ccsdinp.h" 3471#include "ccsections.h" 3472#include "ccsdsym.h" 3473#include "cclr.h" 3474#include "cclres.h" 3475#include "leinf.h" 3476#include "cclrinf.h" 3477#include "ccrspprp.h" 3478#include "ccexci.h" 3479#include "ccqr2r.h" 3480 3481* local parameters: 3482 CHARACTER SECNAM*(10) 3483 PARAMETER (SECNAM='CC_QR2RINP') 3484 3485 INTEGER NTABLE 3486 PARAMETER (NTABLE = 5) 3487 3488* variables: 3489 LOGICAL SET 3490 SAVE SET 3491 3492 CHARACTER WORD*(7) 3493 CHARACTER LABELA*(8),LABELB*(8),LABHELP*70 3494 CHARACTER TABLE(NTABLE)*(8) 3495 3496 INTEGER IJUMP,IDIP(3) 3497* data: 3498 DATA SET /.FALSE./ 3499 DATA TABLE /'.DIPOLE','.NO2N+1','.OPERAT','.SELEXC','.DIPVEL'/ 3500 3501*--------------------------------------------------------------------* 3502* begin: 3503*---------------------------------------------------------------------* 3504 IF (SET) RETURN 3505 SET = .TRUE. 3506 3507*---------------------------------------------------------------------* 3508* initializations & defaults: 3509*---------------------------------------------------------------------* 3510C 3511 QR22N1 = .TRUE. 3512 SELQR2 = .FALSE. 3513 XOSCST = .FALSE. 3514 XVELST = .FALSE. 3515C 3516 NSEQR2 = 0 3517 NQR2OP = 0 3518C 3519C Other initializations 3520C 3521 3522 ICHANG = 0 3523 3524*---------------------------------------------------------------------* 3525* read input: 3526*---------------------------------------------------------------------* 3527 IF (WORD(1:7) .EQ. '*CCQR2R') THEN 3528 3529100 CONTINUE 3530 3531* get new input line: 3532 READ (LUCMD,'(A7)') WORD 3533 CALL UPCASE(WORD) 3534 DO WHILE ( WORD(1:1) .EQ. '!' .OR. WORD(1:1) .EQ. '#' ) 3535 READ (LUCMD,'(A7)') WORD 3536 CALL UPCASE(WORD) 3537 END DO 3538 3539 IF (WORD(1:1) .EQ. '.') THEN 3540 3541c table look up: 3542 IJUMP = 1 3543 DO WHILE ( IJUMP .LE. NTABLE .AND. TABLE(IJUMP) .NE. WORD) 3544 IJUMP = IJUMP + 1 3545 END DO 3546 3547c jump to the appropriate input section: 3548 IF (IJUMP .LE. NTABLE) THEN 3549 ICHANG = ICHANG + 1 3550 GOTO (1,2,3,4,5), IJUMP 3551 CALL QUIT('Illegal address in computed GOTO in CC_QR2RINP.') 3552 3553C 3554C------------------------------------------------- 3555C Calculate dipole oscillator strengths. 3556C------------------------------------------------- 3557C 35581 CONTINUE 3559 IF (NQR2OP+9 .GT. MXQR2O) THEN 3560 WRITE(LUPRI,'(2(/A,I5))') 3561 & ' NO. OF OPERATOR DOUBLES SPECIFIED : ',NQR2OP+9, 3562 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXQR2O 3563 CALL QUIT('TOO MANY OPERATOR DOUBLES IN CCQR2R.') 3564 END IF 3565 IDIP(1) = INDPRP_CC('XDIPLEN ') 3566 IDIP(2) = INDPRP_CC('YDIPLEN ') 3567 IDIP(3) = INDPRP_CC('ZDIPLEN ') 3568 DO IDXA=1,3 3569 DO IDXB=1,3 3570 IDX = NQR2OP + (IDXA-1)*3+IDXB 3571 IAQR2OP(IDX) = IDIP(IDXA) 3572 IBQR2OP(IDX) = IDIP(IDXB) 3573 END DO 3574 END DO 3575 NQR2OP = NQR2OP + 9 3576 XOSCST = .TRUE. 3577 GO TO 100 3578C 3579C------------------------------------------------------------------- 3580C Use 2n+1 rule expression for transition matrix elements. 3581C------------------------------------------------------------------- 3582C 35832 CONTINUE 3584 QR22N1 = .FALSE. 3585 GO TO 100 3586C 3587C--------------------------- 3588C Input OPERATors. 3589C--------------------------- 3590C 35913 CONTINUE 3592 READ (LUCMD,'(2A)') LABELA, LABELB 3593 DO WHILE (LABELA(1:1).NE.'.' .AND. LABELA(1:1).NE.'*') 3594 IF (LABELA(1:1).NE.'!') THEN 3595 IF (NQR2OP.LT.MXQR2O) THEN 3596 NQR2OP = NQR2OP + 1 3597 IAQR2OP(NQR2OP) = INDPRP_CC(LABELA) 3598 IBQR2OP(NQR2OP) = INDPRP_CC(LABELB) 3599 ELSE 3600 WRITE(LUPRI,'(/2A,I5)') 3601 & ' NO. OF OPERATOR DOUBLES SPECIFIED', 3602 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXQR2O 3603 CALL QUIT('TOO MANY OPERATOR DOUBLES IN CCQR2R.') 3604 END IF 3605 END IF 3606 READ (LUCMD,'(2A)') LABELA, LABELB 3607 END DO 3608 BACKSPACE(LUCMD) 3609 GO TO 100 3610C 3611C------------------------- 3612C Select states. 3613C------------------------- 3614C 36154 CONTINUE 3616 SELQR2 =.TRUE. 3617 READ (LUCMD,'(A70)') LABHELP 3618 DO WHILE (LABHELP(1:1).NE.'.' .AND. LABHELP(1:1).NE.'*') 3619 IF (LABHELP(1:1).NE.'!') THEN 3620 READ(LABHELP,*) IXSYM,IXST,IXSYM2,IXST2 3621 IF (NSEQR2.LT.MXQR2ST) THEN 3622 NSEQR2 = NSEQR2 + 1 3623 ISEQR2(NSEQR2,1) = IXSYM 3624 ISEQR2(NSEQR2,2) = IXST 3625 ISEQR2(NSEQR2,3) = IXSYM2 3626 ISEQR2(NSEQR2,4) = IXST2 3627 ELSE 3628 WRITE(LUPRI,'(/2A,I5)') 3629 & ' NO. OF STATES SPECIFIED', 3630 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXQR2ST 3631 CALL QUIT('TOO MANY STATES IN CCQR2R.') 3632 END IF 3633 END IF 3634 READ (LUCMD,'(A70)') LABHELP 3635 END DO 3636 BACKSPACE(LUCMD) 3637 GO TO 100 3638C 3639C------------------------------------------------- 3640C Calculate dipole oscillator strengths. 3641C------------------------------------------------- 3642C 36435 CONTINUE 3644 IF (NQR2OP+9 .GT. MXQR2O) THEN 3645 WRITE(LUPRI,'(2(/A,I5))') 3646 & ' NO. OF OPERATOR DOUBLES SPECIFIED : ',NQR2OP+9, 3647 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXQR2O 3648 CALL QUIT('TOO MANY OPERATOR DOUBLES IN CCQR2R.') 3649 END IF 3650 IDIP(1) = INDPRP_CC('XDIPVEL ') 3651 IDIP(2) = INDPRP_CC('YDIPVEL ') 3652 IDIP(3) = INDPRP_CC('ZDIPVEL ') 3653 DO IDXA=1,3 3654 DO IDXB=1,3 3655 IDX = NQR2OP + (IDXA-1)*3+IDXB 3656 IAQR2OP(IDX) = IDIP(IDXA) 3657 IBQR2OP(IDX) = IDIP(IDXB) 3658 END DO 3659 END DO 3660 NQR2OP = NQR2OP + 9 3661 XVELST = .TRUE. 3662 GO TO 100 3663 3664 ELSE 3665 WRITE (LUPRI,'(/5A/)') ' Prompt "',WORD, 3666 & '" not recognized in ',SECNAM,'.' 3667 CALL PRTAB(NTABLE,TABLE,SECNAM//' input keywords',LUPRI) 3668 CALL QUIT('Illegal Keyword in '//SECNAM//'.') 3669 END IF 3670 3671 ELSE IF (WORD(1:1) .NE. '*') THEN 3672 WRITE (LUPRI,'(/5A/)') 'PROMPT "',WORD, 3673 & '" NOT RECOGNIZED IN ',SECNAM,'.' 3674 CALL QUIT('Illegal prompt in '//SECNAM//'.') 3675 3676 ELSE IF (WORD(1:1) .EQ.'*') THEN 3677 BACKSPACE (LUCMD) 3678 GO TO 200 3679 END IF 3680 3681 END IF 3682 3683200 CONTINUE 3684*---------------------------------------------------------------------* 3685* check, if input consistent. 3686*---------------------------------------------------------------------* 3687C 3688 IF (SELQR2.AND.(NSEQR2 .EQ.0)) WRITE(LUPRI,'(/A)') '@ INFO: '// 3689 & '(*CCQR2R input is strange - no states is requested.)' 3690 IF (NQR2OP .EQ.0) WRITE(LUPRI,'(/A)') '@ INFO: '// 3691 & '(*CCQR2R input ignored, because no operators requested.)' 3692C 3693C--------------------------------------------------------------------- 3694C Finally if we are to calculate anything at all, put CCQR2R true. 3695C--------------------------------------------------------------------- 3696C 3697 CCQR2R = (NQR2OP.GT.0) 3698C 3699 RETURN 3700 END 3701c/* deck cc_grin */ 3702C=====================================================================* 3703 SUBROUTINE CC_GRIN(WORD,MSYM) 3704C---------------------------------------------------------------------* 3705C 3706C Purpose: Read input for CC gradients: ground or excited state 3707C walk. 3708C 3709C if (WORD .eq '*CCGR ') read & process input and set defaults, 3710C else set only defaults 3711C 3712C Ove Christiansen august-1997 3713C 3714C=====================================================================* 3715#include "implicit.h" 3716#include "priunit.h" 3717#include "ccsdinp.h" 3718#include "ccsections.h" 3719#include "ccsdsym.h" 3720#include "cclr.h" 3721#include "leinf.h" 3722#include "cclrinf.h" 3723#include "ccrspprp.h" 3724#include "ccexci.h" 3725#include "ccgr.h" 3726#include "ccfdgeo.h" 3727 3728* local parameters: 3729 CHARACTER SECNAM*(7) 3730 PARAMETER (SECNAM='CC_GRIN') 3731 3732 INTEGER NTABLE 3733 PARAMETER (NTABLE = 3) 3734 3735* variables: 3736 LOGICAL SET 3737 SAVE SET 3738 3739 CHARACTER WORD*(7) 3740 CHARACTER TABLE(NTABLE)*(8) 3741 3742 INTEGER IJUMP 3743* data: 3744 DATA SET /.FALSE./ 3745 DATA TABLE /'.XSTSYM','.XSTNUM','.NUMGD '/ 3746*---------------------------------------------------------------------* 3747* begin: 3748*---------------------------------------------------------------------* 3749 IF (SET) RETURN 3750 SET = .TRUE. 3751 3752*---------------------------------------------------------------------* 3753* initializations & defaults: 3754*---------------------------------------------------------------------* 3755C 3756 IXSTSY = 0 3757 IXSTAT = 0 3758 NUMGD = .FALSE. 3759C 3760C Other initializations 3761C 3762 ICHANG = 0 3763 3764*---------------------------------------------------------------------* 3765* read input: 3766*---------------------------------------------------------------------* 3767 IF (WORD(1:7) .EQ. '*CCGR ') THEN 3768 3769100 CONTINUE 3770 3771* get new input line: 3772 READ (LUCMD,'(A7)') WORD 3773 CALL UPCASE(WORD) 3774 DO WHILE ( WORD(1:1) .EQ. '!' .OR. WORD(1:1) .EQ. '#' ) 3775 READ (LUCMD,'(A7)') WORD 3776 CALL UPCASE(WORD) 3777 END DO 3778 IF (WORD(1:1) .EQ. '.') THEN 3779 IJUMP = 1 3780 DO WHILE ( IJUMP .LE. NTABLE .AND. TABLE(IJUMP) .NE. WORD) 3781 IJUMP = IJUMP + 1 3782 END DO 3783 IF (IJUMP .LE. NTABLE) THEN 3784 ICHANG = ICHANG + 1 3785 GOTO (1,2,3), IJUMP 3786 CALL QUIT('Illegal address in computed GOTO in CC_LRRINP.') 3787C 3788C----------------------------------------- 3789C Readin excited state symmetry. 3790C----------------------------------------- 3791C 37921 CONTINUE 3793 READ (LUCMD,*) IXSTSY 3794 GO TO 100 3795C 3796C--------------------------------------- 3797C Readin excited state number. 3798C--------------------------------------- 3799C 38002 CONTINUE 3801 READ (LUCMD,*) IXSTAT 3802 GO TO 100 3803C 3804C----------------------------------------------------------------------- 3805C Numerical differentiation and no analytical derivative calc. 3806C----------------------------------------------------------------------- 3807C 38083 CONTINUE 3809 NUMGD = .TRUE. 3810 GO TO 100 3811C 3812 ELSE 3813 WRITE (LUPRI,'(/5A/)') ' Prompt "',WORD, 3814 & '" not recognized in ',SECNAM,'.' 3815 CALL PRTAB(NTABLE,TABLE,SECNAM//' input keywords',LUPRI) 3816 CALL QUIT('Illegal Keyword in '//SECNAM//'.') 3817 END IF 3818 3819 ELSE IF (WORD(1:1) .NE. '*') THEN 3820 WRITE (LUPRI,'(/5A/)') 'PROMPT "',WORD, 3821 & '" NOT RECOGNIZED IN ',SECNAM,'.' 3822 CALL QUIT('Illegal prompt in '//SECNAM//'.') 3823 3824 ELSE IF (WORD(1:1) .EQ.'*') THEN 3825 BACKSPACE (LUCMD) 3826 GO TO 200 3827 END IF 3828 3829 END IF 3830 3831200 CONTINUE 3832*---------------------------------------------------------------------* 3833* check, if input consistent. 3834*---------------------------------------------------------------------* 3835C 3836C--------------------------------------------------------------------- 3837C Finally if we are to calculate anything at all, put CCGR true. 3838C Presently this means if numgd then calculate. 3839C--------------------------------------------------------------------- 3840C 3841 CCGR = NUMGD 3842C 3843 RETURN 3844 END 3845c/* deck cc_exgrin */ 3846C=====================================================================* 3847 SUBROUTINE CC_EXGRIN(WORD,MSYM) 3848C---------------------------------------------------------------------* 3849C 3850C Purpose: Read input for CC excited state calculations of 3851C first-order properties. 3852C 3853C if (WORD .eq '*CCEXGR ') read & process input and set defaults, 3854C else set only defaults 3855C 3856C Ove Christiansen 4-2-1997 3857C 3858C=====================================================================* 3859#include "implicit.h" 3860#include "priunit.h" 3861#include "ccsdinp.h" 3862#include "ccsections.h" 3863#include "ccsdsym.h" 3864#include "cclr.h" 3865#include "leinf.h" 3866#include "cclrinf.h" 3867#include "ccrspprp.h" 3868#include "ccexci.h" 3869#include "ccexgr.h" 3870 3871* local parameters: 3872 CHARACTER SECNAM*(9) 3873 PARAMETER (SECNAM='CC_EXGRIN') 3874 3875 INTEGER NTABLE 3876 PARAMETER (NTABLE = 11) 3877 3878* variables: 3879 LOGICAL SET 3880 SAVE SET 3881 3882 CHARACTER WORD*(7) 3883 CHARACTER LABEL*(8), LABHELP*(70) 3884 CHARACTER TABLE(NTABLE)*(8) 3885 3886 INTEGER IJUMP, INDPRP_CC 3887* data: 3888 DATA SET /.FALSE./ 3889 DATA TABLE /'.DIPOLE','.QUADRU','.NQCC ','.OPERAT','XXXXXXX', 3890 * 'XXXXXXX','.ALLONE','.RELCOR','.SECMOM','.SELXST', 3891 * '.SELEXC'/ 3892 3893*---------------------------------------------------------------------* 3894* begin: 3895*---------------------------------------------------------------------* 3896 IF (SET) RETURN 3897 SET = .TRUE. 3898 3899*---------------------------------------------------------------------* 3900* initializations & defaults: 3901*---------------------------------------------------------------------* 3902C 3903 SELXGR = .FALSE. 3904 SELXST = .FALSE. 3905 ALLEXE = .FALSE. 3906 XDIPMO = .FALSE. 3907 XQUADR = .FALSE. 3908 XNQCC = .FALSE. 3909 XRELCO = .FALSE. 3910 XSECMO = .FALSE. 3911 NAXGRO = 0 3912 CCEXGR = .FALSE. 3913C DNSDRV = .FALSE. 3914C 3915C Other initializations 3916C 3917 ICHANG = 0 3918 3919*---------------------------------------------------------------------* 3920* read input: 3921*---------------------------------------------------------------------* 3922 IF (WORD(1:7) .EQ. '*CCEXGR') THEN 3923 3924100 CONTINUE 3925 3926* get new input line: 3927 READ (LUCMD,'(A7)') WORD 3928 CALL UPCASE(WORD) 3929 DO WHILE ( WORD(1:1) .EQ. '!' .OR. WORD(1:1) .EQ. '#' ) 3930 READ (LUCMD,'(A7)') WORD 3931 CALL UPCASE(WORD) 3932 END DO 3933 IF (WORD(1:1) .EQ. '.') THEN 3934 IJUMP = 1 3935 DO WHILE ( IJUMP .LE. NTABLE .AND. TABLE(IJUMP) .NE. WORD) 3936 IJUMP = IJUMP + 1 3937 END DO 3938 IF (IJUMP .LE. NTABLE) THEN 3939 ICHANG = ICHANG + 1 3940 GOTO (1,2,3,4,5,6,7,8,9,10,11), IJUMP 3941 CALL QUIT('Illegal address in computed GOTO in CC_LRRINP.') 3942C 3943C----------------------------------- 3944C Calculate dipole moment. 3945C----------------------------------- 3946C 3947 39481 CONTINUE 3949 XDIPMO = .TRUE. 3950 GO TO 100 3951 3952C 3953C---------------------------------------- 3954C Calculate Quadrupole moments. 3955C---------------------------------------- 3956C 3957 39582 CONTINUE 3959 XQUADR = .TRUE. 3960 GO TO 100 3961 3962C 3963C---------------------------------------------- 3964C Calculate electric field gradients. 3965C---------------------------------------------- 3966C 3967 39683 CONTINUE 3969 XNQCC = .TRUE. 3970 GO TO 100 3971C 3972C---------------------------------------------- 3973C .OPERAT : General operator section. 3974C---------------------------------------------- 3975C 3976 39774 CONTINUE 3978 READ (LUCMD,'(A)') LABEL 3979 DO WHILE ((LABEL(1:1).NE.'.' ).AND.(LABEL(1:1).NE.'*')) 3980 IF (LABEL(1:1).NE.'!') THEN 3981 IF (NAXGRO .LT.MXGROP) THEN 3982 NAXGRO = NAXGRO + 1 3983 IAXGRO(NAXGRO) = INDPRP_CC(LABEL) 3984 ELSE 3985 WRITE(LUPRI,'(/2A,I5)') 3986 & ' NO. OF OPERATORS SPECIFIED', 3987 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXGROP 3988 CALL QUIT('TOO MANY OPERATORS IN CCEXGR.') 3989 END IF 3990 END IF 3991 READ (LUCMD,'(3A)') LABEL 3992 END DO 3993 BACKSPACE(LUCMD) 3994 GO TO 100 3995C 3996C----------------------------------------- 3997C----------------------------------------- 3998C 39995 CONTINUE 4000 GO TO 100 4001C 4002C--------------------------------------- 4003C--------------------------------------- 4004C 40056 CONTINUE 4006 GO TO 100 4007 4008C 4009C--------------------------------------------------------- 4010C Calculate all standard first order properties. 4011C--------------------------------------------------------- 4012C 40137 CONTINUE 4014 XDIPMO = .TRUE. 4015 XQUADR = .TRUE. 4016 XNQCC = .TRUE. 4017 XRELCO = .TRUE. 4018 XSECMO = .TRUE. 4019 GO TO 100 4020C 4021C------------------------------------ 4022C Relativistic corrections. 4023C------------------------------------ 4024C 40258 CONTINUE 4026 XRELCO = .TRUE. 4027 GO TO 100 4028C 4029C-------------------------------- 4030C Second order moments. 4031C-------------------------------- 4032C 40339 CONTINUE 4034 XSECMO = .TRUE. 4035 GO TO 100 4036C 4037C--------------------------------------------------------------------- 4038C Select excited state for first order property calculation. 4039C--------------------------------------------------------------------- 4040C 404110 CONTINUE 4042 SELXST = .TRUE. 4043 GO TO 100 4044C 4045C--------------------------------------------------------------------- 4046C Select excited state for first order property calculation. 4047C--------------------------------------------------------------------- 4048C 404911 CONTINUE 4050 SELXGR = .TRUE. 4051 READ (LUCMD,'(A70)') LABHELP 4052 DO WHILE (LABHELP(1:1).NE.'.' .AND. LABHELP(1:1).NE.'*') 4053 IF (LABHELP(1:1).NE.'!') THEN 4054 READ(LABHELP,*) IXSYM,IXST 4055 IF (NSEXGR.LT.MXXGST) THEN 4056 NSEXGR = NSEXGR + 1 4057 ISEXGR(NSEXGR,1) = IXSYM 4058 ISEXGR(NSEXGR,2) = IXST 4059 ELSE 4060 WRITE(LUPRI,'(/2A,I5)') 4061 & ' NO. OF STATES SPECIFIED', 4062 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXXGST 4063 CALL QUIT('TOO MANY STATES IN CCEXGR.') 4064 END IF 4065 END IF 4066 READ (LUCMD,'(A70)') LABHELP 4067 END DO 4068 BACKSPACE(LUCMD) 4069 GO TO 100 4070C 4071 ELSE 4072 WRITE (LUPRI,'(/5A/)') ' Prompt "',WORD, 4073 & '" not recognized in ',SECNAM,'.' 4074 CALL PRTAB(NTABLE,TABLE,SECNAM//' input keywords',LUPRI) 4075 CALL QUIT('Illegal Keyword in '//SECNAM//'.') 4076 END IF 4077 4078 ELSE IF (WORD(1:1) .NE. '*') THEN 4079 WRITE (LUPRI,'(/5A/)') 'PROMPT "',WORD, 4080 & '" NOT RECOGNIZED IN ',SECNAM,'.' 4081 CALL QUIT('Illegal prompt in '//SECNAM//'.') 4082 4083 ELSE IF (WORD(1:1) .EQ.'*') THEN 4084 BACKSPACE (LUCMD) 4085 GO TO 200 4086 END IF 4087 4088 END IF 4089 4090200 CONTINUE 4091*---------------------------------------------------------------------* 4092* check, if input consistent. 4093*---------------------------------------------------------------------* 4094C 4095C--------------------------------------------------------------------- 4096C Finally if we are to calculate anything at all, put CCEXGR true. 4097C--------------------------------------------------------------------- 4098C 4099 CCEXGR = (XDIPMO.OR.XQUADR.OR.XNQCC.OR.XSECMO 4100 * .OR.XRELCO.OR.(NAXGRO.GT.0)) 4101C 4102 RETURN 4103 END 4104C---------------------------------------------------------------------* 4105c /* deck cc_fopinp */ 4106C=====================================================================* 4107 SUBROUTINE CC_FOPINP(WORD) 4108C---------------------------------------------------------------------* 4109C 4110C Purpose: read input for CC first order properties; 4111C directs calculation of dipole moments, quadrupole moments, 4112C electric field gradients, etc. 4113C 4114C if (WORD .eq '*CCFOP ') read & process input and set defaults, 4115C else set only defaults 4116C 4117C Asger Halkier & Ove Christiansen Oct. 1996/Mar. 1997(RELCOR&APROP) 4118C Asger Halkier primo Nov. 1999: relativistic 2-electron Darwin term. 4119C Asger Halkier ultimo Nov. 1999: First-order Direct Perturbation 4120C Theory (DPT) energy corrections. 4121C 4122C=====================================================================* 4123#include "implicit.h" 4124#include "priunit.h" 4125#include "ccsdinp.h" 4126#include "ccsections.h" 4127#include "ccsdsym.h" 4128#include "cclr.h" 4129#include "ccfop.h" 4130#include "cclrinf.h" 4131#include "ccrspprp.h" 4132 4133* local parameters: 4134 CHARACTER SECNAM*(9) 4135 PARAMETER (SECNAM='CC_FOPINP') 4136 4137 INTEGER NTABLE 4138 PARAMETER (NTABLE = 14) 4139 4140* variables: 4141 LOGICAL SET 4142 SAVE SET 4143 4144 CHARACTER WORD*(7) 4145 CHARACTER LABEL*(8) 4146 CHARACTER TABLE(NTABLE)*(8) 4147 4148 INTEGER IJUMP 4149 4150* external function: 4151 INTEGER INDPRP_CC 4152 4153* data: 4154 DATA SET /.FALSE./ 4155 DATA TABLE /'.DIPMOM','.QUADRU','.NQCC ','.TSTDEN','.ALLONE', 4156 * '.NONREL','.RELCOR','.OPERAT','.SECMOM','.2ELDAR', 4157 * '.DPTECO','.BPH2OO','.BPH2SS','.CRONLY'/ 4158 4159*---------------------------------------------------------------------* 4160* begin: 4161*---------------------------------------------------------------------* 4162 IF (SET) RETURN 4163 SET = .TRUE. 4164 4165*---------------------------------------------------------------------* 4166* initializations & defaults: 4167*---------------------------------------------------------------------* 4168C 4169 DIPMOM = .FALSE. 4170 QUADRU = .FALSE. 4171 NQCC = .FALSE. 4172 TSTDEN = .FALSE. 4173 SECMOM = .FALSE. 4174 RELCOR = .FALSE. 4175 RELORB = .TRUE. 4176 NAFOP = 0 4177 DAR2EL = .FALSE. 4178 DPTECO = .FALSE. 4179 BP2EOO = .FALSE. 4180 CORRONLY = .FALSE. 4181C 4182*---------------------------------------------------------------------* 4183* read input: 4184*---------------------------------------------------------------------* 4185 IF (WORD(1:7) .EQ. '*CCFOP ') THEN 4186 4187100 CONTINUE 4188 4189* get new input line: 4190 READ (LUCMD,'(A7)') WORD 4191 CALL UPCASE(WORD) 4192 DO WHILE ( WORD(1:1) .EQ. '!' .OR. WORD(1:1) .EQ. '#' ) 4193 READ (LUCMD,'(A7)') WORD 4194 CALL UPCASE(WORD) 4195 END DO 4196 4197 IF (WORD(1:1) .EQ. '.') THEN 4198 4199c table look up: 4200 IJUMP = 1 4201 DO WHILE ( IJUMP .LE. NTABLE .AND. TABLE(IJUMP) .NE. WORD) 4202 IJUMP = IJUMP + 1 4203 END DO 4204 4205c jump to the appropriate input section: 4206 IF (IJUMP .LE. NTABLE) THEN 4207 ICHANG = ICHANG + 1 4208 GOTO (1,2,3,4,5,6,7,8,9,10,11,12,13,14), IJUMP 4209 CALL QUIT('Illegal address in computed GOTO in CC_FOPINP.') 4210 4211C 4212C----------------------------------- 4213C Calculate dipole moment. 4214C----------------------------------- 4215C 4216 42171 CONTINUE 4218 DIPMOM = .TRUE. 4219CCN Added for CC-R12: 4220 IDUM = INDPRP_CC('XDIPLEN ') 4221 IDUM = INDPRP_CC('YDIPLEN ') 4222 IDUM = INDPRP_CC('ZDIPLEN ') 4223 GO TO 100 4224 4225C 4226C---------------------------------------- 4227C Calculate Quadrupole moments. 4228C---------------------------------------- 4229C 4230 42312 CONTINUE 4232 QUADRU = .TRUE. 4233CCN Added for CC-R12: 4234 IDUM = INDPRP_CC('XXTHETA ') 4235 IDUM = INDPRP_CC('XYTHETA ') 4236 IDUM = INDPRP_CC('XZTHETA ') 4237 IDUM = INDPRP_CC('YYTHETA ') 4238 IDUM = INDPRP_CC('YZTHETA ') 4239 IDUM = INDPRP_CC('ZZTHETA ') 4240 GO TO 100 4241 4242C 4243C---------------------------------------------- 4244C Calculate electric field gradients. 4245C---------------------------------------------- 4246C 4247 42483 CONTINUE 4249 NQCC = .TRUE. 4250 GO TO 100 4251 4252C 4253C-------------------------- 4254C Test densities. 4255C-------------------------- 4256C 4257 42584 CONTINUE 4259 TSTDEN = .TRUE. 4260 GO TO 100 4261 4262C 4263C---------------------------------------------------------------------- 4264C Calculate all standard first-order one-electron properties. 4265C---------------------------------------------------------------------- 4266C 4267 42685 CONTINUE 4269 DIPMOM = .TRUE. 4270 QUADRU = .TRUE. 4271 NQCC = .TRUE. 4272 RELCOR = .TRUE. 4273 SECMOM = .TRUE. 4274 GO TO 100 4275C 4276C--------------------------------- 4277C No orbital relaxation. 4278C--------------------------------- 4279C 4280 42816 CONTINUE 4282 RELORB = .FALSE. 4283 GO TO 100 4284 4285C 4286C------------------------------------------------- 4287C Relativistic one-electron corrections. 4288C------------------------------------------------- 4289C 4290 42917 CONTINUE 4292 RELCOR = .TRUE. 4293 GO TO 100 4294C 4295C----------------------------------------------------- 4296C Arbitrary Number of One electron operator. 4297C----------------------------------------------------- 4298C 4299 43008 CONTINUE 4301 READ (LUCMD,'(A)') LABEL 4302 DO WHILE ((LABEL(1:1).NE.'.' ).AND.(LABEL(1:1).NE.'*')) 4303 IF (LABEL(1:1).NE.'!') THEN 4304 IF (NAFOP .LT.MAFOP) THEN 4305 NAFOP = NAFOP + 1 4306 IAFOP(NAFOP) = INDPRP_CC(LABEL) 4307 ELSE 4308 WRITE(LUPRI,'(/2A,I5)') 4309 & ' NO. OF OPERATORS SPECIFIED', 4310 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MAFOP 4311 CALL QUIT('TOO MANY OPERATORS IN CCFOP .') 4312 END IF 4313 END IF 4314 READ (LUCMD,'(3A)') LABEL 4315 END DO 4316 BACKSPACE (LUCMD) 4317 GO TO 100 4318C 4319C-------------------------------- 4320C Second order moments. 4321C-------------------------------- 4322C 4323 43249 CONTINUE 4325 SECMOM = .TRUE. 4326CCN Added for CC-R12: 4327 IDUM = INDPRP_CC('XXSECMOM') 4328 IDUM = INDPRP_CC('XYSECMOM') 4329 IDUM = INDPRP_CC('XZSECMOM') 4330 IDUM = INDPRP_CC('YYSECMOM') 4331 IDUM = INDPRP_CC('YZSECMOM') 4332 IDUM = INDPRP_CC('ZZSECMOM') 4333 GO TO 100 4334C 4335C------------------------------------------------- 4336C Relativistic two-electron Darwin term. 4337C------------------------------------------------- 4338C 4339 434010 CONTINUE 4341 DAR2EL = .TRUE. 4342 GO TO 100 4343C 4344C------------------------------------------------- 4345C Relativistic DPT 4346C------------------------------------------------- 4347C 4348 434911 CONTINUE 4350 DPTECO = .TRUE. 4351 GO TO 100 4352C 4353C 4354C------------------------------------------------- 4355C Breit-Pauli Orbit-Orbit 4356C------------------------------------------------- 4357C 4358 435912 CONTINUE 4360 BP2EOO = .TRUE. 4361 GO TO 100 4362C 4363C 4364C 4365C------------------------------------------------- 4366C Breit-Pauli Spin-Spin = -2 Darwin2E 4367C------------------------------------------------- 4368C 4369 437013 CONTINUE 4371 DAR2EL = .TRUE. 4372 GO TO 100 4373C 437414 CONTINUE 4375 !removes Hartree-Fock part of densities 4376 !yields correlation only contribution to 4377 !FOP properties 4378 CORRONLY = .TRUE. 4379 GO TO 100 4380 ELSE 4381 WRITE (LUPRI,'(/5A/)') ' Prompt "',WORD, 4382 & '" not recognized in ',SECNAM,'.' 4383 CALL PRTAB(NTABLE,TABLE,SECNAM//' input keywords',LUPRI) 4384 CALL QUIT('Illegal Keyword in '//SECNAM//'.') 4385 END IF 4386 4387 ELSE IF (WORD(1:1) .NE. '*') THEN 4388 WRITE (LUPRI,'(/5A,/)') 'PROMPT "',WORD, 4389 & '" NOT RECOGNIZED IN ',SECNAM,'.' 4390 CALL QUIT('Illegal prompt in '//SECNAM//'.') 4391 4392 ELSE IF (WORD(1:1) .EQ.'*') THEN 4393 BACKSPACE (LUCMD) 4394 GO TO 200 4395 END IF 4396 4397 END IF 4398 4399200 CONTINUE 4400C 4401C-------------------------------------------------------------------- 4402C Finally if we are to calculate anything at all, put CCFOP true. 4403C-------------------------------------------------------------------- 4404C 4405 CCFOP = (DIPMOM.OR.QUADRU.OR.NQCC.OR.TSTDEN.OR.RELCOR.OR. 4406 * SECMOM.OR.DAR2EL.OR.DPTECO.OR.BP2EOO.OR.(NAFOP.GT.0)) 4407C 4408 IF (CCFOP) RSPIM = .TRUE. 4409C 4410 RETURN 4411 END 4412C-------------------------------------------------------------------- 4413c /* deck cc_lrinp */ 4414C=====================================================================* 4415 SUBROUTINE CC_LRINP(WORD) 4416C---------------------------------------------------------------------* 4417C 4418C Purpose: read input for CC linear response, in particular 4419C dynamic polarizabilities 4420C 4421C if (WORD .eq '*CCLR ') read & process input and set defaults, 4422C else set only defaults 4423C 4424C Christof Haettig and Ove Christiansen October 1996 4425C Relaxed/Unrelaxed options introduced in Nov' 1998, Ch. Haettig 4426C 4427C=====================================================================* 4428C#if defined (IMPLICIT_NONE) 4429C IMPLICIT NONE 4430C#else 4431# include "implicit.h" 4432C#endif 4433#include "priunit.h" 4434#include "ccsdinp.h" 4435#include "ccsections.h" 4436#include "ccsdsym.h" 4437#include "cclrinf.h" 4438#include "ccrspprp.h" 4439#include "mxcent.h" 4440#include "nuclei.h" 4441#include "codata.h" 4442Cholesky 4443#include "maxorb.h" 4444#include "ccdeco.h" 4445Cholesky 4446CTOCD 4447#include "ctocdcc.h" 4448CTOCD 4449 4450 4451* local parameters: 4452 CHARACTER SECNAM*(8) 4453 PARAMETER (SECNAM='CC_LRINP') 4454 4455 INTEGER NTABLE 4456 PARAMETER (NTABLE = 25) 4457 4458#if defined (SYS_CRAY) 4459 REAL ZERO, TOLFRQ 4460#else 4461 DOUBLE PRECISION ZERO, TOLFRQ 4462#endif 4463 PARAMETER (ZERO = 0.0d00) 4464 PARAMETER (TOLFRQ = 1.0D-09) 4465 4466* variables: 4467 LOGICAL SET 4468 SAVE SET 4469 4470 CHARACTER WORD*(7), LINE*(80) 4471 CHARACTER*8 LABELA,LABELB 4472 CHARACTER*8 LABDIP(3), LABDPV(3), LABANG(3) 4473 CHARACTER TABLE(NTABLE)*(8) 4474 4475 LOGICAL LRELAX, LRELAS, LOCSTAT 4476 INTEGER IDX, IJUMP, IDIP(3), IGRA(MXCOOR) 4477 4478! LOGICAL EXCLRL 4479 INTEGER IGNCHO(4) 4480 4481* external function: 4482 INTEGER INDPRP_CC 4483 4484* data: 4485 DATA LABDIP /'XDIPLEN ','YDIPLEN ','ZDIPLEN '/ 4486 DATA LABDPV /'XDIPVEL ','YDIPVEL ','ZDIPVEL '/ 4487 DATA LABANG /'XANGMOM ','YANGMOM ','ZANGMOM '/ 4488 4489 DATA SET /.FALSE./ 4490 DATA TABLE /'.RELAXE','.UNRELA','.FREQUE','.DIPOLE','.ALLDSP', 4491 * '.OLD_LR','.ASYMSD','.DISPCF','.OPERAT','.AVERAG', 4492 * '.PRINT ','.STATIC','.DIPGRA','.OR LEN','.OR VEL', 4493 * '.OR ','.OR MVE','.ORGANL','.ORIGIN','.WAVELE', 4494 * '.INCLRL','.EXCLRL','.CTOSUS','.CTOSHI','.XXXXXX'/ 4495 4496*---------------------------------------------------------------------* 4497* begin: 4498*---------------------------------------------------------------------* 4499 IF (SET) RETURN 4500 SET = .TRUE. 4501 4502*---------------------------------------------------------------------* 4503* initializations & defaults: 4504*---------------------------------------------------------------------* 4505 CAUCHY = .FALSE. 4506 NLRDISP = 0 4507 ALLLRDSPCF = .FALSE. 4508C 4509 ALPHA_ISO = .FALSE. 4510 ALPHA_ANI = .FALSE. 4511 OFFALPHA(1) = -1 4512 OFFALPHA(2) = -1 4513C 4514 NBLRFR = 0 4515 NLROP = 0 4516 NDIPFR = 0 4517 NORGIN = 0 4518 IPRSOP = IPRINT 4519 DIPPOL = .FALSE. 4520 ORLEN = .FALSE. 4521 ORVEL = .FALSE. 4522 ORMVE = .FALSE. 4523 ORGANL = .FALSE. 4524C 4525Cmodvel 4526C 4527! INCLRL = .FALSE. 4528! EXCLRL = .FALSE. 4529C 4530Cmodvel 4531C 4532 ASYMSD = .FALSE. 4533 LRELAX = .FALSE. 4534 DIPGRA = .FALSE. 4535 ICHANG = 0 4536 4537 OLDLR = .FALSE. 4538 4539 CALL IZERO(IGNCHO,4) 4540 CALL DZERO(ORGIN,MORGIN+1) 4541 4542 LOCSTAT = .FALSE. 4543 4544CTOCD 4545 CTOSHI = .FALSE. 4546 CTOSUS = .FALSE. 4547CTOCD 4548 4549*---------------------------------------------------------------------* 4550* read input: 4551*---------------------------------------------------------------------* 4552 IF (WORD(1:7) .EQ. '*CCLR ') THEN 4553 4554100 CONTINUE 4555 4556* get new input line: 4557 READ (LUCMD,'(A7)') WORD 4558 CALL UPCASE(WORD) 4559 DO WHILE ( WORD(1:1) .EQ. '!' .OR. WORD(1:1) .EQ. '#' ) 4560 READ (LUCMD,'(A7)') WORD 4561 CALL UPCASE(WORD) 4562 END DO 4563 4564 IF (WORD(1:1) .EQ. '.') THEN 4565 4566c table look up: 4567 IJUMP = 1 4568 DO WHILE ( IJUMP .LE. NTABLE .AND. TABLE(IJUMP) .NE. WORD) 4569 IJUMP = IJUMP + 1 4570 END DO 4571 4572c jump to the appropriate input section: 4573 IF (IJUMP .LE. NTABLE) THEN 4574 ICHANG = ICHANG + 1 4575 GOTO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20, 4576 & 21,22,23,24,25), IJUMP 4577 CALL QUIT('Illegal address in computed GOTO in CC_LRINP.') 4578C 4579C----------------------- 4580C .RELAXEd 4581C----------------------- 4582C 45831 CONTINUE 4584 LRELAX = .TRUE. 4585 IF (CHOINT) THEN 4586 IGNCHO(4) = 1 4587 LRELAX = .FALSE. 4588 ENDIF 4589 GO TO 100 4590C 4591C----------------------- 4592C .UNRELAxed 4593C----------------------- 4594C 45952 CONTINUE 4596 LRELAX = .FALSE. 4597 GO TO 100 4598C 4599C--------------------- 4600C .FREQUEncy 4601C--------------------- 4602C 46033 CONTINUE 4604 READ (LUCMD,*) NRDFR 4605 NFTOT = NRDFR + NBLRFR 4606 IF (NFTOT .GT. MBLRFR) THEN 4607 WRITE(LUPRI,'(3(/A,I5),/)') 4608 & ' NUMBER OF FREQUENCIES SPECIFIED : ',NFTOT, 4609 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MBLRFR, 4610 & ' THE NUMBER IS RESET TO THE MAXIMUM : ',MBLRFR 4611 NFTOT = MBLRFR 4612 NRDFR = NFTOT - NBLRFR 4613 END IF 4614 READ (LUCMD,*) (BLRFR(NBLRFR+I),I=1,NRDFR) 4615 NBLRFR = NBLRFR + NRDFR 4616 GO TO 100 4617C 4618C----------------------------------- 4619C DIPole POLarizabilities. 4620C----------------------------------- 4621C 46224 CONTINUE 4623 DIPPOL =.TRUE. 4624 CALL CC_LRINPREQ(LABDIP,LABDIP,3,3,.FALSE.,LRELAX) 4625 GO TO 100 4626C 4627C -------------------------------------------------------- 4628C .ALLDSP : do not skip odd/even dispersion coefficients 4629C or real/imaginary properties 4630C -------------------------------------------------------- 46315 CONTINUE 4632 ALLLRDSPCF = .TRUE. 4633 GO TO 100 4634 4635C 4636C ----------------------------------- 4637C .OLD_LR : use old LR code^ 4638C ----------------------------------- 4639C 46406 CONTINUE 4641 OLDLR = .TRUE. 4642 IF (CHOINT) THEN 4643 IGNCHO(3) = 1 4644 OLDLR = .FALSE. 4645 ENDIF 4646 GO TO 100 4647 4648C 4649C ------------------------------------------------- 4650C Use asymmetric form for linear response function. 4651C (Does not obey 2n+2 rule for multipliers but only 4652C response to Y is needed.) 4653C ------------------------------------------------- 4654C 46557 CONTINUE 4656 ASYMSD =.TRUE. 4657 ASYMSD =.TRUE. 4658 IF (CHOINT) THEN 4659 IGNCHO(1) = 1 4660 ASYMSD = .FALSE. 4661 ENDIF 4662 GO TO 100 4663C 4664C --------------------------------- 4665C .DISPCF : dispersion coefficients 4666C --------------------------------- 46678 CONTINUE 4668 CAUCHY = .TRUE. 4669 READ (LUCMD,*) NLRDISP 4670 IF (NLRDISP.LT.0) THEN 4671 CALL QUIT('NLRDISP < 0 not allowed '// 4672 & 'for .DISPCF in *CCLR') 4673 END IF 4674 IF (CHOINT) THEN 4675 IGNCHO(2) = 1 4676 ENDIF 4677 GO TO 100 4678 4679C ------------------------------------------- 4680C .OPERAT : Operator set for Linear response. 4681C ------------------------------------------- 4682 46839 CONTINUE 4684 READ (LUCMD,'(2A)') LABELA, LABELB 4685 DO WHILE (LABELA(1:1).NE.'.' .AND. LABELA(1:1).NE.'*') 4686 IF (LABELA(1:1).NE.'!') THEN 4687 IF (NLROP.LT.MXLROP) THEN 4688 CALL CC_LRINPREQ(LABELA,LABELB,1,1,.TRUE.,LRELAX) 4689 ELSE 4690 WRITE(LUPRI,'(/2A,I5)') 4691 & ' NO. OF OPERATOR DOUBLES SPECIFIED', 4692 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXLROP 4693 CALL QUIT('TOO MANY OPERATOR DOUBLES IN CCLR.') 4694 END IF 4695 END IF 4696 READ (LUCMD,'(2A)') LABELA, LABELB 4697 END DO 4698 BACKSPACE(LUCMD) 4699 GO TO 100 4700C 4701C ------------------------------------------------------- 4702C .AVERAG : calculate averaged tensor components 4703C implemented: alpha_{iso}, alpha_{ani} 4704C ------------------------------------------------------- 470510 CONTINUE 4706 READ(LUCMD,'(A)') LINE 4707 IF (LINE(1:9).EQ.'ALPHA_ISO') THEN 4708 ALPHA_ISO = .TRUE. 4709 ELSE IF (LINE(:9).EQ.'ALPHA_ANI') THEN 4710 ALPHA_ISO = .TRUE. 4711 ALPHA_ANI = .TRUE. 4712 ELSE 4713 WRITE(LUPRI,'(/4A/A/)') 4714 & '@ LABEL "',LINE(1:5),'" UNKNOWN FOR .AVERAG KEYWORD', 4715 & 'IN *CCLR SECTION.','@ INPUT IS IGNORED...' 4716 END IF 4717 4718 READ(LUCMD,'(A)') LINE 4719 CSYM = 'GENERI' 4720 IF (LINE(1:6).EQ.'ATOMIC') THEN 4721 CSYM = 'ATOMIC' ! an atom 4722 ELSE IF (LINE(1:6).EQ.'SPHTOP') THEN 4723 CSYM = 'SPHTOP' ! spherical top 4724 ELSE IF (LINE(1:6).EQ.'LINEAR') THEN 4725 CSYM = 'LINEAR' ! linear molecule 4726 ELSE IF (LINE(1:6).EQ.'XYDEGN') THEN 4727 CSYM = 'LINEAR' ! linear molecule 4728 ELSE IF (LINE(1:5).EQ.'GENER') THEN 4729 CSYM = 'GENERI' ! use generic point group symmetry 4730 ELSE 4731 WRITE (LUPRI,*) 4732 * 'WARNING: unknown symmetry input in *CCLR:' 4733 WRITE (LUPRI,*) LINE 4734 WRITE (LUPRI,*)'WARNING: input line ignored...' 4735 END IF 4736 4737 IF (ALPHA_ISO .OR. ALPHA_ANI) THEN 4738 IDIP(1) = INDPRP_CC('XDIPLEN ') 4739 IDIP(2) = INDPRP_CC('YDIPLEN ') 4740 IDIP(3) = INDPRP_CC('ZDIPLEN ') 4741 DO IDX = 1, 2 4742 IALROP(NLROP+1) = IDIP(3) !cmp 1: alph_zz 4743 IBLROP(NLROP+1) = IDIP(3) 4744 4745 IALROP(NLROP+2+(IDX-1)*3) = IDIP(IDX) !cmp 2: alph_xx 4746 IBLROP(NLROP+2+(IDX-1)*3) = IDIP(IDX) !cmp 5: alph_yy 4747 4748 IALROP(NLROP+3+(IDX-1)*3) = IDIP(IDX) !cmp 3: alph_xz 4749 IBLROP(NLROP+3+(IDX-1)*3) = IDIP(3) !cmp 6: alph_yz 4750 4751 IALROP(NLROP+4) = IDIP(1) !cmp 4: alph_xy 4752 IBLROP(NLROP+4) = IDIP(2) 4753 END DO 4754 DO IDX = 1, 6 4755 LALORX(NLROP+IDX) = LRELAX 4756 LBLORX(NLROP+IDX) = LRELAX 4757 END DO 4758 IF ( LRELAX) OFFALPHA(1) = NLROP 4759 IF (.NOT.LRELAX) OFFALPHA(2) = NLROP 4760 IF (CSYM(1:6).EQ.'ATOMIC') THEN 4761 NLROP = NLROP + 1 4762 ELSE IF (CSYM(1:6).EQ.'SPHTOP') THEN 4763 NLROP = NLROP + 1 4764 ELSE IF (CSYM(1:6).EQ.'LINEAR') THEN 4765 NLROP = NLROP + 3 4766 ELSE IF (CSYM(1:6).EQ.'XYDEGN') THEN 4767 NLROP = NLROP + 4 4768 ELSE 4769 NLROP = NLROP + 6 4770 END IF 4771 END IF 4772 GO TO 100 4773C 4774C -------------------------------------------------- 4775C .PRINT set print level for linear response output: 4776C -------------------------------------------------- 4777C 477811 CONTINUE 4779 READ (LUCMD,*) IPRSOP 4780 GO TO 100 4781C 4782C----------------------- 4783C .STATIC 4784C----------------------- 4785C 478612 CONTINUE 4787 IF (.NOT. LOCSTAT) THEN 4788 IF (NBLRFR .GE. MBLRFR) THEN 4789 WRITE(LUPRI,'(3(/A,I5),/)') 4790 & '@ NUMBER OF FREQUENCIES SPECIFIED : ',NBLRFR, 4791 & '@ IS ALREADY EQUAL TO THE MAXIMUM ALLOWED : ',MBLRFR, 4792 & '@ THE .STATIC KEYWORD UNDER *CCLR WILL BE IGNORED...' 4793 ELSE 4794 LOCSTAT = .TRUE. 4795 NBLRFR = NBLRFR + 1 4796 BLRFR(NBLRFR) = 0.0D0 4797 END IF 4798 ENDIF 4799 GO TO 100 4800C 4801C ------------------------------------------------- 4802C .DIPGRA: Dipole gradients and Cioslowski charges. 4803C ------------------------------------------------- 4804C 480513 CONTINUE 4806 DIPGRA = .TRUE. 4807 NDIP = 3 4808 NCOOR = 3*NUCDEP 4809 NTOT = NDIP*NCOOR 4810 IF (NLROP+NTOT .GT. MXLROP) THEN 4811 WRITE(LUPRI,'(2(/A,I5))') 4812 & ' NO. OF OPERATOR DOUBLES SPECIFIED : ',NLROP+NTOT, 4813 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXLROP 4814 CALL QUIT('TOO MANY OPERATOR DOUBLES IN CCLR') 4815 ENDIF 4816 IF (NCOOR .GT. 999) THEN 4817 WRITE(LUPRI,*) 'Too many centers in CCLR' 4818 WRITE(LUPRI,*) 4819 & 'Unable to construct labels for gradient ints' 4820 CALL QUIT('Too many centers in CCLR') 4821 ENDIF 4822 IF (NCOOR .GT. MXCOOR) THEN 4823 WRITE(LUPRI,*) 'IGRA dimension error in CC_LRINP:' 4824 WRITE(LUPRI,*) ' NCOOR: ',NCOOR 4825 WRITE(LUPRI,*) 'MXCOOR: ',MXCOOR 4826 CALL QUIT('Error in CC_LRINP') 4827 ENDIF 4828 DO I = 1,NCOOR 4829 WRITE(LABELA,'(A5,I3)') '1DHAM',I 4830 DO J = 6,8 4831 IF (LABELA(J:J) .EQ. ' ') LABELA(J:J) = '0' 4832 ENDDO 4833 IGRA(I) = INDPRP_CC(LABELA) 4834 ENDDO 4835 IDIP(1) = INDPRP_CC('XDIPLEN ') 4836 IDIP(2) = INDPRP_CC('YDIPLEN ') 4837 IDIP(3) = INDPRP_CC('ZDIPLEN ') 4838 DO IDXB = 1,NDIP 4839 DO IDXA = 1,NCOOR 4840 IDX = NLROP + NCOOR*(IDXB - 1) + IDXA 4841 IALROP(IDX) = IGRA(IDXA) 4842 IBLROP(IDX) = IDIP(IDXB) 4843 LALORX(IDX) = .TRUE. ! Force orb. relax. for grad. 4844 LBLORX(IDX) = .TRUE. ! Force orb. relax. for dip. 4845 ENDDO 4846 ENDDO 4847 NLROP = NLROP + NTOT 4848 GO TO 100 4849C 4850C------------------------------------------------------ 4851C '.OR LEN': Optical Rotation - LENgth gauge. 4852C------------------------------------------------------ 4853C 485414 CONTINUE 4855 IF (.NOT. ORLEN) THEN 4856 ORLEN =.TRUE. 4857 CALL CC_LRINPREQ(LABDIP,LABANG,3,3,.TRUE.,LRELAX) 4858 ENDIF 4859 GO TO 100 4860C 4861C-------------------------------------------------------- 4862C '.OR VEL': Optical Rotation - VELocity gauge. 4863C-------------------------------------------------------- 4864C 486515 CONTINUE 4866 IF (.NOT. ORVEL) THEN 4867 ORVEL = .TRUE. 4868 CALL CC_LRINPREQ(LABDPV,LABANG,3,3,.TRUE.,LRELAX) 4869 ENDIF 4870 4871C---------------------------------------------------- 4872C '.OR ': same as '.OR MVE' + '.OR LEN'. 4873C---------------------------------------------------- 4874C 487516 CONTINUE 4876 IF (.NOT. ORMVE) THEN 4877 ORMVE = .TRUE. 4878 CALL CC_LRINPREQ(LABDPV,LABANG,3,3,.TRUE.,LRELAX) 4879 IF (.NOT. LOCSTAT) THEN 4880 IF (NBLRFR .GE. MBLRFR) THEN 4881 WRITE(LUPRI,'(2(/A,I5))') 4882 & ' NUMBER OF FREQUENCIES SPECIFIED : ',NBLRFR, 4883 & ' IS ALREADY EQUAL TO THE MAXIMUM ALLOWED : ',MBLRFR 4884 CALL QUIT('Request for .STATIC under .OR MVE ' 4885 & //'failed in CCLR.') 4886 ELSE 4887 LOCSTAT = .TRUE. 4888 NBLRFR = NBLRFR + 1 4889 BLRFR(NBLRFR) = 0.0D0 4890 END IF 4891 END IF 4892 END IF 4893 IF (.NOT. ORLEN) THEN 4894 ORLEN =.TRUE. 4895 CALL CC_LRINPREQ(LABDIP,LABANG,3,3,.TRUE.,LRELAX) 4896 ENDIF 4897 GO TO 100 4898C 4899C------------------------------------------------------------------- 4900C '.OR MVE': Opt. Rot., modified velocity gauge. 4901C I.e. correct for unphysical static component. 4902C------------------------------------------------------------------- 4903C 490417 CONTINUE 4905 IF (.NOT. ORMVE) THEN 4906 ORMVE = .TRUE. 4907 CALL CC_LRINPREQ(LABDPV,LABANG,3,3,.TRUE.,LRELAX) 4908 IF (.NOT. LOCSTAT) THEN 4909 IF (NBLRFR .GE. MBLRFR) THEN 4910 WRITE(LUPRI,'(2(/A,I5))') 4911 & ' NUMBER OF FREQUENCIES SPECIFIED : ',NBLRFR, 4912 & ' IS ALREADY EQUAL TO THE MAXIMUM ALLOWED : ',MBLRFR 4913 CALL QUIT('Request for .STATIC under .OR MVE ' 4914 & //'failed in CCLR.') 4915 ELSE 4916 LOCSTAT = .TRUE. 4917 NBLRFR = NBLRFR + 1 4918 BLRFR(NBLRFR) = 0.0D0 4919 END IF 4920 END IF 4921 END IF 4922 GO TO 100 4923C 4924C------------------------------------------------------------------------ 4925C '.ORGANL': Calculate OR LEN origin dependence (Delta-vector). 4926C------------------------------------------------------------------------ 4927C 492818 CONTINUE 4929 IF (.NOT. ORGANL) THEN 4930 ORGANL = .TRUE. 4931 CALL CC_LRINPREQ(LABDIP,LABDPV,3,3,.FALSE.,LRELAX) 4932 ENDIF 4933 GO TO 100 4934C 4935C------------------------------------------------------------------------ 4936C '.ORIGIN': Additional origins for evaluating OR length gauge. 4937C Implies '.ORGANL' and '.OR LEN'. 4938C------------------------------------------------------------------------ 4939C 494019 CONTINUE 4941 READ(LUCMD,*) NORGIN 4942 NORGSV = NORGIN 4943 IF (NORGIN .GT. MORGIN) THEN 4944 WRITE(LUPRI,'(3(/A,I5))') 4945 & ' NUMBER OF OR ORIGINS SPECIFIED : ',NORGIN, 4946 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MORGIN, 4947 & ' THE NUMBER IS RESET TO THE MAXIMUM : ',MORGIN 4948 NORGIN = MORGIN 4949 ENDIF 4950 DO J = 1,NORGIN 4951 READ(LUCMD,*) (ORGIN(I,J), I=1,3) 4952 ENDDO 4953 DO J = NORGIN+1,NORGSV 4954 READ(LUCMD,*) SCR1,SCR2,SCR3 4955 ENDDO 4956 IF (.NOT. ORGANL) THEN 4957 ORGANL = .TRUE. 4958 CALL CC_LRINPREQ(LABDIP,LABDPV,3,3,.FALSE.,LRELAX) 4959 ENDIF 4960 IF (.NOT. ORLEN) THEN 4961 ORLEN = .TRUE. 4962 CALL CC_LRINPREQ(LABDIP,LABANG,3,3,.TRUE.,LRELAX) 4963 ENDIF 4964 GO TO 100 4965C 4966C----------------------------------------------------------------------- 4967C '.WAVELE': Wavelengths in nm (instead of frequencies in au). 4968C----------------------------------------------------------------------- 4969C 497020 CONTINUE 4971 READ (LUCMD,*) NWAVEL 4972 NFTOT = NWAVEL + NBLRFR 4973 IF (NFTOT .GT. MBLRFR) THEN 4974 WRITE(LUPRI,'(3(/A,I5))') 4975 & ' NUMBER OF FREQUENCIES SPECIFIED : ',NFTOT, 4976 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MBLRFR, 4977 & ' THE NUMBER IS RESET TO THE MAXIMUM : ',MBLRFR 4978 NFTOT = MBLRFR 4979 NWAVEL = NFTOT - NBLRFR 4980 END IF 4981 READ (LUCMD,*) (BLRFR(NBLRFR+I),I=1,NWAVEL) 4982 DO I = 1,NWAVEL 4983 IF (DABS(BLRFR(NBLRFR+I)) .LE. 1.0D-7) THEN 4984 WRITE(LUPRI,'(/A,I5,A,1P,D22.15,A)') 4985 & 'Wavelength number',I,' too small: ', 4986 & BLRFR(NBLRFR+I),' nm' 4987 WRITE(LUPRI,'(A/)') 4988 & 'Input frequency (in au) instead (.FREQUE keyword).' 4989 CALL QUIT('Input wavelength too small in '//SECNAM) 4990 ENDIF 4991 XWAV = BLRFR(NBLRFR+I) 4992 BLRFR(NBLRFR+I) = XTNM/XWAV 4993 ENDDO 4994 NBLRFR = NBLRFR + NWAVEL 4995 GO TO 100 4996C 4997C--------------------------------------------------------- 4998C '.INCLRL': Include commutator terms in OR VEL. 4999C--------------------------------------------------------- 5000C 500121 CONTINUE 5002 call quit('.INCLRL not implemented in this version') 5003! INCLRL = .TRUE. 5004 GO TO 100 5005C 5006C--------------------------------------------------------- 5007C '.EXCLRL': Exclude commutator terms in OR VEL. 5008C--------------------------------------------------------- 5009C 501022 CONTINUE 5011 call quit('.EXCLRL not implemented in this version') 5012! EXCLRL = .TRUE. 5013 GO TO 100 5014C 5015C------------------------------------------- 5016C '.CTOSUS': CTOCD susceptibility. 5017C------------------------------------------- 5018C 501923 CONTINUE 5020 CTOSUS = .TRUE. 5021 GO TO 100 5022C 5023C-------------------------------------- 5024C '.CTOSHI': CTOCD shielding. 5025C-------------------------------------- 5026C 502724 CONTINUE 5028 CTOSHI = .TRUE. 5029 GO TO 100 5030C 5031C ------------------------------------------------- 5032C .XXXXXXX unused keywords 5033C ------------------------------------------------- 5034C 503525 CONTINUE 5036 GO TO 100 5037C 5038 ELSE 5039 WRITE (LUPRI,'(/5A/)') ' Prompt "',WORD, 5040 & '" not recognized in ',SECNAM,'.' 5041 CALL PRTAB(NTABLE,TABLE,SECNAM//' input keywords',LUPRI) 5042 CALL QUIT('Illegal Keyword in '//SECNAM//'.') 5043 END IF 5044 5045 ELSE IF (WORD(1:1) .NE. '*') THEN 5046 WRITE (LUPRI,'(/5A/)') 'PROMPT "',WORD, 5047 & '" NOT RECOGNIZED IN ',SECNAM,'.' 5048 CALL QUIT('Illegal prompt in '//SECNAM//'.') 5049 5050 ELSE IF (WORD(1:1) .EQ.'*') THEN 5051 BACKSPACE (LUCMD) 5052 GO TO 200 5053 END IF 5054 5055 END IF 5056 5057200 CONTINUE 5058C 5059C------------------------------------------------ 5060C Do some checking for Cholesky calculations: 5061C------------------------------------------------ 5062C 5063 IGNSUM = 0 5064 DO I = 1,4 5065 IGNSUM = IGNSUM + ABS(IGNCHO(I)) 5066 ENDDO 5067 IF (CHOINT .AND. (IGNSUM.NE.0)) THEN 5068 WRITE(LUPRI,*) 5069 WRITE(LUPRI,'(A,A)') 5070 & SECNAM, 5071 & ': WARNING: *CCLR options not implemented for Cholesky job:' 5072 IF (IGNCHO(1) .NE. 0) THEN 5073 WRITE(LUPRI,'(A)') 5074 & '.ASYMSD ignored (default 2n+2 expression will be used).' 5075 ENDIF 5076 IF (IGNCHO(2) .NE. 0) THEN 5077 WRITE(LUPRI,'(A)') 5078 & 'FATAL ERROR: No Cauchy for Cholesky job! (.DISPCF option)' 5079 ENDIF 5080 IF (IGNCHO(3) .NE. 0) THEN 5081 WRITE(LUPRI,'(A)') 5082 & '.OLD_LR ignored (default code will be used).' 5083 ENDIF 5084 IF (IGNCHO(4) .NE. 0) THEN 5085 WRITE(LUPRI,'(A)') 5086 & '.RELAXE ignored (unrelaxed properties will be calculated).' 5087 ENDIF 5088 WRITE(LUPRI,*) 5089 IF (IGNCHO(2) .NE. 0) CALL QUIT('Error in '//SECNAM) 5090 ENDIF 5091C 5092C-------------------------------------- 5093C Include operator pairs for CTOCD. 5094C-------------------------------------- 5095C 5096 CTOMAG = CTOSUS .OR. CTOSHI 5097 IF (CTOMAG) CALL CC_CTOMAG 5098C 5099C------------------------------------------------------------ 5100C Check if commutator terms are to be included in OR VEL: 5101C------------------------------------------------------------ 5102C 5103! IF (EXCLRL) INCLRL = .FALSE. 5104C 5105C----------------------------------------------- 5106C check, if operators and frequencies specified: 5107C----------------------------------------------- 5108C 5109 IF (NBLRFR.EQ.0 .AND. (.NOT.CAUCHY)) THEN 5110 NBLRFR = 1 5111 BLRFR(1) = 0.0D0 5112 ENDIF 5113C 5114 IF (ICHANG .NE. 0) THEN 5115 IF (NLROP .EQ.0) WRITE(LUPRI,'(/A)') 5116 & '(*CCLR input ignored, because no operators requested.)' 5117 END IF 5118C 5119C---------------------------- 5120C Make wa frequency list. 5121C---------------------------- 5122 DO IFREQ = 1, NBLRFR 5123 ALRFR(IFREQ) = - BLRFR(IFREQ) 5124 END DO 5125C 5126C------------------------------------------------------------------- 5127C Finally if we are to solve for anything at all, put CCLR true. 5128C------------------------------------------------------------------- 5129C 5130 CCLR = (NLROP.GT.0) 5131 IF (CCLR) RSPIM = .TRUE. 5132C 5133 RETURN 5134 END 5135*---------------------------------------------------------------------* 5136C /* Deck cc_lrinpreq */ 5137 SUBROUTINE CC_LRINPREQ(LABELA,LABELB,NA,NB,LDIAGO,LRELAX) 5138C 5139C Thomas Bondo Pedersen, April 2003. 5140C 5141C Purpose: Request linear response calculation of the tensor 5142C <<LABELA(i),LABELB(j)>> for i = 1,NA and j=1,NB. 5143C 5144C If LDIAGO: request diagonal only (NA=NB only!). 5145C 5146C LRELAX is the flag that will be associated with 5147C each perturbation operator for relaxation. 5148C 5149#include "implicit.h" 5150 CHARACTER*8 LABELA(NA), LABELB(NB) 5151 LOGICAL LDIAGO, LRELAX 5152#include "cclrinf.h" 5153#include "priunit.h" 5154 5155 CHARACTER*11 SECNAM 5156 PARAMETER (SECNAM = 'CC_LRINPREQ') 5157 5158 INTEGER IOPA(MXLROP), IOPB(MXLROP) 5159 5160 IF ((NA.GT.MXLROP) .OR. (NB.GT.MXLROP)) THEN 5161 WRITE(LUPRI,'(//A,A,A)') 5162 & ' Too many operators in ',SECNAM,':' 5163 WRITE(LUPRI,'(A,I10/A,I10)') 5164 & ' NA =',NA,' NB =',NB 5165 CALL QUIT('Too many operators in '//SECNAM) 5166 ELSE IF ((NA.LE.0) .OR. (NB.LE.0)) THEN 5167 RETURN 5168 ENDIF 5169 5170 IF (LDIAGO) THEN 5171 5172 IF (NA .NE. NB) THEN 5173 WRITE(LUPRI,'(//A,A,A/A,I10/A,I10/A)') 5174 & ' Error in ',SECNAM,':', 5175 & ' NA =',NA,' NB =',NB, 5176 & ' NA = NB must hold for LDIAGO option.' 5177 CALL QUIT('NA != NB in '//SECNAM) 5178 ENDIF 5179 5180 IF (NLROP+NA .GT. MXLROP) THEN 5181 WRITE(LUPRI,'(2(/A,I5))') 5182 & ' NO. OF OPERATOR DOUBLES SPECIFIED : ',NLROP+NA, 5183 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXLROP 5184 CALL QUIT('TOO MANY OPERATOR DOUBLES IN '//SECNAM) 5185 ENDIF 5186 5187 DO I = 1,NA 5188 IOPA(I) = INDPRP_CC(LABELA(I)) 5189 IOPB(I) = INDPRP_CC(LABELB(I)) 5190 ENDDO 5191 5192 DO IDXAB = 1,NA 5193 IDX = NLROP + IDXAB 5194 IALROP(IDX) = IOPA(IDXAB) 5195 IBLROP(IDX) = IOPB(IDXAB) 5196 LALORX(IDX) = LRELAX 5197 LBLORX(IDX) = LRELAX 5198 ENDDO 5199 5200 NLROP = NLROP + NA 5201 5202 ELSE 5203 5204 NTOT = NA*NB 5205 5206 IF (NLROP+NTOT .GT. MXLROP) THEN 5207 WRITE(LUPRI,'(2(/A,I5))') 5208 & ' NO. OF OPERATOR DOUBLES SPECIFIED : ',NLROP+NTOT, 5209 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXLROP 5210 CALL QUIT('TOO MANY OPERATOR DOUBLES IN '//SECNAM) 5211 ENDIF 5212 5213 DO I = 1,NA 5214 IOPA(I) = INDPRP_CC(LABELA(I)) 5215 ENDDO 5216 DO I = 1,NB 5217 IOPB(I) = INDPRP_CC(LABELB(I)) 5218 ENDDO 5219 5220 DO IDXA=1,NA 5221 DO IDXB=1,NB 5222 IDX = NLROP + (IDXA - 1)*NB + IDXB 5223 IALROP(IDX) = IOPA(IDXA) 5224 IBLROP(IDX) = IOPB(IDXB) 5225 LALORX(IDX) = LRELAX 5226 LBLORX(IDX) = LRELAX 5227 ENDDO 5228 ENDDO 5229 5230 NLROP = NLROP + NTOT 5231 5232 ENDIF 5233 5234 RETURN 5235 END 5236c /* deck cc_qrinp */ 5237*=====================================================================* 5238 SUBROUTINE CC_QRINP(WORD) 5239*---------------------------------------------------------------------* 5240* 5241* Purpose: read input for CC dynamic first hyperpolarizabilities 5242* and dispersion coefficients 5243* 5244* if (WORD .eq '*CCQR ') read & process input and set defaults, 5245* else set only defaults 5246* 5247* Written by Christof Haettig, October 1996, modified December '96 5248* dispersion coefficients, October 1997 (Christof Haettig) 5249* 5250*=====================================================================* 5251#if defined (IMPLICIT_NONE) 5252 IMPLICIT NONE 5253#else 5254#include "implicit.h" 5255#endif 5256#include "priunit.h" 5257#include "ccsdinp.h" 5258#include "ccsections.h" 5259#include "ccqrinf.h" 5260 5261* local parameters: 5262 CHARACTER MSGDBG*(18) 5263 PARAMETER (MSGDBG='[debug] CC_QRINP> ') 5264 CHARACTER SECNAM*(8) 5265 PARAMETER (SECNAM='CC_QRINP') 5266 5267 INTEGER NTABLE 5268 PARAMETER (NTABLE = 20) 5269 5270#if defined (SYS_CRAY) 5271 REAL ZERO 5272#else 5273 DOUBLE PRECISION ZERO 5274#endif 5275 PARAMETER (ZERO = 0.0d00) 5276 5277 5278* variables: 5279 LOGICAL SET 5280 SAVE SET 5281 5282 CHARACTER WORD*(7), LINE*(80) 5283 CHARACTER*8 LABELA, LABELB, LABELC 5284 CHARACTER TABLE(NTABLE)*(7) 5285 5286 LOGICAL LALRX, LBLRX, LCLRX, LRELAX 5287 INTEGER IDX, IJUMP, K, M, N 5288 INTEGER MFREQ 5289 INTEGER IFREQ, ICA, ICB, ICC, IDXA, IDXB, IDXC, IDIP(3) 5290 5291 DATA SET /.FALSE./ 5292 5293 DATA TABLE /'.OPERAT','.DIPOLE','.PRINT ','.EXPCOF','.AVERAG', 5294 & '.MIXFRE','.SHGFRE','.ORFREQ','.EOPEFR','.STATIC', 5295 & '.DISPCF','.ALLDSP','.XYDEGE','.NOBMAT','.USE R2', 5296 & '.RELAXE','.UNRELA','.USE AA','.AVANEW','.XXXXXX' / 5297 5298 INTEGER INDPRP_CC 5299 5300*---------------------------------------------------------------------* 5301* begin: 5302*---------------------------------------------------------------------* 5303 IF (SET) RETURN 5304 SET = .TRUE. 5305 5306*---------------------------------------------------------------------* 5307* initializations & defaults: 5308*---------------------------------------------------------------------* 5309 5310 NQROPER = 0 5311 NQRFREQ = 0 5312 NQRDISP = 0 5313 NQRDSPE = 0 5314 NQRDSPO = 0 5315 5316 CCQR = .FALSE. 5317 BETA_AVERAGE = .FALSE. 5318 XY_DEGENERAT = .FALSE. 5319 USEBTRAN = .TRUE. 5320 USE_R2 = .FALSE. 5321 USE_AAMAT = .FALSE. 5322 ALLDSPCF = .FALSE. 5323 LALRX = .FALSE. 5324 LBLRX = .FALSE. 5325 LCLRX = .FALSE. 5326 LRELAX = .FALSE. 5327 LAVANEW = .FALSE. 5328 5329 IPRQHYP = 0 5330 5331 ICHANG = 0 5332 5333C filip, 21.10.2013: 5334C Currently CC3 is not working without the .NOBMAT option, 5335C because the B-matrix transformation is going through the 5336C F-matrix routines (for the triples part), hence: 5337 IF (CC3) THEN 5338 USEBTRAN = .FALSE. 5339 WRITE(LUPRI,*)'CC_QRINP: USEBTRAN set to false for CC3' 5340 ENDIF 5341C 5342*---------------------------------------------------------------------* 5343* read input: 5344*---------------------------------------------------------------------* 5345 IF (WORD(1:7) .EQ. '*CCQR ') THEN 5346 5347100 CONTINUE 5348 5349* get new input line: 5350 READ (LUCMD,'(A7)') WORD 5351 CALL UPCASE(WORD) 5352 DO WHILE ( WORD(1:1) .EQ. '!' .OR. WORD(1:1) .EQ. '#' ) 5353 READ (LUCMD,'(A7)') WORD 5354 CALL UPCASE(WORD) 5355 END DO 5356 5357 IF (WORD(1:1) .EQ. '.') THEN 5358C WRITE (LUPRI,*) WORD 5359C CALL FLSHFO(LUPRI) 5360 5361c table look up: 5362 IJUMP = 1 5363 DO WHILE ( IJUMP .LE. NTABLE .AND. TABLE(IJUMP) .NE. WORD) 5364 IJUMP = IJUMP + 1 5365 END DO 5366 5367c jump to the appropriate input section: 5368 IF (IJUMP .LE. NTABLE) THEN 5369 ICHANG = ICHANG + 1 5370 GOTO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20), 5371 & IJUMP 5372 CALL QUIT('Illegal address in computed GOTO in CC_QRINP.') 5373 5374C ------------------------------------------ 5375C .OPERAT : triples of operator lables A,B,C 5376C ------------------------------------------ 53771 CONTINUE 5378 READ (LUCMD,'(3A)') LABELA, LABELB, LABELC 5379 DO WHILE (LABELA(1:1).NE.'.' .AND. LABELA(1:1).NE.'*') 5380 IF (LABELA(1:1).EQ.'!') THEN 5381 CONTINUE 5382 ELSE IF (LABELA(1:1).EQ.'(') THEN 5383 LALRX = .FALSE. 5384 LBLRX = .FALSE. 5385 LCLRX = .FALSE. 5386 IF (LABELA(1:7).EQ.'(RELAX)') LALRX = .TRUE. 5387 IF (LABELB(1:7).EQ.'(RELAX)') LBLRX = .TRUE. 5388 IF (LABELC(1:7).EQ.'(RELAX)') LCLRX = .TRUE. 5389 IF (LALRX .OR. LBLRX .OR. LCLRX) THEN 5390 KEEPAOTWO = MAX(KEEPAOTWO,1) 5391 END IF 5392 ELSE 5393 IF (NQROPER.LT.MXQROP) THEN 5394 NQROPER = NQROPER + 1 5395 IAQROP(NQROPER) = INDPRP_CC(LABELA) 5396 IBQROP(NQROPER) = INDPRP_CC(LABELB) 5397 ICQROP(NQROPER) = INDPRP_CC(LABELC) 5398 LAQLRX(NQROPER) = LALRX 5399 LBQLRX(NQROPER) = LBLRX 5400 LCQLRX(NQROPER) = LCLRX 5401 ELSE 5402 WRITE(LUPRI,'(/2A,I5)') 5403 & ' NO. OF OPERATOR TRIPLES SPECIFIED', 5404 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXQROP 5405 CALL QUIT('TOO MANY OPERATOR TRIPLES IN CCQR.') 5406 END IF 5407 END IF 5408 READ (LUCMD,'(3A)') LABELA, LABELB, LABELC 5409 END DO 5410 BACKSPACE(LUCMD) 5411 GO TO 100 5412 5413C ------------------------------------------------------- 5414C .DIPOL : calculate complete dipole-dipole-dipole tensor 5415C ------------------------------------------------------- 54162 CONTINUE 5417 IF (NQROPER+27 .GT. MXQROP) THEN 5418 WRITE(LUPRI,'(2(/A,I5))') 5419 & ' NO. OF OPERATOR TRIPLES SPECIFIED : ',NQROPER+27, 5420 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXQROP 5421 CALL QUIT('TOO MANY OPERATOR TRIPLES IN CCQR.') 5422 END IF 5423 IDIP(1) = INDPRP_CC('XDIPLEN ') 5424 IDIP(2) = INDPRP_CC('YDIPLEN ') 5425 IDIP(3) = INDPRP_CC('ZDIPLEN ') 5426 DO IDXA=1,3 5427 DO IDXB=1,3 5428 DO IDXC=1,3 5429 IDX = NQROPER + (IDXA-1)*9+(IDXB-1)*3+IDXC 5430 IAQROP(IDX) = IDIP(IDXA) 5431 IBQROP(IDX) = IDIP(IDXB) 5432 ICQROP(IDX) = IDIP(IDXC) 5433 LAQLRX(IDX) = LRELAX 5434 LBQLRX(IDX) = LRELAX 5435 LCQLRX(IDX) = LRELAX 5436 END DO 5437 END DO 5438 END DO 5439 NQROPER = NQROPER + 27 5440 GO TO 100 5441 5442C ------------ 5443C .PRINT 5444C ------------ 54453 CONTINUE 5446 READ (LUCMD,*) IPRQHYP 5447 GO TO 100 5448 5449C ----------------------------------------------------------- 5450C .EXPCOF : coefficients for the expansion of 5451C <<A;B,C>>_{w_B,w_C} in the frequenies w_B and w_C 5452C ----------------------------------------------------------- 54534 CONTINUE 5454 READ (LUCMD,'(A)') LINE 5455 DO WHILE (LINE(1:1).NE.'.' .AND. LINE(1:1).NE.'*') 5456 IF (LINE(1:1).NE.'!') THEN 5457 IF (NQRDISP.LT.MXQRDISP) THEN 5458 READ(LINE,*) ICA, ICB, ICC 5459 IF (ICA.LT.0 .OR. ICB.LT.0 .OR. ICC.LT.0) THEN 5460 NWARN = NWARN + 1 5461 WRITE(LUPRI,'(/2A/A)') 5462 & '@ WARNING: NEGATIVE EXPANSION COEFFICIENTS NOT', 5463 & ' AVAILABLE FOR FIRST HYPERPOLARIZABILITIES.', 5464 & '@ WARNING: INPUT LINE IGNORED...' 5465 ELSE 5466 NQRDISP = NQRDISP + 1 5467 IQCAUA(NQRDISP) = ICA 5468 IQCAUB(NQRDISP) = ICB 5469 IQCAUC(NQRDISP) = ICC 5470 END IF 5471 ELSE 5472 WRITE(LUPRI,'(/2A,I5)') 5473 & ' NO. OF EXPANSION COEFFICIENTS ', 5474 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXQRDISP 5475 CALL QUIT('TOO MANY EXPANSION COEFFICIENTS IN CCQR') 5476 END IF 5477 END IF 5478 READ (LUCMD,'(A)') LINE 5479 END DO 5480 BACKSPACE(LUCMD) 5481 GO TO 100 5482 5483C ------------------------------------------------------- 5484C .AVERAG : calculate averaged tensor components 5485C implemented: beta_{||}, beta_{_|_}, beta_{ms} 5486C ------------------------------------------------------- 54875 CONTINUE 5488 READ (LUCMD,'(A)') LINE 5489 IF (LINE(1:8).EQ.'HYPERPOL') THEN 5490 IF (NQROPER.NE.0) THEN 5491 NWARN = NWARN + 1 5492 WRITE(LUPRI,'(/2A/A/)') 5493 & '@ WARNING: INPUT FOR .DIPOL OR .OPERATOR OPTIONS', 5494 & ' BEFORE THE .AVERAG OPTION', 5495 & '@ IN *CCQR SECTION WILL BE IGNORED.' 5496 NQROPER = 0 5497 END IF 5498 IDIP(1) = INDPRP_CC('XDIPLEN ') 5499 IDIP(2) = INDPRP_CC('YDIPLEN ') 5500 IDIP(3) = INDPRP_CC('ZDIPLEN ') 5501 DO IDX=1,2 5502 IAQROP(1) = IDIP(3) ! component 1: beta_{zzz} 5503 IBQROP(1) = IDIP(3) 5504 ICQROP(1) = IDIP(3) 5505 LAQLRX(1) = LRELAX 5506 LBQLRX(1) = LRELAX 5507 LCQLRX(1) = LRELAX 5508 5509 IAQROP(2+(IDX-1)*3) = IDIP(3) ! comp. 2: beta_{zxx} 5510 IBQROP(2+(IDX-1)*3) = IDIP(IDX) ! comp. 5: beta_{zyy} 5511 ICQROP(2+(IDX-1)*3) = IDIP(IDX) 5512 LAQLRX(2+(IDX-1)*3) = LRELAX 5513 LBQLRX(2+(IDX-1)*3) = LRELAX 5514 LCQLRX(2+(IDX-1)*3) = LRELAX 5515 5516 IAQROP(3+(IDX-1)*3) = IDIP(IDX) ! comp. 3: beta_{xzx} 5517 IBQROP(3+(IDX-1)*3) = IDIP(3) ! comp. 6: beta_{yzy} 5518 ICQROP(3+(IDX-1)*3) = IDIP(IDX) 5519 LAQLRX(3+(IDX-1)*3) = LRELAX 5520 LBQLRX(3+(IDX-1)*3) = LRELAX 5521 LCQLRX(3+(IDX-1)*3) = LRELAX 5522 5523 IAQROP(4+(IDX-1)*3) = IDIP(IDX) ! comp. 4: beta_{xxz} 5524 IBQROP(4+(IDX-1)*3) = IDIP(IDX) ! comp. 7: beta_{yyz} 5525 ICQROP(4+(IDX-1)*3) = IDIP(3) 5526 LAQLRX(4+(IDX-1)*3) = LRELAX 5527 LBQLRX(4+(IDX-1)*3) = LRELAX 5528 LCQLRX(4+(IDX-1)*3) = LRELAX 5529 END DO 5530 NQROPER = 7 5531 BETA_AVERAGE = .TRUE. 5532 IF (XY_DEGENERAT) THEN 5533 ! forget beta_{zyy}, beta_{yzy}, beta_{yyz} 5534 NQROPER = 4 5535 END IF 5536 ELSE 5537 NWARN = NWARN + 1 5538 WRITE(LUPRI,'(/4A/A/)') '@ WARNING: Label "', 5539 & LINE(1:8),'" unknown for .AVERAG keyword', 5540 & 'in *CCQR section.','@ WARNING: INPUT IS IGNORED...' 5541 ENDIF 5542 GO TO 100 5543 5544 5545C --------------------------- 5546C .MIXFRE : mixed frequencies 5547C wb, wc, wa=-wb-wc 5548C --------------------------- 55496 CONTINUE 5550 READ (LUCMD,*) MFREQ 5551 IF (NQRFREQ+MFREQ .GT. MXQRFR) THEN 5552 NWARN = NWARN + 1 5553 WRITE(LUPRI,'(/A,3(/A,I5),/)') '@ WARNING:', 5554 & '@ NUMBER OF FREQUENCIES SPECIFIED : ',NQRFREQ+MFREQ, 5555 & '@ IS GREATER THAN THE ALLOWED NUMBER : ',MXQRFR, 5556 & '@ THE NUMBER IS RESET TO THE MAXIMUM : ',MXQRFR 5557 MFREQ = MXQRFR-NQRFREQ 5558 END IF 5559 READ (LUCMD,*) (BQRFR(IDX),IDX=NQRFREQ+1,NQRFREQ+MFREQ) 5560 READ (LUCMD,*) (CQRFR(IDX),IDX=NQRFREQ+1,NQRFREQ+MFREQ) 5561 NQRFREQ = NQRFREQ + MFREQ 5562 GO TO 100 5563 5564C ------------------------------------------------ 5565C .SHGFRE : second harmonic generation frequencies 5566C wb, wc = wb, wa = -2wb 5567C ------------------------------------------------ 55687 CONTINUE 5569 READ (LUCMD,*) MFREQ 5570 IF (NQRFREQ+MFREQ .GT. MXQRFR) THEN 5571 NWARN = NWARN + 1 5572 WRITE(LUPRI,'(/A,3(/A,I5),/)') '@ WARNING:', 5573 & '@ NUMBER OF FREQUENCIES SPECIFIED : ',NQRFREQ+MFREQ, 5574 & '@ IS GREATER THAN THE ALLOWED NUMBER : ',MXQRFR, 5575 & '@ THE NUMBER IS RESET TO THE MAXIMUM : ',MXQRFR 5576 MFREQ = MXQRFR-NQRFREQ 5577 END IF 5578 READ (LUCMD,*) (BQRFR(IDX),IDX=NQRFREQ+1,NQRFREQ+MFREQ) 5579 DO IDX = NQRFREQ+1, NQRFREQ+MFREQ 5580 CQRFR(IDX) = BQRFR(IDX) 5581 END DO 5582 NQRFREQ = NQRFREQ + MFREQ 5583 GO TO 100 5584 5585C ------------------------------------------------ 5586C .ORFREQ : optical rectification frequencies 5587C wb, wc = -wb, wa = 0 5588C ------------------------------------------------ 55898 CONTINUE 5590 READ (LUCMD,*) MFREQ 5591 IF (NQRFREQ+MFREQ .GT. MXQRFR) THEN 5592 NWARN = NWARN + 1 5593 WRITE(LUPRI,'(/A,3(/A,I5),/)') '@ WARNING:', 5594 & '@ NUMBER OF FREQUENCIES SPECIFIED : ',NQRFREQ+MFREQ, 5595 & '@ IS GREATER THAN THE ALLOWED NUMBER : ',MXQRFR, 5596 & '@ THE NUMBER IS RESET TO THE MAXIMUM : ',MXQRFR 5597 MFREQ = MXQRFR-NQRFREQ 5598 END IF 5599 READ (LUCMD,*) (BQRFR(IDX),IDX=NQRFREQ+1,NQRFREQ+MFREQ) 5600 DO IDX = NQRFREQ+1, NQRFREQ+MFREQ 5601 CQRFR(IDX) = -BQRFR(IDX) 5602 END DO 5603 NQRFREQ = NQRFREQ + MFREQ 5604 GO TO 100 5605 5606C ------------------------------------------------ 5607C .EOPEFR : second harmonic generation frequencies 5608C wb, wc = 0 , wa = -wb 5609C ------------------------------------------------ 56109 CONTINUE 5611 READ (LUCMD,*) MFREQ 5612 IF (NQRFREQ+MFREQ .GT. MXQRFR) THEN 5613 NWARN = NWARN + 1 5614 WRITE(LUPRI,'(/A,3(/A,I5),/)') '@ WARNING:', 5615 & '@ NUMBER OF FREQUENCIES SPECIFIED : ',NQRFREQ+MFREQ, 5616 & '@ IS GREATER THAN THE ALLOWED NUMBER : ',MXQRFR, 5617 & '@ THE NUMBER IS RESET TO THE MAXIMUM : ',MXQRFR 5618 MFREQ = MXQRFR-NQRFREQ 5619 END IF 5620 READ (LUCMD,*) (BQRFR(IDX),IDX=NQRFREQ+1,NQRFREQ+MFREQ) 5621 DO IDX = NQRFREQ+1, NQRFREQ+MFREQ 5622 CQRFR(IDX) = ZERO 5623 END DO 5624 NQRFREQ = NQRFREQ + MFREQ 5625 GO TO 100 5626 5627C --------------------------------------------------- 5628C .STATIC : add wb = wc = wa = zero to frequency list 5629C --------------------------------------------------- 563010 CONTINUE 5631 IF (NQRFREQ+1 .GT. MXQRFR) THEN 5632 NWARN = NWARN + 1 5633 WRITE(LUPRI,'(/A,3(/A,I5),/)') '@ WARNING:', 5634 & '@ NUMBER OF FREQUENCIES SPECIFIED : ',NQRFREQ+1, 5635 & '@ IS GREATER THAN THE ALLOWED NUMBER : ',MXQRFR, 5636 & '@ INPUT OPTION .STATIC WILL BE IGNORED.' 5637 ELSE 5638 NQRFREQ = NQRFREQ + 1 5639 BQRFR(NQRFREQ) = ZERO 5640 CQRFR(NQRFREQ) = ZERO 5641 END IF 5642 GO TO 100 5643 5644C --------------------------------- 5645C .DISPCF : dispersion coefficients 5646C --------------------------------- 564711 CONTINUE 5648 READ (LUCMD,*) NQRDSPE 5649 !WRITE (LUPRI,*) 'NQRDSPE = ',NQRDSPE 5650 IF (NQRDISP.NE.0) THEN 5651 NWARN = NWARN + 1 5652 WRITE(LUPRI,'(/2A)') 5653 & '@ WARNING: INPUT FOR .EXPCOF OPTION BEFORE .DISPCF', 5654 & ' IN *CCQR SECTION WILL BE IGNORED.' 5655 NQRDISP = 0 5656 END IF 5657 DO K = 0, NQRDSPE 5658 ! WRITE (LUPRI,*) 'NQRDSPE,K = ',NQRDSPE,K 5659 IF ((NQRDISP+(K+2)*(K+1)/2).LE.MXQRDISP) THEN 5660 DO M = 0, K, 1 5661 DO N = 0, M, 1 5662 NQRDISP = NQRDISP + 1 5663 IQCAUA(NQRDISP) = K-M 5664 IQCAUB(NQRDISP) = M-N 5665 IQCAUC(NQRDISP) = N 5666 END DO 5667 END DO 5668 ELSE 5669 NWARN = NWARN + 1 5670 WRITE(LUPRI,'(/A/2A,I5/)') '@ WARNING:', 5671 & '@ NO. OF DISPERSION COEFFICIENTS NEEDED', 5672 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXQRDISP 5673 WRITE(LUPRI,'(/A,I3,A)') 5674 & '@ DISPERSION COEFFICIENTS OF ORDER',K,' ARE IGNORED.' 5675 NQRDSPE = MIN(NQRDSPE,K-1) 5676 END IF 5677 END DO 5678 GO TO 100 5679 5680C -------------------------------------------------------- 5681C .ALLDSP : do not skip odd/even dispersion coefficients 5682C or real/imaginary properties 5683C -------------------------------------------------------- 568412 CONTINUE 5685 ALLDSPCF = .TRUE. 5686 GO TO 100 5687 5688C ---------------------------------------------- 5689C .XYDEGE : assume X and Y directions degenerate 5690C ---------------------------------------------- 569113 CONTINUE 5692 XY_DEGENERAT = .TRUE. 5693 IF ( BETA_AVERAGE .AND. NQROPER.EQ.7 ) THEN 5694 ! forget beta_{zyy}, beta_{yzy}, beta_{yyz} 5695 NQROPER = 4 5696 END IF 5697 GO TO 100 5698 5699C --------------------------------------------------------- 5700C .NOBMAT : don't use B matrix transformation but F matrix 5701C (usually less efficient, because less symmetry) 5702C --------------------------------------------------------- 570314 CONTINUE 5704 USEBTRAN = .FALSE. 5705 GO TO 100 5706 5707C ----------------------------------------------------------- 5708C .USE R2 : use second-order response/Cauchy vectors R2/CR2 5709C instead first-order left L1/LC vectors times 5710C B matrix transf. and eta vectors 5711C (test option, computational advantages only in 5712C very rare cases...) 5713C ----------------------------------------------------------- 571415 CONTINUE 5715 USEBTRAN = .FALSE. 5716 USE_R2 = .TRUE. 5717 GO TO 100 5718 5719C ---------------------------------------------------------- 5720C .RELAXE : switch to relaxed modus for all three operators: 5721C ---------------------------------------------------------- 572216 CONTINUE 5723 ! LRELAX = .TRUE. 5724 ! KEEPAOTWO = MAX(KEEPAOTWO,1) 5725 WRITE (LUPRI,*) 5726 * '.RELAXE keyword in *CCQR section is disabled.' 5727 GO TO 100 5728 5729C ------------------------------------------------------------ 5730C .UNRELA : switch to unrelaxed modus for all three operators: 5731C ------------------------------------------------------------ 573217 CONTINUE 5733 LRELAX = .FALSE. 5734 GO TO 100 5735 5736C ------------------------------------------------------------ 5737C .USE AA : Use A{O} transformation instead of Eta{O} vectors: 5738C ------------------------------------------------------------ 573918 CONTINUE 5740 USE_AAMAT = .TRUE. 5741 GO TO 100 5742C 5743C ------------------------------------------------------------ 5744C .AVANEW: Calculates: 5745C beta_i = 1/3 Sum_j=x,y,z [ B_ijj + B_jji + B_jij ] 5746C |beta_i*mu_i| for (i=x,y,z) (mu is the dipole moment) 5747C <beta>=1/6( B_xyz - B_xzy + B_yzx - B_yxz + B_zxy - B_zyx ) 5748C ------------------------------------------------------------ 574919 CONTINUE 5750 LAVANEW = .TRUE. 5751 GO TO 100 5752C ----------------------- 5753C .XXXXXX : unused labels 5754C ----------------------- 575520 CONTINUE 5756 WRITE (LUPRI,*) 'unused .XXXXXX label... ignored' 5757 GO TO 100 5758 5759 ELSE 5760 WRITE (LUPRI,'(/5A/)') ' Prompt "',WORD, 5761 & '" not recognized in ',SECNAM,'.' 5762 CALL PRTAB(NTABLE,TABLE,SECNAM//' input keywords',LUPRI) 5763 CALL QUIT('Illegal Keyword in '//SECNAM//'.') 5764 END IF 5765 5766 ELSE IF (WORD(1:1) .NE. '*') THEN 5767 WRITE (LUPRI,'(/5A/)') 'PROMPT "',WORD, 5768 & '" NOT RECOGNIZED IN ',SECNAM,'.' 5769 CALL QUIT('Illegal prompt in '//SECNAM//'.') 5770 5771 ELSE IF (WORD(1:1) .EQ.'*') THEN 5772 BACKSPACE (LUCMD) 5773 GO TO 200 5774 END IF 5775 5776 END IF 5777 5778200 CONTINUE 5779 5780*---------------------------------------------------------------------* 5781* check, if any triples of operator labels specified: 5782* if not, use default: complete dipole-dipole-dipole tensor 5783*---------------------------------------------------------------------* 5784 IF (NQROPER .EQ. 0) THEN 5785 IF (NQROPER+27 .GT. MXQROP) THEN 5786 WRITE(LUPRI,'(2(/A,I5))') 5787 & ' NO. OF OPERATOR TRIPLES SPECIFIED : ',NQROPER+27, 5788 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXQROP 5789 CALL QUIT('TOO MANY OPERATOR TRIPLES IN CCQR.') 5790 END IF 5791 IDIP(1) = INDPRP_CC('XDIPLEN ') 5792 IDIP(2) = INDPRP_CC('YDIPLEN ') 5793 IDIP(3) = INDPRP_CC('ZDIPLEN ') 5794 DO IDXA=1,3 5795 DO IDXB=1,3 5796 DO IDXC=1,3 5797 IDX = NQROPER + (IDXA-1)*9+(IDXB-1)*3+IDXC 5798 IAQROP(IDX) = IDIP(IDXA) 5799 IBQROP(IDX) = IDIP(IDXB) 5800 ICQROP(IDX) = IDIP(IDXC) 5801 END DO 5802 END DO 5803 END DO 5804 NQROPER = NQROPER + 27 5805 END IF 5806 5807*---------------------------------------------------------------------* 5808* check, if frequencies specified; if not, use default: static 5809*---------------------------------------------------------------------* 5810 IF (NQRFREQ .EQ. 0) THEN 5811 NQRFREQ = NQRFREQ + 1 5812 BQRFR(NQRFREQ) = ZERO 5813 CQRFR(NQRFREQ) = ZERO 5814 END IF 5815 5816*---------------------------------------------------------------------* 5817* add list with wa frequencies: 5818*---------------------------------------------------------------------* 5819 DO IFREQ = 1, NQRFREQ 5820 AQRFR(IFREQ) = - ( BQRFR(IFREQ) + CQRFR(IFREQ) ) 5821 END DO 5822 5823*---------------------------------------------------------------------* 5824* set CCQR flags: 5825*---------------------------------------------------------------------* 5826 CCQR = .TRUE. 5827 5828 RETURN 5829 END 5830*---------------------------------------------------------------------* 5831c /* deck cc_crinp */ 5832*=====================================================================* 5833 SUBROUTINE CC_CRINP(WORD) 5834*---------------------------------------------------------------------* 5835* 5836* Purpose: read input for CC dynamic second hyperpolarizabilities 5837* 5838* if (WORD .eq '*CCCR ') read & process input and set defaults, 5839* else set only defaults 5840* 5841* Written by Christof Haettig, October 1996, modified Februar '97 5842* 5843*=====================================================================* 5844#if defined (IMPLICIT_NONE) 5845 IMPLICIT NONE 5846#else 5847# include "implicit.h" 5848#endif 5849#include "priunit.h" 5850#include "ccsdinp.h" 5851#include "ccsections.h" 5852#include "cccrinf.h" 5853C#include "ccrspprp.h" 5854 5855* local parameters: 5856 CHARACTER MSGDBG*(18) 5857 PARAMETER (MSGDBG='[debug] CC_CRINP> ') 5858 CHARACTER SECNAM*(8) 5859 PARAMETER (SECNAM='CC_CRINP') 5860 5861 INTEGER NTABLE 5862 PARAMETER (NTABLE = 20) 5863 5864#if defined (SYS_CRAY) 5865 REAL ZERO 5866#else 5867 DOUBLE PRECISION ZERO 5868#endif 5869 PARAMETER (ZERO = 0.0d00) 5870 5871 5872* variables: 5873 LOGICAL SET 5874 SAVE SET 5875 5876 CHARACTER*(7) WORD 5877 CHARACTER*(80) LINE 5878 CHARACTER*(7) TABLE(NTABLE) 5879 CHARACTER*(8) LABELA, LABELB, LABELC, LABELD 5880 5881 INTEGER IDX, IJUMP, IFREQ, IDIP(3), IDXA, IDXB, IDXC, IDXD 5882 INTEGER MFREQ, K, L, M, N, ICAUA, ICAUB, ICAUC, ICAUD 5883 5884 DATA SET /.FALSE./ 5885 DATA TABLE /'.OPERAT','.DIPOLE','.PRINT ','.STATIC','.MIXFRE', 5886 & '.THGFRE','.ESHGFR','.DFWMFR','.DCKERR','.USECHI', 5887 & '.USEXKS','.EXPCOF','.AVERAG','.DISPCF','.ODDISP', 5888 & '.NO2NP1','.L2 BCD','.L2 BC ','.XXXXXX','.XXXXXX'/ 5889 5890 INTEGER INDPRP_CC 5891 5892*---------------------------------------------------------------------* 5893* begin: 5894*---------------------------------------------------------------------* 5895 IF (SET) RETURN 5896 SET = .TRUE. 5897 5898*---------------------------------------------------------------------* 5899* initializations & defaults: 5900*---------------------------------------------------------------------* 5901 NCROPER = 0 5902 NCRFREQ = 0 5903 NCRDISP = 0 5904 NCRDSPE = -1 5905 NCRDSPO = -1 5906 5907 CCCR = .FALSE. 5908 GAMMA_PAR = .FALSE. 5909 GAMMA_ORT = .FALSE. 5910 CSYM = 'GENERI' 5911 5912 L_USE_CHI2 = .FALSE. 5913 L_USE_XKS3 = .FALSE. 5914 NO_2NP1_RULE = .FALSE. 5915 USE_L2BC = .FALSE. 5916 USE_LBCD = .FALSE. 5917 5918 IPRCHYP = IPRINT 5919 5920*---------------------------------------------------------------------* 5921* read input: 5922*---------------------------------------------------------------------* 5923 IF (WORD(1:7) .EQ. '*CCCR ') THEN 5924 5925100 CONTINUE 5926 5927* get new input line: 5928 READ (LUCMD,'(A7)') WORD 5929 CALL UPCASE(WORD) 5930 DO WHILE ( WORD(1:1) .EQ. '!' .OR. WORD(1:1) .EQ. '#' ) 5931 READ (LUCMD,'(A7)') WORD 5932 CALL UPCASE(WORD) 5933 END DO 5934 5935 IF (WORD(1:1) .EQ. '.') THEN 5936 5937c table look up: 5938 IJUMP = 1 5939 DO WHILE ( IJUMP .LE. NTABLE .AND. TABLE(IJUMP) .NE. WORD) 5940 IJUMP = IJUMP + 1 5941 END DO 5942 5943c jump to the appropriate input section: 5944 IF (IJUMP .LE. NTABLE) THEN 5945 ICHANG = ICHANG + 1 5946 GOTO ( 1, 2, 3, 4, 5, 6, 7, 8, 9,10, 5947 & 11,12,13,14,15,16,17,18,19,20), IJUMP 5948 CALL QUIT('Illegal address in computed GOTO in CC_CRINP.') 5949 5950C ------------ 5951C .OPERAT 5952C ------------ 59531 CONTINUE 5954 READ (LUCMD,'(4A)') LABELA,LABELB,LABELC,LABELD 5955 DO WHILE (LABELA(1:1).NE.'.' .AND. LABELA(1:1).NE.'*') 5956 IF (LABELA(1:1).NE.'!') THEN 5957 IF (NCROPER.LT.MXCROP) THEN 5958 NCROPER = NCROPER + 1 5959 IACROP(NCROPER) = INDPRP_CC(LABELA) 5960 IBCROP(NCROPER) = INDPRP_CC(LABELB) 5961 ICCROP(NCROPER) = INDPRP_CC(LABELC) 5962 IDCROP(NCROPER) = INDPRP_CC(LABELD) 5963 ELSE 5964 WRITE(LUPRI,'(/2A,I5/)') 5965 & ' NO. OF OPERATOR QUADRUPLES SPECIFIED', 5966 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXCROP 5967 CALL QUIT('TOO MANY OPERATOR QUADRUPLES IN CCCR.') 5968 END IF 5969 END IF 5970 READ (LUCMD,'(4A)') LABELA,LABELB,LABELC,LABELD 5971 END DO 5972 BACKSPACE(LUCMD) 5973 GO TO 100 5974 5975C ------------------------------------------------------- 5976C .DIPOLE: calculate complete dipole-dipole-dipole-dipole 5977C ------------------------------------------------------- 59782 CONTINUE 5979 IF (NCROPER+81 .GT. MXCROP) THEN 5980 WRITE(LUPRI,'(/2A,I5/)') 5981 & ' NO. OF OPERATOR QUADRUPLES SPECIFIED', 5982 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXCROP 5983 CALL QUIT('TOO MANY OPERATOR QUADRUPLES IN CCCR.') 5984 END IF 5985 IDIP(1) = INDPRP_CC('XDIPLEN ') 5986 IDIP(2) = INDPRP_CC('YDIPLEN ') 5987 IDIP(3) = INDPRP_CC('ZDIPLEN ') 5988 DO IDXA=1,3 5989 DO IDXB=1,3 5990 DO IDXC=1,3 5991 DO IDXD=1,3 5992 IDX = NCROPER + (IDXA-1)*27+(IDXB-1)*9+(IDXC-1)*3+IDXD 5993 IACROP(IDX) = IDIP(IDXA) 5994 IBCROP(IDX) = IDIP(IDXB) 5995 ICCROP(IDX) = IDIP(IDXC) 5996 IDCROP(IDX) = IDIP(IDXD) 5997 END DO 5998 END DO 5999 END DO 6000 END DO 6001 NCROPER = NCROPER + 81 6002 GO TO 100 6003 6004C ------------ 6005C .PRINT 6006C ------------ 60073 CONTINUE 6008 READ (LUCMD,*) IPRCHYP 6009 GO TO 100 6010 6011C ------------ 6012C .STATIC 6013C ------------ 60144 CONTINUE 6015 IF (NCRFREQ+1 .GT. MXCRFR) THEN 6016 NWARN = NWARN + 1 6017 WRITE(LUPRI,'(/A,3(/A,I5)/)') '@ WARNING:', 6018 & '@ NUMBER OF FREQUENCIES SPECIFIED : ',NCRFREQ+1, 6019 & '@ IS GREATER THAN THE ALLOWED NUMBER : ',MXCRFR, 6020 & '@ INPUT OPTION .STATIC WILL BE IGNORED.' 6021 ELSE 6022 NCRFREQ = NCRFREQ + 1 6023 BCRFR(NCRFREQ) = ZERO 6024 CCRFR(NCRFREQ) = ZERO 6025 DCRFR(NCRFREQ) = ZERO 6026 END IF 6027 GO TO 100 6028 6029C ------------------------------------------------ 6030C .MIXFRE : mixed frequency input: 6031C read wb, wc, wd ---> wa = -wb-wc-wd 6032C ------------------------------------------------ 60335 CONTINUE 6034 READ (LUCMD,*) MFREQ 6035 IF (NCRFREQ+MFREQ .GT. MXCRFR) THEN 6036 NWARN = NWARN + 1 6037 WRITE(LUPRI,'(/A,3(/A,I5)/)') '@ WARNING:', 6038 & '@ NUMBER OF FREQUENCIES SPECIFIED : ',NCRFREQ+MFREQ, 6039 & '@ IS GREATER THAN THE ALLOWED NUMBER : ',MXCRFR, 6040 & '@ THE NUMBER IS RESET TO THE MAXIMUM : ',MXCRFR 6041 MFREQ = MXCRFR-NCRFREQ 6042 END IF 6043 READ (LUCMD,*) (BCRFR(IDX),IDX=NCRFREQ+1,NCRFREQ+MFREQ) 6044 READ (LUCMD,*) (CCRFR(IDX),IDX=NCRFREQ+1,NCRFREQ+MFREQ) 6045 READ (LUCMD,*) (DCRFR(IDX),IDX=NCRFREQ+1,NCRFREQ+MFREQ) 6046 NCRFREQ = NCRFREQ + MFREQ 6047 GO TO 100 6048 6049C ----------------------------------------------- 6050C .THGFRE : third harmonic generation frequencies 6051C read wb --> wc=wb, wd=wb, wa= -3wb 6052C ----------------------------------------------- 60536 CONTINUE 6054 READ (LUCMD,*) MFREQ 6055 IF (NCRFREQ+MFREQ .GT. MXCRFR) THEN 6056 NWARN = NWARN + 1 6057 WRITE(LUPRI,'(/A,3(/A,I5)/)') '@ WARNING:', 6058 & '@ NUMBER OF FREQUENCIES SPECIFIED : ',NCRFREQ+MFREQ, 6059 & '@ IS GREATER THAN THE ALLOWED NUMBER : ',MXCRFR, 6060 & '@ THE NUMBER IS RESET TO THE MAXIMUM : ',MXCRFR 6061 MFREQ = MXCRFR-NCRFREQ 6062 END IF 6063 READ (LUCMD,*) (BCRFR(IDX),IDX=NCRFREQ+1,NCRFREQ+MFREQ) 6064 DO IDX = NCRFREQ+1, NCRFREQ+MFREQ 6065 CCRFR(IDX) = BCRFR(IDX) 6066 DCRFR(IDX) = BCRFR(IDX) 6067 END DO 6068 NCRFREQ = NCRFREQ + MFREQ 6069 GO TO 100 6070 6071 6072C ----------------------------------------------------------- 6073C .ESHGFR : electric field induced second harmonic generation 6074C read wb --> wc=wb, wd=0, wa= -2wb 6075C ----------------------------------------------------------- 60767 CONTINUE 6077 READ (LUCMD,*) MFREQ 6078 IF (NCRFREQ+MFREQ .GT. MXCRFR) THEN 6079 NWARN = NWARN + 1 6080 WRITE(LUPRI,'(/A,3(/A,I5)/)') '@ WARNING:', 6081 & '@ NUMBER OF FREQUENCIES SPECIFIED : ',NCRFREQ+MFREQ, 6082 & '@ IS GREATER THAN THE ALLOWED NUMBER : ',MXCRFR, 6083 & '@ THE NUMBER IS RESET TO THE MAXIMUM : ',MXCRFR 6084 MFREQ = MXCRFR-NCRFREQ 6085 END IF 6086 READ (LUCMD,*) (BCRFR(IDX),IDX=NCRFREQ+1,NCRFREQ+MFREQ) 6087 DO IDX = NCRFREQ+1, NCRFREQ+MFREQ 6088 CCRFR(IDX) = BCRFR(IDX) 6089 DCRFR(IDX) = ZERO 6090 END DO 6091 NCRFREQ = NCRFREQ + MFREQ 6092 GO TO 100 6093 6094 6095C ----------------------------------------------------------- 6096C .DFWMFR : degenerate four wave mixing 6097C read wb --> wc=+wb, wd=-wb, wa= -wb 6098C ----------------------------------------------------------- 60998 CONTINUE 6100 READ (LUCMD,*) MFREQ 6101 IF (NCRFREQ+MFREQ .GT. MXCRFR) THEN 6102 NWARN = NWARN + 1 6103 WRITE(LUPRI,'(/A,3(/A,I5)/)') '@ WARNING:', 6104 & '@ NUMBER OF FREQUENCIES SPECIFIED : ',NCRFREQ+MFREQ, 6105 & '@ IS GREATER THAN THE ALLOWED NUMBER : ',MXCRFR, 6106 & '@ THE NUMBER IS RESET TO THE MAXIMUM : ',MXCRFR 6107 MFREQ = MXCRFR-NCRFREQ 6108 END IF 6109 READ (LUCMD,*) (BCRFR(IDX),IDX=NCRFREQ+1,NCRFREQ+MFREQ) 6110 DO IDX = NCRFREQ+1, NCRFREQ+MFREQ 6111 CCRFR(IDX) = +BCRFR(IDX) 6112 DCRFR(IDX) = -BCRFR(IDX) 6113 END DO 6114 NCRFREQ = NCRFREQ + MFREQ 6115 GO TO 100 6116 6117C ----------------------------------------------------------- 6118C .DCKERR : dc Kerr effect, also optical Kerr effect (OKE) 6119C read wd --> wc=wd=0, wa= -wd 6120C ----------------------------------------------------------- 61219 CONTINUE 6122 READ (LUCMD,*) MFREQ 6123 IF (NCRFREQ+MFREQ .GT. MXCRFR) THEN 6124 NWARN = NWARN + 1 6125 WRITE(LUPRI,'(/A,3(/A,I5)/)') '@ WARNING:', 6126 & '@ NUMBER OF FREQUENCIES SPECIFIED : ',NCRFREQ+MFREQ, 6127 & '@ IS GREATER THAN THE ALLOWED NUMBER : ',MXCRFR, 6128 & '@ THE NUMBER IS RESET TO THE MAXIMUM : ',MXCRFR 6129 MFREQ = MXCRFR-NCRFREQ 6130 END IF 6131 READ (LUCMD,*) (DCRFR(IDX),IDX=NCRFREQ+1,NCRFREQ+MFREQ) 6132 DO IDX = NCRFREQ+1, NCRFREQ+MFREQ 6133 BCRFR(IDX) = ZERO 6134 CCRFR(IDX) = ZERO 6135 END DO 6136 NCRFREQ = NCRFREQ + MFREQ 6137 GO TO 100 6138 6139 6140C ------------------------------------------------------- 6141C .USECHI : use second-order chi vectors as intermediates 6142C (test option) 6143C ------------------------------------------------------- 614410 CONTINUE 6145 L_USE_CHI2 = .TRUE. 6146 IF (L_USE_XKS3) THEN 6147 L_USE_XKS3 = .FALSE. 6148 WRITE(LUPRI,*) '.USECHI and .USEXKS are incompatible' 6149 WRITE(LUPRI,*) 'in the *CCCR section...' 6150 WRITE(LUPRI,*) '.USEXKS is switched off' 6151 END IF 6152 IF (USE_LBCD) THEN 6153 USE_LBCD = .FALSE. 6154 WRITE(LUPRI,*) '.L2 BCD and .USECHI are incompatible' 6155 WRITE(LUPRI,*) 'in the *CCCR section...' 6156 WRITE(LUPRI,*) '.L2 BCD is switched off' 6157 END IF 6158 IF (USE_L2BC) THEN 6159 USE_L2BC = .FALSE. 6160 WRITE(LUPRI,*) '.L2 BC and .USECHI are incompatible' 6161 WRITE(LUPRI,*) 'in the *CCCR section...' 6162 WRITE(LUPRI,*) '.L2 BC is switched off' 6163 END IF 6164 GO TO 100 6165 6166C ------------------------------------------------------- 6167C .USEXKS : use third-order xksi vectors as intermediates 6168C (test option) 6169C ------------------------------------------------------- 617011 CONTINUE 6171 L_USE_XKS3 = .TRUE. 6172 IF (L_USE_CHI2) THEN 6173 L_USE_CHI2 = .FALSE. 6174 WRITE(LUPRI,*) '.USECHI and .USEXKS are incompatible' 6175 WRITE(LUPRI,*) 'in the *CCCR section...' 6176 WRITE(LUPRI,*) '.USECHI is switched off' 6177 END IF 6178 IF (USE_LBCD) THEN 6179 USE_LBCD = .FALSE. 6180 WRITE(LUPRI,*) '.L2 BCD and .USEXKS are incompatible' 6181 WRITE(LUPRI,*) 'in the *CCCR section...' 6182 WRITE(LUPRI,*) '.L2 BCD is switched off' 6183 END IF 6184 IF (USE_L2BC) THEN 6185 USE_L2BC = .FALSE. 6186 WRITE(LUPRI,*) '.L2 BC and .USEXKS are incompatible' 6187 WRITE(LUPRI,*) 'in the *CCCR section...' 6188 WRITE(LUPRI,*) '.L2 BC is switched off' 6189 END IF 6190 GO TO 100 6191 6192C ----------------------------------------------------------- 6193C .EXPCOF : coefficients for the expansion of 6194C <<A;B,C,D>>_{w_B,w_C,w_D} in the frequenies w_B, w_C, w_D 6195C ----------------------------------------------------------- 619612 CONTINUE 6197 READ (LUCMD,'(A)') LINE 6198 DO WHILE (LINE(1:1).NE.'.' .AND. LINE(1:1).NE.'*') 6199 IF (LINE(1:1).NE.'!') THEN 6200 IF (NCRDISP.LT.MXCRDISP) THEN 6201 READ(LINE,*) ICAUA, ICAUB, ICAUC, ICAUD 6202 IF (ICAUA.LT.0 .OR. ICAUB.LT.0 .OR. 6203 & ICAUC.LT.0 .OR. ICAUD.LT.0 ) THEN 6204 NWARN = NWARN + 1 6205 WRITE(LUPRI,'(/A/2A,/A)') '@ WARNING:', 6206 & '@ NEGATIVE EXPANSION COEFFICIENTS NOT', 6207 & ' AVAILABLE FOR SECOND HYPERPOLARIZABILITIES.', 6208 & '@ INPUT LINE IGNORED...' 6209 ELSE 6210 NCRDISP = NCRDISP + 1 6211 ICCAUA(NCRDISP) = ICAUA 6212 ICCAUB(NCRDISP) = ICAUB 6213 ICCAUC(NCRDISP) = ICAUC 6214 ICCAUD(NCRDISP) = ICAUD 6215 END IF 6216 ELSE 6217 WRITE(LUPRI,'(/2A,I5)') 6218 & ' NO. OF EXPANSION COEFFICIENTS ', 6219 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXCRDISP 6220 CALL QUIT('TOO MANY EXPANSION COEFFICIENTS IN CCCR') 6221 END IF 6222 END IF 6223 READ (LUCMD,'(A)') LINE 6224 END DO 6225 BACKSPACE(LUCMD) 6226 GO TO 100 6227 6228 6229C ------------------------------------------------ 6230C .AVERAG : calculate averaged tensor components 6231C ------------------------------------------------ 623213 CONTINUE 6233 6234* first line: type of property: 6235 READ (LUCMD,'(A)') LINE 6236 6237 IF (LINE(1:9).EQ.'GAMMA_PAR') THEN 6238 GAMMA_PAR = .TRUE. 6239 ELSE IF (LINE(1:9).EQ.'GAMMA_ISO') THEN 6240 GAMMA_PAR = .TRUE. 6241 GAMMA_ORT = .TRUE. 6242 END IF 6243 6244 IF (GAMMA_PAR .OR. GAMMA_ORT) THEN 6245 6246* second line: symmetry: 6247 READ (LUCMD,'(A)') LINE 6248 CSYM = 'GENERI' 6249 IF (LINE(1:6).EQ.'ATOMIC') THEN 6250 CSYM = 'ATOMIC' ! an atom 6251 ELSE IF (LINE(1:6).EQ.'SPHTOP') THEN 6252 CSYM = 'SPHTOP' ! spherical top 6253 ELSE IF (LINE(1:6).EQ.'LINEAR') THEN 6254 CSYM = 'LINEAR' ! linear molecule 6255 ELSE IF (LINE(1:5).EQ.'GENER') THEN 6256 CSYM = 'GENERI' ! use generic point group symmetry 6257 ELSE 6258 WRITE (LUPRI,*) 6259 & 'WARNING: unknown symmetry input in *CCCR:' 6260 WRITE (LUPRI,*) LINE 6261 WRITE (LUPRI,*)'WARNING: input line ignored...' 6262 END IF 6263 6264 IF (NCROPER.NE.0) THEN 6265 NWARN = NWARN + 1 6266 WRITE(LUPRI,'(/2A/A/)') 6267 & '@ WARNING: INPUT FOR .DIPOL OR .OPERATOR OPTIONS', 6268 & ' BEFORE THE .AVERAG OPTION', 6269 & '@ IN *CCCR SECTION WILL BE IGNORED.' 6270 NCROPER = 0 6271 END IF 6272 6273* set operators quadruples for gamma components: 6274 IDIP(1) = INDPRP_CC('XDIPLEN ') 6275 IDIP(2) = INDPRP_CC('YDIPLEN ') 6276 IDIP(3) = INDPRP_CC('ZDIPLEN ') 6277 DO IDX=1,3 6278 IF (IDX.EQ.1) THEN 6279 IDXA = 1 ! X \ XXZZ 6280 IDXB = 3 ! Z / + permutations 6281 IDXC = 3 ! Z - ZZZZ 6282 ELSE IF (IDX.EQ.2) THEN 6283 IDXA = 2 ! Y \ YYZZ 6284 IDXB = 3 ! Z / + permutations 6285 IDXC = 1 ! X - XXXX 6286 ELSE IF (IDX.EQ.3) THEN 6287 IDXA = 1 ! X \ XXYY 6288 IDXB = 2 ! Y / + permutations 6289 IDXC = 2 ! Y - YYYY 6290 ELSE 6291 CALL QUIT('Error in CC_CRINP.') 6292 END IF 6293 6294* note that the order is very important! 6295 IACROP(1+(IDX-1)*7) = IDIP(IDXC) ! 1.: gamma_{zzzz} 6296 IBCROP(1+(IDX-1)*7) = IDIP(IDXC) ! 8.: gamma_{xxxx} 6297 ICCROP(1+(IDX-1)*7) = IDIP(IDXC) ! 15.: gamma_{yyyy} 6298 IDCROP(1+(IDX-1)*7) = IDIP(IDXC) 6299 6300 IACROP(2+(IDX-1)*7) = IDIP(IDXB) ! 2.: gamma_{zxxz} 6301 IBCROP(2+(IDX-1)*7) = IDIP(IDXA) ! 9.: gamma_{zyyz} 6302 ICCROP(2+(IDX-1)*7) = IDIP(IDXA) ! 16.: gamma_{yxxy} 6303 IDCROP(2+(IDX-1)*7) = IDIP(IDXB) 6304 6305 IACROP(3+(IDX-1)*7) = IDIP(IDXA) ! 3.: gamma_{xxzz} 6306 IBCROP(3+(IDX-1)*7) = IDIP(IDXA) ! 10.: gamma_{yyzz} 6307 ICCROP(3+(IDX-1)*7) = IDIP(IDXB) ! 17.: gamma_{xxyy} 6308 IDCROP(3+(IDX-1)*7) = IDIP(IDXB) 6309 6310 IACROP(4+(IDX-1)*7) = IDIP(IDXA) ! 4.: gamma_{xzxz} 6311 IBCROP(4+(IDX-1)*7) = IDIP(IDXB) ! 11.: gamma_{yzyz} 6312 ICCROP(4+(IDX-1)*7) = IDIP(IDXA) ! 18.: gamma_{xyxy} 6313 IDCROP(4+(IDX-1)*7) = IDIP(IDXB) 6314 6315 IACROP(5+(IDX-1)*7) = IDIP(IDXA) ! 5.: gamma_{xzzx} 6316 IBCROP(5+(IDX-1)*7) = IDIP(IDXB) ! 12.: gamma_{yzzy} 6317 ICCROP(5+(IDX-1)*7) = IDIP(IDXB) ! 19.: gamma_{xyyx} 6318 IDCROP(5+(IDX-1)*7) = IDIP(IDXA) 6319 6320 IACROP(6+(IDX-1)*7) = IDIP(IDXB) ! 6.: gamma_{zzxx} 6321 IBCROP(6+(IDX-1)*7) = IDIP(IDXB) ! 13.: gamma_{zzyy} 6322 ICCROP(6+(IDX-1)*7) = IDIP(IDXA) ! 20.: gamma_{yyxx} 6323 IDCROP(6+(IDX-1)*7) = IDIP(IDXA) 6324 6325 IACROP(7+(IDX-1)*7) = IDIP(IDXB) ! 7.: gamma_{zxzx} 6326 IBCROP(7+(IDX-1)*7) = IDIP(IDXA) ! 13.: gamma_{zyzy} 6327 ICCROP(7+(IDX-1)*7) = IDIP(IDXB) ! 21.: gamma_{yxyx} 6328 IDCROP(7+(IDX-1)*7) = IDIP(IDXA) 6329 END DO 6330 6331 NCROPER = 21 6332 IF (CSYM(1:6).EQ.'ATOMIC') THEN 6333 IF (GAMMA_PAR) NCROPER = 1 6334 IF (GAMMA_ORT) NCROPER = 3 6335 ELSE IF (CSYM(1:6).EQ.'SPHTOP') THEN 6336 IF (GAMMA_PAR) NCROPER = 4 6337 IF (GAMMA_ORT) NCROPER = 4 6338 ELSE IF (CSYM(1:6).EQ.'LINEAR') THEN 6339 IF (GAMMA_PAR) NCROPER = 8 6340 IF (GAMMA_ORT) THEN 6341 NCROPER = 10 6342 IACROP(9) = IDIP(1) ! 9.: gamma_{xyyx} 6343 IBCROP(9) = IDIP(2) 6344 ICCROP(9) = IDIP(2) 6345 IDCROP(9) = IDIP(1) 6346 IACROP(10) = IDIP(1) ! 10.: gamma_{xxyy} 6347 IBCROP(10) = IDIP(1) 6348 ICCROP(10) = IDIP(2) 6349 IDCROP(10) = IDIP(2) 6350 END IF 6351 END IF 6352 END IF 6353 GO TO 100 6354 6355 6356C ---------------------------------------- 6357C .DISPCF : (even) dispersion coefficients 6358C for real response functions 6359C ---------------------------------------- 636014 CONTINUE 6361 READ (LUCMD,*) NCRDSPE 6362 IF (NCRDISP.NE.0) THEN 6363 NWARN = NWARN + 1 6364 WRITE(LUPRI,'(/2A)') 6365 & '@ WARNING: INPUT FOR .EXPCOF OPTION BEFORE .DISPCF', 6366 & ' IN *CCCR SECTION WILL BE IGNORED.' 6367 NCRDISP = 0 6368 END IF 6369 DO L = 0, NCRDSPE, 2 6370 IF ((NCRDISP+(L+3)*(L+2)*(L+1)/6).LE.MXCRDISP) THEN 6371 DO K = 0, L, 1 6372 DO M = 0, K, 1 6373 DO N = 0, M, 1 6374 NCRDISP = NCRDISP + 1 6375 ICCAUA(NCRDISP) = L-K 6376 ICCAUB(NCRDISP) = K-M 6377 ICCAUC(NCRDISP) = M-N 6378 ICCAUD(NCRDISP) = N 6379 END DO 6380 END DO 6381 END DO 6382 ELSE 6383 NWARN = NWARN + 1 6384 WRITE(LUPRI,'(/A/2A,I5/)') '@ WARNING:', 6385 & '@ NO. OF DISPERSION COEFFICIENTS NEEDED', 6386 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXCRDISP 6387 WRITE(LUPRI,'(/A,I2,A)') 6388 & '@ DISPERSION COEFFICIENTS OF ORDER',L,' ARE IGNORED' 6389 WRITE(LUPRI,'(/2A,I5)') '@ FOR NEXT ORDER INCREASE ', 6390 & 'MXCRDISP TO:', (NCRDISP+(L+3)*(L+2)*(L+1)/6) 6391 NCRDSPE = L-2 6392 END IF 6393 END DO 6394 GO TO 100 6395 6396C ------------------------------------------ 6397C .ODDISP : (odd) dispersion coefficients 6398C for imaginary response functions 6399C ------------------------------------------ 640015 CONTINUE 6401 WRITE (LUPRI,*) 6402 & '.ODDISP option not yet implemented in CCCR.' 6403 GO TO 100 6404 6405C ----------------------------------------------------------- 6406C .NO2NP1: switch off 2n+1/2n+2 rule for 2.-order Cauchy vec. 6407C ----------------------------------------------------------- 640816 CONTINUE 6409 NO_2NP1_RULE = .TRUE. 6410 GO TO 100 6411 6412C ----------------------------------------------------------- 6413C .L2BCD : use L2(BC), L2(BD), L2(CD) vectors instead of 6414C R2(AD), R2(AC), R2(AB) for freq.-dep. resp. 6415C ----------------------------------------------------------- 641617 CONTINUE 6417 USE_LBCD = .TRUE. 6418 IF (L_USE_XKS3) THEN 6419 L_USE_XKS3 = .FALSE. 6420 WRITE(LUPRI,*) '.L2 BCD and .USEXKS are incompatible' 6421 WRITE(LUPRI,*) 'in the *CCCR section...' 6422 WRITE(LUPRI,*) '.USEXKS is switched off' 6423 END IF 6424 IF (L_USE_CHI2) THEN 6425 L_USE_CHI2 = .FALSE. 6426 WRITE(LUPRI,*) '.L2 BCD and .USECHI are incompatible' 6427 WRITE(LUPRI,*) 'in the *CCCR section...' 6428 WRITE(LUPRI,*) '.USECHI is switched off' 6429 END IF 6430 GO TO 100 6431 6432C ----------------------------------------------------------- 6433C .L2BC : use L2(BC) instead of R2(AD) for freq.-dep. resp. 6434C ----------------------------------------------------------- 643518 CONTINUE 6436 USE_L2BC = .TRUE. 6437 IF (L_USE_XKS3) THEN 6438 L_USE_XKS3 = .FALSE. 6439 WRITE(LUPRI,*) '.L2 BC and .USEXKS are incompatible' 6440 WRITE(LUPRI,*) 'in the *CCCR section...' 6441 WRITE(LUPRI,*) '.USEXKS is switched off' 6442 END IF 6443 IF (L_USE_CHI2) THEN 6444 L_USE_CHI2 = .FALSE. 6445 WRITE(LUPRI,*) '.L2 BC and .USECHI are incompatible' 6446 WRITE(LUPRI,*) 'in the *CCCR section...' 6447 WRITE(LUPRI,*) '.USECHI is switched off' 6448 END IF 6449 GO TO 100 6450 6451C ------------- 6452C unused labels 6453C ------------- 645419 CONTINUE 645520 CONTINUE 6456 6457 ELSE 6458 WRITE (LUPRI,'(/5A/)') ' Prompt "',WORD, 6459 & '" not recognized in ',SECNAM,'.' 6460 CALL PRTAB(NTABLE,TABLE,SECNAM//' input keywords',LUPRI) 6461 CALL QUIT('Illegal Keyword in '//SECNAM//'.') 6462 END IF 6463 6464 ELSE IF (WORD(1:1) .NE. '*') THEN 6465 WRITE (LUPRI,'(/5A/)') 'PROMPT "',WORD, 6466 & '" NOT RECOGNIZED IN ',SECNAM,'.' 6467 CALL QUIT('Illegal prompt in '//SECNAM//'.') 6468 6469 ELSE IF (WORD(1:1) .EQ.'*') THEN 6470 BACKSPACE (LUCMD) 6471 GO TO 200 6472 END IF 6473 6474 END IF 6475 6476200 CONTINUE 6477*---------------------------------------------------------------------* 6478* check, if any quadruples of operator labels specified: 6479* if not, use default: complete dipole-dipole-dipole-dipole tensor 6480*---------------------------------------------------------------------* 6481 IF (NCROPER .EQ. 0) THEN 6482 IF (NCROPER+81 .GT. MXCROP) THEN 6483 WRITE(LUPRI,'(2(/A,I5))') 6484 & ' NO. OF OPERATOR QUADRUPLES SPECIFIED : ',NCROPER+81, 6485 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXCROP 6486 CALL QUIT('TOO MANY OPERATOR QUADRUPLES IN CCQR.') 6487 END IF 6488 IDIP(1) = INDPRP_CC('XDIPLEN ') 6489 IDIP(2) = INDPRP_CC('YDIPLEN ') 6490 IDIP(3) = INDPRP_CC('ZDIPLEN ') 6491 DO IDXA=1,3 6492 DO IDXB=1,3 6493 DO IDXC=1,3 6494 DO IDXD=1,3 6495 IDX = NCROPER + (IDXA-1)*27+(IDXB-1)*9+(IDXC-1)*3+IDXD 6496 IACROP(IDX) = IDIP(IDXA) 6497 IBCROP(IDX) = IDIP(IDXB) 6498 ICCROP(IDX) = IDIP(IDXC) 6499 IDCROP(IDX) = IDIP(IDXD) 6500 END DO 6501 END DO 6502 END DO 6503 END DO 6504 NCROPER = NCROPER + 81 6505 END IF 6506 6507*---------------------------------------------------------------------* 6508* check, if frequencies or dispersion coefficients specified; 6509* if not, use default: static hyperpolarizabilities 6510*---------------------------------------------------------------------* 6511 IF (NCRFREQ.EQ.0 .AND. NCRDISP.EQ.0) THEN 6512 NCRFREQ = NCRFREQ + 1 6513 BCRFR(NCRFREQ) = ZERO 6514 CCRFR(NCRFREQ) = ZERO 6515 DCRFR(NCRFREQ) = ZERO 6516 END IF 6517 6518*---------------------------------------------------------------------* 6519* add list with wa frequencies: 6520*---------------------------------------------------------------------* 6521 DO IFREQ = 1, NCRFREQ 6522 ACRFR(IFREQ) = - (BCRFR(IFREQ) + CCRFR(IFREQ) + DCRFR(IFREQ)) 6523 END DO 6524 6525*---------------------------------------------------------------------* 6526* set CCCR flags: 6527*---------------------------------------------------------------------* 6528 CCCR = .TRUE. 6529 6530 RETURN 6531 END 6532*=====================================================================* 6533c /* deck CC_4RINP */ 6534*=====================================================================* 6535 SUBROUTINE CC_4RINP(WORD) 6536*---------------------------------------------------------------------* 6537* 6538* Purpose: read input for CC dynamic third hyperpolarizabilities 6539* (the quartic response function) 6540* 6541* Written by Christof Haettig, April 1997 6542* 6543*=====================================================================* 6544#if defined (IMPLICIT_NONE) 6545 IMPLICIT NONE 6546#else 6547# include "implicit.h" 6548#endif 6549#include "priunit.h" 6550#include "ccsdinp.h" 6551#include "ccsections.h" 6552#include "cc4rinf.h" 6553 6554* local parameters: 6555 CHARACTER MSGDBG*(18) 6556 PARAMETER (MSGDBG='[debug] CC_4RINP> ') 6557 CHARACTER SECNAM*(8) 6558 PARAMETER (SECNAM='CC_4RINP') 6559 6560 INTEGER NTABLE 6561 PARAMETER (NTABLE = 10) 6562 6563#if defined (SYS_CRAY) 6564 REAL ZERO 6565#else 6566 DOUBLE PRECISION ZERO 6567#endif 6568 PARAMETER (ZERO = 0.0d00) 6569 6570 6571* variables: 6572 LOGICAL SET 6573 SAVE SET 6574 6575 CHARACTER*(7) WORD 6576 CHARACTER*(8) LABELA, LABELB, LABELC, LABELD, LABELE 6577 CHARACTER*(7) TABLE(NTABLE) 6578 6579 INTEGER IDX, IJUMP, IFREQ, IDIP(3) 6580 INTEGER IDXA, IDXB, IDXC, IDXD, IDXE 6581 INTEGER MFREQ 6582 6583 DATA SET /.FALSE./ 6584 DATA TABLE /'.OPERAT','.DIPOLE','.PRINT ','.STATIC','.MIXFRE', 6585 & '.4HGFRE','.USECHI','.XXXXXX','.XXXXXX','.XXXXXX'/ 6586 6587 INTEGER INDPRP_CC 6588 6589*---------------------------------------------------------------------* 6590* begin: 6591*---------------------------------------------------------------------* 6592 IF (SET) RETURN 6593 SET = .TRUE. 6594 6595*---------------------------------------------------------------------* 6596* initializations & defaults: 6597*---------------------------------------------------------------------* 6598 N4ROPER = 0 6599 N4RFREQ = 0 6600 6601 L_USE_CHI3 = .FALSE. 6602 6603 CC4R = .FALSE. 6604 6605 IPR4HYP = IPRINT 6606 6607*---------------------------------------------------------------------* 6608* read input: 6609*---------------------------------------------------------------------* 6610 IF (WORD(1:7) .EQ. '*CC4R ') THEN 6611 6612100 CONTINUE 6613 6614* get new input line: 6615 READ (LUCMD,'(A7)') WORD 6616 CALL UPCASE(WORD) 6617 DO WHILE ( WORD(1:1) .EQ. '!' .OR. WORD(1:1) .EQ. '#' ) 6618 READ (LUCMD,'(A7)') WORD 6619 CALL UPCASE(WORD) 6620 END DO 6621 6622 IF (WORD(1:1) .EQ. '.') THEN 6623 6624c table look up: 6625 IJUMP = 1 6626 DO WHILE ( IJUMP .LE. NTABLE .AND. TABLE(IJUMP) .NE. WORD) 6627 IJUMP = IJUMP + 1 6628 END DO 6629 6630c jump to the appropriate input section: 6631 IF (IJUMP .LE. NTABLE) THEN 6632 ICHANG = ICHANG + 1 6633 GOTO (1,2,3,4,5,6,7,8,9,10), IJUMP 6634 CALL QUIT('Illegal address in computed GOTO in CC_4RINP.') 6635 6636C ------------ 6637C .OPERAT 6638C ------------ 66391 CONTINUE 6640 READ (LUCMD,'(5A)') LABELA,LABELB,LABELC,LABELD,LABELE 6641 DO WHILE (LABELA(1:1).NE.'.' .AND. LABELA(1:1).NE.'*') 6642 IF (LABELA(1:1).NE.'!') THEN 6643 IF (N4ROPER.LT.MX4ROP) THEN 6644 N4ROPER = N4ROPER + 1 6645 IA4ROP(N4ROPER) = INDPRP_CC(LABELA) 6646 IB4ROP(N4ROPER) = INDPRP_CC(LABELB) 6647 IC4ROP(N4ROPER) = INDPRP_CC(LABELC) 6648 ID4ROP(N4ROPER) = INDPRP_CC(LABELD) 6649 IE4ROP(N4ROPER) = INDPRP_CC(LABELE) 6650 ELSE 6651 WRITE(LUPRI,'(/2A,I5/)') 6652 & ' NO. OF OPERATOR QUADRUPLES SPECIFIED', 6653 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MX4ROP 6654 CALL QUIT('TOO MANY OPERATOR QUINTUPLES IN CC4R.') 6655 END IF 6656 END IF 6657 READ (LUCMD,'(5A)') LABELA,LABELB,LABELC,LABELD,LABELE 6658 END DO 6659 BACKSPACE(LUCMD) 6660 GO TO 100 6661 6662C ----------------------------------------------------------- 6663C .DIPOLE: calculate complete dipole^5 tensor (243 elements!) 6664C ----------------------------------------------------------- 66652 CONTINUE 6666 IF (N4ROPER+243 .GT. MX4ROP) THEN 6667 WRITE(LUPRI,'(/2A,I5/)') 6668 & ' NO. OF OPERATOR QUINTUPLES SPECIFIED', 6669 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MX4ROP 6670 CALL QUIT('TOO MANY OPERATOR QUINTUPLES IN CC4R.') 6671 END IF 6672 IDIP(1) = INDPRP_CC('XDIPLEN ') 6673 IDIP(2) = INDPRP_CC('YDIPLEN ') 6674 IDIP(3) = INDPRP_CC('ZDIPLEN ') 6675 DO IDXA=1,3 6676 DO IDXB=1,3 6677 DO IDXC=1,3 6678 DO IDXD=1,3 6679 DO IDXE=1,3 6680 IDX = N4ROPER + (IDXA-1)*81 + (IDXB-1)*27 + 6681 & (IDXC-1)*9 + (IDXD-1)*3 + IDXE 6682 IA4ROP(IDX) = IDIP(IDXA) 6683 IB4ROP(IDX) = IDIP(IDXB) 6684 IC4ROP(IDX) = IDIP(IDXC) 6685 ID4ROP(IDX) = IDIP(IDXD) 6686 IE4ROP(IDX) = IDIP(IDXE) 6687 END DO 6688 END DO 6689 END DO 6690 END DO 6691 END DO 6692 N4ROPER = N4ROPER + 243 6693 GO TO 100 6694 6695C ------------ 6696C .PRINT 6697C ------------ 66983 CONTINUE 6699 READ (LUCMD,*) IPR4HYP 6700 GO TO 100 6701 6702C ------------ 6703C .STATIC 6704C ------------ 67054 CONTINUE 6706 IF (N4RFREQ+1 .GT. MX4RFR) THEN 6707 NWARN = NWARN + 1 6708 WRITE(LUPRI,'(/A,3(/A,I5)/)') '@ WARNING:', 6709 & '@ NUMBER OF FREQUENCIES SPECIFIED : ',N4RFREQ+1, 6710 & '@ IS GREATER THAN THE ALLOWED NUMBER : ',MX4RFR, 6711 & '@ INPUT OPTION STATIC WILL BE IGNORED.' 6712 ELSE 6713 N4RFREQ = N4RFREQ + 1 6714 B4RFR(N4RFREQ) = ZERO 6715 C4RFR(N4RFREQ) = ZERO 6716 D4RFR(N4RFREQ) = ZERO 6717 E4RFR(N4RFREQ) = ZERO 6718 END IF 6719 GO TO 100 6720 6721C ------------------------------------------------------- 6722C .MIXFRE : mixed frequency input: 6723C read wb, wc, wd, we ---> wa = -wb-wc-wd-we 6724C ------------------------------------------------------- 67255 CONTINUE 6726 READ (LUCMD,*) MFREQ 6727 IF (N4RFREQ+MFREQ .GT. MX4RFR) THEN 6728 NWARN = NWARN + 1 6729 WRITE(LUPRI,'(/A,3(/A,I5)/)') '@ WARNING:', 6730 & '@ NUMBER OF FREQUENCIES SPECIFIED : ',N4RFREQ+MFREQ, 6731 & '@ IS GREATER THAN THE ALLOWED NUMBER : ',MX4RFR, 6732 & '@ THE NUMBER IS RESET TO THE MAXIMUM : ',MX4RFR 6733 MFREQ = MX4RFR-N4RFREQ 6734 END IF 6735 READ (LUCMD,*) (B4RFR(IDX),IDX=N4RFREQ+1,N4RFREQ+MFREQ) 6736 READ (LUCMD,*) (C4RFR(IDX),IDX=N4RFREQ+1,N4RFREQ+MFREQ) 6737 READ (LUCMD,*) (D4RFR(IDX),IDX=N4RFREQ+1,N4RFREQ+MFREQ) 6738 READ (LUCMD,*) (E4RFR(IDX),IDX=N4RFREQ+1,N4RFREQ+MFREQ) 6739 N4RFREQ = N4RFREQ + MFREQ 6740 GO TO 100 6741 6742C ---------------------------------------------------- 6743C .4HGFRE : fourth harmonic generation frequencies 6744C read wb --> wc=wb, wd=wb, we=wb, wa= -4wb 6745C ---------------------------------------------------- 67466 CONTINUE 6747 READ (LUCMD,*) MFREQ 6748 IF (N4RFREQ+MFREQ .GT. MX4RFR) THEN 6749 NWARN = NWARN + 1 6750 WRITE(LUPRI,'(/A,3(/A,I5)/)') '@ WARNING:', 6751 & '@ NUMBER OF FREQUENCIES SPECIFIED : ',N4RFREQ+MFREQ, 6752 & '@ IS GREATER THAN THE ALLOWED NUMBER : ',MX4RFR, 6753 & '@ THE NUMBER IS RESET TO THE MAXIMUM : ',MX4RFR 6754 MFREQ = MX4RFR-N4RFREQ 6755 END IF 6756 READ (LUCMD,*) (B4RFR(IDX),IDX=N4RFREQ+1,N4RFREQ+MFREQ) 6757 DO IDX = N4RFREQ+1, N4RFREQ+MFREQ 6758 C4RFR(IDX) = B4RFR(IDX) 6759 D4RFR(IDX) = B4RFR(IDX) 6760 E4RFR(IDX) = B4RFR(IDX) 6761 END DO 6762 N4RFREQ = N4RFREQ + MFREQ 6763 GO TO 100 6764 6765 6766C ------------------------------------------------------- 6767C .USECHI : use second-order chi vectors as intermediates 6768C (test option) 6769C ------------------------------------------------------- 67707 CONTINUE 6771 L_USE_CHI3 = .TRUE. 6772 GO TO 100 6773 6774C ------------- 6775C unused labels 6776C ------------- 67778 CONTINUE 67789 CONTINUE 677910 CONTINUE 6780 WRITE (LUPRI,*) 'unused .XXXXXX label... ignored' 6781 GO TO 100 6782 6783 6784 ELSE 6785 WRITE (LUPRI,'(/5A/)') ' Prompt "',WORD, 6786 & '" not recognized in ',SECNAM,'.' 6787 CALL PRTAB(NTABLE,TABLE,SECNAM//' input keywords',LUPRI) 6788 CALL QUIT('Illegal Keyword in '//SECNAM//'.') 6789 END IF 6790 6791 ELSE IF (WORD(1:1) .NE. '*') THEN 6792 WRITE (LUPRI,'(/5A/)') 'PROMPT "',WORD, 6793 & '" NOT RECOGNIZED IN ',SECNAM,'.' 6794 CALL QUIT('Illegal prompt in '//SECNAM//'.') 6795 6796 ELSE IF (WORD(1:1) .EQ.'*') THEN 6797 BACKSPACE (LUCMD) 6798 GO TO 200 6799 END IF 6800 6801 END IF 6802 6803200 CONTINUE 6804*---------------------------------------------------------------------* 6805* check, if any quintuples of operator labels specified: 6806* if not, use default: complete dipole^5 tensor 6807*---------------------------------------------------------------------* 6808 IF (N4ROPER .EQ. 0) THEN 6809 IF (N4ROPER+243 .GT. MX4ROP) THEN 6810 WRITE(LUPRI,'(2(/A,I5))') 6811 & ' NO. OF OPERATOR QUINTUPLES SPECIFIED : ',N4ROPER+243, 6812 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MX4ROP 6813 CALL QUIT('TOO MANY OPERATOR QUINTUPLES IN CC4R.') 6814 END IF 6815 IDIP(1) = INDPRP_CC('XDIPLEN ') 6816 IDIP(2) = INDPRP_CC('YDIPLEN ') 6817 IDIP(3) = INDPRP_CC('ZDIPLEN ') 6818 DO IDXA=1,3 6819 DO IDXB=1,3 6820 DO IDXC=1,3 6821 DO IDXD=1,3 6822 DO IDXE=1,3 6823 IDX = N4ROPER + (IDXA-1)*81 + (IDXB-1)*27 + 6824 & (IDXC-1)*9 + (IDXD-1)*3 + IDXE 6825 IA4ROP(IDX) = IDIP(IDXA) 6826 IB4ROP(IDX) = IDIP(IDXB) 6827 IC4ROP(IDX) = IDIP(IDXC) 6828 ID4ROP(IDX) = IDIP(IDXD) 6829 IE4ROP(IDX) = IDIP(IDXE) 6830 END DO 6831 END DO 6832 END DO 6833 END DO 6834 END DO 6835 N4ROPER = N4ROPER + 243 6836 END IF 6837 6838*---------------------------------------------------------------------* 6839* check, if frequencies specified; if not, use default: static 6840*---------------------------------------------------------------------* 6841 IF (N4RFREQ .EQ. 0) THEN 6842 N4RFREQ = N4RFREQ + 1 6843 B4RFR(N4RFREQ) = ZERO 6844 C4RFR(N4RFREQ) = ZERO 6845 D4RFR(N4RFREQ) = ZERO 6846 E4RFR(N4RFREQ) = ZERO 6847 END IF 6848 6849*---------------------------------------------------------------------* 6850* add list with wa frequencies: 6851*---------------------------------------------------------------------* 6852 DO IFREQ = 1, N4RFREQ 6853 A4RFR(IFREQ) = - (B4RFR(IFREQ) + C4RFR(IFREQ) 6854 & + D4RFR(IFREQ) + E4RFR(IFREQ)) 6855 END DO 6856 6857*---------------------------------------------------------------------* 6858* set CC4R flags: 6859*---------------------------------------------------------------------* 6860 CC4R = .TRUE. 6861 6862 RETURN 6863 END 6864*=====================================================================* 6865*=====================================================================* 6866c /* deck CC_5RINP */ 6867*=====================================================================* 6868 SUBROUTINE CC_5RINP(WORD) 6869*---------------------------------------------------------------------* 6870* 6871* Purpose: read input for CC dynamic fourth hyperpolarizabilities 6872* (the pentic response function) 6873* 6874* Written by Christof Haettig, Maj 1997 6875* 6876*=====================================================================* 6877#if defined (IMPLICIT_NONE) 6878 IMPLICIT NONE 6879#else 6880# include "implicit.h" 6881#endif 6882#include "priunit.h" 6883#include "ccsdinp.h" 6884#include "ccsections.h" 6885#include "cc5rinf.h" 6886#include "cc5perm.h" 6887 6888* local parameters: 6889 CHARACTER MSGDBG*(18) 6890 PARAMETER (MSGDBG='[debug] CC_5RINP> ') 6891 CHARACTER SECNAM*(8) 6892 PARAMETER (SECNAM='CC_5RINP') 6893 6894 INTEGER NTABLE 6895 PARAMETER (NTABLE = 10) 6896 6897#if defined (SYS_CRAY) 6898 REAL ZERO 6899#else 6900 DOUBLE PRECISION ZERO 6901#endif 6902 PARAMETER (ZERO = 0.0d00) 6903 6904 6905* variables: 6906 LOGICAL SET 6907 SAVE SET 6908 6909 CHARACTER*(7) WORD 6910 CHARACTER*(8) LABEL(6) 6911 CHARACTER*(7) TABLE(NTABLE) 6912 6913 INTEGER IDX, IJUMP, IFREQ, IDIP(3) 6914 INTEGER IDXA, IDXB, IDXC, IDXD, IDXE, IDXF 6915 INTEGER MFREQ 6916 6917 DATA SET /.FALSE./ 6918 DATA TABLE /'.OPERAT','.DIPOLE','.PRINT ','.STATIC','.MIXFRE', 6919 & '.5HGFRE','.XXXXXX','.XXXXXX','.XXXXXX','.XXXXXX'/ 6920 6921 INTEGER INDPRP_CC 6922 6923*---------------------------------------------------------------------* 6924* begin: 6925*---------------------------------------------------------------------* 6926 IF (SET) RETURN 6927 SET = .TRUE. 6928 6929*---------------------------------------------------------------------* 6930* initializations & defaults: 6931*---------------------------------------------------------------------* 6932 N5ROPER = 0 6933 N5RFREQ = 0 6934 6935 CC5R = .FALSE. 6936 6937 IPR5HYP = IPRINT 6938 6939*---------------------------------------------------------------------* 6940* read input: 6941*---------------------------------------------------------------------* 6942 IF (WORD(1:7) .EQ. '*CC5R ') THEN 6943 6944100 CONTINUE 6945 6946* get new input line: 6947 READ (LUCMD,'(A7)') WORD 6948 CALL UPCASE(WORD) 6949 DO WHILE ( WORD(1:1) .EQ. '!' .OR. WORD(1:1) .EQ. '#' ) 6950 READ (LUCMD,'(A7)') WORD 6951 CALL UPCASE(WORD) 6952 END DO 6953 6954 IF (WORD(1:1) .EQ. '.') THEN 6955 6956c table look up: 6957 IJUMP = 1 6958 DO WHILE ( IJUMP .LE. NTABLE .AND. TABLE(IJUMP) .NE. WORD) 6959 IJUMP = IJUMP + 1 6960 END DO 6961 6962c jump to the appropriate input section: 6963 IF (IJUMP .LE. NTABLE) THEN 6964 ICHANG = ICHANG + 1 6965 GOTO (1,2,3,4,5,6,7,8,9,10), IJUMP 6966 CALL QUIT('Illegal address in computed GOTO in CC_5RINP.') 6967 6968C ------------ 6969C .OPERAT 6970C ------------ 69711 CONTINUE 6972 READ (LUCMD,'(6A)') (LABEL(IDX),IDX=1,6) 6973 DO WHILE (LABEL(1)(1:1).NE.'.'.AND.LABEL(1)(1:1).NE.'*') 6974 IF (LABEL(1)(1:1).NE.'!') THEN 6975 IF (N5ROPER.LT.MX5ROP) THEN 6976 N5ROPER = N5ROPER + 1 6977 DO IDX = 1, 6 6978 I5ROP(N5ROPER,IDX) = INDPRP_CC(LABEL(IDX)) 6979 END DO 6980 WRITE (LUPRI,*) 'CC_5RINP>',N5ROPER,LABEL 6981 ELSE 6982 WRITE(LUPRI,'(/2A,I5)') 6983 & ' NO. OF OPERATOR QUADRUPLES SPECIFIED', 6984 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MX5ROP 6985 CALL QUIT('TOO MANY OPERATOR QUINTUPLES IN CC5R.') 6986 END IF 6987 END IF 6988 READ (LUCMD,'(6A)') (LABEL(IDX),IDX=1,6) 6989 END DO 6990 BACKSPACE(LUCMD) 6991 GO TO 100 6992 6993C ----------------------------------------------------------- 6994C .DIPOLE: calculate complete dipole^6 tensor (729 elements!) 6995C ----------------------------------------------------------- 69962 CONTINUE 6997 IF (N5ROPER+729 .GT. MX5ROP) THEN 6998 WRITE(LUPRI,'(/2A,I5)') 6999 & ' NO. OF OPERATOR HEXTUPLES SPECIFIED', 7000 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MX5ROP 7001 CALL QUIT('TOO MANY OPERATOR HEXTUPLES IN CC5R.') 7002 END IF 7003 IDIP(1) = INDPRP_CC('XDIPLEN ') 7004 IDIP(2) = INDPRP_CC('YDIPLEN ') 7005 IDIP(3) = INDPRP_CC('ZDIPLEN ') 7006 DO IDXA=1,3 7007 DO IDXB=1,3 7008 DO IDXC=1,3 7009 DO IDXD=1,3 7010 DO IDXE=1,3 7011 DO IDXF=1,3 7012 IDX = N5ROPER + (IDXA-1)*243 + (IDXB-1)*81 + 7013 & (IDXC-1)*27 + (IDXD-1)*9 + (IDXE-1)*3 + IDXF 7014 I5ROP(IDX,A) = IDIP(IDXA) 7015 I5ROP(IDX,B) = IDIP(IDXB) 7016 I5ROP(IDX,C) = IDIP(IDXC) 7017 I5ROP(IDX,D) = IDIP(IDXD) 7018 I5ROP(IDX,E) = IDIP(IDXE) 7019 I5ROP(IDX,F) = IDIP(IDXF) 7020C WRITE (LUPRI,'(8i5)'), IDX, IDIP(IDXA),IDIP(IDXB),IDIP(IDXC) 7021C & IDIP(IDXD),IDIP(IDXE),IDIP(IDXF) 7022 END DO 7023 END DO 7024 END DO 7025 END DO 7026 END DO 7027 END DO 7028 N5ROPER = N5ROPER + 729 7029 GO TO 100 7030 7031C ------------ 7032C .PRINT 7033C ------------ 70343 CONTINUE 7035 READ (LUCMD,*) IPR5HYP 7036 GO TO 100 7037 7038C ------------ 7039C .STATIC 7040C ------------ 70414 CONTINUE 7042 IF (N5RFREQ+1 .GT. MX5RFR) THEN 7043 NWARN = NWARN + 1 7044 WRITE(LUPRI,'(/A,3(/A,I5)/)') '@ WARNING:', 7045 & '@ NUMBER OF FREQUENCIES SPECIFIED : ',N5RFREQ+1, 7046 & '@ IS GREATER THAN THE ALLOWED NUMBER : ',MX5RFR, 7047 & '@ INPUT OPTION .STATIC WILL BE IGNORED.' 7048 ELSE 7049 N5RFREQ = N5RFREQ + 1 7050 FREQ5(N5RFREQ,B) = ZERO 7051 FREQ5(N5RFREQ,C) = ZERO 7052 FREQ5(N5RFREQ,D) = ZERO 7053 FREQ5(N5RFREQ,E) = ZERO 7054 FREQ5(N5RFREQ,F) = ZERO 7055 END IF 7056 GO TO 100 7057 7058C ------------------------------------------------------- 7059C .MIXFRE : mixed frequency input: 7060C read wb, wc, wd, we, wf ---> wa = -wb-wc-wd-we-wf 7061C ------------------------------------------------------- 70625 CONTINUE 7063 READ (LUCMD,*) MFREQ 7064 IF (N5RFREQ+MFREQ .GT. MX5RFR) THEN 7065 NWARN = NWARN + 1 7066 WRITE(LUPRI,'(/A,3(/A,I5)/)') '@ WARNING:', 7067 & '@ NUMBER OF FREQUENCIES SPECIFIED : ',N5RFREQ+MFREQ, 7068 & '@ IS GREATER THAN THE ALLOWED NUMBER : ',MX5RFR, 7069 & '@ THE NUMBER IS RESET TO THE MAXIMUM : ',MX5RFR 7070 MFREQ = MX5RFR-N5RFREQ 7071 END IF 7072 READ (LUCMD,*) (FREQ5(IDX,B),IDX=N5RFREQ+1,N5RFREQ+MFREQ) 7073 READ (LUCMD,*) (FREQ5(IDX,C),IDX=N5RFREQ+1,N5RFREQ+MFREQ) 7074 READ (LUCMD,*) (FREQ5(IDX,D),IDX=N5RFREQ+1,N5RFREQ+MFREQ) 7075 READ (LUCMD,*) (FREQ5(IDX,E),IDX=N5RFREQ+1,N5RFREQ+MFREQ) 7076 READ (LUCMD,*) (FREQ5(IDX,F),IDX=N5RFREQ+1,N5RFREQ+MFREQ) 7077 N5RFREQ = N5RFREQ + MFREQ 7078 GO TO 100 7079 7080C ---------------------------------------------------- 7081C .5HGFRE : fourth harmonic generation frequencies 7082C read wb --> wc=wb, wd=wb, we=wb, wf=wb, wa= -5wb 7083C ---------------------------------------------------- 70846 CONTINUE 7085 READ (LUCMD,*) MFREQ 7086 IF (N5RFREQ+MFREQ .GT. MX5RFR) THEN 7087 NWARN = NWARN + 1 7088 WRITE(LUPRI,'(/A,3(/A,I5)/)') '@ WARNING:', 7089 & '@ NUMBER OF FREQUENCIES SPECIFIED : ',N5RFREQ+MFREQ, 7090 & '@ IS GREATER THAN THE ALLOWED NUMBER : ',MX5RFR, 7091 & '@ THE NUMBER IS RESET TO THE MAXIMUM : ',MX5RFR 7092 MFREQ = MX5RFR-N5RFREQ 7093 END IF 7094 READ (LUCMD,*) (FREQ5(IDX,B),IDX=N5RFREQ+1,N5RFREQ+MFREQ) 7095 DO IDX = N5RFREQ+1, N5RFREQ+MFREQ 7096 FREQ5(IDX,C) = FREQ5(IDX,B) 7097 FREQ5(IDX,D) = FREQ5(IDX,B) 7098 FREQ5(IDX,E) = FREQ5(IDX,B) 7099 FREQ5(IDX,F) = FREQ5(IDX,B) 7100 END DO 7101 N5RFREQ = N5RFREQ + MFREQ 7102 GO TO 100 7103 7104 7105C ------------- 7106C unused labels 7107C ------------- 71087 CONTINUE 71098 CONTINUE 71109 CONTINUE 711110 CONTINUE 7112 WRITE (LUPRI,*) 'unused .XXXXXX label... ignored' 7113 GO TO 100 7114 7115 7116 ELSE 7117 WRITE (LUPRI,'(/5A/)') ' Prompt "',WORD, 7118 & '" not recognized in ',SECNAM,'.' 7119 CALL PRTAB(NTABLE,TABLE,SECNAM//' input keywords',LUPRI) 7120 CALL QUIT('Illegal Keyword in '//SECNAM//'.') 7121 END IF 7122 7123 ELSE IF (WORD(1:1) .NE. '*') THEN 7124 WRITE (LUPRI,'(/5A/)') 'PROMPT "',WORD, 7125 & '" NOT RECOGNIZED IN ',SECNAM,'.' 7126 CALL QUIT('Illegal prompt in '//SECNAM//'.') 7127 7128 ELSE IF (WORD(1:1) .EQ.'*') THEN 7129 BACKSPACE (LUCMD) 7130 GO TO 200 7131 END IF 7132 7133 END IF 7134 7135200 CONTINUE 7136*---------------------------------------------------------------------* 7137* check, if any quintuples of operator labels specified: 7138* if not, use default: complete dipole^6 tensor 7139*---------------------------------------------------------------------* 7140 IF (N5ROPER .EQ. 0) THEN 7141 IF (N5ROPER+729 .GT. MX5ROP) THEN 7142 WRITE(LUPRI,'(2(/A,I5))') 7143 & ' NO. OF OPERATOR QUINTUPLES SPECIFIED : ',N5ROPER+729, 7144 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MX5ROP 7145 CALL QUIT('TOO MANY OPERATOR QUINTUPLES IN CC5R.') 7146 END IF 7147 IDIP(1) = INDPRP_CC('XDIPLEN ') 7148 IDIP(2) = INDPRP_CC('YDIPLEN ') 7149 IDIP(3) = INDPRP_CC('ZDIPLEN ') 7150 DO IDXA=1,3 7151 DO IDXB=1,3 7152 DO IDXC=1,3 7153 DO IDXD=1,3 7154 DO IDXE=1,3 7155 DO IDXF=1,3 7156 IDX = N5ROPER + (IDXA-1)*243 + (IDXB-1)*81 + 7157 & (IDXC-1)*27 + (IDXD-1)*9 + (IDXE-1)*3 + IDXF 7158 I5ROP(IDX,A) = IDIP(IDXA) 7159 I5ROP(IDX,B) = IDIP(IDXB) 7160 I5ROP(IDX,C) = IDIP(IDXC) 7161 I5ROP(IDX,D) = IDIP(IDXD) 7162 I5ROP(IDX,E) = IDIP(IDXE) 7163 I5ROP(IDX,F) = IDIP(IDXF) 7164 END DO 7165 END DO 7166 END DO 7167 END DO 7168 END DO 7169 END DO 7170 N5ROPER = N5ROPER + 729 7171 END IF 7172 7173*---------------------------------------------------------------------* 7174* check, if frequencies specified; if not, use default: static 7175*---------------------------------------------------------------------* 7176 IF (N5RFREQ .EQ. 0) THEN 7177 N5RFREQ = N5RFREQ + 1 7178 FREQ5(N5RFREQ,B) = ZERO 7179 FREQ5(N5RFREQ,C) = ZERO 7180 FREQ5(N5RFREQ,D) = ZERO 7181 FREQ5(N5RFREQ,E) = ZERO 7182 FREQ5(N5RFREQ,F) = ZERO 7183 END IF 7184 7185*---------------------------------------------------------------------* 7186* add list with wa frequencies: 7187*---------------------------------------------------------------------* 7188 DO IFREQ = 1, N5RFREQ 7189 FREQ5(IFREQ,A) = - (FREQ5(IFREQ,B) + FREQ5(IFREQ,C) 7190 & + FREQ5(IFREQ,D) + FREQ5(IFREQ,E) + FREQ5(IFREQ,F)) 7191 END DO 7192 7193*---------------------------------------------------------------------* 7194* set CC5R flags: 7195*---------------------------------------------------------------------* 7196 CC5R = .TRUE. 7197 7198 RETURN 7199 END 7200*=====================================================================* 7201*---------------------------------------------------------------------* 7202C /* Deck indprpcc */ 7203 INTEGER FUNCTION INDPRP_CC(NEWLBL_CC) 7204C 7205#include "ccrspprp.h" 7206#include "priunit.h" 7207C 7208 CHARACTER*8 NEWLBL_CC 7209 INTEGER I 7210 7211 DO 100 I = 1,NPRLBL_CC 7212 IF ( NEWLBL_CC.EQ.PRPLBL_CC(I) ) THEN 7213 INDPRP_CC = I 7214 RETURN 7215 END IF 7216 100 CONTINUE 7217 7218 NPRLBL_CC = NPRLBL_CC + 1 7219 7220 IF (NPRLBL_CC.GT.MAXLBL_CC) THEN 7221 WRITE(LUPRI,'(/A/A,I5,A,I5/A/)') 7222 &'@ Number of specified CC properties exceeds the maximum allowed', 7223 &'@ MAXPRP =',MAXLBL_CC,' NPRLBL_CC= ',NPRLBL_CC, 7224 &'@ Increase MAXLBL_CC in include/ccrsprp.h and recompile.' 7225 CALL QUIT(' INDPRP_CC: TOO MANY PROPERTIES SPECIFIED') 7226 END IF 7227 7228 PRPLBL_CC(NPRLBL_CC) = NEWLBL_CC 7229 INDPRP_CC = NPRLBL_CC 7230 7231 RETURN 7232 END 7233*---------------------------------------------------------------------* 7234 SUBROUTINE CC_PUT1OP(INDOP,NOP,MAXOP,OPERATOR,ROUTINE) 7235C 7236#include "priunit.h" 7237 CHARACTER*(*) ROUTINE 7238 CHARACTER*(*) OPERATOR 7239 CHARACTER*80 MESSAGE 7240 LOGICAL FAILED 7241 INTEGER MAXOP, NEWOP 7242 INTEGER INDOP(MAXOP) 7243 7244 FAILED = .FALSE. 7245 NEWOP = -1 ! to avoid compiler warning 7246 IF (OPERATOR(1:6).EQ.'DIPLEN') THEN 7247 NEWOP = 3 7248 IF ( (NOP+NEWOP) .GT. MAXOP ) THEN 7249 FAILED = .TRUE. 7250 ELSE 7251 INDOP(NOP+1) = INDPRP_CC('XDIPLEN ') 7252 INDOP(NOP+2) = INDPRP_CC('YDIPLEN ') 7253 INDOP(NOP+3) = INDPRP_CC('ZDIPLEN ') 7254 END IF 7255 ELSE IF (OPERATOR(1:6).EQ.'DIPVEL') THEN 7256 NEWOP = 3 7257 IF ( (NOP+NEWOP) .GT. MAXOP ) THEN 7258 FAILED = .TRUE. 7259 ELSE 7260 INDOP(NOP+1) = INDPRP_CC('XDIPVEL ') 7261 INDOP(NOP+2) = INDPRP_CC('YDIPVEL ') 7262 INDOP(NOP+3) = INDPRP_CC('ZDIPVEL ') 7263 END IF 7264 ELSE IF (OPERATOR(1:6).EQ.'ANGMOM') THEN 7265 NEWOP = 3 7266 IF ( (NOP+NEWOP) .GT. MAXOP ) THEN 7267 FAILED = .TRUE. 7268 ELSE 7269 INDOP(NOP+1) = INDPRP_CC('XANGMOM ') 7270 INDOP(NOP+2) = INDPRP_CC('YANGMOM ') 7271 INDOP(NOP+3) = INDPRP_CC('ZANGMOM ') 7272 END IF 7273 ELSE IF (OPERATOR(1:6).EQ.'SECMOM') THEN 7274 NEWOP = 6 7275 IF ( (NOP+NEWOP) .GT. MAXOP ) THEN 7276 FAILED = .TRUE. 7277 ELSE 7278 INDOP(NOP+1) = INDPRP_CC('XXSECMOM') 7279 INDOP(NOP+2) = INDPRP_CC('XYSECMOM') 7280 INDOP(NOP+3) = INDPRP_CC('XZSECMOM') 7281 INDOP(NOP+4) = INDPRP_CC('YYSECMOM') 7282 INDOP(NOP+5) = INDPRP_CC('YZSECMOM') 7283 INDOP(NOP+6) = INDPRP_CC('ZZSECMOM') 7284 END IF 7285 ELSE IF (OPERATOR(1:6).EQ.'ROTSTR') THEN 7286 NEWOP = 6 7287 IF ( (NOP+NEWOP) .GT. MAXOP ) THEN 7288 FAILED = .TRUE. 7289 ELSE 7290 INDOP(NOP+1) = INDPRP_CC('XXROTSTR') 7291 INDOP(NOP+2) = INDPRP_CC('XYROTSTR') 7292 INDOP(NOP+3) = INDPRP_CC('XZROTSTR') 7293 INDOP(NOP+4) = INDPRP_CC('YYROTSTR') 7294 INDOP(NOP+5) = INDPRP_CC('YZROTSTR') 7295 INDOP(NOP+6) = INDPRP_CC('ZZROTSTR') 7296 END IF 7297 ELSE 7298 CALL QUIT('Unknown OPERATOR in CC_PUT1OP') 7299 END IF 7300 7301 IF (FAILED) THEN 7302 WRITE(MESSAGE,'(3a)') 7303 & 'TOO MANY OPERATORS IN ',ROUTINE(1:LEN(ROUTINE)),'.' 7304 WRITE(LUPRI,'(2(/A,I5))') 7305 & ' NO. OF OPERATORS SPECIFIED : ',NOP+NEWOP, 7306 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MAXOP 7307 CALL QUIT(MESSAGE) 7308 ELSE 7309 NOP = NOP + NEWOP 7310 END IF 7311 7312 RETURN 7313 END 7314*---------------------------------------------------------------------* 7315 SUBROUTINE CC_PUT2OP(INDOP1,INDOP2,NOP,MAXOP,OPERATOR,ROUTINE) 7316C 7317#include "priunit.h" 7318 CHARACTER*(*) ROUTINE 7319 CHARACTER*(*) OPERATOR 7320 CHARACTER*80 MESSAGE 7321 LOGICAL FAILED 7322 INTEGER MAXOP, NEWOP 7323 INTEGER INDOP1(MAXOP), INDOP2(MAXOP), IOP(10) 7324 7325 FAILED = .FALSE. 7326 IF (OPERATOR(1:6).EQ.'DIPLEN') THEN 7327 NEWOP = 3 7328 IF ( (NOP+NEWOP*NEWOP) .GT. MAXOP ) THEN 7329 FAILED = .TRUE. 7330 ELSE 7331 IOP(1) = INDPRP_CC('XDIPLEN ') 7332 IOP(2) = INDPRP_CC('YDIPLEN ') 7333 IOP(3) = INDPRP_CC('ZDIPLEN ') 7334 END IF 7335 ELSE IF (OPERATOR(1:6).EQ.'DIPVEL') THEN 7336 NEWOP = 3 7337 IF ( (NOP+NEWOP*NEWOP) .GT. MAXOP ) THEN 7338 FAILED = .TRUE. 7339 ELSE 7340 IOP(1) = INDPRP_CC('XDIPVEL ') 7341 IOP(2) = INDPRP_CC('YDIPVEL ') 7342 IOP(3) = INDPRP_CC('ZDIPVEL ') 7343 END IF 7344 ELSE IF (OPERATOR(1:6).EQ.'ANGMOM') THEN 7345 NEWOP = 3 7346 IF ( (NOP+NEWOP*NEWOP) .GT. MAXOP ) THEN 7347 FAILED = .TRUE. 7348 ELSE 7349 IOP(1) = INDPRP_CC('XANGMOM ') 7350 IOP(2) = INDPRP_CC('YANGMOM ') 7351 IOP(3) = INDPRP_CC('ZANGMOM ') 7352 END IF 7353 ELSE 7354 CALL QUIT('Unknown OPERATOR in CC_PUT2OP') 7355 END IF 7356 7357 IF (FAILED) THEN 7358 WRITE(MESSAGE,'(3a)') 7359 & 'TOO MANY OPERATORS IN ',ROUTINE(1:LEN(ROUTINE)),'.' 7360 WRITE(LUPRI,'(2(/A,I5))') 7361 & ' NO. OF OPERATORS SPECIFIED : ',NOP+NEWOP, 7362 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MAXOP 7363 CALL QUIT(MESSAGE) 7364 ELSE 7365 DO IDX1 = 1, NEWOP 7366 DO IDX2 = 1, NEWOP 7367 IDX12 = NOP + (IDX1 - 1)*NEWOP + IDX2 7368 INDOP1(IDX12) = IOP(IDX1) 7369 INDOP2(IDX12) = IOP(IDX2) 7370 END DO 7371 END DO 7372 NOP = NOP + NEWOP*NEWOP 7373 END IF 7374 7375 RETURN 7376 END 7377*---------------------------------------------------------------------* 7378c /* deck cc_exlrinp */ 7379*=====================================================================* 7380 SUBROUTINE CC_EXLRINP(WORD) 7381*---------------------------------------------------------------------* 7382* 7383* Purpose: read input for coupled cluster excited state linear response 7384* calculation of frequency-dependent second-order properties 7385* (excited state response functions and two-photon transition 7386* moments between two excited states) 7387* 7388* Written by Christof Haettig, July 1997 7389* 7390*=====================================================================* 7391#if defined (IMPLICIT_NONE) 7392 IMPLICIT NONE 7393#else 7394# include "implicit.h" 7395#endif 7396#include "priunit.h" 7397#include "ccsdinp.h" 7398#include "ccsections.h" 7399#include "ccexlrinf.h" 7400 7401* local parameters: 7402 CHARACTER MSGDBG*(20) 7403 PARAMETER (MSGDBG='[debug] CC_EXLRINP> ') 7404 CHARACTER SECNAM*(10) 7405 PARAMETER (SECNAM='CC_EXLRINP') 7406 7407 INTEGER NTABLE 7408 PARAMETER (NTABLE = 12) 7409 7410#if defined (SYS_CRAY) 7411 REAL ZERO 7412#else 7413 DOUBLE PRECISION ZERO 7414#endif 7415 PARAMETER (ZERO = 0.0d00) 7416 7417 7418* variables: 7419 LOGICAL SET 7420 SAVE SET 7421 7422 CHARACTER WORD*(7), LABHELP*(80) 7423 CHARACTER*8 LABELA, LABELB 7424 CHARACTER TABLE(NTABLE)*(7) 7425 7426 INTEGER IDX, IJUMP, ISYMS(2), IDXS(2), ISTART, IEND 7427 INTEGER MFREQ 7428 INTEGER IDXA, IDXB, IDIP(3) 7429 7430 DATA SET /.FALSE./ 7431 7432 DATA TABLE /'.OPERAT','.DIPOLE','.SELSTA','.PRINT ','.ALLSTA', 7433 & '.HALFFR','.USELEF','.FREQ ','.FREQUE','.STATIC', 7434 & '.USE O2','.NOPROJ'/ 7435 7436 INTEGER INDPRP_CC 7437 7438*---------------------------------------------------------------------* 7439* begin: 7440*---------------------------------------------------------------------* 7441 IF (SET) RETURN 7442 SET = .TRUE. 7443 7444*---------------------------------------------------------------------* 7445* initializations & defaults: 7446*---------------------------------------------------------------------* 7447 7448 NEXLROPER = 0 7449 NEXLRFREQ = 0 7450 NEXLRST = 0 7451 ALLSTATES = .FALSE. 7452 HALFFR = .FALSE. 7453 USE_EL1 = .FALSE. 7454 USE_O2 = .FALSE. 7455 NOPROJ = .FALSE. 7456 7457 CCEXLR = .FALSE. 7458 7459 IPREXLR = 0 7460 7461 ICHANG = 0 7462 7463C filip, 21.10.2013: 7464C Currently the projection onto the orthogonal 7465C complement for the EL1/ER1 equations for 7466C excited state polarizabilities is not 7467C implemented for CC3. 7468C We need therefore to switch this projection off whenever we enter 7469C the CC_EXLRINP module with CC3: 7470 IF (CC3) THEN 7471 NOPROJ = .TRUE. 7472 ENDIF 7473*---------------------------------------------------------------------* 7474* read input: 7475*---------------------------------------------------------------------* 7476 IF (WORD(1:7) .EQ. '*CCEXLR') THEN 7477 7478100 CONTINUE 7479 7480* get new input line: 7481 READ (LUCMD,'(A7)') WORD 7482 CALL UPCASE(WORD) 7483 DO WHILE ( WORD(1:1) .EQ. '!' .OR. WORD(1:1) .EQ. '#' ) 7484 READ (LUCMD,'(A7)') WORD 7485 CALL UPCASE(WORD) 7486 END DO 7487 7488 IF (WORD(1:1) .EQ. '.') THEN 7489 7490* table look up: 7491 IJUMP = 1 7492 DO WHILE ( IJUMP .LE. NTABLE .AND. TABLE(IJUMP) .NE. WORD) 7493 IJUMP = IJUMP + 1 7494 END DO 7495 7496* jump to the appropriate input section: 7497 IF (IJUMP .LE. NTABLE) THEN 7498 ICHANG = ICHANG + 1 7499 GOTO (1,2,3,4,5,6,7,8,9,10,11,12), IJUMP 7500 CALL QUIT('Illegal address in computed GOTO in CC_EXLRINP.') 7501 7502C -------------------------------------- 7503C .OPERAT: pair of operator lables (A,B) 7504C -------------------------------------- 75051 CONTINUE 7506 READ (LUCMD,'(2A)') LABELA, LABELB 7507 DO WHILE (LABELA(1:1).NE.'.' .AND. LABELA(1:1).NE.'*') 7508 IF (LABELA(1:1).NE.'!') THEN 7509 IF (NEXLROPER.LT.MXEXLROP) THEN 7510 NEXLROPER = NEXLROPER + 1 7511 IAEXLROP(NEXLROPER) = INDPRP_CC(LABELA) 7512 IBEXLROP(NEXLROPER) = INDPRP_CC(LABELB) 7513 ELSE 7514 WRITE(LUPRI,'(/2A,I5/)') 7515 & ' NO. OF OPERATOR PAIRS SPECIFIED', 7516 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXEXLROP 7517 CALL QUIT('TOO MANY OPERATOR PAIRS IN CCEXLR.') 7518 END IF 7519 END IF 7520 READ (LUCMD,'(3A)') LABELA, LABELB 7521 END DO 7522 BACKSPACE(LUCMD) 7523 GO TO 100 7524 7525C ------------------------------------------------ 7526C .DIPOLE: calculate complete dipole-dipole tensor 7527C ------------------------------------------------ 75282 CONTINUE 7529 IF (NEXLROPER+9 .GT. MXEXLROP) THEN 7530 WRITE(LUPRI,'(2(/A,I5))') 7531 & ' NO. OF OPERATOR PAIRS SPECIFIED : ',NEXLROPER+9, 7532 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXEXLROP 7533 CALL QUIT('TOO MANY OPERATOR PAIRS IN CCEXLR.') 7534 END IF 7535 IDIP(1) = INDPRP_CC('XDIPLEN ') 7536 IDIP(2) = INDPRP_CC('YDIPLEN ') 7537 IDIP(3) = INDPRP_CC('ZDIPLEN ') 7538 DO IDXA=1,3 7539 DO IDXB=1,3 7540 IDX = NEXLROPER + (IDXA-1)*3+IDXB 7541 IAEXLROP(IDX) = IDIP(IDXA) 7542 IBEXLROP(IDX) = IDIP(IDXB) 7543 END DO 7544 END DO 7545 NEXLROPER = NEXLROPER + 9 7546 GO TO 100 7547 7548C ------------------------------ 7549C .SELSTA: select excited states 7550C ------------------------------ 75513 CONTINUE 7552 READ (LUCMD,'(A80)') LABHELP 7553 DO WHILE(LABHELP(1:1).NE.'.' .AND. LABHELP(1:1).NE.'*') 7554 IF (LABHELP(1:1).NE.'!') THEN 7555 READ(LABHELP,*) ISYMS(1), IDXS(1),ISYMS(2), IDXS(2) 7556 IF (NEXLRST .LT. MXEXLRST) THEN 7557 NEXLRST = NEXLRST + 1 7558 IELRSYM(NEXLRST,1) = ISYMS(1) 7559 IELRSTA(NEXLRST,1) = IDXS(1) 7560 IELRSYM(NEXLRST,2) = ISYMS(2) 7561 IELRSTA(NEXLRST,2) = IDXS(2) 7562 ELSE 7563 NWARN = NWARN + 1 7564 WRITE(LUPRI,'(/A/2A,I5)') '@ WARNING:', 7565 & '@ NO. OF PAIRS OF STATES SPECIFIED', 7566 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXEXLRST 7567 WRITE(LUPRI,'(A,2I5/)') '@ IGNORE STATE',ISYMS,IDXS 7568 END IF 7569 END IF 7570 READ (LUCMD,'(A80)') LABHELP 7571 END DO 7572 BACKSPACE (LUCMD) 7573 GO TO 100 7574 7575 7576C ------------ 7577C .PRINT 7578C ------------ 75794 CONTINUE 7580 READ (LUCMD,*) IPREXLR 7581 GO TO 100 7582 7583C ------------------------------------------------------ 7584C .ALLSTA: calculate polarizabilities for all states 7585C (default, if .SELSTA is not used) 7586C ------------------------------------------------------ 75875 CONTINUE 7588 ALLSTATES = .TRUE. 7589 GO TO 100 7590 7591C -------------------------------------------------------- 7592C .HALFFR : use half the excitation energy as frequency 7593C for two-photon transition moments 7594C Note, that .HALFFR is incompatible with a user- 7595C specified frequency list 7596C for polarizabilities .HALFFR is equivalent 7597C to the .STATIC keyword (because the `excitation 7598C energy' is zero) 7599C -------------------------------------------------------- 76006 CONTINUE 7601 HALFFR = .TRUE. 7602 IF (NEXLRFREQ.NE.0) THEN 7603 NWARN = NWARN + 1 7604 WRITE(LUPRI,'(/2a/)') 7605 & '@ WARNING: in *CCEXLR on one of the Keywords', 7606 & ' .HALFFR and .FREQ/FREQUE', 7607 & ' can be specified...', 7608 & ' .FREQ/.FREQUE input will be ignored.' 7609 END IF 7610 NEXLRFREQ = 1 7611 BEXLRFR(1) = ZERO 7612 GO TO 100 7613 7614C ----------------------- 7615C .USELEF : use left excited state response vectors 7616C (default is to use right excited state responses) 7617C ----------------------- 76187 CONTINUE 7619 USE_EL1 = .TRUE. 7620 GO TO 100 7621 7622 7623C ------------------------------------------------ 7624C .FREQ : external field frequency: wb, wa = -wb 7625C .FREQUE: identical, keept for convenience 7626C ------------------------------------------------ 76278 CONTINUE 76289 CONTINUE 7629 READ (LUCMD,*) MFREQ 7630 IF (NEXLRFREQ+MFREQ .GT. MXEXLRFR) THEN 7631 NWARN = NWARN + 1 7632 WRITE(LUPRI,'(/A,3(/A,I5)/)') '@ WARNING:', 7633 & '@ NUMBER OF FREQUENCIES SPECIFIED :',NEXLRFREQ+MFREQ, 7634 & '@ IS GREATER THAN THE ALLOWED NUMBER :',MXEXLRFR, 7635 & '@ THE NUMBER IS RESET TO THE MAXIMUM :',MXEXLRFR 7636 MFREQ = MXEXLRFR-NEXLRFREQ 7637 END IF 7638 ISTART = NEXLRFREQ+1 7639 IEND = NEXLRFREQ+MFREQ 7640 READ (LUCMD,*) (BEXLRFR(IDX),IDX=ISTART,IEND) 7641 IF (NEXLRFREQ.NE.0) WRITE (LUPRI,*) 7642 & 'CC_EXLRINP> ', BEXLRFR(NEXLRFREQ), NEXLRFREQ 7643 NEXLRFREQ = NEXLRFREQ+MFREQ 7644 IF (HALFFR .AND. MFREQ.GT.0) THEN 7645 WRITE(LUPRI,'(/2a/)') 7646 & '@ WARNING: in *CCEXLR on one of the Keywords', 7647 & ' .HALFFR and .FREQ/FREQUE', 7648 & ' can be specified...', 7649 & ' option .HALFFR will be ignored.' 7650 END IF 7651 GO TO 100 7652 7653C --------------------------------------------------- 7654C .STATIC : add wb = wa = zero to frequency list 7655C --------------------------------------------------- 765610 CONTINUE 7657 IF (NEXLRFREQ+1 .GT. MXEXLRFR) THEN 7658 NWARN = NWARN + 1 7659 WRITE(LUPRI,'(/A,3(/A,I5)/)') '@ WARNING:', 7660 & '@ NUMBER OF FREQUENCIES SPECIFIED : ',NEXLRFREQ+1, 7661 & '@ IS GREATER THAN THE ALLOWED NUMBER : ',MXEXLRFR, 7662 & '@ INPUT OPTION .STATIC WILL BE IGNORED.' 7663 ELSE 7664 NEXLRFREQ = NEXLRFREQ + 1 7665 BEXLRFR(NEXLRFREQ) = ZERO 7666 END IF 7667 GO TO 100 7668 7669C ----------------------------------------------------------- 7670C .USE O2 : use rhs vectors for second-order amplitude 7671C response (might save some time at the 7672C CCS/CC2/CCSD levels if combined with other 7673C properties, but is not (yet) implemented for CC3) 7674C ----------------------------------------------------------- 767511 CONTINUE 7676 USE_O2 = .TRUE. 7677 GO TO 100 7678 7679C ----------------------------------------------------------- 7680C .NOPROJ: switch off projection onto the orthogonal 7681C complement for the EL1/ER1 equations for 7682C excited state polarizabilities 7683C (Note that this will cause numerical problems in 7684C the static limit) 7685C ----------------------------------------------------------- 768612 CONTINUE 7687 NOPROJ = .TRUE. 7688 GO TO 100 7689 7690 ELSE 7691 WRITE (LUPRI,'(/5A/)') ' Prompt "',WORD, 7692 & '" not recognized in ',SECNAM,'.' 7693 CALL PRTAB(NTABLE,TABLE,SECNAM//' input keywords',LUPRI) 7694 CALL QUIT('Illegal Keyword in '//SECNAM//'.') 7695 END IF 7696 7697 ELSE IF (WORD(1:1) .NE. '*') THEN 7698 WRITE (LUPRI,'(/5A/)') 'PROMPT "',WORD, 7699 & '" NOT RECOGNIZED IN ',SECNAM,'.' 7700 CALL QUIT('Illegal prompt in '//SECNAM//'.') 7701 7702 ELSE IF (WORD(1:1) .EQ.'*') THEN 7703 BACKSPACE (LUCMD) 7704 GO TO 200 7705 END IF 7706 7707 END IF 7708 7709200 CONTINUE 7710 7711*---------------------------------------------------------------------* 7712* check, if any pairs of operator labels specified: 7713* if not, use default: complete dipole-dipole tensor 7714*---------------------------------------------------------------------* 7715 IF (NEXLROPER .EQ. 0) THEN 7716 IF (NEXLROPER+9 .GT. MXEXLROP) THEN 7717 WRITE(LUPRI,'(2(/A,I5))') 7718 & ' NO. OF OPERATOR PAIRS SPECIFIED : ',NEXLROPER+9, 7719 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXEXLROP 7720 CALL QUIT('TOO MANY OPERATOR PAIRS IN CCEXLR.') 7721 END IF 7722 IDIP(1) = INDPRP_CC('XDIPLEN ') 7723 IDIP(2) = INDPRP_CC('YDIPLEN ') 7724 DO IDXA=1,3 7725 DO IDXB=1,3 7726 IDX = NEXLROPER + (IDXA-1)*3+IDXB 7727 IAEXLROP(IDX) = IDIP(IDXA) 7728 IBEXLROP(IDX) = IDIP(IDXB) 7729 END DO 7730 END DO 7731 NEXLROPER = NEXLROPER + 9 7732 END IF 7733 7734*---------------------------------------------------------------------* 7735* check, if frequencies specified; if not, use the default: 7736* static polarizabilities and two-photon at half the excitation energy 7737*---------------------------------------------------------------------* 7738 IF (NEXLRFREQ .EQ. 0) THEN 7739 NEXLRFREQ = NEXLRFREQ + 1 7740 BEXLRFR(NEXLRFREQ) = ZERO 7741 HALFFR = .TRUE. 7742 END IF 7743 7744*---------------------------------------------------------------------* 7745* check, if states specificied, if not, use default: all states 7746*---------------------------------------------------------------------* 7747 IF (NEXLRST .EQ. 0) ALLSTATES = .TRUE. 7748 7749*---------------------------------------------------------------------* 7750* set CCEXLR flags: 7751*---------------------------------------------------------------------* 7752 CCEXLR = .TRUE. 7753 7754 RETURN 7755 END 7756*---------------------------------------------------------------------* 7757 SUBROUTINE CC_TMINP(WORD) 7758*---------------------------------------------------------------------* 7759* 7760* Purpose: read input for CC third moment 7761* three photon is a special case 7762* 7763* if (WORD .eq '*CCTM ') read & process input and set defaults, 7764* else set only defaults 7765* 7766*=====================================================================* 7767C#if defined (IMPLICIT_NONE) 7768C IMPLICIT NONE 7769C#else 7770# include "implicit.h" 7771C#endif 7772#include "priunit.h" 7773#include "cctm.h" 7774#include "cctminf.h" 7775#include "ccsdinp.h" 7776#include "ccsections.h" 7777 7778* local parameters: 7779 CHARACTER SECNAM*(8) 7780 PARAMETER (SECNAM='CC_TMINP') 7781 7782 INTEGER NTABLE 7783 PARAMETER (NTABLE = 10) 7784 7785#if defined (SYS_CRAY) 7786 REAL ZERO 7787#else 7788 DOUBLE PRECISION ZERO 7789#endif 7790 7791 PARAMETER (ZERO = 0.0d00) 7792 7793 7794* variables: 7795 LOGICAL SET 7796 SAVE SET 7797 7798 CHARACTER WORD*(7) 7799 CHARACTER*8 LABELA, LABELB, LABELC 7800 CHARACTER*8 LABELD, LABELE, LABELF 7801 CHARACTER*70 LABHELP 7802 CHARACTER TABLE(NTABLE)*(7) 7803 7804#if defined (SYS_CRAY) 7805 REAL FREQB, FREQC 7806#else 7807 DOUBLE PRECISION FREQB, FREQC 7808#endif 7809 7810 7811 INTEGER IDX, IJUMP 7812 INTEGER IDXA, IDXB, IDXC, IDXD, IDXE, IDXF, IDIP(3) 7813 INTEGER IXSYM , IXST 7814 DATA SET /.FALSE./ 7815 7816 DATA TABLE /'.OPERAT','.DIPOLE','.PRINT ','.XXXXXX','.XXXXXX', 7817 & '.SELSTA','.THIRDF','.XXXXXX','.XXXXXX','.XXXXXX'/ 7818 7819 INTEGER INDPRP_CC 7820 7821*---------------------------------------------------------------------* 7822* begin: 7823*---------------------------------------------------------------------* 7824 IF (SET) RETURN 7825 SET = .TRUE. 7826 7827*---------------------------------------------------------------------* 7828* initializations & defaults: 7829*---------------------------------------------------------------------* 7830 NTMSEL = 0 7831 7832 NTMOPER = 0 7833 7834 CCTM = .FALSE. 7835 7836 IPRTM = 0 7837 7838 ICHANG = 0 7839 7840 THIRDFR = .FALSE. 7841 7842 SELTMST = .FALSE. 7843 7844 7845*---------------------------------------------------------------------* 7846* read input: 7847*---------------------------------------------------------------------* 7848 IF (WORD(1:7) .EQ. '*CCTM ') THEN 7849 7850100 CONTINUE 7851 7852* get new input line: 7853 READ (LUCMD,'(A7)') WORD 7854 CALL UPCASE(WORD) 7855 DO WHILE ( WORD(1:1) .EQ. '!' .OR. WORD(1:1) .EQ. '#' ) 7856 READ (LUCMD,'(A7)') WORD 7857 CALL UPCASE(WORD) 7858 END DO 7859 7860 IF (WORD(1:1) .EQ. '.') THEN 7861C WRITE (LUPRI,*) WORD 7862C CALL FLSHFO(LUPRI) 7863 7864c table look up: 7865 IJUMP = 1 7866 DO WHILE ( IJUMP .LE. NTABLE .AND. TABLE(IJUMP) .NE. WORD) 7867 IJUMP = IJUMP + 1 7868 END DO 7869 7870c jump to the appropriate input section: 7871 IF (IJUMP .LE. NTABLE) THEN 7872 ICHANG = ICHANG + 1 7873 GOTO (1,2,3,4,5,6,7,8,9,10), IJUMP 7874 CALL QUIT('Illegal address in computed GOTO in CC_TMINP.') 7875 7876C ------------------------------------------------- 7877C .OPERAT : hexuples of operator lables A,B,C,D,E,F 7878C ------------------------------------------------- 78791 CONTINUE 7880 READ (LUCMD,'(6A)') LABELA, LABELB, LABELC, 7881 & LABELD, LABELE, LABELF 7882 DO WHILE (LABELA(1:1).NE.'.' .AND. LABELA(1:1).NE.'*') 7883 IF (LABELA(1:1).NE.'!') THEN 7884 IF (NTMOPER.LT.MXTMOP) THEN 7885 NTMOPER = NTMOPER + 1 7886 IATMOP(NTMOPER) = INDPRP_CC(LABELA) 7887 IBTMOP(NTMOPER) = INDPRP_CC(LABELB) 7888 ICTMOP(NTMOPER) = INDPRP_CC(LABELC) 7889 IDTMOP(NTMOPER) = INDPRP_CC(LABELD) 7890 IETMOP(NTMOPER) = INDPRP_CC(LABELE) 7891 IFTMOP(NTMOPER) = INDPRP_CC(LABELF) 7892 ELSE 7893 WRITE(LUPRI,'(/2A,I5)') 7894 & ' NO. OF OPERATOR QUADRUPLES SPECIFIED', 7895 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXTMOP 7896 CALL QUIT('TOO MANY OPERATOR IN CCTM.') 7897 END IF 7898 END IF 7899 READ (LUCMD,'(6A)') LABELA, LABELB, LABELC, 7900 & LABELD, LABELE, LABELF 7901 END DO 7902 BACKSPACE(LUCMD) 7903 GO TO 100 7904 7905C ------------------------------------------------------- 7906C .DIPOL : calculate full dipole-dipole-dipole 7907C -dipole-dipole-dipole tensor 7908C ------------------------------------------------------- 79092 CONTINUE 7910 IF (NTMOPER+729 .GT. MXTMOP) THEN 7911 WRITE(LUPRI,'(2(/A,I6))') 7912 & ' NO. OF OPERATOR QUADRUPLES SPECIFIED : ',NTMOPER+729, 7913 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXTMOP 7914 CALL QUIT('TOO MANY OPERATOR QUADRUPLES IN CCTM.') 7915 7916 END IF 7917 IDIP(1) = INDPRP_CC('XDIPLEN ') 7918 IDIP(2) = INDPRP_CC('YDIPLEN ') 7919 IDIP(3) = INDPRP_CC('ZDIPLEN ') 7920 DO IDXA=1,3 7921 DO IDXB=1,3 7922 DO IDXC=1,3 7923 DO IDXD=1,3 7924 DO IDXE=1,3 7925 DO IDXF=1,3 7926 IDX = NTMOPER + (IDXA-1)*243+(IDXB-1)*81+(IDXC-1)*27+ 7927 & (IDXD-1)*9 +(IDXE-1)*3 + IDXF 7928 IATMOP(IDX) = IDIP(IDXA) 7929 IBTMOP(IDX) = IDIP(IDXB) 7930 ICTMOP(IDX) = IDIP(IDXC) 7931 IDTMOP(IDX) = IDIP(IDXD) 7932 IETMOP(IDX) = IDIP(IDXE) 7933 IFTMOP(IDX) = IDIP(IDXF) 7934 END DO 7935 END DO 7936 END DO 7937 END DO 7938 END DO 7939 END DO 7940 NTMOPER = NTMOPER + 729 7941 GO TO 100 7942 7943C ------------ 7944C .PRINT 7945C ------------ 79463 CONTINUE 7947 READ (LUCMD,*) IPRTM 7948 GO TO 100 7949 7950C ----------------------- 7951C .XXXXXX : unused labels 7952C ----------------------- 79534 CONTINUE 79545 CONTINUE 7955 WRITE (LUPRI,*) 'unused .XXXXXX label... ignored' 7956 GO TO 100 7957C 7958C------------------------- 7959C Select states. 7960C------------------------- 7961C .SELSTAtes Select states and frequencies 7962C frequences are overwritten if .THIRDFr are specified 7963C 79646 CONTINUE 7965 SELTMST =.TRUE. 7966 READ (LUCMD,'(A70)') LABHELP 7967 DO WHILE (LABHELP(1:1).NE.'.' .AND. LABHELP(1:1).NE.'*') 7968 IF (LABHELP(1:1).NE.'!') THEN 7969 READ(LABHELP,*) IXSYM,IXST,FREQB,FREQC 7970 IF (NTMSEL.LT.MXTMSEL) THEN 7971 NTMSEL = NTMSEL + 1 7972 ITMSEL(NTMSEL,1) = IXSYM 7973 ITMSEL(NTMSEL,2) = IXST 7974 BTMFR(NTMSEL) = FREQB 7975 CTMFR(NTMSEL) = FREQC 7976 ELSE 7977 WRITE(LUPRI,'(/2A,I5)') 7978 & ' NO. OF STATES SPECIFIED', 7979 & ' IS GREATER THAN THE ALLOWED NUMBER : ' ,MXTMSEL 7980 CALL QUIT('TOO MANY STATES SPECIFIED BY .SELST') 7981 END IF 7982 END IF 7983 READ (LUCMD,'(A70)') LABHELP 7984 END DO 7985 BACKSPACE(LUCMD) 7986 GO TO 100 7987C 7988C ------------------------------------------------ 7989C .THIRDF : impose condition of equal frequencies 7990C for the two lasers 7991C ------------------------------------------------ 79927 CONTINUE 7993 THIRDFR =.TRUE. 7994 GO TO 100 7995 7996C ------------------------------------------------ 79978 CONTINUE 7998 WRITE (LUPRI,*) 'unused .XXXXXX label... ignored' 7999 GO TO 100 8000C ------------------------------------------------ 80019 CONTINUE 8002 WRITE (LUPRI,*) 'unused .XXXXXX label... ignored' 8003 GO TO 100 8004C _______________________________________________ 800510 CONTINUE 8006 WRITE (LUPRI,*) 'unused .XXXXXX label... ignored' 8007 GO TO 100 8008 8009 8010 ELSE 8011 WRITE (LUPRI,'(/5A/)') ' Prompt "',WORD, 8012 & '" not recognized in ',SECNAM,'.' 8013 CALL PRTAB(NTABLE,TABLE,SECNAM//' input keywords',LUPRI) 8014 CALL QUIT('Illegal Keyword in '//SECNAM//'.') 8015 END IF 8016 8017 ELSE IF (WORD(1:1) .NE. '*') THEN 8018 WRITE (LUPRI,'(/5A/)') 'PROMPT "',WORD, 8019 & '" NOT RECOGNIZED IN ',SECNAM,'.' 8020 CALL QUIT('Illegal prompt in '//SECNAM//'.') 8021 8022 ELSE IF (WORD(1:1) .EQ.'*') THEN 8023 BACKSPACE (LUCMD) 8024 GO TO 200 8025 END IF 8026 8027 END IF 8028 8029200 CONTINUE 8030 8031*---------------------------------------------------------------------* 8032* warning if both .SELST AND .THIRDFr is specified 8033* 8034 IF (SELTMST.AND.THIRDFR) THEN 8035 WRITE (LUPRI,*) 8036 & ' WARNING: BOTH .SELST and .THIRDFr are specified' 8037 WRITE (LUPRI,*) ' .THIRDFr is used to obtain frequencies' 8038 END IF 8039*---------------------------------------------------------------------* 8040* check, if any sixtuple of operator labels specified: 8041* if not, use default: complete dipole tensor 8042*---------------------------------------------------------------------* 8043 IF (NTMOPER .EQ. 0) THEN 8044 IF (NTMOPER+729 .GT. MXTMOP) THEN 8045 WRITE(LUPRI,'(2(/A,I5))') 8046 & ' NO. OF OPERATOR SIXTUPLES SPECIFIED : ',NTMOPER+729, 8047 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXTMOP 8048 CALL QUIT('TOO MANY OPERATOR SIXTUPLES IN CCTM.') 8049 END IF 8050 IDIP(1) = INDPRP_CC('XDIPLEN ') 8051 IDIP(2) = INDPRP_CC('YDIPLEN ') 8052 IDIP(3) = INDPRP_CC('ZDIPLEN ') 8053 DO IDXA=1,3 8054 DO IDXB=1,3 8055 DO IDXC=1,3 8056 DO IDXD=1,3 8057 DO IDXE=1,3 8058 DO IDXF=1,3 8059 IDX = NTMOPER + (IDXA-1)*243+(IDXB-1)*81+(IDXC-1)*27+ 8060 & (IDXD-1)*9 +(IDXE-1)*3 + IDXF 8061 IATMOP(IDX) = IDIP(IDXA) 8062 IBTMOP(IDX) = IDIP(IDXB) 8063 ICTMOP(IDX) = IDIP(IDXC) 8064 IDTMOP(IDX) = IDIP(IDXC) 8065 IETMOP(IDX) = IDIP(IDXE) 8066 IFTMOP(IDX) = IDIP(IDXF) 8067 END DO 8068 END DO 8069 END DO 8070 END DO 8071 END DO 8072 END DO 8073 NTMOPER = NTMOPER + 729 8074 END IF 8075 8076*---------------------------------------------------------------------* 8077* check, if frequencies are specified; if not, use default: .THIRDFR 8078*---------------------------------------------------------------------* 8079 IF ( .NOT. SELTMST ) THEN 8080 IF ( .NOT. THIRDFR ) THIRDFR = .TRUE. 8081 NINFO = NINFO + 1 8082 WRITE(LUPRI,'(/2A)') 8083 & '@ INFO: NO FREQUENCIES SPECIFIED IN SECOND MOMENT CALC', 8084 & ' DEFAULT .THIRDFr USED ' 8085 END IF 8086*---------------------------------------------------------------------* 8087* set CCTM flags: 8088*---------------------------------------------------------------------* 8089 WRITE (LUPRI,*) ' CCTM set to .TRUE.' 8090 CCTM = .TRUE. 8091 8092 RETURN 8093 END 8094*======================================================================* 8095 SUBROUTINE CC_MCDINP(WORD) 8096*----------------------------------------------------------------------* 8097* Purpose: read input for CC magnetic circular dichroism 8098* 8099* if (WORD .eq '*CCMCD ') read & process input and set defaults, 8100* else set only defaults 8101* 8102* Use A,B for second order moment, C for first order moment 8103* 8104* Sonia Coriani and Poul Joergensen (fall 1997) 8105* Relaxed/PDBS operators, Sonia Coriani (february 2000) 8106*=====================================================================* 8107#if defined (IMPLICIT_NONE) 8108 IMPLICIT NONE 8109#else 8110# include "implicit.h" 8111#endif 8112#include "priunit.h" 8113#include "ccmcdinf.h" 8114#include "ccsdinp.h" 8115#include "ccsections.h" 8116 8117* local parameters: 8118 CHARACTER SECNAM*(9) 8119 PARAMETER (SECNAM='CC_MCDINP') 8120 CHARACTER*(19) MSGDBG 8121 PARAMETER (MSGDBG = '[debug] CC_MCDINP> ') 8122 LOGICAL LOCDBG 8123 PARAMETER (LOCDBG = .FALSE.) 8124 8125 INTEGER NTABLE 8126 PARAMETER (NTABLE = 10) 8127 8128#if defined (SYS_CRAY) 8129 REAL ZERO 8130#else 8131 DOUBLE PRECISION ZERO 8132#endif 8133 8134 PARAMETER (ZERO = 0.0d00) 8135 8136* variables: 8137 LOGICAL SET 8138 SAVE SET 8139 8140 CHARACTER WORD*(7) 8141 CHARACTER*8 LABELA, LABELB, LABELC 8142 CHARACTER*70 LABHELP 8143 CHARACTER TABLE(NTABLE)*(7) 8144 8145 LOGICAL LARLX, LBRLX, LCRLX, LRELAX 8146 INTEGER IJUMP, IJ, ITOT 8147 INTEGER IDA(6), IDB(6), IDC(6), IDIP(3), IANG(3) 8148 INTEGER IXSYM , IXST 8149* data 8150 DATA SET /.FALSE./ 8151 DATA TABLE /'.OPERAT','.MCD ','.MCDLAO','.PRINT ','.NO2N+1', 8152 & '.SELSTA','.RELAXE','.UNRELA','.USEPL1','.XXXXXX'/ 8153 DATA IDA / 1, 2, 2, 3, 3, 1 / 8154 DATA IDB / 2, 1, 3, 2, 1, 3 / 8155 DATA IDC / 3, 3, 1, 1, 2, 2 / 8156* external function: 8157 INTEGER INDPRP_CC 8158 8159*---------------------------------------------------------------------* 8160* begin: 8161*---------------------------------------------------------------------* 8162 IF (SET) RETURN 8163 SET = .TRUE. 8164*---------------------------------------------------------------------* 8165* initializations & defaults: 8166*---------------------------------------------------------------------* 8167 CCMCD = .FALSE. 8168 NMCDST = 0 ! # MCD (final) states 8169 NMCDOPER = 0 ! # MCD triples 8170 SELMCDST = .FALSE. ! Select MCD fin. state (default) 8171 LUSE2N1 = .TRUE. ! 2N+1 rule (Mbar^f vects in LR, default) 8172 LUSEPL1 = .FALSE. ! debug use of Left transformed vectors 8173 IPRMCD = 0 ! Print level (default) 8174 8175 LARLX = .FALSE. !Relaxed A operator 8176 LBRLX = .FALSE. !Relaxed B operator 8177 LCRLX = .FALSE. !Relaxed C operator 8178 LRELAX = .FALSE. !Relaxation 8179 8180C RELORB1 = .FALSE. !orbital relaxation vectors 8181* 8182 ICHANG = 0 8183*---------------------------------------------------------------------* 8184* Read input: 8185*---------------------------------------------------------------------* 8186 IF (WORD(1:7) .EQ. '*CCMCD ') THEN 8187 8188100 CONTINUE 8189 8190* get new input line: 8191 8192 READ (LUCMD,'(A7)') WORD 8193 CALL UPCASE(WORD) 8194 DO WHILE ( WORD(1:1) .EQ. '!' .OR. WORD(1:1) .EQ. '#' ) 8195 READ (LUCMD,'(A7)') WORD 8196 CALL UPCASE(WORD) 8197 END DO 8198 8199 IF (WORD(1:1) .EQ. '.') THEN 8200* table look up: 8201 IJUMP = 1 8202 DO WHILE ( IJUMP .LE. NTABLE .AND. TABLE(IJUMP) .NE. WORD) 8203 IJUMP = IJUMP + 1 8204 END DO 8205* jump to the appropriate input section: 8206 IF (IJUMP .LE. NTABLE) THEN 8207 ICHANG = ICHANG + 1 8208 GOTO (1,2,3,4,5,6,7,8,9,10), IJUMP 8209 CALL QUIT('Illegal address in computed GOTO in CC_MCDINP.') 8210 8211* ----------------------------------------------------------- 8212* .OPERAT : manually select triples of operator labels A,B,C 8213* A,B for second order moments 8214* C for first order moment 8215* ----------------------------------------------------------- 82161 CONTINUE 8217 READ (LUCMD,'(3A)') LABELA, LABELB, LABELC 8218 DO WHILE (LABELA(1:1).NE.'.' .AND. LABELA(1:1).NE.'*') 8219 IF (LABELA(1:1).EQ.'!') THEN 8220 CONTINUE 8221 ELSE IF (LABELA(1:1).EQ.'(') THEN 8222 LARLX = .FALSE. 8223 LBRLX = .FALSE. 8224 LCRLX = .FALSE. 8225 IF (LABELA(1:7).EQ.'(RELAX)') LARLX = .TRUE. 8226 IF (LABELB(1:7).EQ.'(RELAX)') LBRLX = .TRUE. 8227 IF (LABELC(1:7).EQ.'(RELAX)') LCRLX = .TRUE. 8228 IF (LARLX .OR. LBRLX .OR. LCRLX) THEN 8229 KEEPAOTWO = MAX(KEEPAOTWO,1) 8230C RELORB1 = .TRUE. 8231 END IF 8232 ELSE 8233 IF (NMCDOPER.LT.MXMCDOP) THEN 8234 NMCDOPER = NMCDOPER + 1 8235 IAMCDOP(NMCDOPER) = INDPRP_CC(LABELA) 8236 IBMCDOP(NMCDOPER) = INDPRP_CC(LABELB) 8237 ICMCDOP(NMCDOPER) = INDPRP_CC(LABELC) 8238 LAMCDRX(NMCDOPER) = LARLX 8239 LBMCDRX(NMCDOPER) = LBRLX 8240 LCMCDRX(NMCDOPER) = LCRLX 8241 ELSE 8242 WRITE(LUPRI,'(/2A,I5)') 8243 & ' NO. OF OPERATOR TRIPLES SPECIFIED', 8244 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXMCDOP 8245 CALL QUIT('TOO MANY OPERATOR-TRIPLETS IN CCMCD.') 8246 END IF 8247 END IF 8248 READ (LUCMD,'(3A)') LABELA, LABELB, LABELC 8249 END DO 8250 BACKSPACE(LUCMD) 8251 GO TO 100 8252* ------------------------------------------------------- 8253* .MCD : calculate full tensor (r x L) * r = 6 components 8254* all operators UNRELAXED 8255* ------------------------------------------------------- 82562 CONTINUE 8257 IF (NMCDOPER+6 .GT. MXMCDOP) THEN 8258 WRITE(LUPRI,'(2(/A,I5))') 8259 & ' NO. OF OPERATOR TRIPLES SPECIFIED : ',NMCDOPER+6, 8260 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXMCDOP 8261 CALL QUIT('TOO MANY OPERATOR TRIPLES IN CCMCD.') 8262 8263 END IF 8264 IDIP(1) = INDPRP_CC('XDIPLEN ') 8265 IDIP(2) = INDPRP_CC('YDIPLEN ') 8266 IDIP(3) = INDPRP_CC('ZDIPLEN ') 8267 IANG(1) = INDPRP_CC('XANGMOM ') 8268 IANG(2) = INDPRP_CC('YANGMOM ') 8269 IANG(3) = INDPRP_CC('ZANGMOM ') 8270 DO IJ = 1,6 8271 IAMCDOP(IJ+NMCDOPER) = IDIP(IDA(IJ)) 8272 IBMCDOP(IJ+NMCDOPER) = IANG(IDB(IJ)) 8273 ICMCDOP(IJ+NMCDOPER) = IDIP(IDC(IJ)) 8274 LAMCDRX(IJ+NMCDOPER) = LRELAX 8275 LBMCDRX(IJ+NMCDOPER) = LRELAX 8276 LCMCDRX(IJ+NMCDOPER) = LRELAX 8277 END DO 8278 NMCDOPER = NMCDOPER + 6 8279 GO TO 100 8280* ------------------------------------------------------- 8281* .MCDLAO : calculate full tensor (r x L) * r = 6 compnts 8282* L operator is dh/dB 8283* UNFINISHED!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 8284* ------------------------------------------------------- 82853 CONTINUE 8286 IF (NMCDOPER+6 .GT. MXMCDOP) THEN 8287 WRITE(LUPRI,'(2(/A,I5))') 8288 & ' NO. OF OPERATOR TRIPLES SPECIFIED : ',NMCDOPER+6, 8289 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXMCDOP 8290 CALL QUIT('TOO MANY OPERATOR TRIPLES IN CCMCD.') 8291 8292 END IF 8293 IDIP(1) = INDPRP_CC('XDIPLEN ') 8294 IDIP(2) = INDPRP_CC('YDIPLEN ') 8295 IDIP(3) = INDPRP_CC('ZDIPLEN ') 8296 IANG(1) = INDPRP_CC('dh/dBX ') 8297 IANG(2) = INDPRP_CC('dh/dBY ') 8298 IANG(3) = INDPRP_CC('dh/dBZ ') 8299 DO IJ = 1,6 8300 IAMCDOP(IJ+NMCDOPER) = IDIP(IDA(IJ)) 8301 IBMCDOP(IJ+NMCDOPER) = IANG(IDB(IJ)) 8302 ICMCDOP(IJ+NMCDOPER) = IDIP(IDC(IJ)) 8303 LAMCDRX(IJ+NMCDOPER) = LRELAX 8304 LBMCDRX(IJ+NMCDOPER) = LRELAX 8305 LCMCDRX(IJ+NMCDOPER) = LRELAX 8306 END DO 8307 NMCDOPER = NMCDOPER + 6 8308 GO TO 100 8309* ------------------------------------------------------- 8310* .PRINT : set desired print level (default = 0) 8311* ------------------------------------------------------- 83124 CONTINUE 8313 READ (LUCMD,*) IPRMCD 8314 GO TO 100 8315* ------------------------------------------------------ 8316* .NO2N+1 : don't use the 2N+1 rule, ie don't use Mbar^f 8317* for the calculation of the one-photon moment 8318* for the C operator 8319* ------------------------------------------------------ 83205 CONTINUE 8321 LUSE2N1 = .FALSE. 8322 NWARN = NWARN + 1 8323 WRITE(LUPRI,'(2(/A))') 8324 & '@ WARNING MCD: NO2N+1 not yet carried through', 8325 & ' LUSE2N1 is reset to TRUE !!!!!' 8326 LUSE2N1 = .TRUE. 8327 GO TO 100 8328* --------------------------------------------------------------- 8329* .SELSTA : Select (final) states (Bfrequency zero by default) 8330* Specify then symmetry (IXSYM) and state number (IXST) 8331* of the state(s) we wish to calculate the transition 8332* moments (one line with IXSYM,IXST for each state) 8333* --------------------------------------------------------------- 83346 CONTINUE 8335 8336 SELMCDST =.TRUE. 8337 READ (LUCMD,'(A70)') LABHELP !read buffer line from input 8338 DO WHILE (LABHELP(1:1).NE.'.' .AND. LABHELP(1:1).NE.'*') 8339 IF (LABHELP(1:1).NE.'!') THEN 8340 !read sym/number fin.state (from buffer line) 8341 READ(LABHELP,*) IXSYM,IXST 8342 IF (NMCDST.LT.MXMCDST) THEN 8343 NMCDST = NMCDST + 1 !count how many 8344 !put state-sym in array IMCDSTSY(*) 8345 IMCDSTSY(NMCDST) = IXSYM 8346 !put state-nr in array IMCDSTNR(*) 8347 IMCDSTNR(NMCDST) = IXST 8348 ELSE 8349 WRITE(LUPRI,'(/2A,I5)') 8350 & ' NO. OF STATES SPECIFIED', 8351 & ' IS GREATER THAN THE ALLOWED NUMBER : ' ,MXMCDST 8352 CALL QUIT( 8353 & 'TOO MANY STATES SPECIFIED BY .SELSTA in MCD') 8354 END IF 8355 END IF 8356 READ (LUCMD,'(A70)') LABHELP 8357 END DO 8358 BACKSPACE(LUCMD) 8359 GO TO 100 8360* ---------------------------------------------------------- 8361* .RELAXE : switch to relaxed modus for all three operators: 8362* ---------------------------------------------------------- 83637 CONTINUE 8364 ! LRELAX = .TRUE. 8365 ! KEEPAOTWO = MAX(KEEPAOTWO,1) 8366 WRITE (LUPRI,*) 8367 & '.RELAXE keyword in *CCMCD section is disabled.' 8368 GO TO 100 8369* ------------------------------------------------------------ 8370* .UNRELA : switch to unrelaxed modus for all three operators: 8371* ------------------------------------------------------------ 83728 CONTINUE 8373 LRELAX = .FALSE. 8374 GO TO 100 8375* ----------------------------------------------------- 8376* .USEPL1 : use left transformed contributions (debug) 8377* ----------------------------------------------------- 83789 CONTINUE 8379 LUSEPL1 = .TRUE. 8380 WRITE (LUPRI,*) SECNAM, 8381 & ': Use PL1 and left A transformations' 8382 GO TO 100 8383* ----------------------- 8384* .XXXXXX : unused labels 8385* ----------------------- 838610 CONTINUE 8387 WRITE (LUPRI,*) SECNAM,': unused .XXXXXX label... ignored' 8388 GO TO 100 8389* 8390 ELSE 8391 WRITE (LUPRI,'(/5A/)') ' Prompt "',WORD, 8392 & '" not recognized in ',SECNAM,'.' 8393 CALL PRTAB(NTABLE,TABLE,SECNAM//' input keywords',LUPRI) 8394 CALL QUIT('Illegal Keyword in '//SECNAM//'.') 8395 END IF 8396 8397 ELSE IF (WORD(1:1) .NE. '*') THEN 8398 WRITE (LUPRI,'(/5A/)') 'PROMPT "',WORD, 8399 & '" NOT RECOGNIZED IN ',SECNAM,'.' 8400 CALL QUIT('Illegal prompt in '//SECNAM//'.') 8401 8402 ELSE IF (WORD(1:1) .EQ.'*') THEN 8403 BACKSPACE (LUCMD) 8404 GO TO 200 8405 END IF 8406 8407 END IF 8408 8409200 CONTINUE 8410 8411*---------------------------------------------------------------------* 8412* check if any triple of operator labels has been specified: 8413* if not, use default: complete unrelaxed 8414* {dipole x angmom * dipole} tensor 8415*---------------------------------------------------------------------* 8416 IF (NMCDOPER .EQ. 0) THEN 8417 IF (NMCDOPER+6 .GT. MXMCDOP) THEN 8418 WRITE(LUPRI,'(2(/A,I5))') 8419 & ' NO. OF OPERATOR TRIPLES SPECIFIED : ',NMCDOPER+6, 8420 & ' IS GREATER THAN THE ALLOWED NUMBER : ',MXMCDOP 8421 CALL QUIT('TOO MANY OPERATOR TRIPLES IN CCMCD.') 8422 END IF 8423 IDIP(1) = INDPRP_CC('XDIPLEN ') 8424 IDIP(2) = INDPRP_CC('YDIPLEN ') 8425 IDIP(3) = INDPRP_CC('ZDIPLEN ') 8426 IANG(1) = INDPRP_CC('XANGMOM ') 8427 IANG(2) = INDPRP_CC('YANGMOM ') 8428 IANG(3) = INDPRP_CC('ZANGMOM ') 8429 DO ITOT=1,6 8430 IAMCDOP(ITOT+NMCDOPER) = IDIP(IDA(ITOT)) 8431 IBMCDOP(ITOT+NMCDOPER) = IANG(IDB(ITOT)) 8432 ICMCDOP(ITOT+NMCDOPER) = IDIP(IDC(ITOT)) 8433 LAMCDRX(ITOT+NMCDOPER) = LRELAX 8434 LBMCDRX(ITOT+NMCDOPER) = LRELAX 8435 LCMCDRX(ITOT+NMCDOPER) = LRELAX 8436 END DO 8437 NMCDOPER = NMCDOPER + 6 8438 END IF 8439*---------------------------------------------------------------------* 8440* set CCMCD = TRUE if we are to calculate anything at all 8441*---------------------------------------------------------------------* 8442 CCMCD = .TRUE. 8443*---------------------------------------------------------------------* 8444 RETURN 8445 END 8446*---------------------------------------------------------------------* 8447*=====================================================================* 8448c /* deck cc_slvinp */ 8449*=====================================================================* 8450 SUBROUTINE CC_SLVINP(WORD) 8451C---------------------------------------------------------------------* 8452C 8453C Purpose: read input for CC solvent calculations. 8454C 8455C if (WORD .eq '*CCSLV ') read & process input and set defaults, 8456C else set only defaults 8457C 8458C SLV98,OC 8459C Ove Christiansen April 1998 8460C 8461C=====================================================================* 8462#include "implicit.h" 8463#include "priunit.h" 8464#include "ccsdinp.h" 8465#include "ccsections.h" 8466#include "ccsdsym.h" 8467#include "ccfield.h" 8468#include "ccslvinf.h" 8469#include "qm3.h" 8470 8471 CHARACTER SECNAM*(9) 8472 PARAMETER (SECNAM='CC_SLVINP') 8473 INTEGER NTABLE 8474 PARAMETER (NTABLE = 15) 8475 8476 LOGICAL SET 8477 SAVE SET 8478 8479 CHARACTER WORD*(7) 8480 CHARACTER TABLE(NTABLE)*(8) 8481 8482 8483 DATA SET /.FALSE./ 8484 DATA TABLE /'.SOLVAT','.MXSLIT','.ETOLSL','.TTOLSL','.LTOLSL', 8485 * '.PTSOLV','.CCMM','.DISCEX','.REPTST','.RELMOM', 8486 * '.SLOTH ' ,'.MXINIT','.SKIPNC','.HFFLD ','.CCFIXF'/ 8487 8488*---------------------------------------------------------------------* 8489* begin: 8490*---------------------------------------------------------------------* 8491 8492 IF (SET) RETURN 8493 SET = .TRUE. 8494 8495*---------------------------------------------------------------------* 8496* initializations & defaults: 8497*---------------------------------------------------------------------* 8498 8499 ICHANG = 0 8500 IXCCSLIT = 0 8501 MXCCSLIT = 10 8502 CVGESOL = 1.0D-07 8503 CVGTSOL = 1.0D-07 8504 CVGLSOL = 1.0D-07 8505 PTSOLV = .FALSE. 8506 CCMM = .FALSE. 8507 DISCEX = .FALSE. 8508 ECCCU = 0.0D0 8509 XTNCCCU = 0.0D0 8510 XLNCCCU = 0.0D0 8511 MXTINIT = 200 8512 MXLINIT = 200 8513 LOITER = .FALSE. 8514 REPTST = .FALSE. 8515 NREPMT = 0 8516 RELMOM = .FALSE. 8517 SLOTH = .FALSE. 8518 SKIPNC = .FALSE. 8519 HFFLD = .FALSE. ! Do polarization based on fixed HF/MM reaction field - in doi:10.1039/C0C901075H denoted model 1 8520 FFIRST = .TRUE. ! Dumps Ghf to file in first cc iteration 8521 CCFIXF = .FALSE. ! Do polarization based on fixed CC/MM reaction field neglecting resp terms - ie only static polarization. Model 2 in doi:10.1039/C0C901075H 8522 8523*---------------------------------------------------------------------* 8524* read input: 8525*---------------------------------------------------------------------* 8526 8527 IF (WORD(1:7) .EQ. '*CCSLV ') THEN 8528 8529 8530100 CONTINUE 8531 8532 READ (LUCMD,'(A7)') WORD 8533 CALL UPCASE(WORD) 8534 DO WHILE ( WORD(1:1) .EQ. '!' .OR. WORD(1:1) .EQ. '#' ) 8535 READ (LUCMD,'(A7)') WORD 8536 CALL UPCASE(WORD) 8537 END DO 8538 8539 IF (WORD(1:1) .EQ. '.') THEN 8540 8541 IJUMP = 1 8542 DO WHILE ( IJUMP .LE. NTABLE .AND. TABLE(IJUMP) .NE. WORD) 8543 IJUMP = IJUMP + 1 8544 END DO 8545 8546 IF (IJUMP .LE. NTABLE) THEN 8547 ICHANG = ICHANG + 1 8548 GOTO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15) ,IJUMP 8549 CALL QUIT('Illegal address in computed GOTO in CC_SLVINP.') 8550C 8551C----------------------- 8552C 8553C----------------------- 8554C 85551 CONTINUE 8556 READ(LUCMD,'(I5)') NCCSLV 8557 DO ISLV=1,NCCSLV 8558 READ(LUCMD,*) LMAXCC(ISLV),RCAVCC(ISLV), 8559 * EPSTCC(ISLV),EPOPCC(ISLV) 8560 IF (LMAXCC(ISLV).GT.MAXCCL) THEN 8561 WRITE(LUPRI,*) 'Maximum Lmax in CC is ',MAXCCL 8562 CALL QUIT('Too large LMAX in CC_SLVINP') 8563 ENDIF 8564 ENDDO 8565 GO TO 100 8566C 8567C----------------------- 8568C 8569C----------------------- 8570C 85712 CONTINUE 8572 READ(LUCMD,*) MXCCSLIT 8573 GO TO 100 8574C 8575C----------------------- 8576C 8577C----------------------- 8578C 85793 CONTINUE 8580 READ(LUCMD,*) CVGESOL 8581 GO TO 100 8582C 8583C----------------------- 8584C 8585C----------------------- 8586C 85874 CONTINUE 8588 READ(LUCMD,*) CVGTSOL 8589 GO TO 100 8590C 8591C----------------------- 8592C 8593C----------------------- 8594C 85955 CONTINUE 8596 READ(LUCMD,*) CVGLSOL 8597 GO TO 100 8598C 8599C----------------------- 8600C 8601C----------------------- 8602C 86036 CONTINUE 8604 PTSOLV = .TRUE. 8605 GO TO 100 8606C 8607C----------------------- 8608C 8609C----------------------- 8610C 86117 CONTINUE 8612 CCMM = .TRUE. 8613 GO TO 100 8614C 8615C----------------------- 8616C 8617C----------------------- 8618C 86198 CONTINUE 8620 DISCEX = .TRUE. 8621 GO TO 100 8622C 8623C----------------------- 8624C 8625C----------------------- 8626C 86279 CONTINUE 8628 READ(LUCMD,*) NREPMT 8629 REPTST = .TRUE. 8630 GO TO 100 8631C 8632C----------------------- 8633C 8634C----------------------- 8635C 863610 CONTINUE 8637 RELMOM = .TRUE. 8638 GO TO 100 8639C 8640C----------------------- 8641C 8642C----------------------- 8643C 864411 CONTINUE 8645 SLOTH = .TRUE. 8646 GO TO 100 8647C 8648C----------------------- 8649C 8650C----------------------- 8651C 865212 CONTINUE 8653 READ(LUCMD,*) MXTINIT, MXLINIT 8654 LOITER = .TRUE. 8655 GO TO 100 8656C 8657C----------------------- 8658C 8659C----------------------- 8660C 866113 CONTINUE 8662 SKIPNC = .TRUE. 8663 GO TO 100 8664C 8665C----------------------- 8666C 8667C----------------------- 8668C 866914 CONTINUE 8670 HFFLD = .TRUE. 8671 GO TO 100 8672C 8673C----------------------- 8674C 867515 CONTINUE 8676 CCFIXF = .TRUE. 8677 GO TO 100 8678 8679 ELSE 8680 WRITE (LUPRI,'(/5A/)') ' Prompt "',WORD, 8681 & '" not recognized in ',SECNAM,'.' 8682 CALL PRTAB(NTABLE,TABLE,SECNAM//' input keywords',LUPRI) 8683 CALL QUIT('Illegal Keyword in '//SECNAM//'.') 8684 END IF 8685 8686 ELSE IF (WORD(1:1) .NE. '*') THEN 8687 WRITE (LUPRI,'(/5A/)') 'PROMPT "',WORD, 8688 & '" NOT RECOGNIZED IN ',SECNAM,'.' 8689 CALL QUIT('Illegal prompt in '//SECNAM//'.') 8690 8691 ELSE IF (WORD(1:1) .EQ.'*') THEN 8692 BACKSPACE (LUCMD) 8693 GO TO 200 8694 END IF 8695 8696 END IF 8697 8698200 CONTINUE 8699C 8700C------------------------------------------------------------------- 8701C Finally if we have any solvents put CCSLV true. 8702C------------------------------------------------------------------- 8703C 8704 CCSLV = (ICHANG.GT.0) 8705 IF (CCSLV) RSPIM = .TRUE. 8706C 8707 IF (CC2 ) NONHF = .TRUE. 8708 8709 IF ( (HFFLD) .AND. (CCFIXF) ) THEN 8710 WRITE(LUPRI,*) 'You have specified both CCFIXF and HFFLD. 8711 & Make a choice!' 8712 CALL QUIT('Error in PECC input') 8713 ENDIF 8714C 8715 RETURN 8716 END 8717 8718c/* deck cc_r12in */ 8719 SUBROUTINE CC_R12IN(WORD) 8720C Purpose: Read input for R12 calculations. 8721C Written by Wim Klopper (University of Karlsruhe, 22 November 2002). 8722#include "implicit.h" 8723#include "priunit.h" 8724#include "r12int.h" 8725CCN 8726#include "maxorb.h" 8727#include "infinp.h" 8728CCN 8729 LOGICAL SET 8730 CHARACTER SECNAM*(8) 8731 PARAMETER (SECNAM='CC_R12IN') 8732 PARAMETER (NTABLE = 22, D0 = 0.0D0) 8733 CHARACTER WORD*(7) 8734 CHARACTER TABLE(NTABLE)*(7) 8735 CHARACTER*120 CC2LAB 8736 DATA TABLE /'.NO HYB','.NO A ',".NO A' ",'.NO B ', 8737 & '.NO RXR','.R12THR','.SVDTHR','.R12XXL', 8738 & '.R12DIA','.R12SVD','.R12LEV','.R12RST', 8739 & '.BASSCL','.NO 1 ','.NO 2 ','.R12PRP', 8740 & '.CABS ',".NO B' ",'.NO 3 ','.CC2 ', 8741 & '.NATVIR','.CCVABK'/ 8742 DATA SET/.FALSE./ 8743 R12LEV = D0 8744 IF (SET) RETURN 8745 SET = .TRUE. 8746 IF (WORD(1:4) .EQ. '*R12') THEN 8747 100 CONTINUE 8748 READ (LUCMD,'(A7)') WORD 8749 CALL UPCASE(WORD) 8750 DO WHILE ( WORD(1:1) .EQ. '!' .OR. WORD(1:1) .EQ. '#' ) 8751 READ (LUCMD,'(A7)') WORD 8752 CALL UPCASE(WORD) 8753 END DO 8754 IF (WORD(1:1) .EQ. '.') THEN 8755 IJUMP = 1 8756 DO WHILE ( IJUMP .LE. NTABLE .AND. TABLE(IJUMP) .NE. WORD) 8757 IJUMP = IJUMP + 1 8758 END DO 8759 IF (IJUMP .LE. NTABLE) THEN 8760 GOTO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20, 8761 & 21,22), IJUMP 8762 CALL QUIT('Illegal address in computed GOTO in CC_R12IN.') 8763 1 CONTINUE 8764 R12HYB = .FALSE. 8765 GO TO 100 8766 2 CONTINUE 8767 R12NOA = .TRUE. 8768 GO TO 100 8769 3 CONTINUE 8770 R12NOP = .TRUE. 8771 GO TO 100 8772 4 CONTINUE 8773 R12NOB = .TRUE. 8774 GO TO 100 8775 5 CONTINUE 8776 NORXR = .TRUE. 8777 GO TO 100 8778 6 CONTINUE 8779 READ (LUCMD, *) VCLTHR 8780 GO TO 100 8781 7 CONTINUE 8782 READ (LUCMD, *) SVDTHR 8783 GO TO 100 8784 8 CONTINUE 8785 R12XXL = .TRUE. 8786 GO TO 100 8787 9 CONTINUE 8788 R12DIA = .TRUE. 8789 R12SVD = .FALSE. 8790 GO TO 100 8791 10 CONTINUE 8792 R12SVD = .TRUE. 8793 R12DIA = .FALSE. 8794 GO TO 100 8795 11 CONTINUE 8796 READ (LUCMD, *) R12LEV 8797 GO TO 100 8798 12 CONTINUE 8799 R12RST = .TRUE. 8800 GO TO 100 8801 13 CONTINUE 8802 READ (LUCMD, *) BRASCL, KETSCL 8803 GO TO 100 8804 14 CONTINUE 8805 NOTONE = .TRUE. 8806 GO TO 100 8807 15 CONTINUE 8808 NOTTWO = .TRUE. 8809 GO TO 100 8810 16 CONTINUE 8811 R12PRP = .TRUE. 8812 IANCC2 = 1 8813 IF (R12NOB) IAPCC2 = 1 8814 IF (R12XXL) IAPCC2 = 2 8815celena 8816 IF (R12PRP .AND. .NOT. NOTTWO) THEN 8817 NOTTWO = .TRUE. 8818 NWARN = NWARN + 1 8819 write(lupri,'(/A/A)') '@ WARNING', 8820 & '@ Sorry, calculation of R12 corrections to '// 8821 & 'first order properties using '// 8822 & 'Ansatz 2 not implemented. '// 8823 & 'Ansatz 2 will be ignored.' 8824 write(lupri,*) 8825 ENDIF 8826celena 8827 GO TO 100 8828 17 CONTINUE 8829 R12CBS = .TRUE. 8830 GO TO 100 8831 18 CONTINUE 8832 NOBP = .TRUE. 8833 GO TO 100 8834 19 CONTINUE 8835 NOTTRE = .TRUE. 8836 GO TO 100 8837 20 CONTINUE 8838 DO I = 1, 120 8839 CC2LAB(I:I) = ' ' 8840 ENDDO 8841 READ (LUCMD,'(A)') CC2LAB 8842 DO I = 1, 120 8843 IF (CC2LAB(I:I) .NE. ' ') THEN 8844 READ (CC2LAB(I:I),'(I1)',ERR=300) IANCC2 8845 GOTO 201 8846 END IF 8847 ENDDO 8848 GOTO 300 8849 201 CONTINUE 8850 DO I = 120, 1, -1 8851 IF (CC2LAB(I:I) .NE. ' ') THEN 8852 IF (CC2LAB(I:I) .EQ. 'A') THEN 8853 IAPCC2 = 1 8854 GOTO 100 8855 ELSE IF (CC2LAB(I:I) .EQ. 'B') THEN 8856 IAPCC2 = 2 8857 GOTO 100 8858 ELSE 8859 GOTO 300 8860 END IF 8861 END IF 8862 END DO 8863 GO TO 300 8864 21 CONTINUE ! .NATVIR 8865 NATVIR = .TRUE. 8866 R12NOA = .TRUE. 8867 R12NOP = .TRUE. 8868 NOTTWO = .TRUE. 8869 NOTTRE = .TRUE. 8870 GO TO 100 8871 22 CONTINUE ! .CCVABKL 8872 !use V^(alpha beta)_(kl) intermediate 8873 USEVABKL = .TRUE. 8874 GO TO 100 8875 ELSE 8876 WRITE (LUPRI,'(/5A/)') ' Prompt "',WORD, 8877 & '" not recognized in ',SECNAM,'.' 8878 CALL PRTAB(NTABLE,TABLE,SECNAM//' input keywords',LUPRI) 8879 CALL QUIT('Illegal Keyword in '//SECNAM//'.') 8880 END IF 8881 8882 ELSE IF (WORD(1:1) .NE. '*') THEN 8883 WRITE (LUPRI,'(/5A/)') 'PROMPT "',WORD, 8884 & '" NOT RECOGNIZED IN ',SECNAM,'.' 8885 CALL QUIT('Illegal prompt in '//SECNAM//'.') 8886 ELSE IF (WORD(1:1) .EQ.'*') THEN 8887 BACKSPACE (LUCMD) 8888 GO TO 200 8889 END IF 8890 END IF 8891 200 CONTINUE 8892 8893 NORXR = NORXR .OR. R12HYB 8894 8895 IF (IANCC2 .NE. 0) THEN 8896 IF (IANCC2 .EQ. 1) THEN 8897 NOTTWO = .TRUE. 8898 NOTTRE = .TRUE. 8899 IF (IAPCC2 .EQ. 1) THEN 8900 IF (NATVIR) THEN 8901 R12NOA = .FALSE. 8902 R12NOP = .FALSE. 8903 R12NOB = .TRUE. 8904 NORXR = .TRUE. 8905 END IF 8906 IAP = 2 8907 ELSE IF (IAPCC2 .EQ. 2) THEN 8908 IF (NATVIR) THEN 8909 R12NOA = .TRUE. 8910 R12NOB = .FALSE. 8911 END IF 8912 IF (NORXR) THEN 8913 IAP = 5 8914 ELSE 8915 IAP = 7 8916 END IF 8917 ELSE 8918 GOTO 300 8919 END IF 8920 ELSE IF (IANCC2 .EQ. 2) THEN 8921 IF (NATVIR) 8922 * CALL QUIT('Sorry, NATVIR for Ansatz 2 not implemented') 8923 NOTONE = .TRUE. 8924 NOTTRE = .TRUE. 8925 IF (IAPCC2 .NE. 2) GOTO 300 8926 IF (NORXR) THEN 8927 IAP = 8 8928 ELSE 8929 IAP = 10 8930 END IF 8931 ELSE IF (IANCC2 .EQ. 3) THEN 8932 IF (NATVIR) 8933 * CALL QUIT('Sorry, NATVIR for Ansatz 3 not implemented') 8934 NOTONE = .TRUE. 8935 NOTTWO = .TRUE. 8936 IF (IAPCC2 .NE. 2) GOTO 300 8937 IF (NORXR) THEN 8938 IAP = 8 8939 ELSE 8940 IAP = 10 8941 END IF 8942 ELSE 8943 GOTO 300 8944 END IF 8945 IAPCC2 = IAP 8946 END IF 8947CCN 8948 DIRFCK = .TRUE. 8949 write(lupri,*) 8950 write(lupri,*)'---- Detected R12 input:' 8951 write(lupri,*)'Direct Fock matrix formation switched on!' 8952CCN 8953 write(lupri,*)'Scale factors for CC excitations manifolds:' 8954 write(lupri,*)'for bra states (projection manifold):',brascl 8955 write(lupri,*)'for ket states (operator manifold) :',ketscl 8956 8957 RETURN 8958 300 write (lupri,*) 'WRONG CC2LAB: ',CC2LAB 8959 CALL QUIT('WRONG CC2LAB') 8960 END 8961C 8962C /* Deck cc_chodbinp */ 8963 SUBROUTINE CC_CHODBINP(WORD) 8964C 8965C Thomas Bondo Pedersen, May 2002. 8966C 8967C Purpose: Read input for CC Cholesky debug input section. 8968C 8969#include "implicit.h" 8970 CHARACTER*7 WORD 8971#include "priunit.h" 8972#include "chodbg.h" 8973 8974 CHARACTER*11 SECNAM 8975 PARAMETER (SECNAM = 'CC_CHODBINP') 8976 8977 PARAMETER (NTABLE = 4) 8978 8979 LOGICAL SET 8980 SAVE SET 8981 8982 CHARACTER*7 TABLE(NTABLE) 8983 8984 DATA SET /.FALSE./ 8985 DATA TABLE /'.DBIAJB','.STIAJB','.DBAOIN','.STAOIN'/ 8986 8987C Test SET. 8988C --------- 8989 8990 IF (SET) RETURN 8991 SET = .TRUE. 8992 8993C Initializations and defaults. 8994C ----------------------------- 8995 8996 DBAOIN = .FALSE. 8997 STAOIN = .FALSE. 8998 DBIAJB = .FALSE. 8999 STIAJB = .FALSE. 9000 ICHANG = 0 9001 9002C Process input section. 9003C ---------------------- 9004 9005 IF (WORD(1:7) .EQ. '*CHODBG') THEN 9006 9007 100 CONTINUE 9008 9009C Read new input line. 9010C -------------------- 9011 9012 READ(LUCMD,'(A7)') WORD 9013 DO WHILE ( WORD(1:1) .EQ. '!' .OR. WORD(1:1) .EQ. '#' ) 9014 READ (LUCMD,'(A7)') WORD 9015 END DO 9016 9017 IF (WORD(1:1) .EQ. '.') THEN 9018 9019 IJUMP = 1 9020 DO WHILE ((IJUMP.LE.NTABLE) .AND. (TABLE(IJUMP).NE.WORD)) 9021 IJUMP = IJUMP + 1 9022 END DO 9023 9024 IF (IJUMP .LE. NTABLE) THEN 9025 9026 ICHANG = ICHANG + 1 9027 GOTO (1,2,3,4), IJUMP 9028 9029 CALL QUIT 9030 & ('Illegal address in computed GOTO in '//SECNAM) 9031 9032 1 CONTINUE 9033C '.DBIAJB' 9034C Test Cholesky (ia|jb) integrals. 9035 DBIAJB = .TRUE. 9036 GOTO 100 9037 9038 2 CONTINUE 9039C '.STIAJB' 9040C Stop after (ia|jb) test. 9041 STIAJB = .TRUE. 9042 GOTO 100 9043 9044 3 CONTINUE 9045C '.DBAOIN' 9046C Test Cholesky AO integrals. 9047 DBAOIN = .TRUE. 9048 GOTO 100 9049 9050 4 CONTINUE 9051C '.STAOIN' 9052C Stop after AO integral test. 9053 STAOIN = .TRUE. 9054 GOTO 100 9055 9056 ELSE 9057 9058 WRITE (LUPRI,'(/5A,/)') ' Prompt "',WORD, 9059 & '" not recognized in ',SECNAM,'.' 9060 CALL PRTAB(NTABLE,TABLE,SECNAM//' input keywords', 9061 & LUPRI) 9062 CALL QUIT('Illegal Keyword in '//SECNAM) 9063 9064 ENDIF 9065 9066 ELSE IF (WORD(1:1) .NE. '*') THEN 9067 9068 WRITE (LUPRI,'(/5A,/)') 'PROMPT "',WORD, 9069 & '" NOT RECOGNIZED IN ',SECNAM,'.' 9070 CALL QUIT('Illegal prompt in '//SECNAM) 9071 9072 ELSE IF (WORD(1:1) .EQ.'*') THEN 9073 9074 BACKSPACE (LUCMD) 9075 GO TO 200 9076 9077 ENDIF 9078 9079 ENDIF 9080 9081 200 CONTINUE 9082 9083C Finally, set overall Cholesky debug flag. 9084C ----------------------------------------- 9085 9086 CHODBG = DBIAJB .OR. DBAOIN 9087 9088 RETURN 9089 END 9090C /* Deck cc_chomp2inp */ 9091 SUBROUTINE CC_CHOMP2INP(WORD) 9092C 9093C Thomas Bondo Pedersen, July 2002. 9094C 9095C Purpose: Read input for Cholesky based MP2 calculation. 9096C 9097#include "implicit.h" 9098 CHARACTER*7 WORD 9099#include "priunit.h" 9100#include "chomp2.h" 9101Casm 9102#include "chomp2_b.h" 9103Casm 9104 9105 CHARACTER*12 SECNAM 9106 PARAMETER (SECNAM = 'CC_CHOMP2INP') 9107 9108 PARAMETER (NTABLE = 20) 9109 9110 LOGICAL SET 9111 SAVE SET 9112 9113 CHARACTER*8 TABLE(NTABLE) 9114 9115 DATA SET /.FALSE./ 9116 DATA TABLE /'.NOCHOM','.THRMP2','.SPAMP2','.MXDECM','.NCHORD', 9117 & '.MP2SAV','.SKIPTR','.SKIPCH','.CHOMO ','.ALGORI', 9118 & '.SPRMP2','.SCRMP2','.SPLITM','.ZERO ','.RSTMP2', 9119 & '.OLDEN2','.XXXXXX','.XXXXXX','.XXXXXX','.XXXXXX'/ 9120 9121C Test SET. 9122C --------- 9123 9124 IF (SET) RETURN 9125 SET = .TRUE. 9126 9127C Initializations and defaults. 9128C Negative values of THRMP2 and SPAMP2 prompt the use of 9129C corresponding AO decomposition values. 9130C ------------------------------------------------------ 9131 9132 CALL CC_CHOMP2INIT 9133 9134C Process input section. 9135C ---------------------- 9136 9137 IF (WORD(1:7) .EQ. '*CHOMP2') THEN 9138 9139 100 CONTINUE 9140 9141C Read new input line. 9142C -------------------- 9143 9144 READ(LUCMD,'(A7)') WORD 9145 DO WHILE ( WORD(1:1) .EQ. '!' .OR. WORD(1:1) .EQ. '#' ) 9146 READ (LUCMD,'(A7)') WORD 9147 END DO 9148 9149 IF (WORD(1:1) .EQ. '.') THEN 9150 9151 IJUMP = 1 9152 DO WHILE ((IJUMP.LE.NTABLE) .AND. (TABLE(IJUMP).NE.WORD)) 9153 IJUMP = IJUMP + 1 9154 END DO 9155 9156 IF (IJUMP .LE. NTABLE) THEN 9157 9158 ICHANG = ICHANG + 1 9159 GOTO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15, 9160 & 16,17,18,19,20), IJUMP 9161 9162 CALL QUIT 9163 & ('Illegal address in computed GOTO in '//SECNAM) 9164 9165 1 CONTINUE 9166C '.NOCHOM' 9167C Do not decompose (ai|bj). 9168 CHOMO = .FALSE. 9169 GOTO 100 9170 9171 2 CONTINUE 9172C '.THRMP2' 9173C Threshold for (ai|bj) decomposition. 9174 READ(LUCMD,*) THRMP2 9175 GOTO 100 9176 9177 3 CONTINUE 9178C '.SPAMP2' 9179C Span factor for (ai|bj) decomposition. 9180 READ(LUCMD,*) SPAMP2 9181 GOTO 100 9182 9183 4 CONTINUE 9184C '.MXDECM' 9185C Max. qualified diagonals in (ai|bj) decomposition. 9186 READ(LUCMD,*) MXDECM 9187COLD IF (MXDECM .GT. MAXMOD) THEN 9188COLD WRITE(LUPRI,'(//,5X,A,A,I10)') 9189COLD & SECNAM,': MXDECM too large. Max. allowed: ',MAXMOD 9190COLD CALL QUIT('Input error in '//SECNAM) 9191COLD ELSE IF (MXDECM .LE. 0) THEN 9192 IF (MXDECM .LE. 0) THEN 9193 WRITE(LUPRI,'(5X,A,A,I10)') 9194 & SECNAM,': MXDECM must be positive!' 9195 CALL QUIT('Input error in '//SECNAM) 9196 ENDIF 9197 GOTO 100 9198 9199 5 CONTINUE 9200C '.NCHORD' 9201C Max. prev. vectors in (ai|bj) decomposition. 9202 READ(LUCMD,*) NCHORD 9203 IF (NCHORD .LE. 0) THEN 9204 WRITE(LUPRI,'(5X,A,A,I10)') 9205 & SECNAM,': NCHORD must be positive!' 9206 CALL QUIT('Input error in '//SECNAM) 9207 ENDIF 9208 GOTO 100 9209 9210 6 CONTINUE 9211C '.MP2SAV' 9212C Save MP2 amplitudes on disk. 9213 MP2SAV = .TRUE. 9214 GOTO 100 9215 9216 7 CONTINUE 9217C '.SKIPTR' 9218C Skip MO transformation; use old vectors. 9219 SKIPTR = .TRUE. 9220 GOTO 100 9221 9222 8 CONTINUE 9223C '.SKIPCH' 9224C Skip (ai|bj) decompositon; read info from disk 9225 SKIPCH = .TRUE. 9226 GOTO 100 9227 9228 9 CONTINUE 9229C '.CHOMO ' 9230C (ai|bj) decompositon 9231 CHOMO = .TRUE. 9232 GOTO 100 9233 9234 10 CONTINUE 9235C '.ALGORI' 9236C algorithm: 9237C <1: decided by MP2 routine (default, IALMP2=0) 9238C 1: force storage of full-square (ia|jb) in core 9239C 2: batch over one virtual index 9240C 3: batch over two virtual indices 9241C >3: same as <1. 9242 READ(LUCMD,*) IALMP2 9243 GOTO 100 9244 9245 11 CONTINUE 9246C '.SPRMP2' 9247C Use sparse representation of Cholesky vector. 9248 SPRMP2 = .TRUE. 9249 GOTO 100 9250 9251 12 CONTINUE 9252C '.SCRMP2' 9253C Screening threshold for sparse representation. 9254 READ(LUCMD,*) SCRMP2 9255 GOTO 100 9256 9257 13 CONTINUE 9258C '.SPLITM' 9259C Weight factor for Cholesky part in memory split for 9260C virtual batch algorithms. 9261 READ(LUCMD,*) TMP 9262 IF (TMP .GT. 0.0D0) SPLITM = TMP 9263 GOTO 100 9264 9265 14 CONTINUE 9266C '.ZERO ' 9267C Threshold for diagonal zeroing in decompositions. 9268 READ(LUCMD,*) THZMP2 9269 GOTO 100 9270 9271 15 CONTINUE 9272C '.RSTMP2' 9273C Restart MP2 9274 RSTMP2 = .TRUE. 9275 READ(LUCMD,*) IFSYMB, IFVIRB 9276 GOTO 100 9277 9278 16 CONTINUE 9279C '.OLDEN2' 9280C Old MP2 energy (if desided) 9281 OLDKNO = .TRUE. 9282 READ(LUCMD,*) OLDEN2 9283 GOTO 100 9284 9285 17 CONTINUE 9286 18 CONTINUE 9287 19 CONTINUE 9288 20 CONTINUE 9289C '.XXXXXX' 9290C Not used 9291 GOTO 100 9292 9293 ELSE 9294 9295 WRITE (LUPRI,'(/5A,/)') ' Prompt "',WORD, 9296 & '" not recognized in ',SECNAM,'.' 9297 CALL PRTAB(NTABLE,TABLE,SECNAM//' input keywords', 9298 & LUPRI) 9299 CALL QUIT('Illegal Keyword in '//SECNAM) 9300 9301 ENDIF 9302 9303 ELSE IF (WORD(1:1) .NE. '*') THEN 9304 9305 WRITE (LUPRI,'(/5A,/)') 'PROMPT "',WORD, 9306 & '" NOT RECOGNIZED IN ',SECNAM,'.' 9307 CALL QUIT('Illegal prompt in '//SECNAM) 9308 9309 ELSE IF (WORD(1:1) .EQ.'*') THEN 9310 9311 BACKSPACE (LUCMD) 9312 GO TO 200 9313 9314 ENDIF 9315 9316 ENDIF 9317 9318 200 CONTINUE 9319 9320 9321 RETURN 9322 END 9323C /* Deck cc_chocc2inp */ 9324 SUBROUTINE CC_CHOCC2INP(WORD) 9325C 9326C Thomas Bondo Pedersen, August 2002. 9327C 9328C Purpose: Read input for Cholesky based CC2 calculation. 9329C 9330#include "implicit.h" 9331 CHARACTER*7 WORD 9332#include "priunit.h" 9333#include "chocc2.h" 9334 9335 CHARACTER*12 SECNAM 9336 PARAMETER (SECNAM = 'CC_CHOCC2INP') 9337 9338 PARAMETER (NTABLE = 15) 9339 9340 LOGICAL SET 9341 SAVE SET 9342 9343 CHARACTER*8 TABLE(NTABLE) 9344 9345 DATA SET /.FALSE./ 9346 DATA TABLE /'.CHOMO ','.THRCC2','.SPACC2','.MXDECM','.NCHORD', 9347 & '.XXXXXX','.CHOT2 ','.NOCHOM','.ALGORI','.THRCCC', 9348 & '.SPACCC','.SPLITM','.ZERO ','.XXXXXX','.XXXXXX'/ 9349 9350C Test SET. 9351C --------- 9352 9353 IF (SET) RETURN 9354 SET = .TRUE. 9355 9356C Initializations and defaults. 9357C Negative values of THRCC2 and SPACC2 prompt the use of 9358C corresponding AO decomposition values. 9359C ------------------------------------------------------ 9360 9361 CALL CC_CHOCC2INIT 9362 9363C Process input section. 9364C ---------------------- 9365 9366 IF (WORD(1:7) .EQ. '*CHOCC2') THEN 9367 9368 100 CONTINUE 9369 9370C Read new input line. 9371C -------------------- 9372 9373 READ(LUCMD,'(A7)') WORD 9374 DO WHILE ( WORD(1:1) .EQ. '!' .OR. WORD(1:1) .EQ. '#' ) 9375 READ (LUCMD,'(A7)') WORD 9376 END DO 9377 9378 IF (WORD(1:1) .EQ. '.') THEN 9379 9380 IJUMP = 1 9381 DO WHILE ((IJUMP.LE.NTABLE) .AND. (TABLE(IJUMP).NE.WORD)) 9382 IJUMP = IJUMP + 1 9383 END DO 9384 9385 IF (IJUMP .LE. NTABLE) THEN 9386 9387 ICHANG = ICHANG + 1 9388 GOTO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15), IJUMP 9389 9390 CALL QUIT 9391 & ('Illegal address in computed GOTO in '//SECNAM) 9392 9393 1 CONTINUE 9394C '.CHOMO ' 9395C Decompose (ai|bj) (=> CHOT2 = .FALSE.). 9396 CHOT2 = .FALSE. 9397 CHOMO2 = .TRUE. 9398 GOTO 100 9399 9400 2 CONTINUE 9401C '.THRCC2' 9402C Threshold for decomposition. 9403 READ(LUCMD,*) THRCC2 9404 GOTO 100 9405 9406 3 CONTINUE 9407C '.SPACC2' 9408C Span factor for decomposition. 9409 READ(LUCMD,*) SPACC2 9410 GOTO 100 9411 9412 4 CONTINUE 9413C '.MXDECM' 9414C Max. qualified diagonals in decomposition. 9415 READ(LUCMD,*) MXDEC2 9416 IF (MXDEC2 .LE. 0) THEN 9417 WRITE(LUPRI,'(5X,A,A,I10)') 9418 & SECNAM,': .MXDECM input must be positive!' 9419 CALL QUIT('Input error in '//SECNAM) 9420 ENDIF 9421 GOTO 100 9422 9423 5 CONTINUE 9424C '.NCHORD' 9425C Max. prev. vectors in decomposition. 9426 READ(LUCMD,*) NCHRD2 9427 IF (NCHRD2 .LE. 0) THEN 9428 WRITE(LUPRI,'(5X,A,A,I10)') 9429 & SECNAM,': .NCHORD input must be positive!' 9430 CALL QUIT('Input error in '//SECNAM) 9431 ENDIF 9432 GOTO 100 9433 9434 6 CONTINUE 9435C '.XXXXXX' 9436 GOTO 100 9437 9438 7 CONTINUE 9439C '.CHOT2 ' 9440C Decompose CC2 T2 amplitudes. (=> CHOMO2 = .FALSE.) 9441 CHOT2 = .TRUE. 9442 CHOMO2 = .FALSE. 9443 GOTO 100 9444 9445 8 CONTINUE 9446C '.NOCHOM' 9447C No decompositions in CC2 section. 9448 CHOT2 = .FALSE. 9449 CHOMO2 = .FALSE. 9450 GOTO 100 9451 9452 9 CONTINUE 9453C '.ALGORI' 9454C Set algorithm (=1 for single virtual batch, =2 for double) 9455 READ(LUCMD,*) IALGO 9456 IF (IALGO .LE. 1) THEN 9457 IALCC2 = 1 9458 ELSE 9459 IALCC2 = 2 9460 ENDIF 9461 GOTO 100 9462 9463 10 CONTINUE 9464C '.THRCCC' 9465C Threshold to use in amplitude decomposition for 9466C response intermediates and right-hand sides. 9467 READ(LUCMD,*) THRCCC 9468 GOTO 100 9469 9470 11 CONTINUE 9471C '.SPACCC' 9472C Span factor to use in amplitude decomposition for 9473C response intermediates and right-hand sides. 9474 READ(LUCMD,*) SPACCC 9475 GOTO 100 9476 9477 12 CONTINUE 9478C '.SPLITM' 9479C Weight factor for Cholesky part in memory split for 9480C batching over virtuals. 9481 READ(LUCMD,*) TMP 9482 IF (TMP .GT. 0.0D0) SPLITC = TMP 9483 GOTO 100 9484 9485 13 CONTINUE 9486C '.ZERO ' 9487C Threshold for diagonal zeroing in decompositions. 9488 READ(LUCMD,*) THZCC2 9489 GOTO 100 9490 9491 14 CONTINUE 9492C '.XXXXXX' 9493C Not used. 9494 GOTO 100 9495 9496 15 CONTINUE 9497C '.XXXXXX' 9498C Not used. 9499 GOTO 100 9500 9501 ELSE 9502 9503 WRITE (LUPRI,'(/5A,/)') ' Prompt "',WORD, 9504 & '" not recognized in ',SECNAM,'.' 9505 CALL PRTAB(NTABLE,TABLE,SECNAM//' input keywords', 9506 & LUPRI) 9507 CALL QUIT('Illegal Keyword in '//SECNAM) 9508 9509 ENDIF 9510 9511 ELSE IF (WORD(1:1) .NE. '*') THEN 9512 9513 WRITE (LUPRI,'(/5A,/)') 'PROMPT "',WORD, 9514 & '" NOT RECOGNIZED IN ',SECNAM,'.' 9515 CALL QUIT('Illegal prompt in '//SECNAM) 9516 9517 ELSE IF (WORD(1:1) .EQ.'*') THEN 9518 9519 BACKSPACE (LUCMD) 9520 GO TO 200 9521 9522 ENDIF 9523 9524 ENDIF 9525 9526 200 CONTINUE 9527 9528 RETURN 9529 END 9530C /* Deck cc_chomp2init */ 9531 SUBROUTINE CC_CHOMP2INIT 9532C 9533C Thomas Bondo Pedersen, October 2002. 9534C 9535C Initialize chomp2.h 9536#include "implicit.h" 9537#include "chomp2.h" 9538 9539 MP2SAV = .FALSE. 9540 CHOMO = .FALSE. 9541 SKIPTR = .FALSE. 9542 SKIPCH = .FALSE. 9543 THRMP2 = -1.0D8 9544 SPAMP2 = -1.0D8 9545 MXDECM = 50 9546 NCHORD = 200 9547 THZMP2 = -1.0D8 9548 IALMP2 = 0 9549 SPRMP2 = .FALSE. 9550 SCRMP2 = -1.0D8 9551 SPLITM = 1.0D0 9552 9553 RETURN 9554 END 9555C /* Deck cc_chocc2init */ 9556 SUBROUTINE CC_CHOCC2INIT 9557C 9558C Thomas Bondo Pedersen, October 2002. 9559C 9560C Initialize chocc2.h 9561#include "implicit.h" 9562#include "chocc2.h" 9563Casm 9564#include "chomp2_b.h" 9565C 9566 LOGICAL SET 9567 SAVE SET 9568 DATA SET /.FALSE./ 9569 9570C 9571 IF (SET) THEN 9572 RETURN 9573 ELSE 9574 SET = .TRUE. 9575 END IF 9576Casm 9577 IALCC2 = 2 9578 CHOT2 = .FALSE. 9579 CHOMO2 = .FALSE. 9580 CHOT2C = .FALSE. 9581 DSKETA = .FALSE. 9582 DSKFY2 = .FALSE. 9583 THRCC2 = -1.0D8 9584 SPACC2 = -1.0D8 9585 MXDEC2 = 50 9586 NCHRD2 = 200 9587 THZCC2 = -1.0D8 9588 THRCCC = THRCC2 9589 SPACCC = SPACC2 9590 MXDECC = MXDEC2 9591 NCHRDC = NCHRD2 9592 SPLITC = 1.0D0 9593 9594Casm 9595 RSTMP2 = .FALSE. 9596 OLDKNO = .FALSE. 9597 OLDEN2 = 0.0D0 9598Casm 9599 RETURN 9600 END 9601C /* Deck cc_choptinit */ 9602 SUBROUTINE CC_CHOPTINIT 9603C 9604C TBP, JLC, BFR, AS, and HK, May 2003. 9605C 9606C Purpose: Set defaults for Cholesky denominator CCSD(T) program. 9607C 9608#include "implicit.h" 9609 PARAMETER (ZERO = 0.0D0) 9610#include "cc_cho.h" 9611 9612 MXCHVE = MIN(MAXCHO,10) 9613 THRCHO = -1.0D10 9614Casm 9615C 9616C Virtual part 9617C 9618 RSTVIR = .FALSE. 9619 IFVISY = 1 9620 IFVIOR = 1 9621C 9622C Occupied part 9623C 9624 RSTH = .FALSE. 9625 RSTH1 = .FALSE. 9626 RSTF1 = .FALSE. 9627 RSTC1 = .FALSE. 9628 RSTC2 = .FALSE. 9629C 9630C Files 9631C 9632 SKIVI1 = .FALSE. 9633 SKIVI2 = .FALSE. 9634C 9635C Previous values 9636C 9637 UKNE4V = .TRUE. 9638 UKNE5V = .TRUE. 9639 UKNE4O = .TRUE. 9640 UKNE5O = .TRUE. 9641C 9642 OLD4V = ZERO 9643 OLD5V = ZERO 9644 OLD4O = ZERO 9645 OLD5O = ZERO 9646Casm 9647 RETURN 9648 END 9649C /* Deck cc_choptinp */ 9650 SUBROUTINE CC_CHOPTINP(WORD) 9651C 9652C TBP, JLC, BFR, AS, and HK, May 2003. 9653C 9654C Purpose: Process input for changing defaults for the Cholesky denominator 9655C CCSD(T) program. 9656C 9657#include "implicit.h" 9658 CHARACTER*7 WORD 9659#include "priunit.h" 9660#include "cc_cho.h" 9661 9662 CHARACTER*11 SECNAM 9663 PARAMETER (SECNAM = 'CC_CHOPTINP') 9664 9665 PARAMETER (NTABLE = 15) 9666 9667 LOGICAL SET 9668 SAVE SET 9669 9670 CHARACTER*8 TABLE(NTABLE) 9671 9672 DATA SET /.FALSE./ 9673 DATA TABLE /'.MXCHVE','.THRCHO','.RSTVIR','.RSTH ','.RSTH1 ', 9674 & '.RSTF1 ','.RSTC1 ','.RSTC2 ','.SKIVI1','.SKIVI2', 9675 & '.OLD4V ','.OLD5V ','.OLD4O ','.OLD5O ','.XXXXXX'/ 9676 9677C Test SET. 9678C --------- 9679 9680 IF (SET) RETURN 9681 SET = .TRUE. 9682 9683C Set defaults. 9684C ------------- 9685 9686 CALL CC_CHOPTINIT 9687 9688C Process input section. 9689C ---------------------- 9690 9691 IF (WORD(1:7) .EQ. '*CHO(T)') THEN 9692 9693 100 CONTINUE 9694 9695C Read new input line. 9696C -------------------- 9697 9698 READ(LUCMD,'(A7)') WORD 9699 DO WHILE ( WORD(1:1) .EQ. '!' .OR. WORD(1:1) .EQ. '#' ) 9700 READ (LUCMD,'(A7)') WORD 9701 END DO 9702 9703 IF (WORD(1:1) .EQ. '.') THEN 9704 9705 IJUMP = 1 9706 DO WHILE ((IJUMP.LE.NTABLE) .AND. (TABLE(IJUMP).NE.WORD)) 9707 IJUMP = IJUMP + 1 9708 END DO 9709 9710 IF (IJUMP .LE. NTABLE) THEN 9711 9712 ICHANG = ICHANG + 1 9713 GOTO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15), IJUMP 9714 9715 CALL QUIT 9716 & ('Illegal address in computed GOTO in '//SECNAM) 9717 9718 1 CONTINUE 9719C '.MXCHVE' 9720C Maximum number of Cholesky vectors used. 9721 NCHDEF = MXCHVE 9722 READ(LUCMD,*) MXCHVE 9723 IF (MXCHVE .LE. 0) THEN 9724 WRITE(LUPRI,'(/,1X,A,A,A,I10,A,/,1X,A,I10,/)') 9725 & SECNAM,': NOTICE: Number of Cholesky vectors ', 9726 & 'specified (',MXCHVE,')', 9727 & 'is reset to the default value ',NCHDEF 9728 MXCHVE = NCHDEF 9729 ELSE IF (MXCHVE .GT. MAXCHO) THEN 9730 WRITE(LUPRI,'(/,1X,A,A,A,I10,A,/,1X,A,I10,/)') 9731 & SECNAM,': NOTICE: Number of Cholesky vectors ', 9732 & 'specified (',MXCHVE,')', 9733 & 'is reset to the maximum value ',MAXCHO 9734 MXCHVE = MAXCHO 9735 ENDIF 9736 GOTO 100 9737 9738 2 CONTINUE 9739C '.THRCHO' 9740C Threshold for skipping remaining Cholesky vectors in each 9741C term. 9742 READ(LUCMD,*) THRCHO 9743 GO TO 100 9744 9745 3 CONTINUE 9746 RSTVIR = .TRUE. 9747 READ(LUCMD,*) IFVISY,IFVIOR 9748 GO TO 100 9749 9750 4 CONTINUE 9751 RSTH = .TRUE. 9752 GO TO 100 9753C 9754 5 CONTINUE 9755 RSTH1 = .TRUE. 9756 GO TO 100 9757C 9758 6 CONTINUE 9759 RSTF1 = .TRUE. 9760 GO TO 100 9761C 9762 7 CONTINUE 9763 RSTC1 = .TRUE. 9764 GO TO 100 9765C 9766 8 CONTINUE 9767 RSTC2 = .TRUE. 9768 GO TO 100 9769C 9770 9 CONTINUE 9771 SKIVI1 = .TRUE. 9772 GO TO 100 9773C 9774 10 CONTINUE 9775 SKIVI2 = .TRUE. 9776 GO TO 100 9777 9778 11 CONTINUE 9779 UKNE4V = .FALSE. 9780 READ(LUCMD,*) OLD4V 9781 GO TO 100 9782 9783 12 CONTINUE 9784 UKNE5V = .FALSE. 9785 READ(LUCMD,*) OLD5V 9786 GO TO 100 9787 9788 13 CONTINUE 9789 UKNE4O = .FALSE. 9790 READ(LUCMD,*) OLD4O 9791 GO TO 100 9792 9793 14 CONTINUE 9794 UKNE5O = .FALSE. 9795 READ(LUCMD,*) OLD5O 9796 GO TO 100 9797 9798 15 CONTINUE 9799C Not used 9800 GO TO 100 9801 9802 ELSE 9803 9804 WRITE (LUPRI,'(/5A,/)') ' Prompt "',WORD, 9805 & '" not recognized in ',SECNAM,'.' 9806 CALL PRTAB(NTABLE,TABLE,SECNAM//' input keywords', 9807 & LUPRI) 9808 CALL QUIT('Illegal Keyword in '//SECNAM) 9809 9810 ENDIF 9811 9812 ELSE IF (WORD(1:1) .NE. '*') THEN 9813 9814 WRITE (LUPRI,'(/5A,/)') 'PROMPT "',WORD, 9815 & '" NOT RECOGNIZED IN ',SECNAM,'.' 9816 CALL QUIT('Illegal prompt in '//SECNAM) 9817 9818 ELSE IF (WORD(1:1) .EQ.'*') THEN 9819 9820 BACKSPACE (LUCMD) 9821 GO TO 200 9822 9823 ENDIF 9824 9825 ENDIF 9826 9827 200 CONTINUE 9828 9829 RETURN 9830C 9831C 9832 END 9833C /* Deck cc_ctomag */ 9834 SUBROUTINE CC_CTOMAG 9835C 9836C asm September 2005 9837C 9838C Purpose: Set up operator list for CTOCD calculations 9839C 9840C 9841#include "implicit.h" 9842#include "priunit.h" 9843#include "cclrinf.h" 9844#include "ctocdcc.h" 9845C 9846 PARAMETER (MAXOPR = 10 * MXLROP) 9847C 9848 CHARACTER*8 RECORD(4), STARS, LABEL, LABELA, LABELB 9849 PARAMETER (STARS = '********') 9850C 9851 CHARACTER*8 LSTLBL(MAXOPR) 9852 INTEGER SYMLBL(MAXOPR) 9853C 9854 LOGICAL SET,LF 9855 SAVE SET 9856 DATA SET /.FALSE./ 9857 DATA LF /.FALSE./ 9858C 9859C 9860 IF (SET) RETURN 9861 SET = .TRUE. 9862C 9863 LUPROP = -1 9864 CALL GPOPEN(LUPROP,'AOPROPER','OLD',' ','UNFORMATTED',IDUMMY, 9865 & .FALSE.) 9866 REWIND(LUPROP) 9867C 9868C Read labels in AOPROPER and sort 9869C 9870 NOPER = 0 9871 100 CONTINUE 9872 READ(LUPROP, END=200, ERR=300) RECORD 9873 IF (RECORD(1) .NE. STARS) THEN 9874 GOTO 100 9875 ELSE 9876 LABEL = RECORD(4) 9877 IF ((LABEL .EQ. 'HUCKOVLP') .OR. (LABEL .EQ. 'HUCKEL ') 9878 & .OR. (LABEL .EQ. 'OVERLAP ')) GOTO 100 9879C 9880 NOPER = NOPER + 1 9881 IF (NOPER .GT. MAXOPR) 9882 & CALL QUIT('Too many label found by CC_CTOMAG') 9883C 9884 READ(RECORD(2),'(I1)') SYMLBL(NOPER) 9885 LSTLBL(NOPER) = LABEL 9886 END IF 9887 GOTO 100 9888C 9889 200 CONTINUE 9890C 9891C Select pairs of operators to compute 9892C 9893 DO I = 1,NOPER 9894C 9895 LABELA = LSTLBL(I) 9896 ISYMA = SYMLBL(I) 9897C 9898 IF (LABELA(2:7) .EQ. 'DIPVEL') THEN ! Most of ctocd properties 9899C 9900 DO J = 1,NOPER 9901C 9902 LABELB = LSTLBL(J) 9903 ISYMB = SYMLBL(J) 9904C 9905 IF (ISYMA .EQ. ISYMB) THEN ! Otherwise, sop is zero 9906C 9907 IF (LABELB(3:6) .EQ. 'RANG') THEN !Dia suscep 9908 IF (CTOSUS) 9909 & CALL CC_LRINPREQ(LABELA,LABELB,1,1,LF,LF) 9910 ELSE IF (LABELB(4:7) .EQ. 'RPSO') THEN !Dia shield 9911 IF (CTOSHI) 9912 & CALL CC_LRINPREQ(LABELA,LABELB,1,1,LF,LF) 9913 ELSE IF (LABELB(1:3) .EQ. 'PSO') THEN !Shift shield 9914 IF (CTOSHI) 9915 & CALL CC_LRINPREQ(LABELA,LABELB,1,1,LF,LF) 9916 END IF 9917C 9918 END IF 9919C 9920 END DO 9921C 9922 ELSE IF (CTOSUS .AND. (LABELA(2:7) .EQ. 'ANGMOM')) THEN !Para suscep 9923C 9924 DO J = 1,NOPER 9925C 9926 LABELB = LSTLBL(J) 9927 ISYMB = SYMLBL(J) 9928C 9929 IF (ISYMA .EQ. ISYMB) THEN ! Otherwise, sop is zero 9930C 9931 IF (LABELB(2:7) .EQ. 'ANGMOM') THEN 9932 CALL CC_LRINPREQ(LABELA,LABELB,1,1,LF,LF) 9933 END IF 9934C 9935 END IF 9936C 9937 END DO 9938C 9939 ELSE IF (CTOSHI .AND. (LABELA(1:3) .EQ. 'PSO')) THEN !Para shield 9940C 9941 DO J = 1,NOPER 9942C 9943 LABELB = LSTLBL(J) 9944 ISYMB = SYMLBL(J) 9945C 9946 IF (ISYMA .EQ. ISYMB) THEN ! Otherwise, sop is zero 9947C 9948 IF (LABELB(2:7) .EQ. 'ANGMOM') THEN 9949 CALL CC_LRINPREQ(LABELA,LABELB,1,1,LF,LF) 9950 END IF 9951C 9952 END IF 9953C 9954 END DO 9955C 9956 END IF 9957C 9958 END DO 9959 GOTO 999 9960C 9961 300 CALL QUIT('Error when reading in CC_CTOMAG') 9962C 9963 999 CONTINUE 9964 CALL GPCLOSE(LUPROP,'KEEP') 9965C 9966 RETURN 9967 END 9968C 9969C /* Deck cc_actinp */ 9970 SUBROUTINE CC_ACTINP(WORD,MSYM) 9971C 9972C Alfredo Sanchez de Meras. May 2008 9973C 9974C Purpose: Read input for CC Active section 9975C 9976#include "implicit.h" 9977 CHARACTER*7 WORD 9978#include "priunit.h" 9979#include "mxcent.h" 9980#include "nuclei.h" 9981#include "center.h" 9982#include "maxorb.h" 9983#include "peract.h" 9984 9985 CHARACTER*9 SECNAM 9986 PARAMETER (SECNAM = 'CC_ACTINP') 9987C 9988 PARAMETER (NTABLE = 22) 9989 CHARACTER*7 TABLE(NTABLE) 9990 DATA TABLE /'.ATOMIC','.BOXDEF','.ACTFRE','.DIFADD','.NBOEXP', 9991 & '.NODRSL','.THACOC','.THACVI','.DIALST','.ORDER ', 9992 & '.FULDEC','.DOSPRE','.MINSPR','.LIMLOC','.EXTERN', 9993 & '.SPACES','.LIMSPA','.OMEZER','.SPDILS','.LOCONL', 9994 & '.ADDORB','.ADDEXP'/ 9995C 9996 LOGICAL SET, CHKACT 9997 SAVE SET 9998 DATA SET /.FALSE./ 9999 DATA CHKACT /.FALSE./ 10000 DATA NEWACT /.FALSE./ 10001C 10002C 10003 IF (SET) RETURN 10004 SET = .TRUE. 10005C 10006C Initializations 10007C 10008 ATOMIC = .FALSE. 10009 ACTFRE = .FALSE. 10010 DIFADD = .FALSE. 10011 NBOEXP = .FALSE. 10012 SELDIR = .TRUE. 10013 DIALST = .FALSE. 10014 ACTSEL = .TRUE. 10015 LIMLOC = .FALSE. 10016 EXTERN = .FALSE. 10017 LIMSPA = .FALSE. 10018 PERTCC = .FALSE. 10019 LOCONL = .FALSE. 10020 ADDORB = .FALSE. 10021 ADDEXP = .FALSE. 10022C 10023 IEXPOC = 0 10024 IEXPVI = 0 10025C 10026 CALL IZERO(IACORB,8*MXCORB) 10027C 10028 DOSPREAD = .FALSE. 10029 MINSPR = .FALSE. 10030C 10031 THACOC = 1.0D-2 10032 THACVI = 1.0D-2 10033C 10034 NSPACE = 0 10035C 10036ctmp DO I = 1,NUCIND 10037ctmp IORDEC(I) = I 10038ctmp END DO 10039C 10040 ICHANG = 0 10041C 10042C Process input section. 10043C 10044 IF (WORD(1:7) .EQ. '*CHOACT') THEN 10045C 10046 100 CONTINUE 10047C 10048C Read new input line. 10049C 10050 READ(LUCMD,'(A7)') WORD 10051 DO WHILE ( WORD(1:1) .EQ. '!' .OR. WORD(1:1) .EQ. '#' ) 10052 READ (LUCMD,'(A7)') WORD 10053 END DO 10054C 10055 IF (WORD(1:1) .EQ. '.') THEN 10056C 10057 IJUMP = 1 10058 DO WHILE ((IJUMP.LE.NTABLE) .AND. (TABLE(IJUMP).NE.WORD)) 10059 IJUMP = IJUMP + 1 10060 END DO 10061C 10062 IF (IJUMP .LE. NTABLE) THEN 10063C 10064 ICHANG = ICHANG + 1 10065 GOTO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15, 10066 & 16,17,18,19,20,21,22), IJUMP 10067C 10068 CALL QUIT 10069 & ('Illegal address in computed GOTO in '//SECNAM) 10070C 10071 1 CONTINUE 10072C '.ATOMIC' 10073C Select active atoms (no boxes) 10074 ATOMIC = .TRUE. 10075 CHKACT = .TRUE. 10076 READ(LUCMD,*) NACINP 10077 IF (ABS(NACINP) .GT. MXACAT) THEN 10078 WRITE(LUPRI,*) 'ERROR: From center.h, ' , 10079 & 'maximum number of active ', 10080 & 'atoms is',MXACAT 10081 CALL QUIT('Too many active atoms') 10082 END IF 10083C 10084 IF (NACINP .GT. 0) THEN 10085 READ(LUCMD,*) (LACINP(I), I=1,NACINP) 10086 ELSE IF (NACINP .LT. 0) THEN 10087 NACINP = -NACINP 10088 ILAST = 0 10089 DO WHILE (ILAST .LT. NACINP) 10090 IFIRST = ILAST + 1 10091 READ(LUCMD,*) NACTMP 10092 ILAST = ILAST + NACTMP 10093 READ(LUCMD,*) (LACINP(I),I=IFIRST,ILAST) 10094 END DO 10095 IF (ILAST .NE. NACINP) THEN 10096 WRITE(LUPRI,*) 'Error in number of ', 10097 & 'active atoms : NACINP/ILAST', 10098 & NACINP,ILAST 10099 CALL QUIT('Error defining active atoms') 10100 END IF 10101 ELSE 10102 WRITE(LUPRI,*) 'Number of active atoms is zero' 10103 CALL QUIT('NACINP = 0') 10104 END IF 10105C 10106 DO I = 1,NACINP 10107 DO J = 1,I-1 10108 IF (LACINP(J) .EQ. LACINP(I)) THEN 10109 WRITE(LUPRI,*) 'ERROR : ', 10110 & 'One atom declared ', 10111 & 'twice as active' 10112 CALL QUIT('One atom is hyperactive') 10113 ELSE IF (LACINP(J) .GT. LACINP(I)) THEN 10114 ITMP = LACINP(J) ! Not needed, 10115 LACINP(J) = LACINP(I) ! but output 10116 LACINP(I) = ITMP ! looks nicer 10117 END IF 10118 END DO 10119 END DO 10120 GOTO 100 10121C 10122 2 CONTINUE 10123C '.BOXDEF' 10124C Boxes definition. 10125 CALL QUIT('.BOXDEF not yet implemented') 10126C_to_do copy & paste from mkinp.f 10127 GOTO 100 10128C 10129 3 CONTINUE 10130C '.ACTFRE' 10131C Freeze orbitals in active atomic space 10132 ACTFRE = .TRUE. 10133 READ(LUCMD,*) NACTFR 10134 GOTO 100 10135C 10136 4 CONTINUE 10137C '.DIFADD' 10138C Include in active space selected (diffuse) basis 10139 DIFADD = .TRUE. 10140 CHKACT = .TRUE. 10141 DO ISYM = 1,MSYM 10142 READ(LUCMD,*) NEXTBS(ISYM) 10143 READ(LUCMD,*) (IEXTBS(I,ISYM), I=1,NEXTBS(ISYM)) 10144 END DO 10145 GOTO 100 10146C 10147 5 CONTINUE 10148C '.NBOEXP' 10149C n-body interactions among boxes 10150 CALL QUIT('.NBOEXP not yet implemented') 10151C_to_do copy & paste from mkinp.f 10152 GOTO 100 10153 6 CONTINUE 10154C '.NODRSL' 10155C Decompose on atom by atom basis 10156 SELDIR = .FALSE. 10157 GOTO 100 10158 7 CONTINUE 10159C '.THACOC' 10160C Threshold for decomposition of active occupied block 10161 READ(LUCMD,*) THACOC 10162 GOTO 100 10163 8 CONTINUE 10164C '.THACVI' 10165C Threshold for decomposition of virtual occupied block 10166 READ(LUCMD,*) THACVI 10167 GOTO 100 10168 9 CONTINUE 10169C '.DIALST' 10170C Give list of diagonals to decompose 10171 DIALST = .TRUE. 10172 CHKACT = .TRUE. 10173 READ(LUCMD,*) NABSOC 10174 IF (NABSOC .GT. MXACBS) THEN 10175 WRITE(LUPRI,*) 'Number of occupied diagonals', 10176 & NABSOC 10177 WRITE(LUPRI,*) 'Maximum allowed :',MXACBS 10178 CALL QUIT( 10179 & 'Too many occupied diagonals under SELDIA') 10180 END IF 10181 READ(LUCMD,*) (LACBAS(I),I=1,NABSOC) 10182 READ(LUCMD,*) NABSVI 10183 IF (NABSVI .GT. MXACBS) THEN 10184 WRITE(LUPRI,*) 'Number of virtual diagonals', 10185 & NABSVI 10186 WRITE(LUPRI,*) 'Maximum allowed :',MXACBS 10187 CALL QUIT( 10188 & 'Too many occupied diagonals under SELDIA') 10189 END IF 10190 IF (NINDIA .GT. 0) THEN 10191 READ(LUCMD,*) (LACBAS(I),I=1,NINDIA) 10192 ELSE IF (NINDIA .LT. 0) THEN 10193 NINDIA = -NINDIA 10194 ILAST = 0 10195 DO WHILE (ILAST .LT. NINDIA) 10196 READ(LUCMD,*) NDITMP 10197 IFIRST = ILAST + 1 10198 ILAST = ILAST + NDITMP 10199 READ(LUCMD,*) (LACBAS(I), I=IFIRST,ILAST) 10200 END DO 10201 IF (ILAST .NE. NINDIA) THEN 10202 WRITE(LUPRI,*) 'Error in number of ', 10203 & 'active basis : NABSVI/ILAST', 10204 & NABSVI,ILAST 10205 CALL QUIT('Error defining active basis') 10206 END IF 10207 ELSE 10208 WRITE(LUPRI,*) 'Number of active basis is zero' 10209 CALL QUIT('Zero number of active basis') 10210 END IF 10211 NABSTO = NINDIA 10212 GOTO 100 10213 10 CONTINUE 10214C '.ORDER' 10215C Order to decompose atoms 10216ctmp READ(LUCMD,*) (IORDEC(I), I=1,NUCIND) 10217 GOTO 100 10218 11 CONTINUE 10219C '.FULDEC' 10220C Select all the atoms 10221 FULDEC = .TRUE. 10222 CHKACT = .TRUE. 10223 GOTO 100 10224 12 CONTINUE 10225C '.DOSPRE' 10226C Calculate orbital spread 10227 DOSPREAD = .TRUE. 10228 IF (MSYM .GT. 1) THEN 10229 WRITE(LUPRI,*) 'Calculation of orbital', 10230 & ' spreads is only possible w/o symmetry' 10231 CALL QUIT('DOSPRE with NSYM .GT. 1') 10232 END IF 10233 GOTO 100 10234 13 CONTINUE 10235C 'MINSPR' 10236C Select diagonals to minimize orbital spreads 10237 MINSPR = .TRUE. 10238 DOSPREAD = .TRUE. 10239 IF (MSYM .GT. 1) THEN 10240 WRITE(LUPRI,*) 'Calculation of orbital', 10241 & ' spreads is only possible w/o symmetry' 10242 CALL QUIT('MINSPR with NSYM .GT. 1') 10243 END IF 10244 GOTO 100 10245 14 CONTINUE 10246C 'LIMLOC' 10247C Get limited number of localized orbitals 10248 LIMLOC = .TRUE. 10249 READ(LUCMD,*) (MXOCC(I), I=1,MSYM) 10250 READ(LUCMD,*) (MXVIR(I), I=1,MSYM) 10251 GOTO 100 10252 15 CONTINUE 10253C '.EXTERN' 10254C Initial orbitals from external source 10255 EXTERN = .TRUE. 10256 NEWACT = .TRUE. 10257 GOTO 100 10258 16 CONTINUE 10259C '.SPACES' 10260C Define levels of active spaces 10261 NEWACT = .TRUE. 10262 READ(LUCMD,*) NSPACE 10263 IF (NSPACE .GT. MXSPA) THEN 10264 WRITE(LUPRI,'(2A,I3)') 'Maximum number of ', 10265 & 'spaces is', MXSPA 10266 CALL QUIT('Too many spaces under .SPACES') 10267 END IF 10268 DO ISPA = 1,NSPACE 10269 READ(LUCMD,*) NATOAC(ISPA) 10270 IF (NATOAC(ISPA) .GT. MXACAT) THEN 10271 WRITE(LUPRI,'(2A,I3)') 'Maximum number of ', 10272 & 'active atoms in a subspace is',MXACT 10273 CALL QUIT('Too many active atoms') 10274 END IF 10275 READ(LUCMD,*) (LABSPA(I,ISPA),I=1,NATOAC(ISPA)) 10276 END DO 10277 GOTO 100 10278 17 CONTINUE 10279C '.LIMSPA' 10280C Limited number of localized orbital in each subspace 10281 NEWACT = .TRUE. 10282 LIMSPA = .TRUE. 10283 READ(LUCMD,*) MSPACE 10284 IF (MSPACE .GT. MXSPA) THEN 10285 WRITE(LUPRI,'(2A,I3)') 'Maximum number of ', 10286 & 'spaces is', MXSPA 10287 CALL QUIT('Too many spaces under .LIMSPA') 10288 END IF 10289 DO ISPA = 1,MSPACE 10290 READ(LUCMD,*) (MXOC2(I,ISPA), I=1,MSYM) 10291 READ(LUCMD,*) (MXVI2(I,ISPA), I=1,MSYM) 10292 END DO 10293 GOTO 100 10294 18 CONTINUE 10295C '.OMEZER' 10296C Generate ACTORB for later use 10297 PERTCC = .TRUE. 10298 NEWACT = .TRUE. 10299 GOTO 100 10300 19 CONTINUE 10301C '.SPDILS' 10302C List of diagonals in each space 10303c (right now only one) 10304 SPDILS = .TRUE. 10305 NEWACT = .TRUE. 10306 READ(LUCMD,*) NSPAC2 10307 IF (NSPAC2 .GT. MXSPA) THEN 10308 WRITE(LUPRI,'(2A,I3)') 'Maximum number of ', 10309 & 'spaces is', MXSPA 10310 CALL QUIT('Too many spaces under .SPDILS') 10311 END IF 10312 DO ISPA = 1,NSPAC2 10313 READ(LUCMD,*) NABSO2(ISPA) 10314 IF (NABSO2(ISPA) .GT. MXACBS) THEN 10315 WRITE(LUPRI,*) 10316 & 'Number of occupied diagonals', 10317 & NABSO2(ISPA) 10318 WRITE(LUPRI,*) 'Maximum allowed :',MXACBS 10319 CALL QUIT( 10320 & 'Too many occupied diagonals under SPDILS') 10321 END IF 10322 READ(LUCMD,*) (LACBA2(I,ISPA),I=1,NABSO2(ISPA)) 10323 READ(LUCMD,*) NABSV2(ISPA) 10324 IF (NABSV2(ISPA) .GT. MXACBS) THEN 10325 WRITE(LUPRI,*) 10326 & 'Number of virtual diagonals', 10327 & NABSV2(ISPA) 10328 WRITE(LUPRI,*) 'Maximum allowed :',MXACBS 10329 CALL QUIT( 10330 & 'Too many virtual diagonals under SPDILS') 10331 END IF 10332 IF (NABSV2(ISPA) .LT. 0) THEN 10333 NABSV2(ISPA) = -NABSV2(ISPA) 10334 ILAST = 0 10335 DO WHILE (ILAST .LT. NABSV2(ISPA)) 10336 READ(LUCMD,*) NDITMP 10337 IFIRST = ILAST + 1 10338 ILAST = ILAST + NDITMP 10339 READ(LUCMD,*) 10340 & (LACBV2(I,ISPA), I=IFIRST,ILAST) 10341 END DO 10342 IF (ILAST .NE. NABSV2(ISPA)) THEN 10343 WRITE(LUPRI,*) 'Error in number of ', 10344 & 'active basis : NABSVI/ILAST', 10345 & NABSV2(ISPA),ILAST 10346 CALL QUIT('Error defining active basis') 10347 END IF 10348 ELSE 10349 READ(LUCMD,*) 10350 & (LACBV2(I,ISPA),I=1,NABSV2(ISPA)) 10351 END IF 10352 END DO 10353 GOTO 100 10354 20 CONTINUE 10355C '.LOCONL' 10356C Define subsapce, but don't freeze any 10357 LOCONL = .TRUE. 10358 GOTO 100 10359 21 CONTINUE 10360C '.ADDORB' 10361C Add HOMO and LUMO orbitals if not active 10362 ADDORB = .TRUE. 10363 GOTO 100 10364C 10365 22 CONTINUE 10366C '.ADDEXP' 10367C Explicitly add orbitals to active space 10368 ADDEXP = .TRUE. 10369 READ(LUCMD,*) IEXPOC 10370 READ(LUCMD,*) IEXPVI 10371 GOTO 100 10372C 10373C 10374 ELSE 10375 WRITE (LUPRI,'(/5A,/)') ' Prompt "',WORD, 10376 & '" not recognized in ',SECNAM,'.' 10377 CALL PRTAB(NTABLE,TABLE,SECNAM//' input keywords', 10378 & LUPRI) 10379 CALL QUIT('Illegal Keyword in '//SECNAM) 10380 END IF 10381C 10382 ELSE IF (WORD(1:1) .NE. '*') THEN 10383 WRITE (LUPRI,'(/5A,/)') 'PROMPT "',WORD, 10384 & '" NOT RECOGNIZED IN ',SECNAM,'.' 10385 CALL QUIT('Illegal prompt in '//SECNAM) 10386 ELSE IF (WORD(1:1) .EQ.'*') THEN 10387! BACKSPACE (LUCMD) 10388 GO TO 200 10389 END IF 10390C 10391 END IF 10392C 10393 200 CONTINUE 10394C 10395C Check that input makes sense 10396C 10397 IF (ACTSEL .AND. (.NOT. (CHKACT .OR. NEWACT))) THEN 10398 WRITE(LUPRI,'(//,A,/,3A,/,A,//)') '>>> ERROR :', 10399 & '>>> *ACTIVE was specified, but no definition', 10400 & ' of active atoms, boxes or basis', 10401 & ' functions was given', 10402 & ' Program will stop' 10403 CALL QUIT(SECNAM//' called but no selection data given') 10404 END IF 10405C 10406 IF (NEWACT) THEN 10407C 10408 IF (.NOT. SELDIR) THEN 10409 WRITE(LUPRI,'(//,A,/,A,A)') '>>> ERROR :', 10410 & 'Options SPACES, .EXTERN, and .LIMPSPA ', 10411 & 'cannot be used (yet) in an atom-by-atom basis' 10412 CALL QUIT('.SPACES switched on with no direct selection') 10413 END IF 10414C 10415 IF (MINSPR .OR. ACTFRE .OR. CHKACT .OR. LIMLOC .OR. 10416 & DIALST) THEN 10417 WRITE(LUPRI,'(//,2A,/,A,/,A)') 'Options .MINSPR, .ACTFRE,', 10418 & ' .LIMLOC, .ATOMIC, .DIFADD, .DIALST, and ', 10419 & '.FULDEC are not compatible to options ', 10420 & '.SPACES, .EXTERN, and .LIMPSPA' 10421 CALL QUIT(SECNAM//' called with not compatible options') 10422 END IF 10423C 10424 IF (LIMSPA .AND. (MSPACE .NE. NSPACE)) THEN 10425 WRITE(LUPRI,'(//,A,/,A,I2,/,A,I2)') '>>> ERROR :', 10426 & 'Number of defined spaces :', 10427 & NSPACE, 10428 & 'Number of spaces with limited number of orbitals :', 10429 & MSPACE 10430 CALL QUIT('MSPACE .ne. NSPACE in CC_ACTINP') 10431 END IF 10432C 10433 IF (SPDILS .AND. (NSPAC2 .NE. NSPACE)) THEN 10434 WRITE(LUPRI,'(//,A,/,A,I2,/,A,I2)') '>>> ERROR :', 10435 & 'Number of defined spaces :', 10436 & NSPACE, 10437 & 'Number of spaces with given list of diagonals :', 10438 & NSPAC2 10439 CALL QUIT('NSPAC2 .ne. NSPACE in CC_ACTINP') 10440 END IF 10441C 10442 IF (SPDILS) THEN 10443 THACOC = 1.0D-8 10444 THACVI = 1.0D-8 10445 END IF 10446 10447 END IF 10448C 10449 WRITE(LUPRI,'(//,A)') ' ----------------------------' 10450 WRITE(LUPRI,'(A)') ' Info from Selact input' 10451 WRITE(LUPRI,'(A,/)') ' ----------------------------' 10452C 10453 IF (ATOMIC) THEN 10454 WRITE(LUPRI,*) 10455 WRITE(LUPRI,*) 10456 WRITE(LUPRI,'(I5,A)') NACINP, ' centers declared as active :' 10457 WRITE(LUPRI,'(14I5)') (LACINP(I), I=1,NACINP) 10458 END IF 10459C 10460 IF (SELDIR) THEN 10461 WRITE(LUPRI,*) 10462 WRITE(LUPRI,*) 10463 WRITE(LUPRI,*) 'Density decomposition only in active space' 10464 ELSE 10465 WRITE(LUPRI,*) 10466 WRITE(LUPRI,*) 10467 WRITE(LUPRI,*) 'Decompose in atom-by-atom basis and ', 10468 & 'select afterwards' 10469 END IF 10470C 10471 IF (DIALST) THEN 10472 WRITE(LUPRI,*) 10473 WRITE(LUPRI,*) 10474 WRITE(LUPRI,*) 'Given explicit list of diagonals to decompose' 10475 END IF 10476C 10477 IF (LIMLOC) THEN 10478 IF (.NOT. SELDIR) THEN 10479 WRITE(LUPRI,*) 10480 WRITE(LUPRI,*) 10481 WRITE(LUPRI,*) 'Fixed number of localized orbitals only', 10482 & ' available when direct selection in use' 10483 WRITE(LUPRI,*) 'LIMLOC will be ignored' 10484 ELSE 10485 WRITE(LUPRI,*) 'Fixed number of localized orbitals' 10486 WRITE(LUPRI,'(a,8i6)') 'Occupied : ',(MXOCC(I), I=1,MSYM) 10487 WRITE(LUPRI,'(a,8i6)') 'Virtual : ',(MXVIR(I), I=1,MSYM) 10488 END IF 10489 END IF 10490C 10491 IF (EXTERN) THEN 10492 WRITE(LUPRI,*) 10493 WRITE(LUPRI,*) 10494 WRITE(LUPRI,*) 'Initial orbitals from external source' 10495 END IF 10496C 10497 WRITE(LUPRI,*) 10498 WRITE(LUPRI,*) 10499C 10500 CALL FLSHFO(LUPRI) 10501C 10502 RETURN 10503 END 10504 10505 10506*=====================================================================* 10507c /* deck cc_peinp */ 10508*=====================================================================* 10509 SUBROUTINE CC_PEINP(WORD) 10510C---------------------------------------------------------------------* 10511C 10512C Purpose: read input for P(D)E CC calculations. 10513C 10514C if (WORD .eq. '*PECC ') read & process input and set defaults, 10515C else set only defaults 10516C 10517C PECC16,DH (based on CC_SLVINP) 10518C Dalibor Hršak, July 2016 10519C 10520C=====================================================================* 10521 USE PELIB_INTERFACE, ONLY: USE_PELIB 10522 IMPLICIT NONE 10523#include "priunit.h" 10524#include "ccsdinp.h" 10525#include "ccsections.h" 10526#include "ccsdsym.h" 10527#include "ccfield.h" 10528#include "ccslvinf.h" 10529#include "qm3.h" 10530 10531 CHARACTER*8, PARAMETER :: SECNAM='CC_PEINP' 10532 INTEGER, PARAMETER :: NTABLE = 8 10533 10534 LOGICAL :: SET 10535 SAVE SET 10536 10537 CHARACTER*7 :: WORD 10538 INTEGER :: IXCCSLIT, IJUMP 10539 CHARACTER*8 :: TABLE(NTABLE) 10540 10541 10542 DATA SET /.FALSE./ 10543 DATA TABLE /'.MXSLIT','.ETOLSL','.TTOLSL','.LTOLSL','.MXINIT', 10544 & '.HFFLD ','.CCFIXF','.SIMPLE'/ 10545 10546*---------------------------------------------------------------------* 10547* begin: 10548*---------------------------------------------------------------------* 10549 IF (.NOT. USE_PELIB()) CALL QUIT('Keyword *PELIB is obligatory!') 10550 IF (SET) RETURN 10551 SET = .TRUE. 10552 10553*---------------------------------------------------------------------* 10554* initializations & defaults: 10555*---------------------------------------------------------------------* 10556 10557 ICHANG = 0 10558 IXCCSLIT = 0 10559 MXCCSLIT = 10 10560 CVGESOL = 1.0D-07 10561 CVGTSOL = 1.0D-07 10562 CVGLSOL = 1.0D-07 10563 PTSOLV = .FALSE. 10564 DISCEX = .FALSE. 10565 ECCCU = 0.0D0 10566 XTNCCCU = 0.0D0 10567 XLNCCCU = 0.0D0 10568 MXTINIT = 200 10569 MXLINIT = 200 10570 LOITER = .FALSE. 10571 NREPMT = 0 10572 RELMOM = .FALSE. 10573 SLOTH = .FALSE. 10574 SKIPNC = .FALSE. 10575 HFFLD = .FALSE. ! Do polarization based on fixed HF/MM reaction field - in doi:10.1039/C0C901075H denoted model 1 10576 CCFIXF = .FALSE. ! Do polarization based on fixed CC/MM reaction field neglecting resp terms - ie only static polarization. Model 2 in doi:10.1039/C0C901075H 10577 10578*---------------------------------------------------------------------* 10579* read input: 10580*---------------------------------------------------------------------* 10581 10582 IF (WORD .EQ. '*PECC ') THEN 10583 DO 10584 READ (LUCMD,'(A7)') WORD 10585 CALL UPCASE(WORD) 10586 DO WHILE ( WORD(1:1) .EQ. '!' .OR. WORD(1:1) .EQ. '#' ) 10587 READ (LUCMD,'(A7)') WORD 10588 CALL UPCASE(WORD) 10589 END DO 10590! 10591 IF (WORD(1:1) .EQ. '.') THEN 10592 IF (WORD .EQ. '.MXSLIT') THEN 10593 READ(LUCMD,*) MXCCSLIT 10594 CYCLE 10595 ELSE IF (WORD .EQ. '.ETOLSL') THEN 10596 READ(LUCMD,*) CVGESOL 10597 CYCLE 10598 ELSE IF (WORD .EQ. '.TTOLSL') THEN 10599 READ(LUCMD,*) CVGTSOL 10600 CYCLE 10601 ELSE IF (WORD .EQ. '.LTOLSL') THEN 10602 READ(LUCMD,*) CVGLSOL 10603 CYCLE 10604 ELSE IF (WORD .EQ. '.MXINIT') THEN 10605 READ(LUCMD,*) MXTINIT, MXLINIT 10606 LOITER = .TRUE. 10607 CYCLE 10608 ELSE IF (WORD .EQ. '.HFFLD ') THEN 10609 HFFLD = .TRUE. 10610 CYCLE 10611 ELSE IF (WORD .EQ. '.CCFIXF') THEN 10612 CCFIXF = .TRUE. 10613 CYCLE 10614 ELSE 10615 WRITE (LUPRI,'(/5A/)') ' Prompt "',WORD, 10616 & '" not recognized in ',SECNAM,'.' 10617 CALL PRTAB(NTABLE,TABLE,SECNAM//' input keywords',LUPRI) 10618 CALL QUIT('Illegal Keyword in '//SECNAM//'.') 10619 END IF 10620 ELSE IF (WORD(1:1) .NE. '*') THEN 10621 WRITE (LUPRI,'(/5A/)') 'PROMPT "',WORD, 10622 & '" NOT RECOGNIZED IN ',SECNAM,'.' 10623 CALL QUIT('Illegal prompt in '//SECNAM//'.') 10624 ELSE IF (WORD(1:1) .EQ.'*') THEN 10625 BACKSPACE(LUCMD) 10626 EXIT 10627 END IF 10628 END DO 10629 IF (USE_PELIB()) RSPIM = .TRUE. 10630! 10631 IF (CC2) NONHF = .TRUE. 10632! 10633 IF ( (HFFLD) .AND. (CCFIXF) ) THEN 10634 WRITE(LUPRI,*) 'You have specified both CCFIXF and HFFLD. 10635 & Make a choice!' 10636 CALL QUIT('Error in PECC input') 10637 ENDIF 10638! 10639 END IF 10640! 10641 RETURN 10642 END 10643