1! 2! Dalton, a molecular electronic structure program 3! Copyright (C) by the authors of Dalton. 4! 5! This program is free software; you can redistribute it and/or 6! modify it under the terms of the GNU Lesser General Public 7! License version 2.1 as published by the Free Software Foundation. 8! 9! This program is distributed in the hope that it will be useful, 10! but WITHOUT ANY WARRANTY; without even the implied warranty of 11! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12! Lesser General Public License for more details. 13! 14! If a copy of the GNU LGPL v2.1 was not distributed with this 15! code, you can obtain one at https://www.gnu.org/licenses/old-licenses/lgpl-2.1.en.html. 16! 17! 18C 19*---------------------------------------------------------------------* 20c /* deck cc_tmcal */ 21*=====================================================================* 22 SUBROUTINE CC_TMCAL(WRK,LWRK) 23*---------------------------------------------------------------------* 24* 25* Purpose: Third moment calculations 26* 27* Written by: P.Joergensen and C.Haettig 1997 28* Clean up and new output style: S. Coriani 2001 29*=====================================================================* 30#if defined (IMPLICIT_NONE) 31 IMPLICIT NONE 32#else 33# include "implicit.h" 34#endif 35#include "priunit.h" 36#include "ccorb.h" 37#include "ccsdsym.h" 38#include "ccsdinp.h" 39#include "cctm.h" 40#include "cctminf.h" 41#include "ccrspprp.h" 42#include "ccexci.h" 43#include "ccroper.h" 44 45* local parameters: 46 LOGICAL LOCDBG 47 PARAMETER (LOCDBG = .FALSE.) 48 49* variables: 50 CHARACTER*8 LABELA, LABELB, LABELC,LABELD, LABELE, LABELF 51 CHARACTER MODFIL*10, MODPRI*5 52 INTEGER ISYMB, ISYMC, ISYMA, ISYMD, ISYME, ISYMF, ISYMABC 53 INTEGER IFREQ, INUM, IOPER, IDX, IOFFST, LWRK, IOPTRD 54 INTEGER K1VEC1, K1VEC2, K2VEC1, K2VEC2, IM11 55 INTEGER IX3AC0F, IX3DF0F, IO3AC0F, IO3ACF0, IO3DF0F, IO3DFF0 56 INTEGER NCCVAR1, NCCVAR2 57 58#if defined (SYS_CRAY) 59 REAL HALF, FREQEX, FREQB, FREQC, EIGV, WRK(LWRK) 60 REAL SMLM, SMCLM, SMRM, SMCRM 61 REAL ABCLM,DEFLM,ABCRM,DEFRM 62 REAL X1, X2, Y1, Y2 63 REAL DDOT, ZERO 64#else 65 DOUBLE PRECISION HALF, FREQEX, FREQB, FREQC, EIGV, WRK(LWRK) 66 DOUBLE PRECISION SMLM, SMCLM, SMRM, SMCRM 67 DOUBLE PRECISION ABCLM,DEFLM,ABCRM,DEFRM,THREEPH 68 DOUBLE PRECISION X1, X2, Y1, Y2 69 DOUBLE PRECISION DDOT, ZERO 70#endif 71 72 PARAMETER ( HALF = 0.5D00, ZERO = 0.0D00 ) 73 74* external functions: 75 INTEGER IRHSR3 76 INTEGER ILRMAMP 77 INTEGER ICHI3 78* data: 79 LOGICAL FIRSTCALL 80 SAVE FIRSTCALL 81 DATA FIRSTCALL /.TRUE./ 82*---------------------------------------------------------------------* 83* print header for third order moments section 84*---------------------------------------------------------------------* 85 WRITE (LUPRI,'(7(/1X,2A),/)') 86 & '************************************', 87 & '*******************************', 88 & '* ', 89 & ' *', 90 & '*-------- OUTPUT FROM COUPLED CLUSTER C', 91 & 'UBIC RESPONSE -------------*', 92 & '* ', 93 & ' *', 94 & '*-------- CALCULATION OF THREE PHOTON TRANS', 95 & 'ITION STRENGTHS -------*', 96 & '* ', 97 & ' *', 98 & '************************************', 99 & '*******************************' 100 101*---------------------------------------------------------------------* 102* print debug info 103*---------------------------------------------------------------------* 104 IF (LOCDBG) THEN 105 WRITE (LUPRI,*) 'DEBUG_CC_TMIND> NTMOP = ',NTMOPER 106 END IF 107*---------------------------------------------------------------------* 108* set MODFIL, MODPRI, IOPTRD for calls to CC_RDRSP and print out 109*---------------------------------------------------------------------* 110 IF (CCS) THEN 111 MODFIL = 'CCS ' 112 MODPRI = 'CCS ' 113 IOPTRD = 1 114 ELSE IF (CC2) THEN 115 MODFIL = 'CC2 ' 116 MODPRI = 'CC2 ' 117 IOPTRD = 3 118 ELSE IF (CCSD) THEN 119 MODFIL = 'CCSD ' 120 MODPRI = 'CCSD ' 121 IOPTRD = 3 122 ELSE 123 CALL QUIT('Unknown coupled cluster model in CC_TMCAL') 124 END IF 125*---------------------------------------------------------------------* 126* find list entries for the required response vectors 127* and excitation vectors: 128*---------------------------------------------------------------------* 129 130 DO IOPER = 1, NTMOPER 131 LABELA = LBLOPR(IATMOP(IOPER)) 132 LABELB = LBLOPR(IBTMOP(IOPER)) 133 LABELC = LBLOPR(ICTMOP(IOPER)) 134 LABELD = LBLOPR(IDTMOP(IOPER)) 135 LABELE = LBLOPR(IETMOP(IOPER)) 136 LABELF = LBLOPR(IFTMOP(IOPER)) 137 138 ISYMA = ISYOPR(IATMOP(IOPER)) 139 ISYMB = ISYOPR(IBTMOP(IOPER)) 140 ISYMC = ISYOPR(ICTMOP(IOPER)) 141 ISYMD = ISYOPR(IDTMOP(IOPER)) 142 ISYME = ISYOPR(IETMOP(IOPER)) 143 ISYMF = ISYOPR(IFTMOP(IOPER)) 144 145 IF (LOCDBG) THEN 146 WRITE (LUPRI,*) 'LABELA:',LABELA, ' ISYMA:', ISYMA 147 WRITE (LUPRI,*) 'LABELB:',LABELB, ' ISYMB:', ISYMB 148 WRITE (LUPRI,*) 'LABELC:',LABELC, ' ISYMC:', ISYMC 149 WRITE (LUPRI,*) 'LABELD:',LABELD, ' ISYMD:', ISYMD 150 WRITE (LUPRI,*) 'LABELE:',LABELE, ' ISYME:', ISYME 151 WRITE (LUPRI,*) 'LABELF:',LABELF, ' ISYMF:', ISYMF 152 CALL FLSHFO(LUPRI) 153 END IF 154 155 ISYMABC = MULD2H(MULD2H(ISYMA,ISYMB),ISYMC) 156 IF (ISYMABC .EQ. MULD2H(ISYMD,MULD2H(ISYME,ISYMF))) THEN 157 158 NCCVAR1 = NT1AM(ISYMABC) 159 NCCVAR2 = NT2AM(ISYMABC) 160 K1VEC1 = 1 161 K1VEC2 = K1VEC1 + NCCVAR1 162 K2VEC1 = K1VEC2 + NCCVAR2 163 K2VEC2 = K2VEC1 + NCCVAR1 164 165 DO I = 1, NTMSELX(ISYMABC) 166C bug fix 167c IFREQ = ITMSELX( MULD2H(ISYMA,ISYMB) ) + I 168 IFREQ = ITMSELX(ISYMABC) + I 169 FREQEX = EXTMFR(IFREQ) 170 FREQB = BTMFR(IFREQ) 171 FREQC = CTMFR(IFREQ) 172 IF (LOCDBG) THEN 173 WRITE (LUPRI,*) 'CC_TMCAL> put on the list:', 174 & LABELA,'(',FREQEX,'), ', LABELB,'(',FREQB ,'), ', 175 & LABELC,'(',FREQC, '), ', LABELD,'(',FREQEX,'), ', 176 & LABELE,'(',FREQB, '), ', LABELF,'(',FREQC ,'), ' 177 END IF 178 179* request third order chi vectors: 180 181 IX3AC0F = ICHI3(LABELA,-FREQEX+FREQB+FREQC,ISYMA, 182 & LABELB,-FREQB,ISYMB,LABELC,-FREQC,ISYMC) 183 IX3DF0F = ICHI3(LABELD,-FREQEX+FREQB+FREQC,ISYMD, 184 & LABELE,-FREQB,ISYME,LABELF,-FREQC,ISYMF) 185 186* request third order rhs vectors 187 188 IO3AC0F = IRHSR3(LABELA,-FREQEX+FREQB+FREQC,ISYMA, 189 & LABELB,-FREQB,ISYMB,LABELC,-FREQC,ISYMC) 190 IO3ACF0 = IRHSR3(LABELA,+FREQEX-FREQB-FREQC,ISYMA, 191 & LABELB,+FREQB,ISYMB,LABELC,+FREQC,ISYMC) 192 IO3DF0F = IRHSR3(LABELD,-FREQEX+FREQB+FREQC,ISYMD, 193 & LABELE,-FREQB,ISYME,LABELF,-FREQC,ISYMF) 194 IO3DFF0 = IRHSR3(LABELD,+FREQEX-FREQB-FREQC,ISYMD, 195 & LABELE,+FREQB,ISYME,LABELF,+FREQC,ISYMF) 196 197* request M vectors for different excitation energies 198 199 IOFFST = ISYOFE(ISYMABC) + ITMSEL(IFREQ,2) 200 EIGV = EIGVAL(IOFFST) 201 IM11 = ILRMAMP(IOFFST,EIGV,ISYMABC) 202*--------------------------------------------------------------* 203* calculate left moment M_of^ABC(-w1,-w2) contrib. 204* previously called SMCLM 205*--------------------------------------------------------------* 206 207 CALL CC_RDRSP('X3',IX3AC0F,ISYMABC,IOPTRD,MODFIL, 208 * WRK(K1VEC1),WRK(K1VEC2)) 209 X1 = DDOT(NCCVAR1,WRK(K1VEC1),1,WRK(K1VEC1),1) 210 IF (.NOT.CCS) THEN 211 X2 = DDOT(NCCVAR2,WRK(K1VEC2),1,WRK(K1VEC2),1) 212 ELSE 213 X2 = ZERO 214 END IF 215 IF (LOCDBG) 216 & WRITE (LUPRI,*) ' norm^2 of X3 vector:',X1,X2 217 218 CALL CC_RDRSP('RE',IOFFST,ISYMABC,IOPTRD,MODFIL, 219 * WRK(K2VEC1),WRK(K2VEC2)) 220 Y1 = DDOT(NCCVAR1,WRK(K2VEC1),1,WRK(K2VEC1),1) 221 IF (.NOT.CCS) THEN 222 Y2 = DDOT(NCCVAR2,WRK(K2VEC2),1,WRK(K2VEC2),1) 223 ELSE 224 Y2 = ZERO 225 END IF 226 IF (LOCDBG) 227 & WRITE (LUPRI,*) ' norm^2 of RE vector:',Y1,Y2 228 229 ABCLM = DDOT(NCCVAR1,WRK(K1VEC1),1,WRK(K2VEC1),1) 230 IF (.NOT.CCS) THEN 231 ABCLM=ABCLM + DDOT(NCCVAR2,WRK(K1VEC2),1,WRK(K2VEC2),1) 232 END IF 233 234 CALL CC_RDRSP('M1',IM11,ISYMABC,IOPTRD,MODFIL, 235 * WRK(K1VEC1),WRK(K1VEC2)) 236 X1 = DDOT(NCCVAR1,WRK(K1VEC1),1,WRK(K1VEC1),1) 237 IF (.NOT.CCS) THEN 238 X2 = DDOT(NCCVAR2,WRK(K1VEC2),1,WRK(K1VEC2),1) 239 ELSE 240 X2 = ZERO 241 END IF 242 IF (LOCDBG) 243 & WRITE (LUPRI,*) 'Norm^2 of M1:',X1,X2,X1+X2 244 245 CALL CC_RDRSP('O3',IO3AC0F,ISYMABC,IOPTRD,MODFIL, 246 * WRK(K2VEC1),WRK(K2VEC2)) 247 Y1 = DDOT(NCCVAR1,WRK(K2VEC1),1,WRK(K2VEC1),1) 248 IF (.NOT.CCS) THEN 249 Y2 = DDOT(NCCVAR2,WRK(K2VEC2),1,WRK(K2VEC2),1) 250 ELSE 251 Y2 = ZERO 252 END IF 253 IF (LOCDBG) 254 & WRITE (LUPRI,*) ' Norm^2 of O3 vector:',y1,y2,y1+y2 255 256 CALL CCLR_DIASCL(WRK(K2VEC2),HALF,ISYMABC) 257 258 ABCLM = ABCLM + DDOT(NCCVAR1,WRK(K1VEC1),1,WRK(K2VEC1),1) 259 IF (.NOT.CCS) THEN 260 ABCLM=ABCLM + DDOT(NCCVAR2,WRK(K1VEC2),1,WRK(K2VEC2),1) 261 END IF 262 263*--------------------------------------------------------------* 264* calculate right moment M_fo^DEF(w1,w2) contribution 265* previously called SMCRM 266*--------------------------------------------------------------* 267 268 CALL CC_RDRSP('LE',IOFFST,ISYMABC,IOPTRD,MODFIL, 269 * WRK(K1VEC1),WRK(K1VEC2)) 270 CALL CC_RDRSP('O3',IO3DFF0,ISYMABC,IOPTRD,MODFIL, 271 * WRK(K2VEC1),WRK(K2VEC2)) 272 CALL CCLR_DIASCL(WRK(K2VEC2),HALF,ISYMABC) 273 274 DEFRM = DDOT(NCCVAR1,WRK(K1VEC1),1,WRK(K2VEC1),1) 275 IF (.NOT.CCS) THEN 276 DEFRM=DEFRM + DDOT(NCCVAR2,WRK(K1VEC2),1,WRK(K2VEC2),1) 277 END IF 278 279*--------------------------------------------------------------* 280* calculate left moment M_of^DEF(-w1,-w2) contrib. 281* (previously SMLM) 282*--------------------------------------------------------------* 283 284 CALL CC_RDRSP('X3',IX3DF0F,ISYMABC,IOPTRD,MODFIL, 285 * WRK(K1VEC1),WRK(K1VEC2)) 286 287 CALL CC_RDRSP('RE',IOFFST,ISYMABC,IOPTRD,MODFIL, 288 * WRK(K2VEC1),WRK(K2VEC2)) 289 DEFLM = DDOT(NCCVAR1,WRK(K1VEC1),1,WRK(K2VEC1),1) 290 IF (.NOT.CCS) THEN 291 DEFLM = DEFLM + DDOT(NCCVAR2,WRK(K1VEC2),1,WRK(K2VEC2),1) 292 END IF 293 294 CALL CC_RDRSP('M1',IM11,ISYMABC,IOPTRD,MODFIL, 295 * WRK(K1VEC1),WRK(K1VEC2)) 296 297 CALL CC_RDRSP('O3',IO3DF0F,ISYMABC,IOPTRD,MODFIL, 298 * WRK(K2VEC1),WRK(K2VEC2)) 299 CALL CCLR_DIASCL(WRK(K2VEC2),HALF,ISYMABC) 300 301 DEFLM = DEFLM + DDOT(NCCVAR1,WRK(K1VEC1),1,WRK(K2VEC1),1) 302 IF (.NOT.CCS) THEN 303 DEFLM = DEFLM + DDOT(NCCVAR2,WRK(K1VEC2),1,WRK(K2VEC2),1) 304 END IF 305 306*--------------------------------------------------------------* 307* calculate right moment M_fo^ABC(w1,w2) contribution 308* (previously SMRM) 309*--------------------------------------------------------------* 310 311 CALL CC_RDRSP('LE',IOFFST,ISYMABC,IOPTRD,MODFIL, 312 * WRK(K1VEC1),WRK(K1VEC2)) 313 CALL CC_RDRSP('O3',IO3ACF0,ISYMABC,IOPTRD,MODFIL, 314 * WRK(K2VEC1),WRK(K2VEC2)) 315 CALL CCLR_DIASCL(WRK(K2VEC2),HALF,ISYMABC) 316 317 ABCRM = DDOT(NCCVAR1,WRK(K1VEC1),1,WRK(K2VEC1),1) 318 IF (.NOT.CCS) THEN 319 ABCRM = ABCRM+DDOT(NCCVAR2,WRK(K1VEC2),1,WRK(K2VEC2),1) 320 END IF 321*--------------------------------------------------------------* 322* Final three-photon transition strength: 323*--------------------------------------------------------------* 324 325 THREEPH = HALF*(ABCLM*DEFRM+DEFLM*ABCRM) 326 327*--------------------------------------------------------------* 328* Write results on output 329*--------------------------------------------------------------* 330 WRITE(LUPRI,'(65("-"),/1x,a,f10.6,a,i1,a,i1)') 331 & 'For trans. to |f(',EIGV,')>, state nr. ',ITMSEL(IFREQ,2), 332 & ' of symm. ',ISYMABC 333 WRITE(LUPRI,'(/,3(1x,a5,a,a1,i1,a1))') 334 & ' A: ',LABELA,'(',ISYMA,')', '; B: ',LABELB,'(',ISYMB,')', 335 & '; C: ',LABELC,'(',ISYMC,')' 336 WRITE(LUPRI,'(3(1x,a5,a,a1,i1,a1))') 337 & ' D: ',LABELD,'(',ISYMD,')', '; E: ',LABELE,'(',ISYME,')', 338 & '; F: ',LABELF,'(',ISYMF,')' 339 WRITE(LUPRI,'(1x,a,f10.6,a,f10.6)') 340 & ' Laser frequencies (au): w1 = ', FREQB, '; w2 = ', FREQC 341C IF (LOCDBG) THEN 342 WRITE(LUPRI,'(2(/1x,a,f15.9,1x,a,f15.9))') 343 & ' M^ABC_of(-w1,-w2): ',ABCLM,' M^DEF_fo(w1,w2): ',DEFRM, 344 & ' M^DEF_of(-w1,-w2): ',DEFLM,' M^ABC_fo(w1,w2): ',ABCRM 345 WRITE(LUPRI,'(2(1x,a,f15.9,/))') 346 & ' M^ABC_of(-w1,-w2) x M^DEF_fo(w1,w2) = ', abclm*defrm, 347 & '[M^DEF_of(-w1,-w2) x M^ABC_fo(w1,w2)]* = ', deflm*abcrm 348C END IF 349 WRITE(LUPRI,'(1x,a5,a,/,1x,a5,a,f10.6,a1,f10.6,a,f15.9)') 350 & MODPRI,'Transition strength for Third Order Moment: ', 351 & MODPRI,'S^of_ABC,DEF(',FREQB,',',FREQC,') = ', THREEPH 352 WRITE(LUPRI,'(65("-"))') 353 354*--------------------------------------------------------------* 355 356 END DO 357 END IF 358 359 END DO 360 361 RETURN 362 END 363*=====================================================================* 364*---------------------------------------------------------------------* 365 366 SUBROUTINE CC_TMSORT 367*---------------------------------------------------------------------* 368* 369* Purpose: sort the selected states for which third moment 370* calculation is carried. if no selected states are 371* chosen use all states specified in the excitation 372* energy calculation is used 373* 374* P. Joergensen, C. Haettig 1997 375* Clean up, new output. Sonia 2001 376*=====================================================================* 377 378#if defined (IMPLICIT_NONE) 379 IMPLICIT NONE 380#else 381#include "implicit.h" 382#endif 383#include "priunit.h" 384#include "ccorb.h" 385#include "cctm.h" 386#include "cctminf.h" 387#include "ccexci.h" 388#include "cclr.h" 389 390 391* local parameters: 392 393 INTEGER ISYM, IST, ISEL, I, ISAVE, JSEL, J, IOFF 394 INTEGER ISYMSV, ISTSV, JSTSV, ISTATE 395 LOGICAL LOCDBG 396 PARAMETER (LOCDBG = .FALSE.) 397 398#if defined (SYS_CRAY) 399 REAL D3, BTMFRSV, CTMFRSV 400#else 401 DOUBLE PRECISION D3, BTMFRSV, CTMFRSV 402#endif 403 PARAMETER ( D3 = 3.0D00 ) 404 405C 406C sort the selected states for which third order transition 407C matrix elements are calculated 408C 409 DO 50 ISYM = 1,NSYM 410 NTMSELX(ISYM) = 0 411 50 CONTINUE 412C 413 IF ( SELTMST ) THEN 414C 415C sort list according to symmetry 416C 417 ITMSELX(1) = 0 418 DO 100 ISYM = 1,NSYM 419 IST = ITMSELX(ISYM) + 1 420 DO 200 I = IST,NTMSEL 421 IF ( ITMSEL(I,1).EQ.ISYM) THEN 422 NTMSELX(ISYM) = NTMSELX(ISYM) + 1 423 ELSE 424 DO 300 J = I+1,NTMSEL 425 IF ( ITMSEL(J,1).EQ.ISYM) THEN 426 ISYMSV = ITMSEL(J,1) 427 ISTSV = ITMSEL(J,2) 428 BTMFRSV = BTMFR(J) 429 CTMFRSV = CTMFR(J) 430 ITMSEL(J,1) = ITMSEL(I,1) 431 ITMSEL(J,2) = ITMSEL(I,2) 432 BTMFR(J) = BTMFR(I) 433 CTMFR(J) = CTMFR(I) 434 ITMSEL(I,1) = ISYMSV 435 ITMSEL(I,2) = ISTSV 436 BTMFR(I) = BTMFRSV 437 CTMFR(I) = CTMFRSV 438 NTMSELX(ISYM) = NTMSELX(ISYM) + 1 439 GO TO 200 440 END IF 441 300 CONTINUE 442 END IF 443 200 CONTINUE 444 IF ( ISYM .LT. NSYM ) THEN 445 ITMSELX(ISYM+1) = ITMSELX(ISYM) + NTMSELX(ISYM) 446 END IF 447 IF (LOCDBG) 448 & WRITE (LUPRI,*) 'SORT:',ITMSELX(ISYM),NTMSELX(ISYM),IST 449 100 CONTINUE 450 IF (LOCDBG) THEN 451 WRITE (LUPRI,*) ' after sort of symmetry ' 452 WRITE (LUPRI,*) 'ntmsel',ntmsel 453 do 210 i = 1,ntmsel 454 WRITE (LUPRI,*) ' itmsel(i,1),itmsel(i,2),i' 455 WRITE (LUPRI,*) itmsel(i,1),itmsel(i,2),i 456 210 continue 457 do 211 i = 1,nsym 458 WRITE (LUPRI,*) ' itmselx(i),ntmselx(i),i' 459 WRITE (LUPRI,*) itmselx(i),ntmselx(i),i 460 211 continue 461 END IF 462C 463C sort list according to state number 464C 465 DO 400 ISYM = 1,NSYM 466 IOFF = ITMSELX(ISYM) 467 DO 500 ISEL = 1,NTMSELX(ISYM) 468 I = IOFF + ISEL 469 ISTSV = ITMSEL(I,2) 470 ISAVE = I 471 DO 600 JSEL = ISEL+1,NTMSELX(ISYM) 472 J = IOFF + JSEL 473 JSTSV = ITMSEL(J,2) 474 IF ( JSTSV.LT. ISTSV ) THEN 475 ISTSV = JSTSV 476 ISAVE = J 477 END IF 478 600 CONTINUE 479 IF ( I.NE.ISAVE ) THEN 480 ISYMSV = ITMSEL(ISAVE,1) 481 ISTSV = ITMSEL(ISAVE,2) 482 BTMFRSV = BTMFR(ISAVE) 483 CTMFRSV = CTMFR(ISAVE) 484 ITMSEL(ISAVE,1) = ITMSEL(I,1) 485 ITMSEL(ISAVE,2) = ITMSEL(I,2) 486 BTMFR(ISAVE) = BTMFR(I) 487 CTMFR(ISAVE) = CTMFR(I) 488 ITMSEL(I,1) = ISYMSV 489 ITMSEL(I,2) = ISTSV 490 BTMFR(I) = BTMFRSV 491 CTMFR(I) = CTMFRSV 492 END IF 493 500 CONTINUE 494 400 CONTINUE 495 IF (LOCDBG) THEN 496 WRITE (LUPRI,*) ' after sort of both symmetry and state' 497 WRITE (LUPRI,*) 'ntmsel',ntmsel 498 do 212 i = 1,ntmsel 499 WRITE (LUPRI,*) ' itmsel(i,1),itmsel(i,2),i' 500 WRITE (LUPRI,*) itmsel(i,1),itmsel(i,2),i 501 212 continue 502 do 213 i = 1,nsym 503 WRITE (LUPRI,*) ' itmselx(i),ntmselx(i),i' 504 WRITE (LUPRI,*) itmselx(i),ntmselx(i),i 505 213 continue 506 END IF 507C 508C if .HALFFR not specified find frequencies for AOPERATOR 509C 510 DO 550 ISYM = 1,NSYM 511 IOFF = ITMSELX(ISYM) 512 WRITE (LUPRI,*) 'isym, ioff', isym, ioff 513 DO 560 I = 1,NTMSELX(ISYM) 514 ISTSV = ITMSEL(IOFF+I,2) 515 EXTMFR(IOFF+I) = EIGVAL(ISYOFE(ISYM)+ISTSV) 516 517 IF (LOCDBG) THEN 518 WRITE (LUPRI,*) 'istsv,ioff,isym,i' 519 WRITE (LUPRI,*) istsv,ioff,isym,i 520 WRITE (LUPRI,*) ' isyofe(isym)' 521 WRITE (LUPRI,*) isyofe(isym) 522 WRITE (LUPRI,*) ' eigval(1)' 523 call flshfo(LUPRI) 524 WRITE (LUPRI,*) eigval(1) 525 call flshfo(LUPRI) 526 WRITE (LUPRI,*) ' eigval(isyofe(isym)+istsv)' 527 call flshfo(LUPRI) 528 WRITE (LUPRI,*) eigval(isyofe(isym)+istsv) 529 call flshfo(LUPRI) 530 WRITE (LUPRI,*) ' EXTMFR(IOFF+I) ' 531 call flshfo(LUPRI) 532 WRITE (LUPRI,*) EXTMFR(IOFF+I) 533 call flshfo(LUPRI) 534 END IF 535 560 CONTINUE 536 IF (LOCDBG) THEN 537 WRITE (LUPRI,*) ' isym loop slut',isym 538 call flshfo(LUPRI) 539 END IF 540 550 CONTINUE 541 END IF 542C 543C if selected states not specified for second moment calculations 544C then carry out calculations for all specified excited states 545C and use frequencies that are half the excitation energy 546C 547 IF ( .NOT. SELTMST ) THEN 548 ITMSELX(1) = 0 549 NTMSEL = 0 550 DO 700 ISYM = 1,NSYM 551 DO 750 I = 1,NCCEXCI(ISYM,1) 552 NTMSEL = NTMSEL + 1 553 ITMSEL(NTMSEL,1) = ISYM 554 ITMSEL(NTMSEL,2) = I 555 NTMSELX(ISYM) = NTMSELX(ISYM) + 1 556 750 CONTINUE 557 ITMSELX(ISYM+1) = ITMSELX(ISYM) + NTMSELX(ISYM) 558 700 CONTINUE 559 THIRDFR = .TRUE. 560 END IF 561C 562C 563 IF (THIRDFR) THEN 564 DO 800 ISYM = 1,NSYM 565 IOFF = ITMSELX(ISYM) 566 DO 850 I = 1,NTMSELX(ISYM) 567 ISTATE = ITMSEL(IOFF+I,2) 568 BTMFR(IOFF+I) = EIGVAL(ISYOFE(ISYM)+ISTATE)/ D3 569 CTMFR(IOFF+I) = EIGVAL(ISYOFE(ISYM)+ISTATE)/ D3 570 EXTMFR(IOFF+I) = EIGVAL(ISYOFE(ISYM)+ISTATE) 571 850 CONTINUE 572 800 CONTINUE 573 END IF 574 IF (LOCDBG) THEN 575 WRITE(LUPRI,*) ' leaving sort' 576 do i = 1,ntmsel 577 WRITE(LUPRI,*) ' itmsel(i,1),itmsel(i,2),extmfr(i),i' 578 call flshfo(LUPRI) 579 WRITE(LUPRI,*) itmsel(i,1),itmsel(i,2),extmfr(i),i 580 end do 581 call flshfo(LUPRI) 582 END IF 583 584 RETURN 585 END 586*=====================================================================* 587