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_ETADRV */ 20*=====================================================================* 21 SUBROUTINE CC_ETADRV(TYPE,LABELV,ISYMS,ISTAT,EIGV, 22 & ISYMO,FREQS,ICAU,NVEC,MAXVEC, 23 & WORK,LWORK) 24*---------------------------------------------------------------------* 25* 26* Purpose: calculate response eta vectors, used to build the 27* right-hand-side vectors for the lagrangian multipliers 28* and as intermediates in the hyperpolarizability 29* and n-photon-transition matrix calculations 30* 31* for excited states the X vectors are identical to the 32* rhs vectors for the left eigenvector response equations 33* 34* implemented: L: ORDER = 2, 3 35* LE: ORDER = 1, 2 36* CL: ORDER = 2 37* 38* Written by Christof Haettig april/june/july 1997. 39* extensions for Cauchy eta vectors in March 1998. 40* adapted for CC-R12 by Christian Neiss, june 2005 41* 42*=====================================================================* 43#if defined (IMPLICIT_NONE) 44 IMPLICIT NONE 45#else 46# include "implicit.h" 47#endif 48#include "priunit.h" 49#include "ccsdinp.h" 50#include "ccsdsym.h" 51#include "ccorb.h" 52#include "cclists.h" 53#include "dummy.h" 54#include "r12int.h" 55 56* local parameters: 57 CHARACTER*(19) MSGDBG 58 PARAMETER (MSGDBG = '[debug] CC_ETADRV> ') 59 LOGICAL LOCDBG 60 PARAMETER (LOCDBG = .FALSE. ) 61 62 CHARACTER TYPE*(*) 63 64 INTEGER NVEC, MAXVEC, LWORK 65 INTEGER ISYMO(MAXVEC,*), ICAU(MAXVEC,*) 66 INTEGER ISYMS(MAXVEC,*), ISTAT(MAXVEC,*) 67 68 CHARACTER*8 LABELV(MAXVEC,*) 69 CHARACTER*3 APROXR12 70 71#if defined (SYS_CRAY) 72 REAL FREQS(MAXVEC,*), EIGV(MAXVEC,*) 73 REAL WORK(LWORK) 74 REAL ZERO 75 REAL DDOT, XNORM, RDUM 76#else 77 DOUBLE PRECISION FREQS(MAXVEC,*), EIGV(MAXVEC,*) 78 DOUBLE PRECISION WORK(LWORK) 79 DOUBLE PRECISION ZERO 80 DOUBLE PRECISION DDOT, XNORM, RDUM 81#endif 82 PARAMETER (ZERO = 0.0d0) 83 84 CHARACTER MODEL*(10) 85 INTEGER MX0KTRAN, MX1GTRAN, MX2FTRAN, MX1FATRAN 86 INTEGER MXTRAN, MX0GTRAN, MX1FTRAN, MX0FATRAN, MXXETRAN 87 INTEGER K0KTRAN, K1GTRAN, K2FTRAN, K1FATRAN 88 INTEGER K0GTRAN, K1FTRAN, K0FATRAN, KXETRAN 89 INTEGER N0KTRAN, N1GTRAN, N2FTRAN, N1FATRAN 90 INTEGER N0GTRAN, N1FTRAN, N0FATRAN, NEATRAN 91 INTEGER IOPT, ISYM, IVEC, ORDER, MPERM, NSTAT, IOPTH, IOPTRW 92 INTEGER KEND0, LEND0, KEND1, LEND1, LMAX1, LMAX2, KCHI1, KCHI2 93 INTEGER KEND2, LEND2, KRHS1, KRHS2, IDUM 94 INTEGER KCHIR12, LMAXR12, IOPTRWR12, MODLEN, KRHSR12 95 96* external functions 97 INTEGER ILSTSYM 98 99*---------------------------------------------------------------------* 100* check number of required eta/rhs vectors, if zero return immediatly: 101*---------------------------------------------------------------------* 102 IF (NVEC.EQ.0) RETURN 103 104*---------------------------------------------------------------------* 105* print header for eta/rhs vector section 106*---------------------------------------------------------------------* 107 WRITE (LUPRI,'(7(/1X,2A),/)') 108 & '------------------------------------', 109 & '-------------------------------', 110 & '| OUTPUT FROM ETA/RH', 111 & 'S VECTOR SECTION |', 112 & '------------------------------------', 113 & '-------------------------------' 114 CALL FLSHFO(LUPRI) 115 116*---------------------------------------------------------------------* 117 IF (.NOT. (CCS .OR. CC2 .OR. CCSD) ) THEN 118 CALL QUIT('CC_ETADRV called for unknown Coupled Cluster.') 119 END IF 120 121 IF (TYPE(1:3).EQ.'X1 ') THEN 122 WRITE (LUPRI,*) 'X1 vectors not implemented in CC_ETADRV,' 123 WRITE (LUPRI,*) 'routine CCRHSVEC should be used instead.' 124 CALL QUIT('X1 vectors not implemented in CC_ETADRV.') 125 ELSE IF (TYPE(1:2).EQ.'X2') THEN 126 ORDER = 2 127 NSTAT = 0 128 MPERM = 2 129 ELSE IF (TYPE(1:2).EQ.'X3') THEN 130 ORDER = 3 131 NSTAT = 0 132 MPERM = 6 133C ELSE IF (TYPE(1:2).EQ.'X4') THEN 134C ORDER = 4 135C NSTAT = 0 136C MPERM = ?? 137 ELSE IF (TYPE(1:3).EQ.'EX1') THEN 138 ORDER = 1 139 NSTAT = 1 140 MPERM = 1 141 ELSE IF (TYPE(1:3).EQ.'EX2') THEN 142 ORDER = 2 143 NSTAT = 1 144 MPERM = 2 145 WRITE (LUPRI,*) 'warning: X vectors ',TYPE(1:3), 146 & ' not tested!!!.' 147 ELSE IF (TYPE(1:3).EQ.'CX2') THEN 148 ORDER = 2 149 NSTAT = 0 150 MPERM = 2 151 ELSE 152 WRITE (LUPRI,*) 'rhs vectors ',TYPE(1:2),' not implemented.' 153 CALL QUIT('required rhs vectors not implemented.') 154 END IF 155 156 157* print some debug/info output 158 IF (IPRINT .GT. 10) WRITE(LUPRI,*) 'CC_ETADRV Workspace:',LWORK 159 160*---------------------------------------------------------------------* 161* allocate & initialize work space for lists 162*---------------------------------------------------------------------* 163 164 MXTRAN = MPERM * NVEC 165 166 MX0KTRAN = 5 * MXTRAN 167 MX0GTRAN = 4 * MXTRAN 168 MX1GTRAN = 4 * MXTRAN 169 MX1FTRAN = 3 * MXTRAN 170 MX2FTRAN = 3 * MXTRAN 171 MX0FATRAN = 5 * MXTRAN 172 MX1FATRAN = 5 * MXTRAN 173 MXXETRAN = MXDIM_XEVEC * MXTRAN 174 175 K0KTRAN = 1 176 K0GTRAN = K0KTRAN + MX0KTRAN 177 K1GTRAN = K0GTRAN + MX0GTRAN 178 K1FTRAN = K1GTRAN + MX1GTRAN 179 K2FTRAN = K1FTRAN + MX1FTRAN 180 K0FATRAN = K2FTRAN + MX2FTRAN 181 K1FATRAN = K0FATRAN + MX0FATRAN 182 KXETRAN = K1FATRAN + MX1FATRAN 183 KEND0 = KXETRAN + MXXETRAN 184 LEND0 = LWORK - KEND0 185 186 IF (LEND0 .LT. 0 ) THEN 187 CALL QUIT('Insufficient work space in CC_ETADRV.') 188 END IF 189 190*---------------------------------------------------------------------* 191* set up lists for G, F and F{A} transformations and ETA{O} vectors: 192*---------------------------------------------------------------------* 193 CALL CC_ETA_SETUP(TYPE,NSTAT,ORDER,LABELV,ISTAT,EIGV,FREQS,ICAU, 194 & NVEC, MAXVEC, MXTRAN, 195 & WORK(K0KTRAN), N0KTRAN, 196 & WORK(K0GTRAN), N0GTRAN, 197 & WORK(K1GTRAN), N1GTRAN, 198 & WORK(K1FTRAN), N1FTRAN, 199 & WORK(K2FTRAN), N2FTRAN, 200 & WORK(K0FATRAN),N0FATRAN, 201 & WORK(K1FATRAN),N1FATRAN, 202 & WORK(KXETRAN), NEATRAN ) 203 204*---------------------------------------------------------------------* 205* initialize ETA vector files: 206*---------------------------------------------------------------------* 207 LMAX1 = 0 208 LMAX2 = 0 209 LMAXR12 = 0 210 DO ISYM = 1, NSYM 211 LMAX1 = MAX(LMAX1,NT1AM(ISYM)) 212 LMAX2 = MAX(LMAX2,NT2AM(ISYM)) 213 IF (CCR12) LMAXR12 = MAX(LMAXR12,NTR12AM(ISYM)) 214 END DO 215 216 KCHI1 = KEND0 217 KCHI2 = KCHI1 + LMAX1 218 KCHIR12 = KCHI2 + LMAXR12 219 KEND1 = KCHIR12 + LMAX2 220 LEND1 = LWORK - KEND1 221 222 IF (LEND1 .LT. 0 ) THEN 223 CALL QUIT('Insufficient work space in CC_ETADRV.') 224 END IF 225 226 CALL DZERO(WORK(KCHI1),LMAX1) 227 IF (.NOT.CCS) CALL DZERO(WORK(KCHI2),LMAX2) 228 IF (CCR12) CALL DZERO(WORK(KCHIR12),LMAXR12) 229 230 IF (CCS) THEN 231 MODEL = 'CCS ' 232 IOPTRW = 1 233 ELSE IF (CC2) THEN 234 MODEL = 'CC2 ' 235 IOPTRW = 3 236 ELSE IF (CCSD) THEN 237 MODEL = 'CCSD ' 238 IOPTRW = 3 239 ELSE 240 CALL QUIT('Unknown coupled cluster model in CC_ETADRV.') 241 END IF 242 IF (CCR12) THEN 243 APROXR12 = ' ' 244 IOPTRWR12 = 32 245 END IF 246 CALL CCSD_MODEL(MODEL,MODLEN,10,MODEL,10,APROXR12) 247 248 DO IVEC = 1, NVEC 249 ISYM = ILSTSYM(TYPE,IVEC) 250 CALL CC_WRRSP(TYPE,IVEC,ISYM,IOPTRW,MODEL,IDUMMY, 251 & WORK(KCHI1),WORK(KCHI2),WORK(KEND1),LEND1) 252 IF (CCR12) THEN 253 CALL CC_WRRSP(TYPE,IVEC,ISYM,IOPTRWR12,MODEL,IDUMMY, 254 & IDUMMY,WORK(KCHIR12),WORK(KEND1),LEND1) 255 END IF 256 END DO 257 258*---------------------------------------------------------------------* 259* calculate H matrix contributions: 260*---------------------------------------------------------------------* 261 IF (TYPE(1:2).EQ.'X3') THEN 262 IOPTH = 4 263 CALL CC_HMAT('L0','R1','R1','R1',TYPE,N0KTRAN, 0, 264 & WORK(K0KTRAN),IDUMMY,IDUMMY, 265 & WORK(KEND0), LEND0, IOPTH ) 266 END IF 267 268 IF (LOCDBG) THEN 269 WRITE (LUPRI,*) 270 & MSGDBG, 'NORM^2 of ETA vectors after H matrix terms:' 271 DO IVEC = 1, NVEC 272 ISYM = ILSTSYM(TYPE,IVEC) 273 CALL CC_RDRSP(TYPE,IVEC,ISYM,IOPTRW,MODEL, 274 & WORK(KCHI1),WORK(KCHI2)) 275 IF (CCR12) CALL CC_RDRSP(TYPE,IVEC,ISYM,IOPTRWR12,MODEL, 276 & DUMMY,WORK(KCHIR12)) 277 XNORM = DDOT(NT1AM(ISYM),WORK(KCHI1),1,WORK(KCHI1),1) 278 IF (.NOT.CCS) 279 & XNORM = XNORM+DDOT(NT2AM(ISYM),WORK(KCHI2),1,WORK(KCHI2),1) 280 IF (CCR12) 281 & XNORM = XNORM+DDOT(NTR12AM(ISYM),WORK(KCHIR12),1, 282 & WORK(KCHIR12),1) 283 WRITE (LUPRI,*) MSGDBG, IVEC,XNORM 284 END DO 285 END IF 286 287*---------------------------------------------------------------------* 288* calculate G matrix contributions: 289*---------------------------------------------------------------------* 290 IF (TYPE(1:2).EQ.'X2') THEN 291 IOPT = 4 292 CALL CC_GMATRIX('L0 ','R1 ','R1 ',TYPE,N0GTRAN, 0, 293 & WORK(K0GTRAN),IDUM,RDUM,WORK(KEND0),LEND0,IOPT) 294 ELSE IF (TYPE(1:2).EQ.'X3') THEN 295 IOPT = 4 296 CALL CC_GMATRIX('L0 ','R2 ','R1 ',TYPE,N0GTRAN, 0, 297 & WORK(K0GTRAN),IDUM,RDUM,WORK(KEND0),LEND0,IOPT) 298 IOPT = 4 299 CALL CC_GMATRIX('L1 ','R1 ','R1 ',TYPE,N1GTRAN, 0, 300 & WORK(K1GTRAN),IDUM,RDUM,WORK(KEND0),LEND0,IOPT) 301 ELSE IF (TYPE(1:3).EQ.'EX2') THEN 302 IOPT = 4 303 CALL CC_GMATRIX('LE ','R1 ','R1 ',TYPE,N0GTRAN, 0, 304 & WORK(K0GTRAN),IDUM,RDUM,WORK(KEND0),LEND0,IOPT) 305 ELSE IF (TYPE(1:3).EQ.'CX2') THEN 306 IOPT = 4 307 CALL CC_GMATRIX('L0 ','RC ','RC ',TYPE,N0GTRAN, 0, 308 & WORK(K0GTRAN),IDUM,RDUM,WORK(KEND0),LEND0,IOPT) 309 END IF 310 311 IF (LOCDBG) THEN 312 WRITE (LUPRI,*) MSGDBG, 313 & 'NORM^2 of ETA vectors after G matrix terms:' 314 DO IVEC = 1, NVEC 315 ISYM = ILSTSYM(TYPE,IVEC) 316 CALL CC_RDRSP(TYPE,IVEC,ISYM,IOPTRW,MODEL, 317 & WORK(KCHI1),WORK(KCHI2)) 318 IF (CCR12.AND..NOT.(CCS.OR.CC2)) 319 & CALL CC_RDRSP(TYPE,IVEC,ISYM,IOPTRWR12,MODEL, 320 & DUMMY,WORK(KCHIR12)) 321 XNORM = DDOT(NT1AM(ISYM),WORK(KCHI1),1,WORK(KCHI1),1) 322 IF (.NOT.CCS) 323 & XNORM = XNORM+DDOT(NT2AM(ISYM),WORK(KCHI2),1,WORK(KCHI2),1) 324 IF (CCR12.AND..NOT.(CCS.OR.CC2)) 325 & XNORM = XNORM+DDOT(NTR12AM(ISYM),WORK(KCHIR12),1, 326 & WORK(KCHIR12),1) 327 WRITE (LUPRI,*) MSGDBG, IVEC,XNORM 328 END DO 329 END IF 330 331*---------------------------------------------------------------------* 332* calculate F matrix contributions: 333*---------------------------------------------------------------------* 334 IF (TYPE(1:2).EQ.'X2') THEN 335 IOPT = 4 336 CALL CC_FMATRIX(WORK(K1FTRAN),N1FTRAN,'L1 ','R1 ',IOPT,TYPE, 337 & IDUM, RDUM, 0, WORK(KEND0), LEND0) 338 ELSE IF (TYPE(1:3).EQ.'CX2') THEN 339 IOPT = 4 340 CALL CC_FMATRIX(WORK(K1FTRAN),N1FTRAN,'LC ','RC ',IOPT,TYPE, 341 & IDUM, RDUM, 0, WORK(KEND0), LEND0) 342 ELSE IF (TYPE(1:2).EQ.'X3') THEN 343 IOPT = 4 344 CALL CC_FMATRIX(WORK(K1FTRAN),N1FTRAN,'L1 ','R2 ',IOPT,TYPE, 345 & IDUM, RDUM, 0, WORK(KEND0), LEND0) 346 IOPT = 4 347 CALL CC_FMATRIX(WORK(K2FTRAN),N2FTRAN,'L2 ','R1 ',IOPT,TYPE, 348 & IDUM, RDUM, 0, WORK(KEND0), LEND0) 349 ELSE IF (TYPE(1:3).EQ.'EX2') THEN 350 IOPT = 4 351 CALL CC_FMATRIX(WORK(K1FTRAN),N1FTRAN,'LE ','R2 ',IOPT,TYPE, 352 & IDUM, RDUM, 0, WORK(KEND0), LEND0) 353 IOPT = 4 354 CALL CC_FMATRIX(WORK(K2FTRAN),N2FTRAN,'EL1','R1 ',IOPT,TYPE, 355 & IDUM, RDUM, 0, WORK(KEND0), LEND0) 356 ELSE IF (TYPE(1:3).EQ.'EX1') THEN 357 IOPT = 4 358 CALL CC_FMATRIX(WORK(K1FTRAN),N1FTRAN,'LE ','R1 ',IOPT,TYPE, 359 & IDUM, RDUM, 0, WORK(KEND0), LEND0) 360 END IF 361 362 IF (LOCDBG) THEN 363 WRITE (LUPRI,*) MSGDBG, 364 & 'NORM^2 of ETA vectors after F matrix terms:' 365 DO IVEC = 1, NVEC 366 ISYM = ILSTSYM(TYPE,IVEC) 367 CALL CC_RDRSP(TYPE,IVEC,ISYM,IOPTRW,MODEL, 368 & WORK(KCHI1),WORK(KCHI2)) 369 IF (CCR12) CALL CC_RDRSP(TYPE,IVEC,ISYM,IOPTRWR12,MODEL, 370 & DUMMY,WORK(KCHIR12)) 371 XNORM = DDOT(NT1AM(ISYM),WORK(KCHI1),1,WORK(KCHI1),1) 372 IF (.NOT.CCS) 373 & XNORM = XNORM+DDOT(NT2AM(ISYM),WORK(KCHI2),1,WORK(KCHI2),1) 374 IF (CCR12) 375 & XNORM = XNORM+DDOT(NTR12AM(ISYM),WORK(KCHIR12),1, 376 & WORK(KCHIR12),1) 377 WRITE (LUPRI,*) MSGDBG, IVEC,XNORM 378 END DO 379 END IF 380 381*---------------------------------------------------------------------* 382* calculate F{O} matrix contributions: 383*---------------------------------------------------------------------* 384 IF (TYPE(1:2).EQ.'X2') THEN 385 CALL CCQR_FADRV('L0 ','o1 ','R1 ',TYPE,N0FATRAN, 0, 386 & WORK(K0FATRAN),IDUMMY,IDUMMY, 387 & WORK(KEND0), LEND0, 'FILE' ) 388 ELSE IF (TYPE(1:3).EQ.'CX2') THEN 389 CALL CCQR_FADRV('L0 ','o1 ','RC ',TYPE,N0FATRAN, 0, 390 & WORK(K0FATRAN),IDUMMY,IDUMMY, 391 & WORK(KEND0), LEND0, 'FILE' ) 392 ELSE IF (TYPE(1:2).EQ.'X3') THEN 393 CALL CCQR_FADRV('L0 ','o1 ','R2 ',TYPE,N0FATRAN, 0, 394 & WORK(K0FATRAN),IDUMMY,IDUMMY, 395 & WORK(KEND0), LEND0, 'FILE' ) 396 CALL CCQR_FADRV('L1 ','o1 ','R1 ',TYPE,N1FATRAN, 0, 397 & WORK(K1FATRAN),IDUMMY,IDUMMY, 398 & WORK(KEND0), LEND0, 'FILE' ) 399 ELSE IF (TYPE(1:3).EQ.'EX2') THEN 400 CALL CCQR_FADRV('LE ','o1 ','R1 ',TYPE,N0FATRAN, 0, 401 & WORK(K0FATRAN),IDUMMY,IDUMMY, 402 & WORK(KEND0), LEND0, 'FILE' ) 403 END IF 404 405 IF (LOCDBG) THEN 406 WRITE (LUPRI,*) MSGDBG, 407 & 'NORM^2 of ETA vectors after F{O} matrix terms:' 408 DO IVEC = 1, NVEC 409 ISYM = ILSTSYM(TYPE,IVEC) 410 CALL CC_RDRSP(TYPE,IVEC,ISYM,IOPTRW,MODEL, 411 & WORK(KCHI1),WORK(KCHI2)) 412 IF (CCR12) CALL CC_RDRSP(TYPE,IVEC,ISYM,IOPTRWR12,MODEL, 413 & DUMMY,WORK(KCHIR12)) 414 XNORM = DDOT(NT1AM(ISYM),WORK(KCHI1),1,WORK(KCHI1),1) 415 IF (.NOT.CCS) 416 & XNORM = XNORM+DDOT(NT2AM(ISYM),WORK(KCHI2),1,WORK(KCHI2),1) 417 IF (CCR12) 418 & XNORM = XNORM+DDOT(NTR12AM(ISYM),WORK(KCHIR12),1, 419 & WORK(KCHIR12),1) 420 WRITE (LUPRI,*) MSGDBG, IVEC,XNORM 421 END DO 422 END IF 423 424*---------------------------------------------------------------------* 425* calculate ETA{O} vector contributions: 426*---------------------------------------------------------------------* 427 IF (TYPE(1:2).EQ.'X2') THEN 428 IOPT = 4 429 ORDER = 1 430 CALL CC_XIETA(WORK(KXETRAN),NEATRAN,IOPT, ORDER, 'L1 ', 431 & 'O1 ', IDUM, RDUM, TYPE, IDUM, RDUM, 432 & .FALSE.,0, WORK(KEND0),LEND0) 433 ELSE IF (TYPE(1:3).EQ.'CX2') THEN 434 IOPT = 4 435 ORDER = 1 436 CALL CC_XIETA(WORK(KXETRAN),NEATRAN,IOPT, ORDER, 'LC ', 437 & 'O1 ', IDUM, RDUM, TYPE, IDUM, RDUM, 438 & .FALSE.,0, WORK(KEND0),LEND0) 439 ELSE IF (TYPE(1:2).EQ.'X3') THEN 440 IOPT = 4 441 ORDER = 1 442 CALL CC_XIETA(WORK(KXETRAN),NEATRAN,IOPT, ORDER, 'L2 ', 443 & 'O1 ', IDUM, RDUM, TYPE, IDUM, RDUM, 444 & .FALSE.,0, WORK(KEND0),LEND0) 445 ELSE IF (TYPE(1:3).EQ.'EX2') THEN 446 IOPT = 4 447 ORDER = 1 448 CALL CC_XIETA(WORK(KXETRAN),NEATRAN,IOPT, ORDER, 'EL1', 449 & 'O1 ', IDUM, RDUM, TYPE, IDUM, RDUM, 450 & .FALSE.,0, WORK(KEND0),LEND0) 451 ELSE IF (TYPE(1:3).EQ.'EX1') THEN 452 IOPT = 4 453 ORDER = 1 454 CALL CC_XIETA(WORK(KXETRAN),NEATRAN,IOPT, ORDER, 'LE ', 455 & 'O1 ', IDUM, RDUM, TYPE, IDUM, RDUM, 456 & .FALSE.,0, WORK(KEND0),LEND0) 457 END IF 458 459 IF (LOCDBG) THEN 460 WRITE (LUPRI,*) MSGDBG, 461 & 'NORM^2 of ETA vectors after ETA{O} vec. terms:' 462 DO IVEC = 1, NVEC 463 ISYM = ILSTSYM(TYPE,IVEC) 464 CALL CC_RDRSP(TYPE,IVEC,ISYM,IOPTRW,MODEL, 465 & WORK(KCHI1),WORK(KCHI2)) 466 IF (CCR12) CALL CC_RDRSP(TYPE,IVEC,ISYM,IOPTRWR12,MODEL, 467 & DUMMY,WORK(KCHIR12)) 468 XNORM = DDOT(NT1AM(ISYM),WORK(KCHI1),1,WORK(KCHI1),1) 469 IF (.NOT.CCS) 470 & XNORM = XNORM+DDOT(NT2AM(ISYM),WORK(KCHI2),1,WORK(KCHI2),1) 471 IF (CCR12) 472 & XNORM = XNORM+DDOT(NTR12AM(ISYM),WORK(KCHIR12),1, 473 & WORK(KCHIR12),1) 474 WRITE (LUPRI,*) MSGDBG, IVEC,XNORM 475 END DO 476 END IF 477*---------------------------------------------------------------------* 478* test (static) EX1 vectors by calculating the excited state FOP's 479*---------------------------------------------------------------------* 480 IF (LOCDBG .AND. TYPE(1:3).EQ.'EX1') THEN 481 KRHS1 = KEND1 482 KRHS2 = KRHS1 + LMAX1 483 KEND2 = KRHS2 + LMAX2 484 IF (CCR12) THEN 485 KRHSR12 = KEND2 486 KEND2 = KRHSR12 + LMAXR12 487 END IF 488 LEND2 = LWORK - KEND2 489 490 IF (LEND2 .LT. 0 ) THEN 491 CALL QUIT('Insufficient work space in CC_ETADRV.') 492 END IF 493 494 WRITE (LUPRI,*) MSGDBG, 'excited state first-order properties:' 495 DO IVEC = 1, NVEC 496 IF (ISYMO(IVEC,1).EQ.1 .AND. FREQS(IVEC,1).EQ.ZERO) THEN 497 ISYM = ILSTSYM(TYPE,IVEC) 498 CALL CC_RDRSP(TYPE,IVEC,ISYM,IOPTRW,MODEL, 499 & WORK(KCHI1),WORK(KCHI2)) 500 IF (CCR12) CALL CC_RDRSP(TYPE,IVEC,ISYM,IOPTRWR12,MODEL, 501 & DUMMY,WORK(KCHIR12)) 502 CALL CC_RDRSP('RE',ISTAT(IVEC,1),ISYMS(IVEC,1),IOPTRW,MODEL, 503 & WORK(KRHS1),WORK(KRHS2)) 504 IF (CCR12) CALL CC_RDRSP('RE',ISTAT(IVEC,1),ISYMS(IVEC,1), 505 & IOPTRWR12,MODEL,DUMMY,WORK(KRHSR12)) 506 XNORM = DDOT(NT1AM(ISYM),WORK(KCHI1),1,WORK(KRHS1),1) 507 IF (.NOT. CCS) 508 & XNORM = XNORM+DDOT(NT2AM(ISYM),WORK(KCHI2),1,WORK(KRHS2),1) 509 IF (CCR12) 510 & XNORM = XNORM+DDOT(NTR12AM(ISYM),WORK(KCHIR12),1, 511 & WORK(KRHSR12),1) 512 WRITE (LUPRI,'(A,I3,2X,F12.8,2X,A,2X,F12.8)') MSGDBG, 513 & ISTAT(IVEC,1),EIGV(IVEC,1),LABELV(IVEC,1),XNORM 514 ELSE 515 WRITE (LUPRI,'(A,I3,2X,F12.8,2X,A,2X,F12.8)') MSGDBG, 516 & ISTAT(IVEC,1),EIGV(IVEC,1),LABELV(IVEC,1),ZERO 517 END IF 518 END DO 519 520 END IF 521*---------------------------------------------------------------------* 522* that's it: 523*---------------------------------------------------------------------* 524 525 RETURN 526 END 527 528*=====================================================================* 529* END OF SUBROUTINE CC_ETADRV * 530*=====================================================================* 531 532c /* deck CC_ETA_SETUP */ 533*=====================================================================* 534 SUBROUTINE CC_ETA_SETUP(TYPE,NSTAT,ORDER,LAB, 535 & ISTAT,EIGV,FREQ,ICAU, 536 & NVEC, MAXVEC, MXTRAN, 537 & I0KTRAN, N0KTRAN, 538 & I0GTRAN, N0GTRAN, 539 & I1GTRAN, N1GTRAN, 540 & I1FTRAN, N1FTRAN, 541 & I2FTRAN, N2FTRAN, 542 & I0FATRAN,N0FATRAN, 543 & I1FATRAN,N1FATRAN, 544 & IXETRAN, NEATRAN ) 545*---------------------------------------------------------------------* 546* 547* Purpose: set up for CC_ETA section 548* - list of G matrix transformations 549* - list of F matrix transformations 550* - list of F{O} matrix transformations 551* - list of ETA{O} vector calculations 552* 553* Written by Christof Haettig, april/june/july 1997. 554* extensions for Cauchy eta vectors in march 1998. 555* 556*=====================================================================* 557#if defined (IMPLICIT_NONE) 558 IMPLICIT NONE 559#else 560# include "implicit.h" 561#endif 562#include "priunit.h" 563#include "cclists.h" 564 565* local parameters: 566 CHARACTER*(22) MSGDBG 567 PARAMETER (MSGDBG = '[debug] CC_ETA_SETUP> ') 568 LOGICAL LOCDBG 569 PARAMETER (LOCDBG = .FALSE.) 570 571 572 INTEGER MXORD, MXORD2, MXORD3, MXSTAT 573 PARAMETER (MXORD = 4, MXSTAT = 2) 574 PARAMETER (MXORD2 = MXORD *(MXORD-1)/2 ) 575 PARAMETER (MXORD3 = MXORD2*(MXORD-2)/3 ) 576 577 578 INTEGER MXTRAN, NSTAT, ORDER, MAXVEC, NVEC 579 580 CHARACTER*(*) TYPE 581 582 CHARACTER*(8) LAB(MAXVEC,*) 583 INTEGER ISTAT(MAXVEC,*), ICAU(MAXVEC,*) 584 585#if defined (SYS_CRAY) 586 REAL FREQ(MAXVEC,*), EIGV(MAXVEC,*) 587#else 588 DOUBLE PRECISION FREQ(MAXVEC,*), EIGV(MAXVEC,*) 589#endif 590 591 INTEGER I0KTRAN(5,MXTRAN) 592 INTEGER I0GTRAN(4,MXTRAN) 593 INTEGER I1GTRAN(4,MXTRAN) 594 INTEGER I1FTRAN(3,MXTRAN) 595 INTEGER I2FTRAN(3,MXTRAN) 596 INTEGER I0FATRAN(5,MXTRAN) 597 INTEGER I1FATRAN(5,MXTRAN) 598 INTEGER IXETRAN(MXDIM_XEVEC,MXTRAN) 599 600 INTEGER N0KTRAN, N1GTRAN, N2FTRAN, N1FATRAN 601 INTEGER N0GTRAN, N1FTRAN, N0FATRAN, NEATRAN 602 603 INTEGER IVEC, ISYML, ITRAN, I, IDX, IDXA, IDXB, IDXAB, IDXS 604 605 INTEGER A, B, C, D 606 PARAMETER (A = 1, B = 2, C = 3, D = 4) 607 INTEGER AB, AC, AD, BC, BD, CD 608 PARAMETER (AB = 1, AC = 2, BC = 3, AD = 4, BD = 5, CD = 6) 609 INTEGER ABC, ABD, ACD, BCD 610 PARAMETER (ABC = 1, ABD = 2, ACD = 3, BCD = 4) 611 612 INTEGER NS2A, NS3A, NP3AB, NP4AB, NT4ABC 613 PARAMETER (NS2A = 2, NS3A = 3, NP3AB = 3, NP4AB = 6, NT4ABC = 4) 614 615 INTEGER ISA(NS3A), ISB(NS3A), ISC(NS3A) 616 INTEGER IPAB(NP4AB), IPC(NP4AB), IPD(NP4AB), IPCD(NP4AB) 617 INTEGER ITABC(NT4ABC), ITD(NT4ABC) 618 619 DATA ISA / A, B, C/ 620 DATA ISB / B, A, A/ 621 DATA ISC / C, C, B/ 622 623 DATA IPAB / AB, AC, BC, AD, BD, CD / 624 DATA IPC / C, B, A, B, A, A / 625 DATA IPD / D, D, D, C, C, B / 626 DATA IPCD / CD, BD, AD, BC, AC, AB / 627 628 DATA ITABC / ABC, ABD, ACD, BCD / 629 DATA ITD / D, C, B, A / 630 631 632 INTEGER IL0 633 PARAMETER (IL0 = 0) ! index for zeroth-order zeta vector 634 INTEGER IL1(MXORD), IR1(MXORD), IOP(MXORD), ISYM(MXORD) 635 INTEGER IL2(MXORD2), IR2(MXORD2) 636 INTEGER IE0(MXSTAT), IE1(MXORD,MXSTAT), ISYMS(MXSTAT) 637 INTEGER LEN 638 639 CHARACTER CLASS*(5) 640 641 642* external functions: 643 INTEGER IROPER 644 INTEGER IR1TAMP 645 INTEGER IR2TAMP 646 INTEGER IL1ZETA 647 INTEGER IL2ZETA 648 INTEGER IEL1AMP 649 INTEGER IEL2AMP 650 INTEGER ILRCAMP 651 INTEGER ILC1AMP 652 653*---------------------------------------------------------------------* 654* initializations: 655*---------------------------------------------------------------------* 656 N0KTRAN = 0 657 N0GTRAN = 0 658 N1GTRAN = 0 659 N1FTRAN = 0 660 N2FTRAN = 0 661 N0FATRAN = 0 662 N1FATRAN = 0 663 NEATRAN = 0 664 665*---------------------------------------------------------------------* 666* start loop over all requested ETA-vectors: 667*---------------------------------------------------------------------* 668 669 DO IVEC = 1, NVEC 670 671* eigenvectors that contribute: 672 IF (NSTAT.EQ.1) THEN 673 DO IDXS = 1, NSTAT 674 IE0(IDXS) = ISTAT(IVEC,IDXS) 675 END DO 676 END IF 677 678* operators: 679 IF (ORDER.GE.1) THEN 680 DO IDXA = 1, ORDER 681 IOP(IDXA) = IROPER(LAB(IVEC,IDXA),ISYML) 682 END DO 683 END IF 684 685* operators and first-order vectors that contribute: 686 IF (TYPE(1:1).EQ.'X' .AND. ORDER.GT.1) THEN 687 DO IDXA = 1, ORDER 688 IL1(IDXA) = IL1ZETA(LAB(IVEC,IDXA),.FALSE., 689 & FREQ(IVEC,IDXA),ISYML) 690 IR1(IDXA) = IR1TAMP(LAB(IVEC,IDXA),.FALSE., 691 & FREQ(IVEC,IDXA),ISYML) 692 END DO 693 END IF 694 IF (TYPE(1:2).EQ.'CX' .AND. ORDER.GT.1) THEN 695 DO IDXA = 1, ORDER 696 IR1(IDXA) = ILRCAMP(LAB(IVEC,IDXA),ICAU(IVEC,IDXA),ISYML) 697 IL1(IDXA) = ILC1AMP(LAB(IVEC,IDXA),ICAU(IVEC,IDXA),ISYML) 698 END DO 699 END IF 700 IF (TYPE(1:2).EQ.'EX' .AND. ORDER.GE.1) THEN 701 DO IDXA = 1, ORDER 702 IR1(IDXA) = IR1TAMP(LAB(IVEC,IDXA),.FALSE., 703 & FREQ(IVEC,IDXA),ISYML) 704 END DO 705 IF (ORDER.GT.1) THEN 706 IE1(IDXA,1) = 707 & IEL1AMP(ISTAT(IVEC,1),EIGV(IVEC,1),ISYMS(1), 708 & LAB(IVEC,IDXA),FREQ(IVEC,IDXA),ISYM(IDXA), 709 & .FALSE.,.FALSE.) 710 END IF 711 END IF 712* second-order vectors that contribute: 713 IF (ORDER.GT.2 .OR. (ORDER.GE.2 .AND. NSTAT.GE.1)) THEN 714 715 IDXAB = 0 716 DO IDXB = 2, ORDER 717 DO IDXA = 1, IDXB-1 718 IDXAB = IDXAB + 1 719 IR2(IDXAB) = 720 & IR2TAMP(LAB(IVEC,IDXA),.FALSE.,FREQ(IVEC,IDXA),ISYM(IDXA), 721 & LAB(IVEC,IDXB),.FALSE.,FREQ(IVEC,IDXB),ISYM(IDXB)) 722 END DO 723 END DO 724 725 IF (TYPE(1:2).NE.'EX') THEN 726 IDXAB = 0 727 DO IDXB = 2, ORDER 728 DO IDXA = 1, IDXB-1 729 IDXAB = IDXAB + 1 730 IL2(IDXAB) = 731 & IL2ZETA(LAB(IVEC,IDXA),FREQ(IVEC,IDXA),ISYM(IDXA), 732 & LAB(IVEC,IDXB),FREQ(IVEC,IDXB),ISYM(IDXB)) 733 END DO 734 END DO 735 END IF 736 737 END IF 738 739 740*---------------------------------------------------------------------* 741* set up list of H matrix transformations 742*---------------------------------------------------------------------* 743 IF (TYPE(1:2).EQ.'X3') THEN 744 N0KTRAN = N0KTRAN + 1 745 I0KTRAN(1,N0KTRAN) = IL0 746 I0KTRAN(2,N0KTRAN) = IR1(A) 747 I0KTRAN(3,N0KTRAN) = IR1(B) 748 I0KTRAN(4,N0KTRAN) = IR1(C) 749 I0KTRAN(5,N0KTRAN) = IVEC 750 END IF 751*---------------------------------------------------------------------* 752* set up list of G matrix transformations 753*---------------------------------------------------------------------* 754 IF (TYPE(1:2).EQ.'X2') THEN 755 N0GTRAN = N0GTRAN + 1 756 I0GTRAN(1,N0GTRAN) = IL0 757 I0GTRAN(2,N0GTRAN) = IR1(A) 758 I0GTRAN(3,N0GTRAN) = IR1(B) 759 I0GTRAN(4,N0GTRAN) = IVEC 760 ELSE IF (TYPE(1:3).EQ.'CX2') THEN 761 N0GTRAN = N0GTRAN + 1 762 I0GTRAN(1,N0GTRAN) = IL0 763 I0GTRAN(2,N0GTRAN) = IR1(A) 764 I0GTRAN(3,N0GTRAN) = IR1(B) 765 I0GTRAN(4,N0GTRAN) = IVEC 766 ELSE IF (TYPE(1:2).EQ.'X3') THEN 767 DO IDX = 1, NP3AB 768 N0GTRAN = N0GTRAN + 1 769 I0GTRAN(1,N0GTRAN) = IL0 770 I0GTRAN(2,N0GTRAN) = IR2(IPAB(IDX)) 771 I0GTRAN(3,N0GTRAN) = IR1(IPC(IDX)) 772 I0GTRAN(4,N0GTRAN) = IVEC 773 END DO 774 775 DO IDX = 1, NS3A 776 N1GTRAN = N1GTRAN + 1 777 I1GTRAN(1,N1GTRAN) = IL1(ISA(IDX)) 778 I1GTRAN(2,N1GTRAN) = IR1(ISB(IDX)) 779 I1GTRAN(3,N1GTRAN) = IR1(ISC(IDX)) 780 I1GTRAN(4,N1GTRAN) = IVEC 781 END DO 782 ELSE IF (TYPE(1:3).EQ.'EX2') THEN 783 N0GTRAN = N0GTRAN + 1 784 I0GTRAN(1,N0GTRAN) = IE0(1) 785 I0GTRAN(2,N0GTRAN) = IR1(A) 786 I0GTRAN(3,N0GTRAN) = IR1(B) 787 I0GTRAN(4,N0GTRAN) = IVEC 788 END IF 789 790*---------------------------------------------------------------------* 791* set up list of F matrix transformations 792*---------------------------------------------------------------------* 793 IF (TYPE(1:2).EQ.'X2') THEN 794 N1FTRAN = N1FTRAN + 1 795 I1FTRAN(1,N1FTRAN) = IL1(A) 796 I1FTRAN(2,N1FTRAN) = IR1(B) 797 I1FTRAN(3,N1FTRAN) = IVEC 798 799 N1FTRAN = N1FTRAN + 1 800 I1FTRAN(1,N1FTRAN) = IL1(B) 801 I1FTRAN(2,N1FTRAN) = IR1(A) 802 I1FTRAN(3,N1FTRAN) = IVEC 803 ELSE IF (TYPE(1:3).EQ.'CX2') THEN 804 N1FTRAN = N1FTRAN + 1 805 I1FTRAN(1,N1FTRAN) = IL1(A) 806 I1FTRAN(2,N1FTRAN) = IR1(B) 807 I1FTRAN(3,N1FTRAN) = IVEC 808 809 N1FTRAN = N1FTRAN + 1 810 I1FTRAN(1,N1FTRAN) = IL1(B) 811 I1FTRAN(2,N1FTRAN) = IR1(A) 812 I1FTRAN(3,N1FTRAN) = IVEC 813 ELSE IF (TYPE(1:2).EQ.'X3') THEN 814 DO IDX = 1, NP3AB 815 N1FTRAN = N1FTRAN + 1 816 I1FTRAN(1,N1FTRAN) = IL1(IPC(IDX)) 817 I1FTRAN(2,N1FTRAN) = IR2(IPAB(IDX)) 818 I1FTRAN(3,N1FTRAN) = IVEC 819 END DO 820 821 DO IDX = 1, NP3AB 822 N2FTRAN = N2FTRAN + 1 823 I2FTRAN(1,N2FTRAN) = IL2(IPAB(IDX)) 824 I2FTRAN(2,N2FTRAN) = IR1(IPC(IDX)) 825 I2FTRAN(3,N2FTRAN) = IVEC 826 END DO 827 ELSE IF (TYPE(1:3).EQ.'EX2') THEN 828 N1FTRAN = N1FTRAN + 1 829 I1FTRAN(1,N1FTRAN) = IE0(1) 830 I1FTRAN(2,N1FTRAN) = IR2(AB) 831 I1FTRAN(3,N1FTRAN) = IVEC 832 833 N2FTRAN = N2FTRAN + 1 834 I2FTRAN(1,N2FTRAN) = IE1(A,1) 835 I2FTRAN(2,N2FTRAN) = IR1(B) 836 I2FTRAN(3,N2FTRAN) = IVEC 837 838 N2FTRAN = N2FTRAN + 1 839 I2FTRAN(1,N2FTRAN) = IE1(B,1) 840 I2FTRAN(2,N2FTRAN) = IR1(A) 841 I2FTRAN(3,N2FTRAN) = IVEC 842 ELSE IF (TYPE(1:3).EQ.'EX1') THEN 843 N1FTRAN = N1FTRAN + 1 844 I1FTRAN(1,N1FTRAN) = IE0(1) 845 I1FTRAN(2,N1FTRAN) = IR1(A) 846 I1FTRAN(3,N1FTRAN) = IVEC 847 END IF 848 849*---------------------------------------------------------------------* 850* set up list of F{O} matrix transformations 851*---------------------------------------------------------------------* 852 IF (TYPE(1:2).EQ.'X2') THEN 853 N0FATRAN = N0FATRAN + 1 854 I0FATRAN(1,N0FATRAN) = IL0 855 I0FATRAN(2,N0FATRAN) = IOP(A) 856 I0FATRAN(3,N0FATRAN) = IR1(B) 857 I0FATRAN(4,N0FATRAN) = IVEC 858 I0FATRAN(5,N0FATRAN) = 0 859 860 N0FATRAN = N0FATRAN + 1 861 I0FATRAN(1,N0FATRAN) = IL0 862 I0FATRAN(2,N0FATRAN) = IOP(B) 863 I0FATRAN(3,N0FATRAN) = IR1(A) 864 I0FATRAN(4,N0FATRAN) = IVEC 865 I0FATRAN(5,N0FATRAN) = 0 866 ELSE IF (TYPE(1:3).EQ.'CX2') THEN 867 IF (ICAU(IVEC,A).EQ.0) THEN 868 N0FATRAN = N0FATRAN + 1 869 I0FATRAN(1,N0FATRAN) = IL0 870 I0FATRAN(2,N0FATRAN) = IOP(A) 871 I0FATRAN(3,N0FATRAN) = IR1(B) 872 I0FATRAN(4,N0FATRAN) = IVEC 873 I0FATRAN(5,N0FATRAN) = 0 874 END IF 875 876 IF (ICAU(IVEC,B).EQ.0) THEN 877 N0FATRAN = N0FATRAN + 1 878 I0FATRAN(1,N0FATRAN) = IL0 879 I0FATRAN(2,N0FATRAN) = IOP(B) 880 I0FATRAN(3,N0FATRAN) = IR1(A) 881 I0FATRAN(4,N0FATRAN) = IVEC 882 I0FATRAN(5,N0FATRAN) = 0 883 END IF 884 ELSE IF (TYPE(1:2).EQ.'X3') THEN 885 DO IDX = 1, NP3AB 886 N0FATRAN = N0FATRAN + 1 887 I0FATRAN(1,N0FATRAN) = IL0 888 I0FATRAN(2,N0FATRAN) = IOP(IPC(IDX)) 889 I0FATRAN(3,N0FATRAN) = IR2(IPAB(IDX)) 890 I0FATRAN(4,N0FATRAN) = IVEC 891 I0FATRAN(5,N0FATRAN) = 0 892 END DO 893 894 DO IDX = 1, NP3AB 895 N1FATRAN = N1FATRAN + 1 896 I1FATRAN(1,N1FATRAN) = IL1(ISA(IDX)) 897 I1FATRAN(2,N1FATRAN) = IOP(ISB(IDX)) 898 I1FATRAN(3,N1FATRAN) = IR1(ISC(IDX)) 899 I1FATRAN(4,N1FATRAN) = IVEC 900 I1FATRAN(5,N1FATRAN) = 0 901 N1FATRAN = N1FATRAN + 1 902 I1FATRAN(1,N1FATRAN) = IL1(ISA(IDX)) 903 I1FATRAN(2,N1FATRAN) = IOP(ISC(IDX)) 904 I1FATRAN(3,N1FATRAN) = IR1(ISB(IDX)) 905 I1FATRAN(4,N1FATRAN) = IVEC 906 I1FATRAN(5,N1FATRAN) = 0 907 END DO 908 ELSE IF (TYPE(1:3).EQ.'EX2') THEN 909 N0FATRAN = N0FATRAN + 1 910 I0FATRAN(1,N0FATRAN) = IE0(1) 911 I0FATRAN(2,N0FATRAN) = IOP(A) 912 I0FATRAN(3,N0FATRAN) = IR1(B) 913 I0FATRAN(4,N0FATRAN) = IVEC 914 I0FATRAN(5,N0FATRAN) = 0 915 916 N0FATRAN = N0FATRAN + 1 917 I0FATRAN(1,N0FATRAN) = IE0(1) 918 I0FATRAN(2,N0FATRAN) = IOP(B) 919 I0FATRAN(3,N0FATRAN) = IR1(A) 920 I0FATRAN(4,N0FATRAN) = IVEC 921 I0FATRAN(5,N0FATRAN) = 0 922 END IF 923 924*---------------------------------------------------------------------* 925* set up list of ETA{O} vector calculations: 926*---------------------------------------------------------------------* 927 IF (TYPE(1:2).EQ.'X2') THEN 928 NEATRAN = NEATRAN + 1 929 930 IXETRAN(1,NEATRAN) = IOP(B) 931 IXETRAN(2,NEATRAN) = IL1(A) 932 IXETRAN(3,NEATRAN) = -1 933 IXETRAN(4,NEATRAN) = IVEC 934 IXETRAN(5,NEATRAN) = 0 935 IXETRAN(6,NEATRAN) = 0 936 IXETRAN(7,NEATRAN) = 0 937 IXETRAN(8,NEATRAN) = 0 938 939 NEATRAN = NEATRAN + 1 940 941 IXETRAN(1,NEATRAN) = IOP(A) 942 IXETRAN(2,NEATRAN) = IL1(B) 943 IXETRAN(3,NEATRAN) = -1 944 IXETRAN(4,NEATRAN) = IVEC 945 IXETRAN(5,NEATRAN) = 0 946 IXETRAN(6,NEATRAN) = 0 947 IXETRAN(7,NEATRAN) = 0 948 IXETRAN(8,NEATRAN) = 0 949 ELSE IF (TYPE(1:3).EQ.'CX2') THEN 950 IF (ICAU(IVEC,B).EQ.0) THEN 951 NEATRAN = NEATRAN + 1 952 953 IXETRAN(1,NEATRAN) = IOP(B) 954 IXETRAN(2,NEATRAN) = IL1(A) 955 IXETRAN(3,NEATRAN) = -1 956 IXETRAN(4,NEATRAN) = IVEC 957 IXETRAN(5,NEATRAN) = 0 958 IXETRAN(6,NEATRAN) = 0 959 IXETRAN(7,NEATRAN) = 0 960 IXETRAN(8,NEATRAN) = 0 961 END IF 962 963 IF (ICAU(IVEC,A).EQ.0) THEN 964 NEATRAN = NEATRAN + 1 965 966 IXETRAN(1,NEATRAN) = IOP(A) 967 IXETRAN(2,NEATRAN) = IL1(B) 968 IXETRAN(3,NEATRAN) = -1 969 IXETRAN(4,NEATRAN) = IVEC 970 IXETRAN(5,NEATRAN) = 0 971 IXETRAN(6,NEATRAN) = 0 972 IXETRAN(7,NEATRAN) = 0 973 IXETRAN(8,NEATRAN) = 0 974 END IF 975 ELSE IF (TYPE(1:2).EQ.'X3') THEN 976 DO IDX = 1, NP3AB 977 NEATRAN = NEATRAN + 1 978 979 IXETRAN(1,NEATRAN) = IOP(IPC(IDX)) 980 IXETRAN(2,NEATRAN) = IL2(IPAB(IDX)) 981 IXETRAN(3,NEATRAN) = -1 982 IXETRAN(4,NEATRAN) = IVEC 983 IXETRAN(5,NEATRAN) = 0 984 IXETRAN(6,NEATRAN) = 0 985 IXETRAN(7,NEATRAN) = 0 986 IXETRAN(8,NEATRAN) = 0 987 END DO 988 ELSE IF (TYPE(1:3).EQ.'EX2') THEN 989 NEATRAN = NEATRAN + 1 990 991 IXETRAN(1,NEATRAN) = IOP(B) 992 IXETRAN(2,NEATRAN) = IE1(A,1) 993 IXETRAN(3,NEATRAN) = -1 994 IXETRAN(4,NEATRAN) = IVEC 995 IXETRAN(5,NEATRAN) = 0 996 IXETRAN(6,NEATRAN) = 0 997 IXETRAN(7,NEATRAN) = 0 998 IXETRAN(8,NEATRAN) = 0 999 1000 NEATRAN = NEATRAN + 1 1001 1002 IXETRAN(1,NEATRAN) = IOP(A) 1003 IXETRAN(2,NEATRAN) = IE1(B,1) 1004 IXETRAN(3,NEATRAN) = -1 1005 IXETRAN(4,NEATRAN) = IVEC 1006 IXETRAN(5,NEATRAN) = 0 1007 IXETRAN(6,NEATRAN) = 0 1008 IXETRAN(7,NEATRAN) = 0 1009 IXETRAN(8,NEATRAN) = 0 1010 ELSE IF (TYPE(1:3).EQ.'EX1') THEN 1011 NEATRAN = NEATRAN + 1 1012 1013 IXETRAN(1,NEATRAN) = IOP(A) 1014 IXETRAN(2,NEATRAN) = IE0(1) 1015 IXETRAN(3,NEATRAN) = -1 1016 IXETRAN(4,NEATRAN) = IVEC 1017 IXETRAN(5,NEATRAN) = 0 1018 IXETRAN(6,NEATRAN) = 0 1019 IXETRAN(7,NEATRAN) = 0 1020 IXETRAN(8,NEATRAN) = 0 1021 END IF 1022 1023*---------------------------------------------------------------------* 1024* end loop over all requested ETA vectors 1025*---------------------------------------------------------------------* 1026 END DO 1027 1028*---------------------------------------------------------------------* 1029* print the lists: 1030*---------------------------------------------------------------------* 1031* general statistics: 1032 IF (TYPE(1:1).EQ.'X') THEN 1033 LEN = 2 1034 CLASS = ' eta ' 1035 ELSE IF (TYPE(1:2).EQ.'CX') THEN 1036 LEN = 3 1037 CLASS = ' eta ' 1038 ELSE IF (TYPE(1:2).EQ.'EX') THEN 1039 LEN = 3 1040 CLASS = ' rhs ' 1041 ELSE 1042 LEN = 2 1043 CLASS = ' ' 1044 END IF 1045 WRITE (LUPRI,'(/,/3X,A,I3,1X,3A)') 'For the requested',NVEC, 1046 & TYPE(1:LEN),CLASS,' vectors' 1047 WRITE (LUPRI,'((8X,A,I3,A))') 1048 & ' - ',N0KTRAN, ' H matrix transformations ', 1049 & ' - ',N0GTRAN, ' G matrix transformations ', 1050 & ' - ',N1GTRAN, ' generalized G matrix transformations ', 1051 & ' - ',(N1FTRAN+N2FTRAN), 1052 & ' generalized F matrix transformations ', 1053 & ' - ',N0FATRAN, ' F{O} matrix transformations ', 1054 & ' - ',N1FATRAN, ' generalized F{O} matrix transformations ', 1055 & ' - ',NEATRAN, ' generalized ETA{O} vector calculations ' 1056 WRITE (LUPRI,'(3X,A,/,/)') 'will be performed.' 1057 1058 1059 IF (LOCDBG) THEN 1060 1061* H matrix transformations: 1062 IF (N0KTRAN.GT.0) WRITE(LUPRI,*) 1063 & 'List of H matrix transformations:' 1064 DO ITRAN = 1, N0KTRAN 1065 WRITE(LUPRI,'(A,4I5,5X,(12I5,20X))') MSGDBG, 1066 & (I0KTRAN(I,ITRAN),I=1,4) 1067 END DO 1068 WRITE (LUPRI,*) 1069 1070* G matrix transformations: 1071 IF (N0GTRAN.GT.0) WRITE(LUPRI,*) 1072 & 'List of G matrix transformations:' 1073 DO ITRAN = 1, N0GTRAN 1074 WRITE(LUPRI,'(A,4I5,5X,(12I5,20X))') MSGDBG, 1075 & (I0GTRAN(I,ITRAN),I=1,4) 1076 END DO 1077 WRITE (LUPRI,*) 1078 1079 IF (N1GTRAN.GT.0) 1080 & WRITE (LUPRI,*) 'List of (T^1 C) matrix transformations:' 1081 DO ITRAN = 1, N1GTRAN 1082 WRITE(LUPRI,'(A,4I5,5X,(12I5,20X))') MSGDBG, 1083 & (I1GTRAN(I,ITRAN),I=1,4) 1084 END DO 1085 WRITE (LUPRI,*) 1086 1087* F matrix transformations: 1088 IF (N1FTRAN.GT.0) 1089 & WRITE (LUPRI,*) 'List of (T^1 B) matrix transformations:' 1090 DO ITRAN = 1, N1FTRAN 1091 WRITE(LUPRI,'(A,3I5,5X,(12I5,20X))') MSGDBG, 1092 & (I1FTRAN(I,ITRAN),I=1,3) 1093 END DO 1094 WRITE (LUPRI,*) 1095 1096 IF (N2FTRAN.GT.0) 1097 & WRITE (LUPRI,*) 'List of (T^2 B) matrix transformations:' 1098 DO ITRAN = 1, N2FTRAN 1099 WRITE(LUPRI,'(A,3I5,5X,(12I5,20X))') MSGDBG, 1100 & (I2FTRAN(I,ITRAN),I=1,3) 1101 END DO 1102 WRITE (LUPRI,*) 1103 1104* F{O} matrix transformations: 1105 IF (N0FATRAN.GT.0) 1106 & WRITE (LUPRI,*) 'List of F{O} matrix transformations:' 1107 DO ITRAN = 1, N0FATRAN 1108 WRITE(LUPRI,'(A,4I5,5X,(12I5,20X))') MSGDBG, 1109 & (I0FATRAN(I,ITRAN),I=1,4) 1110 END DO 1111 WRITE (LUPRI,*) 1112 1113 IF (N1FATRAN.GT.0) 1114 & WRITE (LUPRI,*) 'List of (T^1 B{O}) matrix transformations:' 1115 DO ITRAN = 1, N1FATRAN 1116 WRITE(LUPRI,'(A,4I5,5X,(12I5,20X))') MSGDBG, 1117 & (I1FATRAN(I,ITRAN),I=1,4) 1118 END DO 1119 WRITE (LUPRI,*) 1120 1121* ETA{O} vector calculations: 1122 IF (NEATRAN.GT.0) 1123 & WRITE (LUPRI,*) 'List of (T^n A{O}) matrix transformations:' 1124 DO ITRAN = 1, NEATRAN 1125 WRITE(LUPRI,'(A,3I5,5X,(12I5,20X))') MSGDBG, 1126 & (IXETRAN(I,ITRAN),I=1,4) 1127 END DO 1128 WRITE (LUPRI,*) 1129 1130 END IF 1131 1132 RETURN 1133 END 1134 1135*---------------------------------------------------------------------* 1136* END OF SUBROUTINE CC_ETA_SETUP * 1137*---------------------------------------------------------------------* 1138