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 cccr_setup */ 20*=====================================================================* 21 SUBROUTINE CCCR_SETUP(MXTRAN2, MXVEC2, MXTRAN3, MXVEC1, 22 & I0HTRAN, I0HDOTS, N0HTRAN, 23 & I0GTRAN, I0GDOTS, N0GTRAN, 24 & IAGTRAN, IAGDOTS, NAGTRAN, 25 & I0FTRAN, I0FDOTS, N0FTRAN, 26 & IAFTRAN, IAFDOTS, NAFTRAN, 27 & I0FATRAN,I0FADOTS,N0FATRAN, 28 & IAFATRAN,IAFADOTS,NAFATRAN, 29 & IAEATRAN,IAEADOTS,NAEATRAN, 30 & IXTRAN, IXDOTS, NXTRAN, 31 & IOTRAN, IODOTS, NOTRAN, 32 & ILTRAN, ILDOTS, NLTRAN ) 33*---------------------------------------------------------------------* 34* 35* Purpose: set up for CCCR section 36* - list of H^0 matrix transformations 37* - list of G^0 matrix transformations 38* - list of G^A matrix transformations 39* - list of F^0 matrix transformations 40* - list of F^A matrix transformations 41* - list of F^0{O} matrix transformations 42* - list of F^A{O} matrix transformations 43* - list of ETA^A{O} vector calculations 44* - list of chi vector dot products 45* - list of xksi vector dot products 46* - list of L2 x O2 vector dot products 47* 48* Written by Christof Haettig, februar 1997. 49* turn over rule options (USE_L2BC, USE_LBCD) added in april 1998 50* 51*=====================================================================* 52#if defined (IMPLICIT_NONE) 53 IMPLICIT NONE 54#else 55# include "implicit.h" 56#endif 57#include "priunit.h" 58#include "ccorb.h" 59#include "cccrinf.h" 60#include "ccroper.h" 61#include "cccperm.h" 62#include "cclists.h" 63 64* local parameters: 65 CHARACTER*(20) MSGDBG 66 PARAMETER (MSGDBG = '[debug] CCCR_SETUP> ') 67 LOGICAL LOCDBG 68 PARAMETER (LOCDBG = .FALSE.) 69 70 INTEGER MXVEC2, MXTRAN2, MXVEC1, MXTRAN3 71 72 INTEGER I0HTRAN(MXDIM_HTRAN,MXTRAN3) 73 INTEGER I0HDOTS(MXVEC1,MXTRAN3) 74 75 INTEGER I0GTRAN(MXDIM_GTRAN,MXTRAN2) 76 INTEGER I0GDOTS(MXVEC2,MXTRAN2) 77 78 INTEGER IAGTRAN(MXDIM_GTRAN,MXTRAN3) 79 INTEGER IAGDOTS(MXVEC1,MXTRAN3) 80 81 INTEGER I0FTRAN(MXDIM_FTRAN,MXTRAN2) 82 INTEGER I0FDOTS(MXVEC2,MXTRAN2) 83 84 INTEGER IAFTRAN(MXDIM_FTRAN,MXTRAN2) 85 INTEGER IAFDOTS(MXVEC2,MXTRAN2) 86 87 INTEGER I0FATRAN(MXDIM_FATRAN,MXTRAN2) 88 INTEGER I0FADOTS(MXVEC2,MXTRAN2) 89 90 INTEGER IAFATRAN(MXDIM_FATRAN,MXTRAN3) 91 INTEGER IAFADOTS(MXVEC1,MXTRAN3) 92 93C INTEGER IAEATRAN(3,MXTRAN2) 94 INTEGER IAEATRAN(MXDIM_XEVEC,MXTRAN2) 95 INTEGER IAEADOTS(MXVEC2,MXTRAN2) 96 97 INTEGER IXTRAN(MXTRAN2) 98 INTEGER IXDOTS(MXVEC2,MXTRAN2) 99 100 INTEGER ILTRAN(MXTRAN2) 101 INTEGER ILDOTS(MXVEC2,MXTRAN2) 102 103 INTEGER IOTRAN(MXTRAN3) 104 INTEGER IODOTS(MXVEC1,MXTRAN3) 105 106 INTEGER N0HTRAN, N0GTRAN, N0FTRAN, N0FATRAN, NXTRAN, NOTRAN 107 INTEGER NAGTRAN, NAFTRAN, NAFATRAN, NAEATRAN, NLTRAN 108 INTEGER NCRRESF 109 110 INTEGER IVEC, ITRAN, I 111 INTEGER ISYML, ISYM1, ISYM2, ISYM3 112 INTEGER IFREQ, IOPER 113 INTEGER P, ISIGN 114 INTEGER MXV0H, MXV0G, MXVAG, MXV0F, MXVAF, MXV0FA, MXVAFA 115 INTEGER MXVAEA, MXX, MXO, MXL 116 117#if defined (SYS_CRAY) 118 REAL SIGN 119#else 120 DOUBLE PRECISION SIGN 121#endif 122 123 INTEGER IOP(4), ISY(4), IZT(4), IR1(4), IR2(6), IX2(6) 124 INTEGER IO3(4), IO2(6), IL2(6), IE1(4), IKAP(4) 125 126* external functions: 127 INTEGER IR3TAMP 128 INTEGER IR2TAMP 129 INTEGER IR1TAMP 130 INTEGER IL1ZETA 131 INTEGER IL2ZETA 132 INTEGER IRHSR2 133 INTEGER ICHI2 134 INTEGER IETA1 135 INTEGER IRHSR3 136 137 138*---------------------------------------------------------------------* 139* initializations: 140*---------------------------------------------------------------------* 141 N0HTRAN = 0 142 N0GTRAN = 0 143 NAGTRAN = 0 144 N0FTRAN = 0 145 NAFTRAN = 0 146 N0FATRAN = 0 147 NAFATRAN = 0 148 NAEATRAN = 0 149 NXTRAN = 0 150 NOTRAN = 0 151 NLTRAN = 0 152 NCRRESF = 0 153 154 MXV0H = 0 155 MXV0G = 0 156 MXVAG = 0 157 MXV0F = 0 158 MXVAF = 0 159 MXV0FA = 0 160 MXVAFA = 0 161 MXVAEA = 0 162 MXX = 0 163 MXO = 0 164 MXL = 0 165 166 DO ITRAN = 1, MXTRAN2 167 IAEATRAN(3,ITRAN) = -1 168 END DO 169 170*---------------------------------------------------------------------* 171* start loop over all requested second hyperpolarizabilities 172*---------------------------------------------------------------------* 173 174 DO IOPER = 1, NCROPER 175 IOP(A) = IACROP(IOPER) 176 IOP(B) = IBCROP(IOPER) 177 IOP(C) = ICCROP(IOPER) 178 IOP(D) = IDCROP(IOPER) 179 180 IKAP(A)= 0 181 IKAP(B)= 0 182 IKAP(C)= 0 183 IKAP(D)= 0 184 185 ISY(A) = ISYOPR(IOP(A)) 186 ISY(B) = ISYOPR(IOP(B)) 187 ISY(C) = ISYOPR(IOP(C)) 188 ISY(D) = ISYOPR(IOP(D)) 189 190 IF (MULD2H(ISY(A),ISY(B)).EQ.MULD2H(ISY(C),ISY(D))) THEN 191 192 DO IFREQ = 1, NCRFREQ 193 194 NCRRESF = NCRRESF + 1 195 196 DO ISIGN = 1, -1, -2 197 SIGN = DBLE(ISIGN) 198 199 IE1(A) = IETA1(LBLOPR(IOP(A)),.FALSE.,SIGN*ACRFR(IFREQ),ISYML) 200 IE1(B) = IETA1(LBLOPR(IOP(B)),.FALSE.,SIGN*BCRFR(IFREQ),ISYML) 201 IE1(C) = IETA1(LBLOPR(IOP(C)),.FALSE.,SIGN*CCRFR(IFREQ),ISYML) 202 IE1(D) = IETA1(LBLOPR(IOP(D)),.FALSE.,SIGN*DCRFR(IFREQ),ISYML) 203 204 IZT(A) = IL1ZETA(LBLOPR(IOP(A)),.FALSE.,SIGN*ACRFR(IFREQ),ISYML) 205 IZT(B) = IL1ZETA(LBLOPR(IOP(B)),.FALSE.,SIGN*BCRFR(IFREQ),ISYML) 206 IZT(C) = IL1ZETA(LBLOPR(IOP(C)),.FALSE.,SIGN*CCRFR(IFREQ),ISYML) 207 IZT(D) = IL1ZETA(LBLOPR(IOP(D)),.FALSE.,SIGN*DCRFR(IFREQ),ISYML) 208 209 IR1(A) = IR1TAMP(LBLOPR(IOP(A)),.FALSE.,SIGN*ACRFR(IFREQ),ISYML) 210 IR1(B) = IR1TAMP(LBLOPR(IOP(B)),.FALSE.,SIGN*BCRFR(IFREQ),ISYML) 211 IR1(C) = IR1TAMP(LBLOPR(IOP(C)),.FALSE.,SIGN*CCRFR(IFREQ),ISYML) 212 IR1(D) = IR1TAMP(LBLOPR(IOP(D)),.FALSE.,SIGN*DCRFR(IFREQ),ISYML) 213 214 215 IF (USE_LBCD) THEN ! L2(BC,BD,CD) instead of R2(AD,AC,AB) 216 IL2(BC)=IL2ZETA(LBLOPR(IOP(B)), SIGN*BCRFR(IFREQ),ISYM1, 217 & LBLOPR(IOP(C)), SIGN*CCRFR(IFREQ),ISYM2) 218 IL2(BD)=IL2ZETA(LBLOPR(IOP(B)), SIGN*BCRFR(IFREQ),ISYM1, 219 & LBLOPR(IOP(D)), SIGN*DCRFR(IFREQ),ISYM2) 220 IL2(CD)=IL2ZETA(LBLOPR(IOP(C)), SIGN*CCRFR(IFREQ),ISYM1, 221 & LBLOPR(IOP(D)), SIGN*DCRFR(IFREQ),ISYM2) 222C IX2(AD)=ICHI2( LBLOPR(IOP(A)),.FALSE.,SIGN*ACRFR(IFREQ),ISYM1, 223C & LBLOPR(IOP(D)),.FALSE.,SIGN*DCRFR(IFREQ),ISYM2) 224 IO2(AD)=IRHSR2( LBLOPR(IOP(A)),.FALSE.,SIGN*ACRFR(IFREQ),ISYM1, 225 & LBLOPR(IOP(D)),.FALSE.,SIGN*DCRFR(IFREQ),ISYM2) 226C IX2(AC)=ICHI2( LBLOPR(IOP(A)),.FALSE.,SIGN*ACRFR(IFREQ),ISYM1, 227C & LBLOPR(IOP(C)),.FALSE.,SIGN*CCRFR(IFREQ),ISYM2) 228 IO2(AC)=IRHSR2( LBLOPR(IOP(A)),.FALSE.,SIGN*ACRFR(IFREQ),ISYM1, 229 & LBLOPR(IOP(C)),.FALSE.,SIGN*CCRFR(IFREQ),ISYM2) 230C IX2(AB)=ICHI2( LBLOPR(IOP(A)),.FALSE.,SIGN*ACRFR(IFREQ),ISYM1, 231C & LBLOPR(IOP(B)),.FALSE.,SIGN*BCRFR(IFREQ),ISYM2) 232 IO2(AB)=IRHSR2( LBLOPR(IOP(A)),.FALSE.,SIGN*ACRFR(IFREQ),ISYM1, 233 & LBLOPR(IOP(B)),.FALSE.,SIGN*BCRFR(IFREQ),ISYM2) 234 ELSE IF (USE_L2BC) THEN ! use L2(BC) instead of R2(AD) 235 IR2(AB)=IR2TAMP(LBLOPR(IOP(A)),.FALSE.,SIGN*ACRFR(IFREQ),ISYM1, 236 & LBLOPR(IOP(B)),.FALSE.,SIGN*BCRFR(IFREQ),ISYM2) 237 IR2(AC)=IR2TAMP(LBLOPR(IOP(A)),.FALSE.,SIGN*ACRFR(IFREQ),ISYM1, 238 & LBLOPR(IOP(C)),.FALSE.,SIGN*CCRFR(IFREQ),ISYM2) 239 IL2(BC)=IL2ZETA(LBLOPR(IOP(B)), SIGN*BCRFR(IFREQ),ISYM1, 240 & LBLOPR(IOP(C)), SIGN*CCRFR(IFREQ),ISYM2) 241 242C IX2(AD)=ICHI2( LBLOPR(IOP(A)),.FALSE.,SIGN*ACRFR(IFREQ),ISYM1, 243C & LBLOPR(IOP(D)),.FALSE.,SIGN*DCRFR(IFREQ),ISYM2) 244 IO2(AD)=IRHSR2( LBLOPR(IOP(A)),.FALSE.,SIGN*ACRFR(IFREQ),ISYM1, 245 & LBLOPR(IOP(D)),.FALSE.,SIGN*DCRFR(IFREQ),ISYM2) 246 ELSE ! 2n+1/2n+2 rule formula symmetric in A,B,C,D 247 IR2(AB)=IR2TAMP(LBLOPR(IOP(A)),.FALSE.,SIGN*ACRFR(IFREQ),ISYM1, 248 & LBLOPR(IOP(B)),.FALSE.,SIGN*BCRFR(IFREQ),ISYM2) 249 IR2(AC)=IR2TAMP(LBLOPR(IOP(A)),.FALSE.,SIGN*ACRFR(IFREQ),ISYM1, 250 & LBLOPR(IOP(C)),.FALSE.,SIGN*CCRFR(IFREQ),ISYM2) 251 IR2(AD)=IR2TAMP(LBLOPR(IOP(A)),.FALSE.,SIGN*ACRFR(IFREQ),ISYM1, 252 & LBLOPR(IOP(D)),.FALSE.,SIGN*DCRFR(IFREQ),ISYM2) 253 END IF 254 255 IR2(BC)=IR2TAMP(LBLOPR(IOP(B)),.FALSE.,SIGN*BCRFR(IFREQ),ISYM1, 256 & LBLOPR(IOP(C)),.FALSE.,SIGN*CCRFR(IFREQ),ISYM2) 257 IR2(BD)=IR2TAMP(LBLOPR(IOP(B)),.FALSE.,SIGN*BCRFR(IFREQ),ISYM1, 258 & LBLOPR(IOP(D)),.FALSE.,SIGN*DCRFR(IFREQ),ISYM2) 259 IR2(CD)=IR2TAMP(LBLOPR(IOP(C)),.FALSE.,SIGN*CCRFR(IFREQ),ISYM1, 260 & LBLOPR(IOP(D)),.FALSE.,SIGN*DCRFR(IFREQ),ISYM2) 261 262 IF (L_USE_CHI2) THEN 263c IX2(AB)=ICHI2(LBLOPR(IOP(A)),.FALSE.,SIGN*ACRFR(IFREQ),ISYM1, 264c & LBLOPR(IOP(B)),.FALSE.,SIGN*BCRFR(IFREQ),ISYM2) 265c IX2(AC)=ICHI2(LBLOPR(IOP(A)),.FALSE.,SIGN*ACRFR(IFREQ),ISYM1, 266c & LBLOPR(IOP(C)),.FALSE.,SIGN*CCRFR(IFREQ),ISYM2) 267c IX2(AD)=ICHI2(LBLOPR(IOP(A)),.FALSE.,SIGN*ACRFR(IFREQ),ISYM1, 268c & LBLOPR(IOP(D)),.FALSE.,SIGN*DCRFR(IFREQ),ISYM2) 269c IX2(BC)=ICHI2(LBLOPR(IOP(B)),.FALSE.,SIGN*BCRFR(IFREQ),ISYM1, 270c & LBLOPR(IOP(C)),.FALSE.,SIGN*CCRFR(IFREQ),ISYM2) 271c IX2(BD)=ICHI2(LBLOPR(IOP(B)),.FALSE.,SIGN*BCRFR(IFREQ),ISYM1, 272c & LBLOPR(IOP(D)),.FALSE.,SIGN*DCRFR(IFREQ),ISYM2) 273c IX2(CD)=ICHI2(LBLOPR(IOP(C)),.FALSE.,SIGN*CCRFR(IFREQ),ISYM1, 274c & LBLOPR(IOP(D)),.FALSE.,SIGN*DCRFR(IFREQ),ISYM2) 275 276 IX2(AB)=IL2ZETA(LBLOPR(IOP(A)), SIGN*ACRFR(IFREQ),ISYM1, 277 & LBLOPR(IOP(B)), SIGN*BCRFR(IFREQ),ISYM2) 278 IX2(AC)=IL2ZETA(LBLOPR(IOP(A)), SIGN*ACRFR(IFREQ),ISYM1, 279 & LBLOPR(IOP(C)), SIGN*CCRFR(IFREQ),ISYM2) 280 IX2(AD)=IL2ZETA(LBLOPR(IOP(A)), SIGN*ACRFR(IFREQ),ISYM1, 281 & LBLOPR(IOP(D)), SIGN*DCRFR(IFREQ),ISYM2) 282 IX2(BC)=IL2ZETA(LBLOPR(IOP(B)), SIGN*BCRFR(IFREQ),ISYM1, 283 & LBLOPR(IOP(C)), SIGN*CCRFR(IFREQ),ISYM2) 284 IX2(BD)=IL2ZETA(LBLOPR(IOP(B)), SIGN*BCRFR(IFREQ),ISYM1, 285 & LBLOPR(IOP(D)), SIGN*DCRFR(IFREQ),ISYM2) 286 IX2(CD)=IL2ZETA(LBLOPR(IOP(C)), SIGN*CCRFR(IFREQ),ISYM1, 287 & LBLOPR(IOP(D)), SIGN*DCRFR(IFREQ),ISYM2) 288 END IF 289 290 IF (L_USE_XKS3) THEN 291 IO3(ABC) = IR3TAMP(LBLOPR(IOP(A)),SIGN*ACRFR(IFREQ),ISYM1, 292 & LBLOPR(IOP(B)),SIGN*BCRFR(IFREQ),ISYM2, 293 & LBLOPR(IOP(C)),SIGN*CCRFR(IFREQ),ISYM3) 294 IO3(ABD) = IR3TAMP(LBLOPR(IOP(A)),SIGN*ACRFR(IFREQ),ISYM1, 295 & LBLOPR(IOP(B)),SIGN*BCRFR(IFREQ),ISYM2, 296 & LBLOPR(IOP(D)),SIGN*DCRFR(IFREQ),ISYM3) 297 IO3(ACD) = IR3TAMP(LBLOPR(IOP(A)),SIGN*ACRFR(IFREQ),ISYM1, 298 & LBLOPR(IOP(C)),SIGN*CCRFR(IFREQ),ISYM2, 299 & LBLOPR(IOP(D)),SIGN*DCRFR(IFREQ),ISYM3) 300 IO3(BCD) = IR3TAMP(LBLOPR(IOP(B)),SIGN*BCRFR(IFREQ),ISYM1, 301 & LBLOPR(IOP(C)),SIGN*CCRFR(IFREQ),ISYM2, 302 & LBLOPR(IOP(D)),SIGN*DCRFR(IFREQ),ISYM3) 303 END IF 304 305*---------------------------------------------------------------------* 306* set up list of H^0 matrix transformations, 1 permutation 307*---------------------------------------------------------------------* 308 CALL CC_SETH1111(I0HTRAN,I0HDOTS,MXTRAN3,MXVEC1, 309 & 0,IR1(A),IR1(B),IR1(C),IR1(D),ITRAN,IVEC) 310 N0HTRAN = MAX(N0HTRAN,ITRAN) 311 MXV0H = MAX(MXV0H,IVEC) 312 313*---------------------------------------------------------------------* 314* set up list of G^0 matrix transformations, 6 permutations 315*---------------------------------------------------------------------* 316 DO P = 1, 6 317 IF ((USE_L2BC.AND.P.EQ.4) .OR. (USE_LBCD.AND.P.GT.3) ) THEN 318 CONTINUE 319 ELSE 320 CALL CC_SETG112(I0GTRAN,I0GDOTS,MXTRAN2,MXVEC2, 321 & 0,IR1(I1(P)),IR1(I2(P)),IR2(IP(P)),ITRAN,IVEC) 322 N0GTRAN = MAX(N0GTRAN,ITRAN) 323 MXV0G = MAX(MXV0G,IVEC) 324 END IF 325 END DO 326 327*---------------------------------------------------------------------* 328* set up list of G^A matrix transformations, 4 permutations 329*---------------------------------------------------------------------* 330 CALL CCQR_SETG(IAGTRAN,IAGDOTS,MXTRAN3,MXVEC1, 331 & IZT(A),IR1(B),IR1(C),IR1(D),ITRAN,IVEC) 332 NAGTRAN = MAX(NAGTRAN,ITRAN) 333 MXVAG = MAX(MXVAG,IVEC) 334 335 CALL CCQR_SETG(IAGTRAN,IAGDOTS,MXTRAN3,MXVEC1, 336 & IZT(B),IR1(A),IR1(C),IR1(D),ITRAN,IVEC) 337 NAGTRAN = MAX(NAGTRAN,ITRAN) 338 MXVAG = MAX(MXVAG,IVEC) 339 340 CALL CCQR_SETG(IAGTRAN,IAGDOTS,MXTRAN3,MXVEC1, 341 & IZT(C),IR1(B),IR1(A),IR1(D),ITRAN,IVEC) 342 NAGTRAN = MAX(NAGTRAN,ITRAN) 343 MXVAG = MAX(MXVAG,IVEC) 344 345 CALL CCQR_SETG(IAGTRAN,IAGDOTS,MXTRAN3,MXVEC1, 346 & IZT(D),IR1(B),IR1(C),IR1(A),ITRAN,IVEC) 347 NAGTRAN = MAX(NAGTRAN,ITRAN) 348 MXVAG = MAX(MXVAG,IVEC) 349 350*---------------------------------------------------------------------* 351* set up list of F^0 matrix transformations, 3 permutations 352*---------------------------------------------------------------------* 353 IF (.NOT. USE_LBCD) THEN 354 CALL CCQR_SETF(I0FTRAN,I0FDOTS,MXTRAN2,MXVEC2, 355 & 0,IR2(AB),IR2(CD),ITRAN,IVEC) 356 N0FTRAN = MAX(N0FTRAN,ITRAN) 357 MXV0F = MAX(MXV0F,IVEC) 358 END IF 359 360 IF (.NOT. USE_LBCD) THEN 361 CALL CCQR_SETF(I0FTRAN,I0FDOTS,MXTRAN2,MXVEC2, 362 & 0,IR2(AC),IR2(BD),ITRAN,IVEC) 363 N0FTRAN = MAX(N0FTRAN,ITRAN) 364 MXV0F = MAX(MXV0F,IVEC) 365 END IF 366 367 IF (.NOT. (USE_LBCD .OR. USE_L2BC)) THEN 368 CALL CCQR_SETF(I0FTRAN,I0FDOTS,MXTRAN2,MXVEC2, 369 & 0,IR2(AD),IR2(BC),ITRAN,IVEC) 370 N0FTRAN = MAX(N0FTRAN,ITRAN) 371 MXV0F = MAX(MXV0F,IVEC) 372 END IF 373 374*---------------------------------------------------------------------* 375* set up list of F^A matrix transformations, 12 permutations 376*---------------------------------------------------------------------* 377 DO P = 1, 6 378 IF ((USE_L2BC.AND.P.EQ.4) .OR. (USE_LBCD.AND.P.GT.3) ) THEN 379 CONTINUE 380 ELSE 381 CALL CC_SETF12(IAFTRAN,IAFDOTS,MXTRAN2,MXVEC2, ! 1 x 2 x 3,4 382 & IZT(I1(P)),IR1(I2(P)),IR2(IP(P)),ITRAN,IVEC) 383 NAFTRAN = MAX(NAFTRAN,ITRAN) 384 MXVAF = MAX(MXVAF,IVEC) 385 386 CALL CC_SETF12(IAFTRAN,IAFDOTS,MXTRAN2,MXVEC2, ! 2 x 1 x 3,4 387 & IZT(I2(P)),IR1(I1(P)),IR2(IP(P)),ITRAN,IVEC) 388 NAFTRAN = MAX(NAFTRAN,ITRAN) 389 MXVAF = MAX(MXVAF,IVEC) 390 END IF 391 END DO 392 393*---------------------------------------------------------------------* 394* set up list of F^0{O} matrix transformations, 12 permutations 395*---------------------------------------------------------------------* 396 DO P = 1, 6 397 IF ((USE_L2BC.AND.P.EQ.4) .OR. (USE_LBCD.AND.P.GT.3) ) THEN 398 CONTINUE 399 ELSE 400 CALL CC_SETFA12(I0FATRAN,I0FADOTS,MXTRAN2,MXVEC2, ! 1x2x3,4 401 & 0,IOP(I1(P)),IR1(I2(P)),IR2(IP(P)),ITRAN,IVEC) 402 N0FATRAN = MAX(N0FATRAN,ITRAN) 403 MXV0FA = MAX(MXV0FA,IVEC) 404 405 CALL CC_SETFA12(I0FATRAN,I0FADOTS,MXTRAN2,MXVEC2, ! 2x1x3,4 406 & 0,IOP(I2(P)),IR1(I1(P)),IR2(IP(P)),ITRAN,IVEC) 407 N0FATRAN = MAX(N0FATRAN,ITRAN) 408 MXV0FA = MAX(MXV0FA,IVEC) 409 END IF 410 END DO 411 412*---------------------------------------------------------------------* 413* set up list of F^A{O} matrix transformations, 12 permutations 414*---------------------------------------------------------------------* 415 DO P = 1, 6 416 CALL CCQR_SETFA(IAFATRAN,IAFADOTS,MXTRAN3,MXVEC1, ! 1 x 2 x 3,4 417 & IZT(I1(P)),IOP(I2(P)),IR1(I3(P)),IR1(I4(P)),ITRAN,IVEC) 418 NAFATRAN = MAX(NAFATRAN,ITRAN) 419 MXVAFA = MAX(MXVAFA,IVEC) 420 421 CALL CCQR_SETFA(IAFATRAN,IAFADOTS,MXTRAN3,MXVEC1, ! 2 x 1 x 3,4 422 & IZT(I2(P)),IOP(I1(P)),IR1(I3(P)),IR1(I4(P)),ITRAN,IVEC) 423 NAFATRAN = MAX(NAFATRAN,ITRAN) 424 MXVAFA = MAX(MXVAFA,IVEC) 425 END DO 426 427*---------------------------------------------------------------------* 428* set up list of ETA{O} vector calculations, 12 permutations 429*---------------------------------------------------------------------* 430 DO P = 1, 6 431 IF ((USE_L2BC.AND.P.EQ.4) .OR. (USE_LBCD.AND.P.GT.3) ) THEN 432 CONTINUE 433 ELSE 434C CALL CCQR_SETEA(IAEATRAN,IAEADOTS,MXTRAN2,MXVEC2, ! 1x2x3,4 435C & IZT(I1(P)),IOP(I2(P)),IR2(IP(P)),ITRAN,IVEC) 436 CALL CC_SETXE('Eta',IAEATRAN,IAEADOTS,MXTRAN2,MXVEC2,!1x2x3,4 437 & IZT(I1(P)),IOP(I2(P)),IKAP(I2(P)),0,0,0, 438 & IR2(IP(P)),ITRAN,IVEC) 439 NAEATRAN = MAX(NAEATRAN,ITRAN) 440 MXVAEA = MAX(MXVAEA,IVEC) 441 442C CALL CCQR_SETEA(IAEATRAN,IAEADOTS,MXTRAN2,MXVEC2, ! 2x1x3,4 443C & IZT(I2(P)),IOP(I1(P)),IR2(IP(P)),ITRAN,IVEC) 444 CALL CC_SETXE('Eta',IAEATRAN,IAEADOTS,MXTRAN2,MXVEC2,!2x1x3,4 445 & IZT(I2(P)),IOP(I1(P)),IKAP(I1(P)),0,0,0, 446 & IR2(IP(P)),ITRAN,IVEC) 447 NAEATRAN = MAX(NAEATRAN,ITRAN) 448 MXVAEA = MAX(MXVAEA,IVEC) 449 END IF 450 END DO 451 452*---------------------------------------------------------------------* 453* set up list of L2 x O2 vector dot products, max. 3 permutations 454*---------------------------------------------------------------------* 455 IF (USE_LBCD .OR. USE_L2BC) THEN 456 CALL CC_SETDOT(ILTRAN,ILDOTS,MXTRAN2,MXVEC2, 457 & IL2(BC),IO2(AD),ITRAN,IVEC) 458 NLTRAN = MAX(NLTRAN,ITRAN) 459 MXL = MAX(MXL,IVEC) 460 END IF 461 462 IF (USE_LBCD) THEN 463 CALL CC_SETDOT(ILTRAN,ILDOTS,MXTRAN2,MXVEC2, 464 & IL2(BD),IO2(AC),ITRAN,IVEC) 465 NLTRAN = MAX(NLTRAN,ITRAN) 466 MXL = MAX(MXL,IVEC) 467 468 CALL CC_SETDOT(ILTRAN,ILDOTS,MXTRAN2,MXVEC2, 469 & IL2(CD),IO2(AB),ITRAN,IVEC) 470 NLTRAN = MAX(NLTRAN,ITRAN) 471 MXL = MAX(MXL,IVEC) 472 END IF 473*---------------------------------------------------------------------* 474* set up list of chi vector dot products, 6 permutations 475*---------------------------------------------------------------------* 476 IF (L_USE_CHI2) THEN 477 CALL CC_SETDOT(IXTRAN,IXDOTS,MXTRAN2,MXVEC2, 478 & IX2(AB),IR2(CD),ITRAN,IVEC) 479 NXTRAN = MAX(NXTRAN,ITRAN) 480 MXX = MAX(MXX,IVEC) 481 482 CALL CC_SETDOT(IXTRAN,IXDOTS,MXTRAN2,MXVEC2, 483 & IX2(AC),IR2(BD),ITRAN,IVEC) 484 NXTRAN = MAX(NXTRAN,ITRAN) 485 MXX = MAX(MXX,IVEC) 486 487 CALL CC_SETDOT(IXTRAN,IXDOTS,MXTRAN2,MXVEC2, 488 & IX2(AD),IR2(BC),ITRAN,IVEC) 489 NXTRAN = MAX(NXTRAN,ITRAN) 490 MXX = MAX(MXX,IVEC) 491 492 CALL CC_SETDOT(IXTRAN,IXDOTS,MXTRAN2,MXVEC2, 493 & IX2(CD),IR2(AB),ITRAN,IVEC) 494 NXTRAN = MAX(NXTRAN,ITRAN) 495 MXX = MAX(MXX,IVEC) 496 497 CALL CC_SETDOT(IXTRAN,IXDOTS,MXTRAN2,MXVEC2, 498 & IX2(BD),IR2(AC),ITRAN,IVEC) 499 NXTRAN = MAX(NXTRAN,ITRAN) 500 MXX = MAX(MXX,IVEC) 501 502 CALL CC_SETDOT(IXTRAN,IXDOTS,MXTRAN2,MXVEC2, 503 & IX2(BC),IR2(AD),ITRAN,IVEC) 504 NXTRAN = MAX(NXTRAN,ITRAN) 505 MXX = MAX(MXX,IVEC) 506 END IF 507 508*---------------------------------------------------------------------* 509* set up list of Xksi3 vector dot products, 4 permutations 510*---------------------------------------------------------------------* 511 IF (L_USE_XKS3) THEN 512 CALL CC_SETDOT(IOTRAN,IODOTS,MXTRAN3,MXVEC1, 513 & IO3(ABC),IZT(D),ITRAN,IVEC) 514 NOTRAN = MAX(NOTRAN,ITRAN) 515 MXO = MAX(MXO,IVEC) 516 517 CALL CC_SETDOT(IOTRAN,IODOTS,MXTRAN3,MXVEC1, 518 & IO3(ABD),IZT(C),ITRAN,IVEC) 519 NOTRAN = MAX(NOTRAN,ITRAN) 520 MXO = MAX(MXO,IVEC) 521 522 CALL CC_SETDOT(IOTRAN,IODOTS,MXTRAN3,MXVEC1, 523 & IO3(ACD),IZT(B),ITRAN,IVEC) 524 NOTRAN = MAX(NOTRAN,ITRAN) 525 MXO = MAX(MXO,IVEC) 526 527 CALL CC_SETDOT(IOTRAN,IODOTS,MXTRAN3,MXVEC1, 528 & IO3(BCD),IZT(A),ITRAN,IVEC) 529 NOTRAN = MAX(NOTRAN,ITRAN) 530 MXO = MAX(MXO,IVEC) 531 END IF 532 533 534*---------------------------------------------------------------------* 535* end loop over all requested hyperpolarizabilities 536*---------------------------------------------------------------------* 537 END DO 538 END DO 539 END IF 540 END DO 541 542*---------------------------------------------------------------------* 543* print the lists: 544*---------------------------------------------------------------------* 545* general statistics: 546 WRITE(LUPRI,'(/,/3X,A,I4,A)') 'For the requested',NCRRESF, 547 & ' cubic response functions ' 548 WRITE(LUPRI,'((8X,A,I3,A))') 549 & ' - ',N0HTRAN, ' H^0 matrix transformations ', 550 & ' - ',N0GTRAN, ' G^0 matrix transformations ', 551 & ' - ',NAGTRAN, ' G^A matrix transformations ', 552 & ' - ',N0FTRAN, ' F^0 matrix transformations ', 553 & ' - ',NAFTRAN, ' F^A matrix transformations ', 554 & ' - ',N0FATRAN, ' F^0{O} matrix transformations ', 555 & ' - ',NAFATRAN, ' F^A{O} matrix transformations ', 556 & ' - ',NAEATRAN, ' ETA^A{O} vector calculations ' 557 WRITE(LUPRI,'(3X,A,/,/)') 'will be performed.' 558 559 560* K^0 matrix transformations: 561 IF (LOCDBG) THEN 562 WRITE (LUPRI,*) 'List of H^0 matrix transformations:' 563 DO ITRAN = 1, N0HTRAN 564 WRITE(LUPRI,'(A,4I5,5X,(12I5,20X))') MSGDBG, 565 & (I0HTRAN(I,ITRAN),I=1,4),(I0HDOTS(I,ITRAN),I=1,MXV0H) 566 END DO 567 WRITE (LUPRI,*) 568 END IF 569 570* G^0 matrix transformations: 571 IF (LOCDBG) THEN 572 WRITE (LUPRI,*) 'List of G^0 matrix transformations:' 573 DO ITRAN = 1, N0GTRAN 574 WRITE(LUPRI,'(A,3I5,5X,(12I5,20X))') MSGDBG, 575 & (I0GTRAN(I,ITRAN),I=1,3),(I0GDOTS(I,ITRAN),I=1,MXV0G) 576 END DO 577 WRITE (LUPRI,*) 578 END IF 579 580* G^A matrix transformations: 581 IF (LOCDBG) THEN 582 WRITE (LUPRI,*) 'List of G^A matrix transformations:' 583 DO ITRAN = 1, NAGTRAN 584 WRITE(LUPRI,'(A,3I5,5X,(12I5,20X))') MSGDBG, 585 & (IAGTRAN(I,ITRAN),I=1,3),(IAGDOTS(I,ITRAN),I=1,MXVAG) 586 END DO 587 WRITE (LUPRI,*) 588 END IF 589 590* F^0 matrix transformations: 591 IF (LOCDBG) THEN 592 WRITE (LUPRI,*) 'List of F^0 matrix transformations:' 593 DO ITRAN = 1, N0FTRAN 594 WRITE(LUPRI,'(A,2I5,5X,(12I5,20X))') MSGDBG, 595 & (I0FTRAN(I,ITRAN),I=1,2),(I0FDOTS(I,ITRAN),I=1,MXV0F) 596 END DO 597 WRITE (LUPRI,*) 598 END IF 599 600* F^A matrix transformations: 601 IF (LOCDBG) THEN 602 WRITE (LUPRI,*) 'List of F^A matrix transformations:' 603 DO ITRAN = 1, NAFTRAN 604 WRITE(LUPRI,'(A,2I5,5X,(12I5,20X))') MSGDBG, 605 & (IAFTRAN(I,ITRAN),I=1,2),(IAFDOTS(I,ITRAN),I=1,MXVAF) 606 END DO 607 WRITE (LUPRI,*) 608 END IF 609 610* F^0{O} matrix transformations: 611 IF (LOCDBG) THEN 612 WRITE (LUPRI,*) 'List of F{O} matrix transformations:' 613 DO ITRAN = 1, N0FATRAN 614 WRITE(LUPRI,'(A,5I5,5X,(12I5,20X))') MSGDBG, 615 & (I0FATRAN(I,ITRAN),I=1,5),(I0FADOTS(I,ITRAN),I=1,MXV0FA) 616 END DO 617 WRITE (LUPRI,*) 618 END IF 619 620* F^A{O} matrix transformations: 621 IF (LOCDBG) THEN 622 WRITE (LUPRI,*) 'List of F{O} matrix transformations:' 623 DO ITRAN = 1, NAFATRAN 624 WRITE(LUPRI,'(A,5I5,5X,(12I5,20X))') MSGDBG, 625 & (IAFATRAN(I,ITRAN),I=1,5),(IAFADOTS(I,ITRAN),I=1,MXVAFA) 626 END DO 627 WRITE (LUPRI,*) 628 END IF 629 630* ETA{O} vector calculations: 631 IF (LOCDBG) THEN 632 WRITE (LUPRI,*) 'List of ETA{O} vector calculations:' 633 DO ITRAN = 1, NAEATRAN 634 WRITE(LUPRI,'(A,2I5,5X,(12I5,20X))') MSGDBG, 635 & (IAEATRAN(I,ITRAN),I=1,2),(IAEADOTS(I,ITRAN),I=1,MXVAEA) 636 END DO 637 WRITE (LUPRI,*) 638 CALL FLSHFO(LUPRI) 639 END IF 640 641* chi vector dot products 642 IF (LOCDBG) THEN 643 WRITE (LUPRI,*) 'List of chi vector dot products:' 644 DO ITRAN = 1, NXTRAN 645 WRITE(LUPRI,'(A,I5,5X,(12I5,20X))') MSGDBG, 646 & IXTRAN(ITRAN),(IXDOTS(I,ITRAN),I=1,MXX) 647 END DO 648 WRITE (LUPRI,*) 649 CALL FLSHFO(LUPRI) 650 END IF 651 652* L2 x O2 vector dot products 653 IF (LOCDBG) THEN 654 WRITE (LUPRI,*) 'List of L2 x O2 vector dot products:' 655 DO ITRAN = 1, NLTRAN 656 WRITE(LUPRI,'(A,I5,5X,(12I5,20X))') MSGDBG, 657 & ILTRAN(ITRAN),(ILDOTS(I,ITRAN),I=1,MXL) 658 END DO 659 WRITE (LUPRI,*) 660 CALL FLSHFO(LUPRI) 661 END IF 662 663* xksi vector dot products 664 IF (LOCDBG) THEN 665 WRITE (LUPRI,*) 'List of xksi vector dot products:' 666 DO ITRAN = 1, NOTRAN 667 WRITE(LUPRI,'(A,I5,5X,(12I5,20X))') MSGDBG, 668 & IOTRAN(ITRAN),(IODOTS(I,ITRAN),I=1,MXO) 669 END DO 670 WRITE (LUPRI,*) 671 CALL FLSHFO(LUPRI) 672 END IF 673 674 RETURN 675 END 676 677*---------------------------------------------------------------------* 678* END OF SUBROUTINE CCCR_SETUP * 679*---------------------------------------------------------------------* 680c /* deck CCCR_DISP_SETUP */ 681*=====================================================================* 682 SUBROUTINE CCCR_DISP_SETUP( 683 & MXTRAN2, MXVEC2, MXTRAN3, MXVEC1, 684 & I0KTRAN, I0KDOTS, W0K, N0KTRAN, 685 & I0GTRAN, I0GDOTS, W0G, N0GTRAN, 686 & IAGTRAN, IAGDOTS, WAG, NAGTRAN, 687 & I0FTRAN, I0FDOTS, W0F, N0FTRAN, 688 & IAFTRAN, IAFDOTS, WAF, NAFTRAN, 689 & I0FATRAN,I0FADOTS,W0FA, N0FATRAN, 690 & IAFATRAN,IAFADOTS,WAFA, NAFATRAN, 691 & IAEATRAN,IAEADOTS,WAEA, NAEATRAN, 692 & IXTRAN, IXDOTS, WX, NXTRAN, 693 & IOTRAN, IODOTS, WO, NOTRAN, 694 & ILTRAN, ILDOTS, WL, NLTRAN, 695 & EXPCOF, MXEXPCF, LADD ) 696*---------------------------------------------------------------------* 697* 698* Purpose: set up for CCCR dispersion coefficients 699* - list of K^0 matrix transformations 700* - list of G^0 matrix transformations 701* - list of G^A matrix transformations 702* - list of F^0 matrix transformations 703* - list of F^A matrix transformations 704* - list of F^0{O} matrix transformations 705* - list of F^A{O} matrix transformations 706* - list of ETA^A{O} vector calculations 707* - list of chi vector dot products 708* - list of xksi vector dot products 709* 710* Written by Christof Haettig, march 1998. 711* based on CCCR_SETUP routine 712* 713*=====================================================================* 714#if defined (IMPLICIT_NONE) 715 IMPLICIT NONE 716#else 717# include "implicit.h" 718#endif 719#include "priunit.h" 720#include "ccorb.h" 721#include "cccrinf.h" 722#include "ccroper.h" 723#include "cccperm.h" 724 725* local parameters: 726 CHARACTER*(25) MSGDBG 727 PARAMETER (MSGDBG = '[debug] CCCR_DISP_SETUP> ') 728 LOGICAL LOCDBG 729 PARAMETER (LOCDBG = .FALSE.) 730 731 LOGICAL LADD 732 733 INTEGER MXVEC2, MXTRAN2, MXVEC1, MXTRAN3, MXEXPCF 734 735 INTEGER I0KTRAN(5,MXTRAN3) 736 INTEGER I0KDOTS(MXVEC1,MXTRAN3) 737 738 INTEGER I0GTRAN(4,MXTRAN2) 739 INTEGER I0GDOTS(MXVEC2,MXTRAN2) 740 741 INTEGER IAGTRAN(4,MXTRAN3) 742 INTEGER IAGDOTS(MXVEC1,MXTRAN3) 743 744 INTEGER I0FTRAN(3,MXTRAN2) 745 INTEGER I0FDOTS(MXVEC2,MXTRAN2) 746 747 INTEGER IAFTRAN(3,MXTRAN2) 748 INTEGER IAFDOTS(MXVEC2,MXTRAN2) 749 750 INTEGER I0FATRAN(5,MXTRAN2) 751 INTEGER I0FADOTS(MXVEC2,MXTRAN2) 752 753 INTEGER IAFATRAN(5,MXTRAN3) 754 INTEGER IAFADOTS(MXVEC1,MXTRAN3) 755 756 INTEGER IAEATRAN(3,MXTRAN2) 757 INTEGER IAEADOTS(MXVEC2,MXTRAN2) 758 759 INTEGER IXTRAN(MXTRAN2) 760 INTEGER IXDOTS(MXVEC2,MXTRAN2) 761 762 INTEGER IOTRAN(MXTRAN2) 763 INTEGER IODOTS(MXVEC2,MXTRAN2) 764 765 INTEGER ILTRAN(MXTRAN2) 766 INTEGER ILDOTS(MXVEC2,MXTRAN2) 767 768 INTEGER N0KTRAN, N0GTRAN, N0FTRAN, N0FATRAN, NXTRAN, NOTRAN 769 INTEGER NAGTRAN, NAFTRAN, NAFATRAN, NAEATRAN, NLTRAN 770 INTEGER NCREXPCF 771 772 INTEGER IVEC, ITRAN, I 773 INTEGER ISYML, ISYM1, ISYM2, ISYM3, ISYM4 774 INTEGER IDISP, IOPER 775 INTEGER P 776 INTEGER MXV0H, MXV0G, MXVAG, MXV0F, MXVAF, MXV0FA, MXVAFA, MXVAEA 777 INTEGER MXX, MXO, MXL 778 779#if defined (SYS_CRAY) 780 REAL ZERO 781 REAL EXPCOF(MXEXPCF) 782 REAL W0K(MXVEC1,MXTRAN3) 783 REAL W0G(MXVEC2,MXTRAN2) 784 REAL WAG(MXVEC1,MXTRAN3) 785 REAL W0F(MXVEC2,MXTRAN2) 786 REAL WAF(MXVEC2,MXTRAN2) 787 REAL W0FA(MXVEC2,MXTRAN2) 788 REAL WAFA(MXVEC1,MXTRAN3) 789 REAL WAEA(MXVEC2,MXTRAN2) 790 REAL WX(MXVEC2,MXTRAN2) 791 REAL WO(MXVEC2,MXTRAN2) 792 REAL WL(MXVEC2,MXTRAN2) 793 REAL K0CON, G0CON(6), GACON(4), F0CON(3), FACON(12) 794 REAL F0ACON(12), FAACON(12), EAACON(12), SUM 795 REAL XCON(6), OCON(3) 796#else 797 DOUBLE PRECISION ZERO 798 DOUBLE PRECISION EXPCOF(MXEXPCF) 799 DOUBLE PRECISION W0K(MXVEC1,MXTRAN3) 800 DOUBLE PRECISION W0G(MXVEC2,MXTRAN2) 801 DOUBLE PRECISION WAG(MXVEC1,MXTRAN3) 802 DOUBLE PRECISION W0F(MXVEC2,MXTRAN2) 803 DOUBLE PRECISION WAF(MXVEC2,MXTRAN2) 804 DOUBLE PRECISION W0FA(MXVEC2,MXTRAN2) 805 DOUBLE PRECISION WAFA(MXVEC1,MXTRAN3) 806 DOUBLE PRECISION WAEA(MXVEC2,MXTRAN2) 807 DOUBLE PRECISION WX(MXVEC2,MXTRAN2) 808 DOUBLE PRECISION WO(MXVEC2,MXTRAN2) 809 DOUBLE PRECISION WL(MXVEC2,MXTRAN2) 810 DOUBLE PRECISION K0CON, G0CON(6), GACON(4), F0CON(3), FACON(12) 811 DOUBLE PRECISION F0ACON(12), FAACON(12), EAACON(12), SUM 812 DOUBLE PRECISION XCON(6), OCON(3) 813#endif 814 PARAMETER (ZERO = 0.0d0) 815 816 CHARACTER*8 LBL1, LBL2, LBL3, LBL4 817 INTEGER ICO1, ICO2, ICO3, ICO4, ICP1, ICP2 818 INTEGER IOP(4), ICO(4), ISY(4), IZT(4), IR1(4) 819 INTEGER IR2(6), IO2(6), IX2(6), IL2(6) 820 INTEGER ICM1(6), ICM2(6), ICM3(6), ICM4(6) 821 822* external functions: 823 INTEGER ILSTSYM 824 INTEGER ILRCAMP 825 INTEGER ILC1AMP 826 INTEGER ICR2AMP 827 INTEGER ICL2AMP 828 INTEGER IRHSCR2 829 INTEGER IETACL2 830 831 832*---------------------------------------------------------------------* 833* initializations: 834*---------------------------------------------------------------------* 835 IF (.NOT. LADD) THEN 836 N0KTRAN = 0 837 N0GTRAN = 0 838 NAGTRAN = 0 839 N0FTRAN = 0 840 NAFTRAN = 0 841 N0FATRAN = 0 842 NAFATRAN = 0 843 NAEATRAN = 0 844 NXTRAN = 0 845 NOTRAN = 0 846 NLTRAN = 0 847 END IF 848 849 MXV0H = 0 850 MXV0G = 0 851 MXVAG = 0 852 MXV0F = 0 853 MXVAF = 0 854 MXV0FA = 0 855 MXVAFA = 0 856 MXVAEA = 0 857 MXX = 0 858 MXO = 0 859 MXL = 0 860 861 NCREXPCF = 0 862 863 CALL DZERO(EXPCOF,MXEXPCF) 864 865*---------------------------------------------------------------------* 866* start loop over all requested dispersion coefficients: 867*---------------------------------------------------------------------* 868 869 DO IOPER = 1, NCROPER 870 IOP(A) = IACROP(IOPER) 871 IOP(B) = IBCROP(IOPER) 872 IOP(C) = ICCROP(IOPER) 873 IOP(D) = IDCROP(IOPER) 874 875 ISY(A) = ISYOPR(IOP(A)) 876 ISY(B) = ISYOPR(IOP(B)) 877 ISY(C) = ISYOPR(IOP(C)) 878 ISY(D) = ISYOPR(IOP(D)) 879 880 IF (MULD2H(ISY(A),ISY(B)).EQ.MULD2H(ISY(C),ISY(D))) THEN 881 882 DO IDISP = 1, NCRDISP 883 884 NCREXPCF = NCREXPCF + 1 885 886 ICO(A) = ICCAUA(IDISP) 887 ICO(B) = ICCAUB(IDISP) 888 ICO(C) = ICCAUC(IDISP) 889 ICO(D) = ICCAUD(IDISP) 890 891 IZT(A) = ILC1AMP(LBLOPR(IOP(A)),ICCAUA(IDISP),ISYML) 892 IZT(B) = ILC1AMP(LBLOPR(IOP(B)),ICCAUB(IDISP),ISYML) 893 IZT(C) = ILC1AMP(LBLOPR(IOP(C)),ICCAUC(IDISP),ISYML) 894 IZT(D) = ILC1AMP(LBLOPR(IOP(D)),ICCAUD(IDISP),ISYML) 895 896 IR1(A) = ILRCAMP(LBLOPR(IOP(A)),ICCAUA(IDISP),ISYML) 897 IR1(B) = ILRCAMP(LBLOPR(IOP(B)),ICCAUB(IDISP),ISYML) 898 IR1(C) = ILRCAMP(LBLOPR(IOP(C)),ICCAUC(IDISP),ISYML) 899 IR1(D) = ILRCAMP(LBLOPR(IOP(D)),ICCAUD(IDISP),ISYML) 900 901 IF ( NO_2NP1_RULE ) THEN 902 IR2(AB) = ICR2AMP(LBLOPR(IOP(A)),ICCAUA(IDISP),ISYM1, 903 & LBLOPR(IOP(B)),ICCAUB(IDISP),ISYM2) 904 IR2(AC) = ICR2AMP(LBLOPR(IOP(A)),ICCAUA(IDISP),ISYM1, 905 & LBLOPR(IOP(C)),ICCAUC(IDISP),ISYM2) 906 IR2(AD) = ICR2AMP(LBLOPR(IOP(A)),ICCAUA(IDISP),ISYM1, 907 & LBLOPR(IOP(D)),ICCAUD(IDISP),ISYM2) 908 IR2(BC) = ICR2AMP(LBLOPR(IOP(B)),ICCAUB(IDISP),ISYM1, 909 & LBLOPR(IOP(C)),ICCAUC(IDISP),ISYM2) 910 IR2(BD) = ICR2AMP(LBLOPR(IOP(B)),ICCAUB(IDISP),ISYM1, 911 & LBLOPR(IOP(D)),ICCAUD(IDISP),ISYM2) 912 IR2(CD) = ICR2AMP(LBLOPR(IOP(C)),ICCAUC(IDISP),ISYM1, 913 & LBLOPR(IOP(D)),ICCAUD(IDISP),ISYM2) 914 ELSE 915 916 DO P = 1, 3 917 LBL1 = LBLOPR(IOP(I1(P))) ! Labels 918 LBL2 = LBLOPR(IOP(I2(P))) 919 LBL3 = LBLOPR(IOP(I3(P))) 920 LBL4 = LBLOPR(IOP(I4(P))) 921 ICO1 = ICO(I1(P)) ! Cauchy orders 922 ICO2 = ICO(I2(P)) 923 ICO3 = ICO(I3(P)) 924 ICO4 = ICO(I4(P)) 925 926 IF ( (ICO1+ICO2) .GT. (ICO3+ICO4) ) THEN 927 IX2(IP1(P)) = IETACL2(LBL1,ICO1,ISYM1, LBL2,ICO2,ISYM2) 928 IO2(IP1(P)) = IRHSCR2(LBL1,ICO1,ISYM1, LBL2,ICO2,ISYM2) 929 IL2(IP2(P)) = ICL2AMP(LBL3,ICO3,ISYM3, LBL4,ICO4,ISYM4) 930 IR2(IP2(P)) = ICR2AMP(LBL3,ICO3,ISYM3, LBL4,ICO4,ISYM4) 931 ELSE IF ( (ICO1+ICO2) .EQ. (ICO3+ICO4) ) THEN 932 IX2(IP1(P)) = IETACL2(LBL1,ICO1,ISYM1, LBL2,ICO2,ISYM2) 933 IR2(IP1(P)) = ICR2AMP(LBL1,ICO1,ISYM1, LBL2,ICO2,ISYM2) 934 IX2(IP2(P)) = IETACL2(LBL3,ICO3,ISYM3, LBL4,ICO4,ISYM4) 935 IR2(IP2(P)) = ICR2AMP(LBL3,ICO3,ISYM3, LBL4,ICO4,ISYM4) 936 IF (ICO1.GT.0) THEN 937 ICM1(IP1(P))=ICL2AMP(LBL1,ICO1-1,ISYM1, LBL2,ICO2,ISYM2) 938 END IF 939 IF (ICO2.GT.0) THEN 940 ICM2(IP1(P))=ICL2AMP(LBL1,ICO1,ISYM1, LBL2,ICO2-1,ISYM2) 941 END IF 942 IF (ICO3.GT.0) THEN 943 ICM3(IP2(P))=ICL2AMP(LBL3,ICO3-1,ISYM3, LBL4,ICO4,ISYM4) 944 END IF 945 IF (ICO4.GT.0) THEN 946 ICM4(IP2(P))=ICL2AMP(LBL3,ICO3,ISYM3, LBL4,ICO4-1,ISYM4) 947 END IF 948 ELSE IF ( (ICO1+ICO2) .LT. (ICO3+ICO4) ) THEN 949 IL2(IP1(P)) = ICL2AMP(LBL1,ICO1,ISYM1, LBL2,ICO2,ISYM2) 950 IR2(IP1(P)) = ICR2AMP(LBL1,ICO1,ISYM1, LBL2,ICO2,ISYM2) 951 IX2(IP2(P)) = IETACL2(LBL3,ICO3,ISYM3, LBL4,ICO4,ISYM4) 952 IO2(IP2(P)) = IRHSCR2(LBL3,ICO3,ISYM3, LBL4,ICO4,ISYM4) 953 END IF 954 955 END DO ! P 956 957 END IF 958 959*---------------------------------------------------------------------* 960* set up list of K^0 matrix transformations, 1 permutation 961*---------------------------------------------------------------------* 962 CALL CC_SETH1111(I0KTRAN,I0KDOTS,MXTRAN3,MXVEC1, 963 & 0,IR1(A),IR1(B),IR1(C),IR1(D),ITRAN,IVEC) 964 N0KTRAN = MAX(N0KTRAN,ITRAN) 965 MXV0H = MAX(MXV0H,IVEC) 966 K0CON = W0K(IVEC,ITRAN) 967 968*---------------------------------------------------------------------* 969* set up list of G^0 matrix transformations, 6 permutations 970*---------------------------------------------------------------------* 971 IF (NO_2NP1_RULE) THEN 972 DO P = 1, 6 973 CALL CC_SETG112(I0GTRAN,I0GDOTS,MXTRAN2,MXVEC2, 974 & 0,IR1(I1(P)),IR1(I2(P)),IR2(IP(P)),ITRAN,IVEC) 975 N0GTRAN = MAX(N0GTRAN,ITRAN) 976 MXV0G = MAX(MXV0G,IVEC) 977 G0CON(P) = W0G(IVEC,ITRAN) 978 END DO 979 ELSE 980 DO P = 1, 6 981 G0CON(P) = ZERO 982 END DO 983 END IF 984 985*---------------------------------------------------------------------* 986* set up list of G^A matrix transformations, 4 permutations 987*---------------------------------------------------------------------* 988 CALL CCQR_SETG(IAGTRAN,IAGDOTS,MXTRAN3,MXVEC1, 989 & IZT(A),IR1(B),IR1(C),IR1(D),ITRAN,IVEC) 990 NAGTRAN = MAX(NAGTRAN,ITRAN) 991 MXVAG = MAX(MXVAG,IVEC) 992 GACON(1) = WAG(IVEC,ITRAN) 993 994 CALL CCQR_SETG(IAGTRAN,IAGDOTS,MXTRAN3,MXVEC1, 995 & IZT(B),IR1(A),IR1(C),IR1(D),ITRAN,IVEC) 996 NAGTRAN = MAX(NAGTRAN,ITRAN) 997 MXVAG = MAX(MXVAG,IVEC) 998 GACON(2) = WAG(IVEC,ITRAN) 999 1000 CALL CCQR_SETG(IAGTRAN,IAGDOTS,MXTRAN3,MXVEC1, 1001 & IZT(C),IR1(B),IR1(A),IR1(D),ITRAN,IVEC) 1002 NAGTRAN = MAX(NAGTRAN,ITRAN) 1003 MXVAG = MAX(MXVAG,IVEC) 1004 GACON(3) = WAG(IVEC,ITRAN) 1005 1006 CALL CCQR_SETG(IAGTRAN,IAGDOTS,MXTRAN3,MXVEC1, 1007 & IZT(D),IR1(B),IR1(C),IR1(A),ITRAN,IVEC) 1008 NAGTRAN = MAX(NAGTRAN,ITRAN) 1009 MXVAG = MAX(MXVAG,IVEC) 1010 GACON(4) = WAG(IVEC,ITRAN) 1011 1012*---------------------------------------------------------------------* 1013* set up list of F^0 matrix transformations, 3 permutations 1014*---------------------------------------------------------------------* 1015 IF (NO_2NP1_RULE) THEN 1016 CALL CCQR_SETF(I0FTRAN,I0FDOTS,MXTRAN2,MXVEC2, 1017 & 0,IR2(AB),IR2(CD),ITRAN,IVEC) 1018 N0FTRAN = MAX(N0FTRAN,ITRAN) 1019 MXV0F = MAX(MXV0F,IVEC) 1020 F0CON(1) = W0F(IVEC,ITRAN) 1021 1022 CALL CCQR_SETF(I0FTRAN,I0FDOTS,MXTRAN2,MXVEC2, 1023 & 0,IR2(AC),IR2(BD),ITRAN,IVEC) 1024 N0FTRAN = MAX(N0FTRAN,ITRAN) 1025 MXV0F = MAX(MXV0F,IVEC) 1026 F0CON(2) = W0F(IVEC,ITRAN) 1027 1028 CALL CCQR_SETF(I0FTRAN,I0FDOTS,MXTRAN2,MXVEC2, 1029 & 0,IR2(AD),IR2(BC),ITRAN,IVEC) 1030 N0FTRAN = MAX(N0FTRAN,ITRAN) 1031 MXV0F = MAX(MXV0F,IVEC) 1032 F0CON(3) = W0F(IVEC,ITRAN) 1033 END IF 1034 1035*---------------------------------------------------------------------* 1036* set up list of F^A matrix transformations, 12 permutations 1037*---------------------------------------------------------------------* 1038 IF (NO_2NP1_RULE) THEN 1039 DO P = 1, 6 1040 CALL CC_SETF12(IAFTRAN,IAFDOTS,MXTRAN2,MXVEC2, ! 1 x 2 x 3,4 1041 & IZT(I1(P)),IR1(I2(P)),IR2(IP(P)),ITRAN,IVEC) 1042 NAFTRAN = MAX(NAFTRAN,ITRAN) 1043 MXVAF = MAX(MXVAF,IVEC) 1044 FACON(P) = WAF(IVEC,ITRAN) 1045 1046 CALL CC_SETF12(IAFTRAN,IAFDOTS,MXTRAN2,MXVEC2, ! 2 x 1 x 3,4 1047 & IZT(I2(P)),IR1(I1(P)),IR2(IP(P)),ITRAN,IVEC) 1048 NAFTRAN = MAX(NAFTRAN,ITRAN) 1049 MXVAF = MAX(MXVAF,IVEC) 1050 FACON(6+P) = WAF(IVEC,ITRAN) 1051 END DO 1052 ELSE 1053 DO P = 1, 6 1054 FACON(P) = ZERO 1055 FACON(6+P) = ZERO 1056 END DO 1057 END IF 1058 1059*---------------------------------------------------------------------* 1060* set up list of F^0{O} matrix transformations, 12 permutations 1061*---------------------------------------------------------------------* 1062 IF (NO_2NP1_RULE) THEN 1063 DO P = 1, 6 1064 IF ( ICO(I1(P)).EQ.0 ) THEN 1065 CALL CC_SETFA12(I0FATRAN,I0FADOTS,MXTRAN2,MXVEC2, ! 1x2x3,4 1066 & 0,IOP(I1(P)),IR1(I2(P)),IR2(IP(P)),ITRAN,IVEC) 1067 N0FATRAN = MAX(N0FATRAN,ITRAN) 1068 MXV0FA = MAX(MXV0FA,IVEC) 1069 F0ACON(P) = W0FA(IVEC,ITRAN) 1070 ELSE 1071 F0ACON(P) = ZERO 1072 END IF 1073 1074 IF ( ICO(I2(P)).EQ.0 ) THEN 1075 CALL CC_SETFA12(I0FATRAN,I0FADOTS,MXTRAN2,MXVEC2, ! 2x1x3,4 1076 & 0,IOP(I2(P)),IR1(I1(P)),IR2(IP(P)),ITRAN,IVEC) 1077 N0FATRAN = MAX(N0FATRAN,ITRAN) 1078 MXV0FA = MAX(MXV0FA,IVEC) 1079 F0ACON(6+P) = W0FA(IVEC,ITRAN) 1080 ELSE 1081 F0ACON(6+P) = ZERO 1082 END IF 1083 END DO 1084 ELSE 1085 DO P = 1, 6 1086 F0ACON(P) = ZERO 1087 F0ACON(6+P) = ZERO 1088 END DO 1089 END IF 1090 1091*---------------------------------------------------------------------* 1092* set up list of F^A{O} matrix transformations, 12 permutations 1093*---------------------------------------------------------------------* 1094 DO P = 1, 6 1095 IF ( ICO(I2(P)).EQ.0 ) THEN 1096 CALL CCQR_SETFA(IAFATRAN,IAFADOTS,MXTRAN3,MXVEC1, ! 1x2x3x4 1097 & IZT(I1(P)),IOP(I2(P)),IR1(I3(P)),IR1(I4(P)),ITRAN,IVEC) 1098 NAFATRAN = MAX(NAFATRAN,ITRAN) 1099 MXVAFA = MAX(MXVAFA,IVEC) 1100 FAACON(P) = WAFA(IVEC,ITRAN) 1101 ELSE 1102 FAACON(P) = ZERO 1103 END IF 1104 1105 IF ( ICO(I1(P)).EQ.0 ) THEN 1106 CALL CCQR_SETFA(IAFATRAN,IAFADOTS,MXTRAN3,MXVEC1, ! 2x1x3x4 1107 & IZT(I2(P)),IOP(I1(P)),IR1(I3(P)),IR1(I4(P)),ITRAN,IVEC) 1108 NAFATRAN = MAX(NAFATRAN,ITRAN) 1109 MXVAFA = MAX(MXVAFA,IVEC) 1110 FAACON(6+P) = WAFA(IVEC,ITRAN) 1111 ELSE 1112 FAACON(6+P) = ZERO 1113 END IF 1114 END DO 1115 1116*---------------------------------------------------------------------* 1117* set up list of ETA{O} vector calculations, 12 permutations 1118*---------------------------------------------------------------------* 1119 IF (NO_2NP1_RULE) THEN 1120 DO P = 1, 6 1121 IF ( ICO(I2(P)).EQ.0 ) THEN 1122 CALL CCQR_SETEA(IAEATRAN,IAEADOTS,MXTRAN2,MXVEC2, ! 1x2x3,4 1123 & IZT(I1(P)),IOP(I2(P)),IR2(IP(P)),ITRAN,IVEC) 1124 NAEATRAN = MAX(NAEATRAN,ITRAN) 1125 MXVAEA = MAX(MXVAEA,IVEC) 1126 EAACON(P) = WAEA(IVEC,ITRAN) 1127 ELSE 1128 EAACON(P) = ZERO 1129 END IF 1130 1131 IF ( ICO(I1(P)).EQ.0 ) THEN 1132 CALL CCQR_SETEA(IAEATRAN,IAEADOTS,MXTRAN2,MXVEC2, ! 2x1x3,4 1133 & IZT(I2(P)),IOP(I1(P)),IR2(IP(P)),ITRAN,IVEC) 1134 NAEATRAN = MAX(NAEATRAN,ITRAN) 1135 MXVAEA = MAX(MXVAEA,IVEC) 1136 EAACON(6+P) = WAEA(IVEC,ITRAN) 1137 ELSE 1138 EAACON(6+P) = ZERO 1139 END IF 1140 END DO 1141 ELSE 1142 DO P = 1, 6 1143 EAACON(P) = ZERO 1144 EAACON(6+P) = ZERO 1145 END DO 1146 END IF 1147 1148*---------------------------------------------------------------------* 1149* if we use the 2n+1/2n+2 rules for the second-order Cauchy vectors, 1150* we here set up list of CX2 x CR2 and CL2 x CO2 dot products 1151* (max. 3 permutations) and the list for the F transf. (max. 3 perm.) 1152*---------------------------------------------------------------------* 1153 IF (.NOT. NO_2NP1_RULE ) THEN 1154 1155 DO P = 1, 3 1156 ICP1 = ICO(I1(P))+ICO(I2(P)) 1157 ICP2 = ICO(I3(P))+ICO(I4(P)) 1158 1159 IF ( ICP1.GT.ICP2 ) THEN 1160 CALL CC_SETDOT(IXTRAN,IXDOTS,MXTRAN2,MXVEC2, 1161 & IX2(IP1(P)),IR2(IP2(P)),ITRAN,IVEC) 1162 NXTRAN = MAX(NXTRAN,ITRAN) 1163 MXX = MAX(MXX,IVEC) 1164 XCON(P) = WX(IVEC,ITRAN) 1165 1166 CALL CC_SETDOT(IOTRAN,IODOTS,MXTRAN2,MXVEC2, 1167 & IO2(IP1(P)),IL2(IP2(P)),ITRAN,IVEC) 1168 NOTRAN = MAX(NOTRAN,ITRAN) 1169 MXO = MAX(MXO,IVEC) 1170 OCON(P) = WO(IVEC,ITRAN) 1171 1172 XCON(P+3) = ZERO 1173 F0CON(P) = ZERO 1174 1175 ELSE IF ( ICP1.LT.ICP2 ) THEN 1176 CALL CC_SETDOT(IXTRAN,IXDOTS,MXTRAN2,MXVEC2, 1177 & IX2(IP2(P)),IR2(IP1(P)),ITRAN,IVEC) 1178 NXTRAN = MAX(NXTRAN,ITRAN) 1179 MXX = MAX(MXX,IVEC) 1180 XCON(P) = WX(IVEC,ITRAN) 1181 1182 CALL CC_SETDOT(IOTRAN,IODOTS,MXTRAN2,MXVEC2, 1183 & IO2(IP2(P)),IL2(IP1(P)),ITRAN,IVEC) 1184 NOTRAN = MAX(NOTRAN,ITRAN) 1185 MXO = MAX(MXO,IVEC) 1186 OCON(P) = WO(IVEC,ITRAN) 1187 1188 XCON(P+3) = ZERO 1189 F0CON(P) = ZERO 1190 1191 ELSE IF ( ICP1.EQ.ICP2 ) THEN 1192 CALL CC_SETDOT(IXTRAN,IXDOTS,MXTRAN2,MXVEC2, 1193 & IX2(IP1(P)),IR2(IP2(P)),ITRAN,IVEC) 1194 NXTRAN = MAX(NXTRAN,ITRAN) 1195 MXX = MAX(MXX,IVEC) 1196 XCON(P) = WX(IVEC,ITRAN) 1197 1198 CALL CC_SETDOT(IXTRAN,IXDOTS,MXTRAN2,MXVEC2, 1199 & IX2(IP2(P)),IR2(IP1(P)),ITRAN,IVEC) 1200 NXTRAN = MAX(NXTRAN,ITRAN) 1201 MXX = MAX(MXX,IVEC) 1202 XCON(P+3) = WX(IVEC,ITRAN) 1203 1204 OCON(P) = ZERO 1205 1206 IF (ICO(I3(P)).GT.0) THEN 1207 CALL CC_SETDOT(ILTRAN,ILDOTS,MXTRAN2,MXVEC2, 1208 & ICM3(IP2(P)),IR2(IP1(P)),ITRAN,IVEC) 1209 NLTRAN = MAX(NLTRAN,ITRAN) 1210 MXL = MAX(MXL,IVEC) 1211 OCON(P) = OCON(P) + WL(IVEC,ITRAN) 1212 END IF 1213 1214 IF (ICO(I4(P)).GT.0) THEN 1215 CALL CC_SETDOT(ILTRAN,ILDOTS,MXTRAN2,MXVEC2, 1216 & ICM4(IP2(P)),IR2(IP1(P)),ITRAN,IVEC) 1217 NLTRAN = MAX(NLTRAN,ITRAN) 1218 MXL = MAX(MXL,IVEC) 1219 OCON(P) = OCON(P) + WL(IVEC,ITRAN) 1220 END IF 1221 1222 IF (ICO(I1(P)).GT.0) THEN 1223 CALL CC_SETDOT(ILTRAN,ILDOTS,MXTRAN2,MXVEC2, 1224 & ICM1(IP1(P)),IR2(IP2(P)),ITRAN,IVEC) 1225 NLTRAN = MAX(NLTRAN,ITRAN) 1226 MXL = MAX(MXL,IVEC) 1227 OCON(P) = OCON(P) + WL(IVEC,ITRAN) 1228 END IF 1229 1230 IF (ICO(I2(P)).GT.0) THEN 1231 CALL CC_SETDOT(ILTRAN,ILDOTS,MXTRAN2,MXVEC2, 1232 & ICM2(IP1(P)),IR2(IP2(P)),ITRAN,IVEC) 1233 NLTRAN = MAX(NLTRAN,ITRAN) 1234 MXL = MAX(MXL,IVEC) 1235 OCON(P) = OCON(P) + WL(IVEC,ITRAN) 1236 END IF 1237 1238 CALL CCQR_SETF(I0FTRAN,I0FDOTS,MXTRAN2,MXVEC2, 1239 & 0,IR2(IP1(P)),IR2(IP2(P)),ITRAN,IVEC) 1240 N0FTRAN = MAX(N0FTRAN,ITRAN) 1241 MXV0F = MAX(MXV0F,IVEC) 1242 F0CON(P) = W0F(IVEC,ITRAN) 1243 END IF 1244 1245 END DO 1246 1247 ELSE 1248 DO P = 1, 3 1249 XCON(P) = ZERO 1250 XCON(P+3) = ZERO 1251 OCON(P) = ZERO 1252 END DO 1253 END IF 1254 1255*---------------------------------------------------------------------* 1256* add contributions to hyperpolarizabilities: 1257*---------------------------------------------------------------------* 1258 IF (LADD) THEN 1259 1260 EXPCOF(NCRDISP*(IOPER-1)+ IDISP) = 1261 & K0CON + 1262 & G0CON(1) + G0CON(2) + G0CON(3) + G0CON(4) + 1263 & G0CON(5) + G0CON(6) + 1264 & GACON(1) + GACON(2) + GACON(3) + GACON(4) + 1265 & F0CON(1) + F0CON(2) + F0CON(3) + 1266 & FACON(1) + FACON(2) + FACON(3) + FACON(4) + 1267 & FACON(5) + FACON(6) + FACON(7) + FACON(8) + 1268 & FACON(9) + FACON(10) + FACON(11) + FACON(12) + 1269 & F0ACON(1) + F0ACON(2) + F0ACON(3) + F0ACON(4) + 1270 & F0ACON(5) + F0ACON(6) + F0ACON(7) + F0ACON(8) + 1271 & F0ACON(9) + F0ACON(10)+ F0ACON(11) + F0ACON(12) + 1272 & FAACON(1) + FAACON(2) + FAACON(3) + FAACON(4) + 1273 & FAACON(5) + FAACON(6) + FAACON(7) + FAACON(8) + 1274 & FAACON(9) + FAACON(10)+ FAACON(11) + FAACON(12) + 1275 & EAACON(1) + EAACON(2) + EAACON(3) + EAACON(4) + 1276 & EAACON(5) + EAACON(6) + EAACON(7) + EAACON(8) + 1277 & EAACON(9) + EAACON(10)+ EAACON(11) + EAACON(12) + 1278 & XCON(1) + XCON(2) + XCON(3) + 1279 & XCON(4) + XCON(5) + XCON(6) + 1280 & OCON(1) + OCON(2) + OCON(3) 1281 1282 IF (LOCDBG) THEN 1283 WRITE(LUPRI,'(A,3I5)') 'IOPER, IDISP:',IOPER,IDISP 1284 WRITE(LUPRI,'(A,4I5)') 'IOP:',(IOP(I),I=1,4) 1285 WRITE(LUPRI,'(A,4I5)') 'ICO:',(ICO(I),I=1,4) 1286 WRITE(LUPRI,'(A,4I5)') 'ISY:',(ISY(I),I=1,4) 1287 WRITE(LUPRI,'(A,4I5)') 'IZT:',(IZT(I),I=1,4) 1288 WRITE(LUPRI,'(A,4I5)') 'IR1:',(IR1(I),I=1,4) 1289 WRITE(LUPRI,'(A,6I5)') 'IR2:',(IR2(I),I=1,6) 1290 WRITE(LUPRI,*) 'INDEX:', NCRDISP*(IOPER-1)+ IDISP 1291 WRITE(LUPRI,*) 'EXPCOF:',EXPCOF(NCRDISP*(IOPER-1)+ IDISP) 1292 WRITE(LUPRI,*) 'K0CON: ',K0CON 1293 SUM = K0CON 1294 WRITE(LUPRI,*) 'G0CON: ',(G0CON(I),I=1,6) 1295 DO I = 1, 6 1296 SUM = SUM + G0CON(I) 1297 END DO 1298 WRITE(LUPRI,*) 'SUM:',SUM 1299 WRITE(LUPRI,*) 'GACON: ',(GACON(I),I=1,4) 1300 DO I = 1, 4 1301 SUM = SUM + GACON(I) 1302 END DO 1303 WRITE(LUPRI,*) 'SUM:',SUM 1304 WRITE(LUPRI,*) 'F0CON: ',(F0CON(I),I=1,3) 1305 DO I = 1, 3 1306 SUM = SUM + F0CON(I) 1307 END DO 1308 WRITE(LUPRI,*) 'SUM:',SUM 1309 WRITE(LUPRI,*) 'FACON: ',(FACON(I),I=1,12) 1310 DO I = 1, 12 1311 SUM = SUM + FACON(I) 1312 END DO 1313 WRITE(LUPRI,*) 'SUM:',SUM 1314 WRITE(LUPRI,*) 'F0ACON:',(F0ACON(I),I=1,12) 1315 DO I = 1, 12 1316 SUM = SUM + F0ACON(I) 1317 END DO 1318 WRITE(LUPRI,*) 'SUM:',SUM 1319 WRITE(LUPRI,*) 'FAACON:',(FAACON(I),I=1,12) 1320 DO I = 1, 12 1321 SUM = SUM + FAACON(I) 1322 END DO 1323 WRITE(LUPRI,*) 'SUM:',SUM 1324 WRITE(LUPRI,*) 'EAACON:',(EAACON(I),I=1,12) 1325 DO I = 1, 12 1326 SUM = SUM +EAACON(I) 1327 END DO 1328 WRITE(LUPRI,*) 'SUM:',SUM 1329 WRITE(LUPRI,*) 'XCON:',(XCON(I),I=1,6) 1330 DO I = 1, 6 1331 SUM = SUM +XCON(I) 1332 END DO 1333 WRITE(LUPRI,*) 'SUM:',SUM 1334 WRITE(LUPRI,*) 'OCON:',(OCON(I),I=1,3) 1335 DO I = 1, 3 1336 SUM = SUM +OCON(I) 1337 END DO 1338 WRITE(LUPRI,*) 'SUM:',SUM 1339 1340 SUM = EXPCOF(NCRDISP*(IOPER-1)+ IDISP) - SUM 1341 WRITE(LUPRI,*) 'DIFFERENCE:', SUM 1342 END IF 1343 1344 END IF 1345 1346*---------------------------------------------------------------------* 1347* end loop over all requested dispersion coefficients 1348*---------------------------------------------------------------------* 1349 END DO 1350 END IF 1351 END DO 1352 1353*---------------------------------------------------------------------* 1354* print the lists: 1355*---------------------------------------------------------------------* 1356 IF (.NOT. LADD) THEN 1357 1358* general statistics: 1359 WRITE(LUPRI,'(////,/3X,A,I5,A)') 'For the requested',NCREXPCF, 1360 & ' expansion coefficients for cubic response functions ' 1361 WRITE(LUPRI,'((8X,A,I3,A))') 1362 & ' - ',N0KTRAN, ' H^0 matrix transformations ', 1363 & ' - ',N0GTRAN, ' G^0 matrix transformations ', 1364 & ' - ',NAGTRAN, ' G^A matrix transformations ', 1365 & ' - ',N0FTRAN, ' F^0 matrix transformations ', 1366 & ' - ',NAFTRAN, ' F^A matrix transformations ', 1367 & ' - ',N0FATRAN, ' F^0{O} matrix transformations ', 1368 & ' - ',NAFATRAN, ' F^A{O} matrix transformations ', 1369 & ' - ',NAEATRAN, ' ETA^A{O} vector calculations ', 1370 & ' - ',NXTRAN, ' CX2 x CR2 dot product calculations ', 1371 & ' - ',NOTRAN, ' CL2 x CO2 dot product calculations ' 1372 WRITE(LUPRI,'(3X,A,/,/)') 'will be performed.' 1373 1374 1375* K^0 matrix transformations: 1376 IF (LOCDBG) THEN 1377 WRITE (LUPRI,*) 'List of K^0 matrix transformations:' 1378 DO ITRAN = 1, N0KTRAN 1379 WRITE(LUPRI,'(A,4I5,5X,(12I5,20X))') MSGDBG, 1380 & (I0KTRAN(I,ITRAN),I=1,4),(I0KDOTS(I,ITRAN),I=1,MXV0H) 1381 END DO 1382 WRITE (LUPRI,*) 1383 END IF 1384 1385* G^0 matrix transformations: 1386 IF (LOCDBG) THEN 1387 WRITE (LUPRI,*) 'List of G^0 matrix transformations:' 1388 DO ITRAN = 1, N0GTRAN 1389 WRITE(LUPRI,'(A,3I5,5X,(12I5,20X))') MSGDBG, 1390 & (I0GTRAN(I,ITRAN),I=1,3),(I0GDOTS(I,ITRAN),I=1,MXV0G) 1391 END DO 1392 WRITE (LUPRI,*) 1393 END IF 1394 1395* G^A matrix transformations: 1396 IF (LOCDBG) THEN 1397 WRITE (LUPRI,*) 'List of G^A matrix transformations:' 1398 DO ITRAN = 1, NAGTRAN 1399 WRITE(LUPRI,'(A,3I5,5X,(12I5,20X))') MSGDBG, 1400 & (IAGTRAN(I,ITRAN),I=1,3),(IAGDOTS(I,ITRAN),I=1,MXVAG) 1401 END DO 1402 WRITE (LUPRI,*) 1403 END IF 1404 1405* F^0 matrix transformations: 1406 IF (LOCDBG) THEN 1407 WRITE (LUPRI,*) 'List of F^0 matrix transformations:' 1408 DO ITRAN = 1, N0FTRAN 1409 WRITE(LUPRI,'(A,2I5,5X,(12I5,20X))') MSGDBG, 1410 & (I0FTRAN(I,ITRAN),I=1,2),(I0FDOTS(I,ITRAN),I=1,MXV0F) 1411 END DO 1412 WRITE (LUPRI,*) 1413 END IF 1414 1415* F^A matrix transformations: 1416 IF (LOCDBG) THEN 1417 WRITE (LUPRI,*) 'List of F^A matrix transformations:' 1418 DO ITRAN = 1, NAFTRAN 1419 WRITE(LUPRI,'(A,2I5,5X,(12I5,20X))') MSGDBG, 1420 & (IAFTRAN(I,ITRAN),I=1,2),(IAFDOTS(I,ITRAN),I=1,MXVAF) 1421 END DO 1422 WRITE (LUPRI,*) 1423 END IF 1424 1425* F^0{O} matrix transformations: 1426 IF (LOCDBG) THEN 1427 WRITE (LUPRI,*) 'List of F{O} matrix transformations:' 1428 DO ITRAN = 1, N0FATRAN 1429 WRITE(LUPRI,'(A,5I5,5X,(12I5,20X))') MSGDBG, 1430 & (I0FATRAN(I,ITRAN),I=1,5),(I0FADOTS(I,ITRAN),I=1,MXV0FA) 1431 END DO 1432 WRITE (LUPRI,*) 1433 END IF 1434 1435* F^A{O} matrix transformations: 1436 IF (LOCDBG) THEN 1437 WRITE (LUPRI,*) 'List of F{O} matrix transformations:' 1438 DO ITRAN = 1, NAFATRAN 1439 WRITE(LUPRI,'(A,5I5,5X,(12I5,20X))') MSGDBG, 1440 & (IAFATRAN(I,ITRAN),I=1,5),(IAFADOTS(I,ITRAN),I=1,MXVAFA) 1441 END DO 1442 WRITE (LUPRI,*) 1443 END IF 1444 1445* ETA{O} vector calculations: 1446 IF (LOCDBG) THEN 1447 WRITE (LUPRI,*) 'List of ETA{O} vector calculations:' 1448 DO ITRAN = 1, NAEATRAN 1449 WRITE(LUPRI,'(A,2I5,5X,(12I5,20X))') MSGDBG, 1450 & (IAEATRAN(I,ITRAN),I=1,2),(IAEADOTS(I,ITRAN),I=1,MXVAEA) 1451 END DO 1452 WRITE (LUPRI,*) 1453 CALL FLSHFO(LUPRI) 1454 END IF 1455 1456* eta vector dot products: 1457 IF (LOCDBG) THEN 1458 WRITE (LUPRI,*) 'List of eta vector dot products:' 1459 DO ITRAN = 1, NXTRAN 1460 WRITE(LUPRI,'(A,I5,5X,(12I5,20X))') MSGDBG, 1461 & IXTRAN(ITRAN),(IXDOTS(I,ITRAN),I=1,MXX) 1462 END DO 1463 WRITE (LUPRI,*) 1464 CALL FLSHFO(LUPRI) 1465 END IF 1466 1467* xksi vector dot products: 1468 IF (LOCDBG) THEN 1469 WRITE (LUPRI,*) 'List of xksi vector dot products:' 1470 DO ITRAN = 1, NOTRAN 1471 WRITE(LUPRI,'(A,I5,5X,(12I5,20X))') MSGDBG, 1472 & IOTRAN(ITRAN),(IODOTS(I,ITRAN),I=1,MXO) 1473 END DO 1474 WRITE (LUPRI,*) 1475 CALL FLSHFO(LUPRI) 1476 END IF 1477 1478* CL2 x CR2 vector dot products: 1479 IF (LOCDBG) THEN 1480 WRITE (LUPRI,*) 'List of CL2 x CR2 vector dot products:' 1481 DO ITRAN = 1, NLTRAN 1482 WRITE(LUPRI,'(A,I5,5X,(12I5,20X))') MSGDBG, 1483 & ILTRAN(ITRAN),(ILDOTS(I,ITRAN),I=1,MXL) 1484 END DO 1485 WRITE (LUPRI,*) 1486 CALL FLSHFO(LUPRI) 1487 END IF 1488 1489 END IF 1490 1491 RETURN 1492 END 1493 1494*---------------------------------------------------------------------* 1495* END OF SUBROUTINE CCCR_DISP_SETUP * 1496*---------------------------------------------------------------------* 1497c /* deck CC_SETH1111 */ 1498*=====================================================================* 1499 SUBROUTINE CC_SETH1111(IHTRAN,IHDOTS,MXTRAN,MXVEC,IZETAV, 1500 & ITAMPA,ITAMPB,ITAMPC,ITAMPD,ITRAN,IVEC) 1501*---------------------------------------------------------------------* 1502* 1503* Purpose: maintain a list of dot products of H matrix 1504* transformations with right amplitude vectors: 1505* (Z*H*T*T*T) * T 1506* N.B.: assumes that all four T vectors belong to the same list 1507* 1508* IHTRAN - list of H matrix transformations 1509* IHDOTS - list of vectors it should be dottet on 1510* 1511* MXTRAN - maximum list dimension 1512* MXVEC - maximum second dimesion for IHDOTS 1513* 1514* IZETAV - index of lagrangian multiplier vector 1515* ITAMPA - index of amplitude vector A 1516* ITAMPB - index of amplitude vector B 1517* ITAMPC - index of amplitude vector C 1518* ITAMPD - index of amplitude vector D 1519* 1520* ITRAN - index in IHTRAN list 1521* IVEC - second index in IHDOTS list 1522* 1523* Written by Christof Haettig, february 1997. 1524* 1525*=====================================================================* 1526 IMPLICIT NONE 1527#include "priunit.h" 1528 INTEGER MXVEC, MXTRAN 1529 INTEGER IHTRAN(5,MXTRAN) 1530 INTEGER IHDOTS(MXVEC,MXTRAN) 1531 1532 LOGICAL LFNDA, LFNDB, LFNDC, LFNDD 1533 INTEGER IZETAV, ITAMPA, ITAMPB, ITAMPC, ITAMPD 1534 INTEGER ITRAN, IVEC 1535 INTEGER ITAMP, I, IDX 1536 1537* statement functions: 1538 LOGICAL LHTST, LHEND 1539 INTEGER IL, IA, IB,IC 1540 LHTST(ITRAN,IL,IA,IB,IC) = IHTRAN(1,ITRAN).EQ.IL .AND. ( 1541 & (IHTRAN(2,ITRAN).EQ.IA .AND. IHTRAN(3,ITRAN).EQ.IB 1542 & .AND. IHTRAN(4,ITRAN).EQ.IC) .OR. 1543 & (IHTRAN(2,ITRAN).EQ.IB .AND. IHTRAN(3,ITRAN).EQ.IA 1544 & .AND. IHTRAN(4,ITRAN).EQ.IC) .OR. 1545 & (IHTRAN(2,ITRAN).EQ.IC .AND. IHTRAN(3,ITRAN).EQ.IA 1546 & .AND. IHTRAN(4,ITRAN).EQ.IB) .OR. 1547 & (IHTRAN(2,ITRAN).EQ.IA .AND. IHTRAN(3,ITRAN).EQ.IC 1548 & .AND. IHTRAN(4,ITRAN).EQ.IB) .OR. 1549 & (IHTRAN(2,ITRAN).EQ.IB .AND. IHTRAN(3,ITRAN).EQ.IC 1550 & .AND. IHTRAN(4,ITRAN).EQ.IA) .OR. 1551 & (IHTRAN(2,ITRAN).EQ.IC .AND. IHTRAN(3,ITRAN).EQ.IB 1552 & .AND. IHTRAN(4,ITRAN).EQ.IA) ) 1553 LHEND(ITRAN) = ITRAN.GT.MXTRAN .OR. 1554 & (IHTRAN(1,ITRAN)+IHTRAN(2,ITRAN)+ 1555 & IHTRAN(3,ITRAN)+IHTRAN(4,ITRAN) ).LE.0 1556 1557*---------------------------------------------------------------------* 1558* set up list of H matrix transformations 1559*---------------------------------------------------------------------* 1560 ITRAN = 1 1561 LFNDA = LHTST(ITRAN,IZETAV,ITAMPB,ITAMPC,ITAMPD) 1562 LFNDB = LHTST(ITRAN,IZETAV,ITAMPC,ITAMPD,ITAMPA) 1563 LFNDC = LHTST(ITRAN,IZETAV,ITAMPD,ITAMPA,ITAMPB) 1564 LFNDD = LHTST(ITRAN,IZETAV,ITAMPA,ITAMPB,ITAMPC) 1565 1566 DO WHILE ( .NOT. (LFNDA.OR.LFNDB.OR.LFNDC.OR.LFNDD 1567 & .OR.LHEND(ITRAN)) ) 1568 ITRAN = ITRAN + 1 1569 LFNDA = LHTST(ITRAN,IZETAV,ITAMPB,ITAMPC,ITAMPD) 1570 LFNDB = LHTST(ITRAN,IZETAV,ITAMPC,ITAMPD,ITAMPA) 1571 LFNDC = LHTST(ITRAN,IZETAV,ITAMPD,ITAMPA,ITAMPB) 1572 LFNDD = LHTST(ITRAN,IZETAV,ITAMPA,ITAMPB,ITAMPC) 1573 END DO 1574 1575 IF (.NOT.(LFNDA.OR.LFNDB.OR.LFNDC.OR.LFNDD)) THEN 1576 IHTRAN(1,ITRAN) = IZETAV 1577 IHTRAN(2,ITRAN) = ITAMPA 1578 IHTRAN(3,ITRAN) = ITAMPB 1579 IHTRAN(4,ITRAN) = ITAMPC 1580 ITAMP = ITAMPD 1581 ELSE 1582 IF (LFNDA) ITAMP = ITAMPA 1583 IF (LFNDB) ITAMP = ITAMPB 1584 IF (LFNDC) ITAMP = ITAMPC 1585 IF (LFNDD) ITAMP = ITAMPD 1586 END IF 1587 1588 IVEC = 1 1589 DO WHILE (IHDOTS(IVEC,ITRAN).NE.ITAMP .AND. 1590 & IHDOTS(IVEC,ITRAN).NE.0 .AND. IVEC.LE.MXVEC) 1591 IVEC = IVEC + 1 1592 END DO 1593 1594 IHDOTS(IVEC,ITRAN) = ITAMP 1595 1596*---------------------------------------------------------------------* 1597 IF (IVEC.GT.MXVEC .OR. ITRAN.GT.MXTRAN) THEN 1598 WRITE (LUPRI,*) 'IVEC :',IVEC 1599 WRITE (LUPRI,*) 'ITRAN:',ITRAN 1600 WRITE (LUPRI,*) 'ITAMPA,ITAMPB,ITAMPC,ITAMPD:', 1601 & ITAMPA,ITAMPB,ITAMPC,ITAMPD 1602 IDX = 1 1603 DO WHILE (.NOT. LHEND(IDX)) 1604 WRITE(LUPRI,'(A,4I5,5X,(12I5,20X))') 'CC_SETH1111>', 1605 & (IHTRAN(I,IDX),I=1,4),(IHDOTS(I,IDX),I=1,MXVEC) 1606 IDX = IDX + 1 1607 END DO 1608 CALL FLSHFO(LUPRI) 1609 CALL QUIT('Overflow error in CC_SETH1111.') 1610 END IF 1611 1612 RETURN 1613 END 1614*---------------------------------------------------------------------* 1615* END OF SUBROUTINE CC_SETH1111 * 1616*---------------------------------------------------------------------* 1617c /* deck CC_SETG112 */ 1618*=====================================================================* 1619 SUBROUTINE CC_SETG112(IGTRAN,IGDOTS,MXTRAN,MXVEC, 1620 & IZETAV,ITAMPA,ITAMPB,ITAMPC,ITRAN,IVEC) 1621*---------------------------------------------------------------------* 1622* 1623* Purpose: maintain a list of dot products of G matrix 1624* transformations with right amplitude vectors: 1625* (Z*G*T^A*T^B) * T^C 1626* assumes that T^A and T^B belong to one list, 1627* and T^C belongs to a second list 1628* 1629* IGTRAN - list of G matrix transformations 1630* IGDOTS - list of vectors it should be dottet on 1631* 1632* MXTRAN - maximum list dimension 1633* MXVEC - maximum second dimesion for IGDOTS 1634* 1635* IZETAV - index of lagrangian multiplier vector 1636* ITAMPA - index of amplitude vector A 1637* ITAMPB - index of amplitude vector B 1638* ITAMPC - index of amplitude vector C 1639* 1640* ITRAN - index in IGTRAN list 1641* IVEC - second index in IGDOTS list 1642* 1643* Written by Christof Haettig, februar 1997. 1644* 1645*=====================================================================* 1646 IMPLICIT NONE 1647 1648#include "priunit.h" 1649 INTEGER MXVEC, MXTRAN 1650 INTEGER IGTRAN(4,MXTRAN) 1651 INTEGER IGDOTS(MXVEC,MXTRAN) 1652 1653 LOGICAL LFNDC 1654 INTEGER IZETAV, ITAMPA, ITAMPB, ITAMPC 1655 INTEGER ITRAN, IVEC 1656 INTEGER ITAMP, I, IDX 1657 1658* statement functions: 1659 LOGICAL LGTST, LGEND 1660 INTEGER IL, IA, IB 1661 LGTST(ITRAN,IL,IA,IB) = IGTRAN(1,ITRAN).EQ.IL .AND. 1662 & ( (IGTRAN(2,ITRAN).EQ.IA .AND. IGTRAN(3,ITRAN).EQ.IB) .OR. 1663 & (IGTRAN(2,ITRAN).EQ.IB .AND. IGTRAN(3,ITRAN).EQ.IA) ) 1664 LGEND(ITRAN) = ITRAN.GT.MXTRAN .OR. 1665 & (IGTRAN(1,ITRAN)+IGTRAN(2,ITRAN)+IGTRAN(3,ITRAN)).LE.0 1666 1667*---------------------------------------------------------------------* 1668* set up list of G matrix transformations 1669*---------------------------------------------------------------------* 1670 ITRAN = 1 1671 LFNDC = LGTST(ITRAN,IZETAV,ITAMPA,ITAMPB) 1672 1673 DO WHILE ( .NOT. (LFNDC.OR.LGEND(ITRAN)) ) 1674 ITRAN = ITRAN + 1 1675 LFNDC = LGTST(ITRAN,IZETAV,ITAMPA,ITAMPB) 1676 END DO 1677 1678 IF (.NOT.LFNDC) THEN 1679 IGTRAN(1,ITRAN) = IZETAV 1680 IGTRAN(2,ITRAN) = ITAMPA 1681 IGTRAN(3,ITRAN) = ITAMPB 1682 ITAMP = ITAMPC 1683 ELSE 1684 IF (LFNDC) ITAMP = ITAMPC 1685 END IF 1686 1687 IVEC = 1 1688 DO WHILE (IGDOTS(IVEC,ITRAN).NE.ITAMP .AND. 1689 & IGDOTS(IVEC,ITRAN).NE.0 .AND. IVEC.LE.MXVEC) 1690 IVEC = IVEC + 1 1691 END DO 1692 1693 IGDOTS(IVEC,ITRAN) = ITAMP 1694 1695*---------------------------------------------------------------------* 1696 IF (IVEC.GT.MXVEC .OR. ITRAN.GT.MXTRAN) THEN 1697 WRITE (LUPRI,*) 'IVEC :',IVEC 1698 WRITE (LUPRI,*) 'ITRAN:',ITRAN 1699 WRITE (LUPRI,*) 'ITAMPA,ITAMPB,ITAMPC:',ITAMPA,ITAMPB,ITAMPC 1700 IDX = 1 1701 DO WHILE (.NOT. LGEND(IDX)) 1702 WRITE(LUPRI,'(A,3I5,5X,(12I5,20X))') 'CC_SETG112>', 1703 & (IGTRAN(I,IDX),I=1,3),(IGDOTS(I,IDX),I=1,MXVEC) 1704 IDX = IDX + 1 1705 END DO 1706 CALL FLSHFO(LUPRI) 1707 CALL QUIT('Overflow error in CC_SETG112.') 1708 END IF 1709 1710 RETURN 1711 END 1712*---------------------------------------------------------------------* 1713* END OF SUBROUTINE CC_SETG112 * 1714*---------------------------------------------------------------------* 1715c /* deck CC_SETF12 */ 1716*=====================================================================* 1717 SUBROUTINE CC_SETF12(IFTRAN,IFDOTS,MXTRAN,MXVEC, 1718 & IZETAV,ITAMPA,ITAMPB,ITRAN,IVEC) 1719*---------------------------------------------------------------------* 1720* 1721* Purpose: maintain a list of dot products of F matrix 1722* transformations with right amplitude vectors 1723* (Z*F*T^A) * T^B 1724* assumes that T^A and T^B belong to different lists 1725* 1726* IFTRAN - list of F matrix transformations 1727* IFDOTS - list of vectors it should be dottet on 1728* 1729* MXTRAN - maximum list dimension 1730* MXVEC - maximum second dimension for IFDOTS 1731* 1732* IZETAV - index of lagrangian multiplier vector 1733* ITAMPA - index of amplitude vector A 1734* ITAMPB - index of amplitude vector B 1735* 1736* ITRAN - index in IFTRAN list 1737* IVEC - second index in IFDOTS list 1738* 1739* Written by Christof Haettig, februar 1997. 1740* 1741*=====================================================================* 1742 IMPLICIT NONE 1743#include "priunit.h" 1744 1745 INTEGER MXVEC, MXTRAN 1746 INTEGER IFTRAN(3,MXTRAN) 1747 INTEGER IFDOTS(MXVEC,MXTRAN) 1748 1749 LOGICAL LFNDB 1750 INTEGER IZETAV, ITAMPA, ITAMPB 1751 INTEGER ITRAN, IVEC 1752 INTEGER ITAMP, I, IDX 1753 1754* statement functions: 1755 LOGICAL LFTST, LFEND 1756 INTEGER IL, IA 1757 LFTST(ITRAN,IL,IA) = 1758 & IFTRAN(1,ITRAN).EQ.IL .AND. IFTRAN(2,ITRAN).EQ.IA 1759 LFEND(ITRAN) = ITRAN.GT.MXTRAN .OR. 1760 & (IFTRAN(1,ITRAN)+IFTRAN(2,ITRAN)).LE.0 1761 1762*---------------------------------------------------------------------* 1763* set up list of F matrix transformations 1764*---------------------------------------------------------------------* 1765 ITRAN = 1 1766 LFNDB = LFTST(ITRAN,IZETAV,ITAMPA) 1767 1768 DO WHILE ( .NOT. (LFNDB.OR.LFEND(ITRAN)) ) 1769 ITRAN = ITRAN + 1 1770 LFNDB = LFTST(ITRAN,IZETAV,ITAMPA) 1771 END DO 1772 1773 IF (.NOT.LFNDB) THEN 1774 IFTRAN(1,ITRAN) = IZETAV 1775 IFTRAN(2,ITRAN) = ITAMPA 1776 ITAMP = ITAMPB 1777 ELSE 1778 IF (LFNDB) ITAMP = ITAMPB 1779 END IF 1780 1781 IVEC = 1 1782 DO WHILE (IFDOTS(IVEC,ITRAN).NE.ITAMP .AND. 1783 & IFDOTS(IVEC,ITRAN).NE.0 .AND. IVEC.LE.MXVEC) 1784 IVEC = IVEC + 1 1785 END DO 1786 1787 IFDOTS(IVEC,ITRAN) = ITAMP 1788 1789*---------------------------------------------------------------------* 1790 IF (IVEC.GT.MXVEC .OR. ITRAN.GT.MXTRAN) THEN 1791 WRITE (LUPRI,*) 'IVEC :',IVEC 1792 WRITE (LUPRI,*) 'ITRAN:',ITRAN 1793 WRITE (LUPRI,*) 'ITAMPA,ITAMPB:',ITAMPA,ITAMPB 1794 IDX = 1 1795 DO WHILE ( .NOT. LFEND(IDX) ) 1796 WRITE(LUPRI,'(A,2I5,5X,(12I5,20X))') 'CC_SETF12>', 1797 & (IFTRAN(I,IDX),I=1,2),(IFDOTS(I,IDX),I=1,MXVEC) 1798 IDX = IDX + 1 1799 END DO 1800 CALL FLSHFO(LUPRI) 1801 CALL QUIT('Overflow error in CC_SETF12.') 1802 END IF 1803 1804 RETURN 1805 END 1806 1807*---------------------------------------------------------------------* 1808* END OF SUBROUTINE CC_SETF12 * 1809*---------------------------------------------------------------------* 1810c /* deck CC_SETAA */ 1811*=====================================================================* 1812 SUBROUTINE CC_SETAA(IAATRAN,IAADOTS,MXTRAN,MXVEC, 1813 & IZETAV,IOPER,ITAMPB,ITRAN,IVEC) 1814*---------------------------------------------------------------------* 1815* 1816* Purpose: maintain a list of dot products of A{O} matrix 1817* transformations with right amplitude vectors 1818* Z * A{O} * T^B 1819* 1820* IAATRAN - list of A{O} matrix transformations 1821* IAADOTS - list of vectors it should be dottet on 1822* 1823* MXTRAN - maximum list dimension 1824* MXVEC - maximum second dimension for IFDOTS 1825* 1826* IZETAV - index of lagrangian multiplier vector 1827* IOPER - index of operator O 1828* ITAMPB - index of amplitude vector B 1829* 1830* ITRAN - index in IAATRAN list 1831* IVEC - second index in IAADOTS list 1832* 1833* Written by Christof Haettig, Mai 2003. 1834* 1835*=====================================================================* 1836 IMPLICIT NONE 1837#include "priunit.h" 1838#include "cclists.h" 1839 1840 INTEGER MXVEC, MXTRAN 1841 INTEGER IAATRAN(MXDIM_AATRAN,MXTRAN) 1842 INTEGER IAADOTS(MXVEC,MXTRAN) 1843 1844 LOGICAL LFNDB 1845 INTEGER IZETAV, IOPER, ITAMPB 1846 INTEGER ITRAN, IVEC, I, IDX 1847 1848* statement functions: 1849 LOGICAL LAATST, LFEND 1850 INTEGER IO, IB 1851 LAATST(ITRAN,IO,IB) = 1852 & IAATRAN(1,ITRAN).EQ.IO .AND. IAATRAN(2,ITRAN).EQ.IB 1853 LFEND(ITRAN) = ITRAN.GT.MXTRAN .OR. 1854 & (IAATRAN(1,ITRAN)+IAATRAN(2,ITRAN)).LE.0 1855 1856*---------------------------------------------------------------------* 1857* set up list of A{O} matrix transformations 1858*---------------------------------------------------------------------* 1859 ITRAN = 1 1860 LFNDB = LAATST(ITRAN,IOPER,ITAMPB) 1861 1862 DO WHILE ( .NOT. (LFNDB.OR.LFEND(ITRAN)) ) 1863 ITRAN = ITRAN + 1 1864 LFNDB = LAATST(ITRAN,IOPER,ITAMPB) 1865 END DO 1866 1867 IF (.NOT.LFNDB) THEN 1868 IAATRAN(1,ITRAN) = IOPER 1869 IAATRAN(2,ITRAN) = ITAMPB 1870 END IF 1871 1872 IVEC = 1 1873 DO WHILE (IAADOTS(IVEC,ITRAN).NE.IZETAV .AND. 1874 & IAADOTS(IVEC,ITRAN).NE.0 .AND. IVEC.LE.MXVEC) 1875 IVEC = IVEC + 1 1876 END DO 1877 1878 IAADOTS(IVEC,ITRAN) = IZETAV 1879 1880*---------------------------------------------------------------------* 1881 IF (IVEC.GT.MXVEC .OR. ITRAN.GT.MXTRAN) THEN 1882 WRITE (LUPRI,*) 'IVEC :',IVEC 1883 WRITE (LUPRI,*) 'ITRAN:',ITRAN 1884 WRITE (LUPRI,*) 'IOPER,ITAMPB:',IOPER,ITAMPB 1885 IDX = 1 1886 DO WHILE ( .NOT. LFEND(IDX) ) 1887 WRITE(LUPRI,'(A,2I5,5X,(12I5,20X))') 'CC_SETAA>', 1888 & (IAATRAN(I,IDX),I=1,2),(IAADOTS(I,IDX),I=1,MXVEC) 1889 IDX = IDX + 1 1890 END DO 1891 CALL FLSHFO(LUPRI) 1892 CALL QUIT('Overflow error in CC_SETAA.') 1893 END IF 1894 1895 RETURN 1896 END 1897 1898*---------------------------------------------------------------------* 1899* END OF SUBROUTINE CC_SETAA * 1900*---------------------------------------------------------------------* 1901c /* deck CC_SETFA12 */ 1902*=====================================================================* 1903 SUBROUTINE CC_SETFA12(IFTRAN,IFDOTS,MXTRAN,MXVEC, 1904 & IZETAV,IOPER,ITAMPA,ITAMPB,ITRAN,IVEC) 1905*---------------------------------------------------------------------* 1906* 1907* Purpose: maintains a list of dot products of F{O} matrix 1908* transformations with right amplitude vectors: 1909* (Z*F{O}*T^A) * T^B 1910* assumes that T^A and T^B belong to different lists 1911* 1912* IFTRAN - list of F matrix transformations 1913* IFDOTS - list of vectors it should be dottet on 1914* 1915* MXTRAN - maximum list dimension 1916* MXVEC - maximum second dimension for IFDOTS 1917* 1918* IZETAV - index of lagrangian multiplier vector 1919* IOPER - index of property operator 1920* ITAMPA - index of amplitude vector A 1921* ITAMPB - index of amplitude vector B 1922* 1923* ITRAN - index in IFTRAN list 1924* IVEC - second index in IFDOTS list 1925* 1926* Written by Christof Haettig, februar 1997. 1927* 1928*=====================================================================* 1929 IMPLICIT NONE 1930#include "priunit.h" 1931 1932 INTEGER MXVEC, MXTRAN 1933 INTEGER IFTRAN(5,MXTRAN) 1934 INTEGER IFDOTS(MXVEC,MXTRAN) 1935 1936 LOGICAL LFNDB 1937 INTEGER IZETAV, IOPER, ITAMPA, ITAMPB 1938 INTEGER ITRAN, IVEC 1939 INTEGER ITAMP, I, IDX 1940 1941* statement functions: 1942 LOGICAL LFATST, LFAEND 1943 INTEGER IL, IA, IO 1944 LFATST(ITRAN,IL,IO,IA) = IFTRAN(1,ITRAN).EQ.IL 1945 & .AND. IFTRAN(2,ITRAN).EQ.IO .AND. IFTRAN(3,ITRAN).EQ.IA 1946 LFAEND(ITRAN) = ITRAN.GT.MXTRAN .OR. 1947 & (IFTRAN(1,ITRAN)+IFTRAN(2,ITRAN)+IFTRAN(3,ITRAN)).LE.0 1948 1949 1950*---------------------------------------------------------------------* 1951* set up list of F{A} matrix transformations 1952*---------------------------------------------------------------------* 1953 ITRAN = 1 1954 LFNDB = LFATST(ITRAN,IZETAV,IOPER,ITAMPA) 1955 1956 DO WHILE ( .NOT. (LFNDB.OR.LFAEND(ITRAN))) 1957 ITRAN = ITRAN + 1 1958 LFNDB = LFATST(ITRAN,IZETAV,IOPER,ITAMPA) 1959 END DO 1960 1961 IF (.NOT.LFNDB) THEN 1962 IFTRAN(1,ITRAN) = IZETAV 1963 IFTRAN(2,ITRAN) = IOPER 1964 IFTRAN(3,ITRAN) = ITAMPA 1965 IFTRAN(4,ITRAN) = 0 1966 IFTRAN(5,ITRAN) = 0 1967 ITAMP = ITAMPB 1968 ELSE 1969 IF (LFNDB) ITAMP = ITAMPB 1970 END IF 1971 1972 IVEC = 1 1973 DO WHILE (IFDOTS(IVEC,ITRAN).NE.ITAMP .AND. 1974 & IFDOTS(IVEC,ITRAN).NE.0 .AND. IVEC.LE.MXVEC) 1975 IVEC = IVEC + 1 1976 END DO 1977 1978 IFDOTS(IVEC,ITRAN) = ITAMP 1979 1980C WRITE (LUPRI,*) 'CC_SETFA12>',IZETAV,IOPER,ITAMPA,ITAMPB,ITRAN,IVEC 1981*---------------------------------------------------------------------* 1982 IF (IVEC.GT.MXVEC .OR. ITRAN.GT.MXTRAN) THEN 1983 WRITE (LUPRI,*) 'IVEC :',IVEC 1984 WRITE (LUPRI,*) 'ITRAN:',ITRAN 1985 WRITE (LUPRI,*) 'ITAMPA,ITAMPB:',ITAMPA,ITAMPB 1986 IDX = 1 1987 DO WHILE ( .NOT. LFAEND(IDX) ) 1988 WRITE(LUPRI,'(A,5I5,5X,(12I5,20X))') 'CC_SETFA12>', 1989 & (IFTRAN(I,IDX),I=1,5),(IFDOTS(I,IDX),I=1,MXVEC) 1990 IDX = IDX + 1 1991 END DO 1992 CALL FLSHFO(LUPRI) 1993 CALL QUIT('Overflow error in CC_SETFA12.') 1994 END IF 1995 1996 RETURN 1997 END 1998 1999*---------------------------------------------------------------------* 2000* END OF SUBROUTINE CC_SETFA12 * 2001*---------------------------------------------------------------------* 2002c /* deck CC_SETDOT */ 2003*=====================================================================* 2004 SUBROUTINE CC_SETDOT(IDTRAN,IDDOTS,MXTRAN,MXVEC, 2005 & ICHIA,ITAMPB,ITRAN,IVEC ) 2006*---------------------------------------------------------------------* 2007* 2008* Purpose: maintain a list of dot products of 'ICHIA' vectors 2009* times 'ITAMPB' vectors 2010* X^A * T^B 2011* assumes that X^A and T^B belong to different lists 2012* 2013* IDTRAN - list of ICHIA vectors 2014* IDDOTS - list of vectors they should be dotted on 2015* 2016* MXTRAN - maximum list dimension 2017* MXVEC - maximum second dimension for IDDOTS 2018* 2019* ICHIA - index of ICHIA vector 2020* ITAMPB - index of ITAMPB vector 2021* 2022* ITRAN - index in IDTRAN list 2023* IVEC - second index in IDDOTS list 2024* 2025* Written by Christof Haettig, februar 1997. 2026* 2027*=====================================================================* 2028 IMPLICIT NONE 2029#include "priunit.h" 2030 2031 INTEGER MXVEC, MXTRAN 2032 INTEGER IDTRAN(MXTRAN) 2033 INTEGER IDDOTS(MXVEC,MXTRAN) 2034 2035 LOGICAL LFNDB 2036 INTEGER ICHIA, ITAMPB 2037 INTEGER ITRAN, IVEC 2038 INTEGER ITAMP, I, IDX 2039 2040* statement functions: 2041 LOGICAL LFTST, LFEND 2042 INTEGER IA 2043 LFTST(ITRAN,IA) = IDTRAN(ITRAN).EQ.IA 2044 LFEND(ITRAN) = ITRAN.GT.MXTRAN .OR. IDTRAN(ITRAN).LE.0 2045 2046*---------------------------------------------------------------------* 2047* set up list of ICHIA vectors 2048*---------------------------------------------------------------------* 2049 ITRAN = 1 2050 LFNDB = LFTST(ITRAN,ICHIA) 2051 2052 DO WHILE ( .NOT. (LFNDB.OR.LFEND(ITRAN)) ) 2053 ITRAN = ITRAN + 1 2054 LFNDB = LFTST(ITRAN,ICHIA) 2055 END DO 2056 2057 IF (.NOT.LFNDB) THEN 2058 IDTRAN(ITRAN) = ICHIA 2059 ITAMP = ITAMPB 2060 ELSE 2061 IF (LFNDB) ITAMP = ITAMPB 2062 END IF 2063 2064 IVEC = 1 2065 DO WHILE (IDDOTS(IVEC,ITRAN).NE.ITAMP .AND. 2066 & IDDOTS(IVEC,ITRAN).NE.0 .AND. IVEC.LE.MXVEC) 2067 IVEC = IVEC + 1 2068 END DO 2069 2070 IDDOTS(IVEC,ITRAN) = ITAMP 2071 2072*---------------------------------------------------------------------* 2073 IF (IVEC.GT.MXVEC .OR. ITRAN.GT.MXTRAN) THEN 2074 WRITE (LUPRI,*) 'IVEC, MXVEC :',IVEC,MXVEC 2075 WRITE (LUPRI,*) 'ITRAN,MXTRAN:',ITRAN,MXTRAN 2076 WRITE (LUPRI,*) 'ICHIA,ITAMPB:',ICHIA,ITAMPB 2077 IDX = 1 2078 DO WHILE ( .NOT. LFEND(IDX) ) 2079 WRITE(LUPRI,'(A,I5,5X,(12I5,20X))') 'CC_SETDOT>', 2080 & IDTRAN(IDX),(IDDOTS(I,IDX),I=1,MXVEC) 2081 IDX = IDX + 1 2082 END DO 2083 CALL FLSHFO(LUPRI) 2084 CALL QUIT('Overflow error in CC_SETDOT.') 2085 END IF 2086 2087 RETURN 2088 END 2089 2090*---------------------------------------------------------------------* 2091* END OF SUBROUTINE CC_SETDOT * 2092*---------------------------------------------------------------------* 2093