1! 2! Dalton, a molecular electronic structure program 3! Copyright (C) by the authors of Dalton. 4! 5! This program is free software; you can redistribute it and/or 6! modify it under the terms of the GNU Lesser General Public 7! License version 2.1 as published by the Free Software Foundation. 8! 9! This program is distributed in the hope that it will be useful, 10! but WITHOUT ANY WARRANTY; without even the implied warranty of 11! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12! Lesser General Public License for more details. 13! 14! If a copy of the GNU LGPL v2.1 was not distributed with this 15! code, you can obtain one at https://www.gnu.org/licenses/old-licenses/lgpl-2.1.en.html. 16! 17! 18C 19 Subroutine amfi(LUAMFI_INP,LUPROP,BREIT,FINITE,EXP_FIN, 20 * WRK,LFREE) 21CBS 22CBS LUAMFI_INP: Input file, to be replaced by direct reading from DALTON arrays.. 23CBS LUPROP: Unit for writing the atomic integrals 24CBS BREIT: FLAG to switch to Breit-Pauli (Douglas-Kroll is the default) 25CBS FINITE: flag whether to use a finite nucleus or not ... 26CB EXP_FIN: the finite nucleus exponent (if required) 27CBS WRK, KFREE,LFREE standard work-array parameters in DALTON 28CBS 29CBS 30#include "implicit.h" 31c########################################################################### 32c 33c A M F I 34c 35c Atomic Mean-Field Spin-Orbit Integral Program 36c 37c Integral-code to generate the one- and two-electron spin-orbit integrals 38c in the no-pair approximation for an atom. 39c 40c basis set is built by atomic functions of the form: 41c 42c f(r,Omega)= r**l Y_(lm) (Omega) 43c 44c Allthough the code is created with a lot of care and love for 45c the details, the author doesn't give any warranty for it's 46c correctness. 47c 48c B.Schimmelpfennig Fysikum/Stockholm Summer 1996 49c 50c If you use this code, please honour the authors work 51c by citing this work properly. 52c 53c The author would like to thank the Deutsche Forschungsgemeinschaft 54c for financing this project by a Forschungsstipendium. 55c 56c 57c The spatial integrals are expected to be used with a spin part 58c expressed in Paulis spin-matrices rather than with the Spin-operator 59c itself. So if a factor of two is somehow missing, check whether the 60c same form of the operator is used. 61c 62c 63c WARNING !!! WARNING !! WARNING !! WARNING !! WARNING !! 64c 65c when writing spin-same-orbit and spin-other-oribt with sigma_i: 66c 67c For the spin-other-orbit-integrals particle 1 and 2 are exchanged 68c on the arrays carteXOO,carteYOO,carteZOO!!!!!!!!! 69c 70c The reason is to use most of the same-orbit part again and to 71c have the same symmetry for the integrals on the arrays. 72c 73c 74c if the spin-other-orbit-part is used in the formulation with 75c sigma_j, the particles are of cause not interchanged. 76c 77c 78c 79c (i|HSO_mean|j) = (ij) + 1/2 * sum_M occ(M) { 80c 2(ij|MM)_same - (iM|jM)_same -2(iM|jM)_other 81c + (jM|iM)_same +2(jM|iM)_other } 82c 83c in the subroutines some signs are changed to reorder indices 84c in the integrals to (iM|jM) or (Mi|Mj) accoding to the way they 85c were calculated before. 86c 87c 88c 89c one-particle integrals (really one-particle or mean-field) 90c are written to files in CONTANDMULT. Look there for information on 91c the format of files. 92c 93c 94c BUGS: There is still a strange sign-error in the two-electron-integrals 95c if one applies straight-forward the formulae of the documentation. 96c This problem has been solved by the the cheater... 97c 98c Everybody is welcome to find the problem in the formulas ........ 99c 100c First reasonable results on Thallium (SD with frozen 5D) 14.10.96 101c 102c 103c 104c 105c 106c Connection to MOLCAS: 107c How wonderful, they normalize the functions exactly as I do, which 108c means they use the correct linear combinations. 109c 110c Exponents and coefficients are expected in the MOLCAS-Format 111c first exponents 112c coefficients afterwards 113c 114c 8.5.97 115c 116c New version for DALTON canibalized from the MOLCAS version september 2000 117c 118c########################################################################### 119#include "para.h" 120 logical keep ! parameter to decide about keeping angular 121cbs ! integrals in memory 122 logical keepcart ! parameter to decide about keeping cartesian 123cbs ! integrals in memory 124 logical makemean ! parameter to decide about generating a meanfield 125 logical bonn ! if bonn is set, Bonn-approach for spin-other orbit 126 logical breit ! if breit is set, BREIT-PAULI only 127 logical SAMEORB ! parameter for same-orbit only 128 logical AIMP ! parameter to delete CORE for AIMP 129 logical oneonly ! parameter to use only oneelectron integrals 130 logical FINITE 131 character*4 symmetry 132#include "datapow.h" 133 common ipowxyz(3,-Lmax:Lmax,0:Lmax) 134 dimension WRK(LFREE) 135c########################################################################## 136cbs ##################################################################### 137cbs version with all angular integrals in memory 138c keep=.true. 139cbs ##################################################################### 140cbs version without all angular integrals in memory 141 keep=.false. 142cbs ##################################################################### 143cbs version without all cartesian integrals in memory 144 keepcart=.false. 145cbs ##################################################################### 146cbs version with all cartesian integrals in memory 147c keepcart=.true. 148cbs ##################################################################### 149cbs initialize tables with double facultatives... 150 call inidf 151cbs move some powers of x,y,z to the right place BEGIN 152cbs check if Lpowmax is high enough.. 153 if (Lpowmax.lt.Lmax) then 154 CALL QUIT('AMFI: increase lpowmax and edit ixyzpow') 155 endif 156 jrun=1 157 do irun=0,Lmax 158 do Mval=-irun,irun 159 ipowxyz(1,Mval,irun)=ixyzpow(jrun) 160 ipowxyz(2,Mval,irun)=ixyzpow(jrun+1) 161 ipowxyz(3,Mval,irun)=ixyzpow(jrun+2) 162 jrun=jrun+3 163 enddo 164 enddo 165cbs move some powers of x,y,z to the right place END 166 if (FINITE) then 167 ifinite=1 168 else 169 ifinite=0 170 endif 171cbs read the input 172 call readbas(Lhigh,makemean,bonn,breit, 173 *symmetry,sameorb,AIMP,oneonly,ncont4,numballcart,LUAMFI_INP, 174 *ifinite,EXP_FIN) 175cbs 176cbs 177 123 if (ifinite.eq.2) call finsub 178cbs 179cbs 180! Lhigh is the highest l-value in the basis set 181 if (makemean.and.(.not.oneonly).and.ifinite.le.1) 182 *call getAOs(Lhigh) 183 call genpowers(Lhigh) !generate powers of exponents and overlaps 184cbs start generating modified contraction coefficients 185cbs generate starting adresses of contraction coefficients on 186cbs contrarray 187 call genstar(Lhigh) 188cbs generate ovlp of normalized primitives 189 call genovlp(Lhigh) 190 do lrun=0,Lhigh 191cbs cont(L) arranges all the contraction coefficients for a given L-value 192cbs and renormalizes them 193 call cont(lrun,breit,ifinite) 194 enddo 195cbs 196cbs beginning the angular part 197 if (.not.oneonly) then 198CBS write(6,*) '***************************************************' 199CBS write(6,*) '******** beginning the 2e-part ******************' 200CBS write(6,*) '***************************************************' 201cbs 202cbs ##################################################################################### 203cbs ##################################################################################### 204cbs ##################################################################################### 205cbs 206cbs 207 call angular(Lhigh,keep,keepcart,makemean,bonn,breit, 208 *sameorb,ifinite,WRK,LFREE) ! subroutine for angular part 209 endif 210 if (ifinite.eq.1) then ! redo everything for finite core 211CBS write(6,*) 'once more the two-electron integrals' 212 ifinite=2 213 goto 123 214 endif 215cbs ######################################################################################## 216cbs ######################################################################################## 217cbs ######################################################################################## 218CBS write(6,*) '***************************************************' 219CBS write(6,*) '******* beginning the 1-electron-part **********' 220CBS write(6,*) '***************************************************' 221cbs the one-electron spin-orbit integrals 222 call gen1overR3(Lhigh) ! generates the 1/r**3 integrals for normalized functions 223 call contandmult(Lhigh,makemean,AIMP,oneonly,numballcart,LUPROP, 224 *ifinite,WRK,LFREE) ! multiplies radial integrals with l,m-dependent 225cbs factors and contraction coefficients 226CBS write(6,*) '***************************************************' 227CBS write(6,*) '******* end of the 1-electron-part **********' 228CBS write(6,*) '***************************************************' 229cbs ######################################################################################## 230cbs ######################################################################################## 231cbs ######################################################################################## 232 Return 233 end 234 subroutine finsub 235cbs 236cbs subroutine to set up parameters for finite nucleus. The s-functions are replaced 237cbs by just one exponent which models the nucleus. 238cbs 239#include "implicit.h" 240#include "para.h" 241#include "amfi_param.h" 242 common /nucleus/ charge,Exp_finite 243 noccorb(0)=1 244 do l=1,lmax_occ 245 noccorb(l)=0 246 enddo 247 occup(1,0)=-charge 248 nprimit_keep=nprimit(0) 249 ncontrac_keep=ncontrac(0) 250 nprimit(0)=1 251 ncontrac(0)=1 252 exponents(1,0)=0.5d0*Exp_finite 253 return 254 end 255 256 257 subroutine angular(Lhigh,keep,keepcart,makemean,bonn, 258 *breit,sameorb,ifinite,WRK,LFREE) 259c 260cbs COMBINES THE RADIAL INTEGRALS WITH THE ANGULAR FACTORS 261c 262cbs if keep=.true. then 263cbs all the integrals will be kept in memory. 264cbs Perhaps, there will be the option to make the 265cbs transformation to the cartesian basis-sets 266cbs everytime, they are required. 267cbs Therefore, the integrals are kept in memory and 268cbs can be further transformed, whenever required. 269cbs in order not to waste to much memory, the atomic 270cbs integrals are thrown away after each l,l,l,l-block 271#include "implicit.h" 272#include "priunit.h" 273#include "para.h" 274#include "amfi_param.h" 275 logical keep,keepcart,icheck,mcheckxy,mcheckz,makemean,bonn, 276 *breiT,sameorb,cleaner,NFINI 277cbs NFINI means not finite nucleus 278 dimension l2block(0:Lmax,0:Lmax,0:Lmax,0:Lmax) 279 dimension WRK(LFREE) 280cbs ##################################################################### 281cbs some preparation of factors needed later on.. # 282cbs ###################################################################### 283 ipnt(i,j)=(max(i,j)*max(i,j)-max(i,j))/2+min(i,j) 284 roottwo=dsqrt(2d0) 285cbs calculate some prefactors that will be needed quite often 286 call prefac(Lmax,preroots,clebsch) 287 if (ifinite.ne.2) then 288cbs clean array for one electron integrals 289 iprod=MxcontL*MxcontL*(Lmax+Lmax+1)*(Lmax+1)*Lmax 290 call dzero(onecartX,iprod) 291 call dzero(onecartY,iprod) 292 call dzero(onecartZ,iprod) 293 NFINI=.true. 294 else 295 NFINI=.false. 296 endif 297cbs generate an array with sign for (even/odd) m-values 298 isignM(0)=1 299 do I=2,Lmax,2 300 isignM(I)=1 301 isignM(-I)=1 302 enddo 303 do I=1,Lmax,2 304 isignM(I)=-1 305 isignM(-I)=-1 306 enddo 307cbs ##################################################################### 308cbs prefactors preXZ und preY include the factors 1/root(2) 309cbs for the +/- linear combinations of spherical harmonics 310cbs ##################################################################### 311 do M4=-Lmax,Lmax 312 do M3=-Lmax,Lmax 313 do M2=-Lmax,Lmax 314 do M1=-Lmax,Lmax 315 preXZ(m1,m2,m3,m4)=0.25d0 316 enddo 317 enddo 318 enddo 319 enddo 320 do M3=-Lmax,Lmax 321 do M2=-Lmax,Lmax 322 do M1=-Lmax,Lmax 323 preXZ(m1,m2,m3,0)=preXZ(m1,m2,m3,0)*roottwo 324 enddo 325 enddo 326 enddo 327 do M3=-Lmax,Lmax 328 do M2=-Lmax,Lmax 329 do M1=-Lmax,Lmax 330 preXZ(m1,m2,0,m3)=preXZ(m1,m2,0,m3)*roottwo 331 enddo 332 enddo 333 enddo 334 do M3=-Lmax,Lmax 335 do M2=-Lmax,Lmax 336 do M1=-Lmax,Lmax 337 preXZ(m1,0,m2,m3)=preXZ(m1,0,m2,m3)*roottwo 338 enddo 339 enddo 340 enddo 341 do M3=-Lmax,Lmax 342 do M2=-Lmax,Lmax 343 do M1=-Lmax,Lmax 344 preXZ(0,m1,m2,m3)=preXZ(0,m1,m2,m3)*roottwo 345 enddo 346 enddo 347 enddo 348 do M4=-Lmax,Lmax 349 do M3=-Lmax,Lmax 350 do M2=-Lmax,Lmax 351 do M1=-Lmax,Lmax 352 preY(m1,m2,m3,m4)=preXZ(m1,m2,m3,m4) 353 enddo 354 enddo 355 enddo 356 enddo 357cbs ##################################################################### 358cbs additional (-) signs from the (-i) factors in the 359cbs (-) linear combinations (see tosigX(Y,Z).f) 360cbs ##################################################################### 361cbs + - - - => minus 362 do M4=-Lmax,-1 363 do M3=-Lmax,-1 364 do M2=-Lmax,-1 365 do M1= 0,Lmax 366 preXZ(m1,m2,m3,m4)=-preXZ(m1,m2,m3,m4) 367 enddo 368 enddo 369cbs - + - - => minus 370 do M2= 0,Lmax 371 do M1=-Lmax,-1 372 preXZ(m1,m2,m3,m4)=-preXZ(m1,m2,m3,m4) 373 enddo 374 enddo 375 enddo 376 enddo 377 do M2= 0,Lmax 378 do M1= 0,Lmax 379cbs + + + - => minus 380 do M4=-Lmax,-1 381 do M3= 0,Lmax 382 preXZ(m1,m2,m3,m4)=-preXZ(m1,m2,m3,m4) 383 enddo 384 enddo 385cbs + + - + => minus 386 do M4= 0,Lmax 387 do M3=-Lmax,-1 388 preXZ(m1,m2,m3,m4)=-preXZ(m1,m2,m3,m4) 389 enddo 390 enddo 391 enddo 392 enddo 393cbs + + - - > - 394 do M4=-Lmax,-1 395 do M3=-Lmax,-1 396 do M2=0,Lmax 397 do M1=0,Lmax 398 preY(m1,m2,m3,m4)=-preY(m1,m2,m3,m4) 399 enddo 400 enddo 401 enddo 402 enddo 403cbs - - + + > - 404 do M4=0,Lmax 405 do M3=0,Lmax 406 do M2=-Lmax,-1 407 do M1=-Lmax,-1 408 preY(m1,m2,m3,m4)=-preY(m1,m2,m3,m4) 409 enddo 410 enddo 411 enddo 412 enddo 413cbs ##################################################################### 414cbs some quick decision for interaction 415cbs ##################################################################### 416 do M4=0,Lmax 417 do M3=0,Lmax 418 do M2=0,Lmax 419 do M1=0,Lmax 420 icheck=mcheckxy(m1,m2,m3,m4) 421 icheckxy(m1,m2,m3,m4)=icheck 422 icheckxy(m1,m2,m3,-m4)=icheck 423 icheckxy(m1,m2,-m3,m4)=icheck 424 icheckxy(m1,-m2,m3,m4)=icheck 425 icheckxy(-m1,m2,m3,m4)=icheck 426 icheckxy(m1,m2,-m3,-m4)=icheck 427 icheckxy(m1,-m2,m3,-m4)=icheck 428 icheckxy(m1,-m2,-m3,m4)=icheck 429 icheckxy(m1,-m2,-m3,-m4)=icheck 430 icheckxy(-m1,m2,m3,-m4)=icheck 431 icheckxy(-m1,m2,-m3,m4)=icheck 432 icheckxy(-m1,m2,-m3,-m4)=icheck 433 icheckxy(-m1,-m2,m3,m4)=icheck 434 icheckxy(-m1,-m2,m3,-m4)=icheck 435 icheckxy(-m1,-m2,-m3,m4)=icheck 436 icheckxy(-m1,-m2,-m3,-m4)=icheck 437 enddo 438 enddo 439 enddo 440 enddo 441 do M4=0,Lmax 442 do M3=0,Lmax 443 do M2=0,Lmax 444 do M1=0,Lmax 445 icheck=mcheckz(m1,m2,m3,m4) 446 icheckz(m1,m2,m3,m4)=icheck 447 icheckz(m1,m2,m3,-m4)=icheck 448 icheckz(m1,m2,-m3,m4)=icheck 449 icheckz(m1,m2,-m3,-m4)=icheck 450 icheckz(m1,-m2,m3,m4)=icheck 451 icheckz(m1,-m2,m3,-m4)=icheck 452 icheckz(m1,-m2,-m3,m4)=icheck 453 icheckz(m1,-m2,-m3,-m4)=icheck 454 icheckz(-m1,m2,m3,m4)=icheck 455 icheckz(-m1,m2,m3,-m4)=icheck 456 icheckz(-m1,m2,-m3,m4)=icheck 457 icheckz(-m1,m2,-m3,-m4)=icheck 458 icheckz(-m1,-m2,m3,m4)=icheck 459 icheckz(-m1,-m2,m3,-m4)=icheck 460 icheckz(-m1,-m2,-m3,m4)=icheck 461 icheckz(-m1,-m2,-m3,-m4)=icheck 462 enddo 463 enddo 464 enddo 465 enddo 466cbs ##################################################################### 467cbs there are at most 16 possible combinations of signs ( 2**4) 468cbs ##################################################################### 469 do M4=0,Lmax 470 do M3=0,Lmax 471 do M2=0,Lmax 472 do M1=0,Lmax 473 do irun=1,16 474 interxyz(irun,m1,m2,m3,m4)=0 475 enddo 476 enddo 477 enddo 478 enddo 479 enddo 480cbs the following M values are the ones from the cartesian 481cbs linear combinations. interxyz gives the sign sequence 482cbs for interacting spherical functions, starting with 483cbs type 1 (++++) and ending with type 16 (-++-) 484 do M4=0,Lmax 485 do M3=0,Lmax 486 do M2=0,Lmax 487 do M1=0,Lmax 488 if (icheckxy(m1,m2,m3,m4).or.icheckz(m1,m2,m3,m4)) then 489 irun=0 490 if (iabs(m1+m2-m3-m4).le.1) then 491 irun=irun+1 492 interxyz(irun,m1,m2,m3,m4)=1 ! + + + + 493 if (m1.gt.0.and.m2.gt.0.and. 494 * m3.gt.0.and.m4.gt.0) then 495 irun=irun+1 496 interxyz(irun,m1,m2,m3,m4)=2 ! - - - - 497 endif 498 endif 499 if (iabs(m1+m2-m3+m4).le.1) then 500 if (m4.gt.0) then 501 irun=irun+1 502 interxyz(irun,m1,m2,m3,m4)=3 ! + + + - 503 endif 504 if (m1.gt.0.and.m2.gt.0.and. 505 * m3.gt.0) then 506 irun=irun+1 507 interxyz(irun,m1,m2,m3,m4)=4 ! - - - + 508 endif 509 endif 510 if (iabs(m1+m2+m3-m4).le.1) then 511 if (m3.gt.0) then 512 irun=irun+1 513 interxyz(irun,m1,m2,m3,m4)=5 ! + + - + 514 endif 515 if (m1.gt.0.and.m2.gt.0.and. 516 * m4.gt.0) then 517 irun=irun+1 518 interxyz(irun,m1,m2,m3,m4)=6 ! - - + - 519 endif 520 endif 521 if (iabs(m1-m2-m3-m4).le.1) then 522 if (m2.gt.0) then 523 irun=irun+1 524 interxyz(irun,m1,m2,m3,m4)=7 ! + - + + 525 endif 526 if (m1.gt.0.and.m3.gt.0.and. 527 * m4.gt.0) then 528 irun=irun+1 529 interxyz(irun,m1,m2,m3,m4)=8 ! - + - - 530 endif 531 endif 532 if (iabs(-m1+m2-m3-m4).le.1) then 533 if (m1.gt.0) then 534 irun=irun+1 535 interxyz(irun,m1,m2,m3,m4)=9 ! - + + + 536 endif 537 if (m2.gt.0.and.m3.gt.0.and. 538 * m4.gt.0) then 539 irun=irun+1 540 interxyz(irun,m1,m2,m3,m4)=10 ! + - - - 541 endif 542 endif 543 if (iabs(m1+m2+m3+m4).le.1) then 544 if (m3.gt.0.and.m4.gt.0) then 545 irun=irun+1 546 interxyz(irun,m1,m2,m3,m4)=11 ! + + - - 547 endif 548 if (m1.gt.0.and.m2.gt.0) then 549 irun=irun+1 550 interxyz(irun,m1,m2,m3,m4)=12 ! - - + + 551 endif 552 endif 553 if (iabs(m1-m2-m3+m4).le.1) then 554 if (m2.gt.0.and.m4.gt.0) then 555 irun=irun+1 556 interxyz(irun,m1,m2,m3,m4)=13 ! + - + - 557 endif 558 if (m1.gt.0.and.m3.gt.0) then 559 irun=irun+1 560 interxyz(irun,m1,m2,m3,m4)=14 ! - + - + 561 endif 562 endif 563 if (iabs(m1-m2+m3-m4).le.1) then 564 if (m2.gt.0.and.m3.gt.0) then 565 irun=irun+1 566 interxyz(irun,m1,m2,m3,m4)=15 ! + - - + 567 endif 568 if (m1.gt.0.and.m4.gt.0) then 569 irun=irun+1 570 interxyz(irun,m1,m2,m3,m4)=16 ! - + + - 571 endif 572 endif 573 endif 574 enddo 575 enddo 576 enddo 577 enddo 578cbs ##################################################################### 579cbs isgnprod gives the sign due to powers (-1)**M this are again 580cbs angular m-values 581cbs ##################################################################### 582 do M4=-Lmax,Lmax 583 if (M4.gt.0) then 584 inter4=isignM(M4) 585 else 586 inter4=1 587 endif 588 do M3=-Lmax,Lmax 589 if (M3.gt.0) then 590 inter3=inter4*isignM(M3) 591 else 592 inter3=inter4 593 endif 594 do M2=-Lmax,Lmax 595 if (M2.gt.0) then 596 inter2=inter3*isignM(M2) 597 else 598 inter2=inter3 599 endif 600 do M1=-Lmax,Lmax 601 if (M1.gt.0) then 602 isgnprod(m1,m2,m3,m4)=inter2*isignM(M1) 603 else 604 isgnprod(m1,m2,m3,m4)=inter2 605 endif 606 enddo 607 enddo 608 enddo 609 enddo 610cbs ##################################################################### 611cbs some preparation of factors needed later on.. finished # 612cbs ##################################################################### 613c 614c 615c 616cbs counter for total number of cartesian integrals ! set some counters 617 numbcart=0 ! 618cbs same orbit integrals integrals on carteXSO carteYSO and carteSO 619cbs other orbit integrals on carteXOO carteYOO and carteOO 620 iangfirst=0 ! first block of angular integrals 621cbs ##################################################################### 622cbs loop over all (l,l,l,l) blocks generated in the radial part # 623cbs ##################################################################### 624 do lrun4=0,Lmax 625 do lrun3=0,Lmax 626 do lrun2=0,Lmax 627 do lrun1=0,Lmax 628 l2block(lrun1,lrun2,lrun3,lrun4)=0 629 enddo 630 enddo 631 enddo 632 enddo 633cbs loop over all possible < l1 l2, l3 l4 > blocks 634CBS write(6,'(A)') ' L1 L2 L3 L4' 635 do l1=0,Lhigh ! improving is probably possible... 636 do l2=0,Lhigh 637 do l3=0,l1 638 do l4=0,l2 639cbs check parity 640 if (mod(l1+l2+l3+l4,2).eq.0) then 641cbs check that Lleft and Lright do not always differ by more than one 642cbs a difference of two means two spin flips and is therefore not allowed 643 Lleftmax=l1+l2 644 Lrightmax=l3+l4 645 Lleftmin=iabs(l1-l2) 646 Lrightmin=iabs(l3-l4) 647 if ((Lrightmin-Lleftmax.le.1.and.Lrightmax-Lleftmin.gt.-1).or. 648 *(Lleftmin-Lrightmax.le.1.and.Lleftmax-Lrightmin.gt.-1)) then 649cbs additional check for mean-field 650 if ((l1.eq.l3.and.l2.eq.l4).or.(l1.eq.l2.and.l3.eq.l4)) then 651 if (l1+l3.ne.0) then 652CBS write(6,'(4I5)') l1,l2,l3,l4 653CBS now I determine the size of the angular integral arrays 654 jblock=0 655 do m1=-l1,l1 656 do m2=-l2,l2 657 do m3=-l3,l3 658 m4=m1+m2-m3+1 659 if (iabs(m4).le.l4) then 660 if ((.not.makemean).or. 661 * (l1.eq.l3.and.l2.eq.l4.and.iabs(m2).eq.iabs(m4)).or. 662 * (l1.eq.l2.and.l3.eq.l4.and. 663 * (iabs(m1).eq.iabs(m2).or.iabs(m3).eq.iabs(m4)))) then 664 jblock=jblock+1 665 endif 666 endif 667 enddo 668 enddo 669 enddo 670 do m1= 0,l1 671 do m2=-l2,l2 672 do m3=-l3,l3 673 m4=m1+m2-m3 674 if ((.not.makemean).or. 675 * (l1.eq.l3.and.l2.eq.l4.and.iabs(m2).eq.iabs(m4)).or. 676 * (l1.eq.l2.and.l3.eq.l4.and. 677 * (iabs(m1).eq.iabs(m2).or.iabs(m3).eq.iabs(m4)))) then 678 if (m1.ne.0.or.m2.ne.0.or.m3.ne.0) then ! all m eqal 0 make no sense.... 679 if (iabs(m4).le.l4) then 680 jblock=jblock+1 681 endif 682 endif 683 endif 684 enddo 685 enddo 686 enddo 687CBS done !! 688cbs number of contracted integrals for each block 689 ncont=ncontrac(l1)*ncontrac(l2)* 690 * ncontrac(l3)*ncontrac(l4) 691 mxangint=jblock*ncont 692cbs determine the size icont4 for the radial integrals 693 call gencoulDIM(l1,l2,l3,l4,makemean,bonn,breit, 694 *sameorb,icont4) 695 IANGSO = 1 696 iangOO=iangSO+mxangint 697 icartSO=iangOO+mxangint 698 icartOO=icartSO+ncont 699 iconSO=icartOO+ncont 700 iconOO=iconSO+icont4 701 KLAST = ICONOO + ICONT4 702 IF (KLAST .GT. LFREE) CALL STOPIT('AMFI ','ANGULAR',KLAST,LFREE) 703 LLEFT = LFREE - KLAST + 1 704 call gencoul(l1,l2,l3,l4,makemean,bonn,breit, 705 *sameorb,WRK(iconSO),WRK(iconOO),icont4, 706 *WRK(KLAST),LLEFT) ! generates and transforms integrals 707 l2block(l1,l2,l3,l4)=1 ! can be used for getting the 708cbs local counter for integral adresses 709 mblock=0 ! counter of (m,m,m,m)-blocks for (l1,l2,l3,l4) 710cbs if keep is set to false, the angular integrals are 711cbs thrown away after each block of l-values 712cbs which means integrals start at address 0 713 if (.not.keep) iangfirst=0 714 locstar=iangfirst ! local starting adress counter 715 do m1=-l1,l1 716 do m2=-l2,l2 717 do m3=-l3,l3 718 do m4=-l4,l4 719 mcombina(1,m1,m2,m3,m4)=0 ! will hold type of integrals (1,2,3) 720 mcombina(2,m1,m2,m3,m4)=0 ! will hold number of block 721 enddo 722 enddo 723 enddo 724 enddo 725 do m1=-l1,l1 726 do m2=-l2,l2 727 do m3=-l3,l3 728cbs m4 is more or less fixed by m1-3 729c#################################################################################### 730c#################################################################################### 731c########## the L- -type block to be combined with sigma+ ########################### 732c#################################################################################### 733c#################################################################################### 734 m4=m1+m2-m3+1 735 if (iabs(m4).le.l4) then !the L- -block to be combined with sigma+ 736cbs not all m-combinations are needed for the mean-field 737 if ((.not.makemean).or. 738 * (l1.eq.l3.and.l2.eq.l4.and.iabs(m2).eq.iabs(m4)).or. 739 * (l1.eq.l2.and.l3.eq.l4.and. 740 * (iabs(m1).eq.iabs(m2).or.iabs(m3).eq.iabs(m4)))) then 741 mcombina(1,m1,m2,m3,m4)=1 742 mblock=mblock+1 743 if (locstar+ncont.gt.mxangint) then 744 write(LUPRI,*)'not enough space allocated for angular integrals' 745 write(LUPRI,*) 'increase mxangint to at least ', 746 * locstar+ncont 747 CALL QUIT('Out of dimensional bounds in AMFI') 748 endif 749cbs mkangLmin = make_angular_integrals_for_L- type operator 750cbs really generates the angular prefactors and combines them with 751cbs the radial integrals 752 call mkangLmin(Lmax,l1,l2,l3,l4,m1,m2,m3,m4, 753 * WRK(iangSO+locstar), 754 * WRK(iangOO+locstar), 755 * Lfirst(1),Llast(1),Lblocks(1), 756 * ncontrac(l1),ncontrac(l2),ncontrac(l3),ncontrac(l4), 757 * WRK(iconSO+Lstarter(1)-1), 758 * WRK(iconSO+Lstarter(2)-1), 759 * WRK(iconSO+Lstarter(3)-1), 760 * WRK(iconSO+Lstarter(4)-1), 761 * WRK(iconOO+Lstarter(1)-1), 762 * WRK(iconOO+Lstarter(2)-1), 763 * WRK(iconOO+Lstarter(3)-1), 764 * WRK(iconOO+Lstarter(4)-1), 765 * preroots,clebsch,scratch4,bonn,breit, 766 * sameorb) 767 locstar=locstar+ncont ! increase starting address 768 mcombina(2,m1,m2,m3,m4)=mblock ! set the block number 769c#################################################################################### 770c#################################################################################### 771c########## the L+ -type block to be combined with sigma- ########################### 772c#################################################################################### 773c#################################################################################### 774c 775c these integrals are obtained by changing the signs of the m-values. 776c As the integrals are the same, the pointer points to the same integrals... 777c 778c 779 mcombina(1,-m1,-m2,-m3,-m4)=3 780 mcombina(2,-m1,-m2,-m3,-m4)=mblock 781 endif 782 Endif 783 enddo 784 enddo 785 enddo 786c#################################################################################### 787c#################################################################################### 788c########## the L0 -type block to be combined with sigma0 ########################### 789c#################################################################################### 790c#################################################################################### 791 do m1= 0,l1 792 do m2=-l2,l2 793 do m3=-l3,l3 794cbs m4 is more or less fixed by m1-3 795 m4=m1+m2-m3 ! the L0-block to be combined with sigma0 796cbs not all m-combinations are needed for the mean-field 797 if ((.not.makemean).or. 798 * (l1.eq.l3.and.l2.eq.l4.and.iabs(m2).eq.iabs(m4)).or. 799 * (l1.eq.l2.and.l3.eq.l4.and. 800 * (iabs(m1).eq.iabs(m2).or.iabs(m3).eq.iabs(m4)))) then 801c 802 if (m1.ne.0.or.m2.ne.0.or.m3.ne.0) then ! all m eqal 0 make no sense.... 803 if (iabs(m4).le.l4) then 804 mcombina(1,m1,m2,m3,m4)=2 805 mblock=mblock+1 806 if (locstar+ncont.gt.mxangint) then 807 write(LUPRI,*)'not enough space allocated for angular integrals' 808 write(LUPRI,*) 'increase mxangint to at least ', 809 * locstar+ncont 810 CALL QUIT('Out of dimensional bounds in AMFI') 811 endif 812 call mkangL0(Lmax,l1,l2,l3,l4,m1,m2,m3,m4, 813 * WRK(iangSO+locstar), 814 * WRK(iangOO+locstar), 815 * Lfirst(1),Llast(1),Lblocks(1), 816 * ncontrac(l1),ncontrac(l2),ncontrac(l3),ncontrac(l4), 817 * WRK(iconSO+Lstarter(1)-1), 818 * WRK(iconSO+Lstarter(2)-1), 819 * WRK(iconSO+Lstarter(3)-1), 820 * WRK(iconSO+Lstarter(4)-1), 821 * WRK(iconOO+Lstarter(1)-1), 822 * WRK(iconOO+Lstarter(2)-1), 823 * WRK(iconOO+Lstarter(3)-1), 824 * WRK(iconOO+Lstarter(4)-1), 825 * preroots,clebsch,scratch4,bonn,breit, 826 * sameorb) 827 locstar=locstar+ncont 828 mcombina(2,m1,m2,m3,m4)=mblock 829 endif 830 endif 831 endif 832 enddo 833 enddo 834 enddo 835cbs ################################################################################## 836cbs ################################################################################## 837cbs transformation to l,m dependent integrals is finished 838cbs ################################################################################## 839c 840c 841c 842c 843cbs ################################################################################## 844cbs begin transformation to cartesian integrals 845cbs ################################################################################## 846cbs ################################################################################## 847cbs check out, which combinations of m-values will 848cbs contribute to cartesian integrals 849 do m1=-l1,l1 ! 850 do m2=-l2,l2 ! these indices now run over the real harmonics 851 do m3=-l3,l3 ! 852 do m4=-l4,l4 ! 853 mcombcart(1,m1,m2,m3,m4)=0 ! will hold the type x=1 y=2 z=3 854 mcombcart(2,m1,m2,m3,m4)=0 ! will hold the block number 855 enddo 856 enddo 857 enddo 858 enddo 859 mblockx=0 860 mblocky=0 861 mblockz=0 862 do m3=-l3,l3 863 do m4=-l4,l4 864cbs if the l-values are the same : triangular matrix over m-values is sufficient 865 if (l1.eq.l3) then 866 m1upper=m3 867 else 868 m1upper=l1 869 endif 870 if (makemean) m1upper=l1 871cbs if the l-values are the same : triangular matrix over m-values is sufficient 872 if (l2.eq.l4) then 873 m2upper=m4 874 else 875 m2upper=l2 876 endif 877 if (makemean) m2upper=l2 878 do m1=-l1,m1upper 879 If (l1.eq.l3.and.m1.eq.m3) then ! clean real zeros by symmetry to be exactly zero 880cbs this a problem of the spin-other-orbit integrals, as they are by formula 881cbs not antisymmetric in the indices for particle 1. 882 cleaner=.true. 883 else 884 cleaner=.false. 885 endif 886 do m2=-l2,m2upper 887cbs not all m-combinations are needed for the mean-field 888 if ((.not.makemean).or. 889 * (l1.eq.l3.and.l2.eq.l4.and.m2.eq.m4).or. 890 * (l1.eq.l2.and.l3.eq.l4.and.(m1.eq.m2.or.m3.eq.m4))) then 891C 892 indx=ipowxyz(1,m1,l1)+ipowxyz(1,m2,l2)+ 893 * ipowxyz(1,m3,l3)+ipowxyz(1,m4,l4) 894 indy=ipowxyz(2,m1,l1)+ipowxyz(2,m2,l2)+ 895 * ipowxyz(2,m3,l3)+ipowxyz(2,m4,l4) 896 indz=ipowxyz(3,m1,l1)+ipowxyz(3,m2,l2)+ 897 * ipowxyz(3,m3,l3)+ipowxyz(3,m4,l4) 898 indx=mod(indx,2) 899 indy=mod(indy,2) 900 indz=mod(indz,2) 901C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 902C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 903C++++++++++++++++ SIGMA X ++++++++++++++++++++++++++++++++++++++++++++++++++++ 904C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 905C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 906 if (indx.eq.0.and.indy.eq.1.and.indz.eq.1.and. 907 * icheckxy(m1,m2,m3,m4)) then ! Y*Z -> transforms like L_x (B1) 908cbs integrals for sigma_x 909 mblockx=mblockx+1 910 mcombcart(1,m1,m2,m3,m4)=1 911 mcombcart(2,m1,m2,m3,m4)=mblockx 912 call tosigX(m1,m2,m3,m4,WRK(iangSO+iangfirst), 913 * mcombina,ncontrac(l1),ncontrac(l2),ncontrac(l3), 914 * ncontrac(l4),WRK(icartSO),preXZ, 915 * interxyz(1,iabs(m1),iabs(m2),iabs(m3),iabs(m4)),isgnprod, 916 * cleaner) 917c 918 if (.not.bonn.and.(.not.breiT)) 919 * call tosigX(m1,m2,m3,m4,WRK(iangOO+iangfirst), 920 * mcombina,ncontrac(l1),ncontrac(l2),ncontrac(l3), 921 * ncontrac(l4),WRK(icartOO),preXZ, 922 * interxyz(1,iabs(m1),iabs(m2),iabs(m3),iabs(m4)),isgnprod, 923 * cleaner) 924 if (makemean) then ! generate mean-field-contributions 925c########################################################################## 926c############ mean-field-part ############################################ 927c########################################################################## 928 if (l1.eq.l3.and.l2.eq.l4) then 929 if (m2.eq.m4.and.m1.lt.m3.and. 930 * iabs(m1+m3).eq.1.and.l1.ne.0) then 931 call two2mean13(WRK(icartSO),occup(1,l2), 932 * AOcoeffs(1,1,l2),onecartx(1,1,ipnt(m1+l1+1,m3+l3+1),l1), 933 * ncontrac(l1),ncontrac(l2),noccorb(l2)) 934 endif 935 endif 936 if (l1.eq.l2.and.l3.eq.l4) then 937 if (m1.eq.m2.and.l3.ne.0.and.l3.ne.l1) then 938 if (m3.lt.m4.and.iabs(m4+m3).eq.1) then 939cbs for the "Bonn-approach" exchange cartexOO by cartexSO 940 if (bonn.or.breiT) then 941 if (NFINI) call two2mean34a(WRK(icartSO), 942 * WRK(icartSO), 943 * occup(1,l1), 944 * AOcoeffs(1,1,l1),onecartx(1,1,ipnt(m3+l3+1,m4+l4+1),l3), 945 * ncontrac(l3),ncontrac(l1),noccorb(l2),sameorb) 946 else 947 if(NFINI) call two2mean34a(WRK(icartSO), 948 * WRK(icartOO), 949 * occup(1,l1), 950 * AOcoeffs(1,1,l1),onecartx(1,1,ipnt(m3+l3+1,m4+l4+1),l3), 951 * ncontrac(l3),ncontrac(l1),noccorb(l2),sameorb) 952 endif 953 endif 954 if (m3.gt.m4.and.iabs(m4+m3).eq.1) then 955cbs for the "Bonn-approach" exchange cartexOO by cartexSO 956 if (bonn.or.breiT) then 957 if (NFINI) call two2mean34b(WRK(icartSO), 958 * WRK(icartSO), 959 * occup(1,l1), 960 * AOcoeffs(1,1,l1),onecartx(1,1,ipnt(m3+l3+1,m4+l4+1),l3), 961 * ncontrac(l3),ncontrac(l1),noccorb(l2),sameorb) 962 else 963 if (NFINI) call two2mean34b(WRK(icartSO), 964 * WRK(icartOO), 965 * occup(1,l1), 966 * AOcoeffs(1,1,l1),onecartx(1,1,ipnt(m3+l3+1,m4+l4+1),l3), 967 * ncontrac(l3),ncontrac(l1),noccorb(l2),sameorb) 968 endif 969 endif 970 elseif(m3.eq.m4.and.l1.ne.0) then 971 if (m1.lt.m2.and.iabs(m1+m2).eq.1) then 972cbs for the "Bonn-approach" exchange cartexOO by cartexSO 973 if (bonn.or.breiT) then 974 if (NFINI) call two2mean12a(WRK(icartSO), 975 * WRK(icartSO),occup(1,l3), 976 * AOcoeffs(1,1,l3),onecartx(1,1,ipnt(m1+l1+1,m2+l2+1),l1), 977 * ncontrac(l1),ncontrac(l3),noccorb(l3),sameorb) 978 else 979 if (NFINI) call two2mean12a(WRK(icartSO), 980 * WRK(icartOO),occup(1,l3), 981 * AOcoeffs(1,1,l3),onecartx(1,1,ipnt(m1+l1+1,m2+l2+1),l1), 982 * ncontrac(l1),ncontrac(l3),noccorb(l3),sameorb) 983 endif 984 endif 985 if (m1.gt.m2.and.iabs(m1+m2).eq.1) then 986cbs for the "Bonn-approach" exchange cartexOO by cartexSO 987 if (bonn.or.breiT) then 988 if (NFINI) call two2mean12b(WRK(icartSO), 989 * WRK(icartSO),occup(1,l3), 990 * AOcoeffs(1,1,l3),onecartx(1,1,ipnt(m1+l1+1,m2+l2+1),l1), 991 * ncontrac(l1),ncontrac(l3),noccorb(l3),sameorb) 992 else 993 if (NFINI) call two2mean12b(WRK(icartSO), 994 * WRK(icartOO),occup(1,l3), 995 * AOcoeffs(1,1,l3),onecartx(1,1,ipnt(m1+l1+1,m2+l2+1),l1), 996 * ncontrac(l1),ncontrac(l3),noccorb(l3),sameorb) 997 endif 998 endif 999 endif 1000 endif 1001c########################################################################## 1002c############ mean-field-part ############################################ 1003c########################################################################## 1004 endif 1005C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1006C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1007C++++++++++++++++ SIGMA Y ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1008C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1009C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1010 elseif (indx.eq.1.and.indy.eq.0.and.indz.eq.1.and. 1011 * icheckxy(m1,m2,m3,m4)) then ! X*Z transforms like L_y (B2) 1012cbs integrals for sigma_y 1013 mblocky=mblocky+1 1014 mcombcart(1,m1,m2,m3,m4)=2 1015 mcombcart(2,m1,m2,m3,m4)=mblocky 1016 call tosigY(m1,m2,m3,m4,WRK(iangSO+iangfirst), 1017 * mcombina,ncontrac(l1),ncontrac(l2),ncontrac(l3), 1018 * ncontrac(l4),WRK(icartSO),preY, 1019 * interxyz(1,iabs(m1),iabs(m2),iabs(m3),iabs(m4)),isgnprod, 1020 * cleaner) 1021c 1022 if (.not.bonn.and.(.not.breit)) 1023 * call tosigY(m1,m2,m3,m4,WRK(iangOO+iangfirst), 1024 * mcombina,ncontrac(l1),ncontrac(l2),ncontrac(l3), 1025 * ncontrac(l4),WRK(icartOO),preY, 1026 * interxyz(1,iabs(m1),iabs(m2),iabs(m3),iabs(m4)),isgnprod, 1027 * cleaner) 1028 if (makemean) then ! generate mean-field-contributions 1029c########################################################################## 1030c############ mean-field-part ############################################ 1031c########################################################################## 1032 if (l1.eq.l3.and.l2.eq.l4) then 1033 if (m2.eq.m4.and.m1.lt.m3. 1034 * and.iabs(m3-m1).eq.1.and.l1.ne.0) then 1035 call two2mean13(WRK(icartSO),occup(1,l2), 1036 * AOcoeffs(1,1,l2),onecartY(1,1,ipnt(m1+l1+1,m3+l3+1),l1), 1037 * ncontrac(l1),ncontrac(l2),noccorb(l2)) 1038 endif 1039 endif 1040 if (l1.eq.l2.and.l3.eq.l4) then 1041 if (m1.eq.m2.and.l3.ne.0.and.l3.ne.l1) then 1042 if (m3.lt.m4.and.iabs(m3-m4).eq.1) then 1043cbs for the "Bonn-approach" exchange carteYOO by carteYSO 1044 if (bonn.or.breiT) then 1045 if (NFINI) call two2mean34a(WRK(icartSO), 1046 * WRK(icartSO),occup(1,l1), 1047 * AOcoeffs(1,1,l1),onecartY(1,1,ipnt(m3+l3+1,m4+l4+1),l3), 1048 * ncontrac(l3),ncontrac(l1),noccorb(l2),sameorb) 1049 else 1050 if (NFINI) call two2mean34a(WRK(icartSO), 1051 * WRK(icartOO),occup(1,l1), 1052 * AOcoeffs(1,1,l1),onecartY(1,1,ipnt(m3+l3+1,m4+l4+1),l3), 1053 * ncontrac(l3),ncontrac(l1),noccorb(l2),sameorb) 1054 endif 1055 endif 1056 if (m3.gt.m4.and.iabs(m3-m4).eq.1) then 1057cbs for the "Bonn-approach" exchange carteYOO by carteYSO 1058 if (bonn.or.breiT) then 1059 if (NFINI) call two2mean34b(WRK(icartSO), 1060 * WRK(icartSO),occup(1,l1), 1061 * AOcoeffs(1,1,l1),onecartY(1,1,ipnt(m3+l3+1,m4+l4+1),l3), 1062 * ncontrac(l3),ncontrac(l1),noccorb(l2),sameorb) 1063 else 1064 if (NFINI) call two2mean34b(WRK(icartSO), 1065 * WRK(icartOO),occup(1,l1), 1066 * AOcoeffs(1,1,l1),onecartY(1,1,ipnt(m3+l3+1,m4+l4+1),l3), 1067 * ncontrac(l3),ncontrac(l1),noccorb(l2),sameorb) 1068 endif 1069 endif 1070 elseif(m3.eq.m4.and.l1.ne.0) then 1071 if (m1.lt.m2.and.iabs(m1-m2).eq.1) then 1072cbs for the "Bonn-approach" exchange carteOO by carteSO 1073 if (bonn.or.breiT) then 1074 if (NFINI) call two2mean12a(WRK(icartSO), 1075 * WRK(icartSO),occup(1,l3), 1076 * AOcoeffs(1,1,l3),onecartY(1,1,ipnt(m1+l1+1,m2+l2+1),l1), 1077 * ncontrac(l1),ncontrac(l3),noccorb(l3),sameorb) 1078 else 1079 if (NFINI) call two2mean12a(WRK(icartSO), 1080 * WRK(icartOO),occup(1,l3), 1081 * AOcoeffs(1,1,l3),onecartY(1,1,ipnt(m1+l1+1,m2+l2+1),l1), 1082 * ncontrac(l1),ncontrac(l3),noccorb(l3),sameorb) 1083 endif 1084 endif 1085 if (m1.gt.m2.anD.Iabs(m1-m2).eq.1) then 1086cbs for the "Bonn-approach" exchange carteYOO by carteYSO 1087 if (bonn.or.breiT) then 1088 if (NFINI) call two2mean12b(WRK(icartSO), 1089 * WRK(icartSO),occup(1,l3), 1090 * AOcoeffs(1,1,l3),onecartY(1,1,ipnt(m1+l1+1,m2+l2+1),l1), 1091 * ncontrac(l1),ncontrac(l3),noccorb(l3),sameorb) 1092 else 1093 if (NFINI) call two2mean12b(WRK(icartSO), 1094 * WRK(icartOO),occup(1,l3), 1095 * AOcoeffs(1,1,l3),onecartY(1,1,ipnt(m1+l1+1,m2+l2+1),l1), 1096 * ncontrac(l1),ncontrac(l3),noccorb(l3),sameorb) 1097 endif 1098 endif 1099 endif 1100 endif 1101c########################################################################## 1102c############ mean-field-part ############################################ 1103c########################################################################## 1104 endif 1105C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1106C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1107C++++++++++++++++ SIGMA Z ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1108C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1109C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1110 elseif (indx.eq.1.and.indy.eq.1.and.indz.eq.0.and. 1111 * icheckz(m1,m2,m3,m4)) then ! X*Y transforms like L_z (A2) 1112cbs integrals for sigma_z 1113 mblockz=mblockz+1 1114 mcombcart(1,m1,m2,m3,m4)=3 1115 mcombcart(2,m1,m2,m3,m4)=mblockz 1116 call tosigZ(m1,m2,m3,m4,WRK(iangSO+iangfirst), 1117 * mcombina,ncontrac(l1),ncontrac(l2),ncontrac(l3), 1118 * ncontrac(l4),WRK(icartSO),preXZ, 1119 * interxyz(1,iabs(m1),iabs(m2),iabs(m3),iabs(m4)),isgnprod, 1120 * cleaner) 1121c 1122 if (.not.bonn.and.(.not.breit)) 1123 * call tosigZ(m1,m2,m3,m4,WRK(iangOO+iangfirst), 1124 * mcombina,ncontrac(l1),ncontrac(l2),ncontrac(l3), 1125 * ncontrac(l4),WRK(icartOO),preXZ, 1126 * interxyz(1,iabs(m1),iabs(m2),iabs(m3),iabs(m4)),isgnprod, 1127 * cleaner) 1128 if (makemean) then ! generate mean-field-contributions 1129c########################################################################## 1130c############ mean-field-part ############################################ 1131c########################################################################## 1132 if (l1.eq.l3.and.l2.eq.l4) then 1133 if (m2.eq.m4.and.m1.lt.m3. 1134 * and.m1.eq.-m3.and.l1.ne.0) then 1135 call two2mean13(WRK(icartSO),occup(1,l2), 1136 * AOcoeffs(1,1,l2),onecartz(1,1,ipnt(m1+l1+1,m3+l3+1),l1), 1137 * ncontrac(l1),ncontrac(l2),noccorb(l2)) 1138 endif 1139 endif 1140 if (l1.eq.l2.and.l3.eq.l4) then 1141 if (m1.eq.m2.and.l3.ne.0.and.l3.ne.l1) then 1142 if (m3.lt.m4.and.m3.eq.-m4) then 1143cbs for the "Bonn-approach" exchange carteOO by carteSO 1144 if (bonn.or.breiT) then 1145 if (NFINI) call two2mean34a(WRK(icartSO), 1146 * WRK(icartSO),occup(1,l1), 1147 * AOcoeffs(1,1,l1),onecartz(1,1,ipnt(m3+l3+1,m4+l4+1),l3), 1148 * ncontrac(l3),ncontrac(l1),noccorb(l2),sameorb) 1149 else 1150 if (NFINI) call two2mean34a(WRK(icartSO), 1151 * WRK(icartOO),occup(1,l1), 1152 * AOcoeffs(1,1,l1),onecartz(1,1,ipnt(m3+l3+1,m4+l4+1),l3), 1153 * ncontrac(l3),ncontrac(l1),noccorb(l2),sameorb) 1154 endif 1155 endif 1156 if (m3.gt.m4.and.m3.eq.-m4) then 1157cbs for the "Bonn-approach" exchange carteOO by carteSO 1158 if (bonn.or.breiT) then 1159 if (NFINI) call two2mean34b(WRK(icartSO), 1160 * WRK(icartSO),occup(1,l1), 1161 * AOcoeffs(1,1,l1),onecartz(1,1,ipnt(m3+l3+1,m4+l4+1),l3), 1162 * ncontrac(l3),ncontrac(l1),noccorb(l2),sameorb) 1163 else 1164 if (NFINI) call two2mean34b(WRK(icartSO), 1165 * WRK(icartOO), 1166 * occup(1,l1), 1167 * AOcoeffs(1,1,l1),onecartz(1,1,ipnt(m3+l3+1,m4+l4+1),l3), 1168 * ncontrac(l3),ncontrac(l1),noccorb(l2),sameorb) 1169 endif 1170 endif 1171 elseif(m3.eq.m4.and.l1.ne.0) then 1172 if (m1.lt.m2.and.m1.eq.-m2) then 1173cbs for the "Bonn-approach" exchange carteOO by carteSO 1174 if (bonn.or.breiT) then 1175 if (NFINI) call two2mean12a(WRK(icartSO), 1176 * WRK(icartSO),occup(1,l3), 1177 * AOcoeffs(1,1,l3),onecartz(1,1,ipnt(m1+l1+1,m2+l2+1),l1), 1178 * ncontrac(l1),ncontrac(l3),noccorb(l3),sameorb) 1179 else 1180 if (NFINI) call two2mean12a(WRK(icartSO), 1181 * WRK(icartOO), 1182 * occup(1,l3), 1183 * AOcoeffs(1,1,l3),onecartz(1,1,ipnt(m1+l1+1,m2+l2+1),l1), 1184 * ncontrac(l1),ncontrac(l3),noccorb(l3),sameorb) 1185 endif 1186 endif 1187 if (m1.gt.m2.and.m1.eq.-m2) then 1188cbs for the "Bonn-approach" exchange carteOO by carteSO 1189 if (bonn.or.breiT) then 1190 if (NFINI) call two2mean12b(WRK(icartSO), 1191 * WRK(icartSO), 1192 * occup(1,l3), 1193 * AOcoeffs(1,1,l3),onecartz(1,1,ipnt(m1+l1+1,m2+l2+1),l1), 1194 * ncontrac(l1),ncontrac(l3),noccorb(l3),sameorb) 1195 else 1196 if (NFINI) call two2mean12b(WRK(icartSO), 1197 * WRK(icartOO), 1198 * occup(1,l3), 1199 * AOcoeffs(1,1,l3),onecartz(1,1,ipnt(m1+l1+1,m2+l2+1),l1), 1200 * ncontrac(l1),ncontrac(l3),noccorb(l3),sameorb) 1201 endif 1202 endif 1203 endif 1204 endif 1205c########################################################################## 1206c############ mean-field-part ############################################ 1207c########################################################################## 1208 endif 1209 endif 1210C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1211C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1212C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1213C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1214 endif ! for check of significance for meanfield. 1215 enddo 1216 enddo 1217 enddo 1218 enddo 1219 numbcart=numbcart+(mblockx+mblocky+mblockz)*ncont 1220cbs just controlling if x and y integrals have the same number of blocks 1221 if (mblockx.ne.mblocky) then 1222 write(LUPRI,*) 1223 *'numbers of integrals for sigma_x and sigma_y not equal!' 1224 write(LUPRI,'(A12,4I3,2(A3,I5))') 1225 *'l1,l2,l3,l4 ',l1,l2,l3,l4,' X:',mblockx,' Y:',mblocky 1226 write(LUPRI,*) ' check the ipowxyz-array' 1227 CALL QUIT('Problems with IPOWXYA array in AMFI') 1228 endif 1229cbs start adresses for the next <ll|ll> block of integrals 1230 endif 1231 endif 1232 endif 1233 endif 1234 enddo 1235 enddo 1236 enddo 1237 enddo 1238 return 1239 end 1240 subroutine buildcoul(l1,l2,l3,l4,! angular momenta of primitives 1241 *incl1,incl3, ! shifts for different radial integrals 1242 *Lrun, ! L-value for coulomb integrals 1243 *prmints, 1244 *nprim1,nprim2,nprim3,nprim4, ! number of primitives 1245 *expo1,expo2,expo3,expo4, ! arrays with the exponents 1246 *power13, 1247 *power24, 1248 *quotpow1,quotpow2 1249 *) 1250cbs ################################################################## 1251c 1252cbs purpose: builds up the coulomb integrals 1253cbs inbetween primitives and multiplies 1254cbs with extra factors to correct the 1255cbs normalization 1256c 1257cbs ################################################################## 1258#include "implicit.h" 1259#include "para.h" 1260#include "amfi_param.h" 1261#include "dofuc.h" 1262#include "pi.h" 1263 dimension expo1(nprim1), 1264 *expo2(nprim2), 1265 *expo3(nprim3), 1266 *expo4(nprim4), ! the exponents 1267 *prmints(nprim1,nprim2,nprim3,nprim4), ! scratch array for integrals over primitives 1268 *power13(MxprimL,MxprimL), 1269 *power24(MxprimL,MxprimL), 1270 *quotpow1(nprim1,nprim2,nprim3,nprim4), 1271 *quotpow2(nprim1,nprim2,nprim3,nprim4), 1272 *fraclist1(0:Lmax+3),fraclist2(0:Lmax+3),fact(MxprimL), 1273 *frac(MxprimL),cfunctx1(MxprimL),cfunctx2(MxprimL) 1274 root8ovpi=dsqrt(8d0/pi) 1275cbs ################################################################## 1276cbs prepare indices for coulint 1277cbs ################################################################## 1278 n1=l1+incl1+1 1279 n2=l2+1 1280 n3=l3+incl3+1 1281 n4=l4+1 1282 n13=n1+n3 1283 n24=n2+n4 1284 index1=N13-Lrun-1 1285 index2=n24+Lrun 1286 index3=N24-Lrun-1 1287 index4=n13+Lrun 1288 do krun=0,(index1-1)/2 1289 fraclist1(krun)=dffrac(krun+krun+index2-1,krun+krun)* 1290 *dffrac(1,index2-1) 1291 enddo 1292 do krun=0,(index3-1)/2 1293 fraclist2(krun)=dffrac(krun+krun+index4-1,krun+krun)* 1294 *dffrac(1,index4-1) 1295 enddo 1296cbs ################################################################## 1297cbs common factors including double factorials 1298cbs ################################################################## 1299 doff1=dffrac(index1-1,n13-1)*dffrac(n24+Lrun-1,n24-1) 1300 doff2=dffrac(index3-1,n24-1)*dffrac(n13+Lrun-1,n13-1) 1301 if (index1.eq.1) then 1302 do irun4=1,nprim4 1303 do irun3=1,nprim3 1304 if (l2.eq.l4) then 1305 limit2=irun4 1306 else 1307 limit2=nprim2 1308 endif 1309 do irun2=1,limit2 1310 pow24inv=doff1/power24(irun4,irun2) 1311 if (l1.eq.l3) then 1312 limit1=irun3 1313 else 1314 limit1=nprim1 1315 endif 1316 do irun1=1,limit1 1317 prmints(irun1,irun2,irun3,irun4)= 1318 * quotpow1(irun1,irun2,irun3,irun4)* 1319 * dsqrt(0.5d0*(expo1(irun1)+expo3(irun3)))* 1320 * power13(irun3,irun1)*pow24inv 1321 enddo 1322 enddo 1323 enddo 1324 enddo 1325 else 1326 do irun4=1,nprim4 1327 do irun3=1,nprim3 1328 if (l2.eq.l4) then 1329 limit2=irun4 1330 else 1331 limit2=nprim2 1332 endif 1333 do irun2=1,limit2 1334 alpha24inv=1d0/(expo2(irun2)+expo4(irun4)) 1335 pow24inv=doff1/power24(irun4,irun2) 1336 if (l1.eq.l3) then 1337 limit1=irun3 1338 else 1339 limit1=nprim1 1340 endif 1341 do irun1=1,limit1 1342 a1324= alpha24inv*(expo1(irun1)+expo3(irun3)) 1343 Cfunctx1(irun1)=fraclist1(0) 1344 frac(irun1)=a1324/(1d0+a1324) 1345 fact(irun1)=frac(irun1) 1346 enddo 1347*vocl loop,repeat(Lmax+3) 1348 do k=1,(index1-1)/2 1349 do irun1=1,limit1 1350 Cfunctx1(irun1)=Cfunctx1(irun1)+fraclist1(k) 1351 * *fact(irun1) 1352 enddo 1353 do irun1=1,limit1 1354 fact(irun1)=fact(irun1)*frac(irun1) 1355 enddo 1356 enddo 1357 do irun1=1,limit1 1358 alpha13=0.5d0*(expo1(irun1)+expo3(irun3)) 1359 prmints(irun1,irun2,irun3,irun4)= 1360 * quotpow1(irun1,irun2,irun3,irun4)* 1361 * dsqrt(alpha13)*power13(irun3,irun1)*pow24inv* 1362 * Cfunctx1(irun1) 1363 enddo 1364 enddo 1365 enddo 1366 enddo 1367 endif 1368 if (index3.eq.1) then 1369 do irun4=1,nprim4 1370 do irun3=1,nprim3 1371 if (l2.eq.l4) then 1372 limit2=irun4 1373 else 1374 limit2=nprim2 1375 endif 1376 do irun2=1,limit2 1377 pow24=doff2*power24(irun4,irun2)* 1378 * dsqrt(0.5d0*(expo2(irun2)+expo4(irun4))) 1379 if (l1.eq.l3) then 1380 limit1=irun3 1381 else 1382 limit1=nprim1 1383 endif 1384 do irun1=1,limit1 1385 prmints(irun1,irun2,irun3,irun4)= 1386 * prmints(irun1,irun2,irun3,irun4)+ 1387 * pow24*quotpow2(irun1,irun2,irun3,irun4)/ 1388 * power13(irun3,irun1) 1389 enddo 1390 enddo 1391 enddo 1392 enddo 1393 else 1394 do irun4=1,nprim4 1395 do irun3=1,nprim3 1396 if (l2.eq.l4) then 1397 limit2=irun4 1398 else 1399 limit2=nprim2 1400 endif 1401 do irun2=1,limit2 1402 alpha24=expo2(irun2)+expo4(irun4) 1403 pow24=doff2*power24(irun4,irun2)* 1404 * dsqrt(0.5d0*alpha24) 1405 if (l1.eq.l3) then 1406 limit1=irun3 1407 else 1408 limit1=nprim1 1409 endif 1410 do irun1=1,limit1 1411 a2413= alpha24/(expo1(irun1)+expo3(irun3)) 1412 Cfunctx2(irun1)=fraclist2(0) 1413 frac(irun1)=a2413/(1d0+a2413) 1414 fact(irun1)=frac(irun1) 1415 enddo 1416*vocl loop,repeat(Lmax+3) 1417 do k=1,(index3-1)/2 1418 do irun1=1,limit1 1419 Cfunctx2(irun1)=Cfunctx2(irun1)+ 1420 * fraclist2(k)*fact(irun1) 1421 enddo 1422 do irun1=1,limit1 1423 fact(irun1)=fact(irun1)*frac(irun1) 1424 enddo 1425 enddo 1426 do irun1=1,limit1 1427 prmints(irun1,irun2,irun3,irun4)= 1428 * prmints(irun1,irun2,irun3,irun4)+ 1429 * quotpow2(irun1,irun2,irun3,irun4)* 1430 * Cfunctx2(irun1)* 1431 * pow24/power13(irun3,irun1) 1432 enddo 1433 enddo 1434 enddo 1435 enddo 1436 endif 1437cbs make some mirroring for identical l-values 1438cbs for the case that l1=l3 1439 if (l1.eq.l3) then 1440 do irun4=1,nprim4 1441 do irun3=1,nprim3 1442 do irun2=1,nprim2 1443 do irun1=irun3+1,nprim1 1444 prmints(irun1,irun2,irun3,irun4)= 1445 *prmints(irun3,irun2,irun1,irun4) 1446 enddo 1447 enddo 1448 enddo 1449 enddo 1450 endif 1451cbs for the case that l2=l4 1452 if (l2.eq.l4) then 1453 do irun4=1,nprim4 1454 do irun3=1,nprim3 1455 do irun2=irun4+1,nprim2 1456 do irun1=1,nprim1 1457 prmints(irun1,irun2,irun3,irun4)= 1458 *prmints(irun1,irun4,irun3,irun2) 1459 enddo 1460 enddo 1461 enddo 1462 enddo 1463 endif 1464cbs some factors which are the same for all cases 1465 do irun4=1,nprim4 1466 do irun3=1,nprim3 1467 do irun2=1,nprim2 1468 do irun1=1,nprim1 1469 prmints(irun1,irun2,irun3,irun4)= 1470 *prmints(irun1,irun2,irun3,irun4)* 1471 *coulovlp(irun4,irun2,0,0,l4,l2)* 1472 *coulovlp(irun3,irun1,incl3,incl1,l3,l1)* 1473 *root8ovpi 1474 enddo 1475 enddo 1476 enddo 1477 enddo 1478cbs 1479cbs look for additional factors, as the 1480cbs coulomb integrals are calculated 1481cbs for normalized functions with that 1482cbs specific l 1483cbs 1484cbs if l was increased by one, the factor is 1485cbs 0.5*dsqrt((2l+3)/(exponent)) 1486cbs if l was decreased by one, the factor is 1487cbs 2d0*dsqrt(exponent/(2l+1)) 1488cbs 1489cbs 1490cbs check for first function 1491cbs 1492cbs 1493 if (incl1.eq.1) then 1494 fact1=0.5d0*dsqrt(dfloat(l1+l1+3)) 1495 do irun4=1,nprim4 1496 do irun3=1,nprim3 1497 do irun2=1,nprim2 1498 do irun1=1,nprim1 1499 factor=fact1/dsqrt(expo1(irun1)) 1500 prmints(irun1,irun2,irun3,irun4)= 1501 *prmints(irun1,irun2,irun3,irun4)*factor 1502 enddo 1503 enddo 1504 enddo 1505 enddo 1506 elseif (incl1.eq.-1) then 1507 fact1=2d0/dsqrt(dfloat(l1+l1+1)) 1508 do irun4=1,nprim4 1509 do irun3=1,nprim3 1510 do irun2=1,nprim2 1511 do irun1=1,nprim1 1512 factor=fact1*dsqrt(expo1(irun1)) 1513 prmints(irun1,irun2,irun3,irun4)= 1514 *prmints(irun1,irun2,irun3,irun4)*factor 1515 enddo 1516 enddo 1517 enddo 1518 enddo 1519 endif 1520cbs 1521cbs 1522cbs check for third function 1523cbs 1524cbs 1525 if (incl3.eq.1) then 1526 fact1=0.5d0*dsqrt(dfloat(l3+l3+3)) 1527 do irun4=1,nprim4 1528 do irun3=1,nprim3 1529 do irun2=1,nprim2 1530 do irun1=1,nprim1 1531 factor=fact1/dsqrt(expo3(irun3)) 1532 prmints(irun1,irun2,irun3,irun4)= 1533 *prmints(irun1,irun2,irun3,irun4)*factor 1534 enddo 1535 enddo 1536 enddo 1537 enddo 1538 elseif (incl3.eq.-1) then 1539 fact1=2d0/dsqrt(dfloat(l3+l3+1)) 1540 do irun4=1,nprim4 1541 do irun3=1,nprim3 1542 do irun2=1,nprim2 1543 do irun1=1,nprim1 1544 factor=fact1*dsqrt(expo3(irun3)) 1545 prmints(irun1,irun2,irun3,irun4)= 1546 *prmints(irun1,irun2,irun3,irun4)*factor 1547 enddo 1548 enddo 1549 enddo 1550 enddo 1551 endif 1552 return 1553 end 1554 subroutine cartoneX(L,Lmax,onecontr,ncontrac, 1555 *MxcontL,onecartX) 1556#include "implicit.h" 1557 dimension onecontr(MxcontL,MxcontL,-Lmax:Lmax,3), 1558 *onecartX(MxcontL,MxcontL,(Lmax+Lmax+1)*(Lmax+1)) 1559cbs arranges the cartesian one-elctron-integrals for X on a 1560cbs quadratic matrix 1561 ipnt(I,J)=(max(i,j)*(max(i,j)-1))/2+min(i,j) 1562cbs - + Integrals m || mprime mprime=m+1 1563 do Mprime=2,L 1564 M=mprime-1 1565 iaddr=ipnt(Mprime+L+1,-M+L+1) 1566 do jcont=1,ncontrac 1567 do icont=1,ncontrac 1568 onecartX(icont,jcont,iaddr)= 1569 *onecartX(icont,jcont,iaddr) 1570 *-0.25d0*( 1571 *onecontr(icont,jcont,Mprime,1)+ 1572 *onecontr(icont,jcont,-Mprime,3)) 1573 enddo 1574 enddo 1575 enddo 1576cbs - + Integrals m || mprime mprime=m-1 1577 do Mprime=1,L-1 1578 M=mprime+1 1579 iaddr=ipnt(Mprime+L+1,-M+L+1) 1580 do jcont=1,ncontrac 1581 do icont=1,ncontrac 1582 onecartX(icont,jcont,iaddr)= 1583 *onecartX(icont,jcont,iaddr) 1584 *-0.25d0*( 1585 *onecontr(icont,jcont,Mprime,3)+ 1586 *onecontr(icont,jcont,-Mprime,1)) 1587 enddo 1588 enddo 1589 enddo 1590cbs -1 || 0 integrals 1591 pre=dsqrt(0.125d0) 1592 iaddr=ipnt(L,L+1) 1593 do jcont=1,ncontrac 1594 do icont=1,ncontrac 1595 onecartX(icont,jcont,iaddr)= 1596 *onecartX(icont,jcont,iaddr) 1597 *-pre* (onecontr(icont,jcont,0,3)+ 1598 *onecontr(icont,jcont,0,1) ) 1599 enddo 1600 enddo 1601 return 1602 end 1603 subroutine cartoneY(L,Lmax,onecontr,ncontrac, 1604 *MxcontL,onecartY) 1605#include "implicit.h" 1606 dimension onecontr(MxcontL,MxcontL,-Lmax:Lmax,3), 1607 *onecartY(MxcontL,MxcontL,(Lmax+Lmax+1)*(Lmax+1)) 1608cbs arranges the cartesian one-electron integrals for Y 1609cbs on a quadratic matrix 1610 ipnt(I,J)=(max(i,j)*(max(i,j)-1))/2+min(i,j) 1611cbs + + Integrals m || mprime mprime=m+1 1612 do Mprime=2,L 1613 M=mprime-1 1614 iaddr=ipnt(Mprime+L+1,M+L+1) 1615 do jcont=1,ncontrac 1616 do icont=1,ncontrac 1617 onecartY(icont,jcont,iaddr)= 1618 *onecartY(icont,jcont,iaddr) 1619 *-0.25d0*( 1620 *onecontr(icont,jcont,Mprime,1)+ 1621 *onecontr(icont,jcont,-Mprime,3)) 1622 enddo 1623 enddo 1624 enddo 1625cbs - - Integrals m || mprime mprime=m-1 1626 do Mprime=1,L-1 1627 M=mprime+1 1628 iaddr=ipnt(-Mprime+L+1,-M+L+1) 1629 do jcont=1,ncontrac 1630 do icont=1,ncontrac 1631 onecartY(icont,jcont,iaddr)= 1632 *onecartY(icont,jcont,iaddr) 1633 *+0.25d0*( 1634 *onecontr(icont,jcont,Mprime,3)+ 1635 *onecontr(icont,jcont,-Mprime,1)) 1636 enddo 1637 enddo 1638 enddo 1639cbs 0 || 1 integrals 1640 pre=-dsqrt(0.125d0) 1641 iaddr=ipnt(L+1,L+2) 1642 do jcont=1,ncontrac 1643 do icont=1,ncontrac 1644 onecartY(icont,jcont,iaddr)= 1645 *onecartY(icont,jcont,iaddr) 1646 *+pre* 1647 *(onecontr(icont,jcont,1,1)+ 1648 *onecontr(icont,jcont,-1,3)) 1649 enddo 1650 enddo 1651 return 1652 end 1653 subroutine cartoneZ(L,Lmax,onecontr,ncontrac, 1654 *MxcontL,onecartZ) 1655#include "implicit.h" 1656 dimension onecontr(MxcontL,MxcontL,-Lmax:Lmax,3), 1657 *onecartZ(MxcontL,MxcontL,(Lmax+Lmax+1)*(Lmax+1)) 1658cbs arranges the cartesian one-electron integrals for Z 1659cbs on a quadratic matrix 1660 ipnt(I,J)=(max(i,j)*(max(i,j)-1))/2+min(i,j) 1661cbs - + Integrals m || mprime mprime=m 1662 do Mprime=1,L 1663 iaddr=ipnt(Mprime+L+1,-mprime+L+1) 1664 do jcont=1,ncontrac 1665 do icont=1,ncontrac 1666 onecartZ(icont,jcont,iaddr)= 1667 *onecartZ(icont,jcont,iaddr)+ 1668 *0.5d0*( 1669 *onecontr(icont,jcont,Mprime,2)- 1670 *onecontr(icont,jcont,-Mprime,2)) 1671 enddo 1672 enddo 1673 enddo 1674 return 1675 end 1676 subroutine chngcont(coeffs,coeffst1,coeffst1a,coeffst2, 1677 *coeffst2a,ncont,nprims,evec, 1678 *type1,type2,work,work2,work3,MxprimL, 1679 *rootOVLP,OVLPinv,exponents) 1680c############################################################################### 1681cbs purpose: makes out of old contraction coefficients(in normalized functions) 1682cbs new coefficients including the kinematical factors 1683cbs using the diagonal matrices on type1 and type2 (see subroutine kinemat) 1684cbs coeffst1a and coeffst2a additionally include the exponents alpha 1685cbs (that is why ....a). So the exponents in the integrals are moved 1686cbs to the contraction coefficients and not in some way into the primitive 1687cbs integrals. 1688cbs 1689cbs the different cases for contracted integrals differ later on in the 1690cbs choice of different sets of contraction coefficients. 1691cbs 1692c############################################################################### 1693#include "implicit.h" 1694 dimension coeffs(nprims,ncont), ! original contraction coefficients 1695 *coeffst1(nprims,ncont), ! A * contraction coefficients 1696 *coeffst1a(nprims,ncont), ! A * alpha*contraction coefficients 1697 *coeffst2a(nprims,ncont), ! c*A/(E+m) * contraction coefficients 1698 *coeffst2(nprims,ncont), ! c*A/(E+m) * alpha *contraction coefficients 1699 *evec(nprims,nprims), 1700 *work(nprims,nprims) , 1701 *work2(nprims,nprims) , 1702 *work3(nprims,nprims) , 1703 *rootOVLP(MxprimL,*), 1704 *OVLPinv(MxprimL,*), 1705 *type1(*),type2(*), 1706 *exponents(*) 1707cbs 1708cbs first new coefficients for type1 (A) 1709cbs generate a transformation matrix on work 1710cbs 1711 do J=1,nprims 1712 do I=1,nprims 1713 work(I,J)=0d0 1714 work2(I,J)=0d0 1715 work3(I,J)=0d0 1716 enddo 1717 enddo 1718cbs build up the transformation matrix 1719 do K=1,nprims 1720 do J=1,nprims 1721 do I=1,nprims 1722 work(I,J)=work(I,J)+evec(I,K)*type1(K)*evec(J,K) 1723 enddo 1724 enddo 1725 enddo 1726 do K=1,nprims 1727 do J=1,nprims 1728 do I=1,nprims 1729 work2(I,J)=work2(I,J)+work(I,K)*rootOVLP(K,J) 1730 enddo 1731 enddo 1732 enddo 1733 do K=1,nprims 1734 do J=1,nprims 1735 do I=1,nprims 1736 work3(I,J)=work3(I,J)+rootOVLP(I,K)*work2(K,J) 1737 enddo 1738 enddo 1739 enddo 1740 do J=1,nprims 1741 do I=1,nprims 1742 work(I,J)=0d0 1743 enddo 1744 enddo 1745 do K=1,nprims 1746 do J=1,nprims 1747 do I=1,nprims 1748 work(J,I)=work(J,I)+OVLPinv(I,K)*work3(K,J) 1749 enddo 1750 enddo 1751 enddo 1752 do K=1,ncont 1753 do I=1,nprims 1754 coeffst1(I,K)=0d0 1755 enddo 1756 enddo 1757cbs now transform the vectors 1758 do K=1,ncont 1759 do J=1,nprims 1760 do I=1,nprims 1761 coeffst1(I,K)=coeffst1(I,K)+work(J,I)*coeffs(J,K) 1762 enddo 1763 enddo 1764 enddo 1765cbs 1766cbs now with exponent 1767cbs 1768 do K=1,ncont 1769 do I=1,nprims 1770 coeffst1a(I,K)=exponents(I)*coeffst1(I,K) 1771 enddo 1772 enddo 1773cbs 1774cbs and now the same for the other type A/(E+m) 1775cbs 1776 do J=1,nprims 1777 do I=1,nprims 1778 work(I,J)=0d0 1779 work2(I,J)=0d0 1780 work3(I,J)=0d0 1781 enddo 1782 enddo 1783cbs build up the transformation matrix 1784 do K=1,nprims 1785 do J=1,nprims 1786 do I=1,nprims 1787 work(I,J)=work(I,J)+evec(I,K)*type2(K)*evec(J,K) 1788 enddo 1789 enddo 1790 enddo 1791 do K=1,nprims 1792 do J=1,nprims 1793 do I=1,nprims 1794 work2(I,J)=work2(I,J)+work(I,K)*rootOVLP(K,J) 1795 enddo 1796 enddo 1797 enddo 1798 do K=1,nprims 1799 do J=1,nprims 1800 do I=1,nprims 1801 work3(I,J)=work3(I,J)+rootOVLP(I,K)*work2(K,J) 1802 enddo 1803 enddo 1804 enddo 1805 do J=1,nprims 1806 do I=1,nprims 1807 work(I,J)=0d0 1808 enddo 1809 enddo 1810 do K=1,nprims 1811 do J=1,nprims 1812 do I=1,nprims 1813 work(J,I)=work(J,I)+OVLPinv(I,K)*work3(K,J) 1814 enddo 1815 enddo 1816 enddo 1817 do K=1,ncont 1818 do I=1,nprims 1819 coeffst2(I,K)=0d0 1820 enddo 1821 enddo 1822cbs now transform the vectors 1823 do K=1,ncont 1824 do J=1,nprims 1825 do I=1,nprims 1826 coeffst2(I,K)=coeffst2(I,K)+work(J,I)*coeffs(J,K) 1827 enddo 1828 enddo 1829 enddo 1830cbs 1831cbs now with exponent 1832cbs 1833 do K=1,ncont 1834 do I=1,nprims 1835 coeffst2a(I,K)=exponents(I)*coeffst2(I,K) 1836 enddo 1837 enddo 1838 return 1839 end 1840 subroutine cont(L,breit,ifinite) 1841cbs########################################################################### 1842cbs cont prepares all required contraction coefficients for functions 1843cbs with angular momentum L 1844cbs########################################################################### 1845#include "implicit.h" 1846#include "para.h" 1847#include "amfi_param.h" 1848 dimension tkintria((MxprimL*MxprimL+MxprimL)/2) 1849 logical breit,breit_finite 1850 breit_finite=.true. 1851cbs transcon transfers and normalizes contracted functions 1852cbs ore more precizely the coefficients 1853 call transcon(cntscrtch(1,1,L),MxprimL, 1854 *MxcontL,normovlp(1,1,L), 1855 *contrarray(iaddori(L)),nprimit(L),ncontrac(L)) 1856cbs gentkin generates the matrix of kinetic energy TKIN 1857 call gentkin(L,TKIN,nprimit(L),exponents(1,L),rootOVLPinv(1,1,L)) 1858cbs kindiag diagonalizes TKIN 1859cbs for finite nucleus 1860 if (ifinite.eq.2.and.L.eq.0) then 1861 call kindiag(TKIN,TKINTRIA,nprimit(L),evec,eval,breit_finite) 1862 else 1863 call kindiag(TKIN,TKINTRIA,nprimit(L),evec,eval,breit) 1864 endif 1865cbs kinemat generates kinematic factors in 1866cbs the basis of eigenvectors 1867 call kinemat(L,nprimit(L),eval,type1,type2,Energy) 1868 incr=nprimit(L)*ncontrac(L) 1869cbs chngcont= changecont generates the contraction coeffs 1870cbs including kinematic factors and even exponents as factors 1871 call chngcont( 1872 *contrarray(iaddori(L)), 1873 *contrarray(iaddtyp1(L)), 1874 *contrarray(iaddtyp2(L)), 1875 *contrarray(iaddtyp3(L)), 1876 *contrarray(iaddtyp4(L)), 1877 *ncontrac(L),nprimit(L),evec, 1878 *type1,type2,scratch4,scratch4(nprimit(L)*nprimit(L)+1), 1879 *scratch4(2*nprimit(L)*nprimit(L)+1),MxprimL, 1880 *rootOVLP(1,1,L),OVLPinv(1,1,L), 1881 *exponents(1,L)) 1882 return 1883 end 1884 Subroutine contandmult(Lhigh,makemean,AIMP,oneonly,numballcart, 1885 *LUPROP,ifinite,WRK,LWRK) 1886#include "implicit.h" 1887#include "para.h" 1888#include "amfi_param.h" 1889#include "ired.h" 1890 logical makemean,AIMP,oneonly 1891 character*8 xa,ya,za 1892 dimension xa(4),ya(4),za(4) 1893 DIMENSION WRK(LWRK) 1894 common /nucleus/ charge,Exp_Finite 1895 double precision normasHERMIT(-Lmax:Lmax,0:Lmax) 1896 data ((normasHERMIT(ml,l),ml=-lmax,lmax),l=0,lmax) 1897 & /0.0d0,0.0d0,0.0d0,0.0d0,1.0d0,0.0d0,0.0d0,0.0d0,0.0d0, 1898 & 0.0d0,0.0d0,0.0d0,1.0d0,1.0d0,1.0d0,0.0d0,0.0d0,0.0d0, 1899 & 0.0d0,0.0d0,1.0d0,1.0d0,3.46410162d0, 1900 & 1.0d0,2.0d0,0.0d0,0.0d0, 1901 & 0.0d0,4.8989795d0,1.0d0,6.3245553d0,-2.5819889d0,6.3245553d0, 1902 & 2.0d0,-1.6329932d0,0.0d0, 1903 & 3.4641016d0,4.89897949d0,9.16515139d0,4.3204938d0, 1904 & -3.4156503d0,4.3204938d0,18.330303d0,-1.6329932d0,-6.9282032d0/ 1905cbs get back the real number of functions for the finite nucleus 1906 if (ifinite.eq.2) ncontrac(0)=ncontrac_keep 1907c############################################################################### 1908cbs subroutine to contract radial one-electron integrals 1909cbs and multiply them with angular factors 1910c############################################################################### 1911 xa(1)='********' 1912 ya(1)='********' 1913 za(1)='********' 1914 xa(2)=' ' 1915 ya(2)=' ' 1916 Za(2)=' ' 1917 xa(3)='ANTISYMM' 1918 ya(3)='ANTISYMM' 1919 Za(3)='ANTISYMM' 1920 xa(4)='X1MNF-SO' 1921 ya(4)='Y1MNF-SO' 1922 ZA(4)='Z1MNF-SO' 1923c 1924cbs clean the arrays for cartesian integrals 1925C 1926 length3=(numbalLcart*numbalLcart+numbalLcart)/2 1927 iloca=length3 1928CBS print *, 'iloca',iloca 1929 IOCAX = 1 1930 iocay=iocax+iloca 1931 iocaz=iocay+iloca 1932 iocax2=iocaz+iloca 1933 iocay2=iocax2+iloca 1934 iocaz2=iocay2+iloca 1935 KLAST = IOCAZ2 + ILOCA 1936 IF (KLAST .GT. LWRK) CALL STOPIT('AMFI ','CAMUL',KLAST,LFREE) 1937 call dzero(WRK(iocax),6*length3) 1938c 1939c 1940c 1941c 1942cbs one-electron-integrals: 1943cbs 1. index: number of first contracted function 1944cbs 2. index: number of second contracted function 1945cbs 3. index: pointer(m1,m2) m1< m2 otherwise change sign of integral 1946cbs 4. index: L-value 1947cbs onecartX(mxcontL,MxcontL,(Lmax+Lmax+1)*(Lmax+1),Lmax), 1948cbs onecartY(mxcontL,MxcontL,(Lmax+Lmax+1)*(Lmax+1),Lmax), 1949cbs onecartZ(mxcontL,MxcontL,(Lmax+Lmax+1)*(Lmax+1),Lmax) 1950c 1951c 1952c 1953cbs generate one-electron integrals for all L greater/equal 1 1954 if (ifinite.eq.2) charge=0d0 ! nuclear integrals are modelled for finite nucleus somewhere else 1955 do L=1,Lhigh 1956 call contone(L,oneoverr3(1,L),onecontr(1,1,-Lmax,1,L), 1957 * Lmax,contrarray(iaddtyp3(L)),nprimit(L),ncontrac(L), 1958 * MxcontL,dummyone, 1959 * onecartx(1,1,1,L),onecartY(1,1,1,L),onecartZ(1,1,1,L), 1960 * charge,oneonly) 1961 Enddo 1962c 1963cbs *********************************************************************** 1964cbs now move all integrals to one big arrays for X,Y,Z 1965cbs *********************************************************************** 1966 do Lrun=1,Lhigh !loop over L-values (integrals are diagonal in L) 1967 mrun=0 1968 do Msec=-Lrun,Lrun ! cartesian M-values (Mfirst,Msec) with 1969 do Mfirst=-Lrun,Msec ! Mfirst <= Msec (actually '=' does never appear 1970C 1971cbs determine if L_X L_Y or L_Z 1972 ipowx=ipowxyz(1,mfirst,Lrun)+ipowxyz(1,msec,Lrun) 1973 ipowy=ipowxyz(2,mfirst,Lrun)+ipowxyz(2,msec,Lrun) 1974 ipowz=ipowxyz(3,mfirst,Lrun)+ipowxyz(3,msec,Lrun) 1975c 1976 mrun=mrun+1 1977cbs now determine the irreducable representations 1978 iredfirst=iredLM(Mfirst,Lrun) 1979 iredsec=iredLM(Msec,Lrun) 1980cbs check out which IR is the lower one. 1981 if (iredfirst.le.iredsec) then 1982cbs calculate shift to get to the beginning of the block 1983 iredired=shiftIRIR((iredsec*iredsec-iredsec)/2+iredfirst) 1984 * +incrlm(Mfirst,Lrun)*itotalperIR(iredsec)+ 1985 * incrLM(Msec,Lrun) 1986 if (mod(ipowx,2).eq.0.and.mod(ipowy,2).eq.1.and. 1987 * mod(ipowz,2).eq.1) then 1988 do icartfirst=1,ncontrac(Lrun) ! loop over functions first index 1989 do icartsec=1,ncontrac(Lrun) ! loop over functions second index 1990CBS print *, 'iocax',iocax,iredired,icartsec 1991 WRK(iocax+iredired+(icartsec-1))= 1992 * WRK(iocax+iredired+(icartsec-1)) 1993 * +onecartx(icartfirst,icartsec,mrun,Lrun) 1994 enddo 1995cbs shift pointer by number of functions in IR 1996 iredired=iredired+itotalperIR(iredsec) 1997 enddo 1998 endif 1999 if (mod(ipowx,2).eq.1.and.mod(ipowy,2).eq.0.and. 2000 * mod(ipowz,2).eq.1) then 2001 do icartfirst=1,ncontrac(Lrun) ! loop over functions first index 2002 do icartsec=1,ncontrac(Lrun) ! loop over functions second index 2003 WRK(iocay+iredired+(icartsec-1))= 2004 * WRK(iocay+iredired+(icartsec-1)) 2005 * +onecarty(icartfirst,icartsec,mrun,Lrun) 2006 enddo 2007cbs shift pointer by number of functions in IR 2008 iredired=iredired+itotalperIR(iredsec) 2009 enddo 2010 endif 2011 if (mod(ipowx,2).eq.1.and.mod(ipowy,2).eq.1.and. 2012 * mod(ipowz,2).eq.0) then 2013 do icartfirst=1,ncontrac(Lrun) ! loop over functions first index 2014 do icartsec=1,ncontrac(Lrun) ! loop over functions second index 2015 WRK(iocaz+iredired+(icartsec-1))= 2016 * WRK(iocaz+iredired+(icartsec-1)) 2017 * +onecartz(icartfirst,icartsec,mrun,Lrun) 2018 enddo 2019cbs shift pointer by number of functions in IR 2020 iredired=iredired+itotalperIR(iredsec) 2021 enddo 2022 endif 2023 elseif (iredfirst.gt.iredsec) then 2024cbs In this case, indices are exchanged with respect to former 2025cbs symmetry of blocks. Therefore, there will be a minus sign 2026c 2027cbs calculate shift to get to the beginning of the block 2028 iredired=shiftIRIR((iredfirst*iredfirst-iredfirst)/2+ 2029 * iredsec)+ 2030 * incrLM(Msec,Lrun)*itotalperIR(iredfirst)+ 2031 * incrLM(Mfirst,Lrun) 2032 if (mod(ipowx,2).eq.0.and.mod(ipowy,2).eq.1.and. 2033 * mod(ipowz,2).eq.1) then 2034 do icartsec=1,ncontrac(Lrun) !loop over functions second index 2035 do icartfirst=1,ncontrac(Lrun) !loop over functions first index 2036 WRK(iocax+iredired+(icartfirst-1))= 2037 * WRK(iocax+iredired+(icartfirst-1)) 2038 * -onecartx(icartsec,icartfirst,mrun,Lrun) 2039 enddo 2040cbs shift pointer by number of functions in IR 2041 iredired=iredired+itotalperIR(iredfirst) 2042 enddo 2043 endif 2044 if (mod(ipowx,2).eq.1.and.mod(ipowy,2).eq.0.and. 2045 * mod(ipowz,2).eq.1) then 2046 do icartsec=1,ncontrac(Lrun) !loop over functions second index 2047 do icartfirst=1,ncontrac(Lrun) !loop over functions first index 2048 WRK(iocay+iredired+(icartfirst-1))= 2049 * WRK(iocay+iredired+(icartfirst-1)) 2050 * -onecarty(icartsec,icartfirst,mrun,Lrun) 2051 enddo 2052cbs shift pointer by number of functions in IR 2053 iredired=iredired+itotalperIR(iredfirst) 2054 enddo 2055 endif 2056 if (mod(ipowx,2).eq.1.and.mod(ipowy,2).eq.1.and. 2057 * mod(ipowz,2).eq.0) then 2058 do icartsec=1,ncontrac(Lrun) !loop over functions second index 2059 do icartfirst=1,ncontrac(Lrun) !loop over functions first index 2060 WRK(iocaz+iredired+(icartfirst-1))= 2061 * WRK(iocaz+iredired+(icartfirst-1)) 2062 * -onecartz(icartsec,icartfirst,mrun,Lrun) 2063 enddo 2064 iredired=iredired+itotalperIR(iredfirst) 2065 enddo 2066 endif 2067 endif 2068 enddo 2069 enddo 2070 enddo 2071C 2072C 2073cbs copy integrals on arrays with no symmetry blocking at all 2074cbs which means huge triangular matrices 2075 irun=0 2076 do norb2=1,numballcarT 2077 ired2=iredoffunctnew(norb2) 2078 norbsh2=norb2-shiftIRED(ired2) 2079 do norb1=1,norb2 2080 ired1=iredoffunctnew(norb1) 2081 norbsh1=noRb1-shiftIRED(ired1) 2082 irun=irun+1 2083 iredirEd=shiftIRIR((ired2*ired2-ired2)/2+ 2084 * ired1) 2085 if (ired1.ne.ired2) then 2086 WRK(iocax2+irun-1)=WRK(iocax-1+iredired+norbsh2+ 2087 * (norbsH1-1)*itotalperIR(IREd2)) 2088 WRK(iocay2+irun-1)=WRK(iocay-1+iredired+norbsh2+ 2089 * (norbsH1-1)*itotalperIR(IREd2)) 2090 WRK(iocaz2+irun-1)=WRK(iocaz-1+iredired+norbsh2+ 2091 * (norbsH1-1)*itotalperIR(IREd2)) 2092 else 2093 WRK(iocax2+irun-1)=WRK(iocax-1+iredired+norbsh2* 2094 * (norbsH2-1)/2+norbsh1) 2095 WRK(iocay2+irun-1)=WRK(iocay-1+iredired+norbsh2* 2096 * (norbsH2-1)/2+norbsh1) 2097 WRK(iocaz2+irun-1)=WRK(iocaz-1+iredired+norbsh2* 2098 * (norbsH2-1)/2+norbsh1) 2099 endif 2100 Enddo 2101 enddo 2102c write a hermit-like file b.s. 4.10.96 2103CBS write(6,*) 'number of orbitals ',numbalLcarT 2104CBS write(6,*) 'length of triangular matrix ', length3 2105 write(LUPROP) xa,numbofsym,(nrtofiperIR(I), 2106 * i=1,numbofsym), 2107 * numballcart,(Loffunction(I),I=1,numballcart), 2108 * (Moffunction(I),I=1,numballcart), 2109 * Lhigh,(ncontrac(I),I=0,Lhigh) 2110 write(LUPROP) (WRK(iocax2+irun),irun=0,length3-1) 2111 write(LUPROP) Ya 2112 write(LUPROP) (WRK(iocay2+irun),irun=0,length3-1) 2113 write(LUPROP) Za 2114 write(LUPROP) (WRK(iocaz2+irun),irun=0,length3-1) 2115cbs 2116cbs that is it!! 2117cbs 2118 return 2119 end 2120 subroutine contcasaOO(l1,l2,l3,l4,nstart,primints, 2121 *scratch1,scratch2,cont4OO) 2122cbs contraction for powers (+2) with alpha1*alpha3 2123cbs other-orbit term 2124cbs use averaged integrals by interchanging kinematic factors 2125cbs this is case a in the documentation 2126#include "implicit.h" 2127#include "para.h" 2128#include "amfi_param.h" 2129 dimension ncont(4),nprim(4),primints(*),scratch1(*),scratch2(*) 2130 *,cont4OO(*) 2131 ncont(1)=ncontrac(l1) 2132 ncont(2)=ncontrac(l2) 2133 ncont(3)=ncontrac(l3) 2134 ncont(4)=ncontrac(l4) 2135 nprim(1)=nprimit(l1) 2136 nprim(2)=nprimit(l2) 2137 nprim(3)=nprimit(l3) 2138 nprim(4)=nprimit(l4) 2139 ilength=nprim(1)*nprim(2)*nprim(3)*nprim(4) 2140 nprod=ncont(1)*ncont(2)*ncont(3)*ncont(4) 2141C 2142C 2143C 2144cbs copy primitive integrals to scratch1 2145 do IRUN=1,ilength 2146 scratch1(IRUN)=primints(IRUN) 2147 enddo 2148 call contract( 2149 *contrarray(iaddtyp2(l1)), !A *alpha 2150 *contrarray(iaddtyp3(l2)), !A/E+m 2151 *contrarray(iaddtyp4(l3)), !A/E+m *alpha 2152 *contrarray(iaddtyp1(l4)), !A 2153 *ncont, ! i-th element is number of contracted functions i. index 2154 *nprim, ! i-th element is number of primitive functions i. index 2155 *scratch1,scratch2) 2156 do irun=1,nprod 2157 cont4OO(nstart+irun-1)=0.25d0*scratch1(irun) 2158 enddo 2159C 2160C 2161C 2162cbs copy primitive integrals to scratch1 2163 do IRUN=1,ilength 2164 scratch1(IRUN)=primints(IRUN) 2165 enddo 2166 call contract( 2167 *contrarray(iaddtyp4(l1)), 2168 *contrarray(iaddtyp3(l2)), 2169 *contrarray(iaddtyp2(l3)), 2170 *contrarray(iaddtyp1(l4)), 2171 *ncont, ! i-th element is number of contracted functions i. index 2172 *nprim, ! i-th element is number of primitive functions i. index 2173 *scratch1,scratch2) 2174 do irun=1,nprod 2175 cont4OO(nstart+irun-1)=cont4OO(nstart+irun-1)+0.25d0* 2176 *scratch1(irun) 2177 enddo 2178C 2179C 2180C 2181cbs copy primitive integrals to scratch1 2182 do IRUN=1,ilength 2183 scratch1(IRUN)=primints(IRUN) 2184 enddo 2185 call contract( 2186 *contrarray(iaddtyp2(l1)), 2187 *contrarray(iaddtyp1(l2)), 2188 *contrarray(iaddtyp4(l3)), 2189 *contrarray(iaddtyp3(l4)), 2190 *ncont, ! i-th element is number of contracted functions i. index 2191 *nprim, ! i-th element is number of primitive functions i. index 2192 *scratch1,scratch2) 2193 do irun=1,nprod 2194 cont4OO(nstart+irun-1)=cont4OO(nstart+irun-1)+0.25d0* 2195 *scratch1(irun) 2196 enddo 2197C 2198C 2199C 2200cbs copy primitive integrals to scratch1 2201 do IRUN=1,ilength 2202 scratch1(IRUN)=primints(IRUN) 2203 enddo 2204 call contract( 2205 *contrarray(iaddtyp4(l1)), 2206 *contrarray(iaddtyp1(l2)), 2207 *contrarray(iaddtyp2(l3)), 2208 *contrarray(iaddtyp3(l4)), 2209 *ncont, ! i-th element is number of contracted functions i. index 2210 *nprim, ! i-th element is number of primitive functions i. index 2211 *scratch1,scratch2) 2212 do irun=1,nprod 2213 cont4OO(nstart+irun-1)=cont4OO(nstart+irun-1)+0.25d0* 2214 *scratch1(irun) 2215 enddo 2216 return 2217 end 2218 subroutine contcasaSO(l1,l2,l3,l4,nstart,primints, 2219 *scratch1,scratch2,cont4SO) 2220cbs contraction for powers (+2) with alpha1*alpha3 2221cbs same orbit term 2222cbs this is case a in the documentation 2223#include "implicit.h" 2224#include "para.h" 2225#include "amfi_param.h" 2226 dimension ncont(4),nprim(4),primints(*),scratch1(*),scratch2(*), 2227 *cont4SO(*) 2228 ncont(1)=ncontrac(l1) 2229 ncont(2)=ncontrac(l2) 2230 ncont(3)=ncontrac(l3) 2231 ncont(4)=ncontrac(l4) 2232 nprim(1)=nprimit(l1) 2233 nprim(2)=nprimit(l2) 2234 nprim(3)=nprimit(l3) 2235 nprim(4)=nprimit(l4) 2236 ilength=nprim(1)*nprim(2)*nprim(3)*nprim(4) 2237 nprod=ncont(1)*ncont(2)*ncont(3)*ncont(4) 2238cbs copy primitive integrals to scratch1 2239 do IRUN=1,ilength 2240 scratch1(IRUN)=primints(IRUN) 2241 enddo 2242c write(6,*) 'scratch1 ',(scratch1(I),I=1,ilength) 2243c write(6,*) 'contraction coeff' 2244c write(6,*) (contrarray(iaddtyp4(l1)+I),I=0,nprim(1)-1) 2245c write(6,*) (contrarray(iaddtyp1(l2)+I),I=0,nprim(2)-1) 2246c write(6,*) (contrarray(iaddtyp4(l3)+I),I=0,nprim(3)-1) 2247c write(6,*) (contrarray(iaddtyp1(l4)+I),I=0,nprim(4)-1) 2248 call contract( 2249 *contrarray(iaddtyp4(l1)), 2250 *contrarray(iaddtyp1(l2)), 2251 *contrarray(iaddtyp4(l3)), 2252 *contrarray(iaddtyp1(l4)), 2253 *ncont, ! i-th element is number of contracted functions i. index 2254 *nprim, ! i-th element is number of primitive functions i. index 2255 *scratch1,scratch2) 2256c write(6,*) 'nstart ',nstart 2257 do irun=1,nprod 2258 cont4SO(nstart+irun-1)=scratch1(irun) 2259 enddo 2260 return 2261 end 2262 subroutine contcasb1OO(l1,l2,l3,l4,nstart,primints, 2263 *scratch1,scratch2,cont4OO) 2264cbs contraction for powers (0) with alpha1 2265cbs this is one of the cases b in the documentation 2266cbs use averaged integrals by interchanging kinematic factors 2267#include "implicit.h" 2268#include "para.h" 2269#include "amfi_param.h" 2270 dimension ncont(4),nprim(4),primints(*),scratch1(*),scratch2(*) 2271 *,cont4OO(*) 2272 ncont(1)=ncontrac(l1) 2273 ncont(2)=ncontrac(l2) 2274 ncont(3)=ncontrac(l3) 2275 ncont(4)=ncontrac(l4) 2276 nprod=ncont(1)*ncont(2)*ncont(3)*ncont(4) 2277 nprim(1)=nprimit(l1) 2278 nprim(2)=nprimit(l2) 2279 nprim(3)=nprimit(l3) 2280 nprim(4)=nprimit(l4) 2281C 2282C 2283c 2284cbs copy primitive integrals to scratch1 2285 ilength=nprim(1)*nprim(2)*nprim(3)*nprim(4) 2286 do IRUN=1,ilength 2287 scratch1(IRUN)=primints(IRUN) 2288 enddo 2289 call contract( 2290 *contrarray(iaddtyp2(l1)), 2291 *contrarray(iaddtyp3(l2)), 2292 *contrarray(iaddtyp3(l3)), 2293 *contrarray(iaddtyp1(l4)), 2294 *ncont, ! i-th element is number of contracted functions i. index 2295 *nprim, ! i-th element is number of primitive functions i. index 2296 *scratch1,scratch2) 2297 do irun=1,nprod 2298 cont4OO(nstart+irun-1)=0.25d0*scratch1(irun) 2299 enddo 2300C 2301C 2302C 2303cbs copy primitive integrals to scratch1 2304 do IRUN=1,ilength 2305 scratch1(IRUN)=primints(IRUN) 2306 enddo 2307 call contract( 2308 *contrarray(iaddtyp4(l1)), 2309 *contrarray(iaddtyp3(l2)), 2310 *contrarray(iaddtyp1(l3)), 2311 *contrarray(iaddtyp1(l4)), 2312 *ncont, ! i-th element is number of contracted functions i. index 2313 *nprim, ! i-th element is number of primitive functions i. index 2314 *scratch1,scratch2) 2315 do irun=1,nprod 2316 cont4OO(nstart+irun-1)=cont4OO(nstart+irun-1)+ 2317 *0.25d0*scratch1(irun) 2318 enddo 2319C 2320C 2321C 2322cbs copy primitive integrals to scratch1 2323 do IRUN=1,ilength 2324 scratch1(IRUN)=primints(IRUN) 2325 enddo 2326 call contract( 2327 *contrarray(iaddtyp2(l1)), 2328 *contrarray(iaddtyp1(l2)), 2329 *contrarray(iaddtyp3(l3)), 2330 *contrarray(iaddtyp3(l4)), 2331 *ncont, ! i-th element is number of contracted functions i. index 2332 *nprim, ! i-th element is number of primitive functions i. index 2333 *scratch1,scratch2) 2334 do irun=1,nprod 2335 cont4OO(nstart+irun-1)=cont4OO(nstart+irun-1)+ 2336 *0.25d0*scratch1(irun) 2337 enddo 2338C 2339C 2340C 2341cbs copy primitive integrals to scratch1 2342 do IRUN=1,ilength 2343 scratch1(IRUN)=primints(IRUN) 2344 enddo 2345 call contract( 2346 *contrarray(iaddtyp4(l1)), 2347 *contrarray(iaddtyp1(l2)), 2348 *contrarray(iaddtyp1(l3)), 2349 *contrarray(iaddtyp3(l4)), 2350 *ncont, ! i-th element is number of contracted functions i. index 2351 *nprim, ! i-th element is number of primitive functions i. index 2352 *scratch1,scratch2) 2353 do irun=1,nprod 2354 cont4OO(nstart+irun-1)=cont4OO(nstart+irun-1)+ 2355 *0.25d0*scratch1(irun) 2356 enddo 2357 return 2358 end 2359 subroutine contcasb1SO(l1,l2,l3,l4,nstart,primints, 2360 *scratch1,scratch2,cont4SO) 2361cbs contraction for powers (0) with alpha1 2362cbs this is one of the cases b in the documentation 2363#include "implicit.h" 2364#include "para.h" 2365#include "amfi_param.h" 2366 dimension ncont(4),nprim(4),primints(*),scratch1(*),scratch2(*), 2367 *cont4SO(*) 2368 ncont(1)=ncontrac(l1) 2369 ncont(2)=ncontrac(l2) 2370 ncont(3)=ncontrac(l3) 2371 ncont(4)=ncontrac(l4) 2372 nprod=ncont(1)*ncont(2)*ncont(3)*ncont(4) 2373 nprim(1)=nprimit(l1) 2374 nprim(2)=nprimit(l2) 2375 nprim(3)=nprimit(l3) 2376 nprim(4)=nprimit(l4) 2377cbs copy primitive integrals to scratch1 2378 ilength=nprim(1)*nprim(2)*nprim(3)*nprim(4) 2379 do IRUN=1,ilength 2380 scratch1(IRUN)=primints(IRUN) 2381 enddo 2382 call contract( 2383 *contrarray(iaddtyp4(l1)), 2384 *contrarray(iaddtyp1(l2)), 2385 *contrarray(iaddtyp3(l3)), 2386 *contrarray(iaddtyp1(l4)), 2387 *ncont, ! i-th element is number of contracted functions i. index 2388 *nprim, ! i-th element is number of primitive functions i. index 2389 *scratch1,scratch2) 2390 call dcopy(nprod,scratch1(1),1,cont4SO(nstart),1) 2391 return 2392 end 2393 subroutine contcasb2OO(l1,l2,l3,l4,nstart,primints, 2394 *scratch1,scratch2,cont4OO) 2395cbs contraction for powers (0) with alpha3 2396cbs this is one of the cases b in the documentation 2397cbs use averaged integrals by interchanging kinematic factors 2398#include "implicit.h" 2399#include "para.h" 2400#include "amfi_param.h" 2401 dimension ncont(4),nprim(4),primints(*),scratch1(*),scratch2(*) 2402 *,cont4OO(*) 2403 ncont(1)=ncontrac(l1) 2404 ncont(2)=ncontrac(l2) 2405 ncont(3)=ncontrac(l3) 2406 ncont(4)=ncontrac(l4) 2407 nprod=ncont(1)*ncont(2)*ncont(3)*ncont(4) 2408 nprim(1)=nprimit(l1) 2409 nprim(2)=nprimit(l2) 2410 nprim(3)=nprimit(l3) 2411 nprim(4)=nprimit(l4) 2412 ilength=nprim(1)*nprim(2)*nprim(3)*nprim(4) 2413c 2414c 2415C 2416cbs copy primitive integrals to scratch1 2417 do IRUN=1,ilength 2418 scratch1(IRUN)=primints(IRUN) 2419 enddo 2420 call contract( 2421 *contrarray(iaddtyp1(l1)), 2422 *contrarray(iaddtyp3(l2)), 2423 *contrarray(iaddtyp4(l3)), 2424 *contrarray(iaddtyp1(l4)), 2425 *ncont, ! i-th element is number of contracted functions i. index 2426 *nprim, ! i-th element is number of primitive functions i. index 2427 *scratch1,scratch2) 2428 do irun=1,nprod 2429 cont4OO(nstart+irun-1)=0.25d0*scratch1(irun) 2430 enddo 2431c 2432c 2433C 2434cbs copy primitive integrals to scratch1 2435 do IRUN=1,ilength 2436 scratch1(IRUN)=primints(IRUN) 2437 enddo 2438 call contract( 2439 *contrarray(iaddtyp3(l1)), 2440 *contrarray(iaddtyp3(l2)), 2441 *contrarray(iaddtyp2(l3)), 2442 *contrarray(iaddtyp1(l4)), 2443 *ncont, ! i-th element is number of contracted functions i. index 2444 *nprim, ! i-th element is number of primitive functions i. index 2445 *scratch1,scratch2) 2446 do irun=1,nprod 2447 cont4OO(nstart+irun-1)=cont4OO(nstart+irun-1)+ 2448 *0.25d0*scratch1(irun) 2449 enddo 2450c 2451c 2452C 2453cbs copy primitive integrals to scratch1 2454 do IRUN=1,ilength 2455 scratch1(IRUN)=primints(IRUN) 2456 enddo 2457 call contract( 2458 *contrarray(iaddtyp1(l1)), 2459 *contrarray(iaddtyp1(l2)), 2460 *contrarray(iaddtyp4(l3)), 2461 *contrarray(iaddtyp3(l4)), 2462 *ncont, ! i-th element is number of contracted functions i. index 2463 *nprim, ! i-th element is number of primitive functions i. index 2464 *scratch1,scratch2) 2465 do irun=1,nprod 2466 cont4OO(nstart+irun-1)=cont4OO(nstart+irun-1)+ 2467 *0.25d0*scratch1(irun) 2468 enddo 2469c 2470c 2471C 2472cbs copy primitive integrals to scratch1 2473 do IRUN=1,ilength 2474 scratch1(IRUN)=primints(IRUN) 2475 enddo 2476 call contract( 2477 *contrarray(iaddtyp3(l1)), 2478 *contrarray(iaddtyp1(l2)), 2479 *contrarray(iaddtyp2(l3)), 2480 *contrarray(iaddtyp3(l4)), 2481 *ncont, ! i-th element is number of contracted functions i. index 2482 *nprim, ! i-th element is number of primitive functions i. index 2483 *scratch1,scratch2) 2484 do irun=1,nprod 2485 cont4OO(nstart+irun-1)=cont4OO(nstart+irun-1)+ 2486 *0.25d0*scratch1(irun) 2487 enddo 2488 return 2489 end 2490 subroutine contcasb2SO(l1,l2,l3,l4,nstart,primints, 2491 *scratch1,scratch2,cont4SO) 2492cbs contraction for powers (0) with alpha3 2493cbs this is one of the cases b in the documentation 2494#include "implicit.h" 2495#include "para.h" 2496#include "amfi_param.h" 2497 dimension ncont(4),nprim(4),primints(*),scratch1(*),scratch2(*), 2498 *cont4SO(*) 2499 ncont(1)=ncontrac(l1) 2500 ncont(2)=ncontrac(l2) 2501 ncont(3)=ncontrac(l3) 2502 ncont(4)=ncontrac(l4) 2503 nprod=ncont(1)*ncont(2)*ncont(3)*ncont(4) 2504 nprim(1)=nprimit(l1) 2505 nprim(2)=nprimit(l2) 2506 nprim(3)=nprimit(l3) 2507 nprim(4)=nprimit(l4) 2508 ilength=nprim(1)*nprim(2)*nprim(3)*nprim(4) 2509cbs copy primitive integrals to scratch1 2510 do IRUN=1,ilength 2511 scratch1(IRUN)=primints(IRUN) 2512 enddo 2513 call contract( 2514 *contrarray(iaddtyp3(l1)), 2515 *contrarray(iaddtyp1(l2)), 2516 *contrarray(iaddtyp4(l3)), 2517 *contrarray(iaddtyp1(l4)), 2518 *ncont, ! i-th element is number of contracted functions i. index 2519 *nprim, ! i-th element is number of primitive functions i. index 2520 *scratch1,scratch2) 2521 call dcopy(nprod,scratch1(1),1,cont4SO(nstart),1) 2522 return 2523 end 2524 SUBroutine contcascOO(l1,l2,l3,l4,nstart,primints, 2525 *scratch1,scratch2,cont4OO) 2526cbs contraction for powers (-2) with factor 1 2527cbs this is case c in the documentation 2528cbs use averaged integrals by interchanging kinematic factors 2529#include "implicit.h" 2530#include "para.h" 2531#include "amfi_param.h" 2532 dimension ncont(4),nprim(4),primints(*),scratch1(*),scratch2(*) 2533 *,cont4OO(*) 2534 ncont(1)=ncontrac(l1) 2535 ncont(2)=ncontrac(l2) 2536 ncont(3)=ncontrac(l3) 2537 ncont(4)=ncontrac(l4) 2538 nprod=ncont(1)*ncont(2)*ncont(3)*ncont(4) 2539 nprim(1)=nprimit(l1) 2540 nprim(2)=nprimit(l2) 2541 nprim(3)=nprimit(l3) 2542 nprim(4)=nprimit(l4) 2543 ilength=nprim(1)*nprim(2)*nprim(3)*nprim(4) 2544c 2545c 2546C 2547cbs copy primitive integrals to scratch1 2548 do IRUN=1,ilength 2549 scratch1(IRUN)=primints(IRUN) 2550 enddo 2551 call contract( 2552 *contrarray(iaddtyp1(l1)), 2553 *contrarray(iaddtyp3(l2)), 2554 *contrarray(iaddtyp3(l3)), 2555 *contrarray(iaddtyp1(l4)), 2556 *ncont, ! i-th element is number of contracted functions i. index 2557 *nprim, ! i-th element is number of primitive functions i. index 2558 *scratch1,scratch2) 2559 do irun=1,nprod 2560 cont4OO(nstart+irun-1)=0.25d0*scratch1(irun) 2561 enddo 2562c 2563c 2564C 2565cbs copy primitive integrals to scratch1 2566 do IRUN=1,ilength 2567 scratch1(IRUN)=primints(IRUN) 2568 enddo 2569 call contract( 2570 *contrarray(iaddtyp3(l1)), 2571 *contrarray(iaddtyp3(l2)), 2572 *contrarray(iaddtyp1(l3)), 2573 *contrarray(iaddtyp1(l4)), 2574 *ncont, ! i-th element is number of contracted functions i. index 2575 *nprim, ! i-th element is number of primitive functions i. index 2576 *scratch1,scratch2) 2577 do irun=1,nprod 2578 cont4OO(nstart+irun-1)=cont4OO(nstart+irun-1)+ 2579 *0.25d0*scratch1(irun) 2580 enddo 2581c 2582c 2583C 2584cbs copy primitive integrals to scratch1 2585 do IRUN=1,ilength 2586 scratch1(IRUN)=primints(IRUN) 2587 enddo 2588 call contract( 2589 *contrarray(iaddtyp1(l1)), 2590 *contrarray(iaddtyp1(l2)), 2591 *contrarray(iaddtyp3(l3)), 2592 *contrarray(iaddtyp3(l4)), 2593 *ncont, ! i-th element is number of contracted functions i. index 2594 *nprim, ! i-th element is number of primitive functions i. index 2595 *scratch1,scratch2) 2596 do irun=1,nprod 2597 cont4OO(nstart+irun-1)=cont4OO(nstart+irun-1)+ 2598 *0.25d0*scratch1(irun) 2599 enddo 2600c 2601c 2602C 2603cbs copy primitive integrals to scratch1 2604 do IRUN=1,ilength 2605 scratch1(IRUN)=primints(IRUN) 2606 enddo 2607 call contract( 2608 *contrarray(iaddtyp3(l1)), 2609 *contrarray(iaddtyp1(l2)), 2610 *contrarray(iaddtyp1(l3)), 2611 *contrarray(iaddtyp3(l4)), 2612 *ncont, ! i-th element is number of contracted functions i. index 2613 *nprim, ! i-th element is number of primitive functions i. index 2614 *scratch1,scratch2) 2615 do irun=1,nprod 2616 cont4OO(nstart+irun-1)=cont4OO(nstart+irun-1)+ 2617 *0.25d0*scratch1(irun) 2618 enddo 2619 return 2620 end 2621 subroutine contcascSO(l1,l2,l3,l4,nstart,primints, 2622 *scratch1,scratch2,cont4SO) 2623cbs contraction for powers (-2) with factor 1 2624cbs this is case c in the documentation 2625#include "implicit.h" 2626#include "para.h" 2627#include "amfi_param.h" 2628 dimension ncont(4),nprim(4),primints(*),scratch1(*),scratch2(*), 2629 *cont4SO(*) 2630 ncont(1)=ncontrac(l1) 2631 ncont(2)=ncontrac(l2) 2632 ncont(3)=ncontrac(l3) 2633 ncont(4)=ncontrac(l4) 2634 nprod=ncont(1)*ncont(2)*ncont(3)*ncont(4) 2635 nprim(1)=nprimit(l1) 2636 nprim(2)=nprimit(l2) 2637 nprim(3)=nprimit(l3) 2638 nprim(4)=nprimit(l4) 2639 ilength=nprim(1)*nprim(2)*nprim(3)*nprim(4) 2640cbs copy primitive integrals to scratch1 2641 do IRUN=1,ilength 2642 scratch1(IRUN)=primints(IRUN) 2643 enddo 2644 call contract( 2645 *contrarray(iaddtyp3(l1)), 2646 *contrarray(iaddtyp1(l2)), 2647 *contrarray(iaddtyp3(l3)), 2648 *contrarray(iaddtyp1(l4)), 2649 *ncont, ! i-th element is number of contracted functions i. index 2650 *nprim, ! i-th element is number of primitive functions i. index 2651 *scratch1,scratch2) 2652 call dcopy(nprod,scratch1(1),1,cont4SO(nstart),1) 2653 return 2654 end 2655 subroutine contone(L,oneoverr3,onecontr,Lmax, 2656 *contcoeff,nprim,ncont,MxcontL,dummy, 2657 *onecartx,onecartY,onecartZ,charge,oneonly) 2658cbs contracts one-electron integrals and multiplies with l,m-dependent 2659cbs factors for L-,L0,L+ 2660#include "implicit.h" 2661 dimension oneoverR3(*), 2662 *onecontr(MxcontL,MxcontL,-Lmax:Lmax,3), 2663 *contcoeff(nprim,ncont),dummy(ncont,ncont), 2664 *onecartx(MxcontL,MxcontL, 2665 *(Lmax+Lmax+1)*(Lmax+1)), 2666 *onecarty(MxcontL,MxcontL, 2667 *(Lmax+Lmax+1)*(Lmax+1)), 2668 *onecartz(MxcontL,MxcontL, 2669 *(Lmax+Lmax+1)*(Lmax+1)) 2670 logical oneonly 2671 ipnt(I,J)=(max(i,j)*(max(i,j)-1))/2+min(i,j) 2672cbs first of all cleaning dummy and onecontr 2673 do jrun=1,ncont 2674 do irun=1,ncont 2675 dummy(irun,jrun)=0d0 2676 enddo 2677 enddo 2678 if (oneonly) then 2679 iprod=MxcontL*MxcontL*(Lmax+Lmax+1)*(Lmax+1) 2680 call dzero(onecartx,iprod) 2681 call dzero(onecarty,iprod) 2682 call dzero(onecartz,iprod) 2683 endif 2684 iprod=3*(Lmax+lmax+1)*MxcontL*MxcontL 2685 call dzero(onecontr,iprod) 2686cbs contract onto dummy 2687 do icont2=1,ncont 2688 do icont1=1,ncont 2689 do iprim2=1,nprim 2690 do iprim1=1,nprim 2691 dummy(icont1,icont2)=dummy(icont1,icont2)+ 2692 *contcoeff(iprim1,icont1)*contcoeff(iprim2,icont2)* 2693 *oneoverR3(ipnt(iprim1,iprim2)) 2694 enddo 2695 enddo 2696 enddo 2697 enddo 2698 do icont2=1,ncont 2699 do icont1=1,ncont 2700 dummy(icont1,icont2)=dummy(icont1,icont2)*charge 2701 enddo 2702 enddo 2703cbs start to add l,m dependent factors 2704 do M=-L,L 2705 factormin=dsqrt(dfloat(L*L-M*M+L+M)) 2706 factor0=dfloat(M) 2707 factorplus=dsqrt(dfloat(L*L-M*M+L-M)) 2708 do irun=1,ncont 2709 do jrun=1,ncont 2710 onecontr(irun,jrun,M,1)=dummy(jrun,irun)*factormin ! L-minus 2711 enddo 2712 enddo 2713 do irun=1,ncont 2714 do jrun=1,ncont 2715 onecontr(irun,jrun,M,2)=dummy(jrun,irun)*factor0 ! L-0 2716 enddo 2717 enddo 2718 do irun=1,ncont 2719 do jrun=1,ncont 2720 onecontr(irun,jrun,M,3)=dummy(jrun,irun)*factorplus ! L-plus 2721 enddo 2722 enddo 2723 enddo 2724cbs make the final cartesian integrals 2725 call cartoneX(L,Lmax,onecontr,ncont, 2726 *MxcontL,onecartX(1,1,1)) 2727 call cartoneY(L,Lmax,onecontr,ncont, 2728 *MxcontL,onecartY(1,1,1)) 2729 call cartoneZ(L,Lmax,onecontr,ncont, 2730 *MxcontL,onecartZ(1,1,1)) 2731 return 2732 end 2733 subroutine contract( coeffs1, coeffs2, coeffs3, coeffs4, 2734 * ncont, nprim, arr1, arr2 ) 2735c coeffs1, !(nprim(1),ncont(1)) modified contraction coefficients 2736c coeffs2, !(nprim(2),ncont(2)) modified contraction coefficients 2737c coeffs3, !(nprim(3),ncont(3)) modified contraction coefficients 2738c coeffs4, !(nprim(4),ncont(4)) modified contraction coefficients 2739c ncont, ! i-th element is number of contracted functions i. index 2740c nprim, ! i-th element is number of primitive functions i. index 2741cbs array one contains at the beginning the uncontracted integrals 2742c arr1, ! array of size (nprim(1)*nprim(2)*nprim(3)*nprim(4)) 2743c arr2 ! array of size (nprim(1)*nprim(2)*nprim(3)*nprim(4)) 2744#include "implicit.h" 2745 dimension coeffs1(*),coeffs2(*),coeffs3(*),coeffs4(*), 2746 *arr1(*),arr2(*),ncont(4),nprim(4),nolds(4),nnew(4) 2747C 2748cbs makes four indextransformations in a row.... 2749cbs try to find out, which indices should be transformed first... 2750c 2751 ratio1=dfloat(nprim(1))/dfloat(ncont(1)) 2752 ratio2=dfloat(nprim(2))/dfloat(ncont(2)) 2753 ratio3=dfloat(nprim(3))/dfloat(ncont(3)) 2754 ratio4=dfloat(nprim(4))/dfloat(ncont(4)) 2755 do IBM=1,4 2756 nolds(IBM)=nprim(IBM) 2757 nnew(IBM)=nprim(IBM) 2758 enddo 2759cbs determine first, second,third and last index 2760cbs determine the first 2761 xmax=max(ratio1,ratio2,ratio3,ratio4) 2762 if (xmax.eq.ratio1) then 2763 ifirst=1 2764 ratio1=0 2765 nnew(ifirst)=ncont(ifirst) 2766 call trans(coeffs1,nprim(1),ncont(1),1,nolds(1),nolds(2), 2767 *nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr1,arr2) 2768 else if (xmax.eq.ratio2) then 2769 ifirst=2 2770 ratio2=0 2771 nnew(ifirst)=ncont(ifirst) 2772 call trans(coeffs2,nprim(2),ncont(2),2,nolds(1),nolds(2), 2773 *nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr1,arr2) 2774 else if (xmax.eq.ratio3) then 2775 ifirst=3 2776 ratio3=0 2777 nnew(ifirst)=ncont(ifirst) 2778 call trans(coeffs3,nprim(3),ncont(3),3,nolds(1),nolds(2), 2779 *nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr1,arr2) 2780 else if (xmax.eq.ratio4) then 2781 ifirst=4 2782 ratio4=0 2783 nnew(ifirst)=ncont(ifirst) 2784 call trans(coeffs4,nprim(4),ncont(4),4,nolds(1),nolds(2), 2785 *nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr1,arr2) 2786 endif 2787 nolds(ifirst)=nnew(ifirst) 2788cbs determine the second 2789 xmax=max(ratio1,ratio2,ratio3,ratio4) 2790 if (xmax.eq.ratio1) then 2791 isec=1 2792 ratio1=0 2793 nnew(isec)=ncont(isec) 2794 call trans(coeffs1,nprim(1),ncont(1),1,nolds(1),nolds(2), 2795 *nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr2,arr1) 2796 else if (xmax.eq.ratio2) then 2797 isec=2 2798 ratio2=0 2799 nnew(isec)=ncont(isec) 2800 call trans(coeffs2,nprim(2),ncont(2),2,nolds(1),nolds(2), 2801 *nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr2,arr1) 2802 else if (xmax.eq.ratio3) then 2803 isec=3 2804 ratio3=0 2805 nnew(isec)=ncont(isec) 2806 call trans(coeffs3,nprim(3),ncont(3),3,nolds(1),nolds(2), 2807 *nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr2,arr1) 2808 else if (xmax.eq.ratio4) then 2809 isec=4 2810 ratio4=0 2811 nnew(isec)=ncont(isec) 2812 call trans(coeffs4,nprim(4),ncont(4),4,nolds(1),nolds(2), 2813 *nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr2,arr1) 2814 endif 2815 nolds(isec)=nnew(isec) 2816cbs determine the third 2817 xmax=max(ratio1,ratio2,ratio3,ratio4) 2818 if (xmax.eq.ratio1) then 2819 ithird=1 2820 ratio1=0 2821 nnew(ithird)=ncont(ithird) 2822 call trans(coeffs1,nprim(1),ncont(1),1,nolds(1),nolds(2), 2823 *nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr1,arr2) 2824 else if (xmax.eq.ratio2) then 2825 ithird=2 2826 ratio2=0 2827 nnew(ithird)=ncont(ithird) 2828 call trans(coeffs2,nprim(2),ncont(2),2,nolds(1),nolds(2), 2829 *nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr1,arr2) 2830 else if (xmax.eq.ratio3) then 2831 ithird=3 2832 ratio3=0 2833 nnew(ithird)=ncont(ithird) 2834 call trans(coeffs3,nprim(3),ncont(3),3,nolds(1),nolds(2), 2835 *nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr1,arr2) 2836 else if (xmax.eq.ratio4) then 2837 ithird=4 2838 ratio4=0 2839 nnew(ithird)=ncont(ithird) 2840 call trans(coeffs4,nprim(4),ncont(4),4,nolds(1),nolds(2), 2841 *nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr1,arr2) 2842 endif 2843 nolds(ithird)=nnew(ithird) 2844cbs determine the last 2845 xmax=max(ratio1,ratio2,ratio3,ratio4) 2846 if (xmax.eq.ratio1) then 2847 ifourth=1 2848 ratio1=0 2849 nnew(ifourth)=ncont(ifourth) 2850 call trans(coeffs1,nprim(1),ncont(1),1,nolds(1),nolds(2), 2851 *nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr2,arr1) 2852 else if (xmax.eq.ratio2) then 2853 ifourth=2 2854 ratio2=0 2855 nnew(ifourth)=ncont(ifourth) 2856 call trans(coeffs2,nprim(2),ncont(2),2,nolds(1),nolds(2), 2857 *nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr2,arr1) 2858 else if (xmax.eq.ratio3) then 2859 ifourth=3 2860 ratio3=0 2861 nnew(ifourth)=ncont(ifourth) 2862 call trans(coeffs3,nprim(3),ncont(3),3,nolds(1),nolds(2), 2863 *nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr2,arr1) 2864 else if (xmax.eq.ratio4) then 2865 ifourth=4 2866 ratio4=0 2867 nnew(ifourth)=ncont(ifourth) 2868 call trans(coeffs4,nprim(4),ncont(4),4,nolds(1),nolds(2), 2869 *nolds(3),nolds(4),nnew(1),nnew(2),nnew(3),nnew(4),arr2,arr1) 2870 endif 2871cbs contracted integrals are now on 2872cbs arr1(ncont1,ncont2,ncont3,ncont4) 2873 return 2874 end 2875 double precision function couple3J( 2876 *l1, l2, l3, m1, m2, m3) 2877cbs this routine calculates the coupling of three angular momenta to zero 2878cbs 2879cbs 2880cbs Int dOmega i^(l1+l2+l3) Y^l1_m1 (Omega) Y^l2_m2 (Omega) Y^l3_m3 (Omega) = 2881cbs sqrt( (2l1+1)(2l2+1)(2l2+3)/ 4Pi) * 3J(l1,l2,l3,0,0,0) * 2882cbs 3J(l1,l2,l3,m1,m2,m3) 2883cbs 2884cbs 2885#include "implicit.h" 2886#include "pi.h" 2887 double precision inv4pi 2888cbs (4*PI)**-1 2889 inv4pi=0.25d0/pi 2890cbs initialize couple3J-coefficient 2891 couple3J=0d0 2892cbs quick check 2893 if (m1+m2+m3.ne.0) return 2894cbs double all values for regge3j 2895 l1d=l1+l1 2896 l2d=l2+l2 2897 l3d=l3+l3 2898 m1d=m1+m1 2899 m2d=m2+m2 2900 m3d=m3+m3 2901 fac1=dsqrt(dfloat(l1d+1)*dfloat(l2d+1)*dfloat(l3d+1)*inv4pi) 2902 fac2=regge3j(l1d,l2d,l3d,0,0,0) 2903 fac3=regge3j(l1d,l2d,l3d,m1d,m2d,m3d) 2904 couple3J=fac1*fac2*fac3 2905 return 2906 end 2907 subroutine daxpint(from,to,fact,ndim1,ndim2,ndim3,ndim4) 2908#include "implicit.h" 2909cbs subroutine similar to daxpy with interchange of two indices 2910cbs change from physicists notation to chemists notaion 2911cbs to(i,j,k,l)=to(i,j,k,l)+fact*from(i,k,j,l) 2912 dimension from(ndim1,ndim2,ndim3,ndim4), 2913 *to(ndim1,ndim3,ndim2,ndim4) 2914 if (fact.eq.0d0) return 2915 do irun4=1,ndim4 2916 do irun3=1,ndim3 2917 do irun2=1,ndim2 2918 do irun1=1,ndim1 2919 to(irun1,irun3,irun2,irun4)=to(irun1,irun3,irun2,irun4)+ 2920 *fact*from(irun1,irun2,irun3,irun4) 2921 enddo 2922 enddo 2923 enddo 2924 enddo 2925 return 2926 end 2927 subroutine gen1overR3(Lhigh) 2928#include "implicit.h" 2929cbs generates the radial integrals for the one electron spin orbit integrals 2930cbs taken the 1/r**3 formula from the documentation and included additional 2931cbs factors for normalization 2932#include "para.h" 2933#include "amfi_param.h" 2934#include "dofuc.h" 2935#include "pi.h" 2936 do L=1,Lhigh 2937 icount=0 2938 do iprim2=1,nprimit(L) 2939 alpha2=exponents(iprim2,L) 2940 do iprim1=1,iprim2 2941 alpha1=exponents(iprim1,L) 2942 icount=icount+1 2943 oneoverR3(icount,L)=dsqrt(2d0/pi)* 2944 *(df(L+L-2)*2**(L+3)* 2945 *(alpha1*alpha2)**(0.25d0* 2946 *(L+L+3)))/((alpha1+alpha2)**L*df(L+L+1)) 2947 enddo 2948 enddo 2949 enddo 2950 return 2951 end 2952 subroutine gencoul(l1,l2,l3,l4,makemean, 2953 *bonn,breit,sameorb,cont4SO,cont4OO,icont4, 2954 *WRK,LFREE) 2955#include "implicit.h" 2956cbs SUBROUTINE to generate all required radial 2957cbs integrals for the four angular momenta l1-l4 2958#include "priunit.h" 2959#include "para.h" 2960#include "amfi_param.h" 2961 logical makemean,bonn,breit,sameorb 2962 dimension cont4SO(*),cont4OO(*),WRK(LFREE) 2963 max1=1 !starting values for limits of precalculated 2964c ! powers of function Cfunct(X) 2965 max2=1 2966cbs first of all, this routine determines, for which L 2967cbs values the radial integrals have to be solved 2968cbs initialize the number of blocks for the different 2969cbs l-combinations 2970cbs no (ss|ss) contributions 2971 if (l1.eq.0.and.l2.eq.0.and.l3.eq.0.and.l4.eq.0) return ! no integrals for <ss|ss> 2972 if (makemean) then 2973 nblock=1 ! sp sp are the first, so the first block 2974 Lstarter(1)=1 2975 else 2976 CALL QUIT('only mean-field with this version') 2977 endif 2978cbs keep track of L-values for later purposes 2979 Lvalues(1)=l1 2980 Lvalues(2)=l2 2981 Lvalues(3)=l3 2982 Lvalues(4)=l4 2983cbs now nanz is given the new value 2984 nanz=ncontrac(l1)*ncontrac(l2)*ncontrac(l3)*ncontrac(l4) 2985 nprimprod=nprimit(l1)*nprimit(l2)*nprimit(l3)*nprimit(l4) 2986 IQUOT1 = 1 2987 iquot2=iquot1+nprimprod 2988 iquotp1=iquot2+nprimprod 2989 iquotp2=iquotp1+nprimprod 2990 iprim=iquotp2+nprimprod 2991 iscr1=iprim+nprimprod 2992 iscr2=iscr1+nprimprod 2993 KLAST = ISCR2 + NPRIMPROD 2994 IF (KLAST .GT. LFREE) CALL STOPIT('AMFI ','GENCOU',KLAST,LFREE) 2995c 2996 call initfrac(nprimit(l1),nprimit(l2),nprimit(l3),nprimit(l4), 2997 *WRK(iquot1),WRK(iquot2),exponents(1,l1),exponents(1,l2), 2998 *exponents(1,l3),exponents(1,l4)) 2999cbs prepare the powers needed for cfunctx 3000c 3001c 3002c There are seven different CASES of integrals following 3003c ( A -- C) 3004c 3005c The structure is the same for all cases, therefore comments can be found only on case A 3006c 3007c 3008c 3009cbs ########################################################################################################### 3010cbs the (+2) cases CASE A 3011cbs ########################################################################################################## 3012 incl1=1 ! Those increments define the case 3013 incl3=1 3014cbs determine the possible L-values for the integrals by checking for triangular equation 3015c 3016 call getlimit(l1+incl1,l2,l3+incl3,l4,Lanf,Lend) 3017c 3018cbs returns first and last L-values (Lanf,Lend), for which 3019cbs radial integrals have to be calculated 3020 if(Lend-Lanf.ge.0) then 3021cbs if there are blocks 3022 Lblocks(1)=(Lend-Lanf)/2+1 ! L increases in steps of 2, 3023cbs due to parity conservation 3024 Lfirst(1)=Lanf 3025 Llast(1)=Lend 3026 else 3027 Lblocks(1)=0 3028 endif 3029 if (Lblocks(1).gt.0) then ! integrals have to be calculated 3030cbs### check, whether integrals fit on array ################ 3031 if (Lstarter(1)+nanz*Lblocks(1).gt.icont4) then 3032 write(LUPRI,*) 'end at: ',Lstarter(1)+nanz*Lblocks(1) 3033 CALL QUIT('increase icont4 in amfi.F') 3034 endif 3035cbs### check, whether integrals fit on array ################ 3036 istart=Lstarter(1) ! gives the address, where to write the contracted integrals 3037cbs ipow1 and ipow2 are the the numbers of powers in the prefactor 3038cbs of the function Cfunct 3039cbs now loop over possible L-values 3040 do Lrun= Lfirst(1),Llast(1),2 3041 ipow1=2+(l2+l4+Lrun)/2 3042 ipow2=2+(l1+l3+incl1+incl3+Lrun)/2 3043cbs those powers have to be generated... 3044 call getpow(ipow1,WRK(iquot1),WRK(iquotp1), 3045 *nprimit(l1),nprimit(l2),nprimit(l3),nprimit(l4)) 3046cbs those powers have to be generated... 3047 call getpow(ipow2,WRK(iquot2),WRK(iquotp2), 3048 *nprimit(l1),nprimit(l2),nprimit(l3),nprimit(l4)) 3049c in buildcoul the radial integrals are calculated 3050 call buildcoul(l1,l2,l3,l4,incl1,incl3, 3051 * Lrun,WRK(iprim),nprimit(l1),nprimit(l2),nprimit(l3), 3052 * nprimit(l4), 3053 * exponents(1,l1),exponents(1,l2), 3054 * exponents(1,l3),exponents(1,l4), 3055 * powexp(1,1,l3,l1,lrun),powexp(1,1,l4,l2,lrun), 3056 * WRK(iquotp1),WRK(iquotp2)) 3057cbs in the contcas_ routines the integrals are contracted, including exponents as prefactors... 3058 if (bonn.or.breit.or.sameorb) then 3059 call contcasASO(l1,l2,l3,l4,istart,WRK(iprim), 3060 * WRK(iscr1),WRK(iscr2),cont4SO) 3061 else 3062 call contcasASO(l1,l2,l3,l4,istart,WRK(iprim), 3063 * WRK(iscr1),WRK(iscr2),cont4SO) 3064 call contcasAOO(l1,l2,l3,l4,istart,WRK(iprim), 3065 * WRK(iscr1),WRK(iscr2),cont4OO) 3066 endif 3067 istart=istart+nanz ! start-address for the next block of contracted integrals 3068 enddo 3069 endif 3070cbs ########################################################################################################## 3071cbs the (0) cases CASE B 3072cbs ########################################################################################################## 3073 incl1=0 3074 incl3=0 3075 call getlimit(l1+incl1,l2,l3+incl3,l4,Lanf,Lend) 3076 if(Lend-Lanf.ge.0) then 3077 Lblocks(2)=(Lend-Lanf)/2+1 3078 Lfirst(2)=Lanf 3079 Llast(2)=Lend 3080 Lblocks(3)=(Lend-Lanf)/2+1 3081 Lfirst(3)=Lanf 3082 Llast(3)=Lend 3083 else 3084 Lblocks(2)=0 3085 Lblocks(3)=0 3086 endif 3087 Lstarter(2)=Lstarter(1)+ 3088 *nanz*Lblocks(1) 3089 Lstarter(3)=Lstarter(2)+ 3090 *nanz*Lblocks(2) 3091cbs primitive integrals are the same for type 2 and 3 !!!!! 3092 if (Lblocks(2).gt.0) then 3093cbs### check, whether integrals fit on array ################ 3094 if (Lstarter(2)+2*nanz*Lblocks(2).gt.icont4) then 3095 write(LUPRI,*) 'end at: ',Lstarter(2)+2*nanz*Lblocks(2) 3096 CALL QUIT('increase icont4 in amfi.F') 3097 endif 3098cbs### check, whether integrals fit on array ################ 3099 istart=Lstarter(2) 3100 istart2=Lstarter(3) 3101 do Lrun= Lfirst(2),Llast(2),2 3102 ipow1=2+(l2+l4+Lrun)/2 3103 ipow2=2+(l1+l3+incl1+incl3+Lrun)/2 3104 call getpow(ipow1,WRK(iquot1),WRK(iquotp1), 3105 *nprimit(l1),nprimit(l2),nprimit(l3),nprimit(l4)) 3106 call getpow(ipow2,WRK(iquot2),WRK(iquotp2), 3107 *nprimit(l1),nprimit(l2),nprimit(l3),nprimit(l4)) 3108 call buildcoul(l1,l2,l3,l4,incl1,incl3, 3109 *Lrun,WRK(iprim),nprimit(l1),nprimit(l2),nprimit(l3), 3110 *nprimit(l4), 3111 *exponents(1,l1),exponents(1,l2), 3112 *exponents(1,l3),exponents(1,l4), 3113 *powexp(1,1,l3,l1,lrun),powexp(1,1,l4,l2,lrun), 3114 *WRK(iquotp1),WRK(iquotp2)) 3115 if (bonn.or.breit.or.sameorb) then 3116 call contcasB1SO(l1,l2,l3,l4,istart,WRK(iprim), 3117 *WRK(iscr1),WRK(iscr2),cont4SO) 3118 call contcasB2SO(l1,l2,l3,l4,istart2,WRK(iprim), 3119 *WRK(iscr1),WRK(iscr2),cont4SO) 3120 else 3121 call contcasB1SO(l1,l2,l3,l4,istart,WRK(iprim), 3122 *WRK(iscr1),WRK(iscr2),cont4SO) 3123 call contcasB2SO(l1,l2,l3,l4,istart2,WRK(iprim), 3124 *WRK(iscr1),WRK(iscr2),cont4SO) 3125 Call contcasB1OO(l1,l2,l3,l4,istart,WRK(iprim), 3126 *WRK(iscr1),WRK(iscr2),cont4OO) 3127 Call contcasB2OO(l1,l2,l3,l4,istart2,WRK(iprim), 3128 *WRK(iscr1),WRK(iscr2),cont4OO) 3129 endif 3130 istart=istart+nanz 3131 istart2=istart2+nanz 3132 enddo 3133 endif 3134cbs ########################################################################################################## 3135cbs the (-2) cases CASE C 3136cbs ########################################################################################################## 3137 if (l1.eq.0.or.l3.eq.0) then 3138 Lblocks(4)=0 3139 else 3140 incl1=-1 3141 incl3=-1 3142 call getlimit(l1+incl1,l2,l3+incl3,l4,Lanf,Lend) 3143 if(Lend-Lanf.ge.0) then 3144 Lblocks(4)=(Lend-Lanf)/2+1 3145 Lfirst(4)=Lanf 3146 Llast(4)=Lend 3147 else 3148 Lblocks(4)=0 3149 endif 3150 endif 3151 Lstarter(4)=Lstarter(3)+ 3152 *nanz*Lblocks(3) 3153 if (Lblocks(4).gt.0) then 3154cbs### check, whether integrals fit on array ################ 3155 if (Lstarter(4)+nanz*Lblocks(4).gt.icont4) then 3156 write(LUPRI,*) 'end at: ',Lstarter(4)+nanz*Lblocks(4) 3157 CALL QUIT('increase icont4 in amfi.F') 3158 endif 3159cbs### check, whether integrals fit on array ################ 3160 istart=Lstarter(4) 3161 do Lrun= Lfirst(4),Llast(4),2 3162 ipow1=2+(l2+l4+Lrun)/2 3163 ipow2=2+(l1+l3+incl1+incl3+Lrun)/2 3164 call getpow(ipow1,WRK(iquot1),WRK(iquotp1), 3165 *nprimit(l1),nprimit(l2),nprimit(l3),nprimit(l4)) 3166 call getpow(ipow2,WRK(iquot2),WRK(iquotp2), 3167 *nprimit(l1),nprimit(l2),nprimit(l3),nprimit(l4)) 3168 call buildcoul(l1,l2,l3,l4,incl1,incl3, 3169 *Lrun,WRK(iprim),nprimit(l1),nprimit(l2),nprimit(l3), 3170 *nprimit(l4), 3171 *exponents(1,l1),exponents(1,l2), 3172 *exponents(1,l3),exponents(1,l4), 3173 *powexp(1,1,l3,l1,lrun),powexp(1,1,l4,l2,lrun), 3174 *WRK(iquotp1),WRK(iquotp2)) 3175 if (bonn.or.breit.or.sameorb) then 3176 call contcasCSO(l1,l2,l3,l4,istart,WRK(iprim), 3177 *WRK(iscr1),WRK(iscr2),cont4SO) 3178 else 3179 call contcasCSO(l1,l2,l3,l4,istart,WRK(iprim), 3180 *WRK(iscr1),WRK(iscr2),cont4SO) 3181 call contcasCOO(l1,l2,l3,l4,istart,WRK(iprim), 3182 *WRK(iscr1),WRK(iscr2),cont4OO) 3183 endif 3184 istart=istart+nanz 3185 enddo 3186 endif 3187 return 3188 end 3189 subroutine gencoulDIM(l1,l2,l3,l4,makemean, 3190 *bonn,breit,sameorb,icont4) 3191#include "implicit.h" 3192#include "priunit.h" 3193#include "para.h" 3194#include "amfi_param.h" 3195cbs SUBROUTINE to calculate the dimemsion of the radial integral 3196cbs arrays. BASICALLY GENCOUL WITHOUT EXPLICIT INTEGRAL CALCULATION 3197cbs integrals for the four angular momenta l1-l4 3198 logical makemean,bonn,breit,sameorb 3199 max1=1 !starting values for limits of precalculated 3200c ! powers of function Cfunct(X) 3201 max2=1 3202c 3203 incont4=0 3204c 3205cbs first of all, this routine determines, for which L 3206cbs values the radial integrals have to be solved 3207cbs initialize the number of blocks for the different 3208cbs l-combinations 3209cbs no (ss|ss) contributions 3210 if (l1.eq.0.and.l2.eq.0.and.l3.eq.0.and.l4.eq.0) return ! no integrals for <ss|ss> 3211 if (makemean) then 3212 nblock=1 ! sp sp are the first, so the first block 3213 Lstarter(1)=1 3214 else 3215 CALL QUIT('only mean-field with this version') 3216 endif 3217cbs keep track of L-values for later purposes 3218 Lvalues(1)=l1 3219 Lvalues(2)=l2 3220 Lvalues(3)=l3 3221 Lvalues(4)=l4 3222cbs now nanz is given the new value 3223 nanz=ncontrac(l1)*ncontrac(l2)*ncontrac(l3)*ncontrac(l4) 3224 nprimprod=nprimit(l1)*nprimit(l2)*nprimit(l3)*nprimit(l4) 3225c 3226cbs prepare the powers needed for cfunctx 3227c 3228c 3229c There are seven different CASES of integrals following 3230c ( A -- C) 3231c 3232c The structure is the same for all cases, therefore comments can be found only on case A 3233c 3234c 3235c 3236cbs ########################################################################################################### 3237cbs the (+2) cases CASE A 3238cbs ########################################################################################################## 3239 incl1=1 ! Those increments define the case 3240 incl3=1 3241cbs determine the possible L-values for the integrals by checking for triangular equation 3242c 3243 call getlimit(l1+incl1,l2,l3+incl3,l4,Lanf,Lend) 3244c 3245cbs returns first and last L-values (Lanf,Lend), for which 3246cbs radial integrals have to be calculated 3247 if(Lend-Lanf.ge.0) then 3248cbs if there are blocks 3249 Lblocks(1)=(Lend-Lanf)/2+1 ! L increases in steps of 2, 3250cbs due to parity conservation 3251 Lfirst(1)=Lanf 3252 Llast(1)=Lend 3253 else 3254 Lblocks(1)=0 3255 endif 3256cbs ########################################################################################################## 3257cbs the (0) cases CASE B 3258cbs ########################################################################################################## 3259 incl1=0 3260 incl3=0 3261 call getlimit(l1+incl1,l2,l3+incl3,l4,Lanf,Lend) 3262 if(Lend-Lanf.ge.0) then 3263 Lblocks(2)=(Lend-Lanf)/2+1 3264 Lfirst(2)=Lanf 3265 Llast(2)=Lend 3266 Lblocks(3)=(Lend-Lanf)/2+1 3267 Lfirst(3)=Lanf 3268 Llast(3)=Lend 3269 else 3270 Lblocks(2)=0 3271 Lblocks(3)=0 3272 endif 3273 Lstarter(2)=Lstarter(1)+ 3274 *nanz*Lblocks(1) 3275 Lstarter(3)=Lstarter(2)+ 3276 *nanz*Lblocks(2) 3277cbs ########################################################################################################## 3278cbs the (-2) cases CASE C 3279cbs ########################################################################################################## 3280 if (l1.eq.0.or.l3.eq.0) then 3281 Lblocks(4)=0 3282 else 3283 incl1=-1 3284 incl3=-1 3285 call getlimit(l1+incl1,l2,l3+incl3,l4,Lanf,Lend) 3286 if(Lend-Lanf.ge.0) then 3287 Lblocks(4)=(Lend-Lanf)/2+1 3288 Lfirst(4)=Lanf 3289 Llast(4)=Lend 3290 else 3291 Lblocks(4)=0 3292 endif 3293 endif 3294 Lstarter(4)=Lstarter(3)+ 3295 *nanz*Lblocks(3) 3296c 3297CBS now the hole purpose of this routine 3298c 3299 icont4=Lstarter(4)+nanz*Lblocks(4) 3300 return 3301 end 3302 subroutine genovlp(Lhigh) 3303#include "implicit.h" 3304#include "para.h" 3305#include "amfi_param.h" 3306cbs generates overlap of normalized primitives. 3307 dimension evecinv(MxprimL,MxprimL) 3308 do L=0,Lhigh 3309 do Jrun=1,nprimit(L) 3310 do Irun=1,nprimit(L) 3311 normovlp(Irun,Jrun,L)=coulovlp(irun,jrun,0,0, 3312 * L,L) 3313 enddo 3314 enddo 3315cbs invert the matrix, not very elegant, but sufficient 3316 ipnt=0 3317 do jrun=1,nprimit(L) 3318 do irun=1,jrun 3319 ipnt=ipnt+1 3320 scratchinv(ipnt)=normovlp(irun,jrun,L) 3321 enddo 3322 enddo 3323 do Jrun=1,nprimit(L) 3324 do Irun=1,nprimit(L) 3325 evecinv(Irun,Jrun)=0d0 3326 enddo 3327 enddo 3328 do Jrun=1,nprimit(L) 3329 evecinv(jrun,jrun)=1d0 3330 enddo 3331 call jacobi(scratchinv,evecinv,nprimit(L),MxprimL) 3332 do irun=1,nprimit(L) 3333 eval(irun)=dsqrt(scratchinv((irun*irun+irun)/2)) 3334 enddo 3335cbs ensure normalization of the vectors. 3336 do IRUN=1,nprimit(L) 3337 fact=0d0 3338 do JRUN=1,nprimit(L) 3339 fact=fact+evecinv(JRUN,IRUN)*evecinv(JRUN,IRUN) 3340 enddo 3341 fact=1d0/dsqrt(fact) 3342 do JRUN=1,nprimit(L) 3343 evecinv(JRUN,IRUN)=fact*evecinv(JRUN,IRUN) 3344 enddo 3345 enddo 3346cbs now generate rootOVLP 3347 do irun=1,nprimit(L) 3348 do jrun=1,nprimit(L) 3349 rootOVLP(irun,jrun,l)=0d0 3350 enddo 3351 enddo 3352 do jrun=1,nprimit(L) 3353 do irun=1,nprimit(L) 3354 do krun=1,nprimit(L) 3355 rootOVLP(irun,jrun,L)=rootOVLP(irun,jrun,L)+ 3356 *evecinv(irun,krun)*evecinv(jrun,krun)*eval(krun) 3357 enddo 3358 enddo 3359 enddo 3360cbs now generate rootOVLPinv 3361 do irun=1,nprimit(L) 3362 eval(irun)=1d0/eval(irun) 3363 enddo 3364 do irun=1,nprimit(L) 3365 do jrun=1,nprimit(L) 3366 rootOVLPinv(irun,jrun,l)=0d0 3367 enddo 3368 enddo 3369 do jrun=1,nprimit(L) 3370 do irun=1,nprimit(L) 3371 do krun=1,nprimit(L) 3372 rootOVLPinv(irun,jrun,L)=rootOVLPinv(irun,jrun,L)+ 3373 *evecinv(irun,krun)*evecinv(jrun,krun)*eval(krun) 3374 enddo 3375 enddo 3376 enddo 3377cbs now generate OVLPinv 3378 do irun=1,nprimit(L) 3379 eval(irun)=eval(irun)*eval(irun) 3380 enddo 3381 do irun=1,nprimit(L) 3382 do jrun=1,nprimit(L) 3383 OVLPinv(irun,jrun,l)=0d0 3384 enddo 3385 enddo 3386 do jrun=1,nprimit(L) 3387 do irun=1,nprimit(L) 3388 do krun=1,nprimit(L) 3389 OVLPinv(irun,jrun,L)=OVLPinv(irun,jrun,L)+ 3390 *evecinv(irun,krun)*evecinv(jrun,krun)*eval(krun) 3391 enddo 3392 enddo 3393 enddo 3394 enddo 3395 return 3396 end 3397 subroutine genpowers(Lhigh) 3398#include "implicit.h" 3399#include "para.h" 3400#include "amfi_param.h" 3401#include "dofuc.h" 3402cbs set some often used powers of exponents 3403 do L2=0,Lhigh 3404 do L1=0,L2 3405 do irun1=1,nprimit(L1) 3406 do irun2=1,nprimit(L2) 3407 powexp(irun1,irun2,L1,L2,0)=1d0 3408 enddo 3409 enddo 3410 enddo 3411 enddo 3412 do L2=0,Lhigh 3413 do L1=0,L2 3414 do Lrun=1,(L1+L2+5) 3415 do irun2=1,nprimit(L2) 3416 do irun1=1,nprimit(L1) 3417 fact=dsqrt(0.5d0*(exponents(irun1,L1)+exponents(irun2,L2))) 3418 powexp(irun1,irun2,L1,L2,Lrun)= powexp(irun1,irun2,L1,L2,Lrun-1)* 3419 *fact 3420 enddo 3421 enddo 3422 enddo 3423 enddo 3424 enddo 3425cbs generate coulovlp = overlap for normalized functions, but sometimes 3426cbs with shifted l-values 3427 do l2=0,lhigh 3428 do incl2=-1,1 3429 if (l2+incl2.ge.0) then ! do not lower l for s-functions 3430 n2=l2+incl2+1 3431 df2=1d0/dsqrt(df(n2+n2-1)) 3432 do l1=0,l2 3433 do incl1=-1,1 3434 if (l1+incl1.ge.0) then ! do not lower l for s-functions 3435 n1=l1+incl1+1 3436 df1=1d0/dsqrt(df(n1+n1-1)) 3437 df12=df(n1+n2-1) 3438 do iprim2=1,nprimit(l2) 3439 fact2=dsqrt(powexp(iprim2,iprim2,l2,l2,n2+n2+1)) 3440 factor=fact2*df1*df2*df12 3441 do iprim1=1,nprimit(l1) 3442 fact1=dsqrt(powexp(iprim1,iprim1,l1,l1,n1+n1+1)) 3443 coulovlp(iprim1,iprim2,incl1,incl2,l1,l2)= 3444 * fact1*factor/powexp(iprim1,iprim2,l1,l2,n1+n2+1) 3445 enddo 3446 enddo 3447 endif 3448 enddo 3449 enddo 3450 endif 3451 enddo 3452 enddo 3453 return 3454 end 3455 3456 3457 subroutine genstar(Lhigh) 3458#include "implicit.h" 3459#include "para.h" 3460#include "amfi_param.h" 3461cbs purpose: generate start adresses of contraction coeffs on 3462cbs contrarray for the different L-Blocks 3463 istart=1 3464 do L=0,Lhigh 3465 inc=nprimit(L)*ncontrac(L) 3466 iaddori(L)=istart 3467 istart=istart+inc 3468 iaddtyp1(L)=istart 3469 istart=istart+inc 3470 iaddtyp2(L)=istart 3471 istart=istart+inc 3472 iaddtyp3(L)=istart 3473 istart=istart+inc 3474 iaddtyp4(L)=istart 3475 istart=istart+inc 3476 enddo 3477 return 3478 end 3479 subroutine gentkin(L,TKIN,nprims,exponents,rootOVLPinv) 3480#include "implicit.h" 3481#include "para.h" 3482cbs subroutine to generate the kinetic energy 3483 dimension TKIN(nprims,nprims),exponents(*), 3484 *dummy(MxprimL,MxprimL),dummy2(MxprimL,MxprimL), 3485 *rootOVLPinv(MxprimL,MxprimL) 3486cbs one triangular part of the matrix 3487 do irun2=1,nprims 3488 do irun1=1,irun2 3489 dummy(irun1,irun2)= 3490 * Tkinet(l,exponents(irun1), 3491 * exponents(irun2)) 3492 enddo 3493 enddo 3494cbs copy to the other triangular part.... 3495 do irun2=1,nprims-1 3496 do irun1=irun2+1,nprims 3497 dummy(irun1,irun2)=dummy(irun2,irun1) 3498 enddo 3499 enddo 3500cbs now transform by rootovlp*dummy*rootovlp 3501 do jrun=1,nprims 3502 do irun=1,nprims 3503 TKIN(irun,jrun)=0d0 3504 dummy2(irun,jrun)=0d0 3505 enddo 3506 enddo 3507 do irun=1,nprims 3508 do jrun=1,nprims 3509 do krun=1,nprims 3510 dummy2(irun,jrun)=dummy2(irun,jrun)+ 3511 * dummy(irun,krun)*rootovlpinv(krun,jrun) 3512 enddo 3513 enddo 3514 enddo 3515 do irun=1,nprims 3516 do jrun=1,nprims 3517 do krun=1,nprims 3518 Tkin(irun,jrun)=Tkin(irun,jrun)+ 3519 * dummy2(krun,jrun)*rootovlpinv(irun,krun) 3520 enddo 3521 enddo 3522 enddo 3523 return 3524 end 3525 subroutine getAOs(lhigh) 3526#include "implicit.h" 3527#include "dummy.h" 3528#include "priunit.h" 3529#include "para.h" 3530#include "amfi_param.h" 3531cbs get expansions of atomic orbitals in contracted functions 3532 character*12 occtext,occread 3533 character*18 textnorbmf,textnorbmf2 3534 logical EX 3535 occtext='OCCUPATION: ' 3536 textnorbmf='Number of orbitals' 3537 Inquire(File='AO-expansion',exist=EX) 3538 if (.not.EX) then 3539CBS write(6,*) 'get occupations from DATA-block' 3540 call getAOs2(lhigh) 3541 return 3542 endif 3543 LUAOEX = -1 3544 CALL GPOPEN(LUAOEX,'AO-expansion','UNKNOWN',' ','FORMATTED', 3545 & IDUMMY,.FALSE.) 3546 write(LUPRI,*) 'Orbitals for mean-field' 3547 do lrun=0,lhigh 3548 write(LUPRI,'(A3,I3)') 'L= ',lrun 3549 read(LUAOEX,'(A18,I3)') textnorbmf2,noccorb(lrun) 3550 if (textnorbmf.ne.textnorbmf2) 3551 *CALL QUIT('wrong keyword for number of orbitals in getAOs') 3552 write(LUPRI,*) 'number of orbitals ',noccorb(lrun) 3553 do iorbital=1,noccorb(lrun) 3554 read(LUAOEX,'(A12,F6.3)') occread,occup(iorbital,lrun) 3555 write(LUPRI,'(A,F8.4)') occtext,occup(iorbital,lrun) 3556 if (occread.ne.occtext) CALL QUIT('error reading AOs') 3557 read(LUAOEX,*) (AOcoeffs(icont,iorbital,lrun), 3558 *icont=1,ncontrac(lrun)) 3559 write(LUPRI,'(8F10.4)') (AOcoeffs(icont,iorbital,lrun), 3560 *icont=1,ncontrac(lrun)) 3561 write(LUPRI,*) ' ' 3562 read(LUAOEX,*) 3563 enddo 3564 enddo 3565 call gpclose(LUAOEX,'KEEP') 3566 return 3567 end 3568 subroutine getAOs2(lhigh) 3569#include "implicit.h" 3570#include "para.h" 3571#include "amfi_param.h" 3572cbs get expansions of atomic orbitals in contracted functions 3573 common /nucleus/ charge,Exp_finite 3574 character*12 occtext 3575 integer closedshells(0:LMAX),openshells(0:LMAX) 3576 call getocc_ao(int(charge),closedshells,openshells) 3577 occtext='OCCUPATION: ' 3578 do lrun=0,lhigh 3579 do irun=1,MxcontL 3580 do jrun=1,MxcontL 3581 AOcoeffs(jrun,irun,lrun)=0d0 3582 enddo 3583 enddo 3584 enddo 3585CBS write(6,*) 'Orbitals for mean-field' 3586 do lrun=0,lhigh 3587CBS write(6,'(A3,I3)') 'L= ',lrun 3588 do i=1,closedshells(lrun) 3589 occup(i,lrun)=2.0 3590 AOcoeffs(i,i,lrun)=1d0 3591 enddo 3592 noccorb(lrun)=closedshells(lrun) 3593 if (openshells(lrun).gt.0) then 3594 i=closedshells(lrun)+1 3595 occup(i,lrun)=1d0*openshells(lrun)/dfloat(lrun+lrun+1) 3596 AOcoeffs(i,i,lrun)=1d0 3597 noccorb(lrun)=i 3598 endif 3599 if (noccorb(lrun).gt.0) then 3600CBS write(6,'(A,I3)') 'number of orbitals ',noccorb(lrun) 3601CBS do iorbital=1,noccorb(lrun) 3602CBS write(6,'(A,8F8.4)') occtext,(occup(iorbital,lrun), 3603CBS *iorbital=1,noccorb(lrun)) 3604CBS enddo 3605 endif 3606 enddo 3607 return 3608 end 3609cbs 3610 subroutine getocc_ao(icharge,iclosed,iopen) 3611#include "implicit.h" 3612#include "priunit.h" 3613#include "para.h" 3614 parameter (ichargemax=96) 3615 dimension iclocc(0:Lmax_occ,0:ichargemax) 3616 dimension iopocc(0:Lmax_occ,0:ichargemax) 3617 character*30 occtxt(0:96) 3618 character*32 txt 3619 data txt/'SO-integrals are calculated for '/ 3620 dimension iclosed(0:LMAX),iopen(0:LMAX) 3621 data (occtxt(i),i=0,96) / 3622 *'dummy atom (no integrals) ', 3623 *' H: no mean-field ', 3624 *'He: 1s^2 ', 3625 *'Li: [He]2s^1 ', 3626 *'Be: [He]2s^2 ', 3627 *' B: [He]2s^2 2p^1 ', 3628 *' C: [He]2s^2 2p^2 ', 3629 *' N: [He]2s^2 2p^3 ', 3630 *' O: [He]2s^2 2p^4 ', 3631 *' F: [He]2s^2 2p^5 ', 3632 *'Ne: [He]2s^2 2p^6 ', 3633 *'Na: [Ne]3s^1 ', 3634 *'Mg: [Ne]3s^2 ', 3635 *'Al: [Ne]3s^2 3p^1 ', 3636 *'Si: [Ne]3s^2 3p^2 ', 3637 *' P: [Ne]3s^2 3p^3 ', 3638 *' S: [Ne]3s^2 3p^4 ', 3639 *'Cl: [Ne]3s^2 3p^5 ', 3640 *'Ar: [Ne]3s^2 3p^6 ', 3641 *' K: [Ar]4s^1 ', 3642 *'Ca: [Ar]4s^2 ', 3643 *'Sc: [Ar]4s^2 3d^1 ', 3644 *'Ti: [Ar]4s^2 3d^2 ', 3645 *' V: [Ar]4s^2 3d^3 ', 3646 *'Cr: [Ar]4s^2 3d^4 ', 3647 *'Mn: [Ar]4s^2 3d^5 ', 3648 *'Fe: [Ar]4s^2 3d^6 ', 3649 *'Co: [Ar]4s^2 3d^7 ', 3650 *'Ni: [Ar]4s^2 3d^8 ', 3651 *'Cu: [Ar]4s^1 3d^10 ', 3652 *'Zn: [Ar]4s^2 3d^10 ', 3653 *'Ga: [Ar]4s^2 3d^10 4p^1 ', 3654 *'Ge: [Ar]4s^2 3d^10 4p^2 ', 3655 *'As: [Ar]4s^2 3d^10 4p^3 ', 3656 *'Se: [Ar]4s^2 3d^10 4p^4 ', 3657 *'Br: [Ar]4s^2 3d^10 4p^5 ', 3658 *'Kr: [Ar]4s^2 3d^10 4p^6 ', 3659 *'Rb: [Kr]5s^1 ', 3660 *'Sr: [Kr]5s^2 ', 3661 *' Y: [Kr]5s^2 4d^1 ', 3662 *'Zr: [Kr]5s^2 4d^2 ', 3663 *'Nb: [Kr]5s^2 4d^3 ', 3664 *'Mo: [Kr]5s^2 4d^4 ', 3665 *'Tc: [Kr]5s^2 4d^5 ', 3666 *'Ru: [Kr]5s^2 4d^6 ', 3667 *'Rh: [Kr]5s^2 4d^7 ', 3668 *'Pd: [Kr]5s^2 4d^8 ', 3669 *'Ag: [Kr]5s^1 4d^10 ', 3670 *'Cd: [Kr]5s^2 4d^10 ', 3671 *'In: [Kr]5s^2 4d^10 5p^1 ', 3672 *'Sn: [Kr]5s^2 4d^10 5p^2 ', 3673 *'Sb: [Kr]5s^2 4d^10 5p^3 ', 3674 *'Te: [Kr]5s^2 4d^10 5p^4 ', 3675 *' I: [Kr]5s^2 4d^10 5p^5 ', 3676 *'Xe: [Kr]5s^2 4d^10 5p^6 ', 3677 *'Cs: [Xe]6s^1 ', 3678 *'Ba: [Xe]6s^2 ', 3679 *'La: [Xe]6s^2 5d^1 ', 3680 *'Ce: [Xe]6s^2 4f^2 ', 3681 *'Pr: [Xe]6s^2 4f^3 ', 3682 *'Nd: [Xe]6s^2 4f^4 ', 3683 *'Pm: [Xe]6s^2 4f^5 ', 3684 *'Sm: [Xe]6s^2 4f^6 ', 3685 *'Eu: [Xe]6s^2 4f^7 ', 3686 *'Gd: [Xe]6s^2 4f^8 ', 3687 *'Tb: [Xe]6s^2 4f^9 ', 3688 *'Dy: [Xe]6s^2 4f^10 ', 3689 *'Ho: [Xe]6s^2 4f^11 ', 3690 *'Er: [Xe]6s^2 4f^12 ', 3691 *'Tm: [Xe]6s^2 4f^13 ', 3692 *'Yb: [Xe]6s^2 4f^14 ', 3693 *'Lu: [Xe+4f^14]6s^2 5d^1 ', 3694 *'Hf: [Xe+4f^14]6s^2 5d^2 ', 3695 *'Ta: [Xe+4f^14]6s^2 5d^3 ', 3696 *' W: [Xe+4f^14]6s^2 5d^4 ', 3697 *'Re: [Xe+4f^14]6s^2 5d^5 ', 3698 *'Os: [Xe+4f^14]6s^2 5d^6 ', 3699 *'Ir: [Xe+4f^14]6s^2 5d^7 ', 3700 *'Pt: [Xe+4f^14]6s^1 5d^9 ', 3701 *'Au: [Xe+4f^14]6s^1 5d^10 ', 3702 *'Hg: [Xe+4f^14]6s^2 5d^10 ', 3703 *'Tl: [Xe+4f^14+5d^10]6s^2 6p^1 ', 3704 *'Pb: [Xe+4f^14+5d^10]6s^2 6p^2 ', 3705 *'Bi: [Xe+4f^14+5d^10]6s^2 6p^3 ', 3706 *'Po: [Xe+4f^14+5d^10]6s^2 6p^4 ', 3707 *'At: [Xe+4f^14+5d^10]6s^2 6p^5 ', 3708 *'Rn: [Xe+4f^14+5d^10]6s^2 6p^6 ', 3709 *'Fr: [Rn]7s^1 ', 3710 *'Ra: [Rn]7s^2 ', 3711 *'Ac: [Rn]7s^2 6d^1 ', 3712 *'Th: [Rn]7s^2 6d^2 ', 3713 *'Pa: [Rn]7s^2 6d^1 5f^2 ', 3714 *' U: [Rn]7s^2 6d^1 5f^3 ', 3715 *'Np: [Rn]7s^2 6d^1 5f^4 ', 3716 *'Pu: [Rn]7s^2 6d^0 5f^6 ', 3717 *'Am: [Rn]7s^2 6d^0 5f^7 ', 3718 *'Cm: [Rn]7s^2 6d^0 5f^8 '/ 3719 data ((iclocc(i,j),i=0,LMAX_occ),j=0,ichargemax) / 3720 & 0 , 0, 0, 0, !0 3721 & 0 , 0, 0, 0, !1 3722 & 1 , 0, 0, 0, !2 3723 & 1 , 0, 0, 0, !3 3724 & 2 , 0, 0, 0, !4 3725 & 2 , 0, 0, 0, !5 3726 & 2 , 0, 0, 0, !6 3727 & 2 , 0, 0, 0, !7 3728 & 2 , 0, 0, 0, !8 3729 & 2 , 0, 0, 0, !9 3730 & 2 , 1, 0, 0, !10 3731c 3732 & 2 , 1, 0, 0, !11 3733 & 3 , 1, 0, 0, !12 3734 & 3 , 1, 0, 0, !13 3735 & 3 , 1, 0, 0, !14 3736 & 3 , 1, 0, 0, !15 3737 & 3 , 1, 0, 0, !16 3738 & 3 , 1, 0, 0, !17 3739 & 3 , 2, 0, 0, !18 3740 & 3 , 2, 0, 0, !19 3741 & 4 , 2, 0, 0, !20 3742c 3743 & 4 , 2, 0, 0, !21 3744 & 4 , 2, 0, 0, !22 3745 & 4 , 2, 0, 0, !23 3746 & 4 , 2, 0, 0, !24 3747 & 4 , 2, 0, 0, !25 3748 & 4 , 2, 0, 0, !26 3749 & 4 , 2, 0, 0, !27 3750 & 4 , 2, 0, 0, !28 3751 & 3 , 2, 1, 0, !29 3752 & 4 , 2, 1, 0, !30 3753c 3754 & 4 , 2, 1, 0, !31 3755 & 4 , 2, 1, 0, !32 3756 & 4 , 2, 1, 0, !33 3757 & 4 , 2, 1, 0, !34 3758 & 4 , 2, 1, 0, !35 3759 & 4 , 3, 1, 0, !36 3760 & 4 , 3, 1, 0, !37 3761 & 5 , 3, 1, 0, !38 3762 & 5 , 3, 1, 0, !39 3763 & 5 , 3, 1, 0, !40 3764c 3765 & 5 , 3, 1, 0, !41 3766 & 5 , 3, 1, 0, !42 3767 & 5 , 3, 1, 0, !43 3768 & 5 , 3, 1, 0, !44 3769 & 5 , 3, 1, 0, !45 3770 & 5 , 3, 1, 0, !46 3771 & 4 , 3, 2, 0, !47 3772 & 5 , 3, 2, 0, !48 3773c 3774 & 5 , 3, 2, 0, !49 3775 & 5 , 3, 2, 0, !50 3776 & 5 , 3, 2, 0, !51 3777 & 5 , 3, 2, 0, !52 3778 & 5 , 3, 2, 0, !53 3779 & 5 , 4, 2, 0, !54 3780 & 5 , 4, 2, 0, !55 3781 & 6 , 4, 2, 0, !56 3782 & 6 , 4, 2, 0, !57 3783 & 6 , 4, 2, 0, !58 3784 & 6 , 4, 2, 0, !59 3785 & 6 , 4, 2, 0, !60 3786c 3787 & 6 , 4, 2, 0, !61 3788 & 6 , 4, 2, 0, !62 3789 & 6 , 4, 2, 0, !63 3790 & 6 , 4, 2, 0, !64 3791 & 6 , 4, 2, 0, !65 3792 & 6 , 4, 2, 0, !66 3793 & 6 , 4, 2, 0, !67 3794 & 6 , 4, 2, 0, !68 3795 & 6 , 4, 2, 0, !69 3796 & 6 , 4, 2, 1, !70 3797c 3798 & 6 , 4, 2, 1, !71 3799 & 6 , 4, 2, 1, !72 3800 & 6 , 4, 2, 1, !73 3801 & 6 , 4, 2, 1, !74 3802 & 6 , 4, 2, 1, !75 3803 & 6 , 4, 2, 1, !76 3804 & 6 , 4, 2, 1, !77 3805 & 5 , 4, 2, 1, !78 3806 & 5 , 4, 3, 1, !79 3807 & 6 , 4, 3, 1, !80 3808c 3809 & 6 , 4, 3, 1, !81 3810 & 6 , 4, 3, 1, !82 3811 & 6 , 4, 3, 1, !83 3812 & 6 , 4, 3, 1, !84 3813 & 6 , 4, 3, 1, !85 3814 & 6 , 5, 3, 1, !86 3815 & 6 , 5, 3, 1, !87 3816 & 7 , 5, 3, 1, !88 3817 & 7 , 5, 3, 1, !89 3818 & 7 , 5, 3, 1, !90 3819c 3820 & 7 , 5, 3, 1, !91 3821 & 7 , 5, 3, 1, !92 3822 & 7 , 5, 3, 1, !93 3823 & 7 , 5, 3, 1, !94 3824 & 7 , 5, 3, 1, !95 3825 & 7 , 5, 3, 1/ !96 3826cbs 3827 data ((iopocc(i,j),i=0,LMAX_occ),j=0,ichargemax) / 3828 & 0 , 0, 0, 0, !0 3829c 3830 & 0 , 0, 0, 0, ! 1 3831 & 0 , 0, 0, 0, ! 2 3832 & 1 , 0, 0, 0, ! 3 3833 & 0 , 0, 0, 0, ! 4 3834 & 0 , 1, 0, 0, ! 5 3835 & 0 , 2, 0, 0, ! 6 3836 & 0 , 3, 0, 0, ! 7 3837 & 0 , 4, 0, 0, ! 8 3838 & 0 , 5, 0, 0, ! 9 3839 & 0 , 0, 0, 0, ! 10 3840c 3841 & 1 , 0, 0, 0, ! 11 3842 & 0 , 0, 0, 0, ! 12 3843 & 0 , 1, 0, 0, ! 13 3844 & 0 , 2, 0, 0, ! 14 3845 & 0 , 3, 0, 0, ! 15 3846 & 0 , 4, 0, 0, ! 16 3847 & 0 , 5, 0, 0, ! 17 3848 & 0 , 0, 0, 0, ! 18 3849 & 1 , 0, 0, 0, ! 19 3850 & 0 , 0, 0, 0, ! 20 3851c 3852 & 0 , 0, 1, 0, ! 21 3853 & 0 , 0, 2, 0, ! 22 3854 & 0 , 0, 3, 0, ! 23 3855 & 0 , 0, 4, 0, ! 24 3856 & 0 , 0, 5, 0, ! 25 3857 & 0 , 0, 6, 0, ! 26 3858 & 0 , 0, 7, 0, ! 27 3859 & 0 , 0, 8, 0, ! 28 3860 & 1 , 0, 0, 0, ! 29 3861 & 0 , 0, 0, 0, ! 30 3862c 3863 & 0 , 1, 0, 0, ! 31 3864 & 0 , 2, 0, 0, ! 32 3865 & 0 , 3, 0, 0, ! 33 3866 & 0 , 4, 0, 0, ! 34 3867 & 0 , 5, 0, 0, ! 35 3868 & 0 , 0, 0, 0, ! 36 3869 & 1 , 0, 0, 0, ! 37 3870 & 0 , 0, 0, 0, ! 38 3871 & 0 , 0, 1, 0, ! 39 3872 & 0 , 0, 2, 0, ! 40 3873c 3874 & 0 , 0, 3, 0, ! 41 3875 & 0 , 0, 4, 0, ! 42 3876 & 0 , 0, 5, 0, ! 43 3877 & 0 , 0, 6, 0, ! 44 3878 & 0 , 0, 7, 0, ! 45 3879 & 0 , 0, 8, 0, ! 46 3880 & 1 , 0, 0, 0, ! 47 3881 & 0 , 0, 0, 0, ! 48 3882 & 0 , 1, 0, 0, ! 49 3883 & 0 , 2, 0, 0, ! 50 3884c 3885 & 0 , 3, 0, 0, ! 51 3886 & 0 , 4, 0, 0, ! 52 3887 & 0 , 5, 0, 0, ! 53 3888 & 0 , 0, 0, 0, ! 54 3889 & 1 , 0, 0, 0, ! 55 3890 & 0 , 0, 0, 0, ! 56 3891 & 0 , 0, 1, 0, ! 57 3892 & 0 , 0, 0, 2, ! 58 3893 & 0 , 0, 0, 3, ! 59 3894 & 0 , 0, 0, 4, ! 60 3895c 3896 & 0 , 0, 0, 5, ! 61 3897 & 0 , 0, 0, 6, ! 62 3898 & 0 , 0, 0, 7, ! 63 3899 & 0 , 0, 0, 8, ! 64 3900 & 0 , 0, 0, 9, ! 65 3901 & 0 , 0, 0, 10, ! 66 3902 & 0 , 0, 0, 11, ! 67 3903 & 0 , 0, 0, 12, ! 68 3904 & 0 , 0, 0, 13, ! 69 3905 & 0 , 0, 0, 0, ! 70 3906c 3907 & 0 , 0, 1, 0, ! 71 3908 & 0 , 0, 2, 0, ! 72 3909 & 0 , 0, 3, 0, ! 73 3910 & 0 , 0, 4, 0, ! 74 3911 & 0 , 0, 5, 0, ! 75 3912 & 0 , 0, 6, 0, ! 76 3913 & 0 , 0, 7, 0, ! 77 3914 & 1 , 0, 9, 0, ! 78 3915 & 1 , 0, 0, 0, ! 79 3916 & 0 , 0, 0, 0, ! 80 3917c 3918 & 0 , 1, 0, 0, ! 81 3919 & 0 , 2, 0, 0, ! 82 3920 & 0 , 3, 0, 0, ! 83 3921 & 0 , 4, 0, 0, ! 84 3922 & 0 , 5, 0, 0, ! 85 3923 & 0 , 0, 0, 0, ! 86 3924 & 1 , 0, 0, 0, ! 87 3925 & 0 , 0, 0, 0, ! 88 3926 & 0 , 0, 1, 0, ! 89 3927 & 0 , 0, 2, 0, ! 90 3928c 3929 & 0 , 0, 1, 2, ! 91 3930 & 0 , 0, 1, 3, ! 92 3931 & 0 , 0, 1, 4, ! 93 3932 & 0 , 0, 0, 6, ! 94 3933 & 0 , 0, 0, 7, ! 95 3934 & 0 , 0, 0, 8/ ! 96 3935cbs 3936 if (icharge.gt.ichargemax) then 3937 CALL QUIT('occupations not implemented') 3938 endif 3939 write(LUPRI,'(A32,A30)') txt,occtxt(icharge) 3940 do irun=0,min(lmax,lmax_occ) 3941 iclosed(irun)=iclocc(irun,icharge) 3942 iopen(irun)=iopocc(irun,icharge) 3943 end do 3944 do irun=min(lmax,lmax_occ)+1,lmax 3945 iclosed(irun)=0 3946 iopen(irun)=0 3947 end do 3948 return 3949 end 3950 double precision function getCG( 3951 *j1, j2, j3, m1, m2, m3) 3952c *j1, ! integer 2*j1 3953c *j2, ! integer 2*j2 3954c *j3, ! integer 2*j3 3955c *m1, ! integer 2*m1 3956c *m2, ! integer 2*m2 3957c *m3) ! integer 2*m2 3958cbs this routine calculates the Clebsch-Gordon-coefficients 3959cbs by actually calculating the 3j-symbol 3960cbs --- --- 3961cbs | j1 j2 | j3 | j1+m1+j2-m2 3962cbs | | | = (-) sqrt (2 j3+1) * 3963cbs | m1 m2 | m3 | 3964cbs --- --- 3965cbs 3966cbs --- --- 3967cbs | j1 j2 j3 | 3968cbs | | 3969cbs | m1 m2 -m3 | 3970cbs --- --- 3971#include "implicit.h" 3972cbs initialize CG-coefficient 3973 getCG=0d0 3974cbs quick check 3975 if (m1+m2.ne.m3) return 3976 if (j1.lt.0.or.j2.lt.0.or.j3.lt.0) return 3977cbs check the correct sign beginning 3978 idummy=(j1+j2+m1-m2)/2 3979 if (mod(idummy,2).eq.0) then 3980 isign=1 3981 else 3982 isign=-1 3983 endif 3984cbs check the correct sign end 3985 fac1=dsqrt(dfloat(j3+1)) 3986 fac2=regge3j(j1,j2,j3,m1,m2,-m3) 3987 getCG=isign*fac1*fac2 3988 return 3989 end 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 subroutine getLIMIT(l1,l2,l3,l4,Lanf,Lend) 4000#include "implicit.h" 4001#include "priunit.h" 4002cbs get the minimum and maximum L-values 4003cbs of the the coulomb-potential to interact 4004cbs with l1-l4 4005 lower1=iabs(l1-l3) 4006 lower2=iabs(l2-l4) 4007 lupper1=l1+l3 4008 lupper2=l2+l4 4009 Lanf=max(lower1,lower2) 4010 Lend=min(lupper1,lupper2) 4011cbs check for parity 4012 lsum=Lanf+l1+l3 4013 if (mod(lsum,2).eq.1) Lanf=Lanf+1 4014 lsum=Lend+l1+l3 4015 if (mod(lsum,2).eq.1) Lend=Lend-1 4016cbs check the other parity 4017 lsum=Lanf+l2+l4 4018 if (mod(lsum,2).eq.1) then 4019 write(LUPRI,*) ' error in getLIMIT: ' 4020 write(LUPRI,*) ' parity inconsistency for ' 4021 write(LUPRI,*) 'l1,l2,l3,l4= ',l1,l2,l3,l4 4022 CALL QUIT('Inconsistency error in getLIMIT') 4023 endif 4024 return 4025 end 4026 subroutine getpow(max,quot,quotpow, 4027 *nprim1,nprim2,nprim3,nprim4) 4028cbs generates some powers of for the prefactors of cfunct(X) 4029cbs look out for details there and in initfrac 4030#include "implicit.h" 4031#include "para.h" 4032 dimension quotpow(nprim1,nprim2, 4033 *nprim3,nprim4), 4034 *quot(nprim1,nprim2,nprim3,nprim4) 4035 do irun4=1,nprim4 4036 do irun3=1,nprim3 4037 do irun2=1,nprim2 4038 do irun1=1,nprim1 4039 quotpow(irun1,irun2,irun3,irun4)= 4040 *dsqrt(quot(irun1,irun2,irun3,irun4)) 4041 enddo 4042 enddo 4043 enddo 4044 enddo 4045 if (max.eq.1) return 4046cbs 4047 do irun=2,max 4048 do irun4=1,nprim4 4049 do irun3=1,nprim3 4050 do irun2=1,nprim2 4051 do irun1=1,nprim1 4052 quotpow(irun1,irun2,irun3,irun4)= 4053 *quotpow(irun1,irun2,irun3,irun4)* 4054 *quot(irun1,irun2,irun3,irun4) 4055 enddo 4056 enddo 4057 enddo 4058 enddo 4059 enddo 4060 return 4061 end 4062 subroutine inidf 4063cbs initializes the df on common block with double facultatives 4064#include "implicit.h" 4065#include "para.h" 4066#include "amfi_param.h" 4067#include "dofuc.h" 4068 df(0)=1.d0 4069 df(1)=1.d0 4070 do irun=2,ndfmx 4071 df(irun)=dfloat(irun)*df(irun-2) 4072 enddo 4073 do jbm=0,ndfmx-1 4074 do ibm=jbm,ndfmx 4075 dffrac(ibm,jbm)=df(ibm)/df(jbm) 4076 enddo 4077 enddo 4078 do jbm=1,ndfmx 4079 do ibm=0,jbm-1 4080 dffrac(ibm,jbm)=1d0/dffrac(jbm,ibm) 4081 enddo 4082 enddo 4083 return 4084 end 4085 subroutine initfrac(nprimit1,nprimit2, 4086 *nprimit3,nprimit4, 4087 *quot1,quot2,expo1,expo2, 4088 *expo3,expo4) 4089cbs initialize some arrays with factors needed for cfunct(x) 4090#include "implicit.h" 4091 dimension expo1(*),expo2(*),expo3(*),expo4(*), 4092 *quot1(nprimit1,nprimit2,nprimit3,nprimit4), 4093 *quot2(nprimit1,nprimit2,nprimit3,nprimit4) 4094 do irun4=1,nprimit4 4095 do irun3=1,nprimit3 4096 do irun2=1,nprimit2 4097 sum24=expo2(irun2)+expo4(irun4) 4098 do irun1=1,nprimit1 4099 quot1(irun1,irun2,irun3,irun4)= 4100 * 1d0/(1d0+(expo1(irun1)+expo3(irun3))/ 4101 * sum24) 4102 enddo 4103 enddo 4104 enddo 4105 enddo 4106 do irun4=1,nprimit4 4107 do irun3=1,nprimit3 4108 do irun2=1,nprimit2 4109 sum24=expo2(irun2)+expo4(irun4) 4110 do irun1=1,nprimit1 4111 quot2(irun1,irun2,irun3,irun4)= 4112 * 1d0/(1d0+sum24/ 4113 * (expo1(irun1)+expo3(irun3))) 4114 enddo 4115 enddo 4116 enddo 4117 enddo 4118 return 4119 end 4120 subroutine initired 4121#include "implicit.h" 4122cbs initialize all information for ireducible representations 4123cbs later on, it might be useful to have a switch for 4124cbs changing to other orders of IREDs like e.g. in TURBOMOLE 4125c 4126c 4127c HOW2ADD another symmetry: 4128c 4129c 1. add it in readbas.f to be accepted. Add the number of IRs 4130c 4131c 2. copy one of the symmetry-blocks in this subroutine and 4132c edit the multiplication-table for the group 4133c 4134c 3. assign the right IRs to L_X, L_Y and L_Z 4135c 4136c that is all. Good luck!!! 4137c 4138#include "priunit.h" 4139#include "para.h" 4140#include "ired.h" 4141 character*3 symmetry 4142 symmetry='D2H' ! MOLCAS-Version 4143 if (symmetry.eq.'D2H') then 4144 mult(2,1)=2 4145 mult(3,1)=3 4146 mult(4,1)=4 4147 mult(5,1)=5 4148 mult(6,1)=6 4149 mult(7,1)=7 4150 mult(8,1)=8 4151c 4152 mult(3,2)=4 4153 mult(4,2)=3 4154 mult(5,2)=6 4155 mult(6,2)=5 4156 mult(7,2)=8 4157 mult(8,2)=7 4158c 4159 mult(4,3)=2 4160 mult(5,3)=7 4161 mult(6,3)=8 4162 mult(7,3)=5 4163 mult(8,3)=6 4164c 4165 mult(5,4)=8 4166 mult(6,4)=7 4167 mult(7,4)=6 4168 mult(8,4)=5 4169c 4170 mult(6,5)=2 4171 mult(7,5)=3 4172 mult(8,5)=4 4173c 4174 mult(7,6)=4 4175 mult(8,6)=3 4176c 4177 mult(8,7)=2 4178c 4179C 4180 do ired=1,8 4181 mult(ired,ired)=1 4182 enddo 4183 do irun=2,8 4184 do jrun=1,irun-1 4185 mult(jrun,irun)=mult(irun,jrun) 4186 enddo 4187 enddo 4188CBS write(6,*) 4189CBS write(6,*) 4190CBS *'multiplicitation table (atkins,child and phillips)' 4191CBS write(6,*) 4192CBS do ired=1,8 4193CBS write(6,'(8I5)') (mult(jred,ired),jred=1,8) 4194CBS write(6,*) 4195CBS enddo 4196 4197c 4198 IRLX=4 4199 IRLY=3 4200 IRLZ=2 4201cbs assume same order of ireds as Atkins Child and Phillips use.. 4202cbs would lead to an order with 1 to 1, 2 to 2 ... 4203cbs however, this is the molecule/ seward order. 4204 iredorder(1)=1 4205 iredorder(2)=4 4206 iredorder(3)=6 4207 iredorder(4)=7 4208 iredorder(5)=8 4209 iredorder(6)=5 4210 iredorder(7)=3 4211 iredorder(8)=2 4212 do ired=1,8 4213 iredorderinv(iredorder(ired))=ired 4214 enddo 4215 ipow2ired(0,0,0)=iredorder(1) 4216 ipow2ired(1,1,0)=iredorder(2) 4217 ipow2ired(1,0,1)=iredorder(3) 4218 ipow2ired(0,1,1)=iredorder(4) 4219 ipow2ired(1,1,1)=iredorder(5) 4220 ipow2ired(0,0,1)=iredorder(6) 4221 ipow2ired(0,1,0)=iredorder(7) 4222 ipow2ired(1,0,0)=iredorder(8) 4223c write(6,*) 'interacting IRs ' 4224 do ired=1,8 4225 IRwithLX(ired)= 4226 *iredorder(mult(IRLX,iredorderinv(ired))) 4227 IRwithLY(ired)= 4228 *iredorder(mult(IRLY,iredorderinv(ired))) 4229 IRwithLZ(ired)= 4230 *iredorder(mult(IRLZ,iredorderinv(ired))) 4231c write(6,*) IRwithLX(ired),IRwithLY(ired), 4232c *IRwithLZ(ired) 4233 enddo 4234 elseif(symmetry.eq.'C2V') then 4235cbs 1. A1 2. A2 3. B1 4. B2 4236 mult(2,1)=2 4237 mult(3,1)=3 4238 mult(4,1)=4 4239c 4240 mult(3,2)=4 4241 mult(4,2)=3 4242c 4243 mult(4,3)=2 4244C 4245 do ired=1,4 4246 mult(ired,ired)=1 4247 enddo 4248 do irun=2,4 4249 do jrun=1,irun-1 4250 mult(jrun,irun)=mult(irun,jrun) 4251 enddo 4252 enddo 4253 write(LUPRI,*) 4254 write(LUPRI,*) 4255 *'multiplicitation table ' 4256 write(LUPRI,*) 4257 do ired=1,4 4258 write(LUPRI,'(4I5)') (mult(jred,ired),jred=1,4) 4259 write(LUPRI,*) 4260 enddo 4261 4262c 4263 IRLX=4 4264 IRLY=3 4265 IRLZ=2 4266cbs this is the molecule/ seward order. 4267 iredorder(1)=1 4268 iredorder(2)=4 4269 iredorder(3)=2 4270 iredorder(4)=3 4271 do ired=1,4 4272 iredorderinv(iredorder(ired))=ired 4273 enddo 4274 ipow2ired(0,0,0)=iredorder(1) 4275 ipow2ired(1,1,0)=iredorder(2) 4276 ipow2ired(1,0,1)=iredorder(3) 4277 ipow2ired(0,1,1)=iredorder(4) 4278 ipow2ired(1,1,1)=iredorder(2) 4279 ipow2ired(0,0,1)=iredorder(1) 4280 ipow2ired(0,1,0)=iredorder(4) 4281 ipow2ired(1,0,0)=iredorder(3) 4282c write(6,*) 'interacting IRs ' 4283 do ired=1,4 4284 IRwithLX(ired)= 4285 *iredorder(mult(IRLX,iredorderinv(ired))) 4286 IRwithLY(ired)= 4287 *iredorder(mult(IRLY,iredorderinv(ired))) 4288 IRwithLZ(ired)= 4289 *iredorder(mult(IRLZ,iredorderinv(ired))) 4290c write(6,*) IRwithLX(ired),IRwithLY(ired), 4291c *IRwithLZ(ired) 4292 enddo 4293 elseif(symmetry.eq.'D2 ') then 4294cbs 1. A1 2. B1 3. B2 4. B3 4295 mult(2,1)=2 4296 mult(3,1)=3 4297 mult(4,1)=4 4298c 4299 mult(3,2)=4 4300 mult(4,2)=3 4301 mult(4,3)=2 4302C 4303 do ired=1,4 4304 mult(ired,ired)=1 4305 enddo 4306 do irun=2,4 4307 do jrun=1,irun-1 4308 mult(jrun,irun)=mult(irun,jrun) 4309 enddo 4310 enddo 4311 write(LUPRI,*) 4312 write(LUPRI,*) 4313 *'multiplicitation table ' 4314 write(LUPRI,*) 4315 do ired=1,4 4316 write(LUPRI,'(4I5)') (mult(jred,ired),jred=1,4) 4317 write(LUPRI,*) 4318 enddo 4319 4320c 4321 IRLX=4 4322 IRLY=3 4323 IRLZ=2 4324 iredorder(1)=1 4325 iredorder(2)=2 4326 iredorder(3)=3 4327 iredorder(4)=4 4328 do ired=1,4 4329 iredorderinv(iredorder(ired))=ired 4330 enddo 4331 ipow2ired(0,0,0)=iredorder(1) 4332 ipow2ired(1,1,0)=iredorder(2) 4333 ipow2ired(1,0,1)=iredorder(3) 4334 ipow2ired(0,1,1)=iredorder(4) 4335 ipow2ired(1,1,1)=iredorder(1) 4336 ipow2ired(0,0,1)=iredorder(2) 4337 ipow2ired(0,1,0)=iredorder(3) 4338 ipow2ired(1,0,0)=iredorder(4) 4339c write(6,*) 'interacting IRs ' 4340 do ired=1,4 4341 IRwithLX(ired)= 4342 *iredorder(mult(IRLX,iredorderinv(ired))) 4343 IRwithLY(ired)= 4344 *iredorder(mult(IRLY,iredorderinv(ired))) 4345 IRwithLZ(ired)= 4346 *iredorder(mult(IRLZ,iredorderinv(ired))) 4347c write(6,*) IRwithLX(ired),IRwithLY(ired), 4348c *IRwithLZ(ired) 4349 enddo 4350 elseif(symmetry.eq.'C2H') then 4351cbs assume 1.Ag 2.Au 3.Bg 4.Bu 4352 mult(2,1)=2 4353 mult(3,1)=3 4354 mult(4,1)=4 4355c 4356 mult(3,2)=4 4357 mult(4,2)=3 4358c 4359 mult(4,3)=2 4360C 4361 do ired=1,4 4362 mult(ired,ired)=1 4363 enddo 4364 do irun=2,4 4365 do jrun=1,irun-1 4366 mult(jrun,irun)=mult(irun,jrun) 4367 enddo 4368 enddo 4369 write(LUPRI,*) 4370 write(LUPRI,*) 4371 *'multiplicitation table ' 4372 write(LUPRI,*) 4373 do ired=1,4 4374 write(LUPRI,'(4I5)') (mult(jred,ired),jred=1,4) 4375 write(LUPRI,*) 4376 enddo 4377 4378c 4379 IRLX=3 4380 IRLY=3 4381 IRLZ=1 4382 iredorder(1)=1 4383 iredorder(2)=2 4384 iredorder(3)=3 4385 iredorder(4)=4 4386 do ired=1,4 4387 iredorderinv(iredorder(ired))=ired 4388 enddo 4389 ipow2ired(0,0,0)=iredorder(1) 4390 ipow2ired(1,1,0)=iredorder(1) 4391 ipow2ired(1,0,1)=iredorder(3) 4392 ipow2ired(0,1,1)=iredorder(3) 4393 ipow2ired(1,1,1)=iredorder(2) 4394 ipow2ired(0,0,1)=iredorder(2) 4395 ipow2ired(0,1,0)=iredorder(4) 4396 ipow2ired(1,0,0)=iredorder(4) 4397c write(6,*) 'interacting IRs ' 4398 do ired=1,4 4399 IRwithLX(ired)= 4400 *iredorder(mult(IRLX,iredorderinv(ired))) 4401 IRwithLY(ired)= 4402 *iredorder(mult(IRLY,iredorderinv(ired))) 4403 IRwithLZ(ired)= 4404 *iredorder(mult(IRLZ,iredorderinv(ired))) 4405c write(6,*) IRwithLX(ired),IRwithLY(ired), 4406c *IRwithLZ(ired) 4407 enddo 4408 elseif(symmetry.eq.'CS ') then 4409 write(LUPRI,*) 'CS in initired ' 4410cbs assume 1.A' 2.A' 4411 mult(2,1)=2 4412C 4413 do ired=1,2 4414 mult(ired,ired)=1 4415 enddo 4416 do irun=2,2 4417 do jrun=1,irun-1 4418 mult(jrun,irun)=mult(irun,jrun) 4419 enddo 4420 enddo 4421 write(LUPRI,*) 4422 write(LUPRI,*) 4423 *'multiplicitation table ' 4424 write(LUPRI,*) 4425 do ired=1,2 4426 write(LUPRI,'(2I5)') (mult(jred,ired),jred=1,2) 4427 write(LUPRI,*) 4428 enddo 4429 4430c 4431 IRLX=2 4432 IRLY=2 4433 IRLZ=1 4434 iredorder(1)=1 4435 iredorder(2)=2 4436 do ired=1,2 4437 iredorderinv(iredorder(ired))=ired 4438 enddo 4439 ipow2ired(0,0,0)=iredorder(1) 4440 ipow2ired(1,1,0)=iredorder(1) 4441 ipow2ired(1,0,1)=iredorder(2) 4442 ipow2ired(0,1,1)=iredorder(2) 4443 ipow2ired(1,1,1)=iredorder(2) 4444 ipow2ired(0,0,1)=iredorder(2) 4445 ipow2ired(0,1,0)=iredorder(1) 4446 ipow2ired(1,0,0)=iredorder(1) 4447c write(6,*) 'interacting IRs ' 4448 do ired=1,2 4449 IRwithLX(ired)= 4450 *iredorder(mult(IRLX,iredorderinv(ired))) 4451 IRwithLY(ired)= 4452 *iredorder(mult(IRLY,iredorderinv(ired))) 4453 IRwithLZ(ired)= 4454 *iredorder(mult(IRLZ,iredorderinv(ired))) 4455c write(6,*) IRwithLX(ired),IRwithLY(ired), 4456c *IRwithLZ(ired) 4457 enddo 4458 endif 4459 return 4460 end 4461 subroutine kindiag(TKIN,TKINTRIA,ndim,evec,eval,breit) 4462#include "implicit.h" 4463cbs determines eigenvectors and -values of TKIN 4464 dimension tkin(ndim,ndim), 4465 *TKINTRIA((ndim*ndim+ndim)/2),eval(ndim),evec(ndim,ndim) 4466 logical breit 4467cbs move symmetric matrix to triangular matrix 4468 itria=1 4469 do irun2=1,ndim 4470 do irun1=1,irun2 4471 TKINTRIA(itria)=TKIN(irun1,irun2) 4472 itria=itria+1 4473 enddo 4474 enddo 4475 do irun2=1,ndim 4476 do irun1=1,ndim 4477 evec(irun1,irun2)=0d0 4478 enddo 4479 enddo 4480 do irun1=1,ndim 4481 evec(irun1,irun1)=1d0 4482 enddo 4483cbs now diagonalize 4484 CALL jacobi(TKINTRIA,evec,ndim,ndim) 4485cbs get the eigenvalues 4486 do irun=1,ndim 4487 eval(irun)=TKINTRIA((irun*irun+irun)/2) 4488 enddo 4489 if (breit) then 4490 do irun=1,ndim 4491 eval(irun)=0d0 4492 enddo 4493 endif 4494cbs ensure normalization of the vectors. 4495 do IRUN=1,ndim 4496 fact=0d0 4497 do JRUN=1,ndim 4498 fact=fact+evec(JRUN,IRUN)*evec(JRUN,IRUN) 4499 enddo 4500 fact=1d0/dsqrt(fact) 4501 do JRUN=1,ndim 4502 evec(JRUN,IRUN)=fact*evec(JRUN,IRUN) 4503 enddo 4504 enddo 4505 return 4506 end 4507 Subroutine kinemat(L,ndim,evtkin,type1,type2,Energy) 4508#include "implicit.h" 4509#include "codata.h" 4510cbs at least it's identical with Odd's valuE 4511 parameter (speed2=CVEL*CVEL) 4512 parameter (speed4=speed2*speed2) 4513cbs this routine generates the kinematic A-factors=dsqrt((E+mc^2)/(2E)) 4514cbs (type1) and c*A/(E+mc^2) (type2) 4515cbs The c in the second kinematic factor comes from Jan Almloef and 4516cbs Odd Gropen in Rev in Comp.Chem. 8(1996) 4517 dimension evtkin(*),type1(*),type2(*),Energy(*) 4518c E= dsqrt(p**2 c**2 + m**2 c**4) 4519c p**2= 2*m*TKIN 4520c with m = 1 4521 do Irun=1,ndim 4522 if (evtkin(Irun).lt.0) CALL QUIT('strange kinetic energy ') 4523 Energy(Irun)=(evtkin(Irun)+evtkin(Irun))*speed2+speed4 4524 enddo 4525 do Irun=1,ndim 4526 Energy(Irun)=dsqrt(energy(irun)) 4527 enddo 4528 do Irun=1,ndim 4529! dsqrt((E+mc^2)/(2E)): 4530 type1(Irun)=dsqrt(0.5d0*(1d0+speed2/Energy(Irun))) 4531 enddo 4532! c*A/(E+mc^2) 4533 do Irun=1,ndim 4534 type2(Irun)=CVEL*type1(Irun)/(Energy(Irun)+speed2) 4535 enddo 4536 do Irun=1,ndim 4537 type2(Irun)=2*CVEL*type2(Irun) 4538 enddo 4539 return 4540 end 4541 Double precision function LMdepang( 4542 *L,M,l1,l2,l3,l4,m1,m2,m3,m4,cheater) 4543cbs l1-l4 and m1-m4 are already shifted !! 4544cbs purpose: calculates the angular part of the 4545cbs coulomb-type integrals. See documentation for details... 4546cbs LMdepang= LM dependent angular factors 4547cbs cheater included for a correcting signs, as there were some 4548cbs signs (only signs!!!!) missing when compared to HERMIT 4549cbs B.S. 08.10.96 4550#include "implicit.h" 4551#include "priunit.h" 4552#include "pi.h" 4553 LMdepang=0d0 4554cbs some quick checks 4555 if (L.lt.abs(M)) return 4556 if (l1.lt.abs(m1)) return 4557 if (l2.lt.abs(m2)) return 4558 if (l3.lt.abs(m3)) return 4559 if (l4.lt.abs(m4)) return 4560cbs prefactor 4561 fact1=4d0*pi/dfloat(L+L+1) 4562cbs determining the sign 4563 isum=-l3-l1-l4-l2+2*(M+m3+m4) !???? I am not sure 4564 if (mod(isum,4).eq.0) then 4565 isign=1 4566 elseif (iabs(mod(isum,4)).eq.2) then 4567 isign=-1 4568 else 4569 write(LUPRI,*) 'L,l1,l2,l3,l4,M,m1,m2,m3,m4' 4570 write(LUPRI,'(10I3)') L,l1,l2,l3,l4,M,m1,m2,m3,m4 4571 write(LUPRI,*) 'isum= ',isum,' mod = ',mod(isum,4) 4572 CALL QUIT('error in lmdepang') 4573 endif 4574 fact2=couple3J(L,l3,l1,-M,m3,-m1) 4575 fact3=couple3J(L,l4,l2,M,m4,-m2) 4576C write(6,*) 'fact2,fact3 ',fact2,fact3 4577 LMdepang=cheater*dfloat(isign)*fact1*fact2*fact3 4578 return 4579 end 4580 logical function mcheckxy(m1,m2,m3,m4) 4581 integer m1,m2,m3,m4,int12a,int12b, 4582 *int34a,int34b 4583cbs makes a check, if there is an interaction inbetween cartesian functions 4584cbs with m-values m1-m4 4585 mcheckxy=.true. 4586 int12a=m1+m2 4587 int12b=-m1+m2 4588 int34a=m3+m4 4589 int34b=-m3+m4 4590cbs lots of checks 4591 if (iabs(int12a+int34a).eq.1) return 4592 if (iabs(int12a-int34a).eq.1) return 4593 if (iabs(int12b+int34b).eq.1) return 4594 if (iabs(int12b-int34b).eq.1) return 4595 if (iabs(int12a+int34b).eq.1) return 4596 if (iabs(int12a-int34b).eq.1) return 4597 if (iabs(int12b+int34a).eq.1) return 4598 if (iabs(int12b-int34a).eq.1) return 4599 mcheckxy=.false. 4600 return 4601 end 4602 logical function mcheckz(m1,m2,m3,m4) 4603cbs makes a check, if there is an interaction inbetween cartesian functions 4604cbs with m-values m1-m4 4605 integer m1,m2,m3,m4,int12a,int12b, 4606 *int34a,int34b 4607 mcheckz=.true. 4608 int12a=m1+m2 4609 int12b=-m1+m2 4610 int34a=m3+m4 4611 int34b=-m3+m4 4612cbs lots of checks 4613 if (iabs(int12a+int34a).eq.0) return 4614 if (iabs(int12a-int34a).eq.0) return 4615 if (iabs(int12b+int34b).eq.0) return 4616 if (iabs(int12b-int34b).eq.0) return 4617 if (iabs(int12a+int34b).eq.0) return 4618 if (iabs(int12a-int34b).eq.0) return 4619 if (iabs(int12b+int34a).eq.0) return 4620 if (iabs(int12b-int34a).eq.0) return 4621 mcheckz=.false. 4622 return 4623 end 4624 subroutine mkangL0(Lmax,l1,l2,l3,l4,m1,m2,m3,m4, 4625 *angintSO,angintOO, 4626 *Lfirst,Llast,Lblocks, 4627 *ncont1,ncont2,ncont3, 4628 *ncont4, 4629 *caseaSO,caseb1SO,caseb2SO,casecSO, 4630 *caseaOO,caseb1OO,caseb2OO,casecOO, 4631 *preroots,clebsch,dummy,bonn,breit, 4632 *sameorb) 4633#include "implicit.h" 4634cbs subroutine for combining radial integrals with angular 4635cbs factors for the block with l1,l2,l3,l4,m1,m2,m3m,m4 4636cbs this routine mkangL0 = make angular factors for the L0-part 4637cbs includes both, spin-same and spin-other-orbit parts. 4638 double precision LMdepang 4639 dimension 4640 *angintSO(ncont1,ncont2,ncont3,ncont4), 4641 *angintOO(ncont1,ncont2,ncont3,ncont4), 4642 *Lfirst(*),Llast(*),Lblocks(*), 4643cbs all the arrays with the radial integrals for 4644cbs this combination of l-values 4645 *caseaSO(ncont1*ncont2*ncont3*ncont4,*), ! (2,0) integrals with alpha1*alpha3 4646 *caseb1SO(ncont1*ncont2*ncont3*ncont4,*), ! (0,0) integrals with alpha1 4647 *caseb2SO(ncont1*ncont2*ncont3*ncont4,*), ! (0,0) integrals with alpha3 4648 *casecSO(ncont1*ncont2*ncont3*ncont4,*), ! (-2,0) integrals with factor 1 4649 *caseaOO(ncont1*ncont2*ncont3*ncont4,*), ! (2,0) integrals with alpha1*alpha3 4650 *caseb1OO(ncont1*ncont2*ncont3*ncont4,*), ! (0,0) integrals with alpha1 4651 *caseb2OO(ncont1*ncont2*ncont3*ncont4,*), ! (0,0) integrals with alpha3 4652 *casecOO(ncont1*ncont2*ncont3*ncont4,*), ! (-2,0) integrals with factor 1 4653 *preroots(2,0:Lmax), ! some prefactors: dsqrt( (l(+1))/(2l+1)) 4654 *clebsch(3,2,-Lmax:Lmax,0:Lmax) ! some clebsch gordans, that appear regulary 4655 dimension dummy(0:*) 4656 logical bonn,breiT,sameorb 4657c write(6,*) 'begin mkangL0 ', 4658c *l1,l2,l3,l4,m1,m2,m3,m4 4659cbs 4660 ncontall=ncont1*ncont2*ncont3*ncont4 4661cbs cheater introduced to correct signs, because they were different from HERMIT 4662 if (mod(l1+l2+l3+l4,4).eq.2) then 4663 cheater=1d0 4664 else 4665 cheater=-1d0 4666 endif 4667cbs cleaning up 4668 if (bonn.or.breit.or.sameorb) then 4669 call dzero(angintSO,ncontall) 4670 else 4671 call dzero(angintSO,ncontall) 4672 call dzero(angintOO,ncontall) 4673 endif 4674cbs starting with the same-orbit-contributions 4675cbs first term: ########################################################################### 4676 factor=-preroots(2,l1)*preroots(2,l3)* 4677 *clebsch(1,2,m1,l1)* 4678 *clebsch(1,2,m3,l3) 4679 if (factor.ne.0d0) then 4680cbs get the L,M dependent coefficients 4681 if (Lblocks(1).gt.0) then 4682 do I=0,Lmax+Lmax+1 4683 dummy(I)=0d0 4684 enddo 4685 M=m2-m4 4686 Lrun=1 4687 do L=Lfirst(1),Llast(1),2 4688 dummy(L)=LMdepang(L,M,l1+1,l2,l3+1,l4,m1-1,m2,m3-1,m4,cheater) 4689 if (dummy(L).ne.0d0) then 4690 if (bonn.or.breit.or.sameorb) then 4691 Call daxpy(ncontall,4*factor*dummy(L), 4692 * caseaSO(1,Lrun),1,angintSO,1) 4693 else 4694 call daxpy(ncontall,4*factor*dummy(L), 4695 * caseaSO(1,Lrun),1,angintSO,1) 4696 call daxpy(ncontall, 4697 * 4*factor*dummy(L),CaseaOO(1,Lrun),1,angintOO,1) 4698 endif 4699 endif 4700 Lrun=Lrun+1 4701 enddo 4702 endif 4703 endif 4704cbs second term: ########################################################################### 4705 factor=-preroots(1,l1)*preroots(2,l3)* 4706 *clebsch(1,1,m1,l1)* 4707 *clebsch(1,2,m3,l3) 4708 if (factor.ne.0d0) then 4709 do I=0,Lmax+Lmax+1 4710 dummy(I)=0d0 4711 enddo 4712 Klast=0 4713 Kfirst=Lmax+Lmax+1 ! just to be sure .. 4714cbs get the L,M dependent coefficients 4715 if (Lblocks(1).gt.0) then 4716 M=m2-m4 4717 Kfirst=Lfirst(1) 4718 Klast=Llast(1) 4719 Lrun=1 4720 do L=Lfirst(1),Llast(1),2 4721 dummy(L)=LMdepang(L,M,l1-1,l2,l3+1,l4,m1-1,m2,m3-1,m4,cheater) 4722 if (dummy(L).ne.0d0) then 4723 If (bonn.or.breit.or.sameorb) then 4724 call daxpy(ncontall,4*factor*dummy(L),caseaSO(1,Lrun),1, 4725 * angintSO,1) 4726 else 4727 call daxpy(ncontall,4*factor*dummy(L),caseaSO(1,Lrun),1, 4728 * angintSO,1) 4729 call daxpy(ncontall, 4730 * 4*factor*dummy(L),caseaOO(1,Lrun),1,AngintOO,1) 4731 endif 4732 endif 4733 Lrun=Lrun+1 4734 enddo 4735 endif 4736 if (Lblocks(3).gt.0) then 4737 M=m2-m4 4738 if (Lfirst(3).lt.Kfirst) then 4739 do L=Lfirst(3),Kfirst,2 4740 dummy(L)=LMdepang(L,M,l1-1,l2,l3+1,l4,m1-1,m2, 4741 * m3-1,m4,cheater) 4742 enddo 4743 Kfirst=Lfirst(3) 4744 endif 4745 if (Llast(3).gt.Klast) then 4746 do L=Klast,Llast(3),2 4747 dummy(L)=LMdepang(L,M,l1-1,l2,l3+1,l4,m1-1,m2, 4748 * m3-1,m4,cheater) 4749 enddo 4750 Klast=Llast(3) 4751 endif 4752 Lrun=1 4753 do L=Lfirst(3),Llast(3),2 4754 if (dummy(L).ne.0d0) then 4755 If (bonn.or.breit.or.sameorb) then 4756 call daxpy(ncontall,-(2+4*l1)*factor*dummy(L), 4757 * caseb2SO(1,Lrun),1,angintSO,1) 4758 else 4759 call daxpy(ncontall,-(2+4*l1)*factor*dummy(L), 4760 * caseb2SO(1,Lrun),1,angintSO,1) 4761 call daxpy(ncontall,-(2+4*l1)* 4762 * factor*dummy(L),caseb2OO(1,Lrun),1,angintOO,1) 4763 endif 4764 endif 4765 Lrun=Lrun+1 4766 enddo 4767 endif 4768 endif 4769cbs third term: ########################################################################### 4770 factor=-preroots(2,l1)*preroots(1,l3)* 4771 *clebsch(1,2,m1,l1)* 4772 *clebsch(1,1,m3,l3) 4773 if (factor.ne.0d0) then 4774 do I=0,Lmax+Lmax+1 4775 dummy(I)=0d0 4776 enddo 4777 Klast=0 4778 Kfirst=Lmax+Lmax+1 ! just to be sure .. 4779cbs get the L,M dependent coefficients 4780 if (Lblocks(1).gt.0) then 4781 M=m2-m4 4782 Kfirst=Lfirst(1) 4783 Klast=Llast(1) 4784 Lrun=1 4785 do L=Lfirst(1),Llast(1),2 4786 dummy(L)=LMdepang(L,M,l1+1,l2,l3-1,l4,m1-1,m2, 4787 *m3-1,m4,cheater) 4788 if (dummy(L).ne.0d0) then 4789 If (bonn.or.breit.or.sameorb) then 4790 call daxpy(ncontall,4*factor*dummy(L), 4791 * caseaSO(1,Lrun),1,angintSO,1) 4792 else 4793 call daxpy(ncontall,4*factor*dummy(L), 4794 * caseaSO(1,Lrun),1,angintSO,1) 4795 call daxpy(ncontall, 4796 * 4*factor*dummy(L),CaseaOO(1,Lrun),1,angintOO,1) 4797 endif 4798 endif 4799 Lrun=Lrun+1 4800 enddo 4801 endif 4802 if (Lblocks(2).gt.0) then 4803 M=m2-m4 4804 if (Lfirst(2).lt.Kfirst) then 4805 do L=Lfirst(2),Kfirst,2 4806 dummy(L)=LMdepang(L,M,l1+1,l2,l3-1,l4,m1-1,m2, 4807 * m3-1,m4,cheater) 4808 enddo 4809 Kfirst=Lfirst(2) 4810 endif 4811 if (Llast(2).gt.Klast) then 4812 do L=Klast,Llast(2),2 4813 dummy(L)=LMdepang(L,M,l1+1,l2,l3-1,l4,m1-1,m2, 4814 * m3-1,m4,cheater) 4815 enddo 4816 Klast=Llast(2) 4817 endif 4818 Lrun=1 4819 do L=Lfirst(2),Llast(2),2 4820 if (dummy(L).ne.0d0) then 4821 If (bonn.or.breit.or.sameorb) then 4822 call daxpy(ncontall,-(2+4*l3)*factor*dummy(L), 4823 * caseb1SO(1,Lrun),1,angintSO,1) 4824 else 4825 call daxpy(ncontall,-(2+4*l3)*factor*dummy(L), 4826 * caseb1SO(1,Lrun),1,angintSO,1) 4827 call daxpy(ncontall, 4828 * -(2+4*l3)*factor*dummy(L),caseb1OO(1,Lrun),1,angintOO,1) 4829 endif 4830 endif 4831 Lrun=Lrun+1 4832 enddo 4833 endif 4834 endif 4835cbs fourth term: ########################################################################### 4836 factor=-preroots(1,l1)*preroots(1,l3)* 4837 *clebsch(1,1,m1,l1)* 4838 *clebsch(1,1,m3,l3) 4839 if (factor.ne.0d0) then 4840 do I=0,Lmax+Lmax+1 4841 dummy(I)=0d0 4842 enddo 4843 Klast=0 4844 Kfirst=Lmax+Lmax+1 ! just to be sure .. 4845cbs get the L,M dependent coefficients 4846 if (Lblocks(1).gt.0) then 4847 M=m2-m4 4848 Kfirst=Lfirst(1) 4849 Klast=Llast(1) 4850 Lrun=1 4851 do L=Lfirst(1),Llast(1),2 4852 dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1-1,m2,m3-1,m4,cheater) 4853 if (dummy(L).ne.0d0) then 4854 If (bonn.or.breit.or.sameorb) then 4855 call daxpy(ncontall,4*factor*dummy(L),caseaSO(1,Lrun),1, 4856 * angintSO,1) 4857 else 4858 call daxpy(ncontall,4*factor*dummy(L),caseaSO(1,Lrun),1, 4859 * angintSO,1) 4860 call daxpy(ncontall, 4861 * 4*factor*dummy(L),caseaOO(1,Lrun),1,AngintOO,1) 4862 endif 4863 endif 4864 Lrun=Lrun+1 4865 enddo 4866 endif 4867 if (Lblocks(2).gt.0) then 4868 M=m2-m4 4869 if (Lfirst(2).lt.Kfirst) then 4870 do L=Lfirst(2),Kfirst,2 4871 dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1-1,m2, 4872 * m3-1,m4,cheater) 4873 enddo 4874 Kfirst=Lfirst(2) 4875 endif 4876 if (Llast(2).gt.Klast) then 4877 do L=Klast,Llast(2),2 4878 dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1-1,m2, 4879 * m3-1,m4,cheater) 4880 enddo 4881 Klast=Llast(2) 4882 endif 4883 Lrun=1 4884 do L=Lfirst(2),Llast(2),2 4885 if (dummy(L).ne.0d0) then 4886 If (bonn.or.breit.or.sameorb) then 4887 call daxpy(ncontall,-(2+4*l3)*factor*dummy(L), 4888 * caseb1SO(1,Lrun),1,angintSO,1) 4889 else 4890 call daxpy(ncontall,-(2+4*l3)*factor*dummy(L), 4891 * caseb1SO(1,Lrun),1,angintSO,1) 4892 call daxpy(ncontall, 4893 * -(2+4*l3)*factor*dummy(L),caseb1OO(1,Lrun),1,angintOO,1) 4894 endif 4895 endif 4896 Lrun=Lrun+1 4897 enddo 4898 endif 4899 if (Lblocks(3).gt.0) then 4900 M=m2-m4 4901 if (Lfirst(3).lt.Kfirst) then 4902 do L=Lfirst(3),Kfirst,2 4903 dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1-1,m2, 4904 * m3-1,m4,cheater) 4905 enddo 4906 Kfirst=Lfirst(3) 4907 endif 4908 if (Llast(3).gt.Klast) then 4909 do L=Klast,Llast(3),2 4910 dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1-1,m2, 4911 * m3-1,m4,cheater) 4912 enddo 4913 Klast=Llast(3) 4914 endif 4915 Lrun=1 4916 do L=Lfirst(3),Llast(3),2 4917 if (dummy(L).ne.0d0) then 4918 If (bonn.or.breit.or.sameorb) then 4919 call daxpy(ncontall,-(2+4*l1)*factor*dummy(L), 4920 * caseb2SO(1,Lrun),1,angintSO,1) 4921 else 4922 call daxpy(ncontall,-(2+4*l1)*factor*dummy(L), 4923 * caseb2SO(1,Lrun),1,angintSO,1) 4924 call daxpy(ncontall, 4925 * -(2+4*l1)*factor*dummy(L),caseb2OO(1,Lrun),1,angintOO,1) 4926 endif 4927 endif 4928 Lrun=Lrun+1 4929 enddo 4930 endif 4931 if (Lblocks(4).gt.0) then 4932 M=m2-m4 4933 if (Lfirst(4).lt.Kfirst) then 4934 do L=Lfirst(4),Kfirst,2 4935 dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1-1,m2, 4936 * m3-1,m4,cheater) 4937 enddo 4938 Kfirst=Lfirst(4) 4939 endif 4940 if (Llast(4).gt.Klast) then 4941 do L=Klast,Llast(4),2 4942 dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1-1,m2, 4943 * m3-1,m4,cheater) 4944 enddo 4945 Klast=Llast(4) 4946 endif 4947 Lrun=1 4948 do L=Lfirst(4),Llast(4),2 4949 if (dummy(L).ne.0d0) then 4950 If (bonn.or.breit.or.sameorb) then 4951 call daxpy(ncontall,(4*l1*l3+2*l1+2*l3+1)*factor*dummy(L), 4952 * casecSO(1,Lrun),1,angintSO,1) 4953 else 4954 call daxpy(ncontall,(4*l1*l3+2*l1+2*l3+1)*factor*dummy(L), 4955 * casecSO(1,Lrun),1,angintSO,1) 4956 call daxpy(ncontall, 4957 * (4*l1*l3+2*l1+2*l3+1)*factor*dummy(L), 4958 * casecOO(1,Lrun),1,angintOO,1) 4959 endif 4960 endif 4961 Lrun=Lrun+1 4962 enddo 4963 endif 4964 endif 4965cbs fifth term: ########################################################################### 4966 factor=preroots(2,l1)*preroots(2,l3)* 4967 *clebsch(3,2,m1,l1)* 4968 *clebsch(3,2,m3,l3) 4969 if (factor.ne.0d0) then 4970 do I=0,Lmax+Lmax+1 4971 dummy(I)=0d0 4972 enddo 4973cbs get the L,M dependent coefficients 4974 if (Lblocks(1).gt.0) then 4975 M=m2-m4 4976 Lrun=1 4977 do L=Lfirst(1),Llast(1),2 4978 dummy(L)=LMdepang(L,M,l1+1,l2,l3+1,l4,m1+1,m2,m3+1,m4,cheater) 4979 if (dummy(L).ne.0d0) then 4980 If (bonn.or.breit.or.sameorb) then 4981 call daxpy(ncontall,4*factor*dummy(L),caseaSO(1,Lrun),1, 4982 * angintSO,1) 4983 else 4984 call daxpy(ncontall,4*factor*dummy(L),caseaSO(1,Lrun),1, 4985 * angintSO,1) 4986 call daxpy(ncontall, 4987 * 4*factor*dummy(L),caseaOO(1,Lrun),1,angintOO,1) 4988 endif 4989 endif 4990 Lrun=Lrun+1 4991 enddo 4992 endif 4993 endif 4994cbs sixth term: ########################################################################### 4995 factor=preroots(1,l1)*preroots(2,l3)* 4996 *clebsch(3,1,m1,l1)* 4997 *clebsch(3,2,m3,l3) 4998 if (factor.ne.0d0) then 4999 do I=0,Lmax+Lmax+1 5000 dummy(I)=0d0 5001 enddo 5002 Klast=0 5003 Kfirst=Lmax+Lmax+1 ! just to be sure .. 5004cbs get the L,M dependent coefficients 5005 if (Lblocks(1).gt.0) then 5006 M=m2-m4 5007 Kfirst=Lfirst(1) 5008 Klast=Llast(1) 5009 Lrun=1 5010 do L=Lfirst(1),Llast(1),2 5011 dummy(L)=LMdepang(L,M,l1-1,l2,l3+1,l4,m1+1,m2,m3+1,m4,cheater) 5012 if (dummy(L).ne.0d0) then 5013 If (bonn.or.breit.or.sameorb) then 5014 call daxpy(ncontall,4*factor*dummy(L), 5015 * caseaSO(1,Lrun),1,angintSO,1) 5016 else 5017 call daxpy(ncontall,4*factor*dummy(L), 5018 * caseaSO(1,Lrun),1,angintSO,1) 5019 call daxpy(ncontall, 5020 * 4*factor*dummy(L),caseaOO(1,Lrun),1,angintOO,1) 5021 endif 5022 endif 5023 Lrun=Lrun+1 5024 enddo 5025 endif 5026 if (Lblocks(3).gt.0) then 5027 M=m2-m4 5028 if (Lfirst(3).lt.Kfirst) then 5029 do L=Lfirst(3),Kfirst,2 5030 dummy(L)=LMdepang(L,M,l1-1,l2,l3+1,l4,m1+1,m2, 5031 * m3+1,m4,cheater) 5032 enddo 5033 Kfirst=Lfirst(3) 5034 endif 5035 if (Llast(3).gt.Klast) then 5036 do L=Klast,Llast(3),2 5037 dummy(L)=LMdepang(L,M,l1-1,l2,l3+1,l4,m1+1,m2, 5038 * m3+1,m4,cheater) 5039 enddo 5040 Klast=Llast(3) 5041 endif 5042 Lrun=1 5043 do L=Lfirst(3),Llast(3),2 5044 if (dummy(L).ne.0d0) then 5045 If (bonn.or.breit.or.sameorb) then 5046 call daxpy(ncontall,-(2+4*l1)*factor*dummy(L), 5047 * caseb2SO(1,Lrun),1,angintSO,1) 5048 else 5049 call daxpy(ncontall,-(2+4*l1)*factor*dummy(L), 5050 * caseb2SO(1,Lrun),1,angintSO,1) 5051 call daxpy(ncontall,-(2+4*l1)* 5052 * factor*dummy(L),caseb2OO(1,Lrun),1,angintOO,1) 5053 endif 5054 endif 5055 Lrun=Lrun+1 5056 enddo 5057 endif 5058 endif 5059cbs seventh term: ########################################################################### 5060 factor=preroots(2,l1)*preroots(1,l3)* 5061 *clebsch(3,2,m1,l1)* 5062 *clebsch(3,1,m3,l3) 5063 if (factor.ne.0d0) then 5064 do I=0,Lmax+Lmax+1 5065 dummy(I)=0d0 5066 enddo 5067 Klast=0 5068 Kfirst=Lmax+Lmax+1 ! just to be sure .. 5069cbs get the L,M dependent coefficients 5070 if (Lblocks(1).gt.0) then 5071 M=m2-m4 5072 Kfirst=Lfirst(1) 5073 Klast=Llast(1) 5074 Lrun=1 5075 do L=Lfirst(1),Llast(1),2 5076 dummy(L)=LMdepang(L,M,l1+1,l2,l3-1,l4,m1+1,m2,m3+1,m4,cheater) 5077 if (dummy(L).ne.0d0) then 5078 If (bonn.or.breit.or.sameorb) then 5079 call daxpy(ncontall,4*factor*dummy(L), 5080 * caseaSO(1,Lrun),1,angintSO,1) 5081 else 5082 call daxpy(ncontall,4*factor*dummy(L), 5083 * caseaSO(1,Lrun),1,angintSO,1) 5084 Call daxpy(ncontall, 5085 * 4*factor*dummy(L),caseaOO(1,Lrun),1,angintOO,1) 5086 endif 5087 endif 5088 Lrun=Lrun+1 5089 enddo 5090 endif 5091 if (Lblocks(2).gt.0) then 5092 M=m2-m4 5093 if (Lfirst(2).lt.Kfirst) then 5094 do L=Lfirst(2),Kfirst,2 5095 dummy(L)=LMdepang(L,M,l1+1,l2,l3-1,l4,m1+1,m2, 5096 * m3+1,m4,cheater) 5097 enddo 5098 Kfirst=Lfirst(2) 5099 endif 5100 if (Llast(2).gt.Klast) then 5101 do L=Klast,Llast(2),2 5102 dummy(L)=LMdepang(L,M,l1+1,l2,l3-1,l4,m1+1,m2, 5103 * m3+1,m4,cheater) 5104 enddo 5105 Klast=Llast(2) 5106 endif 5107 Lrun=1 5108 do L=Lfirst(2),Llast(2),2 5109 if (dummy(L).ne.0d0) then 5110 If (bonn.or.breit.or.sameorb) then 5111 call daxpy(ncontall,-(2+4*l3)*factor*dummy(L), 5112 * caseb1SO(1,Lrun),1,angintSO,1) 5113 else 5114 Call daxpy(ncontall,-(2+4*l3)*factor*dummy(L), 5115 * caseb1SO(1,Lrun),1,angintSO,1) 5116 Call daxpy(ncontall,-(2+4*l3)* 5117 * factor*dummy(L),caseb1OO(1,Lrun),1,angintOO,1) 5118 endif 5119 endif 5120 Lrun=Lrun+1 5121 enddo 5122 endif 5123 endif 5124cbs eigth term: ########################################################################### 5125 factor=preroots(1,l1)*preroots(1,l3)* 5126 *clebsch(3,1,m1,l1)* 5127 *clebsch(3,1,m3,l3) 5128 if (factor.ne.0d0) then 5129 do I=0,Lmax+Lmax+1 5130 dummy(I)=0d0 5131 enddo 5132 Klast=0 5133 Kfirst=Lmax+Lmax+1 ! just to be sure .. 5134cbs get the L,M dependent coefficients 5135 if (Lblocks(1).gt.0) then 5136 M=m2-m4 5137 Kfirst=Lfirst(1) 5138 Klast=Llast(1) 5139 Lrun=1 5140 do L=Lfirst(1),Llast(1),2 5141 dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2,m3+1,m4,cheater) 5142 if (dummy(L).ne.0d0) then 5143 If (bonn.or.breit.or.sameorb) then 5144 call daxpy(ncontall,4*factor*dummy(L), 5145 * caseaSO(1,Lrun),1,angintSO,1) 5146 else 5147 call daxpy(ncontall,4*factor*dummy(L), 5148 * caseaSO(1,Lrun),1,angintSO,1) 5149 call daxpy(ncontall, 5150 * 4*factor*dummy(L),caseaOO(1,Lrun),1,angintOO,1) 5151 endif 5152 endif 5153 Lrun=Lrun+1 5154 enddo 5155 endif 5156 if (Lblocks(2).gt.0) then 5157 M=m2-m4 5158 if (Lfirst(2).lt.Kfirst) then 5159 do L=Lfirst(2),Kfirst,2 5160 dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2, 5161 * m3+1,m4,cheater) 5162 enddo 5163 Kfirst=Lfirst(2) 5164 endif 5165 if (Llast(2).gt.Klast) then 5166 do L=Klast,Llast(2),2 5167 dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2, 5168 * m3+1,m4,cheater) 5169 enddo 5170 Klast=Llast(2) 5171 endif 5172 Lrun=1 5173 do L=Lfirst(2),Llast(2),2 5174 if (dummy(L).ne.0d0) then 5175 If (bonn.or.breit.or.sameorb) then 5176 call daxpy(ncontall,-(2+4*l3)*factor*dummy(L), 5177 * caseb1SO(1,Lrun),1,angintSO,1) 5178 else 5179 call daxpy(ncontall,-(2+4*l3)*factor*dummy(L), 5180 * caseb1SO(1,Lrun),1,angintSO,1) 5181 call daxpy(ncontall, 5182 * -(2+4*l3)*factor*dummy(L),caseb1OO(1,Lrun),1,angintOO,1) 5183 endif 5184 endif 5185 Lrun=Lrun+1 5186 enddo 5187 endif 5188 if (Lblocks(3).gt.0) then 5189 M=m2-m4 5190 if (Lfirst(3).lt.Kfirst) then 5191 do L=Lfirst(3),Kfirst,2 5192 dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2, 5193 * m3+1,m4,cheater) 5194 enddo 5195 Kfirst=Lfirst(3) 5196 endif 5197 if (Llast(3).gt.Klast) then 5198 do L=Klast,Llast(3),2 5199 dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2, 5200 * m3+1,m4,cheater) 5201 enddo 5202 Klast=Llast(3) 5203 endif 5204 Lrun=1 5205 do L=Lfirst(3),Llast(3),2 5206 if (dummy(L).ne.0d0) then 5207 If (bonn.or.breit.or.sameorb) then 5208 call daxpy(ncontall,-(2+4*l1)*factor*dummy(L), 5209 * caseb2SO(1,Lrun),1,angintSO,1) 5210 else 5211 call daxpy(ncontall,-(2+4*l1)*factor*dummy(L), 5212 * caseb2SO(1,Lrun),1,angintSO,1) 5213 call daxpy(ncontall,-(2+4*l1)* 5214 * factor*dummy(L),caseb2OO(1,Lrun),1,angintOO,1) 5215 endif 5216 endif 5217 Lrun=Lrun+1 5218 enddo 5219 endif 5220 if (Lblocks(4).gt.0) then 5221 M=m2-m4 5222 if (Lfirst(4).lt.Kfirst) then 5223 do L=Lfirst(4),Kfirst,2 5224 dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2, 5225 * m3+1,m4,cheater) 5226 enddo 5227 Kfirst=Lfirst(4) 5228 endif 5229 if (Llast(4).gt.Klast) then 5230 do L=Klast,Llast(4),2 5231 dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2, 5232 * m3+1,m4,cheater) 5233 enddo 5234 Klast=Llast(4) 5235 endif 5236 Lrun=1 5237 do L=Lfirst(4),Llast(4),2 5238 if (dummy(L).ne.0d0) then 5239 If (bonn.or.breit.or.sameorb) then 5240 call daxpy(ncontall,(4*l1*l3+2*l1+2*l3+1)* 5241 * factor*dummy(L), 5242 * casecSO(1,Lrun),1,angintSO,1) 5243 else 5244 call daxpy(ncontall,(4*l1*l3+2*l1+2*l3+1)* 5245 * factor*dummy(L), 5246 * casecSO(1,Lrun),1,angintSO,1) 5247 call daxpy(ncontall, 5248 * (4*l1*l3+2*l1+2*l3+1)*factor*dummy(L), 5249 * casecOO(1,Lrun),1,angintOO,1) 5250 endif 5251 endif 5252 Lrun=Lrun+1 5253 enddo 5254 endif 5255 endif 5256 return 5257 end 5258 subroutine mkangLmin(Lmax,l1,l2,l3,l4,m1,m2,m3,m4, 5259 *angintSO,angintOO, 5260 *Lfirst,Llast,Lblocks, 5261 *ncont1,ncont2,ncont3, 5262 *ncont4, 5263 *caseaSO,caseb1SO,caseb2SO,casecSO, 5264 *caseaOO,caseb1OO,caseb2OO,casecOO, 5265 *preroots,clebsch,dummy,bonn,breit, 5266 *sameorb) 5267#include "implicit.h" 5268cbs subroutine for combining radial intgrls with angular 5269cbs factors for the block with l1,l2,l3,l4,m1,m2,m3m,m4 5270cbs this routine mkangLmin = make angular factors for the L- -part 5271cbs includes both, spin-same and spin-other-orbit parts. 5272 double precision LMdepang 5273 dimension 5274 *angintSO(ncont1,ncont2,ncont3,ncont4), 5275 *angintOO(ncont1,ncont2,ncont3,ncont4), 5276 *Lfirst(*),Llast(*),Lblocks(*), 5277cbs all the arrays with the radial intgrls for 5278cbs this combination of l-values 5279 *caseaSO(ncont1*ncont2*ncont3*ncont4,*), ! (2,0) intgrls with alpha1*alpha3 5280 *caseb1SO(ncont1*ncont2*ncont3*ncont4,*), ! (0,0) intgrls with alpha1 5281 *caseb2SO(ncont1*ncont2*ncont3*ncont4,*), ! (0,0) intgrls with alpha3 5282 *casecSO(ncont1*ncont2*ncont3*ncont4,*), ! (-2,0) intgrls with factor 1 5283 *caseaOO(ncont1*ncont2*ncont3*ncont4,*), ! (2,0) intgrls with alpha1*alpha3 5284 *caseb1OO(ncont1*ncont2*ncont3*ncont4,*), ! (0,0) intgrls with alpha1 5285 *caseb2OO(ncont1*ncont2*ncont3*ncont4,*), ! (0,0) intgrls with alpha3 5286 *casecOO(ncont1*ncont2*ncont3*ncont4,*), ! (-2,0) intgrls with factor 1 5287 *preroots(2,0:Lmax), ! some prefactors: dsqrt( (l(+1))/(2l+1)) 5288 *clebsch(3,2,-Lmax:Lmax,0:Lmax) ! some clebsch gordans, that appear regulary 5289 dimension dummy(0:*) 5290 logical bonn,breiT,sameorb 5291 root2=dsqrt(2.0d0) 5292 root2inv=1d0/root2 5293c write(6,*) 'begin mkangL- ', 5294c *l1,l2,l3,l4,m1,m2,m3,m4 5295cbs 5296 ncontall=ncont1*ncont2*ncont3*ncont4 5297cbs cheater introduced to correct signs, because they were different from HERMIT 5298 if (mod(l1+l2+l3+l4,4).eq.2) then 5299 cheater=1d0 5300 else 5301 cheater=-1d0 5302 endiF 5303cbs cleaning up 5304 if (bonn.or.breit.or.sameorb) then 5305 call dzero(angintSO,ncontall) 5306 else 5307 call dzero(angintSO,ncontall) 5308 call dzero(angintOO,ncontall) 5309 endif 5310cbs starting with the same-orbit-contributions 5311cbs first term: ########################################################################### 5312 factor=-root2inv*preroots(2,l1)*preroots(2,l3)* 5313 *clebsch(3,2,m1,l1)* 5314 *clebsch(2,2,m3,l3) 5315 if (factor.ne.0d0) then 5316 do I=0,Lmax+Lmax+1 5317 dummy(I)=0d0 5318 enddo 5319cbs get the L,M dependent coefficients 5320 if (Lblocks(1).gt.0) then 5321 M=m2-m4 5322 Lrun=1 5323 do L=Lfirst(1),Llast(1),2 5324 dummy(L)=LMdepang(L,M,l1+1,l2,l3+1,l4,m1+1,m2,m3,m4,cheater) 5325 if (dummy(L).ne.0d0) then 5326 if (bonn.or.breit.or.sameorb) then 5327 call daxpy(ncontall,4*factor*dummy(L), 5328 * caseaSO(1,Lrun),1,angintSO,1) 5329 else 5330 call daxpy(ncontall,4*factor*dummy(L), 5331 * caseaSO(1,Lrun),1,angintSO,1) 5332 call daxpy(ncontall, 5333 * 4*factor*dummy(L),caseaOO(1,Lrun),1,angintOO,1) 5334 endif 5335 Endif 5336 Lrun=Lrun+1 5337 enddo 5338 endif 5339 endif 5340cbs second term: ########################################################################### 5341 factor=-root2inv*preroots(1,l1)*preroots(2,l3)* 5342 *clebsch(3,1,m1,l1)* 5343 *clebsch(2,2,m3,l3) 5344 if (factor.ne.0d0) then 5345 do I=0,Lmax+Lmax+1 5346 dummy(I)=0d0 5347 enddo 5348 Klast=0 5349 Kfirst=Lmax+Lmax+1 ! just to be sure .. 5350cbs get the L,M dependent coefficients 5351 if (Lblocks(1).gt.0) then 5352 M=m2-m4 5353 Kfirst=Lfirst(1) 5354 Klast=Llast(1) 5355 Lrun=1 5356 do L=Lfirst(1),Llast(1),2 5357 dummy(L)=LMdepang(L,M,l1-1,l2,l3+1,l4,m1+1,m2,m3,m4,cheater) 5358 if (dummy(L).ne.0d0) then 5359 if (bonn.or.breit.or.sameorb) then 5360 call daxpy(ncontall,4*factor*dummy(L), 5361 * caseaSO(1,Lrun),1,angintSO,1) 5362 else 5363 call daxpy(ncontall,4*factor*dummy(L), 5364 * caseaSO(1,Lrun),1,angintSO,1) 5365 call daxpy(ncontall, 5366 * 4*factor*dummy(L),caseaOO(1,Lrun),1,angintOO,1) 5367 endif 5368 endif 5369 Lrun=Lrun+1 5370 enddo 5371 endif 5372 if (Lblocks(3).gt.0) then 5373 M=m2-m4 5374 if (Lfirst(3).lt.Kfirst) then 5375 do L=Lfirst(3),Kfirst,2 5376 dummy(L)=LMdepang(L,M,l1-1,l2,l3+1,l4,m1+1,m2,m3,m4,cheater) 5377 enddo 5378 Kfirst=Lfirst(3) 5379 endif 5380 if (Llast(3).gt.Klast) then 5381 do L=Klast,Llast(3),2 5382 dummy(L)=LMdepang(L,M,l1-1,l2,l3+1,l4,m1+1,m2,m3,m4,cheater) 5383 enddo 5384 Klast=Llast(3) 5385 endif 5386 Lrun=1 5387 do L=Lfirst(3),Llast(3),2 5388 if (dummy(L).ne.0d0) then 5389 if (bonn.or.breit.or.sameorb) then 5390 call daxpy(ncontall,-(2+4*l1)*factor*dummy(L), 5391 * caseb2SO(1,Lrun),1,angintSO,1) 5392 else 5393 call daxpy(ncontall,-(2+4*l1)*factor*dummy(L), 5394 * caseb2SO(1,Lrun),1,angintSO,1) 5395 call daxpy(ncontall,-(2+4*l1)* 5396 * factor*dummy(L),caseb2OO(1,Lrun),1,angintOO,1) 5397 endif 5398 endif 5399 Lrun=Lrun+1 5400 enddo 5401 endif 5402 endif 5403cbs third term: ########################################################################### 5404 factor=-root2inv*preroots(2,l1)*preroots(1,l3)* 5405 *clebsch(3,2,m1,l1)* 5406 *clebsch(2,1,m3,l3) 5407 if (factor.ne.0d0) then 5408 do I=0,Lmax+Lmax+1 5409 dummy(I)=0d0 5410 enddo 5411 Klast=0 5412 Kfirst=Lmax+Lmax+1 ! just to be sure .. 5413cbs get the L,M dependent coefficients 5414 if (Lblocks(1).gt.0) then 5415 M=m2-m4 5416 Kfirst=Lfirst(1) 5417 Klast=Llast(1) 5418 Lrun=1 5419 do L=Lfirst(1),Llast(1),2 5420 dummy(L)=LMdepang(L,M,l1+1,l2,l3-1,l4,m1+1,m2,m3,m4,cheater) 5421 if (dummy(L).ne.0d0) then 5422 if (bonn.or.breit.or.sameorb) then 5423 call daxpy(ncontall,4*factor*dummy(L), 5424 * caseaSO(1,Lrun),1,angintSO,1) 5425 else 5426 call daxpy(ncontall,4*factor*dummy(L), 5427 * caseaSO(1,Lrun),1,angintSO,1) 5428 call daxpy(ncontall, 5429 * 4*factor*dummy(L),caseaOO(1,Lrun),1,angintOO,1) 5430 endif 5431 endif 5432 Lrun=Lrun+1 5433 enddo 5434 endif 5435 if (Lblocks(2).gt.0) then 5436 M=m2-m4 5437 if (Lfirst(2).lt.Kfirst) then 5438 do L=Lfirst(2),Kfirst,2 5439 dummy(L)=LMdepang(L,M,l1+1,l2,l3-1,l4,m1+1,m2, 5440 * m3,m4,Cheater) 5441 enddo 5442 Kfirst=Lfirst(2) 5443 endif 5444 if (Llast(2).gt.Klast) then 5445 do L=Klast,Llast(2),2 5446 dummy(L)=LMdepang(L,M,l1+1,l2,l3-1,l4,m1+1,m2,m3,m4,cheater) 5447 enddo 5448 Klast=Llast(2) 5449 endif 5450 Lrun=1 5451 do L=Lfirst(2),Llast(2),2 5452 if (dummy(L).ne.0d0) then 5453 if (bonn.or.breit.or.sameorb) then 5454 call daxpy(ncontall,-(2+4*l3)*factor*dummy(L), 5455 * caseb1SO(1,Lrun),1,angintSO,1) 5456 else 5457 call daxpy(ncontall,-(2+4*l3)*factor*dummy(L), 5458 * caseb1SO(1,Lrun),1,angintSO,1) 5459 call daxpy(ncontall,-(2+4*l3)* 5460 * factor*dummy(L),caseb1OO(1,Lrun),1,angintOO,1) 5461 endif 5462 endif 5463 Lrun=Lrun+1 5464 enddo 5465 endif 5466 endif 5467cbs fourth term: ########################################################################### 5468 factor=-root2inv*preroots(1,l1)*preroots(1,l3)* 5469 *clebsch(3,1,m1,l1)* 5470 *clebsch(2,1,m3,l3) 5471 if (factor.ne.0d0) then 5472 do I=0,Lmax+Lmax+1 5473 dummy(I)=0d0 5474 enddo 5475 Klast=0 5476 Kfirst=Lmax+Lmax+1 ! just to be sure .. 5477cbs get the L,M dependent coefficients 5478 if (Lblocks(1).gt.0) then 5479 M=m2-m4 5480 Kfirst=Lfirst(1) 5481 Klast=Llast(1) 5482 Lrun=1 5483 do L=Lfirst(1),Llast(1),2 5484 dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2,m3,m4,cheater) 5485 if (dummy(L).ne.0d0) then 5486 if (bonn.or.breit.or.sameorb) then 5487 call daxpy(ncontall,4*factor*dummy(L), 5488 * caseaSO(1,Lrun),1,angintSO,1) 5489 else 5490 call daxpy(ncontall,4*factor*dummy(L), 5491 * caseaSO(1,Lrun),1,angintSO,1) 5492 call daxpy(ncontall, 5493 * 4*factor*dummy(L),caseaOO(1,Lrun),1,angintOO,1) 5494 endif 5495 endif 5496 Lrun=Lrun+1 5497 enddo 5498 endif 5499 if (Lblocks(2).gt.0) then 5500 M=m2-m4 5501 if (Lfirst(2).lt.Kfirst) then 5502 do L=Lfirst(2),Kfirst,2 5503 dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2,m3,m4,cheater) 5504 enddo 5505 Kfirst=Lfirst(2) 5506 endif 5507 if (Llast(2).gt.Klast) then 5508 do L=Klast,Llast(2),2 5509 dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2,m3,m4,cheater) 5510 enddo 5511 Klast=Llast(2) 5512 endif 5513 Lrun=1 5514 do L=Lfirst(2),Llast(2),2 5515 if (dummy(L).ne.0d0) then 5516 if (bonn.or.breit.or.sameorb) then 5517 call daxpy(ncontall,-(2+4*l3)*factor*dummy(L), 5518 * caseb1SO(1,Lrun),1,angintSO,1) 5519 else 5520 call daxpy(ncontall,-(2+4*l3)*factor*dummy(L), 5521 * caseb1SO(1,Lrun),1,angintSO,1) 5522 call daxpy(ncontall,-(2+4*l3)* 5523 * factor*dummy(L),caseb1OO(1,Lrun),1,angintOO,1) 5524 endif 5525 endif 5526 Lrun=Lrun+1 5527 enddo 5528 endif 5529 if (Lblocks(3).gt.0) then 5530 M=m2-m4 5531 if (Lfirst(3).lt.Kfirst) then 5532 do L=Lfirst(3),Kfirst,2 5533 dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2,m3,m4,cheater) 5534 enddo 5535 Kfirst=Lfirst(3) 5536 endif 5537 if (Llast(3).gt.Klast) then 5538 do L=Klast,Llast(3),2 5539 dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2,m3,m4,cheater) 5540 enddo 5541 Klast=Llast(3) 5542 endif 5543 Lrun=1 5544 do L=Lfirst(3),Llast(3),2 5545 if (dummy(L).ne.0d0) then 5546 if (bonn.or.breit.or.sameorb) then 5547 call daxpy(ncontall,-(2+4*l1)*factor*dummy(L), 5548 * caseb2SO(1,Lrun),1,angintSO,1) 5549 else 5550 call daxpy(ncontall,-(2+4*l1)*factor*dummy(L), 5551 * caseb2SO(1,Lrun),1,angintSO,1) 5552 call daxpy(ncontall,-(2+4*l1)* 5553 * factor*dummy(L),caseb2OO(1,Lrun),1,angintOO,1) 5554 endif 5555 endif 5556 Lrun=Lrun+1 5557 enddo 5558 endif 5559 if (Lblocks(4).gt.0) then 5560 M=m2-m4 5561 if (Lfirst(4).lt.Kfirst) then 5562 do L=Lfirst(4),Kfirst,2 5563 dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2,m3,m4,cheater) 5564 enddo 5565 Kfirst=Lfirst(4) 5566 endif 5567 if (Llast(4).gt.Klast) then 5568 do L=Klast,Llast(4),2 5569 dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1+1,m2,m3,m4,cheater) 5570 enddo 5571 Klast=Llast(4) 5572 endif 5573 Lrun=1 5574 do L=Lfirst(4),Llast(4),2 5575 if (dummy(L).ne.0d0) then 5576 if (bonn.or.breit.or.sameorb) then 5577 call daxpy(ncontall,(4*l1*l3+2*l1+2*l3+1)*factor*dummy(L), 5578 * casecSO(1,Lrun),1,angintSO,1) 5579 else 5580 call daxpy(ncontall,(4*l1*l3+2*l1+2*l3+1)*factor*dummy(L), 5581 * casecSO(1,Lrun),1,angintSO,1) 5582 call daxpy(ncontall, 5583 * (4*l1*l3+2*l1+2*l3+1)*factor*dummy(L), 5584 * casecOO(1,Lrun),1,angintOO,1) 5585 endif 5586 endif 5587 Lrun=Lrun+1 5588 enddo 5589 endif 5590 endif 5591cbs fifth term: ########################################################################### 5592 factor=-root2inv*preroots(2,l1)*preroots(2,l3)* 5593 *clebsch(2,2,m1,l1)* 5594 *clebsch(1,2,m3,l3) 5595 if (factor.ne.0d0) then 5596 do I=0,Lmax+Lmax+1 5597 dummy(I)=0d0 5598 enddo 5599cbs get the L,M dependent coefficients 5600 if (Lblocks(1).gt.0) then 5601 M=m2-m4 5602 Lrun=1 5603 do L=Lfirst(1),Llast(1),2 5604 dummy(L)=LMdepang(L,M,l1+1,l2,l3+1,l4,m1,m2,m3-1,m4,cheater) 5605 if (dummy(L).ne.0d0) then 5606 if (bonn.or.breit.or.sameorb) then 5607 call daxpy(ncontall,4*factor*dummy(L), 5608 * caseaSO(1,Lrun),1,angintSO,1) 5609 else 5610 call daxpy(ncontall,4*factor*dummy(L), 5611 * caseaSO(1,Lrun),1,angintSO,1) 5612 call daxpy(ncontall, 5613 * 4*factor*dummy(L),caseaOO(1,Lrun),1,angintOO,1) 5614 endif 5615 endif 5616 Lrun=Lrun+1 5617 enddo 5618 endif 5619 endif 5620cbs sixth term: ########################################################################### 5621 factor=-root2inv*preroots(1,l1)*preroots(2,l3)* 5622 *clebsch(2,1,m1,l1)* 5623 *clebsch(1,2,m3,l3) 5624 if (factor.ne.0d0) then 5625 do I=0,Lmax+Lmax+1 5626 dummy(I)=0d0 5627 enddo 5628 Klast=0 5629 Kfirst=Lmax+Lmax+1 ! just to be sure .. 5630cbs get the L,M dependent coefficients 5631 if (Lblocks(1).gt.0) then 5632 M=m2-m4 5633 Kfirst=Lfirst(1) 5634 Klast=Llast(1) 5635 Lrun=1 5636 do L=Lfirst(1),Llast(1),2 5637 dummy(L)=LMdepang(L,M,l1-1,l2,l3+1,l4,m1,m2,m3-1,m4,cheater) 5638 if (dummy(L).ne.0d0) then 5639 if (bonn.or.breit.or.sameorb) then 5640 call daxpy(ncontall,4*factor*dummy(L), 5641 * caseaSO(1,Lrun),1,angintSO,1) 5642 else 5643 call daxpy(ncontall,4*factor*dummy(L), 5644 * caseaSO(1,Lrun),1,angintSO,1) 5645 call daxpy(ncontall,4* 5646 * factor*dummy(L),caseaOO(1,Lrun),1,angintOO,1) 5647 endif 5648 endif 5649 Lrun=Lrun+1 5650 enddo 5651 endif 5652 if (Lblocks(3).gt.0) then 5653 M=m2-m4 5654 if (Lfirst(3).lt.Kfirst) then 5655 do L=Lfirst(3),Kfirst,2 5656 dummy(L)=LMdepang(L,M,l1-1,l2,l3+1,l4,m1,m2,m3-1,m4,cheater) 5657 enddo 5658 Kfirst=Lfirst(3) 5659 endif 5660 if (Llast(3).gt.Klast) then 5661 do L=Klast,Llast(3),2 5662 dummy(L)=LMdepang(L,M,l1-1,l2,l3+1,l4,m1,m2,m3-1,m4,cheater) 5663 enddo 5664 Klast=Llast(3) 5665 endif 5666 Lrun=1 5667 do L=Lfirst(3),Llast(3),2 5668 if (dummy(L).ne.0d0) then 5669 if (bonn.or.breit.or.sameorb) then 5670 call daxpy(ncontall,-(2+4*l1)*factor*dummy(L), 5671 * caseb2SO(1,Lrun),1,angintSO,1) 5672 else 5673 call daxpy(ncontall,-(2+4*l1)*factor*dummy(L), 5674 * caseb2SO(1,Lrun),1,angintSO,1) 5675 call daxpy(ncontall,-(2+4*l1)* 5676 * factor*dummy(L),caseb2OO(1,Lrun),1,angintOO,1) 5677 endif 5678 endif 5679 Lrun=Lrun+1 5680 enddo 5681 endif 5682 endif 5683cbs seventh term: ########################################################################### 5684 factor=-root2inv*preroots(2,l1)*preroots(1,l3)* 5685 *clebsch(2,2,m1,l1)* 5686 *clebsch(1,1,m3,l3) 5687 if (factor.ne.0d0) then 5688 do I=0,Lmax+Lmax+1 5689 dummy(I)=0d0 5690 enddo 5691 Klast=0 5692 Kfirst=Lmax+Lmax+1 ! just to be sure .. 5693cbs get the L,M dependent coefficients 5694 if (Lblocks(1).gt.0) then 5695 M=m2-m4 5696 Kfirst=Lfirst(1) 5697 Klast=Llast(1) 5698 Lrun=1 5699 do L=Lfirst(1),Llast(1),2 5700 dummy(L)=LMdepang(L,M,l1+1,l2,l3-1,l4,m1,m2,m3-1,m4,cheater) 5701 if (dummy(L).ne.0d0) then 5702 if (bonn.or.breit.or.sameorb) then 5703 call daxpy(ncontall,4*factor*dummy(L), 5704 * caseaSO(1,Lrun),1,angintSO,1) 5705 else 5706 call daxpy(ncontall,4*factor*dummy(L), 5707 * caseaSO(1,Lrun),1,angintSO,1) 5708 call daxpy(ncontall, 5709 * 4*factor*dummy(L),caseaOO(1,Lrun),1,angintOO,1) 5710 endif 5711 endif 5712 Lrun=Lrun+1 5713 enddo 5714 endif 5715 if (Lblocks(2).gt.0) then 5716 M=m2-m4 5717 if (Lfirst(2).lt.Kfirst) then 5718 do L=Lfirst(2),Kfirst,2 5719 dummy(L)=LMdepang(L,M,l1+1,l2,l3-1,l4,m1,m2,m3-1,m4,cheater) 5720 enddo 5721 Kfirst=Lfirst(2) 5722 endif 5723 if (Llast(2).gt.Klast) then 5724 do L=Klast,Llast(2),2 5725 dummy(L)=LMdepang(L,M,l1+1,l2,l3-1,l4,m1,m2,m3-1,m4,cheater) 5726 enddo 5727 Klast=Llast(2) 5728 endif 5729 Lrun=1 5730 do L=Lfirst(2),Llast(2),2 5731 if (dummy(L).ne.0d0) then 5732 if (bonn.or.breit.or.sameorb) then 5733 call daxpy(ncontall,-(2+4*l3)*factor*dummy(L), 5734 * caseb1SO(1,Lrun),1,angintSO,1) 5735 else 5736 call daxpy(ncontall,-(2+4*l3)*factor*dummy(L), 5737 * caseb1SO(1,Lrun),1,angintSO,1) 5738 call daxpy(ncontall,-(2+4*l3)* 5739 * factor*dummy(L),caseb1OO(1,Lrun),1,angintOO,1) 5740 endif 5741 endif 5742 Lrun=Lrun+1 5743 enddo 5744 endif 5745 endif 5746cbs eigth term: ########################################################################### 5747 factor=-root2inv*preroots(1,l1)*preroots(1,l3)* 5748 *clebsch(2,1,m1,l1)* 5749 *clebsch(1,1,m3,l3) 5750 if (factor.ne.0d0) then 5751 do I=0,Lmax+Lmax+1 5752 dummy(I)=0d0 5753 enddo 5754 Klast=0 5755 Kfirst=Lmax+Lmax+1 ! just to be sure .. 5756cbs get the L,M dependent coefficients 5757 if (Lblocks(1).gt.0) then 5758 M=m2-m4 5759 Kfirst=Lfirst(1) 5760 Klast=Llast(1) 5761 Lrun=1 5762 do L=Lfirst(1),Llast(1),2 5763 dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1,m2,m3-1,m4,cheater) 5764 if (dummy(L).ne.0d0) then 5765 if (bonn.or.breit.or.sameorb) then 5766 call daxpy(ncontall,4*factor*dummy(L), 5767 * caseaSO(1,Lrun),1,angintSO,1) 5768 else 5769 call daxpy(ncontall,4*factor*dummy(L), 5770 * caseaSO(1,Lrun),1,angintSO,1) 5771 call daxpy(ncontall,4* 5772 * factor*dummy(L),caseaOO(1,Lrun),1,angintOO,1) 5773 endif 5774 endif 5775 Lrun=Lrun+1 5776 enddo 5777 endif 5778 if (Lblocks(2).gt.0) then 5779 M=m2-m4 5780 if (Lfirst(2).lt.Kfirst) then 5781 do L=Lfirst(2),Kfirst,2 5782 dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1,m2,m3-1,m4,cheater) 5783 enddo 5784 Kfirst=Lfirst(2) 5785 endif 5786 if (Llast(2).gt.Klast) then 5787 do L=Klast,Llast(2),2 5788 dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1,m2,m3-1,m4,cheater) 5789 enddo 5790 Klast=Llast(2) 5791 endif 5792 Lrun=1 5793 do L=Lfirst(2),Llast(2),2 5794 if (dummy(L).ne.0d0) then 5795 if (bonn.or.breit.or.sameorb) then 5796 call daxpy(ncontall,-(2+4*l3)*factor*dummy(L), 5797 * caseb1SO(1,Lrun),1,angintSO,1) 5798 else 5799 call daxpy(ncontall,-(2+4*l3)*factor*dummy(L), 5800 * caseb1SO(1,Lrun),1,angintSO,1) 5801 call daxpy(ncontall,-(2+4*l3)* 5802 *factor*dummy(L),caseb1OO(1,Lrun),1,angintOO,1) 5803 endif 5804 endif 5805 Lrun=Lrun+1 5806 enddo 5807 endif 5808 if (Lblocks(3).gt.0) then 5809 M=m2-m4 5810 if (Lfirst(3).lt.Kfirst) then 5811 do L=Lfirst(3),Kfirst,2 5812 dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1,m2,m3-1,m4,cheater) 5813 enddo 5814 Kfirst=Lfirst(3) 5815 endif 5816 if (Llast(3).gt.Klast) then 5817 do L=Klast,Llast(3),2 5818 dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1,m2,m3-1,m4,cheater) 5819 enddo 5820 Klast=Llast(3) 5821 endif 5822 Lrun=1 5823 do L=Lfirst(3),Llast(3),2 5824 if (dummy(L).ne.0d0) then 5825 if (bonn.or.breit.or.sameorb) then 5826 call daxpy(ncontall,-(2+4*l1)*factor*dummy(L), 5827 * caseb2SO(1,Lrun),1,angintSO,1) 5828 else 5829 call daxpy(ncontall,-(2+4*l1)*factor*dummy(L), 5830 * caseb2SO(1,Lrun),1,angintSO,1) 5831 call daxpy(ncontall,-(2+4*l1)* 5832 * factor*dummy(L),caseb2OO(1,Lrun),1,angintOO,1) 5833 endif 5834 endif 5835 Lrun=Lrun+1 5836 enddo 5837 endif 5838 if (Lblocks(4).gt.0) then 5839 M=m2-m4 5840 if (Lfirst(4).lt.Kfirst) then 5841 do L=Lfirst(4),Kfirst,2 5842 dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1,m2,m3-1,m4,cheater) 5843 enddo 5844 Kfirst=Lfirst(4) 5845 endif 5846 if (Llast(4).gt.Klast) then 5847 do L=Klast,Llast(4),2 5848 dummy(L)=LMdepang(L,M,l1-1,l2,l3-1,l4,m1,m2,m3-1,m4,cheater) 5849 enddo 5850 Klast=Llast(4) 5851 endif 5852 Lrun=1 5853 do L=Lfirst(4),Llast(4),2 5854 if (dummy(L).ne.0d0) then 5855 if (bonn.or.breit.or.sameorb) then 5856 call daxpy(ncontall,(4*l1*l3+2*l1+2*l3+1)* 5857 * factor*dummy(L), 5858 * casecSO(1,Lrun),1,angintSO,1) 5859 else 5860 call daxpy(ncontall,(4*l1*l3+2*l1+2*l3+1)* 5861 * factor*dummy(L), 5862 * casecSO(1,Lrun),1,angintSO,1) 5863 call daxpy(ncontall, 5864 * (4*l1*l3+2*l1+2*l3+1)*factor*dummy(L), 5865 * casecOO(1,Lrun),1,angintOO,1) 5866 endif 5867 endif 5868 Lrun=Lrun+1 5869 enddo 5870 endif 5871 endif 5872 return 5873 end 5874 5875 subroutine prefac(Lmax,preroots,clebsch) 5876#include "implicit.h" 5877 dimension preroots(2,0:Lmax), 5878 *clebsch(3,2,-Lmax:Lmax,0:Lmax) 5879cbs the roots appearing in front of all 5880cbs the contributions 5881c write(6,*) 'begin of prefac' 5882 do L=0,Lmax 5883 fact=1d0/dsqrt(dfloat(L+L+1)) 5884 preroots(1,L)=dsqrt(dfloat(L))*fact 5885 preroots(2,L)=dsqrt(dfloat(L+1))*fact 5886 enddo 5887cbs there are Clebsch-Gordon-Coefficients 5888cbs which always appear: 5889cbs 5890cbs ----- ------ 5891cbs | | 5892cbs | l +/- 1 1 | l | 5893cbs | | | 5894cbs | | | 5895cbs | m+/-1,0 -1,1,0 | m | 5896cbs | | | 5897cbs | | 5898cbs ----- ----- 5899cbs 5900cbs 5901cbs array clebsch (3,2,-Lmax:Lmax,0:Lmax) 5902cbs first index 1: m-1 5903cbs 2: m 5904cbs 3: m+1 5905cbs second index 1: l-1 5906cbs 2: l+1 5907cbs third index m 5908cbs fourth index l 5909cbs 5910c write(6,*),'start to generate CGs' 5911 do L=0,Lmax 5912 L2=L+L 5913 do M=-L,L 5914c write(6,*) 'L,M: ',L,M 5915 M2=M+M 5916cbs getCG calculates CG-coeffecients. In order to avoid fractions, 5917cbs e.g. for spins, arguments are doubled values... 5918 clebsch(1,1,M,L)= 5919 *getCG(L2-2,2,L2,M2-2,2,M2) 5920 clebsch(2,1,M,L)= 5921 *getCG(L2-2,2,L2,M2,0,M2) 5922 clebsch(3,1,M,L)= 5923 *getCG(L2-2,2,L2,M2+2,-2,M2) 5924 clebsch(1,2,M,L)= 5925 *getCG(L2+2,2,L2,M2-2,2,M2) 5926 clebsch(2,2,M,L)= 5927 *getCG(L2+2,2,L2,M2,0,M2) 5928 clebsch(3,2,M,L)= 5929 *getCG(L2+2,2,L2,M2+2,-2,M2) 5930 enddo 5931 enddo 5932 return 5933 end 5934 5935 5936 subroutine readbas(Lhigh,makemean,bonn,breit, 5937 *symmetry,sameorb,AIMP,oneonly,ncont4,numballcart,LUAMFI_INP, 5938 *ifinite,EXP_FIN) 5939cbs suposed to read the maximum of l-values, the number of primitive and contracted 5940cbs functions, the exponents and contraction coefficients 5941#include "implicit.h" 5942#include "priunit.h" 5943#include "para.h" 5944#include "amfi_param.h" 5945#include "ired.h" 5946 character*4 WORD 5947 character*4 symmetry 5948 character*13 Llimit 5949 character*19 chcharge 5950 character*30 Nofprim 5951 character*28 addtext 5952 character*32 Nofcont 5953 character*76 Stars 5954 logical makemean,bonn,breit, 5955 *sameorb,AIMP,oneonly 5956 common /nucleus/ charge,Exp_finite 5957 Integer ibeginIRED(8),idelpersym(8) 5958 dimension INOFT(Mxcart),INOFF(MxCart) 5959 stars='********************************************************'// 5960 * '********************' 5961 Llimit='MAX. L-VALUE:' 5962 chcharge=' CHARGE OF NUCLEUS:' 5963 Nofprim='NUMBER OF PRIMITIVE FUNCTIONS:' 5964 Nofcont=' NUMBER OF CONTRACTED FUNCTIONS:' 5965 addtext='ADDITIONAL FUNCTIONS in IRS:' 5966CBS write(LUPRI,*) 5967CBS write(LUPRI,*) 'ATOMIC NO-PAIR SO-MF CODE starts' 5968CBS write(LUPRI,*) 5969 bonn=.false. 5970 sameorb=.false. 5971 aimp=.false. 5972 oneonly=.false. 5973 makemean=.true. 5974CBS write(LUPRI,*) stars 5975CBS write(LUPRI,*) '2e-integrals for the mean-field only' 5976CBS write(LUPRI,*) ' mean-field will be generated ' 5977CBS write(LUPRI,*) stars 5978 do i=0,Lmax 5979 icore(i)=0 5980 enddo 5981 if (ifinite.eq.1) Exp_finite=EXP_FIN 5982 if (BONN) then 5983CBS write(LUPRI,*) 'Bonn-approach for spin-other-orbit part' 5984 endif 5985 if (BREIT) then 5986CBS write(LUPRI,*) ' Breit-Pauli-Approximation' 5987 else 5988CBS write(LUPRI,*) 'Douglas-Kroll type operators ' 5989 endif 5990 if (ifinite.eq.0) then 5991CBS write(LUPRI,*) 'Point-nucleus ' 5992 else 5993CBS write(LUPRI,*) 'Finite Nucleus' 5994 endif 5995CBS write(LUPRI,*) stars 5996CBS write(LUPRI,*) 'write out one-electron integrals in MOLCAS-style' 5997CBS write(LUPRI,*) ' and with MOLCAS normalization ' 5998CBS write(LUPRI,*) stars 5999CBS write(LUPRI,*) stars 6000CBS write(LUPRI,*) 6001 symmetry='D2H' 6002CBS write(LUPRI,*) 'Symmetry is D2H' 6003CBS write(LUPRI,*) 'check whether order of IRs is correct!!!' 6004 numbofsym=8 6005 if (SAMEORB) then 6006CBS write(LUPRI,*) 'SAME-ORBIT only' 6007 else 6008CBS write(LUPRI,*) 'OTHER-ORBIT included' 6009 endif 6010 if (AIMP) then 6011CBS write(LUPRI,*) 'CORE removed for use with AIMP' 6012 endif 6013 read(LUAMFI_INP,*) charge,Lhigh 6014 if (Lhigh.gt.Lmax) then 6015 write(LUPRI,*) 'Sorry, so far the AMFI code deals only ', 6016 *'with maximum l-values of ',Lmax 6017 CALL QUIT('Too high angular momentum values in AMFI') 6018 endif 6019CBS write(LUPRI,*) ' Functions will go up to an L-value of : ',Lhigh 6020CBS write(LUPRI,'(A19,F5.2)') chcharge,charge 6021 call initired 6022 Do iredrun=1,numbofsym 6023 do Lrun=0,Lhigh 6024 nmbMperIRL(iredrun,Lrun)=0 6025 enddo 6026 enddo 6027 do Lrun=0,Lhigh 6028CBS write(LUPRI,*) 'ANGULAR MOMENTUM ',LRUN 6029 read(LUAMFI_INP,*) nprimit(Lrun),ncontrac(Lrun) 6030CBS write(LUPRI,'(I3,I3)') nprimit(Lrun),ncontrac(Lrun) 6031cbs check keywords 6032cbs check maximum numbers 6033 if (nprimit(Lrun).gt.MxprimL) then 6034 write(LUPRI,*) 'Too many primitives for L=',Lrun, 6035 * ' increase MxprimL in para.h or reduce ', 6036 * 'the number of primitives to at least ',MxprimL 6037 CALL QUIT('Too many primitive functions in AMFI') 6038 endif 6039 if (ncontrac(Lrun).gt.MxcontL) then 6040 write(LUPRI,*) 'Too many contracted fncts for L=',Lrun, 6041 * ' increase MxcontL in para.h or ', 6042 * 'reduce the number of contracted functions', 6043 * 'to at most ',MxcontL 6044 CALL QUIT('Too many contracted functions in AMFI') 6045 endif 6046 if (ncontrac(Lrun).gt.nprimit(Lrun)) then 6047 write(LUPRI,*) 'You have more contracted than ', 6048 * 'uncontracted functions, I don''t believe ', 6049 * 'that. Sorry!! ' 6050 CALL QUIT('Inconsistent input detected in AMFI') 6051 endif 6052C write(LUPRI,'(A7,I3,A15,I3,A33,I3,A24)') 'For L= ',Lrun, 6053C *' there will be ', 6054C *ncontrac(Lrun),' contracted functions, built from ', 6055C *nprimit(Lrun), 6056C *' uncontracted functions.' 6057 do ILINE=1,nprimit(Lrun) 6058 read(LUAMFI_INP,*) exponents(ILINE,Lrun), 6059 * (cntscrtch(ILINE,JRUN,Lrun), 6060 * Jrun=1,ncontrac(Lrun)) 6061 enddo 6062ckr read(LUAMFI_INP,'(A76)') header 6063c 6064cbs 6065cbs end of reading for the current L-value 6066cbs 6067c do Irun=1,ncontrac(Lrun) 6068c writE(LUPRI,*) 'orbital : ',irun 6069c write(LUPRI,'(6(X,E13.6))') 6070c *(cntscrtch(I,Irun,Lrun),I=1,nprimit(Lrun)) 6071c enddo 6072c write(LUPRI,*) ' ' 6073cbs setting the numbers of cartesians per IR 6074 do iredrun=1,numbofsym 6075 nfunctions(iredrun,Lrun)=0 6076 enddo 6077 do mrun=-Lrun,Lrun 6078 nfunctions(ipow2ired(ipowxyz(1,mrun,Lrun), 6079 * ipowxyz(2,mrun,Lrun),Ipowxyz(3,mrun,Lrun)),Lrun)= 6080 * nfunctions(ipow2ired(ipowxyz(1,mrun,Lrun), 6081 * ipowxyz(2,mrun,Lrun), 6082 * ipowxyz(3,mrun,Lrun)),Lrun)+ncontrac(Lrun) 6083 enddo 6084 do mrun=-Lrun,Lrun 6085 nmbMperIRL(ipow2ired(ipowxyz(1,mrun,Lrun), 6086 * ipowxyz(2,mrun,Lrun),Ipowxyz(3,mrun,Lrun)),lruN)= 6087 * nmbMperIRL(ipOw2ired(ipowxyz(1,mrun,Lrun), 6088 * ipowxyz(2,mrun,Lrun),IpowxYz(3,mrun,Lrun)),lruN)+1 6089 enddo 6090CBS write(LUPRI,*) stars 6091CBS write(LUPRI,'(A,8I4)') 6092CBS *'Number of functions per IR: ',(nfunctions(iredrun,Lrun), 6093CBS *iredrun=1,numbofsym) 6094CBS write(LUPRI,*) stars 6095 enddo ! enddo for loop over L-values 6096C write(LUPRI,*) 'distribution of M-values' 6097c do Lrun=0,Lhigh 6098c write(LUPRI,*) (nmbMperIRL(nsym,Lrun),nsym=1,numbofsym) 6099c endDo 6100 numbofcart=0 6101 do lrun=0,Lhigh 6102 numbofcart=numbofcart+(Lrun+Lrun+1)* 6103 *ncontrac(Lrun) 6104 enddo 6105 do iredrun=1,numbofsym 6106 nfunctperIRED(iredrun)=0 6107 enddo 6108 do Lrun=0,Lhigh 6109 do iredrun=1,numbofsym 6110 nfunctperIRED(iredrun)=nfunctperIRED(iredrun)+ 6111 *nfunctions(iredrun,Lrun) 6112 enddo 6113 enddo 6114CBS write(LUPRI,*) stars 6115CBS write(LUPRI,'(A,8I3)') 'total number of atomic functions per IRED ', 6116CBS *(nfunctperIRED(iredrun),iredrun=1,numbofsym) 6117CBS write(LUPRI,*) stars 6118 isum=0 6119 do iredrun=1,numbofsym 6120 itotalperIR(iredrun)=nfunctperIRED(iredrun) 6121 isum=isum+itotalperIR(iredrun) 6122 enddo 6123 numballcart=isum 6124 iorbrun=0 6125 do iredrun=1,numbofsym 6126 do inired=1,itotalperIR(iredrun) 6127 iorbrun=iorbrun+1 6128 IREDoffunctnew(Iorbrun)=iredrun 6129 enddo 6130 enddo 6131CBS write(LUPRI,*) stars 6132CBS write(LUPRI,'(A,8I3)') 'including additional functions per IRED ', 6133CBS *(itotalperIR(iredrun),iredrun=1,numbofsym) 6134CBS write(LUPRI,*) stars 6135 do iredrun=1,numbofsym 6136 ibeginIRED(iredrun)=0 6137 enddo 6138 do lrun=0,Lhigh 6139 do mrun=-lrun,lrun 6140 iredLM(mrun,lrun)=ipow2ired(ipowxyz(1,mrun,Lrun), 6141 *ipowxyz(2,mrun,Lrun), 6142 *ipowxyz(3,mrun,Lrun)) 6143 incrLM(mrun,lrun)=ibeginIRED(iredLM(mrun,lrun)) 6144 ibeginIRED(iredLM(mrun,lrUn))= 6145 *ibeginIRED(iredLM(mrun,lrun))+ncontrac(lrun) 6146 enddo 6147 enddo 6148c do lrun=0,Lhigh 6149c write(LUPRI,'(A,I4,A,21I3)') 'L= ',lrun, 6150c *' shifts inside the IRED', 6151c *(incrLM(mrun,lrun),mrun=-lrun,lrun) 6152c enddo 6153 shiftIRED(1)=0 6154 do iredrun=2,numbofsym 6155 shiftIRED(iredrun)=shiftIRED(iredrun-1) 6156 * +itotalperIR(iredrun-1) 6157 enddo 6158c write(LUPRI,'(A,8I4)') 'shifts for the IREDs ', 6159c *(shiftIRED(iredrun),iredrun=1,numbofsym) 6160cbs test all orbital numbers 6161c do lrun=0,Lhigh 6162c do mrun=-Lrun,Lrun 6163c do irun=1,ncontrac(lrun) 6164c write(LUPRI,*) 'L,M,contr funct, absolute number ', 6165c *lrun,mrun,irun,shiftired(iredLM(mrun,lrun))+ 6166c *incrLM(mrun,Lrun)+irun 6167c enddo 6168c enddo 6169c enddo 6170 shiftIRIR(1)=0 6171 irun=1 6172 do ired1=2,numbofsym 6173 do ired2=1,ired1 6174 irun=irun+1 6175 if (ired2.eq.1) then 6176 shiftIRIR(irun)=shiftIRIR(irun-1)+ 6177 *(itotalperIR(ired1-1)*itotalperIR(ired1-1)+ 6178 *itotalperIR(ired1-1))/2 6179 else 6180 shiftIRIR(irun)=shiftIRIR(irun-1)+ 6181 *itotalperIR(ired1)*itotalperIR(ired2-1) 6182 endif 6183c write(LUPRI,*) 'ired1,ired2 ',ired1,ired2, 6184c *irun,shiftIRIR(irun) 6185 enddo 6186 enddo 6187cbs 6188 do lrun=0,Lhigh 6189 do Mrun=-Lrun,Lrun 6190 ired=iredLM(Mrun,Lrun) 6191 ishifter=shiftIRED(ired)+incrLM(mrun,lrun) 6192 do icart=1,ncontrac(Lrun) 6193 moffunction(ishifter+icart)=Mrun 6194 Loffunction(ishifter+icart)=Lrun 6195 IREDoffunction(ishifter+Icart)=ired 6196 INOFT(ishifter+Icart)=icart 6197 enddo 6198 enddo 6199 enddo 6200CBS write(LUPRI,*) stars 6201CBS write(LUPRI,*) 'SYMMETRY-INFORMATION ON FUNCTIONS ' 6202CBS write(LUPRI,*) stars 6203 do irun = 1, numbofcart 6204CBS write(LUPRI,'(4(A,I3))') 'Number of function: ', 6205CBS *irun, 6206CBS *' IR of function: ',IREDoffunction(irun), 6207CBS *' L-value: ',Loffunction(irun), 6208CBS *' M-value: ',Moffunction(irun) 6209CBS numboffunct(irun)=irun 6210 INOFF(irun)=irun 6211CBS if (IREDoffunction(irun).ne.IREDoffunction(irun+1)) 6212CBS *write(LUPRI,*) 6213 enddo 6214 do nsymrun=1,numbofsym 6215 idelpersym(nsymrun)=0 6216 enddo 6217 do nsymrun=1,numbofsym 6218 nrtofiperIR(nsymrun)=itotalperIR(nsymrun) 6219 enddo 6220 if (AIMP) then 6221cbs generate list of orbitals to be removed 6222 ikeeporb=0 6223 numbprev=0 6224 do irun=1,numbofcart 62254712 if (irun.eq.1.or.(irun.ge.2.and.INOFF(irun).eq. 6226 *numbprev+1)) then 6227 Lval=Loffunction(irun) 6228 number=INOFF(irun) 6229 itype=INOFT(irun) 6230 if (itype.le.icore(lval)) then 6231 write(LUPRI,777) number,itype,lval 6232 idelpersym(IREDoffunction(irun))= 6233 * idelpersym(IREDoffunction(irun))+1 6234 numbprev=number 6235 else 6236 ikeeporb=ikeeporb+1 6237 ikeeplist(ikeeporb)=number 6238 numbprev=number 6239 endif 6240 else 6241 ikeeporb=ikeeporb+1 6242 ikeeplist(ikeeporb)=numbprev+1 6243 numbprev=numbprev+1 6244 goto 4712 6245 endif 6246 enddo 6247 ikeeporb=0 6248 do nsymrun=1,numbofsym 6249 nrtofiperIR(nsymrun)=itotalperIR(nsymrun)-idelpersym(nsymrun) 6250 enddo 6251 do nsymrun=1,numbofsym 6252 ikeeporb=ikeeporb+nrtofiperIR(nsymrun) 6253 enddo 6254CBS write(LUPRI,*) stars 6255 write(LUPRI,'(A,8I3)')'# of funct. per IRED after removing core ', 6256 *(nrtofiperIR(iredrun),iredrun=1,numbofsym) 6257 write(LUPRI,*) ikeeporb,' orbitals left after deleting core' 6258 endif 6259CBS write(LUPRI,*) stars 6260 nmax=max(6,ncontrac(0)) 6261 do lrun=1,Lhigh 6262 nmax=max(nmax,ncontrac(lrun)) 6263 enddo 6264 ncont4=nmax*nmax*nmax*nmax 6265 return 6266777 format('ORBITAL NUMBER ',I4,' IS THE ',I3,'TH of L-value ',I3, 6267 *' IT WILL BE REMOVED !!!') 6268 end 6269 double precision function regge3j( 6270 *j1, ! integer 2*j1 6271 *j2, ! integer 2*j2 6272 *j3, ! integer 2*j3 6273 *m1, ! integer 2*m1 6274 *m2, ! integer 2*m2 6275 *m3) ! integer 2*m3 6276cbs uses magic square of regge (see Lindner pp. 38-39) 6277cbs 6278cbs --- --- 6279cbs | | 6280cbs | -j1+j2+j3 j1-j2+j3 j1+j2-j3 | 6281cbs | | 6282cbs | | 6283cbs | j1-m1 j2-m2 j3-m3 | 6284cbs | | 6285cbs | | 6286cbs | j1+m1 j2+m2 j3+m3 | 6287cbs | | 6288cbs --- --- 6289cbs 6290#include "implicit.h" 6291 dimension MAT(3,3) 6292 logical testup,testdown 6293#include "Regge.h" 6294cbs facul, integer array (nprim,0:mxLinRE) prime-expansion of factorials 6295cbs mxLinRE, integer max. number for facul is given 6296cbs nprim, number of primes for expansion of factorials 6297cbs prim, integer array with the first nprim prime numbers 6298cbs iwork) integer array of size nprim 6299 regge3j=0d0 6300c write(6,'(A24,6I3)') '3J to be calculated for ', 6301c *j1,j2,j3,m1,m2,m3 6302cbs quick check if =/= 0 at all 6303 icheck=m1+m2+m3 6304 if (icheck.ne.0) then 6305c write(6,*) 'sum over m =/= 0' 6306 return 6307 endif 6308cbs check triangular relation (|j1-j2|<= j3 <= j1+j2 ) 6309 imini=iabs(j1-j2) 6310 imaxi=j1+j2 6311 if (j3.lt.imini.or.j3.gt.imaxi) then 6312c write(6,*) 'triangular relation not fulfilled' 6313 return 6314 endif 6315cbs quick check if =/= 0 at all end 6316cbs 6317cbs 3J-symbol is not zero by simple rules 6318cbs 6319cbs initialize MAT 6320 MAT(1,1) =-j1+j2+j3 6321 MAT(2,1) =j1-m1 6322 MAT(3,1) =j1+m1 6323 MAT(1,2) =j1-j2+j3 6324 MAT(2,2) =j2-m2 6325 MAT(3,2) =j2+m2 6326 MAT(1,3) =j1+j2-j3 6327 MAT(2,3) =j3-m3 6328 MAT(3,3) =j3+m3 6329 do I=1,3 6330 do J=1,3 6331cbs check for even numbers (2*integer) and positive or zero 6332 if (mod(MAT(J,I),2).ne.0.or.MAT(J,I).lt.0) then 6333c write(6,*) 'J,I,MAT(J,I): ',J,I,MAT(J,I) 6334 return 6335 endif 6336 MAT(J,I)=MAT(J,I)/2 6337 if (Mat(j,i).gt.mxLinRE) 6338 *CALL QUIT('increase mxLinRE for regge3j') 6339 enddo 6340 enddo 6341 Isigma=(j1+j2+j3)/2 6342cbs check the magic sums 6343 do I=1,3 6344 IROW=0 6345 ICOL=0 6346 do J=1,3 6347 IROW=IROW+MAT(I,J) 6348 ICOL=ICOL+MAT(J,I) 6349 enddo 6350 if (IROW.ne.Isigma.or.ICOL.ne.Isigma) then 6351c write(6,*) 'I,IROW,ICOL ',I,IROW,ICOL 6352 return 6353 endif 6354 enddo 6355cbs if j1+j2+j3 is odd: check for equal rows or columns 6356 Isign=1 6357 if (iabs(mod(Isigma,2)).eq.1) then 6358 isign=-1 6359 do I=1,3 6360 do J=I+1,3 6361 if (MAT(1,I).eq.MAT(1,J).and. 6362 * MAT(2,I).eq.MAT(2,J).and. 6363 * MAT(3,I).eq.MAT(3,J)) return 6364 if (MAT(I,1).eq.MAT(J,1).and. 6365 * MAT(I,2).eq.MAT(J,2).and. 6366 * MAT(I,3).eq.MAT(J,3)) return 6367 enddo 6368 enddo 6369 endif 6370cbs look for the lowest element indices: IFIRST,ISECOND 6371 imini=MAT(1,1) 6372 IFIRST=1 6373 ISECOND=1 6374 do I=1,3 6375 do J=1,3 6376 if (MAT(J,I).lt.imini) then 6377 IFIRST=J 6378 ISECOND=I 6379 imini=MAT(J,I) 6380 endif 6381 enddo 6382 enddo 6383c write(6,*) 'Matrix before commuting vectors' 6384 do ibm=1,3 6385c write(6,'(3I5)') (Mat(ibm,j),j=1,3) 6386 enddo 6387 if (IFIRST.ne.1) then !interchange rows 6388c write(6,*) 'IFIRST = ',ifirst 6389 do I=1,3 6390 IDUMMY=MAT(1,I) 6391 MAT(1,I)=MAT(IFIRST,I) 6392 MAT(IFIRST,I)=IDUMMY 6393 enddo 6394 endif 6395 if (ISECOND.ne.1) then !interchange columns 6396c write(6,*) 'ISECOND = ',isecond 6397 do I=1,3 6398 IDUMMY=MAT(I,1) 6399 MAT(I,1)=MAT(I,ISECOND) 6400 MAT(I,ISECOND)=IDUMMY 6401 enddo 6402 endif 6403cbs lowest element is now on (1,1) 6404c write(6,*) 'Matrix after commuting vectors' 6405c do ibm=1,3 6406c write(6,'(3I5)') (Mat(ibm,j),j=1,3) 6407c enddo 6408cbs begin to calculate Sum over s_n 6409cbs first the simple cases 6410 if (Mat(1,1).eq.0) then 6411 isum=1 6412 elseif (Mat(1,1).eq.1) then 6413 isum=Mat(2,3)*Mat(3,2)-Mat(2,2)*Mat(3,3) 6414 elseif (Mat(1,1).eq.2) then 6415 isum=Mat(2,3)*(Mat(2,3)-1)*Mat(3,2)*(Mat(3,2)-1)- 6416 *2*Mat(2,3)*Mat(3,2)*Mat(2,2)*Mat(3,3)+ 6417 *Mat(2,2)*(Mat(2,2)-1)*Mat(3,3)*(Mat(3,3)-1) 6418 else ! all the cases with Mat(1,1) >= 3 6419 Icoeff=1 6420 do Ibm=Mat(3,2)-Mat(1,1)+1,Mat(3,2) 6421 icoeff=icoeff*ibm 6422 enddo 6423 do Ibm=Mat(2,3)-Mat(1,1)+1,Mat(2,3) 6424 icoeff=icoeff*ibm 6425 enddo 6426 isum=icoeff 6427 do Icount=1,MAT(1,1) 6428 icoeff=-icoeff*(Mat(1,1)+1-icount)*(Mat(2,2)+1-icount)* 6429 * (Mat(3,3)+1-icount) 6430 Idenom=icount*(Mat(2,3)-Mat(1,1)+icount)* 6431 * (Mat(3,2)-Mat(1,1)+icount) 6432 icoeff=icoeff/Idenom 6433 isum=isum+icoeff 6434 enddo 6435 endif 6436cbs additional sign from interchanging rows or columns 6437 if (ifirst.ne.1) isum=isum*isign 6438 if (isecond.ne.1) isum=isum*isign 6439c write(6,*) 'isum = ',isum 6440cbs Mat(2,3)+Mat(3,2) 6441cbs (-) 6442 if (iabs(mod((Mat(2,3)+Mat(3,2)),2)).eq.1) isum=-isum 6443cbs final factor 6444 LIMIT=ihigh(max(Mat(1,1),Mat(1,2),Mat(1,3), 6445 *Mat(2,1),Mat(2,2),Mat(2,3),Mat(3,1),Mat(3,2), 6446 *Mat(3,3),(Isigma+1))) 6447 do I=1,LIMIT 6448 iwork(I)=facul(I,Mat(1,2))+facul(I,Mat(2,1))+ 6449 *facul(I,Mat(3,1))+facul(I,Mat(1,3))- 6450 *facul(I,Mat(1,1))-facul(I,Mat(2,2))- 6451 *facul(I,Mat(3,3))-facul(I,(Isigma+1))- 6452 *facul(I,Mat(2,3))-facul(I,Mat(3,2)) 6453 enddo 6454c write(6,*) 'Iwork: ',(iwork(i),i=1,LIMIT) 6455 factor=1d0 6456 iup=1 6457 idown=1 6458 testup=.true. 6459 testdown=.true. 6460 do I=1,LIMIT 6461 do J=1,iwork(I) 6462 iup=iup*prim(i) 6463 if (iup.lt.0) testup=.false. !check for Integer overflow 6464 enddo 6465 Enddo 6466 up=dfloat(iup) 6467 if(.not.testup) then ! if the integers did not run correctly 6468 up=1d0 6469 do I=1,LIMIT 6470 do J=1,iwork(I) 6471 up=up*dfloat(prim(i)) 6472 enddo 6473 enddo 6474 endif 6475 do I=1,LIMIT 6476 do J=1,-iwork(I) 6477 idown=idown*prim(i) 6478 if (idown.lt.0) testdown=.false. 6479 enddo 6480 enddo 6481 down=dfloat(idown) 6482 if(.not.testdown) then 6483 down=1d0 6484 do I=1,LIMIT 6485 do J=1,-iwork(I) 6486 down=down*dfloat(prim(i)) 6487 enddo 6488 enddo 6489 endif 6490c if (.not.(testup.and.testdown)) then 6491c write(6,*) 'j1,j2,j3,m1,m2,m3 ',j1,j2,j3,m1,m2,m3 6492c write(6,*) 'iup,idown ',iup,idown,'up,down ',up,down 6493c endif 6494 factor=factor*up/down 6495cbs final result 6496 regge3j=dsqrt(factor)*dfloat(isum) 6497 return 6498 end 6499 double precision function Tkinet(l,alpha1,alpha2) 6500cbs calculates the matrix element of kinetic energy 6501cbs for primitive normalized functions with the same angular momentum l 6502cbs and exponents alpha1 and alpha2 6503cbs works only, if r**l is assumed for an l-value 6504cbs formular obtained from the symmetric expression (d/dr's to (') 6505cbs the left and to the right. 6506cbs Overlaps of the different powers are partially crossed out 6507cbs with the overlap of functions with angular momentum l 6508cbs final formula: 6509cbs Tkinet=0.5*alpha12 (2l+3) (alpha1*alpha2/alpha12*alpha12)**((2L+7)/4) 6510cbs with alpha12=0.5*(alpha1+alpha2) 6511cbs as alpha12 has the dimensions 1/length**2, this can not be that bad... 6512 Implicit double precision (a-h,o-z) 6513Cbs alpha12 is the effective exponent 6514 Alpha12=0.5d0*(alpha1+alpha2) 6515 alphpro=alpha1*alpha2 6516 ll3=l+l+3 6517 ll7=l+l+7 6518 Tkinet=0.5d0*alpha12*ll3*(alphpro/ 6519 *(alpha12*alpha12))**(0.25*dfloat(ll7)) 6520 return 6521 end 6522 subroutine tosigX(m1,m2,m3,m4,angint, 6523 *mcombina,ncontl1,ncontl2,ncontl3, 6524 *ncontl4,carteX,preXZ,interxyz,isgnprod, 6525 *cleaner) 6526cbs this subroutine combines the angular integrals 6527cbs to the integrals for the real-valued linear 6528cbs combinations for the sigma_X part 6529cbs definition of the real-valued linear combinations: 6530cbs 6531cbs 6532cbs M=0 is the same as Y(L,0) 6533cbs 6534cbs 6535cbs M > 0 6536cbs 6537cbs | L,M,+> = 2**(-0.5) ( (-1)**M Y(L,M) + Y(L,-M)) 6538cbs 6539cbs | L,M,-> = -i 2**(-0.5) ( (-1)**M Y(L,M) - Y(L,-M)) ($$$$) 6540cbs 6541cbs 6542cbs due to symmetry, there can be only integrals 6543cbs with indices one or three (sigma_+ and sigma_-)- combinations 6544cbs 6545#include "implicit.h" 6546#include "para.h" 6547#include "priunit.h" 6548 logical cleaner 6549 dimension mcombina(2,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax), 6550 *angint(ncontl1,ncontl2,ncontl3,ncontl4,*), 6551cbs !!!!!!!!!!!changing now to the order of chemists notation!!!!!!!!!! 6552 *carteX(ncontl1,ncontl3,ncontl2,ncontl4), 6553 *preXZ(-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax), 6554 *interxyz(*), 6555 *isgnprod(-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax), 6556 *isgnM(-1:1,-1:1,-1:1,-1:1) 6557c write(6,*) ' begin tosigx' 6558cbs cleaning up the integral-array 6559 irun=ncontl1*ncontl2*ncontl3*ncontl4 6560 call dzero(cartex,irun) 6561cbs set some signs 6562cbs isgnM will give an additonal minus-sign if both m-values 6563cbs (cartesian and angular) are negative see $$$$ 6564 do irun4=-1,1 6565 do irun3=-1,1 6566 do irun2=-1,1 6567 do irun1=-1,1 6568 isgnM(irun1,irun2,irun3,irun4)=1 6569 enddo 6570 enddo 6571 enddo 6572 enddo 6573 if (m1.lt.0) then 6574 do irun4=-1,1 6575 do irun3=-1,1 6576 do irun2=-1,1 6577 isgnM(-1,irun2,irun3,irun4)= 6578 *-isgnM(-1,irun2,irun3,irun4) 6579 enddo 6580 enddo 6581 enddo 6582 endif 6583 if (m2.lt.0) then 6584 do irun4=-1,1 6585 do irun3=-1,1 6586 do irun1=-1,1 6587 isgnM(irun1,-1,irun3,irun4)= 6588 *-isgnM(irun1,-1,irun3,irun4) 6589 enddo 6590 enddo 6591 enddo 6592 endif 6593 if (m3.lt.0) then 6594 do irun4=-1,1 6595 do irun2=-1,1 6596 do irun1=-1,1 6597 isgnM(irun1,irun2,-1,irun4)= 6598 *-isgnM(irun1,irun2,-1,irun4) 6599 enddo 6600 enddo 6601 enddo 6602 endif 6603 if (m4.lt.0) then 6604 do irun3=-1,1 6605 do irun2=-1,1 6606 do irun1=-1,1 6607 isgnM(irun1,irun2,irun3,-1)= 6608 *-isgnM(irun1,irun2,irun3,-1) 6609 enddo 6610 enddo 6611 enddo 6612 endif 6613cbs define absolute m-values 6614 Mabs1=iabs(m1) 6615 Mabs2=iabs(m2) 6616 Mabs3=iabs(m3) 6617 Mabs4=iabs(m4) 6618 irun=0 6619 if (interxyz(1).eq.0) then 6620 write(LUPRI,*) 'tosigx: no interaction: ',m1,m2,m3,m4 6621 CALL QUIT('Error in TOSIGX in AMFI') 6622 endif 6623 prexz1234=preXZ(m1,m2,m3,m4) 6624 do while (interxyz(irun+1).gt.0) 6625 irun=irun+1 6626c write(6,*) 'tosigx: ',irun,interxyz(irun) 6627c 6628cbs 6629cbs 6630cbs This could be done with gotos, but I am biased to hate those.. 6631cbs 6632cbs 6633 if (interxyz(irun).eq.1) then 6634 ityp=mcombina(1,Mabs1,Mabs2,Mabs3,Mabs4) 6635 iblock=mcombina(2,Mabs1,Mabs2,Mabs3,Mabs4) 6636 factor=isgnM(1,1,1,1)*prexz1234* 6637 * dfloat(isgnprod(Mabs1,Mabs2,Mabs3,Mabs4)) 6638 call daxpint(angint(1,1,1,1,iblock),carteX, 6639 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 6640c 6641 elseif (interxyz(irun).eq.2) then 6642 ityp=mcombina(1,-Mabs1,-Mabs2,-Mabs3,-Mabs4) 6643 iblock=mcombina(2,-Mabs1,-Mabs2,-Mabs3,-Mabs4) 6644 factor=isgnM(-1,-1,-1,-1)*prexz1234* 6645 * dfloat(isgnprod(-Mabs1,-Mabs2,-Mabs3,-Mabs4)) 6646 call daxpint(angint(1,1,1,1,iblock),carteX, 6647 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 6648c 6649 elseif (interxyz(irun).eq.3) then 6650 ityp=mcombina(1,Mabs1,Mabs2,Mabs3,-Mabs4) 6651 iblock=mcombina(2,Mabs1,Mabs2,Mabs3,-Mabs4) 6652 factor=isgnM(1,1,1,-1)*prexz1234* 6653 * dfloat(isgnprod(Mabs1,Mabs2,Mabs3,-Mabs4)) 6654 call daxpint(angint(1,1,1,1,iblock),carteX, 6655 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 6656c 6657 elseif (interxyz(irun).eq.4) then 6658 ityp=mcombina(1,-Mabs1,-Mabs2,-Mabs3,Mabs4) 6659 iblock=mcombina(2,-Mabs1,-Mabs2,-Mabs3,Mabs4) 6660 factor=isgnM(-1,-1,-1,1)*prexz1234* 6661 * dfloat(isgnprod(-Mabs1,-Mabs2,-Mabs3,Mabs4)) 6662 call daxpint(angint(1,1,1,1,iblock),carteX, 6663 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 6664c 6665 elseif (interxyz(irun).eq.5) then 6666 ityp=mcombina(1,Mabs1,Mabs2,-Mabs3,Mabs4) 6667 iblock=mcombina(2,Mabs1,Mabs2,-Mabs3,Mabs4) 6668 factor=isgnM(1,1,-1,1)*prexz1234* 6669 * dfloat(isgnprod(Mabs1,Mabs2,-Mabs3,Mabs4)) 6670 call daxpint(angint(1,1,1,1,iblock),carteX, 6671 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 6672c 6673 elseif (interxyz(irun).eq.6) then 6674 ityp=mcombina(1,-Mabs1,-Mabs2,Mabs3,-Mabs4) 6675 iblock=mcombina(2,-Mabs1,-Mabs2,Mabs3,-Mabs4) 6676 factor=isgnM(-1,-1,1,-1)*prexz1234* 6677 * dfloat(isgnprod(-Mabs1,-Mabs2,Mabs3,-Mabs4)) 6678 call daxpint(angint(1,1,1,1,iblock),carteX, 6679 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 6680c 6681 elseif (interxyz(irun).eq.7) then 6682 ityp=mcombina(1,Mabs1,-Mabs2,Mabs3,Mabs4) 6683 iblock=mcombina(2,Mabs1,-Mabs2,Mabs3,Mabs4) 6684 factor=isgnM(1,-1,1,1)*prexz1234* 6685 * dfloat(isgnprod(Mabs1,-Mabs2,Mabs3,Mabs4)) 6686 call daxpint(angint(1,1,1,1,iblock),carteX, 6687 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 6688c 6689 elseif (interxyz(irun).eq.8) then 6690 ityp=mcombina(1,-Mabs1,Mabs2,-Mabs3,-Mabs4) 6691 iblock=mcombina(2,-Mabs1,Mabs2,-Mabs3,-Mabs4) 6692 factor=isgnM(-1,1,-1,-1)*prexz1234* 6693 * dfloat(isgnprod(-Mabs1,Mabs2,-Mabs3,-Mabs4)) 6694 call daxpint(angint(1,1,1,1,iblock),carteX, 6695 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 6696c 6697 elseif (interxyz(irun).eq.9) then 6698 ityp=mcombina(1,-Mabs1,Mabs2,Mabs3,Mabs4) 6699 iblock=mcombina(2,-Mabs1,Mabs2,Mabs3,Mabs4) 6700 factor=isgnM(-1,1,1,1)*prexz1234* 6701 * dfloat(isgnprod(-Mabs1,Mabs2,Mabs3,Mabs4)) 6702 call daxpint(angint(1,1,1,1,iblock),carteX, 6703 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 6704c 6705 elseif (interxyz(irun).eq.10) then 6706 ityp=mcombina(1,Mabs1,-Mabs2,-Mabs3,-Mabs4) 6707 iblock=mcombina(2,Mabs1,-Mabs2,-Mabs3,-Mabs4) 6708 factor=isgnM(1,-1,-1,-1)*prexz1234* 6709 * dfloat(isgnprod(Mabs1,-Mabs2,-Mabs3,-Mabs4)) 6710 call daxpint(angint(1,1,1,1,iblock),carteX, 6711 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 6712c 6713 elseif (interxyz(irun).eq.11) then 6714 ityp=mcombina(1,Mabs1,Mabs2,-Mabs3,-Mabs4) 6715 iblock=mcombina(2,Mabs1,Mabs2,-Mabs3,-Mabs4) 6716 factor=isgnM(1,1,-1,-1)*prexz1234* 6717 * dfloat(isgnprod(Mabs1,Mabs2,-Mabs3,-Mabs4)) 6718 call daxpint(angint(1,1,1,1,iblock),carteX, 6719 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 6720c 6721 elseif (interxyz(irun).eq.12) then 6722 ityp=mcombina(1,-Mabs1,-Mabs2,Mabs3,Mabs4) 6723 iblock=mcombina(2,-Mabs1,-Mabs2,Mabs3,Mabs4) 6724 factor=isgnM(-1,-1,1,1)*prexz1234* 6725 * dfloat(isgnprod(-Mabs1,-Mabs2,Mabs3,Mabs4)) 6726 call daxpint(angint(1,1,1,1,iblock),carteX, 6727 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 6728c 6729 elseif (interxyz(irun).eq.13) then 6730 ityp=mcombina(1,Mabs1,-Mabs2,Mabs3,-Mabs4) 6731 iblock=mcombina(2,Mabs1,-Mabs2,Mabs3,-Mabs4) 6732 factor=isgnM(1,-1,1,-1)*prexz1234* 6733 * dfloat(isgnprod(Mabs1,-Mabs2,Mabs3,-Mabs4)) 6734 call daxpint(angint(1,1,1,1,iblock),carteX, 6735 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 6736c 6737 elseif (interxyz(irun).eq.14) then 6738 ityp=mcombina(1,-Mabs1,Mabs2,-Mabs3,Mabs4) 6739 iblock=mcombina(2,-Mabs1,Mabs2,-Mabs3,Mabs4) 6740 factor=isgnM(-1,1,-1,1)*prexz1234* 6741 * dfloat(isgnprod(-Mabs1,Mabs2,-Mabs3,Mabs4)) 6742 call daxpint(angint(1,1,1,1,iblock),carteX, 6743 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 6744c 6745 elseif (interxyz(irun).eq.15) then 6746 ityp=mcombina(1,Mabs1,-Mabs2,-Mabs3,Mabs4) 6747 iblock=mcombina(2,Mabs1,-Mabs2,-Mabs3,Mabs4) 6748 factor=isgnM(1,-1,-1,1)*prexz1234* 6749 * dfloat(isgnprod(Mabs1,-Mabs2,-Mabs3,Mabs4)) 6750 call daxpint(angint(1,1,1,1,iblock),carteX, 6751 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 6752c 6753 elseif (interxyz(irun).eq.16) then 6754 ityp=mcombina(1,-Mabs1,Mabs2,Mabs3,-Mabs4) 6755 iblock=mcombina(2,-Mabs1,Mabs2,Mabs3,-Mabs4) 6756 factor=isgnM(-1,1,1,-1)*prexz1234* 6757 * dfloat(isgnprod(-Mabs1,Mabs2,Mabs3,-Mabs4)) 6758 call daxpint(angint(1,1,1,1,iblock),carteX, 6759 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 6760 endif 6761 enddo 6762 if (cleaner) then 6763 do irun4=1,ncontl4 6764 do irun2=1,ncontl2 6765 do irun1=1,ncontl1 6766 cartex(irun1,irun1,irun2,irun4)=0d0 6767 enddo 6768 enddo 6769 enddo 6770 endif 6771 return 6772 end 6773 subroutine tosigY(m1,m2,m3,m4,angint, 6774 *mcombina,ncontl1,ncontl2,ncontl3, 6775 *ncontl4,carteY,preY,interxyz,isgnprod, 6776 *cleaner) 6777cbs this subroutine combines the angular integrals 6778cbs to the integrals for the real-valued linear 6779cbs combinations for the sigma_X part 6780cbs definition of the real-valued linear combinations: 6781cbs 6782cbs 6783cbs M=0 is the same as Y(L,0) 6784cbs 6785cbs 6786cbs M > 0 6787cbs 6788cbs | L,M,+> = 2**(-0.5) ( (-1)**M Y(L,M) + Y(L,-M)) 6789cbs 6790cbs | L,M,-> = -i 2**(-0.5) ( (-1)**M Y(L,M) - Y(L,-M)) ($$$$) 6791cbs 6792cbs 6793cbs due to symmetry, there can be only integrals 6794cbs with one or three (sigma_+ and sigma_-) - combinations 6795cbs 6796#include "implicit.h" 6797#include "priunit.h" 6798#include "para.h" 6799 dimension mcombina(2,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax), 6800 *angint(ncontl1,ncontl2,ncontl3,ncontl4,*), 6801cbs !!!!!!!!!!!changing now to the order of chemists notation!!!!!!!!!! 6802 *carteY(ncontl1,ncontl3,ncontl2,ncontl4), 6803 *preY(-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax), 6804 *interxyz(*), 6805 *isgnprod(-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax), 6806 *isgnM(-1:1,-1:1,-1:1,-1:1) 6807 logical cleaner 6808c write(6,*) 'begin tosigy ' 6809cbs cleaning up the integral-array 6810 irun=ncontl4*ncontl2*ncontl3*ncontl1 6811 call dzero(carteY,irun) 6812cbs set some signs 6813cbs isgnM will give an additonal minus-sign if both m-values 6814cbs (cartesian and angular) are negative see $$$$ 6815 do irun4=-1,1 6816 do irun3=-1,1 6817 do irun2=-1,1 6818 do irun1=-1,1 6819 isgnM(irun1,irun2,irun3,irun4)=1 6820 enddo 6821 enddo 6822 enddo 6823 enddo 6824 if (m1.lt.0) then 6825 do irun4=-1,1 6826 do irun3=-1,1 6827 do irun2=-1,1 6828 isgnM(-1,irun2,irun3,irun4)= 6829 *-isgnM(-1,irun2,irun3,irun4) 6830 enddo 6831 enddo 6832 enddo 6833 endif 6834 if (m2.lt.0) then 6835 do irun4=-1,1 6836 do irun3=-1,1 6837 do irun1=-1,1 6838 isgnM(irun1,-1,irun3,irun4)= 6839 *-isgnM(irun1,-1,irun3,irun4) 6840 enddo 6841 enddo 6842 enddo 6843 endif 6844 if (m3.lt.0) then 6845 do irun4=-1,1 6846 do irun2=-1,1 6847 do irun1=-1,1 6848 isgnM(irun1,irun2,-1,irun4)= 6849 *-isgnM(irun1,irun2,-1,irun4) 6850 enddo 6851 enddo 6852 enddo 6853 endif 6854 if (m4.lt.0) then 6855 do irun3=-1,1 6856 do irun2=-1,1 6857 do irun1=-1,1 6858 isgnM(irun1,irun2,irun3,-1)= 6859 *-isgnM(irun1,irun2,irun3,-1) 6860 enddo 6861 enddo 6862 enddo 6863 endif 6864cbs define absolute m-values 6865 Mabs1=iabs(m1) 6866 Mabs2=iabs(m2) 6867 Mabs3=iabs(m3) 6868 Mabs4=iabs(m4) 6869 irun=0 6870 if (interxyz(1).eq.0) then 6871 write(LUPRI,*) 'tosigy: no interaction: ',m1,m2,m3,m4 6872 CALL QUIT('Error in TOSIGY in AMFI') 6873 endif 6874 prey1234=preY(m1,m2,m3,m4) 6875c write(6,*) 'prey ',prey1234 6876 do while (interxyz(irun+1).gt.0) 6877 irun=irun+1 6878c write(6,*) 'tosigy: ',irun,interxyz(irun) 6879c 6880cbs 6881cbs 6882cbs This could be done with gotos, but I am biased to hate those.. 6883cbs 6884cbs 6885 if (interxyz(irun).eq.1) then 6886 ityp=mcombina(1,Mabs1,Mabs2,Mabs3,Mabs4) 6887 iblock=mcombina(2,Mabs1,Mabs2,Mabs3,Mabs4) 6888 factor=isgnM(1,1,1,1)*prey1234* 6889 * dfloat(isgnprod(Mabs1,Mabs2,Mabs3,Mabs4)) 6890 if (ityp.eq.3) factor=-factor 6891 call daxpint(angint(1,1,1,1,iblock),carteY, 6892 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 6893c 6894 elseif (interxyz(irun).eq.2) then 6895 ityp=mcombina(1,-Mabs1,-Mabs2,-Mabs3,-Mabs4) 6896 iblock=mcombina(2,-Mabs1,-Mabs2,-Mabs3,-Mabs4) 6897 factor=isgnM(-1,-1,-1,-1)*prey1234* 6898 * dfloat(isgnprod(-Mabs1,-Mabs2,-Mabs3,-Mabs4)) 6899 if (ityp.eq.3) factor=-factor 6900 call daxpint(angint(1,1,1,1,iblock),carteY, 6901 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 6902c 6903 elseif (interxyz(irun).eq.3) then 6904 ityp=mcombina(1,Mabs1,Mabs2,Mabs3,-Mabs4) 6905 iblock=mcombina(2,Mabs1,Mabs2,Mabs3,-Mabs4) 6906 factor=isgnM(1,1,1,-1)*prey1234* 6907 * dfloat(isgnprod(Mabs1,Mabs2,Mabs3,-Mabs4)) 6908 if (ityp.eq.3) factor=-factor 6909 call daxpint(angint(1,1,1,1,iblock),carteY, 6910 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 6911c 6912 elseif (interxyz(irun).eq.4) then 6913 ityp=mcombina(1,-Mabs1,-Mabs2,-Mabs3,Mabs4) 6914 iblock=mcombina(2,-Mabs1,-Mabs2,-Mabs3,Mabs4) 6915 factor=isgnM(-1,-1,-1,1)*prey1234* 6916 * dfloat(isgnprod(-Mabs1,-Mabs2,-Mabs3,Mabs4)) 6917 if (ityp.eq.3) factor=-factor 6918 call daxpint(angint(1,1,1,1,iblock),carteY, 6919 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 6920c 6921 elseif (interxyz(irun).eq.5) then 6922 ityp=mcombina(1,Mabs1,Mabs2,-Mabs3,Mabs4) 6923 iblock=mcombina(2,Mabs1,Mabs2,-Mabs3,Mabs4) 6924 factor=isgnM(1,1,-1,1)*prey1234* 6925 * dfloat(isgnprod(Mabs1,Mabs2,-Mabs3,Mabs4)) 6926 if (ityp.eq.3) factor=-factor 6927 call daxpint(angint(1,1,1,1,iblock),carteY, 6928 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 6929c 6930 elseif (interxyz(irun).eq.6) then 6931 ityp=mcombina(1,-Mabs1,-Mabs2,Mabs3,-Mabs4) 6932 iblock=mcombina(2,-Mabs1,-Mabs2,Mabs3,-Mabs4) 6933 factor=isgnM(-1,-1,1,-1)*prey1234* 6934 * dfloat(isgnprod(-Mabs1,-Mabs2,Mabs3,-Mabs4)) 6935 if (ityp.eq.3) factor=-factor 6936 call daxpint(angint(1,1,1,1,iblock),carteY, 6937 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 6938c 6939 elseif (interxyz(irun).eq.7) then 6940 ityp=mcombina(1,Mabs1,-Mabs2,Mabs3,Mabs4) 6941 iblock=mcombina(2,Mabs1,-Mabs2,Mabs3,Mabs4) 6942 factor=isgnM(1,-1,1,1)*prey1234* 6943 * dfloat(isgnprod(Mabs1,-Mabs2,Mabs3,Mabs4)) 6944 if (ityp.eq.3) factor=-factor 6945 call daxpint(angint(1,1,1,1,iblock),carteY, 6946 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 6947c 6948 elseif (interxyz(irun).eq.8) then 6949 ityp=mcombina(1,-Mabs1,Mabs2,-Mabs3,-Mabs4) 6950 iblock=mcombina(2,-Mabs1,Mabs2,-Mabs3,-Mabs4) 6951 factor=isgnM(-1,1,-1,-1)*prey1234* 6952 * dfloat(isgnprod(-Mabs1,Mabs2,-Mabs3,-Mabs4)) 6953 if (ityp.eq.3) factor=-factor 6954 call daxpint(angint(1,1,1,1,iblock),carteY, 6955 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 6956c 6957 elseif (interxyz(irun).eq.9) then 6958 ityp=mcombina(1,-Mabs1,Mabs2,Mabs3,Mabs4) 6959 iblock=mcombina(2,-Mabs1,Mabs2,Mabs3,Mabs4) 6960 factor=isgnM(-1,1,1,1)*prey1234* 6961 * dfloat(isgnprod(-Mabs1,Mabs2,Mabs3,Mabs4)) 6962 if (ityp.eq.3) factor=-factor 6963 call daxpint(angint(1,1,1,1,iblock),carteY, 6964 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 6965c 6966 elseif (interxyz(irun).eq.10) then 6967 ityp=mcombina(1,Mabs1,-Mabs2,-Mabs3,-Mabs4) 6968 iblock=mcombina(2,Mabs1,-Mabs2,-Mabs3,-Mabs4) 6969 factor=isgnM(1,-1,-1,-1)*prey1234* 6970 * dfloat(isgnprod(Mabs1,-Mabs2,-Mabs3,-Mabs4)) 6971 if (ityp.eq.3) factor=-factor 6972 call daxpint(angint(1,1,1,1,iblock),carteY, 6973 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 6974c 6975 elseif (interxyz(irun).eq.11) then 6976 ityp=mcombina(1,Mabs1,Mabs2,-Mabs3,-Mabs4) 6977 iblock=mcombina(2,Mabs1,Mabs2,-Mabs3,-Mabs4) 6978 factor=isgnM(1,1,-1,-1)*prey1234* 6979 * dfloat(isgnprod(Mabs1,Mabs2,-Mabs3,-Mabs4)) 6980 if (ityp.eq.3) factor=-factor 6981 call daxpint(angint(1,1,1,1,iblock),carteY, 6982 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 6983c 6984 elseif (interxyz(irun).eq.12) then 6985 ityp=mcombina(1,-Mabs1,-Mabs2,Mabs3,Mabs4) 6986 iblock=mcombina(2,-Mabs1,-Mabs2,Mabs3,Mabs4) 6987 factor=isgnM(-1,-1,1,1)*prey1234* 6988 * dfloat(isgnprod(-Mabs1,-Mabs2,Mabs3,Mabs4)) 6989 if (ityp.eq.3) factor=-factor 6990 call daxpint(angint(1,1,1,1,iblock),carteY, 6991 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 6992c 6993 elseif (interxyz(irun).eq.13) then 6994 ityp=mcombina(1,Mabs1,-Mabs2,Mabs3,-Mabs4) 6995 iblock=mcombina(2,Mabs1,-Mabs2,Mabs3,-Mabs4) 6996 factor=isgnM(1,-1,1,-1)*prey1234* 6997 * dfloat(isgnprod(Mabs1,-Mabs2,Mabs3,-Mabs4)) 6998 if (ityp.eq.3) factor=-factor 6999 call daxpint(angint(1,1,1,1,iblock),carteY, 7000 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 7001c 7002 elseif (interxyz(irun).eq.14) then 7003 ityp=mcombina(1,-Mabs1,Mabs2,-Mabs3,Mabs4) 7004 iblock=mcombina(2,-Mabs1,Mabs2,-Mabs3,Mabs4) 7005 factor=isgnM(-1,1,-1,1)*prey1234* 7006 * dfloat(isgnprod(-Mabs1,Mabs2,-Mabs3,Mabs4)) 7007 if (ityp.eq.3) factor=-factor 7008 call daxpint(angint(1,1,1,1,iblock),carteY, 7009 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 7010c 7011 elseif (interxyz(irun).eq.15) then 7012 ityp=mcombina(1,Mabs1,-Mabs2,-Mabs3,Mabs4) 7013 iblock=mcombina(2,Mabs1,-Mabs2,-Mabs3,Mabs4) 7014 factor=isgnM(1,-1,-1,1)*prey1234* 7015 * dfloat(isgnprod(Mabs1,-Mabs2,-Mabs3,Mabs4)) 7016 if (ityp.eq.3) factor=-factor 7017 call daxpint(angint(1,1,1,1,iblock),carteY, 7018 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 7019c 7020 elseif (interxyz(irun).eq.16) then 7021 ityp=mcombina(1,-Mabs1,Mabs2,Mabs3,-Mabs4) 7022 iblock=mcombina(2,-Mabs1,Mabs2,Mabs3,-Mabs4) 7023 factor=isgnM(-1,1,1,-1)*prey1234* 7024 * dfloat(isgnprod(-Mabs1,Mabs2,Mabs3,-Mabs4)) 7025 if (ityp.eq.3) factor=-factor 7026 call daxpint(angint(1,1,1,1,iblock),carteY, 7027 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 7028c 7029 endif 7030 Enddo 7031 if (cleaner) then 7032 do irun4=1,ncontl4 7033 do irun2=1,ncontl2 7034 do irun1=1,ncontl1 7035 cartey(irun1,irun1,irun2,irun4)=0d0 7036 enddo 7037 enddo 7038 enddo 7039 endif 7040 return 7041 end 7042 subroutine tosigZ(m1,m2,m3,m4,angint, 7043 *mcombina,ncontl1,ncontl2,ncontl3, 7044 *ncontl4,carteZ,preXZ,interxyz,isgnprod, 7045 *cleaner) 7046cbs this subroutine combines the angular integrals 7047cbs to the integrals for the real-valued linear 7048cbs combinations for the sigma_Z part 7049cbs definition of the real-valued linear combinations: 7050cbs 7051cbs 7052cbs M=0 is the same as Y(L,0) 7053cbs 7054cbs 7055cbs M > 0 7056cbs 7057cbs | L,M,+> = 2**(-0.5) ( (-1)**M Y(L,M) + Y(L,-M)) 7058cbs 7059cbs | L,M,-> = -i 2**(-0.5) ( (-1)**M Y(L,M) - Y(L,-M)) ($$$$) 7060cbs 7061cbs only angular integrals of type 2 (sigma_0) contribute 7062cbs 7063#include "implicit.h" 7064#include "priunit.h" 7065#include "para.h" 7066 dimension mcombina(2,-Lmax:Lmax,-Lmax:Lmax, 7067 *-Lmax:Lmax,-Lmax:Lmax), 7068 *angint(ncontl1,ncontl2,ncontl3,ncontl4,*), 7069cbs !!!!!!!!!!!changing now to the order of chemists notation!!!!!!!!!! 7070 *carteZ(ncontl1,ncontl3,ncontl2,ncontl4), 7071 *preXZ(-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax), 7072 *interxyz(*), 7073 *isgnprod(-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax,-Lmax:Lmax), 7074 *isgnM(-1:1,-1:1,-1:1,-1:1) 7075 logical cleaner 7076cbs cleaning up the integral-array 7077 irun=ncontl4*ncontl2*ncontl3*ncontl1 7078 call dzero(carteZ,irun) 7079c write(6,*) 'begin tosigz' 7080cbs set some signs 7081cbs isgnM will give an additonal minus-sign if both m-values 7082cbs (cartesian and angular) are negative see $$$$ 7083 do irun4=-1,1 7084 do irun3=-1,1 7085 do irun2=-1,1 7086 do irun1=-1,1 7087 isgnM(irun1,irun2,irun3,irun4)=1 7088 enddo 7089 enddo 7090 enddo 7091 enddo 7092 if (m1.lt.0) then 7093 do irun4=-1,1 7094 do irun3=-1,1 7095 do irun2=-1,1 7096 isgnM(-1,irun2,irun3,irun4)= 7097 *-isgnM(-1,irun2,irun3,irun4) 7098 enddo 7099 enddo 7100 enddo 7101 endif 7102 if (m2.lt.0) then 7103 do irun4=-1,1 7104 do irun3=-1,1 7105 do irun1=-1,1 7106 isgnM(irun1,-1,irun3,irun4)= 7107 *-isgnM(irun1,-1,irun3,irun4) 7108 enddo 7109 enddo 7110 enddo 7111 endif 7112 if (m3.lt.0) then 7113 do irun4=-1,1 7114 do irun2=-1,1 7115 do irun1=-1,1 7116 isgnM(irun1,irun2,-1,irun4)= 7117 *-isgnM(irun1,irun2,-1,irun4) 7118 enddo 7119 enddo 7120 enddo 7121 endif 7122 if (m4.lt.0) then 7123 do irun3=-1,1 7124 do irun2=-1,1 7125 do irun1=-1,1 7126 isgnM(irun1,irun2,irun3,-1)= 7127 *-isgnM(irun1,irun2,irun3,-1) 7128 enddo 7129 enddo 7130 enddo 7131 endif 7132cbs define absolute m-values 7133 Mabs1=iabs(m1) 7134 Mabs2=iabs(m2) 7135 Mabs3=iabs(m3) 7136 Mabs4=iabs(m4) 7137 irun=0 7138 if (interxyz(1).eq.0) then 7139 write(LUPRI,*) 'tosigz: no interaction: ',m1,m2,m3,m4 7140 CALL QUIT('Error in TOSIGZ in AMFI') 7141 endif 7142 prexz1234=preXZ(m1,m2,m3,m4) 7143 do while (interxyz(irun+1).gt.0) 7144 irun=irun+1 7145c 7146cbs 7147cbs 7148cbs This could be done with gotos, but I am biased to hate those.. 7149cbs 7150cbs 7151 if (interxyz(irun).eq.1) then 7152 ityp=mcombina(1,Mabs1,Mabs2,Mabs3,Mabs4) 7153 iblock=mcombina(2,Mabs1,Mabs2,Mabs3,Mabs4) 7154 factor=isgnM(1,1,1,1)*prexz1234* 7155 * dfloat(isgnprod(Mabs1,Mabs2,Mabs3,Mabs4)) 7156 call daxpint(angint(1,1,1,1,iblock),carteZ, 7157 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 7158c 7159 elseif (interxyz(irun).eq.2) then 7160 ityp=mcombina(1,Mabs1,Mabs2,Mabs3,Mabs4) 7161 iblock=mcombina(2,Mabs1,Mabs2,Mabs3,Mabs4) 7162 factor=-isgnM(-1,-1,-1,-1)*prexz1234* 7163 * dfloat(isgnprod(-Mabs1,-Mabs2,-Mabs3,-Mabs4)) 7164 call daxpint(angint(1,1,1,1,iblock),carteZ, 7165 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 7166c 7167 elseif (interxyz(irun).eq.3) then 7168 ityp=mcombina(1,Mabs1,Mabs2,Mabs3,-Mabs4) 7169 iblock=mcombina(2,Mabs1,Mabs2,Mabs3,-Mabs4) 7170 factor=isgnM(1,1,1,-1)*prexz1234* 7171 * dfloat(isgnprod(Mabs1,Mabs2,Mabs3,-Mabs4)) 7172 call daxpint(angint(1,1,1,1,iblock),carteZ, 7173 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 7174c 7175 elseif (interxyz(irun).eq.4) then 7176 ityp=mcombina(1,Mabs1,Mabs2,Mabs3,-Mabs4) 7177 iblock=mcombina(2,Mabs1,Mabs2,Mabs3,-Mabs4) 7178 factor=-isgnM(-1,-1,-1,1)*prexz1234* 7179 * dfloat(isgnprod(-Mabs1,-Mabs2,-Mabs3,Mabs4)) 7180 call daxpint(angint(1,1,1,1,iblock),carteZ, 7181 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 7182c 7183 elseif (interxyz(irun).eq.5) then 7184 ityp=mcombina(1,Mabs1,Mabs2,-Mabs3,Mabs4) 7185 iblock=mcombina(2,Mabs1,Mabs2,-Mabs3,Mabs4) 7186 factor=isgnM(1,1,-1,1)*prexz1234* 7187 * dfloat(isgnprod(Mabs1,Mabs2,-Mabs3,Mabs4)) 7188 call daxpint(angint(1,1,1,1,iblock),carteZ, 7189 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 7190c 7191 elseif (interxyz(irun).eq.6) then 7192 ityp=mcombina(1,Mabs1,Mabs2,-Mabs3,Mabs4) 7193 iblock=mcombina(2,Mabs1,Mabs2,-Mabs3,Mabs4) 7194 factor=-isgnM(-1,-1,1,-1)*prexz1234* 7195 * dfloat(isgnprod(-Mabs1,-Mabs2,Mabs3,-Mabs4)) 7196 call daxpint(angint(1,1,1,1,iblock),carteZ, 7197 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 7198c 7199 elseif (interxyz(irun).eq.7) then 7200 ityp=mcombina(1,Mabs1,-Mabs2,Mabs3,Mabs4) 7201 iblock=mcombina(2,Mabs1,-Mabs2,Mabs3,Mabs4) 7202 factor=isgnM(1,-1,1,1)*prexz1234* 7203 * dfloat(isgnprod(Mabs1,-Mabs2,Mabs3,Mabs4)) 7204 call daxpint(angint(1,1,1,1,iblock),carteZ, 7205 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 7206c 7207 elseif (interxyz(irun).eq.8) then 7208 ityp=mcombina(1,Mabs1,-Mabs2,Mabs3,Mabs4) 7209 iblock=mcombina(2,Mabs1,-Mabs2,Mabs3,Mabs4) 7210 factor=-isgnM(-1,1,-1,-1)*prexz1234* 7211 * dfloat(isgnprod(-Mabs1,Mabs2,-Mabs3,-Mabs4)) 7212 call daxpint(angint(1,1,1,1,iblock),carteZ, 7213 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 7214c 7215 elseif (interxyz(irun).eq.9) then 7216 ityp=mcombina(1,Mabs1,-Mabs2,-Mabs3,-Mabs4) 7217 iblock=mcombina(2,Mabs1,-Mabs2,-Mabs3,-Mabs4) 7218 factor=-isgnM(-1,1,1,1)*prexz1234* 7219 * dfloat(isgnprod(-Mabs1,Mabs2,Mabs3,Mabs4)) 7220 call daxpint(angint(1,1,1,1,iblock),carteZ, 7221 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 7222c 7223 elseif (interxyz(irun).eq.10) then 7224 ityp=mcombina(1,Mabs1,-Mabs2,-Mabs3,-Mabs4) 7225 iblock=mcombina(2,Mabs1,-Mabs2,-Mabs3,-Mabs4) 7226 factor=isgnM(1,-1,-1,-1)*prexz1234* 7227 * dfloat(isgnprod(Mabs1,-Mabs2,-Mabs3,-Mabs4)) 7228 call daxpint(angint(1,1,1,1,iblock),carteZ, 7229 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 7230c 7231 elseif (interxyz(irun).eq.11) then 7232 ityp=mcombina(1,Mabs1,Mabs2,-Mabs3,-Mabs4) 7233 iblock=mcombina(2,Mabs1,Mabs2,-Mabs3,-Mabs4) 7234 factor=isgnM(1,1,-1,-1)*prexz1234* 7235 * dfloat(isgnprod(Mabs1,Mabs2,-Mabs3,-Mabs4)) 7236 call daxpint(angint(1,1,1,1,iblock),carteZ, 7237 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 7238c 7239 elseif (interxyz(irun).eq.12) then 7240 ityp=mcombina(1,Mabs1,Mabs2,-Mabs3,-Mabs4) 7241 iblock=mcombina(2,Mabs1,Mabs2,-Mabs3,-Mabs4) 7242 factor=-isgnM(-1,-1,1,1)*prexz1234* 7243 * dfloat(isgnprod(-Mabs1,-Mabs2,Mabs3,Mabs4)) 7244 call daxpint(angint(1,1,1,1,iblock),carteZ, 7245 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 7246c 7247 elseif (interxyz(irun).eq.13) then 7248 ityp=mcombina(1,Mabs1,-Mabs2,Mabs3,-Mabs4) 7249 iblock=mcombina(2,Mabs1,-Mabs2,Mabs3,-Mabs4) 7250 factor=isgnM(1,-1,1,-1)*prexz1234* 7251 * dfloat(isgnprod(Mabs1,-Mabs2,Mabs3,-Mabs4)) 7252 call daxpint(angint(1,1,1,1,iblock),carteZ, 7253 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 7254c 7255 elseif (interxyz(irun).eq.14) then 7256 ityp=mcombina(1,Mabs1,-Mabs2,Mabs3,-Mabs4) 7257 iblock=mcombina(2,Mabs1,-Mabs2,Mabs3,-Mabs4) 7258 factor=-isgnM(-1,1,-1,1)*prexz1234* 7259 * dfloat(isgnprod(-Mabs1,Mabs2,-Mabs3,Mabs4)) 7260 call daxpint(angint(1,1,1,1,iblock),carteZ, 7261 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 7262c 7263 elseif (interxyz(irun).eq.15) then 7264 ityp=mcombina(1,Mabs1,-Mabs2,-Mabs3,Mabs4) 7265 iblock=mcombina(2,Mabs1,-Mabs2,-Mabs3,Mabs4) 7266 factor=isgnM(1,-1,-1,1)*prexz1234* 7267 * dfloat(isgnprod(Mabs1,-Mabs2,-Mabs3,Mabs4)) 7268 call daxpint(angint(1,1,1,1,iblock),carteZ, 7269 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 7270c 7271 elseif (interxyz(irun).eq.16) then 7272 ityp=mcombina(1,Mabs1,-Mabs2,-Mabs3,Mabs4) 7273 iblock=mcombina(2,Mabs1,-Mabs2,-Mabs3,Mabs4) 7274 factor=-isgnM(-1,1,1,-1)*prexz1234* 7275 * dfloat(isgnprod(-Mabs1,Mabs2,Mabs3,-Mabs4)) 7276 call daxpint(angint(1,1,1,1,iblock),carteZ, 7277 * factor,ncontl1,ncontl2,ncontl3,ncontl4) 7278c 7279 endif 7280 enddo 7281 if (cleaner) then 7282 do irun4=1,ncontl4 7283 do irun2=1,ncontl2 7284 do irun1=1,ncontl1 7285 cartez(irun1,irun1,irun2,irun4)=0d0 7286 enddo 7287 enddo 7288 enddo 7289 endif 7290 return 7291 end 7292 subroutine trans( 7293cbs makes the transformation for the ich-th index 7294 *coeffs, !(nolds(ith),nnew(ith)) modified contraction coefficients 7295 *idim1, ! first dimension 7296 *idim2, ! second dimension 7297 *ich, ! index to be changed 7298 *nolds1,nolds2,nolds3,nolds4, ! old dimensions 7299 *nnew1,nnew2,nnew3,nnew4, ! new dimensions 7300 *array1, ! array of size (nolds1,nolds2,nolds3,nolds4) 7301 *array2 ! array of size (nnew1,nnew2,nnew3,nnew4) 7302 *) 7303#include "implicit.h" 7304 dimension coeffs(idim1,idim2), 7305 *array1(nolds1,nolds2,nolds3,nolds4), 7306 *array2(nnew1,nnew2,nnew3,nnew4) 7307c write(6,*) 'begin trans ' ,ich 7308c write(6,'(8I5)') nolds1,nolds2,nolds3,nolds4, 7309c *nnew1,nnew2,nnew3,nnew4 7310 do ind4=1,nnew4 7311 do ind3=1,nnew3 7312 do ind2=1,nnew2 7313 do ind1=1,nnew1 7314 array2(ind1,ind2,ind3,ind4)=0d0 7315 enddo 7316 enddo 7317 enddo 7318 enddo 7319 if (ich.eq.1) then 7320 do ind4=1,nnew4 7321 do ind3=1,nnew3 7322 do ind2=1,nnew2 7323 do ind5=1,nnew1 7324 do ind1=1,nolds1 7325 array2(ind5,ind2,ind3,ind4)=array2(ind5,ind2,ind3,ind4)+ 7326 *coeffs(ind1,ind5)*array1(ind1,ind2,ind3,ind4) 7327 enddo 7328 enddo 7329 enddo 7330 enddo 7331 enddo 7332 elseif (ich.eq.2) then 7333c write(6,*) 'transform second index ' 7334 do ind4=1,nnew4 7335 do ind3=1,nnew3 7336 do ind5=1,nnew2 7337 do ind2=1,nolds2 7338 coeff=coeffs(ind2,ind5) 7339 do ind1=1,nnew1 7340 array2(ind1,ind5,ind3,ind4)=array2(ind1,ind5,ind3,ind4)+ 7341 *coeff*array1(ind1,ind2,ind3,ind4) 7342 enddo 7343 enddo 7344 enddo 7345 enddo 7346 enddo 7347c write(6,*) 'end to transform second index ' 7348 elseif (ich.eq.3) then 7349 do ind4=1,nnew4 7350 do ind5=1,nnew3 7351 do ind3=1,nolds3 7352 coeff=coeffs(ind3,ind5) 7353 do ind2=1,nnew2 7354 do ind1=1,nnew1 7355 array2(ind1,ind2,ind5,ind4)=array2(ind1,ind2,ind5,ind4)+ 7356 *coeff*array1(ind1,ind2,ind3,ind4) 7357 enddo 7358 enddo 7359 enddo 7360 enddo 7361 enddo 7362 elseif (ich.eq.4) then 7363 do ind5=1,nnew4 7364 do ind4=1,nolds4 7365 coeff=coeffs(ind4,ind5) 7366 do ind3=1,nnew3 7367 do ind2=1,nnew2 7368 do ind1=1,nnew1 7369 array2(ind1,ind2,ind3,ind5)=array2(ind1,ind2,ind3,ind5)+ 7370 *coeff*array1(ind1,ind2,ind3,ind4) 7371 enddo 7372 enddo 7373 enddo 7374 enddo 7375 enddo 7376 endif 7377c write(6,*) 'end trans ' 7378 return 7379 end 7380 subroutine transcon(contold,idim1,idim2,ovlp,contnew,nprim,ncont) 7381#include "implicit.h" 7382 dimension contold(idim1,idim2),contnew(nprim,ncont), 7383 *ovlp(idim1,idim1) 7384c write(6,*) 'begin transcon nprim,ncont ',nprim,ncont 7385cbs copy old contraction coefficients in dense form to common block 7386 do Jrun=1,ncont 7387 do Irun=1,nprim 7388 contnew(Irun,Jrun)=contold(Irun,Jrun) 7389 enddo 7390 enddo 7391cbs ensure normalization 7392 do ICONT=1,ncont 7393 xnorm=0d0 7394 do Jrun=1,nprim 7395 do Irun=1,nprim 7396 xnorm=xnorm+contnew(Irun,ICONT)*contnew(Jrun,ICONT) 7397 * *ovlp(Irun,Jrun) 7398c write(6,*) 'Icont,jrun,irun,xnorm ', 7399c * icont,jrun,irun,xnorm 7400 enddo 7401 enddo 7402c write(6,*) 'ICONT ',ICONT,xnorm 7403 xnorm=1d0/dsqrt(xnorm) 7404cbs scale with normalization factor 7405 do Irun=1,nprim 7406 contnew(Irun,ICONT)=xnorm*contnew(Irun,ICONT) 7407 enddo 7408 enddo 7409c write(6,*) 'end transcon nprim,ncont ',nprim,ncont 7410 return 7411 end 7412 subroutine two2mean12a(carteSO,carteOO,occup,AOcoeffs,onecart, 7413 *ncontmf,norbsum,noccorb,sameorb) 7414#include "implicit.h" 7415#include "para.h" 7416 logical sameorb 7417 dimension 7418 *carteSO(ncontmf,norbsum,ncontmf,norbsum), 7419 *carteOO(ncontmf,norbsum,ncontmf,norbsum), 7420 *occup(*),AOcoeffs(MxcontL,*),onecart(MxcontL,MxcontL) 7421 if (sameorb) THEN 7422 do icartleft=1,norbsum 7423 do icartright=1,norbsum 7424 coeff=0d0 7425 do Mrun=1,noccorb 7426 coeff=coeff+occup(Mrun)*AOcoeffs(icartleft,Mrun)* 7427 * AOcoeffs(icartright,Mrun) 7428 enddo 7429 coeff=0.5d0*coeff 7430 do irun=1,ncontmf 7431 do jrun=1,ncontmf 7432 onecart(irun,jrun)=onecart(irun,jrun)-coeff* 7433 *carteSO(irun,icartleft,jrun,icartright) 7434 enddo 7435 enddo 7436 enddo 7437 enddo 7438 else 7439 do icartleft=1,norbsum 7440 do icartright=1,norbsum 7441 coeff=0d0 7442 do Mrun=1,noccorb 7443 coeff=coeff+occup(Mrun)*AOcoeffs(icartleft,Mrun)* 7444 * AOcoeffs(icartright,Mrun) 7445 enddo 7446 coeff=0.5d0*coeff 7447 do irun=1,ncontmf 7448 do jrun=1,ncontmf 7449 onecart(irun,jrun)=onecart(irun,jrun)-coeff* 7450 *(carteSO(irun,icartleft,jrun,icartright)+ 7451 *2d0*carteOO(irun,icartleft,jrun,icartright)) 7452 enddo 7453 enddo 7454 enddo 7455 enddo 7456 endif 7457 return 7458 end 7459 7460 subroutine two2mean12b(carteSO,carteOO,occup,AOcoeffs,onecart, 7461 *ncontmf,norbsum,noccorb,sameorb) 7462#include "implicit.h" 7463#include "para.h" 7464 logical sameorb 7465 dimension 7466 *carteSO(ncontmf,norbsum,ncontmf,norbsum), 7467 *carteOO(ncontmf,norbsum,ncontmf,norbsum), 7468 *occup(*),AOcoeffs(MxcontL,*),onecart(MxcontL,MxcontL) 7469 if (sameorb) then 7470 do icartleft=1,norbsum 7471 do icartright=1,norbsum 7472 coeff=0d0 7473 do Mrun=1,noccorb 7474 coeff=coeff+occup(Mrun)*AOcoeffs(icartleft,Mrun)* 7475 * AOcoeffs(icartright,Mrun) 7476 enddo 7477 coeff=0.5d0*coeff 7478 do irun=1,ncontmf 7479 do jrun=1,ncontmf 7480 onecart(irun,jrun)=onecart(irun,jrun)+coeff* 7481 *carteSO(jrun,icartleft,irun,icartright) 7482 enddo 7483 enddo 7484 enddo 7485 enddo 7486 else 7487 do icartleft=1,norbsum 7488 do icartright=1,norbsum 7489 coeff=0d0 7490 do Mrun=1,noccorb 7491 coeff=coeff+occup(Mrun)*AOcoeffs(icartleft,Mrun)* 7492 * AOcoeffs(icartright,Mrun) 7493 enddo 7494 coeff=0.5d0*coeff 7495 do irun=1,ncontmf 7496 do jrun=1,ncontmf 7497 onecart(irun,jrun)=onecart(irun,jrun)+coeff* 7498 *(carteSO(jrun,icartleft,irun,icartright)+ 7499 *2d0*carteOO(jrun,icartleft,irun,icartright)) 7500 enddo 7501 enddo 7502 enddo 7503 enddo 7504 endif 7505 return 7506 end 7507 7508 subroutine two2mean13(carteSO,occup,AOcoeffs,onecart, 7509 *ncontmf,norbsum,noccorb) 7510cbs gives the two first contributions 7511cbs < i M | j M > with Malpha and Mbeta 7512cbs the other orbit parts cancel 7513#include "implicit.h" 7514#include "para.h" 7515 dimension carteSO(ncontmf,ncontmf,norbsum,norbsum), 7516 *occup(*),AOcoeffs(MxcontL,*),onecart(MxcontL,MxcontL) 7517 do icartleft=1,norbsum 7518 do icartright=1,norbsum 7519 coeff=0d0 7520 do Mrun=1,noccorb 7521 coeff=coeff+occup(Mrun)*AOcoeffs(icartleft,Mrun)* 7522 * AOcoeffs(icartright,Mrun) 7523 enddo 7524 do irun=1,ncontmf 7525 do jrun=1,ncontmf 7526 onecart(irun,jrun)=onecart(irun,jrun)+coeff* 7527 *carteSO(irun,jrun,icartleft,icartright) 7528 enddo 7529 enddo 7530 enddo 7531 enddo 7532c write(6,*) 'effective integrals' 7533c do jrun=1,ncontmf 7534c write(6,'(4E21.14)') (onecart(irun,jrun),irun=1,ncontmf) 7535c enddo 7536 return 7537 end 7538 7539 subroutine two2mean34a(carteSO,carteOO,occup,AOcoeffs,onecart, 7540 *ncontmf,norbsum,noccorb,sameorb) 7541#include "implicit.h" 7542#include "para.h" 7543 logical sameorb 7544 dimension 7545 *carteSO(norbsum,ncontmf,norbsum,ncontmf), 7546 *carteOO(norbsum,ncontmf,norbsum,ncontmf), 7547 *occup(*),AOcoeffs(MxcontL,*),onecart(MxcontL,MxcontL) 7548 if (sameorb) then 7549 do icartleft=1,norbsum 7550 do icartright=1,norbsum 7551 coeff=0d0 7552 do Mrun=1,noccorb 7553 coeff=coeff+occup(Mrun)*AOcoeffs(icartleft,Mrun)* 7554 * AOcoeffs(icartright,Mrun) 7555 enddo 7556 coeff=0.5d0*coeff 7557 do irun=1,ncontmf 7558 do jrun=1,ncontmf 7559 onecart(irun,jrun)=onecart(irun,jrun)+coeff* 7560 *carteSO(icartleft,irun,icartright,jrun) 7561 enddo 7562 enddo 7563 enddo 7564 enddo 7565 else 7566 do icartleft=1,norbsum 7567 do icartright=1,norbsum 7568 coeff=0d0 7569 do Mrun=1,noccorb 7570 coeff=coeff+occup(Mrun)*AOcoeffs(icartleft,Mrun)* 7571 * AOcoeffs(icartright,Mrun) 7572 enddo 7573 coeff=0.5d0*coeff 7574 do irun=1,ncontmf 7575 do jrun=1,ncontmf 7576 onecart(irun,jrun)=onecart(irun,jrun)+coeff* 7577 *(carteSO(icartleft,irun,icartright,jrun)+ 7578 *2d0*carteOO(icartleft,irun,icartright,jrun)) 7579 enddo 7580 enddo 7581 enddo 7582 enddo 7583 endif 7584 return 7585 end 7586 7587 subroutine two2mean34b(carteSO,carteOO,occup,AOcoeffs,onecart, 7588 *ncontmf,norbsum,noccorb,sameorb) 7589#include "implicit.h" 7590#include "para.h" 7591 logical sameorb 7592 dimension 7593 *carteSO(norbsum,ncontmf,norbsum,ncontmf), 7594 *carteOO(norbsum,ncontmf,norbsum,ncontmf), 7595 *occup(*),AOcoeffs(MxcontL,*),onecart(MxcontL,MxcontL) 7596 if (sameorb) then 7597 do icartleft=1,norbsum 7598 do icartright=1,norbsum 7599 coeff=0d0 7600 do Mrun=1,noccorb 7601 coeff=coeff+occup(Mrun)*AOcoeffs(icartleft,Mrun)* 7602 * AOcoeffs(icartright,Mrun) 7603 enddo 7604 coeff=0.5D0*coeff 7605 do irun=1,ncontmf 7606 do jrun=1,ncontmf 7607 onecart(irun,jrun)=onecart(irun,jrun)-coeff* 7608 *carteSO(icartleft,jrun,icartright,irun) 7609 enddo 7610 enddo 7611 enddo 7612 enddo 7613 else 7614 do icartleft=1,norbsum 7615 do icartright=1,norbsum 7616 coeff=0d0 7617 do Mrun=1,noccorb 7618 coeff=coeff+occup(Mrun)*AOcoeffs(icartleft,Mrun)* 7619 * AOcoeffs(icartright,Mrun) 7620 enddo 7621 coeff=0.5D0*coeff 7622 do irun=1,ncontmf 7623 do jrun=1,ncontmf 7624 onecart(irun,jrun)=onecart(irun,jrun)-coeff* 7625 *(carteSO(icartleft,jrun,icartright,irun)+ 7626 *2d0*carteOO(icartleft,jrun,icartright,irun)) 7627 enddo 7628 enddo 7629 enddo 7630 enddo 7631 endif 7632 return 7633 end 7634! --- end of amfi/amfi.F --- 7635