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 /* Deck r12qv */ 19 SUBROUTINE R12QV(FROS,IFEL,QQ,S0,X1,Y1,Z1,X2,Y2,Z2,UU,ZZ, 20 * WORK,LWORK,NBAST,NORBT,NOCCT, 21 * NVIRT,FEL) 22C 23C This subroutine computes the integrals (ak|r12**2|jl). 24C 25#include "implicit.h" 26#include "priunit.h" 27#include "ccfro.h" 28 DIMENSION QQ(*),X1(*),Y1(*),Z1(*),X2(*),Y2(*),Z2(*), 29 * UU(*),ZZ(*),WORK(LWORK),S0(*) 30 LOGICAL FROS,FOUND,FEL,IFEL 31 KEND = 1 + NBAST*NBAST 32 LWRK = LWORK - KEND 33 CALL RDPROP('CM000000',WORK,FOUND) 34 CALL UTHZ(WORK,UU,ZZ,S0,WORK(KEND),LWRK,NBAST,NORBT) 35 CALL RDPROP('CM010000',WORK,FOUND) 36 CALL UTHZ(WORK,UU,ZZ,X1,WORK(KEND),LWRK,NBAST,NORBT) 37 CALL RDPROP('CM000100',WORK,FOUND) 38 CALL UTHZ(WORK,UU,ZZ,Y1,WORK(KEND),LWRK,NBAST,NORBT) 39 CALL RDPROP('CM000001',WORK,FOUND) 40 CALL UTHZ(WORK,UU,ZZ,Z1,WORK(KEND),LWRK,NBAST,NORBT) 41 CALL RDPROP('CM020000',WORK,FOUND) 42 CALL UTHZ(WORK,UU,ZZ,X2,WORK(KEND),LWRK,NBAST,NORBT) 43 CALL RDPROP('CM000200',WORK,FOUND) 44 CALL UTHZ(WORK,UU,ZZ,Y2,WORK(KEND),LWRK,NBAST,NORBT) 45 CALL RDPROP('CM000002',WORK,FOUND) 46 CALL UTHZ(WORK,UU,ZZ,Z2,WORK(KEND),LWRK,NBAST,NORBT) 47 IF (FROS .EQV. .TRUE.) THEN 48 IF (FEL) THEN 49 CALL MAKEF(S0,X1,Y1,Z1,X2,Y2,Z2,QQ,NOCCT,NORBT,NVIRT) 50 ELSEIF (IFEL) THEN 51 CALL MAKF(S0,X1,Y1,Z1,X2,Y2,Z2,QQ,NOCCT,NORBT,NVIRT) 52 ELSE 53 CALL MAKEQF(S0,X1,Y1,Z1,X2,Y2,Z2,QQ,NOCCT,NORBT,NVIRT) 54 ENDIF 55 ELSE 56 IF (IFEL .AND. FEL) THEN 57 CALL MAKEQM1(S0,X1,Y1,Z1,X2,Y2,Z2,QQ,NOCCT,NORBT) 58 ELSEIF (FEL) THEN 59 CALL MAKEV(S0,X1,Y1,Z1,X2,Y2,Z2,QQ,NOCCT,NORBT,NVIRT) 60 ELSEIF (IFEL) THEN 61 CALL MAKV(S0,X1,Y1,Z1,X2,Y2,Z2,QQ,NOCCT,NORBT,NVIRT) 62 ELSE 63 CALL MAKEQV(S0,X1,Y1,Z1,X2,Y2,Z2,QQ,NOCCT,NORBT,NVIRT) 64 ENDIF 65 ENDIF 66 RETURN 67 END 68c----------------------------------------------------------------------- 69C /* Deck makeqv */ 70 SUBROUTINE MAKEQV(S0,X1,Y1,Z1,X2,Y2,Z2,QQ,NOCCT,NORBT,NVIRT) 71C 72C This subroutine computes the integrals (ak|r12**2|jl). 73C 74#include "implicit.h" 75 PARAMETER (D2 = 2D0) 76#include "priunit.h" 77 DIMENSION X1(NORBT,NORBT,2),Y1(NORBT,NORBT,2), 78 * Z1(NORBT,NORBT,2),X2(NORBT,NORBT,2), 79 * Y2(NORBT,NORBT,2),Z2(NORBT,NORBT,2), 80 * S0(NORBT,NORBT,2), 81 * QQ(NVIRT,NOCCT,NOCCT,NOCCT) 82 DO 100 I = 1, NVIRT 83 DO 200 J = 1, NOCCT 84 DO 300 K = 1, NOCCT 85 DO 400 L = 1,NOCCT 86 QQ(I,J,K,L) = 87 * (X2(I+NOCCT,L,2) + Y2(I+NOCCT,L,2) + Z2(I+NOCCT,L,2)) 88 * * S0(J,K,1) + 89 * (X2(J,K,1) + Y2(J,K,1) + 90 * Z2(J,K,1)) * S0(I+NOCCT,L,2) - 91 * D2 * ( X1(I+NOCCT,L,2) * X1(J,K,1) + 92 * Y1(I+NOCCT,L,2) * Y1(J,K,1) + 93 * Z1(I+NOCCT,L,2) * Z1(J,K,1) ) 94 400 CONTINUE 95 300 CONTINUE 96 200 CONTINUE 97 100 CONTINUE 98 RETURN 99 END 100*--------------------------------------------------------------------------- 101c----------------------------------------------------------------------- 102C /* Deck makeqf */ 103 SUBROUTINE MAKEQF(S0,X1,Y1,Z1,X2,Y2,Z2,QQ,NOCCT,NORBT,NVIRT) 104C 105C This subroutine computes the integrals (ak|r12**2|jl). 106C 107#include "implicit.h" 108 PARAMETER (D2 = 2D0) 109#include "priunit.h" 110 DIMENSION X1(NORBT,NORBT,2),Y1(NORBT,NORBT,2), 111 * Z1(NORBT,NORBT,2),X2(NORBT,NORBT,2), 112 * Y2(NORBT,NORBT,2),Z2(NORBT,NORBT,2), 113 * S0(NORBT,NORBT,2), 114 * QQ(NVIRT,NOCCT,NOCCT,NOCCT) 115 DO 100 I = 1, NVIRT 116 DO 200 J = 1, NOCCT 117 DO 300 K = 1, NOCCT 118 DO 400 L = 1,NOCCT 119 QQ(I,J,K,L) = 120 * (X2(I,L+NVIRT,2) + Y2(I,L+NVIRT,2) + Z2(I,L+NVIRT,2)) 121 * * S0(J+NVIRT,K+NVIRT,1) + 122 * (X2(J+NVIRT,K+NVIRT,1) + Y2(J+NVIRT,K+NVIRT,1) + 123 * Z2(J+NVIRT,K+NVIRT,1)) * S0(I,L+NVIRT,2) - 124 * D2 * ( X1(I,L+NVIRT,2) * X1(J+NVIRT,K+NVIRT,1) + 125 * Y1(I,L+NVIRT,2) * Y1(J+NVIRT,K+NVIRT,1) + 126 * Z1(I,L+NVIRT,2) * Z1(J+NVIRT,K+NVIRT,1) ) 127 400 CONTINUE 128 300 CONTINUE 129 200 CONTINUE 130 100 CONTINUE 131 RETURN 132 END 133*--------------------------------------------------------------------------- 134 135c----------------------------------------------------------------------- 136C /* Deck makeqvi */ 137 SUBROUTINE MAKEQVI(S0,X1,Y1,Z1,X2,Y2,Z2,QQ,NOCCT,NORBT,NVIRT) 138C 139C This subroutine computes the integrals (ak|r12**2|jl). 140C 141#include "implicit.h" 142 PARAMETER (D2 = 2D0) 143#include "priunit.h" 144 DIMENSION X1(NORBT,NORBT,2),Y1(NORBT,NORBT,2), 145 * Z1(NORBT,NORBT,2),X2(NORBT,NORBT,2), 146 * Y2(NORBT,NORBT,2),Z2(NORBT,NORBT,2), 147 * S0(NORBT,NORBT,2), 148 * QQ(NVIRT,NOCCT,NOCCT,NOCCT) 149 DO 100 I = 1, NVIRT 150 DO 200 J = 2, NOCCT 151 DO 300 K = 2, NOCCT 152 DO 400 L = 2,NOCCT 153 QQ(I,J,K,L) = 154 * (X2(I+NOCCT+1,L,2) + Y2(I+NOCCT+1,L,2)+ Z2(I+NOCCT+1,L,2)) 155 * * S0(J,K,1) + 156 * (X2(J,K,1) + Y2(J,K,1) + 157 * Z2(J,K,1)) * S0(I+NOCCT+1,L,2) - 158 * D2 * ( X1(I+NOCCT+1,L,2) * X1(J,K,1) + 159 * Y1(I+NOCCT+1,L,2) * Y1(J,K,1) + 160 * Z1(I+NOCCT+1,L,2) * Z1(J,K,1) ) 161 400 CONTINUE 162 300 CONTINUE 163 200 CONTINUE 164 100 CONTINUE 165 RETURN 166 END 167*--------------------------------------------------------------------------- 168C /* Deck makev */ 169 SUBROUTINE MAKEV(S0,X1,Y1,Z1,X2,Y2,Z2,QQ,NOCCT,NORBT,NVIRT) 170C 171C This subroutine computes the integrals (ak|r12**2|jl). 172C 173#include "implicit.h" 174 PARAMETER (D2 = 2D0) 175#include "priunit.h" 176 DIMENSION X1(NORBT,NORBT,2),Y1(NORBT,NORBT,2), 177 * Z1(NORBT,NORBT,2),X2(NORBT,NORBT,2), 178 * Y2(NORBT,NORBT,2),Z2(NORBT,NORBT,2), 179 * S0(NORBT,NORBT,2), 180 * QQ(NVIRT,NOCCT,NOCCT,NOCCT) 181 DO I = 1,NOCCT 182 DO J = 1,NVIRT 183 DO K = 1,NOCCT 184 DO L = 1,NOCCT 185 QQ(J,I,L,K) = 186 * (X2(I,L,2) + Y2(I,L,2) + Z2(I,L,2)) 187 * * S0(J+NOCCT,K,1) + 188 * (X2(J+NOCCT,K,1) + Y2(J+NOCCT,K,1) + 189 * Z2(J+NOCCT,K,1)) * S0(I,L,2) - 190 * D2 * ( X1(I,L,2) * X1(J+NOCCT,K,1) + 191 * Y1(I,L,2) * Y1(J+NOCCT,K,1) + 192 * Z1(I,L,2) * Z1(J+NOCCT,K,1) ) 193 ENDDO 194 ENDDO 195 ENDDO 196 ENDDO 197 RETURN 198 END 199*--------------------------------------------------------------------------- 200*--------------------------------------------------------------------------- 201C /* Deck makef */ 202 SUBROUTINE MAKEF(S0,X1,Y1,Z1,X2,Y2,Z2,QQ,NOCCT,NORBT,NVIRT) 203C 204C This subroutine computes the integrals (ak|r12**2|jl). 205C 206#include "implicit.h" 207 PARAMETER (D2 = 2D0) 208#include "priunit.h" 209 DIMENSION X1(NORBT,NORBT,2),Y1(NORBT,NORBT,2), 210 * Z1(NORBT,NORBT,2),X2(NORBT,NORBT,2), 211 * Y2(NORBT,NORBT,2),Z2(NORBT,NORBT,2), 212 * S0(NORBT,NORBT,2), 213 * QQ(NVIRT,NOCCT,NOCCT,NOCCT) 214 DO I = 1,NOCCT 215 DO J = 1,NVIRT 216 DO K = 1,NOCCT 217 DO L = 1,NOCCT 218 QQ(J,I,L,K) = 219 * (X2(I+NVIRT,L+NVIRT,2) + Y2(I+NVIRT,L+NVIRT,2) + 220 & Z2(I+NVIRT,L+NVIRT,2)) 221 * * S0(J,K+NVIRT,1) + 222 * (X2(J,K+NVIRT,1) + Y2(J,K+NVIRT,1) + 223 * Z2(J,K+NVIRT,1)) * S0(I+NVIRT,L+NVIRT,2) - 224 * D2 * ( X1(I+NVIRT,L+NVIRT,2) * X1(J,K+NVIRT,1) + 225 * Y1(I+NVIRT,L+NVIRT,2) * Y1(J,K+NVIRT,1) + 226 * Z1(I+NVIRT,L+NVIRT,2) * Z1(J,K+NVIRT,1) ) 227 ENDDO 228 ENDDO 229 ENDDO 230 ENDDO 231 RETURN 232 END 233*--------------------------------------------------------------------------- 234 235*--------------------------------------------------------------------------- 236C /* Deck makv */ 237 SUBROUTINE MAKV(S0,X1,Y1,Z1,X2,Y2,Z2,QQ,NOCCT,NORBT,NVIRT) 238C 239C This subroutine computes the integrals (ak|r12**2|jl). 240C 241#include "implicit.h" 242 PARAMETER (D2 = 2D0) 243#include "priunit.h" 244 DIMENSION X1(NORBT,NORBT,2),Y1(NORBT,NORBT,2), 245 * Z1(NORBT,NORBT,2),X2(NORBT,NORBT,2), 246 * Y2(NORBT,NORBT,2),Z2(NORBT,NORBT,2), 247 * S0(NORBT,NORBT,2), 248 * QQ(NVIRT,NOCCT,NOCCT,NOCCT) 249 DO I = 1,NOCCT 250 DO J = 1,NOCCT 251 DO K = 1,NVIRT 252 DO L = 1,NOCCT 253 QQ(K,L,J,I) = 254 * (X2(I,K+NOCCT,2) + Y2(I,K+NOCCT,2) + Z2(I,K+NOCCT,2)) 255 * * S0(J,L,1) + 256 * (X2(J,L,1) + Y2(J,L,1) + 257 * Z2(J,L,1)) * S0(I,K+NOCCT,2) - 258 * D2 * ( X1(I,K+NOCCT,2) * X1(J,L,1) + 259 * Y1(I,K+NOCCT,2) * Y1(J,L,1) + 260 * Z1(I,K+NOCCT,2) * Z1(J,L,1) ) 261 ENDDO 262 ENDDO 263 ENDDO 264 ENDDO 265 266 RETURN 267 END 268*------------------------------------------------------------------- 269*=====================================================================* 270*--------------------------------------------------------------------------- 271C /* Deck makf */ 272 SUBROUTINE MAKF(S0,X1,Y1,Z1,X2,Y2,Z2,QQ,NOCCT,NORBT,NVIRT) 273C 274C This subroutine computes the integrals (ak|r12**2|jl). 275C 276#include "implicit.h" 277 PARAMETER (D2 = 2D0) 278#include "priunit.h" 279 DIMENSION X1(NORBT,NORBT,2),Y1(NORBT,NORBT,2), 280 * Z1(NORBT,NORBT,2),X2(NORBT,NORBT,2), 281 * Y2(NORBT,NORBT,2),Z2(NORBT,NORBT,2), 282 * S0(NORBT,NORBT,2), 283 * QQ(NVIRT,NOCCT,NOCCT,NOCCT) 284 DO I = 1,NOCCT 285 DO J = 1,NOCCT 286 DO K = 1,NVIRT 287 DO L = 1,NOCCT 288 QQ(K,L,J,I) = 289 * (X2(I+NVIRT,K,2) + Y2(I+NVIRT,K,2) + Z2(I+NVIRT,K,2)) 290 * * S0(J+NVIRT,L+NVIRT,1) + 291 * (X2(J+NVIRT,L+NVIRT,1) + Y2(J+NVIRT,L+NVIRT,1) + 292 * Z2(J+NVIRT,L+NVIRT,1)) * S0(I+NVIRT,K,2) - 293 * D2 * ( X1(I+NVIRT,K,2) * X1(J+NVIRT,L+NVIRT,1) + 294 * Y1(I+NVIRT,K,2) * Y1(J+NVIRT,L+NVIRT,1) + 295 * Z1(I+NVIRT,K,2) * Z1(J+NVIRT,L+NVIRT,1) ) 296 ENDDO 297 ENDDO 298 ENDDO 299 ENDDO 300 301 RETURN 302 END 303*------------------------------------------------------------------- 304*=====================================================================* 305 306 subroutine cc_r12xsort(sajkl,blajkl,nvir0) 307c--------------------------------------------------------------------- 308 309 implicit none 310#include "ccorb.h" 311#include "ccsdsym.h" 312#include "r12int.h" 313#include "ccfro.h" 314 integer isymkl,isymij,isyml,isymk,isymaj 315 integer isymj,isyma,idxkl,isym,nvir0(8) 316 integer kt,idx,nvir0t,koffj,koffa,koffk,koffl 317 integer icoun1,kl,aj,ivir0(8),ajkl,nrhfst 318#if defined (SYS_CRAY) 319 real blajkl(*),sajkl(*) 320#else 321 double precision blajkl(*),sajkl(*) 322#endif 323c 324 call qenter('cc_r12xsort') 325c 326 nvir0t = 0 327 nrhfst = 0 328 do isym = 1, nsym 329 nvir0t = nvir0t + nvir0(isym) 330 nrhfst = nrhfst + nrhfs(isym) 331 end do 332 333 icoun1 = 0 334 do isym = 1,nsym 335 ivir0(isym) = icoun1 336 icoun1 = icoun1 + nvir0(isym) 337 enddo 338 339 340 idx = 0 341 do isymkl = 1, nsym 342 isymaj = isymkl 343 isymij = isymkl 344 do isyml =1, nsym 345 isymk = muld2h(isymkl,isyml) 346 do k = 1, nrhfs(isymk) 347 koffk = irhfs(isymk)+k 348 do l = 1, nrhfs(isyml) 349 koffl = irhfs(isyml)+l 350 idxkl=imatij(isymk,isyml)+nrhfs(isymk)*(l-1)+k 351 do isyma =1, nsym 352 isymj = muld2h(isymaj,isyma) 353 do j = 1, nrhfs(isymj) 354 koffj = irhfs(isymj)+j 355 do a = 1, nvir0(isyma) 356 idx = idx + 1 357 koffa = ivir0(isyma)+a 358 kl = (koffk-1)*nrhfst + koffl 359 aj = (koffj-1)*nvir0t + koffa 360 ajkl = aj +(kl-1)*nvir0t*nrhfst 361 blajkl(idx) = sajkl(ajkl) 362 enddo 363 enddo 364 enddo 365 enddo 366 enddo 367 enddo 368 enddo 369 370 call qexit('cc_r12xsort') 371 end 372 373*--------------------------------------------------------------------------- 374*=====================================================================* 375 subroutine cc_r12xsort1(sajkl,blajkl) 376c--------------------------------------------------------------------- 377 378 implicit none 379#include "ccorb.h" 380#include "ccsdsym.h" 381#include "r12int.h" 382#include "ccfro.h" 383 integer isymkl,isymij,isyml,isymk,isymaj 384 integer isymj,isyma,idxkl,isym,nvir0(8) 385 integer kt,idx,nvir0t,koffj,koffa,koffk,koffl 386 integer icoun1,kl,aj,ivir0(8),ajkl,nrhfst 387#if defined (SYS_CRAY) 388 real blajkl(*),sajkl(*) 389#else 390 double precision blajkl(*),sajkl(*) 391#endif 392c 393 call qenter('cc_r12xsort1') 394c 395 nvir0t = 0 396 nrhfst = 0 397 do isym = 1, nsym 398 nvir0(isym) = norb1(isym) - nrhfs(isym) 399 nvir0t = nvir0t + nvir0(isym) 400 nrhfst = nrhfst + nrhfs(isym) 401 end do 402 403 icoun1 = 0 404 do isym = 1,nsym 405 ivir0(isym) = icoun1 406 icoun1 = icoun1 + nvir0(isym) 407 enddo 408 409 410 idx = 0 411 do isymkl = 1, nsym 412 isymaj = isymkl 413 isymij = isymkl 414 do isyml =1, nsym 415 isymk = muld2h(isymkl,isyml) 416 do k = 1, nrhfs(isymk) 417 koffk = irhfs(isymk)+k 418 do l = 1, nrhfs(isyml) 419 koffl = irhfs(isyml)+l 420 idxkl=imatij(isymk,isyml)+nrhf(isymk)*(l-1)+k 421 do isyma =1, nsym 422 isymj = muld2h(isymaj,isyma) 423 do j = 1, nrhfs(isymj) 424 koffj = irhfs(isymj)+j 425 do a = 1, nrhfs(isyma) 426 koffa = irhfs(isyma)+a 427 idx = idx + 1 428 kl = (koffl-1)*nrhfst + koffk 429 aj = (koffj-1)*nrhfst + koffa 430 ajkl = aj +(kl-1)*nrhfst*nrhfst 431 blajkl(idx) = sajkl(ajkl) 432 enddo 433 enddo 434 enddo 435 enddo 436 enddo 437 enddo 438 enddo 439 440 call qexit('cc_r12xsort1') 441 end 442 443*--------------------------------------------------------------------------- 444*=====================================================================* 445C /* Deck utz */ 446 SUBROUTINE UTZ(AA,UU,ZZ,BB,WORK,LWORK,NBAST,NOCCT) 447C 448C B(1) = Z(Transpose) * A * Z 449C B(2) = A * Z 450C 451C On input, AA is the upper triangle of the symmetric 452C matrix A. B is returned through the array BB as 453C square matrix. 454C 455c Modified UTHZ 456#include "implicit.h" 457#include "priunit.h" 458 DIMENSION AA(*),UU(NBAST,NOCCT),ZZ(NBAST,NOCCT), 459 * WORK(NBAST,NOCCT),BB(NOCCT,NOCCT,2) 460 INDEX(I,J) = MAX(I,J)*(MAX(I,J) - 3)/2 + I + J 461 IF (NBAST*NOCCT .GT. LWORK) 462 * CALL STOPIT('UTZ',' ',LWORK,NBAST*NOCCT) 463 CALL DZERO(WORK,NBAST*NOCCT) 464 DO K = 1, NBAST 465 DO J = 1, NOCCT 466 ZZKJ = ZZ(K,J) 467 DO I = 1, NBAST 468 IK = INDEX(I,K) 469 WORK(I,J) = WORK(I,J) + AA(IK) * ZZKJ 470 ENDDO 471 ENDDO 472 ENDDO 473 DO I = 1, NOCCT 474 DO J = 1, NOCCT 475 BB(I,J,1) = DDOT(NBAST,ZZ(1,I),1,WORK(1,J),1) 476 ENDDO 477 ENDDO 478 DO I = 1, NBAST 479 DO J = 1, NOCCT 480 BB(I,J,2) = WORK(I,J) 481 ENDDO 482 ENDDO 483 RETURN 484 END 485*=====================================================================* 486c--------------------------------------------------------------------------- 487c-------------------------------------------------------------------------- 488C /* Deck makeqm1 */ 489 SUBROUTINE MAKEQM1(S0,X1,Y1,Z1,X2,Y2,Z2,QQ,NOCCT,NORBT) 490C 491C This subroutine computes the integrals (i'k|r12**2|jl). 492C 493C Written by Wim Klopper (University of Karlsruhe, 31 October 2002). 494C 495#include "implicit.h" 496 PARAMETER (D2 = 2D0) 497#include "priunit.h" 498 DIMENSION X1(NORBT,NORBT,2),Y1(NORBT,NORBT,2), 499 * Z1(NORBT,NORBT,2),X2(NORBT,NORBT,2), 500 * Y2(NORBT,NORBT,2),Z2(NORBT,NORBT,2), 501 * S0(NORBT,NORBT,2), 502 * QQ(NORBT,NOCCT,NOCCT,NOCCT) 503 DO 100 I = 1,NORBT 504 DO 200 J = 1, NOCCT 505 DO 300 K = 1, NOCCT 506 DO 400 L = 1,NOCCT 507 QQ(I,J,K,L) = 508 * (X2(I,L,2) + Y2(I,L,2) + Z2(I,L,2)) 509 * * S0(J,K,1) + 510 * (X2(J,K,1) + Y2(J,K,1) + 511 * Z2(J,K,1)) * S0(I,L,2) - 512 * D2 * ( X1(I,L,2) * X1(J,K,1) + 513 * Y1(I,L,2) * Y1(J,K,1) + 514 * Z1(I,L,2) * Z1(J,K,1) ) 515 400 CONTINUE 516 300 CONTINUE 517 200 CONTINUE 518 100 CONTINUE 519 RETURN 520 END 521c--------------------------------------------------------------------------- 522*=====================================================================* 523*=====================================================================* 524 subroutine cc_r12xsort2(sajkl,blajkl,nvir0) 525c--------------------------------------------------------------------- 526 527 implicit none 528#include "ccorb.h" 529#include "ccsdsym.h" 530#include "r12int.h" 531 integer isymkl,isymij,isyml,isymk,isymaj 532 integer isymj,isyma,idxkl,isym 533 integer nvir0(8),kt,idx,koffj,koffa,koffk,koffl 534 integer nvir0t,icoun1,kl,aj,iorb1(8),ajkl,ivir0(8) 535#if defined (SYS_CRAY) 536 real blajkl(*),sajkl(*) 537#else 538 double precision blajkl(*),sajkl(*) 539#endif 540c 541 call qenter('cc_r12xsort2') 542 543c 544 nvir0t = 0 545 do isym = 1, nsym 546 nvir0t = nvir0t + nvir0(isym) 547 end do 548 549 icoun1 = 0 550 do isym = 1,nsym 551 ivir0(isym) = icoun1 552 icoun1 = icoun1 + nvir0(isym) 553 enddo 554 555 556 idx = 0 557 do isymkl = 1, nsym 558 isymaj = isymkl 559 isymij = isymkl 560 do isyml =1, nsym 561 isymk = muld2h(isymkl,isyml) 562 do k = 1, nrhf(isymk) 563 koffk = irhf(isymk)+k 564 do l = 1, nrhf(isyml) 565 koffl = irhf(isyml)+l 566 idxkl=imatij(isymk,isyml)+nrhfs(isymk)*(l-1)+k 567 do isyma =1, nsym 568 isymj = muld2h(isymaj,isyma) 569 do j = 1, nrhf(isymj) 570 koffj = irhf(isymj)+j 571 do a = 1, nvir0(isyma) 572 idx = idx + 1 573 koffa = ivir0(isyma)+a 574 kl = (koffk-1)*nrhft + koffl 575 aj = (koffj-1)*nvir0t + koffa 576 ajkl = aj +(kl-1)*nvir0t*nrhft 577 blajkl(idx) = sajkl(ajkl) 578 enddo 579 enddo 580 enddo 581 enddo 582 enddo 583 enddo 584 enddo 585 586 587c 588 589 call qexit('cc_r12xsort2') 590 end 591 592*--------------------------------------------------------------------------- 593*------------------------------------------------------------------- 594*=====================================================================* 595 subroutine cc_r12xsort3(sajkl,blajkl,nvir0) 596c--------------------------------------------------------------------- 597 598 implicit none 599#include "ccorb.h" 600#include "ccsdsym.h" 601#include "r12int.h" 602#include "ccfro.h" 603 integer isymkl,isymij,isyml,isymk,isymaj 604 integer isymj,isyma,idxkl,isym,nvir0(8) 605 integer kt,idx,nvir0t,koffj,koffa,koffk,koffl 606 integer icoun1,kl,aj,ivir0(8),ajkl 607#if defined (SYS_CRAY) 608 real blajkl(*),sajkl(*) 609#else 610 double precision blajkl(*),sajkl(*) 611#endif 612c 613 call qenter('cc_r12xsort3') 614c 615 nvir0t = 0 616 do isym = 1, nsym 617 nvir0t = nvir0t + nvir0(isym) 618 end do 619 620 icoun1 = 0 621 do isym = 1,nsym 622 ivir0(isym) = icoun1 623 icoun1 = icoun1 + nvir0(isym) 624 enddo 625 626 627 idx = 0 628 do isymkl = 1, nsym 629 isymaj = isymkl 630 isymij = isymkl 631 do isyml =1, nsym 632 isymk = muld2h(isymkl,isyml) 633 do k = 1, nrhf(isymk) 634 koffk = irhf(isymk)+k 635 do l = 1, nrhf(isyml) 636 koffl = irhf(isyml)+l 637 idxkl=imatij(isymk,isyml)+nrhf(isymk)*(l-1)+k 638 do isyma =1, nsym 639 isymj = muld2h(isymaj,isyma) 640 do j = 1, nrhf(isymj) 641 koffj = irhf(isymj)+j 642 do a = 1, nvir0(isyma) 643 idx = idx + 1 644 koffa = ivir0(isyma)+a 645 kl = (koffk-1)*nrhft + koffj 646 aj = (koffl-1)*nvir0t + koffa 647 ajkl = aj +(kl-1)*nvir0t*nrhft 648 blajkl(idx) = sajkl(ajkl) 649 enddo 650 enddo 651 enddo 652 enddo 653 enddo 654 enddo 655 enddo 656 657 call qexit('cc_r12xsort3') 658 end 659 660*=====================================================================* 661 subroutine cc_r12xsort4(sajkl,blajkl) 662c--------------------------------------------------------------------- 663 664 implicit none 665#include "ccorb.h" 666#include "ccsdsym.h" 667#include "r12int.h" 668#include "ccfro.h" 669 integer isymkl,isymij,isyml,isymk,isymaj 670 integer irhffr(8),isymj,isyma,idxkl,isym,nvir0(8) 671 integer kt,idx,nvir0t,koffj,koffa,koffk,koffl 672 integer nrhffrt,nrhfst,icoun1,kl,aj,ivir0(8),ajkl 673#if defined (SYS_CRAY) 674 real blajkl(*),sajkl(*) 675#else 676 double precision blajkl(*),sajkl(*) 677#endif 678c 679 call qenter('cc_r12xsort4') 680c 681 nvir0t = 0 682 nrhfst= 0 683 nrhffrt= 0 684 do isym = 1, nsym 685 nvir0(isym) = norb1(isym) - nrhfs(isym) 686 nvir0t = nvir0t + nvir0(isym) 687 nrhfst = nrhfst + nrhfs(isym) 688 nrhffrt = nrhffrt + nrhffr(isym) 689 end do 690 691 icoun1 = 0 692 do isym = 1,nsym 693 irhffr(isym) = icoun1 694 icoun1 = icoun1 + nrhffr(isym) 695 enddo 696 697 698 idx = 0 699 do isymkl = 1, nsym 700 isymaj = isymkl 701 isymij = isymkl 702 do isyml =1, nsym 703 isymk = muld2h(isymkl,isyml) 704 do k = 1, nrhfs(isymk) 705 koffk = irhfs(isymk)+k 706 do l = 1, nrhfs(isyml) 707 koffl = irhfs(isyml)+l 708 idxkl=imatij(isymk,isyml)+nrhf(isymk)*(l-1)+k 709 do isyma =1, nsym 710 isymj = muld2h(isymaj,isyma) 711 do j = 1, nrhfs(isymj) 712 koffj = irhfs(isymj)+j 713 do a = 1, nrhfs(isyma) 714 idx = idx + 1 715 koffa = irhfs(isyma)+a 716 kl = (koffk-1)*nrhfst + koffl 717 aj = (koffj-1)*nrhfst + koffa 718 ajkl = aj +(kl-1)*nrhfst*nrhfst 719 blajkl(idx) = sajkl(ajkl) 720 enddo 721 enddo 722 enddo 723 enddo 724 enddo 725 enddo 726 enddo 727 call qexit('cc_r12xsort4') 728 end 729 730*=====================================================================* 731 subroutine cc_r12fsym(imatmunu,sajkl,blajkl) 732c--------------------------------------------------------------------- 733 734 implicit none 735#include "ccorb.h" 736#include "ccsdsym.h" 737#include "r12int.h" 738 integer isymkl,isymij,isyml,isymk,isymaj 739 integer isymj,isyma,idxkl,isym 740 integer kt,idx,koffj,koffa,koffk,koffl 741 integer ibasi(8),icoun1,kl,aj,iorb1(8),ajkl 742 integer imatmunu(8,8) 743#if defined (SYS_CRAY) 744 real blajkl(*),sajkl(*) 745#else 746 double precision blajkl(*),sajkl(*) 747#endif 748c 749 call qenter('cc_r12fsym') 750c 751 nbast = 0 752 do isym = 1, nsym 753 nbast = nbast + nbas(isym) 754 end do 755 756 icoun1 = 0 757 do isym = 1,nsym 758 ibasi(isym) = icoun1 759 icoun1 = icoun1 + nbas(isym) 760 enddo 761 762 idx = 0 763 do isymkl = 1, nsym 764 isymaj = isymkl 765 isymij = isymkl 766 do isyml =1, nsym 767 isymk = muld2h(isymkl,isyml) 768 do k = 1, nbas(isymk) 769 koffk = ibasi(isymk)+k 770 do l = 1, nbas(isyml) 771 koffl = ibasi(isyml)+l 772 idxkl=imatmunu(isyml,isymk)+nbas(isyml)*(k-1)+l 773 idx = idx + 1 774 kl = (koffk-1)*nbast + koffl 775 blajkl(kl) = sajkl(idx) 776 enddo 777 enddo 778 enddo 779 enddo 780 781 782 call qexit('cc_r12fsym') 783 end 784 785*--------------------------------------------------------------------------- 786*=====================================================================* 787 subroutine cc_r12mksfr(V2AM,F2AM,WORK,LWRK1) 788c--------------------------------------------------------------------- 789c Make s_{kl}^{Ij*} 790c--------------------------------------------------------------------- 791 implicit none 792#include "priunit.h" 793#include "dummy.h" 794#include "ccorb.h" 795#include "ccsdsym.h" 796#include "r12int.h" 797#include "ccfro.h" 798#include "ccsdinp.h" 799#if defined (SYS_CRAY) 800 real zero,one 801 real work(*),v2am(*),f2am(*) 802#else 803 double precision zero,one 804 double precision work(*),v2am(*),f2am(*) 805#endif 806 logical ldum,test,fel 807 parameter (test = .false.,zero = 0.0d0, one = 1.0d0) 808 integer isymai,ISYMIP,ISYMI,ISYMP,ISYMK,NPK,KGX,npi,nki 809 integer npiki,kug,kcmo,kend1,LUSIRG,index,LWRK1,isymik 810 integer isym,it1vm(8,8),it2vm(8,8) 811 integer nrhffrt,isyma,lunit,IGX,IUG,nb1fro(8) 812 integer ISMRS0,ISMRX1,ISMRY1,ISMRZ1,ISMRX2,ISMRY2,ISMRZ2 813 integer nrhfst,ntotgu,kemo,lu43,kugz,kcmoz,LQQ,KQF,IEND 814 integer kend2,norb1t,ismo0,ismo2,ismo1,ismou,isymj 815 integer iv2fro(8,8),iv1fro(8,8),icoun1,icoun2,icoun3,icoun4 816 integer kdmo,i2frofr(8,8),icoun5 817 integer kemoz,kdmox,kdmoz,isymkl,isymaj,isyml 818 819 INDEX(I,J) = MAX(I,J)*(MAX(I,J) - 3)/2 + I + J 820 821 call qenter('cc_r12mksfr') 822 823 do isymk = 1,nsym 824 nv1fro(isymk) = 0 825 do isymj = 1,nsym 826 isymi = muld2h(isymk,isymj) 827 nv1fro(isymk) = nv1fro(isymk) + nrhffr(isymj)* 828 & (norb1(isymi)-nrhffr(isymi)) 829 enddo 830 enddo 831 832 833 do isymk = 1, nsym 834 icoun1 = 0 835 icoun2 = 0 836 icoun3 = 0 837 icoun4 = 0 838 icoun5 = 0 839 do isymj = 1,nsym 840 isymi = muld2h(isymk,isymj) 841 iv2fro(isymi,isymj) = icoun3 842 iv1fro(isymi,isymj) = icoun4 843 i2frofr(isymi,isymj) = icoun5 844 icoun3 = icoun3 + nt1fro(isymi)*nv1fro(isymj) 845 icoun4 = icoun4 + (nrhffr(isymi)) 846 & *(norb1(isymj)-nrhffr(isymj)) 847 icoun5 = icoun5 + nt1fro(isymi)*nfrofr(isymj) 848 enddo 849 enddo 850 851 852 DO ISYMAI = 1,NSYM 853 Nb1FRO(ISYMAI) = 0 854 DO ISYMI = 1,NSYM 855 ISYMA = MULD2H(ISYMAI,ISYMI) 856 Nb1FRO(ISYMAI) = Nb1FRO(ISYMAI) + NRHFFR(ISYMA)*NBAS(ISYMI) 857 ENDDO 858 ENDDO 859 860 NRHFFRT = 0 861 NRHFST = 0 862 NORB1T = 0 863 DO ISYM = 1,NSYM 864 NRHFFRT = NRHFFRT + NRHFFR(ISYM) 865 NRHFST = NRHFST + NRHFS(ISYM) 866 NORB1T = NORB1T + NORB1(ISYM) 867 ENDDO 868 869 870 kgx = 1 871 kcmo = kgx + nt1fro(1) 872 kug = kcmo+ nlamds 873 kemo = kug + nb1fro(1) 874 kdmo = kemo+ nlamds 875 kend1 = kdmo+ nlamds 876 877 call dzero(work(kemo),nlamds) 878 lu43 = -1 879 call gpopen(lu43,'GUMAT.1','UNKNOWN',' ','UNFORMATTED', 880 & IDUMMY,LDUM) 881 REWIND(LU43) 882 READ(LU43) NTOTGU 883 READ(LU43) (work(kemo+I-1), I = 1, NTOTGU) 884 CALL GPCLOSE(LU43,'KEEP') 885 886 887 888 889 890 kcmoz = kcmo 891 kugz = kug 892 893 call dzero(work(kcmo),nlamds) 894 LUSIRG = -1 895 CALL GPOPEN(LUSIRG,'SIRIFC','OLD',' ','UNFORMATTED',IDUMMY,LDUM) 896 REWIND LUSIRG 897 898 CALL MOLLAB(LABEL,LUSIRG,LUPRI) 899 READ (LUSIRG) 900C 901 READ (LUSIRG) 902 READ (LUSIRG) (WORK(kcmo+i-1), I=1,NLAMDS) 903C 904 CALL GPCLOSE(LUSIRG,'KEEP') 905 906 907 call dzero(work(kGX),nt1fro(1)) 908 call dzero(work(kug),nt1fro(1)) 909 910 DO ISYMIP = 1, NSYM 911 ISYMIK = ISYMIP 912 DO ISYMI = 1, NSYM 913 ISYMP = MULD2H(ISYMI,ISYMIP) 914 ISYMK = ISYMP 915 DO I = 1, NRHF(ISYMI) 916 NPK = IT1FRO(ISYMP,ISYMK) 917 DO K = 1, NRHFFR(ISYMK) 918 DO P = 1, NVIR(ISYMP) 919 NPK = NPK + 1 920 NPI = IT1AM(ISYMP,ISYMI) 921 * + NVIR(ISYMP)*(I-1) + P 922 NKI = IT1AM(ISYMK,ISYMI) 923 * + NVIR(ISYMK)*(I-1) + K 924 NPIKI = IT2AM(ISYMIP,ISYMIK) 925 * + INDEX(NPI,NKI) 926 work(kGX+NPK-1) = work(kGX+NPK-1) + V2AM(NPIKI) 927 ENDDO 928 ENDDO 929 ENDDO 930 ENDDO 931 ENDDO 932 DO ISYMIP = 1, NSYM 933 ISYMIK = ISYMIP 934 DO ISYMI = 1, NSYM 935 ISYMP = MULD2H(ISYMI,ISYMIP) 936 ISYMK = ISYMP 937 DO I = 1, NRHFFR(ISYMI) 938 NPK = IT1FRO(ISYMP,ISYMK) 939 DO K = 1, NRHFFR(ISYMK) 940 DO P = 1, NVIR(ISYMP) 941 NPK = NPK + 1 942 NKI = IFROFR(ISYMI,ISYMK) 943 * + NRHFFR(ISYMI)*(K-1) + I 944 NPI = IT1FRO(ISYMP,ISYMI) 945 * + NVIR(ISYMP)*(I-1) + P 946 NPIKI = i2frofr(ISYMIP,ISYMIK) 947 * + NT1FRO(ISYMIP)*(NKI-1) 948 * + NPI 949 work(kGX+NPK-1) = work(kGX+NPK-1) + F2AM(NPIKI) 950 ENDDO 951 ENDDO 952 ENDDO 953 ENDDO 954 ENDDO 955 956 DO ISYM = 1, NSYM 957 NPK = IT1fro(ISYM,ISYM) + NORB1(ISYM) + 1 958 DO K = 1, NRHFFR(ISYM) 959 CALL DZERO(work(kGX+NPK-1),NORB2(ISYM)) 960 NPK = NPK + NVIR(ISYM) 961 ENDDO 962 ENDDO 963 964 965 IGX = 1 966 IUG = 1 967 DO ISYM = 1, NSYM 968 KCMO = KCMO + NRHFS(ISYM)*NBAS(ISYM) 969 CALL MPAB(WORK(KCMO),NBAS(ISYM),NVIR(ISYM), 970 * NBAS(ISYM),NVIR(ISYM), 971 * work(kGX+IGX-1),NVIR(ISYM),NRHFFR(ISYM), 972 * NVIR(ISYM),NRHFFR(ISYM), 973 * work(kUG+IUG-1),NBAS(ISYM),NRHFFR(ISYM)) 974 IF (NORB1(ISYM)*NBAS(ISYM) .NE. 0 .AND. IPRINT .GT.3) THEN 975 WRITE(LUPRI,'(/A,I2)') ' U(NRHFFR) x X/ISYM =',ISYM 976 CALL OUTPUT(work(kUG+IUG-1),1,NBAS(ISYM),1,NRHFFR(ISYM), 977 * NBAS(ISYM),NRHFFR(ISYM),1,LUPRI) 978 WRITE(LUPRI,'(/A,I2)') ' G(NRHFFR) x X/ISYM =',ISYM 979 CALL OUTPUT(work(kGX+IGX-1),1,NBAS(ISYM),1,NRHFFR(ISYM), 980 * NBAS(ISYM),NRHFFR(ISYM),1,LUPRI) 981 ENDIF 982 KCMO = KCMO + NBAS(ISYM)*NVIRS(ISYM) 983 IGX = IGX + NVIR(ISYM)*NRHFFR(ISYM) 984 IUG = IUG + NBAS(ISYM)*NRHFFR(ISYM) 985 ENDDO 986 987 kdmoz = kdmo 988 kdmox = kdmo 989 call dzero(work(kdmo),nlamds) 990 do isym =1, nsym 991 do i = 1,nrhffr(isym) 992 call dcopy(nbas(isym),work(kugz),1,work(kdmo),1) 993 kdmo = kdmo + nbas(isym) 994 kugz = kugz + nbas(isym) 995 enddo 996 kdmo = kdmo + nrhf(isym)*nbas(isym) 997 enddo 998 kemoz = kemo 999 do isym =1, nsym 1000 kdmox = kdmox + nrhffr(isym)*nbas(isym) 1001 do i = 1,nrhf(isym) 1002 call dcopy(nbas(isym),work(kemoz),1,work(kdmox),1) 1003 kdmox = kdmox + nbas(isym) 1004 kemoz = kemoz + nbas(isym) 1005 enddo 1006 kemoz = kemoz + nbas(isym)*(norb1(isym)-nrhfs(isym)) 1007 enddo 1008 1009 1010 1011 ISMO0 = 1 + nt1fro(1) 1012 ISMOU = 1 1013 ISMO1 = KEND1 + NLAMDS 1014 ISMO2 = ISMO1 + NORB1T*NBAST 1015 KEND2 = ISMO2 + NLAMDS 1016 CALL DZERO(WORK(ISMO1),NLAMDS) 1017 CALL DZERO(WORK(ISMO2),NLAMDS) 1018 DO ISYM=1,NSYM 1019 ISMO0 = ISMO0 + NRHFS(ISYM)*NBAS(ISYM) 1020 DO I = 1, NRHFFR(ISYM) 1021 CALL DCOPY(NBAS(ISYM),WORK(ISMO0),1,WORK(ISMO1),1) 1022 CALL DCOPY(NBAS(ISYM),work(kug+ISMOU-1),1,WORK(ISMO2),1) 1023 ISMO1 = ISMO1 + NBAST 1024 ISMO2 = ISMO2 + NBAST 1025 ISMO0 = ISMO0 + NBAS(ISYM) 1026 ISMOU = ISMOU + NBAS(ISYM) 1027 ENDDO 1028 ISMO0 = ISMO0 + 1029 & (NORB2(ISYM)+NORB1(ISYM)-NRHFFR(ISYM))*NBAS(ISYM) 1030 ISMO1 = ISMO1 + NBAS(ISYM) 1031 ISMO2 = ISMO2 + NBAS(ISYM) 1032 ENDDO 1033 ISMO0 = 1 + nt1fro(1) 1034 ISMOU = 1 1035 ISMO1 = KEND1 + NLAMDS+NRHFFRT*NBAST 1036 ISMO2 = ISMO1 + NORB1T*NBAST 1037 KEND2 = ISMO2 + NLAMDS 1038 DO ISYM=1,NSYM 1039 ISMO0 = ISMO0 + (NRHFS(ISYM)+NRHFFR(ISYM))*NBAS(ISYM) 1040 DO I = 1, NRHF(ISYM) 1041 CALL DCOPY(NBAS(ISYM),WORK(ISMO0),1,WORK(ISMO1),1) 1042 CALL DCOPY(NBAS(ISYM),work(kemo+ISMOU-1),1,WORK(ISMO2),1) 1043 ISMO1 = ISMO1 + NBAST 1044 ISMO2 = ISMO2 + NBAST 1045 ISMO0 = ISMO0 + NBAS(ISYM) 1046 ISMOU = ISMOU + NBAS(ISYM) 1047 ENDDO 1048 ISMO0 = ISMO0 + 1049 & (NORB2(ISYM)+NORB1(ISYM)-NRHFS(ISYM))*NBAS(ISYM) 1050 ISMOU=ISMOU + (NORB1(ISYM)-NRHFS(ISYM))*NBAS(ISYM) 1051 ISMO1 = ISMO1 + NBAS(ISYM) 1052 ISMO2 = ISMO2 + NBAS(ISYM) 1053 ENDDO 1054 1055 1056 LUNIT = -1 1057 CALL GPOPEN(LUNIT,'EXFRO','UNKNOWN','SEQUENTIAL', 1058 & 'FORMATTED',IDUMMY,LDUM) 1059 WRITE(LUNIT,'(4E30.20)') (work(kUG+J-1), J = 1,NB1FRO(1)) 1060 CALL GPCLOSE(LUNIT,'KEEP') 1061 1062 1063 ISMO1 = KEND1 + NLAMDS 1064 ISMO2 = ISMO1 + NORB1T*NBAST 1065 ISMRS0 = KEND2 1066 ISMRX1 = ISMRS0 + 2*NRHFST*NRHFST 1067 ISMRY1 = ISMRX1 + 2*NRHFST*NRHFST 1068 ISMRZ1 = ISMRY1 + 2*NRHFST*NRHFST 1069 ISMRX2 = ISMRZ1 + 2*NRHFST*NRHFST 1070 ISMRY2 = ISMRX2 + 2*NRHFST*NRHFST 1071 ISMRZ2 = ISMRY2 + 2*NRHFST*NRHFST 1072 KQF = ISMRZ2 + 2*NRHFST*NRHFST 1073 IEND = KQF + NRHFFRT*NRHFT**3 1074 LQQ = LWRK1 - IEND 1075 1076 1077 1078 CALL DZERO(WORK(ISMRS0),14*NRHFST*NRHFST) 1079 CALL DZERO(WORK(KQF),NRHFFRT*NRHFT**3) 1080 CALL R12QV(.TRUE.,.FALSE.,WORK(KQF),WORK(ISMRS0),WORK(ISMRX1), 1081 * WORK(ISMRY1), 1082 * WORK(ISMRZ1), 1083 * WORK(ISMRX2),WORK(ISMRY2), 1084 * WORK(ISMRZ2), 1085 * WORK(ISMO2),WORK(ISMO1), 1086 * WORK(IEND),LQQ,NBAST,NRHFST,NRHFT,NRHFFRT,.FALSE.) 1087 LUNIT = -1 1088 CALL GPOPEN(LUNIT,'AUXQSF12','UNKNOWN','SEQUENTIAL', 1089 & 'FORMATTED',IDUMMY,LDUM) 1090 WRITE(LUNIT,'(4E30.20)') (WORK(KQF+J-1), J = 1, NRHFFRT*NRHFT**3) 1091 CALL GPCLOSE(LUNIT,'KEEP') 1092 1093 1094 CALL DZERO(WORK(ISMRS0),14*NRHFST*NRHFST) 1095 CALL DZERO(WORK(KQF),NRHFFRT*NRHFT**3) 1096 CALL R12QV(.TRUE.,.FALSE.,WORK(KQF),WORK(ISMRS0),WORK(ISMRX1), 1097 * WORK(ISMRY1), 1098 * WORK(ISMRZ1), 1099 * WORK(ISMRX2),WORK(ISMRY2), 1100 * WORK(ISMRZ2), 1101 * WORK(ISMO2),WORK(ISMO1), 1102 * WORK(IEND),LQQ,NBAST,NRHFST,NRHFT,NRHFFRT,.TRUE.) 1103 LUNIT = -1 1104 CALL GPOPEN(LUNIT,'AUXQSFJ12','UNKNOWN','SEQUENTIAL', 1105 & 'FORMATTED',IDUMMY,LDUM) 1106 WRITE(LUNIT,'(4E30.20)') (WORK(KQF+J-1), J = 1, NRHFFRT*NRHFT**3) 1107 CALL GPCLOSE(LUNIT,'KEEP') 1108 1109 CALL DZERO(WORK(ISMRS0),14*NRHFST*NRHFST) 1110 CALL DZERO(WORK(KQF),NRHFFRT*NRHFT**3) 1111 CALL R12QV(.TRUE.,.TRUE.,WORK(KQF),WORK(ISMRS0),WORK(ISMRX1), 1112 * WORK(ISMRY1), 1113 * WORK(ISMRZ1), 1114 * WORK(ISMRX2),WORK(ISMRY2), 1115 * WORK(ISMRZ2), 1116 * WORK(ISMO2),WORK(ISMO1), 1117 * WORK(IEND),LQQ,NBAST,NRHFST,NRHFT,NRHFFRT,.FALSE.) 1118 LUNIT = -1 1119 CALL GPOPEN(LUNIT,'AUXQSFI12','UNKNOWN','SEQUENTIAL', 1120 & 'FORMATTED',IDUMMY,LDUM) 1121 WRITE(LUNIT,'(4E30.20)') (WORK(KQF+J-1), J = 1, NRHFFRT*NRHFT**3) 1122 CALL GPCLOSE(LUNIT,'KEEP') 1123 1124 1125 1126 1127 call qexit('cc_r12mksfr') 1128 end 1129*=====================================================================* 1130 1131 subroutine cc_r12xsort5(sajkl,blajkl,nvir0) 1132c--------------------------------------------------------------------- 1133 1134 implicit none 1135#include "ccorb.h" 1136#include "ccsdsym.h" 1137#include "r12int.h" 1138#include "ccfro.h" 1139 integer isymkl,isymij,isyml,isymk,isymaj 1140 integer isymj,isyma,idxkl,isym,nvir0(8) 1141 integer kt,idx,nvir0t,koffj,koffa,koffk,koffl 1142 integer icoun1,kl,aj,ivir0(8),ajkl,nrhfst 1143#if defined (SYS_CRAY) 1144 real blajkl(*),sajkl(*) 1145#else 1146 double precision blajkl(*),sajkl(*) 1147#endif 1148c 1149 call qenter('cc_r12xsort5') 1150c 1151 nvir0t = 0 1152 nrhfst = 0 1153 do isym = 1, nsym 1154 nvir0t = nvir0t + nvir0(isym) 1155 nrhfst = nrhfst + nrhfs(isym) 1156 end do 1157 1158 icoun1 = 0 1159 do isym = 1,nsym 1160 ivir0(isym) = icoun1 1161 icoun1 = icoun1 + nvir0(isym) 1162 enddo 1163 1164 1165 idx = 0 1166 do isymkl = 1, nsym 1167 isymaj = isymkl 1168 isymij = isymkl 1169 do isyml =1, nsym 1170 isymk = muld2h(isymkl,isyml) 1171 do k = 1, nrhf(isymk) 1172 koffk = irhf(isymk)+k 1173 do l = 1, nrhf(isyml) 1174 koffl = irhf(isyml)+l 1175 do isyma =1, nsym 1176 isymj = muld2h(isymaj,isyma) 1177 do j = 1, nrhf(isymj) 1178 koffj = irhf(isymj)+j 1179 do a = 1, nvir0(isyma) 1180 idx = idx + 1 1181 koffa = ivir0(isyma)+a 1182 kl = (koffk-1)*nrhft + koffl 1183 aj = (koffj-1)*nvir0t + koffa 1184 ajkl = aj +(kl-1)*nvir0t*nrhft 1185 blajkl(idx) = sajkl(ajkl) 1186 enddo 1187 enddo 1188 enddo 1189 enddo 1190 enddo 1191 enddo 1192 enddo 1193 1194 call qexit('cc_r12xsort5') 1195 end 1196 1197*--------------------------------------------------------------------------- 1198 subroutine cc_r12xsort6(sajkl,blajkl,nvir0) 1199c--------------------------------------------------------------------- 1200 1201 implicit none 1202#include "ccorb.h" 1203#include "ccsdsym.h" 1204#include "r12int.h" 1205#include "ccfro.h" 1206 integer isymkl,isymij,isyml,isymk,isymaj 1207 integer isymj,isyma,idxkl,isym,nvir0(8) 1208 integer kt,idx,nvir0t,koffj,koffa,koffk,koffl 1209 integer icoun1,kl,aj,ivir0(8),ajkl 1210#if defined (SYS_CRAY) 1211 real blajkl(*),sajkl(*) 1212#else 1213 double precision blajkl(*),sajkl(*) 1214#endif 1215c 1216 call qenter('cc_r12xsort6') 1217c 1218 nvir0t = 0 1219 do isym = 1, nsym 1220 nvir0t = nvir0t + nvir0(isym) 1221 end do 1222 1223 icoun1 = 0 1224 do isym = 1,nsym 1225 ivir0(isym) = icoun1 1226 icoun1 = icoun1 + nvir0(isym) 1227 enddo 1228 1229 1230 idx = 0 1231 do isymkl = 1, nsym 1232 isymaj = isymkl 1233 isymij = isymkl 1234 do isyml =1, nsym 1235 isymk = muld2h(isymkl,isyml) 1236 do k = 1, nrhf(isymk) 1237 koffk = irhf(isymk)+k 1238 do l = 1, nrhf(isyml) 1239 koffl = irhf(isyml)+l 1240 idxkl=imatij(isymk,isyml)+nrhf(isymk)*(l-1)+k 1241 do isyma =1, nsym 1242 isymj = muld2h(isymaj,isyma) 1243 do j = 1, nrhf(isymj) 1244 koffj = irhf(isymj)+j 1245 do a = 1, nvir0(isyma) 1246 idx = idx + 1 1247 koffa = ivir0(isyma)+a 1248 kl = (koffk-1)*nrhft + koffj 1249 aj = (koffl-1)*nvir0t + koffa 1250 ajkl = aj +(kl-1)*nvir0t*nrhft 1251 blajkl(idx) = sajkl(ajkl) 1252 enddo 1253 enddo 1254 enddo 1255 enddo 1256 enddo 1257 enddo 1258 enddo 1259 1260 call qexit('cc_r12xsort6') 1261 end 1262 1263 1264*=====================================================================* 1265