1 2 block data feffbd 3 4 implicit double precision (a-h, o-z) 5 6 character*72 header 7 common /header_common/ header 8 9 character*10 shole(0:9) 10 character*8 sout(0:6) 11 common /labels/ shole, sout 12 13 14 character*12 vfeff, vpotph, vpaths, vgenfm, vff2ch 15 common /vers/ vfeff, vpotph, vpaths, vgenfm, vff2ch 16 17c character*12 vfeff, vpotph, vpaths, vgenfm, vff2ch 18c common /vers/ vfeff, vpotph, vpaths, vgenfm, vff2ch 19 20 data shole /'no hole', 'K shell', 21 1 'LI shell', 'LII shell', 22 2 'LIII shell', 'MI shell', 23 3 'MII shell', 'MIII shell', 24 4 'MIV shell', 'MV shell'/ 25 data sout /'H-L exch', 'D-H exch', 'Gd state', 26 1 'DH - HL ', 'DH + HL ', 'HLnoimag', 'Gs HL '/ 27 28c 123456789012 29 data vfeff /' Feff 6.01l'/ 30 data vpotph /' potph 4.12'/ 31 data vpaths /' paths 3.05'/ 32 data vgenfm /' genfmt 1.44'/ 33 data vff2ch /' ff2chi 2.01'/ 34 35c 6.01l EXAFS only lite version 10/02 jjr 36c 5.05a is current working version 37c 5.05j is jjr's version 6/93 38c 6.00 Alexey's polarization and XANES 39c 6.01 Release version of FEFF6 including bug fixes ala and jjr 40c 4.04 Major code reorganization. Muffin tin finder modified -- now 41c uses average of all possible muffin tin radii instead of minimum. 42c 26 March, 1991 Steven Zabinsky 43c 4.05 Yet another improvement to muffin tin finder, now averages 44c based on volume of lense-shaped overlapping region, April, 1991 45c 4.06 Bug fix in sumax, april 1991 46c 4.07 Several minor changes involving non-standard F77 6/6/91, siz 47c 4.08 ION card added 7/24/91, siz 48c 4.08a, bug in header for ION card fixed 9/10/91, siz 49c 4.09, quinn correction added to imhl, interstitial calculation 50c corrected, rmt modified to handle too few neighbors and 51c error msg in phase about hard test in fovrg modified, 52c folp card added 53c POTPH 4.1 Same as feff4.09, but version hacked to work with 54c module potph of feff5, Mar 1992, siz 55c 56c new version common added, siz, Mar 1992 57c feff 5.03, first 'real' release, lots of little changes. 58c 4 criteria added is the big change. siz, April 1992 59c feffx 5.04, intermediate intermittent version of code with 60c background, xsect, xmu, timereversal, lots 61c of input cards, xanes, etc. July 1992, siz 62c e REQUIRE card removed, Oct 92, siz 63c f, and paths 3.04, new crits, 9 points. Oct 92 64c g: major bug in xsect - ixc not passed to xcpot, beginning with 65c 5.04g, it's fixed. 66c h use gs for xsect (hard coded) 67c i fixed init and final state mixup in xsect 68c Feff 5.05, release version with all of the above in it. XANES 69c is turned off in RDINP for the release -- turn it back on 70c there for development. 71c Feff 6 includes polarization (Alexey) and XANES (Steve Z.) 72c Feff 6.01 is the first release version of FEFF6. 73c Feff 6.01l EXAFS only lite version 10/02 jjr 74 75 end 76c code: relativistic atom code (relativistic hartree fock slater) 77c modified desclaux code -- partially translated from the french 78c 79c modified by: r. c. albers (from previously modified code from 80c j. e. muller who in turn got it from the danes) 81c j. j. rehr and s. i. zabinsky for inclusion in feff 82c 83c special features: renormalizes charge density at wigner-seitz 84c radius 85c 86c version 2 (30 september 87): renormalized coulomb potential and 87c renormalized charge density are produced to be used in XAFS 88c calculations by cphase program. j.j. rehr, j. mustre university 89c of washington., a.djaoui university of essex. 90c please acknowledge use. r. c. albers (los alamos national lab) 91c j.j. rehr (university of washington), 92c 93c Subroutine calling hierarchy siz 1/8/90 94c ATOM 95c INDATA 96c GETORB 97c FPOT 98c DIRAC 99c INOUH 100c INTH 101c POTSL 102c SOMM 103c TOTALE 104c SOMM 105c CDSLD 106c SOMM 107c YKDIR 108c RENORM 109c POTSLW 110c 111c Version 1/11/90: Input and output re-organized to work 112c easily with overlapped potential code 113c in FEFF. 114c 115c Version Aug 1990: Minor modification to work more easily with 116c FEFF4, cluster version. SRHO no longer has 117c factor of r**2. INDATA uses rr function to 118c set r grid. 119c Version Dec 1990: Writes to atom.dat restored 120c Version Feb 1991: Unit 16 opened in atom if necessary 121c June 1992 dirac upper and lower components and total energy 122c passed out for use with matrix element calculations 123c 124c Input: title title, max 40 characters 125c ifr index of free atom, used for output labels 126c iz atomic number of atom 127c ihole location of electron hole 128c rws Wigner-Seitz radius 129c ionin ionicity 130c iprint print flag, passed through commom /print/ 131c ispinr 0, do not save dirac spinors, else save for 132c orbital ispinr 133c 134c Output: vcoul(251) coulomb potential (no factor r**2) 135c srho(251) electron density in form 136c 4*pi*density (formerly 4*pi*density*r**2) 137c dgc0(251) large component (set if ispinr.ne.0) 138c dpc0(251) small component (set if ispinr.ne.0) 139c eatom total energy in rydbergs 140c 141c All data is on a grid r(i) = exp (-8.8 + (i-1)*0.05) 142 143 subroutine feff_atom(title,ifr,iz,ihole,rws,ionin,vcoul,srho, 144 1 ispinr, dgc0, dpc0, eatom) 145 146 implicit double precision (a-h,o-z) 147 save 148 149c Save central atom dirac components, see comments below. 150 dimension dgc0(251), dpc0(251) 151 152 character*(*) title 153 dimension vcoul(251) 154 dimension srho(251) 155 common /print/ iprint 156 157 common /atomco/ den(30), dq1(30), dfl(30), ws, nqn(30), nql(30), 158 1 nk(30), nmax(30), nel(30), norb, norbco 159 160 common /dira/ dv(251), dr(251), dp(251), dq(251), dpas, tets, 161 1 z, nstop, nes, np, nuc 162 163 common /ps2/ dexv, dexe, dcop, test, teste, 164 1 testy, testv, niter, ion, icut, iprat, irnorm 165 166 common /deux/ dvn(251), dvf(251), d(251), dc(251), dgc(251,30), 167 1 dpc(251,30) 168 169 character*40 ttl 170 character*2 titre 171 common /char2/ titre(30), ttl 172 173 dimension tden(30) 174 character*30 fname 175 176 data harryd /2./ 177 character*72 header 178 common /header_common/ header 179 180 181 if (iprint .ge. 3) then 182c prepare file for atom output 183 write(fname,14) ifr 184 14 format('atom', i2.2, '.dat') 185 open (unit=16, file=trim(header)//fname, 186 > status='unknown', iostat=ios) 187 call chopen (ios, trim(header)//fname, 'atom') 188c call head (16) 189 write(16,*) ' Free atom ', ifr 190 endif 191 192 ttl = title 193 194 nstop=1 195 mark=0 196 197 call indata (iz, ihole, rws, ionin) 198 iter=1 199 do 30 i=1,np 200 do 30 j=1,norb 201 dgc(i,j)=0.0 202 dpc(i,j)=0.0 203 30 continue 204 205 if (iprint .ge. 3) write(16,40) ttl 206 40 format (1h1,40x,a40) 207 n=-(ion+1) 208 209 60 continue 210 do 70 i=1,np 211 d(i)=0.0 212 70 continue 213 tets=test 214 ymax=0.0 215 vmax=0.0 216 emax=0.0 217 218c resolution of the dirac equation for each orbital 219 do 150 j=1,norb 220 de=den(j) 221 80 call feff_dirac (nqn(j),nql(j),nk(j),imax,den(j), 222 D dfl(j),dq1(j),j) 223 if (nstop.eq.0) go to 110 224 if (nstop.ne.362.or.iter.ge.10.or.tets.gt.test) go to 90 225 tets=testv 226 go to 80 227 90 if (iprint .ge. 3) write(16,100) nstop,nqn(j),titre(j) 228 100 format (' nstop=',i4,' for the orbital',i3,a2) 229 write(77,*) ' Fatal error.' 230 write(77,*) ' Wigner-Seitz or muffin tin radius may be', 231 1 ' too small.' 232 go to 999 233 234 110 val=abs((den(j)-de)/de) 235 if (val.gt.emax) emax=val 236 nmax(j)=imax 237 do 140 i=1,np 238 val=dgc(i,j)-dp(i) 239 if (abs(dp(i)).gt.1.0d0) val=val/dp(i) 240 if (abs(val).lt.abs(ymax)) go to 120 241 ymax=val 242 y=dp(i) 243 yn=dgc(i,j) 244 120 val=dpc(i,j)-dq(i) 245 if (abs(dq(i)).gt.1.0d0) val=val/dq(i) 246 if (abs(val).lt.abs(ymax)) go to 130 247 ymax=val 248 y=dq(i) 249 yn=dpc(i,j) 250 130 dgc(i,j)=dp(i) 251 dpc(i,j)=dq(i) 252 140 d(i)=d(i)+nel(j)*(dp(i)*dp(i)+dq(i)*dq(i)) 253 150 continue 254 255c dgc and dpc are set in loop above, only referenced in remainder 256c of code, so save them into dgc0 and dpc0 here. Note: np=251, 257c set in indata. dgc0 is large component 258c dpc0 is small 259 if (ispinr .ne. 0) then 260 do 152 i = 1, np 261 dgc0(i) = dgc(i,ispinr) 262 dpc0(i) = dpc(i,ispinr) 263 152 continue 264 endif 265 266 if (mark.eq.0) go to 280 267 268c This is case mark .ne. 0 269c d is the core electron density resulting from the renormalized pot. 270 dval=0.0 271 do 160 j=1,norb 272 160 dval=dval+nel(j)*den(j) 273 274 dval=dval*2.0 275c jm-- core charge density commented away in unit 6 appears in unit 3-- 276 if (iprint .ge. 3) write(16,170) dval 277 170 format (1h ,' core energy = ',e15.8) 278 279c jm- renormalized potential 280 281c note conversion to rydbergs using constant harryd 282c passvt is part of old system to pass data directly from 283c ATOM to PHASE 284c do 200 ixx=1,251 285c 200 passvt(ixx)=harryd*dr(ixx)*dr(ixx)*dv(ixx) 286 287 288c d is the core electron density resulting from the renormalized pot. 289 290c next write renormalized electron density for each shell 291 do 270 j=1,norb 292 do 240 i=1,np 293 d(i)=dgc(i,j)*sqrt(12.56637062d0) 294 240 continue 295 270 continue 296 go to 750 297 298c mark .eq. 0 case 299 280 continue 300 301 call potsl (dc,d,dp,dr,dpas,dexv,z,np,ion,icut,dvn) 302 if (nuc.le.0) go to 300 303 do 290 i=1,nuc 304 dc(i)=dc(i)+z/dr(i)+z*((dr(i)/dr(nuc))**2-3.0d0) / 305 1 (dr(nuc)+dr(nuc)) 306 290 continue 307 300 continue 308 do 310 i=1,np 309 dval=abs(dc(i)-dv(i)) 310 if ((dr(i)*dc(i)).le.n) dval=-dval/dc(i) 311 if (dval.le.vmax) go to 310 312 vmax=dval 313 j=i 314 310 continue 315 316c print 320, iter,vmax,dr(j),dv(j),dc(j),emax,ymax,yn,y 317c 320 format (i5,1pe11.2,3(1pe16.6),2(1pe11.2),2(1pe16.6)) 318 319 if (tets.le.test.and.emax.le.teste.and.vmax.le.testv.and.ymax.le 320 1 .testy) go to 430 321 if (mark.eq.1) go to 430 322 iter=iter+1 323 if (iter.le.niter) go to 340 324 if (iprint .ge. 3) write(16,330) niter 325 330 format (' number of iterations greater than',i4) 326 nstop=2 327c print*, ' ATOM-Fatal error, too many iterations.' 328c print*, ' iter, niter ', iter, niter 329 write(77,*) ' ATOM-Fatal error, too many iterations.' 330 write(77,*) ' iter, niter ', iter, niter 331 go to 999 332c potential for the following iteration 333 334 340 continue 335 if (iter.eq.2) go to 350 336 if (iprat) 350,390,350 337 350 dval=1.0-dcop 338 do 360 i=1,np 339 dvn(i)=dv(i) 340 dvf(i)=dc(i) 341 360 dv(i)=dval*dv(i)+dcop*dc(i) 342 go to 60 343 344 390 continue 345 do 400 i=1,np 346 dval=dalp(dvn(i),dvf(i),dv(i),dc(i)) 347 dvn(i)=dv(i) 348 dvf(i)=dc(i) 349 400 dv(i)=dval*dv(i)+(1.0d0-dval)*dc(i) 350 go to 60 351 352 430 if (iprint .ge. 3) write(16,40) ttl 353 if (iprint .ge. 3) write(16,460) 354 460 format (12x,'energie',12x,'(r4)',14x,'(r2)',14x,'(r)',15x,'(r-1)', 355 1 13x,'(r-3)'/) 356 357c valeurs moyennes de r 358 do 470 i=1,np 359 dvf(i)=dc(i) 360 470 dq(i)=0.0 361 dval=0.0 362 do 560 i=1,norb 363 im=nmax(i) 364 dval=dval+nel(i)*den(i) 365 do 480 j=1,im 366 480 dc(j)=dgc(j,i)*dgc(j,i)+dpc(j,i)*dpc(j,i) 367 l=5 368 if (iabs(nk(i)).eq.1) l=l-1 369 do 550 j=1,l 370 dp(j)=dfl(i)+dfl(i) 371 if (j-2) 490,500,510 372 490 n=4 373 go to 550 374 500 n=2 375 go to 550 376 510 if (j-4) 520,530,540 377 520 n=1 378 go to 550 379 530 n=-1 380 go to 550 381 540 n=-3 382 550 call somm (dr,dc,dq,dpas,dp(j),n,im) 383 560 if (iprint .ge. 3) write(16,570) nqn(i),titre(i), 384 1 den(i),(dp(j),j=1,l) 385 570 format (i3,a2,6(1pe18.7)) 386 387 if (dexv.eq.0.0) go to 650 388 389c energie totale en moyenne spherique 390 do 580 i=1,norb 391 580 tden(i)=-2.0d0*den(i) 392 393 dc(1)=1 394 do 600 i=1,np 395 600 dp(i)=d(i)/dr(i) 396 if (nuc.le.0) go to 620 397 do 610 i=1,nuc 398 610 dp(i)=d(i)*(3.0d0-dr(i)*dr(i)/(dr(nuc)*dr(nuc)))/(dr(nuc)+dr(nuc)) 399 dc(1)=4 400 620 call somm (dr,dp,dq,dpas,dc(1),0,np) 401 do 630 i=1,np 402 dp(i)=d(i)*dvf(i) 403 630 d(i)=d(i)*((d(i)*dr(i))**(1.0d0/3.0d0)) 404 dc(2)=3 405 dc(3)=1 406 if (nuc.ne.0) dc(3)=4 407 call somm (dr,dp,dq,dpas,dc(3),0,np) 408 call somm (dr,d,dq,dpas,dc(2),-1,np) 409 dc(2)=-3.0d0*dc(2)/(105.27578d0**(1.0d0/3.0d0)) 410 dc(1)=-z*dc(1) 411 dc(4)=dval-dc(3) 412 dval=dval+(dc(1)-dc(3)+(dexe-dexv)*dc(2))/2.0d0 413 dc(3)=(dc(3)-dc(1)-dexv*dc(2))/2.0d0 414 dc(2)=dc(2)*dexe/2.0d0 415 if (iprint .ge. 3) write(16,640) dval,dc(4),dc(3),dc(2),dc(1) 416 640 format (1h0,5x,'et=',1pe14.7,5x,'ec=',1pe14.7,5x,'ee=',1pe14.7,5x, 417 1 'ex=',1pe14.7,5x,'en=',1pe14.7) 418 go to 660 419 650 call totale (dval) 420 660 continue 421 422c pass out eatom (total energy) (factor of 2 is to put energy in 423c rydberg units) 424 eatom = 2 * dval 425 426 if (norb.eq.1) go to 710 427 if (iprint .ge. 3) write(16,40) ttl 428 if (iprint .ge. 3) write(16,670) 429 670 format (1h0,47x,'overlap integrals '/) 430 431c overlap integrals 432 do 700 i=2,norb 433 k=i-1 434 do 700 j=1,k 435 if (nql(i).ne.nql(j).or.nk(i).ne.nk(j)) go to 700 436 im=nmax(j) 437 if (nmax(i).lt.im) im=nmax(i) 438 do 680 l=1,im 439 dq(l)=dpc(l,i)*dpc(l,j) 440 680 dc(l)=dgc(l,i)*dgc(l,j) 441 dval=dfl(i)+dfl(j) 442 call somm (dr,dc,dq,dpas,dval,0,im) 443 if (iprint .ge. 3) write(16,690) nqn(i),titre(i), 444 1 nqn(j),titre(j),dval 445 690 format (34x,i1,a2,i3,a2,f19.7) 446 700 continue 447 710 call cdsld 448 449 450 if (irnorm.eq.1) then 451 call renorm (dexv, vcoul, srho) 452 endif 453 do 720 i=1,np 454 720 dc(i)=harryd*dv(i)*dr(i)**2 455 if (irnorm.ne.1) stop 0000 456 norb=norbco 457 if (norbco.eq.0) go to 750 458 if (mark.eq.1) go to 750 459 mark=1 460 go to 60 461 462 750 continue 463 464c return srho as 4*pi*density instead of 4*pi*density*r**2 465 do 760 i = 1, 251 466 srho(i) = srho(i) / (dr(i)**2) 467 760 continue 468 469 if (iprint .ge. 3) close(unit=16) 470 471 return 472 473 474 999 continue 475 stop 'ATOM-1' 476 end 477 subroutine besjn (x, jl, nl) 478 479c----------------------------------------------------------------------- 480c 481c purpose: to calculate the spherical bessel functions jl and nl 482c for l = 0 to 30 (no offset) 483c 484c arguments: 485c x = argument of jl and nl 486c jl = jl bessel function (abramowitz conventions) 487c nl = nl bessel function (abramowitz yl conventions) 488c Note that this array nl = abramowitz yl. 489c jl and nl must be dimensioned 490c complex*16 jl(ltot+2), nl(ltot+2), with ltot defined in 491c dim.h. 492c 493c notes: jl and nl should be calculated at least to 10 place 494c accuracy for the range 0<x<100 according to spot 495c checks with tables 496c 497c error messages written with PRINT statement. 498c 499c first coded by r. c. albers on 14 dec 82 500c 501c version 3 502c 503c last modified: 27 jan 83 by r. c. albers 504c dimension of jl,nl changed from 31 to 26 (10 aug 89) j. rehr 505c modified again, siz, June 1992 506c 507c----------------------------------------------------------------------- 508 509 implicit double precision (a-h, o-z) 510 511 parameter (nphx = 7) !max number of unique potentials (potph) 512 parameter (npotx = nphx) !max number of unique potentials (genfmt, paths) 513 parameter (nfrx = nphx) !max number of free atom types 514 parameter (novrx = 8) !max number of overlap shells 515 parameter (natx = 250) !max number of atoms in problem 516 parameter (ltot = 24) !max number of ang mom (arrays 1:ltot+1) 517 parameter (nrptx = 250) !Loucks r grid used through overlap 518 parameter (nex = 100) !Number of energy points genfmt, etc. 519 520 parameter (lamtot=15) !Max number of distinct lambda's for genfmt 521 !15 handles iord 2 and exact ss 522 parameter (mtot=4, ntot=2) !vary mmax and nmax independently 523 parameter (legtot=9) !matches path finder, used in GENFMT 524 parameter (npatx = 8) !max number of path atoms, used in path 525 !finder, NOT in genfmt 526 527 528 complex*16 x 529 complex*16 jl(ltot+2), nl(ltot+2) 530 complex*16 cjl(ltot+2), sjl(ltot+2), cnl(ltot+2), snl(ltot+2) 531 532 complex*16 xjl,xnl,asx,acx 533 complex*16 xi,xi2,xi3,xi4,xi5,xi6,xi7,xi8,xi9,xi10,xi11 534 535 parameter (xcut = 1.0d0, xcut1 = 7.51d0, xcut2 = 5.01d0) 536 537 if (dble(x) .le. 0) stop 'Re(x) is .le. zero in besjn' 538 539 lmaxp1 = ltot+2 540 541 if (dble(x) .lt. xcut) then 542c case Re(x) < 1, just use series expansion 543 do 10 il = 1,lmaxp1 544 l = il-1 545 ifl = 0 546 call bjnser (x,l,xjl,xnl,ifl) 547 jl(il) = xjl 548 nl(il) = xnl 549 10 continue 550 551 elseif (dble(x) .lt. xcut1) then 552 553c case 1 <= Re(x) < 7.5 554 555 call bjnser (x,lmaxp1-1,xjl,xnl,1) 556 jl(lmaxp1) = xjl 557 558 call bjnser (x,lmaxp1-2,xjl,xnl,1) 559 jl(lmaxp1-1) = xjl 560 561 if (dble(x) .lt. xcut2) then 562c Re(x) < 5 563 call bjnser (x,0,xjl,xnl,2) 564 nl(1) = xnl 565 call bjnser (x,1,xjl,xnl,2) 566 nl(2) = xnl 567 else 568c Re(x) >= 5 569 asx = sin(x) 570 acx = cos(x) 571 xi = 1.0d0 / x 572 xi2 = xi**2 573 nl(1) = -acx*xi 574 nl(2) = -acx*xi2 - asx*xi 575 endif 576 577c Use recursion relation 10.1.19 to get nl and jl 578 do 50 lp1 = 3, lmaxp1 579 l = lp1 - 2 580 tlxp1 = 2*l + 1 581 nl(lp1) = tlxp1 * nl(lp1-1) / x - nl(lp1-2) 582 50 continue 583 584 do 60 lx = 3,lmaxp1 585 lp1 = lmaxp1+1-lx 586 l = lp1-1 587 tlxp3 = 2*l + 3 588 jl(lp1) = tlxp3 * jl(lp1+1) / x - jl(lp1+2) 589 60 continue 590 591 else 592c case Re(x) > 7.5 593c Use AS 10.1.8 and 10.1.9, sjl=P, qjl=Q, note that AS formulae 594c use cos (z - n*pi/2), etc., so cos and sin terms get a bit 595c scrambled (mod 4) here, since n is integer. These are hard- 596c coded into the terms below. 597 xi = 1.0d0 / x 598 xi2 = xi*xi 599 xi3 = xi*xi2 600 xi4 = xi*xi3 601 xi5 = xi*xi4 602 xi6 = xi*xi5 603 xi7 = xi*xi6 604 xi8 = xi*xi7 605 xi9 = xi*xi8 606 xi10 = xi*xi9 607 xi11 = xi*xi10 608 609 sjl(1) = xi 610 sjl(2) = xi2 611 sjl(3) = 3.0d0*xi3 - xi 612 sjl(4) = 15.0d0*xi4 - 6.0d0*xi2 613 sjl(5) = 105.0d0*xi5 - 45.0d0*xi3 + xi 614 sjl(6) = 945.0d0*xi6 - 420.0d0*xi4 + 15.0d0*xi2 615 sjl(7) = 10395.0d0*xi7 - 4725.0d0*xi5 + 210.0d0*xi3 - xi 616 sjl(8) = 135135.0d0*xi8 - 62370.0d0*xi6 + 3150.0d0*xi4 617 > - 28.0d0*xi2 618 sjl(9) = 2027025.0d0*xi9 - 945945.0d0*xi7 + 51975.0d0*xi5 619 1 - 630.0d0*xi3 + xi 620 sjl(10) = 34459425.0d0*xi10 - 16216200.0d0*xi8 +945945.0d0*xi6 621 1 - 13860.0d0*xi4 + 45.0d0*xi2 622 sjl(11) = 654729075.0d0*xi11 - 310134825.0d0*xi9 623 > + 18918900.0d0*xi7 624 1 - 315315.0d0*xi5 + 1485.0d0*xi3 - xi 625 cjl(1) = 0.0d0 626 cjl(2) = -xi 627 cjl(3) = -3.0d0*xi2 628 cjl(4) = -15.0d0*xi3 + xi 629 cjl(5) = -105.0d0*xi4 + 10.0d0*xi2 630 cjl(6) = -945.0d0*xi5 + 105.0d0*xi3 - xi 631 cjl(7) = -10395.0d0*xi6 + 1260.0d0*xi4 - 21.0d0*xi2 632 cjl(8) = -135135.0d0*xi7 + 17325.0d0*xi5 - 378.0d0*xi3 + xi 633 cjl(9) = -2027025.0d0*xi8 + 270270.0d0*xi6 - 6930.0d0*xi4 634 > + 36.0d0*xi2 635 cjl(10) = -34459425.0d0*xi9 + 4729725.0d0*xi7 - 135135.0d0*xi5 636 1 + 990.0d0*xi3 - xi 637 cjl(11) = -654729075.0d0*xi10 + 91891800.0d0*xi8 638 > - 2837835.0d0*xi6 639 1 + 25740.0d0*xi4 - 55.0d0*xi2 640 do 80 ie = 1,11 641 snl(ie) = cjl(ie) 642 cnl(ie) = -sjl(ie) 643 80 continue 644 do 90 lp1 = 12,lmaxp1 645 l = lp1-2 646 tlxp1 = dble(2*l+1) 647 sjl(lp1) = tlxp1*xi*sjl(lp1-1)-sjl(lp1-2) 648 cjl(lp1) = tlxp1*xi*cjl(lp1-1)-cjl(lp1-2) 649 snl(lp1) = tlxp1*xi*snl(lp1-1)-snl(lp1-2) 650 cnl(lp1) = tlxp1*xi*cnl(lp1-1)-cnl(lp1-2) 651 90 continue 652 asx = sin(x) 653 acx = cos(x) 654 do 110 lp1 = 1,lmaxp1 655 jl(lp1) = asx*sjl(lp1)+acx*cjl(lp1) 656 nl(lp1) = asx*snl(lp1)+acx*cnl(lp1) 657 110 continue 658 endif 659 660 return 661 end 662 subroutine bjnser (x, l, jl, nl, ifl) 663 664c----------------------------------------------------------------------- 665c 666c subroutine: bjnser (x,l,jl,nl,ifl) 667c 668c purpose: to calculate the spherical bessel functions jl and nl 669c 670c arguments: 671c x = argument of jl and nl 672c l = l value calculated (no offset) 673c jl = jl bessel function (abramowitz conventions) 674c nl = nl bessel function (abramowitz yl conventions) 675c ifl = 0 return both jl and nl 676c 1 return jl only 677c 2 return nl only 678c 679c notes: jl and nl are calculated by a series 680c expansion according to 10.1.2 and 10.1.3 681c in abramowitz and stegun (ninth printing), 682c page 437 683c 684c error msgs written with PRINT statements. 685c 686c first coded by r. c. albers on 26 jan 83 687c 688c version 2 689c 690c last modified: 27 jan 83 by r. c. albers 691c 692c----------------------------------------------------------------------- 693 694 implicit double precision (a-h,o-z) 695 696 complex*16 x,u,ux,del,pj,pn 697 complex*16 jl,nl 698 699 parameter (niter = 20, tol = 1.d-15) 700 701 if (l .lt. 0) then 702 write(77,*) 'l .lt. 0 in bjnser' 703 stop 'bjnser 1' 704 endif 705 20 if (dble(x).lt. 0.0d0) then 706 write(77,30) x 707 30 format (/, ' x = ', 1p, 2e14.6, ' is .le. 0 in bjnser') 708 stop 'bjnser 2' 709 endif 710 711 lp1 = l+1 712 u = x**2 / 2.0d0 713 714c make djl = 1 * 3 * 5 * ... * (2*l+1), 715c dnl = 1 * 3 * 5 * ... * (2*l-1) 716 djl = 1 717 fac = -1 718 do 50 il = 1, lp1 719 fac = fac + 2 720 djl = fac * djl 721 50 continue 722 dnl = djl / (2*l+1) 723 724 725 if (ifl .eq. 2) goto 90 726c make jl 727c pj is term in { } in 10.1.2, del is last factor in the series 728c convergence test is (last factor)/(total term) <= tol 729 pj = 1 730 nf = 1 731 nfac = 2*l + 3 732 den = nfac 733 sgn = -1 734 ux = u 735 do 60 il = 1, niter 736 del = sgn*ux / den 737 pj = pj + del 738 trel = abs (del / pj) 739 if (trel .le. tol) goto 80 740 sgn = -sgn 741 ux = u*ux 742 nf = nf+1 743 nfac = nfac+2 744 den = nf * nfac * den 745 60 continue 746 stop 'jl does not converge in bjnser' 747 80 jl = pj * (x**l) / djl 748 749 90 if (ifl.eq.1) return 750c make nl 751c pn is term in { } in 10.1.3, del is last factor in the series 752c convergence test is (last factor)/(total term) <= tol 753 pn = 1 754 nf = 1 755 nfac = 1 - 2*l 756 den = nfac 757 sgn = -1 758 ux = u 759 do 100 il = 1, niter 760 del = sgn * ux / den 761 pn = pn + del 762 trel = abs (del / pn) 763 if (trel .le. tol) goto 120 764 sgn = -sgn 765 ux = u*ux 766 nf = nf+1 767 nfac = nfac+2 768 den = nf * nfac * den 769 100 continue 770 stop 'nl does not converge in bjnser' 771 120 nl = -pn * dnl / (x**lp1) 772 773 return 774 end 775 subroutine ccrit(npat, ipat, ckspc, 776 1 fbetac, rmax, pcrith, pcritk, nncrit, ipotnn, ipot, 777 2 rpath, lheap, lkeep, xcalcx) 778 implicit double precision (a-h, o-z) 779 780c lheap to add to heap, lkeep if keep path at output. 781c NB, if lheap is false, lkeep is not used (since path 782c won't be in the heap). 783 784 785 parameter (pi = 3.1415926535897932384626433d0) 786 parameter (one = 1, zero = 0) 787 parameter (third = 1.0d0/3.0d0) 788 parameter (raddeg = 180.0d0 / pi) 789 complex*16 coni 790 parameter (coni = (0.0d0,1.0d0)) 791c kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37 792 parameter (fa = 1.919158292677512811d0) 793 794 parameter (bohr = 0.529177249d0, ryd = 13.605698d0) 795 parameter (alpinv = 137.03598956d0) 796c fine structure alpha 797 parameter (alphfs = 1.0d0 / alpinv) 798c speed of light in louck's units (rydbergs?) 799 parameter (clight = 2 * alpinv) 800 801 802 parameter (nphx = 7) !max number of unique potentials (potph) 803 parameter (npotx = nphx) !max number of unique potentials (genfmt, paths) 804 parameter (nfrx = nphx) !max number of free atom types 805 parameter (novrx = 8) !max number of overlap shells 806 parameter (natx = 250) !max number of atoms in problem 807 parameter (ltot = 24) !max number of ang mom (arrays 1:ltot+1) 808 parameter (nrptx = 250) !Loucks r grid used through overlap 809 parameter (nex = 100) !Number of energy points genfmt, etc. 810 811 parameter (lamtot=15) !Max number of distinct lambda's for genfmt 812 !15 handles iord 2 and exact ss 813 parameter (mtot=4, ntot=2) !vary mmax and nmax independently 814 parameter (legtot=9) !matches path finder, used in GENFMT 815 parameter (npatx = 8) !max number of path atoms, used in path 816 !finder, NOT in genfmt 817 818 logical lheap, lkeep 819 dimension ipat(npatx) 820 dimension ipot(0:natx) 821 parameter (necrit=9, nbeta=40) 822 dimension fbetac(-nbeta:nbeta,0:npotx,necrit), ckspc(necrit) 823 824c local variables 825 dimension ri(npatx+1), beta(npatx+1), indbet(npatx+1) 826 827c mrb is efficient way to get only ri and beta 828c note that beta is cos(beta) 829 call mrb (npat, ipat, ri, beta) 830 831 rpath = 0.0d0 832 do 300 i = 1, npat+1 833 rpath = rpath + ri(i) 834 300 continue 835 836c If we can decide only on rpath, do it here... 837 if (rpath .gt. rmax) then 838 lheap = .false. 839 lkeep = .false. 840 return 841 endif 842 843c If last atom central atom, do put in heap, don't use it 844c as an actual path at output 845 if (ipat(npat).eq.0) then 846 lheap = .true. 847 lkeep = .false. 848 return 849 endif 850 851c Make index into fbetac array (this is nearest cos(beta) grid 852c point, code is a bit cute [sorry!], see prcrit for grid). 853 do 290 i = 1, npat+1 854 tmp = abs(beta(i)) 855 n = tmp / 0.025d0 856 del = tmp - n*0.025d0 857 if (del .gt. 0.0125d0) n = n+1 858 if (beta(i) .lt. 0.0d0) n = -n 859 indbet(i) = n 860 290 continue 861 862c Decide if we want the path added to the heap if necessary. 863c (Not necessary if no pcrith in use.) 864 if (pcrith .gt. 0) then 865 866 call mcrith(npat, ipat, ri, indbet, 867 1 ipot, nncrit, fbetac, ckspc, xheap) 868 869c xheap = -1 if not defined for this path (too few legs, etc.) 870 if (xheap .ge. 0 .and. xheap .lt. pcrith) then 871c Do not want path in heap 872 lheap = .false. 873 lkeep = .false. 874 return 875 endif 876 endif 877c Keep this path in the heap 878 lheap = .true. 879 880c We may want path in heap so that other paths built from this 881c path will be considered, but do not want this path to be 882c written out for itself. Decide that now and save the flag 883c in the heap, so we won't have to re-calculate the mpprm 884c path parameters later. 885 886c Skip calc if pcritk < 0 887 if (pcritk .le. 0) then 888 lkeep = .true. 889 return 890 endif 891 892c Make xout, output inportance factor. 893 call mcritk (npat, ipat, ri, beta, indbet, 894 1 ipot, nncrit, fbetac, ckspc, xout, xcalcx) 895 896c See if path wanted for output 897c Do not want it if last atom is central atom (xout = -1) or 898c if xout is too small 899 lkeep = .false. 900 if (xout .ge. pcritk) lkeep = .true. 901 902 return 903 end 904 subroutine cdsld 905 906 implicit double precision (a-h,o-z) 907 save 908 common /print/ iprint 909 common /atomco/ den(30), dq1(30), dfl(30), ws, nqn(30), nql(30), 910 1 nk(30), nmax(30), nel(30), norb, norbco 911 912 common /dira/ dv(251), dr(251), dp(251), dq(251), dpas, tets, 913 1 z, nstop, nes, np, nuc 914 common /deux/ dvn(251), dvf(251), d(251), dc(251), dgc(251,30), 915 1 dpc(251,30) 916 917c titre = identification of the wave functions s,p*,p,........ 918 character*40 ttl 919 character*2 titre 920 common /char2/ titre(30), ttl 921 922c -- This read commented out to make input easier, not used for 923c PHASE calculations 924 irm = 0 925 ins = 0 926 npun = 0 927 nmfg = 0 928 nmrk = 0 929c read (5,10) irm,ins,npun,nmfg,nmrk 930 10 format (8i3) 931 932c valeurs moyennes de r**j if irm non-zero 933c tabulation of the wave functions if ins non-zero 934c the potential multiplied by r is perfore if npun non-zero 935 if (irm.eq.0) go to 200 936 if (iprint .ge. 5) write(16,20) ttl 937 20 format (1h1,40x,a40,/) 938 30 read (5,10) j,l,n1,l1,j1,n2,l2,j2 939 if (l.eq.0) go to 200 940 941c valeur moyenne of (p1*p2+q1*q2)*r**j if l positive 942c valeur moyenne of (p1*q2+p2*q1)*r**j if l negative 943 if (n1.gt.0) go to 40 944 if (((n1+1)*(n1+2)).ne.0) go to 60 945 i1=1 946 i2=1 947 go to 80 948 40 i1=0 949 i2=0 950 do 50 i=1,norb 951 if (nqn(i).eq.n1.and.nql(i).eq.l1.and.(j1-1).eq.(-nk(i)/iabs(nk(i) 952 1 ))) i1=i 953 if (nqn(i).eq.n2.and.nql(i).eq.l2.and.(j2-1).eq.(-nk(i)/iabs(nk(i) 954 1 ))) i2=i 955 50 continue 956 if (i1.ne.0.and.i2.ne.0) go to 80 957 60 if (iprint .ge. 5) write(16,70) j,l,n1,l1,j1,n2,l2,j2 958 70 format (1h0,' error for the card ',8i3) 959 go to 30 960 80 dval=dfl(i1)+dfl(i2) 961 if ((dval+j).gt.-1.0) go to 90 962 if (n1) 170,170,60 963 90 im=nmax(i1) 964 if (nmax(i2).lt.im) im=nmax(i2) 965 if (l.lt.0) go to 110 966 do 100 i=1,im 967 dv(i)=dgc(i,i1)*dgc(i,i2) 968 100 dq(i)=dpc(i,i1)*dpc(i,i2) 969 go to 130 970 110 do 120 i=1,im 971 dv(i)=dgc(i,i1)*dpc(i,i2) 972 120 dq(i)=dgc(i,i2)*dpc(i,i1) 973 130 call somm (dr,dv,dq,dpas,dval,j,im) 974 if (l.lt.0) go to 150 975 if (iprint .ge. 5) write(16,140) j,nqn(i1),titre(i1),nqn(i2), 976 1 titre(i2),dval 977 140 format (24x,'(p1p2+q1q2)r**',i2,' for ',i1,a2,i3,a2,5x,'=',1pe14. 978 1 7,/) 979 go to 170 980 150 if (iprint .ge. 5) write(16,160) j,nqn(i1),titre(i1),nqn(i2), 981 1 titre(i2),dval 982 160 format (24x,'(p1q2+q1p2)r**',i2,' for ',i1,a2,i3,a2,5x,'=',1pe14. 983 1 7,/) 984 170 if (n1+1) 190,180,30 985 180 i1=i1+1 986 i2=i1 987 if (i1-norb) 80,80,30 988 190 i2=i2+1 989 if (i2-norb) 80,80,180 990 200 if (ins.eq.0) go to 260 991 do 250 i=1,norb,3 992 j=i+2 993 if (j.gt.norb) j=norb 994 im=0 995 do 210 l=i,j 996 if (nmax(l).gt.im) im=nmax(l) 997 210 continue 998 do 230 k=1,im 999 if (((k-1)*(k-48*(k/48))).ne.0) go to 230 1000 if (iprint .ge. 5) write(16,20) ttl 1001 if (iprint .ge. 5) write(16,220) (nqn(l),titre(l),nqn(l), 1002 1 titre(l),l=i,j) 1003 220 format (9x,'r',14x,3(i1,a2,'g.c.',i11,a2,'p.c.',10x)) 1004 230 if (iprint .ge. 5) write(16,240) dr(k), 1005 1 (dgc(k,l),dpc(k,l),l=i,j) 1006 240 format (7(1pe17.7)) 1007 250 continue 1008 260 if (npun.eq.0) go to 300 1009 do 270 i=1,np 1010 270 dp(i)=dvf(i)*dr(i) 1011c write(8,280) ttl 1012 280 format (a40) 1013c write(8,290) (dp(i),i=1,np) 1014 290 format (8f9.4) 1015 300 do 310 i=1,np 1016 310 d(i)=0.0 1017 nag=1 1018 if (nmfg.eq.0) go to 470 1019 if (iprint .ge. 5) write(16,20) 1020 if (iprint .ge. 5) write(16,320) 1021 320 format (/,30x,'integrales magnetiques directes et d echange'//) 1022 330 read (5,10) i1,i2,n1 1023 if (i1.le.0) go to 470 1024 if (i2.gt.0) go to 350 1025 if (((i2+1)*(i2+2)).ne.0) go to 340 1026 if (n1.le.0) n1=1 1027 i1=n1 1028 n1=i2 1029 i2=i1 1030 go to 360 1031 340 if (iprint .ge. 5) write(16,70) i1,i2,n1 1032 go to 330 1033 350 if (i1.gt.norb.or.i2.gt.norb) go to 340 1034 n1=1 1035 360 j1=2*iabs(nk(i1))-1 1036 j2=2*iabs(nk(i2))-1 1037 kma=min0(j1,j2) 1038 nm=nmax(i2) 1039 do 380 j=1,kma,2 1040 call ykdir (i1,i1,j,nag) 1041 do 370 i=1,nm 1042 370 dp(i)=dq(i)*dgc(i,i2)*dpc(i,i2) 1043 dval=j+1 1044 call somm (dr,d,dp,dpas,dval,-1,nm) 1045 380 if (iprint .ge. 5) write(16,390) j,nqn(i1),titre(i1),nqn(i2), 1046 1 titre(i2),dval 1047 390 format (20x,'fm',i2,' (',i1,a2,',',i1,a2,') =',1pe14.7) 1048 if (i1.eq.i2) go to 440 1049 j1=(iabs(1-2*nk(i1))-1)/2 1050 j2=(iabs(1-2*nk(i2))-1)/2 1051 kma=max0(nql(i1)+j2,nql(i2)+j1) 1052 j1=iabs(nql(i2)-j1) 1053 j2=iabs(nql(i1)-j2) 1054 kmi=min0(j1,j2) 1055 j1=kmi+nql(i1)+nql(i2) 1056 j1=j1-2*(j1/2) 1057 if (j1.eq.0) kmi=kmi+1 1058 nm=min0(nmax(i1),nmax(i2)) 1059 do 420 j=kmi,kma,2 1060 call ykdir (i1,i2,j,nag) 1061 do 400 i=1,nm 1062 dp(i)=dq(i)*dgc(i,i1)*dpc(i,i2) 1063 400 dc(i)=dq(i)*dgc(i,i2)*dpc(i,i1) 1064 dval=j+1 1065 dvalp=dval 1066 dvalm=dval 1067 call somm (dr,d,dp,dpas,dvalp,-1,nm) 1068 call somm (dr,d,dc,dpas,dval,-1,nm) 1069 call ykdir (i2,i1,j,nag) 1070 do 410 i=1,nm 1071 410 dp(i)=dq(i)*dgc(i,i2)*dpc(i,i1) 1072 call somm (dr,d,dp,dpas,dvalm,-1,nm) 1073 420 if (iprint .ge. 5) write(16,430) j,nqn(i1),titre(i1),nqn(i2), 1074 1 titre(i2),dvalm,dval,dvalp 1075 430 format (' gm',i2,' (',i1,a2,',',i1,a2,')',5x,'(-1)=',1pe14.7,5x,'( 1076 10)=',1pe14.7,5x,'(+1)=',1pe14.7) 1077 440 if (n1+1) 460,450,330 1078 450 i1=i1+1 1079 i2=i1 1080 if (i1-norb) 360,360,330 1081 460 i2=i2+1 1082 if (i2-norb) 360,360,450 1083 470 if (nmrk.eq.0) go to 530 1084 if (iprint .ge. 5) write(16,20) 1085 if (iprint .ge. 5) write(16,480) 1086 480 format (/,20x,'integrales magnetiques rk=integrale de p1(1)*q2(1)* 1087 1uk(1,2)*p3(2)*q4(2)'//) 1088 490 read (5,10) i1,i2,i3,i4,k 1089 if (i1.le.0) go to 530 1090 if (i1.le.norb.and.i2.gt.0.and.i2.le.norb.and.i3.gt.0.and.i3.le 1091 1 .norb.and.i4.gt.0.and.i4.le.norb.and.k.ge.0) go to 500 1092 if (iprint .ge. 5) write(16,70) i1,i2,i3,i4,k 1093 go to 490 1094 500 call ykdir (i1,i2,k,nag) 1095 do 510 i=1,np 1096 510 dp(i)=dq(i)*dgc(i,i3)*dpc(i,i4) 1097 dval=k+1 1098 call somm (dr,d,dp,dpas,dval,-1,np) 1099 if (iprint .ge. 5) write(16,520) k,nqn(i1),titre(i1),nqn(i2), 1100 1 titre(i2),nqn(i3),titre(i3),nqn(i4),titre(i4),dval 1101 520 format (20x,'rm',i2,' (',i1,a2,',',i1,a2,',',i1,a2,',',i1,a2,') =' 1102 1 ,1pe14.7) 1103 go to 490 1104 530 return 1105 end 1106 subroutine chopen (ios, fname, mod) 1107 implicit double precision (a-h, o-z) 1108c Writes error msg and stops if error in ios flag from open 1109c statement. fname is filename, mod is module with failed open. 1110 character*(*) fname, mod 1111 1112c open successful 1113 if (ios .le. 0) return 1114 1115c error opening file, tell user and die. 1116 write(77,100) fname, mod 1117 1118 100 format (' ERROR opening file, ', /, 1119 1 ' filename: ', a, /, 1120 2 ' in module: ', a) 1121 1122 write(77,*) 'Fatal error' 1123 stop 'CHOPEN' 1124 end 1125 subroutine cpl0 (x, pl0, lmaxp1) 1126 implicit double precision (a-h, o-z) 1127 1128c----------------------------------------------------------------------- 1129c 1130c cpl0: Calculate associated legendre polynomials p_l0(x) 1131c by recursion. 1132c Adapted from aslgndr. 1133c 1134c first written: (25 june 86) by j. j. rehr 1135c 1136c version 1 (25 june 86) (aslgndr) 1137c version 2 (March, 1992) siz 1138c 1139c----------------------------------------------------------------------- 1140 1141 dimension pl0 (lmaxp1) 1142 1143 lmax = lmaxp1-1 1144 1145c calculate legendre polynomials p_l0(x) up to l=lmax 1146 pl0(1) = 1.0d0 1147 pl0(2) = x 1148 do 10 il = 2, lmax 1149 l = il-1 1150 pl0(il+1) = ( (2*l+1)*x*pl0(il) - l*pl0(l) ) / il 1151 10 continue 1152 1153 return 1154 end 1155c Copyright Notice: FEFF6 is copyright protected software and users must 1156c obtain a license from the University of Washington Office of 1157c Technology Transfer for its use; see section V of FEFF document. 1158 1159c Main Authors of FEFF5: please contact us concerning problems. 1160c A. L. Ankudinov, alex@phys.washington.edu (206) 543 0435 1161c S. I. Zabinsky, zabinsky@phys.washington.edu (206) 543 0435 1162c J. J. Rehr, jjr@phys.washington.edu (206) 543 8593 1163c R. C. Albers, rca@nidhug.lanl.gov (505) 665 0417 1164 1165c Citations: Please cite at least one of the following articles if 1166c FEFF is used in published work: 1167c 1) Multiple scattering 1168c J.J. Rehr and R.C. Albers, Phys. Rev. B41, 8139 (1990). 1169c J.J. Rehr, S.I. Zabinsky and R.C. Albers, 1170c Phys. Rev. Let. 69, 3397 (1992). 1171c 2) General reference 1172c J.J. Rehr, J. Mustre de Leon, S.I. Zabinsky, and R.C. Albers, 1173c J. Am. Chem. Soc. 113, 5135 (1991). 1174c 3) Technical reference 1175c J. Mustre de Leon, J.J. Rehr, S.I. Zabinsky, and R.C. Albers, 1176c Phys. Rev. B44, 4146 (1991). 1177 1178 1179 subroutine csomm (dr,dp,dq,dpas,da,m,np) 1180c Modified to use complex p and q. SIZ 4/91 1181c integration by the method of simpson of (dp+dq)*dr**m from 1182c 0 to r=dr(np) 1183c dpas=exponential step; 1184c for r in the neighborhood of zero (dp+dq)=cte*r**da 1185c ********************************************************************** 1186 implicit double precision (a-h,o-z) 1187 dimension dr(*) 1188 complex*16 dp(*),dq(*),da,dc 1189 mm=m+1 1190 d1=da+mm 1191 da=0.0d0 1192 db=0.0d0 1193 do 70 i=1,np 1194 dl=dr(i)**mm 1195 if (i.eq.1.or.i.eq.np) go to 10 1196 dl=dl+dl 1197 if ((i-2*(i/2)).eq.0) dl=dl+dl 1198 10 dc=dp(i)*dl 1199 da=da+dc 1200 dc=dq(i)*dl 1201 da=da+dc 1202 70 continue 1203 da=dpas*da/3.0d0 1204 dd=exp(dpas)-1.0d0 1205 db=d1*(d1+1.0d0)*dd*exp((d1-1.0d0)*dpas) 1206 db=dr(1)*(dr(2)**m)/db 1207 dd=(dr(1)**mm)*(1.0d0+1.0d0/(dd*(d1+1.0d0)))/d1 1208 da=da+dd*(dp(1)+dq(1))-db*(dp(2)+dq(2)) 1209 return 1210 end 1211 subroutine cubic (xk0, wp, alph, rad, qplus, qminus) 1212 1213c input: xk0, wp, alph 1214c output: rad, qplus, qminus 1215 1216 implicit double precision (a-h, o-z) 1217 complex*16 s1,s13 1218 parameter (three = 3.0d0) 1219 parameter (third = 1.0d0/three) 1220 1221c this subroutine finds the roots of the equation 1222c 4xk0 * q^3 + (alph-4xk0^2) * q^2 + wp^2 = 0 1223c see abramowitz and stegun pg 17 for formulae. 1224 1225 a2 = (alph / (4.0d0*xk0**2) - 1.0d0) * xk0 1226 a0 = wp**2 / (4.0d0*xk0) 1227 a1 = 0.0d0 1228 q = a1/3.0d0 - a2**2/9.0d0 1229 r = (a1*a2 - 3.0d0*a0)/6.0d0 - a2**3/27.0d0 1230 rad = q**3 + r**2 1231 if (rad .gt. 0.0d0) then 1232 qplus = 0.0d0 1233 qminus = 0.0d0 1234 return 1235 endif 1236 1237 s13 = dcmplx (r, sqrt(-rad)) 1238 s1 = s13 ** third 1239 qz1 = 2.0d0*s1 - a2/3.0d0 1240 qz2 = -(s1 + sqrt(three)*dimag(s1) + a2/3.0d0) 1241 qz3 = -(s1 - sqrt(three)*dimag(s1) + a2/3.0d0) 1242 qplus = qz1 1243 qminus = qz3 1244 1245 return 1246 end 1247 double precision function dalp (d1,d2,d3,d4) 1248 implicit double precision (a-h,o-z) 1249 save 1250c 1251c procedure of pratt to accelerate the convergence 1252c d1=initial (n-1); d2=final (n-1); d3=initial (n); d4=final (n); 1253c ********************************************************************** 1254 if ((d1+d4).eq.(d2+d3)) go to 10 1255 d=(d4-d2)/((d1+d4)-(d2+d3)) 1256 if (d.lt.0.0d0) go to 20 1257 if (d.lt.0.5d0) go to 30 1258 10 d=0.5d0 1259 go to 30 1260 20 d=0.0d0 1261 30 dalp=d 1262 return 1263 end 1264 subroutine feff_diff(v, dx, n, vm) 1265 implicit double precision (a-h,o-z) 1266 complex*16 v(n), vm(n) 1267 vm(1)=((6.0d0*v(2)+6.66666666667d0*v(4)+1.2d0*v(6))-(2.45d0*v(1) 1268 > +7.0d0 1269 1 5*v(3)+3.75d0*v(5)+.166666666667d0*v(7)))/dx 1270 vm(2)=((6.0d0*v(3)+6.66666666667d0*v(5)+1.2d0*v(7))-(2.45d0*v(2) 1271 > +7.0d0 1272 1 5*v(4)+3.75d0*v(6)+.166666666667d0*v(8)))/dx 1273 nm2=n-2 1274 do 10 i=3,nm2 1275 10 vm(i)=((v(i-2)+8.0d0*v(i+1))-(8.0d0*v(i-1)+v(i+2)))/12.0d0/dx 1276 vm(n-1)=(v(n)-v(n-2))/(2.0d0*dx) 1277 vm(n)=(v(n-2)*0.5d0-2.0d0*v(n-1)+1.5d0*v(n))/dx 1278 return 1279 end 1280 subroutine feff_dirac (nqn,nql,nk,imax,de,dfl,dq1,jc) 1281c 1282c solution of the dirac equation 1283c nqn=principal quantum number; nql=orbital quantum number 1284c nk=kappa quantum number; imax=the last tabulated point of the 1285c wave function; de=energy; dfl=power of the first term of the 1286c developpement limite; dq1=slope at the origin of dp or dq 1287c ********************************************************************** 1288 implicit double precision (a-h,o-z) 1289 save 1290 common /dira/ dv(251), dr(251), dp(251), dq(251), dpas, test, 1291 1 z, nstop, nes, np, nuc 1292c 1293c dv=potential in a.u. and negative; dr=radial mesh 1294c dp=large component; dq=small component; dpas=exponential step; 1295c nes=number of attempts to adjust the energy 1296c z=atomic number; nstop controls the numeric integration 1297c test=precision obtained in the energies; np=maximum number of points 1298c finite nuclear size if nuc is non-zero 1299c ********************************************************************** 1300 common /ps1/ dep(5), deq(5), db, dvc, dsal, dk, dm 1301c 1302c dep,deq=derivatives of op and dq; db=energie/dvc; 1303c dvc=speed of light in a.u.; dsal=2.*dvc; dk=kappa quantum number 1304c dm=exponential step/720., dkoef=1./720. 1305c ********************************************************************** 1306 common /trois/ dpno(4,30), dqno(4,30) 1307 data dkoef /0.1388888888888888d-2/ 1308 nstop=0 1309 dvc=137.0373d0 1310 dsal=dvc+dvc 1311 imm=0 1312 ies=0 1313 dk=nk 1314 lll=(nql*(nql+1))/2 1315 nd=0 1316 noeud=nqn-nql 1317 if (lll.ne.0) go to 10 1318 elim=-z*z/(1.5d0*nqn*nqn) 1319 go to 40 1320 10 elim=dv(1)+lll/(dr(1)*dr(1)) 1321 do 20 i=2,np 1322 val=dv(i)+lll/(dr(i)*dr(i)) 1323 if (val.le.elim) elim=val 1324 20 continue 1325 if (elim) 40,30,30 1326 30 nstop=17 1327c 2*v+l*(l+1)/r**2 is everywhere positive 1328c ********************************************************************** 1329 return 1330 40 if (de.le.elim) de=elim*0.5d0 1331 50 if (imm.eq.1) go to 80 1332 do 60 i=7,np,2 1333 imat=np+1-i 1334 if ((dv(imat)+lll/(dr(imat)*dr(imat))-de).le.0.0d0) go to 70 1335 60 continue 1336 70 if (imat.gt.5) go to 80 1337 de=de*0.5d0 1338 if (de.lt.-test.and.nd.le.noeud) go to 50 1339 nstop=28 1340c 2*v+l*(l+1)/r**2-2*e is everywhere positive 1341c ********************************************************************** 1342 return 1343c initial value for the outward integration 1344c ********************************************************************** 1345 80 db=de/dvc 1346 call inouh (dp,dq,dr,dq1,dfl,dv(1),z,test,nuc,nstop,jc) 1347 if (nstop) 310,90,310 1348c nstop=45 1349c the expansion at the origin does not converge 1350c ********************************************************************** 1351 90 nd=1 1352 do 110 i=1,5 1353 dval=dr(i)**dfl 1354 if (i.eq.1) go to 100 1355 if (dp(i-1).eq.0.0d0) go to 100 1356 if ((dp(i)/dp(i-1)).gt.0.0d0) go to 100 1357 nd=nd+1 1358 100 dp(i)=dp(i)*dval 1359 dq(i)=dq(i)*dval 1360 dep(i)=dep(i)*dval 1361 110 deq(i)=deq(i)*dval 1362 k=-1+2*(noeud-2*(noeud/2)) 1363 if ((dp(1)*k).gt.0.0d0) go to 130 1364 120 nstop=53 1365c error in the expansion at the origin 1366c ********************************************************************** 1367 return 1368 130 if ((k*nk*dq(1)).lt.0.0d0) go to 120 1369 dm=dpas*dkoef 1370c outward integration 1371c ********************************************************************** 1372 do 140 i=6,imat 1373 dp(i)=dp(i-1) 1374 dq(i)=dq(i-1) 1375 call inth (dp(i),dq(i),dv(i),dr(i)) 1376 if (dp(i-1).eq.0.0d0) go to 140 1377 if ((dp(i)/dp(i-1)).gt.0.0d0) go to 140 1378 nd=nd+1 1379 if (nd.gt.noeud) go to 150 1380 140 continue 1381 if (nd.eq.noeud) go to 160 1382 de=0.8d0*de 1383 if (de.lt.-test) go to 50 1384 nstop=206 1385c the number of nodes is too small 1386c ********************************************************************** 1387 return 1388 150 de=1.2d0*de 1389 if (de.gt.elim) go to 50 1390 nstop=210 1391c the number of nodes is too big 1392c ********************************************************************** 1393 return 1394c initial values for the inward integration 1395c ********************************************************************** 1396 160 dqm=dq(imat) 1397 dpm=dp(imat) 1398 if (imm.eq.1) go to 180 1399 do 170 i=1,np,2 1400 imax=np+1-i 1401 if(((dv(imax)-de)*dr(imax)*dr(imax)).le.300.0d0) go to 180 1402 170 continue 1403 180 dd=sqrt(-de*(2.0d0+db/dvc)) 1404 dpq=-dd/(dsal+db) 1405 dm=-dm 1406 do 190 i=1,5 1407 j=imax+1-i 1408 dp(j)=exp(-dd*dr(j)) 1409 dep(i)=-dd*dp(j)*dr(j) 1410 dq(j)=dpq*dp(j) 1411 190 deq(i)=dpq*dep(i) 1412 m=imax-5 1413c inward integration 1414c*********************************************************************** 1415 do 200 i=imat,m 1416 j=m+imat-i 1417 dp(j)=dp(j+1) 1418 dq(j)=dq(j+1) 1419 200 call inth (dp(j),dq(j),dv(j),dr(j)) 1420c joining of the large components 1421c ********************************************************************** 1422 dval=dpm/dp(imat) 1423 if (dval.gt.0.0d0) go to 210 1424 nstop=312 1425c error in the sign of the large component 1426c ********************************************************************** 1427 return 1428 210 do 220 i=imat,imax 1429 dp(i)=dp(i)*dval 1430 220 dq(i)=dq(i)*dval 1431c calculation of the norm 1432c ********************************************************************** 1433 dsum=3.0d0*dr(1)*(dp(1)**2+dq(1)**2)/(dpas*(dfl+dfl+1.0d0)) 1434 do 230 i=3,imax,2 1435 230 dsum=dsum+dr(i)*(dp(i)**2+dq(i)**2) 1436 > +4.0d0*dr(i-1)*(dp(i-1)**2+dq(i- 1437 1 1)**2)+dr(i-2)*(dp(i-2)**2+dq(i-2)**2) 1438 dsum=dpas*(dsum+dr(imat)*(dqm*dqm-dq(imat)*dq(imat)))*0.3333333333 1439 1 333333d0 1440c modification of the energy 1441c ********************************************************************** 1442 dbe=dp(imat)*(dqm-dq(imat))*dvc/dsum 1443 imm=0 1444 val=abs(dbe/de) 1445 if (val.le.test) go to 260 1446 240 dval=de+dbe 1447 if (dval.lt.0.0d0) go to 250 1448 dbe=dbe*0.5d0 1449 val=val*0.5d0 1450 if (val.gt.test) go to 240 1451 nstop=345 1452c energie nulle 1453c ********************************************************************** 1454 return 1455 250 de=dval 1456 if (val.le.0.1d0) imm=1 1457 ies=ies+1 1458 if (ies.le.nes) go to 50 1459 nstop=362 1460c number of iterations too big 1461c ********************************************************************** 1462 return 1463 260 dsum=sqrt(dsum) 1464 dq1=dq1/dsum 1465 do 270 i=1,imax 1466 dp(i)=dp(i)/dsum 1467 270 dq(i)=dq(i)/dsum 1468 do 280 i=1,4 1469 dpno(i,jc)=dpno(i,jc)/dsum 1470 280 dqno(i,jc)=dqno(i,jc)/dsum 1471 if (imax.eq.np) go to 300 1472 j=imax+1 1473 do 290 i=j,np 1474 dp(i)=0.0d0 1475 290 dq(i)=0.0d0 1476 300 nstop=0 1477 310 return 1478 end 1479 double precision function feff_dist(r0, r1) 1480c find distance between cartesian points r0 and r1 1481 implicit double precision (a-h, o-z) 1482 dimension r0(3), r1(3) 1483 feff_dist = 0.0d0 1484 do 10 i = 1, 3 1485 feff_dist = feff_dist + (r0(i) - r1(i))**2 1486 10 continue 1487 feff_dist = dsqrt(feff_dist) 1488 return 1489 end 1490c*********************************************************************** 1491c 1492c this subroutine calculates the ' energy dependent 1493c exchange-correlation potential' (or 'dirac- hara potential') 1494c ref.: paper by s.h.chou, j.j.rehr, e.a.stern, e.r.davidson (1986) 1495c 1496c inputs: rs in a.u. 1497c xk momentum in a.u. 1498c vi0 constant imaginary part in rydbergs 1499c outputs: vr --- dirac potential (Hartrees) 1500c vi --- constant imag part of the potential (Hartrees) 1501c written by j. mustre 8/31/87 1502c********************************************************************** 1503 1504 subroutine edp (rs, xk, vi0, vr, vi) 1505 implicit double precision (a-h, o-z) 1506 1507 parameter (pi = 3.1415926535897932384626433d0) 1508 parameter (one = 1, zero = 0) 1509 parameter (third = 1.0d0/3.0d0) 1510 parameter (raddeg = 180.0d0 / pi) 1511 complex*16 coni 1512 parameter (coni = (0.0d0,1.0d0)) 1513c kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37 1514 parameter (fa = 1.919158292677512811d0) 1515 1516 parameter (bohr = 0.529177249d0, ryd = 13.605698d0) 1517 parameter (alpinv = 137.03598956d0) 1518c fine structure alpha 1519 parameter (alphfs = 1.0d0 / alpinv) 1520c speed of light in louck's units (rydbergs?) 1521 parameter (clight = 2 * alpinv) 1522 1523 1524 xf = fa / rs 1525 1526c p = sqrt (k^2 + kf^2) is the local momentum, and x = p / kf 1527c Reference formula 23 in Role of Inelastic effects in EXAFS 1528c by Rehr and Chou. EXAFS1 conference editted by Bianconi. 1529c x is local momentum in units of fermi momentum 1530 1531 x = xk / xf 1532 x = x + 1.0d-5 1533c set to fermi level if below fermi level 1534 if (x .lt. 1.00001d0) x = 1.00001d0 1535 c = abs( (1+x) / (1-x) ) 1536 c = log(c) 1537 vr = - (xf/pi) * (1.0d0 + c * (1.0d0-x**2) / (2*x)) 1538 1539c Note vi=vi0/2 to have both real and imaginary part in hartrees 1540c to be consistent with other subroutines. 1541 vi = vi0 / 2.0d0 1542 return 1543 end 1544 double precision function exchan (d,dr,dexv) 1545 implicit double precision (a-h,o-z) 1546 save 1547c dexv=0.0, hedin-barth corr. and exch. potential 1548c dexv.ne. 0.0, dexv*slater exchange potential 1549c d=4pi*rho*r^2 , radial density for r=dr 1550c this function calculates exch=-r*Vexch 1551c 105.27578=32*(pi^2)/3 1552c comments added by j. mustre 8/27/87 1553 if (dexv.eq.0.0d0) go to 10 1554 exchan=3.0d0*dexv*((dr*d/105.27578d0)**(1.0d0/3.0d0)) 1555 return 1556 10 continue 1557 rrs=(d/(3.0d0*dr**2))**0.33333333333d0 1558 exchan=+0.5d0*(1.22177412d0*rrs 1559 > +0.0504d0*log(30.0d0*rrs+1.0d0))*dr 1560 return 1561 end 1562 double precision function exchee (d,dr) 1563 implicit double precision (a-h,o-z) 1564 save 1565c jm if density= 0,make exchange energy equal to zero 1566 if (d .eq. 0.0d0) then 1567 exchee=0.0d0 1568 else 1569 x=(3.0d0*dr**2/d)**0.333333333333d0/30.0d0 1570 rx=1.0d0/x 1571 exchee=0.02520d0*(x**3*log(1.0d0+rx)+x*0.50d0 1572 > -x**2-1.0d0/3.0d0-0.2020129d0 1573 1 2*rx) 1574 endif 1575 return 1576 end 1577 subroutine exjlnl (z, l, jl, nl) 1578 1579c purpose: to calculate the spherical bessel functions jl and nl 1580c for l = 0, 1, 2 or 3 using exact analytic expression 1581c 1582c arguments: 1583c z = argument of jl and nl 1584c l = integer order of spherical bessel function 1585c jl = jl bessel function (abramowitz conventions) 1586c nl = nl bessel function (abramowitz yl conventions) 1587c Note that this nl = abramowitz yl. 1588c 1589c analytic expressions from abramowitz 10.1.11 and 10.1.12 1590c recurrence relation to get analytic j4,n4 eqns 10.1.19-22 1591 1592 implicit double precision (a-h, o-z) 1593 1594 complex*16 z, jl, nl 1595 1596 complex*16 cosz, sinz 1597 1598c Exact formulae unstable for very small z, so use series 1599c expansion there. Limit of .3 chosen for 9 digit agreement. 1600 if (abs(z) .lt. 0.3d0) then 1601 call bjnser (z, l, jl, nl, 0) 1602 else 1603c use analytic formulae 1604 cosz = cos(z) 1605 sinz = sin(z) 1606 1607 if (l .eq. 0) then 1608 jl = sinz / z 1609 nl = -cosz / z 1610 1611 elseif (l .eq. 1) then 1612 jl = sinz/z**2 - cosz/z 1613 nl = -cosz/z**2 - sinz/z 1614 1615 elseif (l .eq. 2) then 1616 jl = ( 3.0d0/z**3 - 1.0d0/z)*sinz - 3.0d0*cosz/z**2 1617 nl = (-3.0d0/z**3 + 1.0d0/z)*cosz - 3.0d0*sinz/z**2 1618 1619 elseif (l .eq. 3) then 1620 jl = ( 15.0d0/z**4 - 6.0d0/z**2)*sinz 1621 > + (-15.0d0/z**3 + 1.0d0/z)*cosz 1622 nl = (-15.0d0/z**4 + 6.0d0/z**2)*cosz 1623 > + (-15.0d0/z**3 + 1.0d0/z)*sinz 1624 1625 else 1626 stop 'exjlnl, l out of range' 1627 1628 endif 1629 endif 1630 1631 return 1632 end 1633 subroutine fermi (rhoint, vint, xmu, rs, xf) 1634 1635 implicit double precision (a-h, o-z) 1636 1637 1638 parameter (pi = 3.1415926535897932384626433d0) 1639 parameter (one = 1, zero = 0) 1640 parameter (third = 1.0d0/3.0d0) 1641 parameter (raddeg = 180.0d0 / pi) 1642 complex*16 coni 1643 parameter (coni = (0.0d0,1.0d0)) 1644c kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37 1645 parameter (fa = 1.919158292677512811d0) 1646 1647 parameter (bohr = 0.529177249d0, ryd = 13.605698d0) 1648 parameter (alpinv = 137.03598956d0) 1649c fine structure alpha 1650 parameter (alphfs = 1.0d0 / alpinv) 1651c speed of light in louck's units (rydbergs?) 1652 parameter (clight = 2 * alpinv) 1653 1654 1655c calculate fermi level of the system (mu) according to formula 1656c mu=vcoulomb(interstitial)+vxc(interstitial)+kf(interstitial)^2 1657c formula 2.13 in lee and beni, phys. rev. b15,2862(1977) 1658 1659c note that vint includes both coulomb and ground state 1660c exchange-correlation potentials 1661 1662c den is the interstitial density 1663c rs is the density parameter 1664c xf is the interstital fermi momentum 1665c xmu is the fermi level in rydbergs 1666 1667 den = rhoint / (4.0d0*pi) 1668 rs = (3.0d0 / (4.0d0*pi*den)) ** third 1669 xf = fa / rs 1670 xmu = vint + xf**2 1671 1672 return 1673 end 1674 subroutine ff2chi (ipr4, critcw, s02, tk, thetad, icsig, 1675 1 vrcorr, vicorr) 1676c modified for feff6l by jjr 1677 implicit double precision (a-h, o-z) 1678 1679 1680 character*12 vfeff, vpotph, vpaths, vgenfm, vff2ch 1681 common /vers/ vfeff, vpotph, vpaths, vgenfm, vff2ch 1682 1683 1684 parameter (pi = 3.1415926535897932384626433d0) 1685 parameter (one = 1, zero = 0) 1686 parameter (third = 1.0d0/3.0d0) 1687 parameter (raddeg = 180.0d0 / pi) 1688 complex*16 coni 1689 parameter (coni = (0.0d0,1.0d0)) 1690c kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37 1691 parameter (fa = 1.919158292677512811d0) 1692 1693 parameter (bohr = 0.529177249d0, ryd = 13.605698d0) 1694 parameter (alpinv = 137.03598956d0) 1695c fine structure alpha 1696 parameter (alphfs = 1.0d0 / alpinv) 1697c speed of light in louck's units (rydbergs?) 1698 parameter (clight = 2 * alpinv) 1699 1700 1701 parameter (delk = 0.05d0) 1702 parameter (eps = 1.0d-10) 1703 parameter (eps4 = 1.0d-4) 1704c e (eV) = bohr**2 * ryd * k**2 (k in invA), b2r ~=3.81 1705 parameter (b2r = bohr**2 * ryd) 1706 1707c This is set in dim.h for other parts of the code 1708 parameter (nex = 100) 1709 1710c Max number of points on fine k grid for chi output 1711 parameter (nfinex = 601) 1712 1713 dimension achi(nex), achix(nex) 1714 dimension xk(nex), cdelta(nex), afeff(nex), phfeff(nex), 1715 1 redfac(nex), xlam(nex), rep(nex) 1716 1717 dimension emxs(nex), omega(nex), xkxs(nex), xsec(nex) 1718 1719 complex*16 p2, pp2 1720 complex*16 ck(nex), dw 1721 complex*16 cchi(nfinex), ccc, ccpath(nfinex) 1722 1723c head is headers from files.dat, hdxs is headers from xsect.bin 1724 parameter (nheadx = 30) 1725 character*80 head(nheadx), hdxs(nheadx) 1726 dimension lhead(nheadx), lhdxs(nheadx) 1727 1728 parameter (nlegx = 10) 1729 dimension rat(3,0:nlegx), iz(0:nlegx) 1730 1731 character*80 line 1732 parameter (nwordx = 4) 1733 character*50 words(nwordx), fname 1734 1735c do (or don't) correlated debye model dw factor 1736 logical dwcorr 1737c write xmu file only if xsect.bin exists 1738 logical wxmu 1739 character*72 header 1740 common /header_common/ header 1741 1742 1743c icsig 0, use real momentum for debye waller factor 1744c 1, use complex momentum for debye waller factor 1745 1746c NB: code units for this module are Ang, Ang**-1, eV, etc. 1747 vrcorr = vrcorr * ryd 1748 vicorr = vicorr * ryd 1749 1750 do 22 i = 1, nfinex 1751 cchi(i) = 0 1752 22 continue 1753 1754c Keep stats on total paths and paths used to make chi 1755 ntotal = 0 1756 nused = 0 1757 1758c open files.dat 1759 open (unit=2, file=trim(header)//'files.dat', 1760 > status='old', iostat=ios) 1761 call chopen (ios, trim(header)//'files.dat', 'ff2chi') 1762 nhead = nheadx 1763 call rdhead (2, nhead, head, lhead) 1764c header from rdhead includes carriage control 1765c skip a label line 1766 read(2,*) 1767 1768 dwcorr = .false. 1769 if (tk .gt. 1.0d-1) dwcorr = .true. 1770 1771c Open chi.dat and xmu.dat (output) and start header 1772 open (unit=3, file=trim(header)//'chi.dat', 1773 > status='unknown', iostat=ios) 1774 call chopen (ios, trim(header)//'chi.dat', 'ff2chi') 1775c open (unit=8, file='xsect.bin', status='old', iostat=ios) 1776 wxmu = .false. 1777 if (ios .le. 0) wxmu = .true. 1778 if(wxmu) then 1779c read xsect.bin 1780 nhdxs = nheadx 1781c skip label 1782 edge0 = (emxs(1)/ryd + xkxs(1)**2*bohr**2)*ryd 1783 1784 endif 1785 1786 do 14 ihead = 1, nhead 1787 if (lhead(ihead) .gt. 0) then 1788 write(3,12) head(ihead)(1:lhead(ihead)) 1789 endif 1790 12 format ('#',a) 1791 14 continue 1792 if (dwcorr) then 1793 write(3,800) s02, tk, thetad, vfeff, vff2ch 1794 800 format ('# S02', f7.3, ' Temp', f8.2, ' Debye temp', f8.2, 1795 1 t57, 2a12) 1796 else 1797 write(3,801) s02, vfeff, vff2ch 1798 801 format ('# S02', f7.3, t57, 2a12) 1799 endif 1800 1801 if (abs(vrcorr).ge.eps4 .or. abs(vicorr).ge.eps4) then 1802 write(3,802) vrcorr, vicorr 1803 write(77,802) vrcorr, vicorr 1804 endif 1805 802 format ('# Energy zero shift, vr, vi ', 1p, 2e14.5) 1806 1807 1808 if (critcw .gt. 0) write(3,15) critcw 1809 15 format ('# Curved wave amplitude ratio filter ', f7.3, '%') 1810 write(3,16) 1811 16 format ('# file sig2 cw amp ratio deg', 1812 1 ' nlegs r effective') 1813 1814c Open sig2.dat if necessary (output) and start header 1815 if (ipr4 .ge. 1) then 1816 open (unit=4, file=trim(header)//'sig2.dat', 1817 > status='unknown', iostat=ios) 1818 call chopen (ios, trim(header)//'sig2.dat', 'ff2chi') 1819 do 514 ihead = 1, nhead 1820 if (lhead(ihead) .gt. 0) 1821 1 write(4,12) head(ihead)(1:lhead(ihead)) 1822 514 continue 1823 if (dwcorr) then 1824 write(4,800) s02, tk, thetad, vfeff, vff2ch 1825 else 1826 write(4,801) s02, vfeff, vff2ch 1827 endif 1828 write(4,16) 1829 endif 1830 write(77,515) critcw 1831 515 format (' Use all paths with cw amplitude ratio', f7.2, '%') 1832 if (dwcorr) then 1833 write(77,516) s02, tk, thetad 1834 else 1835 write(77,517) s02 1836 endif 1837 516 format(' Use correlated Debye model. S02', f7.3, 1838 1 ' Temp', f8.2, ' Debye temp', f8.2) 1839 517 format(' Use Debye-Waller factors from files.dat. S02', f7.3) 1840 1841 10 continue 1842 read(2,11,end=399) line 1843 11 format (a) 1844 call triml (line) 1845 nwords = nwordx 1846 call bwords (line, nwords, words) 1847c if line was blank, skip it and go on to next line 1848 if (nwords .lt. 1) goto 10 1849 1850 ntotal = ntotal+1 1851c word 1 - feff.dat file name 1852c 2 - sig2 for path 1853c 3 - amplitude ratio, full k range 1854 1855 read(words(2),40,err=900) sig2 1856 read(words(3),40,err=900) crit 1857 40 format (bn, f15.0) 1858c Skip un-important path 1859 1860c Write output if path is important enough (ie, path is 1861 if (crit .lt. critcw) then 1862 write(77,17) words(1)(1:15), crit, ' (not used) ' 1863 17 format (4x, a, f10.4, a) 1864 goto 10 1865 endif 1866 1867c Read feff.dat file 1868 nused = nused+1 1869 write(77,17) words(1)(1:15), crit 1870 fname = words(1) 1871 open (unit=1, file=trim(header)//words(1), 1872 > status='old', iostat=ios) 1873 call chopen (ios, trim(header)//words(1), 'ff2chi') 1874 nhead = nheadx 1875 call rdhead (1, nhead, head, lhead) 1876 read(1,*) nleg, deg, reff, rs, edge 1877 if (abs(vrcorr) .gt. eps4) edge = edge-vrcorr 1878 if (nleg .gt. nlegx) stop 'too many legs' 1879c skip label 1880 read(1,*) 1881 do 30 ileg = 0, nleg-1 1882 read(1,*) (rat(j,ileg),j=1,3), ipot, iz(ileg) 1883 30 continue 1884c skip label 1885 read(1,*) 1886 do 20 j = 1, 3 1887 rat(j,nleg) = rat(j,0) 1888 20 continue 1889 iz(nleg) = iz(0) 1890 1891c Get sig2 from correlated debye model if required 1892 if (dwcorr) then 1893c replace sig2 from files.dat 1894 call sigms (tk, thetad, rs, nlegx, nleg, rat, iz, sig2) 1895 endif 1896 1897c Put path into chi.dat header, sig2.dat as required 1898 write(3,110) words(1)(1:15), sig2, crit, 1899 1 deg, nleg, reff 1900 if (ipr4 .ge. 1) then 1901 write(4,110) words(1)(1:15), sig2, crit, 1902 1 deg, nleg, reff 1903 endif 1904 110 format('#',1x, a, f8.5, 2f10.2, i6, f9.4) 1905 1906c read data 1907 i = 1 1908 120 read(1,*,end=130) xk(i), cdelta(i), afeff(i), 1909 1 phfeff(i), redfac(i), xlam(i), rep(i) 1910 1911c make complex momentum 1912c add correction to imag part of energy to xlam here 1913 1914c use atomic units for this 1915 viryd = vicorr / ryd 1916 preal = rep(i) * bohr 1917 xlamb = xlam(i) / bohr 1918 pimag = 1 / xlamb 1919c p2 is p**2, pp2 is p' **2 (p prime squared, new p) 1920 p2 = (preal + coni*pimag)**2 1921 pp2 = p2 + coni*viryd 1922 ck(i) = sqrt (pp2) 1923 xlam(i) = 1 / dimag(ck(i)) 1924 rep(i) = dble(ck(i)) 1925c put everything back into Ang and invAng 1926 ck(i) = ck(i) / bohr 1927 xlam(i) = xlam(i) * bohr 1928 rep(i) = rep(i) / bohr 1929 1930 npts = i 1931 i = i+1 1932 goto 120 1933 130 continue 1934 close(unit=1) 1935 1936c Make chi, note that |feff| at k=0 is zero. Must interpolate 1937c or extrapolate to find it. Can interpolate when we have 1938c data for k<0, but just extrapolate for all cases for now. 1939 iextr = 0 1940 do 300 i = 1, npts 1941 1942c extrapolate chi when k=0, otherwise calculate it 1943c achi has no 2kr term 1944 dw = exp(-2*sig2*ck(i)**2) 1945 phdw = atan2 (dimag(dw), dble(dw)) 1946 if (abs(xk(i)) .lt. 0.01d0) then 1947 iextr = i 1948 else 1949 achi(i) = afeff(i) * deg * abs(dw) * 1950 1 exp(-2*reff/xlam(i)) * redfac(i) * s02 / 1951 2 (abs(xk(i))*reff**2) 1952 endif 1953 achix(i) = cdelta(i) + phfeff(i) + phdw 1954 300 continue 1955c fill in achi where extrapolation necessary 1956 if (iextr .gt. 0) then 1957 achi(iextr) = 2*achi(iextr+1) - achi(iextr+2) 1958 endif 1959 1960c make sure no 2pi jumps in phase 1961 do 310 i = 2, npts 1962 call pijump (achix(i), achix(i-1)) 1963 310 continue 1964 1965c Decide on fine grid -- need k' if vrcorr /= 0 1966 if (abs(vrcorr) .gt. eps4) then 1967 xkpmin = xk2xkp (xk(1), vrcorr) 1968 n = xkpmin / delk 1969c need 1st int ABOVE xkpmin/delk 1970 if (xkpmin .gt. 0.0d0) n = n+1 1971c First k grid point moved by vrcorr 1972 xkmin = n * delk 1973 else 1974c Use unmodified grid 1975 xkmin = xk(1) 1976 endif 1977 1978c sum chi on fine k grid 1979 nkx = nfinex 1980 do 330 i = 1, nfinex 1981c xkout is k value for output, xk0 is k value used for 1982c interpolation and reconstruction of chi with original grid. 1983c If vrcorr=0, xk0 and xkout will be the same. 1984 xkout = delk * (i-1) + xkmin 1985 xk0 = xkp2xk (xkout, vrcorr) 1986 1987c find end of data, eps4 is to handle round-off (we've been 1988c reading files with limited precision) 1989 if (xk0 .gt. xk(npts)+eps4) then 1990 nkx = i-1 1991 goto 331 1992 endif 1993 call terp (xk, achi, npts, xk0, achi0) 1994 call terp (xk, achix, npts, xk0, achix0) 1995 cchi(i) = cchi(i) + achi0 * 1996 1 exp (coni * (2*xk0*reff + achix0)) 1997 ccpath(i) = achi0 * exp (coni * (2*xk0*reff + achix0)) 1998 330 continue 1999 331 continue 2000 2001c write out a chinnnn.dat for this path, if necessary. Headers 2002c later... 2003 if (ipr4 .ge. 2) then 2004c Assume file is form feffnnnn.whatever, change it to 2005c chipnnnn.whatever. Other filenames 2006c will turn out wierdly 2007 fname(1:4) = 'chip' 2008 open (unit=9, file=trim(header)//fname, status='unknown') 2009 do 370 ihead = 1, nhead 2010 if (lhead(ihead) .gt. 0) then 2011 write(9,12) head(ihead)(1:lhead(ihead)) 2012 endif 2013 370 continue 2014 if (dwcorr) then 2015 write(9,800) s02, tk, thetad, vfeff, vff2ch 2016 else 2017 write(9,801) s02, vfeff, vff2ch 2018 endif 2019 2020 if (abs(vrcorr).ge.eps4 .or. abs(vicorr).ge.eps4) then 2021 write(9,802) vrcorr, vicorr 2022 endif 2023 write(9,*) 'Debye-waller factor ', sig2 2024 2025 write(9,407) 2026 write(9,338) 2027 338 format (' k chi mag ', 2028 1 'phase phase-2kr @#') 2029 do 340 i = 1, nkx 2030 xk0 = delk * (i-1) + xkmin 2031 ccc = ccpath(i) 2032 phase=0 2033 if (abs(ccc) .gt. 0) phase=atan2(dimag(ccc), dble(ccc)) 2034 if (i .gt. 1) call pijump (phase, phase0) 2035 phase0 = phase 2036 write(9,410) xk0, dimag(ccc), abs(ccc), phase, 2037 1 phase-2*xk0*reff 2038 340 continue 2039 endif 2040 2041 goto 10 2042 399 continue 2043 close (unit=2) 2044 2045c Write it out 2046 write(3,405) nused, ntotal 2047 405 format ('#',1x, i4, '/', i4, ' paths used') 2048 write(3,407) 2049 407 format ('#',1x, 79('-')) 2050 write(3,406) 2051 406 format ( '# k chi mag phase @#') 2052 do 420 i = 1, nkx 2053 xk0 = delk * (i-1) + xkmin 2054 ccc = cchi(i) 2055 phase=0 2056 if (abs(ccc) .gt. 0) phase=atan2(dimag(ccc), dble(ccc)) 2057 if (i .gt. 1) call pijump (phase, phase0) 2058 phase0 = phase 2059 write(3,410) xk0, dimag(ccc), abs(ccc), phase 2060 410 format (1x, f10.4, 3x, 4(1pe13.6,1x)) 2061 420 continue 2062 close (unit=3) 2063 2064 2065 write(77,500) nused, ntotal 2066 500 format (' ff2chi done, ', i4, '/', i4, ' paths used.') 2067 return 2068 2069 900 stop 'Error reading files.dat importance factors' 2070 end 2071 2072c following functions use invA and eV as input and output, 2073c internal workings in atomic units 2074 2075 double precision function xk2xkp (xk, vrcorr) 2076 implicit double precision (a-h, o-z) 2077 2078 parameter (pi = 3.1415926535897932384626433d0) 2079 parameter (one = 1, zero = 0) 2080 parameter (third = 1.0d0/3.0d0) 2081 parameter (raddeg = 180.0d0 / pi) 2082 complex*16 coni 2083 parameter (coni = (0.0d0,1.0d0)) 2084c kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37 2085 parameter (fa = 1.919158292677512811d0) 2086 2087 parameter (bohr = 0.529177249d0, ryd = 13.605698d0) 2088 parameter (alpinv = 137.03598956d0) 2089c fine structure alpha 2090 parameter (alphfs = 1.0d0 / alpinv) 2091c speed of light in louck's units (rydbergs?) 2092 parameter (clight = 2 * alpinv) 2093 2094 xk0 = xk*bohr 2095 vr = vrcorr / ryd 2096 xksign = sign (one, xk0) 2097 e = xksign*xk0**2 + vr 2098 xk2xkp = getxk(e) / bohr 2099 return 2100 end 2101 2102 double precision function xkp2xk (xkp, vrcorr) 2103 implicit double precision (a-h, o-z) 2104 2105 parameter (pi = 3.1415926535897932384626433d0) 2106 parameter (one = 1, zero = 0) 2107 parameter (third = 1.0d0/3.0d0) 2108 parameter (raddeg = 180.0d0 / pi) 2109 complex*16 coni 2110 parameter (coni = (0.0d0,1.0d0)) 2111c kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37 2112 parameter (fa = 1.919158292677512811d0) 2113 2114 parameter (bohr = 0.529177249d0, ryd = 13.605698d0) 2115 parameter (alpinv = 137.03598956d0) 2116c fine structure alpha 2117 parameter (alphfs = 1.0d0 / alpinv) 2118c speed of light in louck's units (rydbergs?) 2119 parameter (clight = 2 * alpinv) 2120 2121 xkp0 = xkp*bohr 2122 vr = vrcorr / ryd 2123 xkpsgn = sign (one, xkp0) 2124 e = xkpsgn*xkp0**2 - vr 2125 xkp2xk = getxk(e) / bohr 2126 return 2127 end 2128 double precision function ffq(q, ef, xk, wp, alph) 2129 implicit double precision (a-h,o-z) 2130 2131c input: q, wp, alph, ef, xk 2132c q is dimensionless, normalized to fermi momentum 2133c xk is momentum in invBohrs 2134c output: ffq only 2135 2136 wq = sqrt (wp**2 + alph*q**2 + q**4) 2137 ffq = (wp+wq)/(q**2) + alph/(2.0d0*wp) 2138 ffq = ((ef*wp) / (4.0d0*xk)) * log(ffq) 2139 2140 return 2141 end 2142 subroutine fixvar (rmt, edens, vtot, 2143 1 vint, rhoint, nr, dx, x0, ri, 2144 2 vtotph, rhoph) 2145 2146 implicit double precision (a-h, o-z) 2147 2148 character*72 header 2149 common /header_common/ header 2150 2151 2152 2153 parameter (nphx = 7) !max number of unique potentials (potph) 2154 parameter (npotx = nphx) !max number of unique potentials (genfmt, paths) 2155 parameter (nfrx = nphx) !max number of free atom types 2156 parameter (novrx = 8) !max number of overlap shells 2157 parameter (natx = 250) !max number of atoms in problem 2158 parameter (ltot = 24) !max number of ang mom (arrays 1:ltot+1) 2159 parameter (nrptx = 250) !Loucks r grid used through overlap 2160 parameter (nex = 100) !Number of energy points genfmt, etc. 2161 2162 parameter (lamtot=15) !Max number of distinct lambda's for genfmt 2163 !15 handles iord 2 and exact ss 2164 parameter (mtot=4, ntot=2) !vary mmax and nmax independently 2165 parameter (legtot=9) !matches path finder, used in GENFMT 2166 parameter (npatx = 8) !max number of path atoms, used in path 2167 !finder, NOT in genfmt 2168 2169 2170 parameter (pi = 3.1415926535897932384626433d0) 2171 parameter (one = 1, zero = 0) 2172 parameter (third = 1.0d0/3.0d0) 2173 parameter (raddeg = 180.0d0 / pi) 2174 complex*16 coni 2175 parameter (coni = (0.0d0,1.0d0)) 2176c kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37 2177 parameter (fa = 1.919158292677512811d0) 2178 2179 parameter (bohr = 0.529177249d0, ryd = 13.605698d0) 2180 parameter (alpinv = 137.03598956d0) 2181c fine structure alpha 2182 parameter (alphfs = 1.0d0 / alpinv) 2183c speed of light in louck's units (rydbergs?) 2184 parameter (clight = 2 * alpinv) 2185 2186 2187 dimension edens(nrptx), vtot (nrptx) 2188 dimension vtotph(nr), rhoph(nr) 2189 dimension ri(nr) 2190 2191c PHASE needs 2192c vtot = total potential including gs xcorr, no r**2 2193c edens = rho, charge density, no factor of 4*pi, no r**2 2194c From overlapping, vtot = potential only, ok as is 2195c edens = density*4*pi, so fix this here. 2196 2197c If new grid is different from old one, be sure to interpolate 2198c somehow... 2199 2200c Only values inside the muffin tin are used, except that XCPOT 2201c (in PHASE) uses values at imt+1 and requires these to be the 2202c interstitial values. So set the last part of the arrays to 2203c interstitial values... 2204 2205 imt = ii(rmt) 2206 2207 do 190 i = 1, imt 2208 vtotph(i) = vtot(i) 2209 rhoph(i) = edens(i)/(4.0d0*pi) 2210 190 continue 2211 do 200 i = imt+1, nrptx 2212 vtotph(i) = vint 2213 rhoph(i) = rhoint/(4.0d0*pi) 2214 200 continue 2215 2216 return 2217 end 2218 subroutine fmtrxi (lam1x, lam2x, ie, iterm, ileg, ilegp) 2219 implicit double precision (a-h, o-z) 2220 2221 character*72 header 2222 common /header_common/ header 2223 2224 2225c all commons except for /fmat/ are inputs 2226 2227c inputs: 2228c lam1x, lam2x: limits on lambda and lambda' 2229c ie: energy grid points 2230c iterm = 1 if we're doing the termination matrix M, 2231c -1 otherwise 2232c ileg, ilegp: leg and leg' 2233c 2234c Inputs from common: 2235c phases, use ph(ie,...,ilegp), and lmax(ie,ilegp) 2236c lambda arrays 2237c rotation matrix for ilegp 2238c clmz for ileg and ilegp 2239c path data, eta(ilegp) and ipot(ilegp) 2240c xnlm array 2241c 2242c Output: fmati(...,ilegp) in common /fmatrx/ is set for 2243c current energy point. 2244 2245c calculate scattering amplitude matrices 2246c f(lam,lam') = sum_l tl gam(l,m,n)dri(l,m,m',ileg)gamt(l,m',n') 2247c *cexp(-i*m*eta), eta = gamma+alpha' 2248c lam lt lam1x, lam' lt lam2x such that m(lam) lt l0, n(lam) lt l0 2249c gam = (-)**m c_l,n+m*xnlm, gamt = (2l+1)*c_ln/xnlm, 2250c gamtl = gamt*tl 2251 2252 2253 parameter (pi = 3.1415926535897932384626433d0) 2254 parameter (one = 1, zero = 0) 2255 parameter (third = 1.0d0/3) 2256 parameter (raddeg = 180.0d0 / pi) 2257 complex*16 coni 2258 parameter (coni = (0.0d0,1.0d0)) 2259c kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37 2260 parameter (fa = 1.919158292677512811d0) 2261 2262 parameter (bohr = 0.529177249d0, ryd = 13.605698d0) 2263 parameter (alpinv = 137.03598956d0) 2264c fine structure alpha 2265 parameter (alphfs = 1.0d0 / alpinv) 2266c speed of light in louck's units (rydbergs?) 2267 parameter (clight = 2 * alpinv) 2268 2269 2270 parameter (nphx = 7) !max number of unique potentials (potph) 2271 parameter (npotx = nphx) !max number of unique potentials (genfmt, paths) 2272 parameter (nfrx = nphx) !max number of free atom types 2273 parameter (novrx = 8) !max number of overlap shells 2274 parameter (natx = 250) !max number of atoms in problem 2275 parameter (ltot = 24) !max number of ang mom (arrays 1:ltot+1) 2276 parameter (nrptx = 250) !Loucks r grid used through overlap 2277 parameter (nex = 100) !Number of energy points genfmt, etc. 2278 2279 parameter (lamtot=15) !Max number of distinct lambda's for genfmt 2280 !15 handles iord 2 and exact ss 2281 parameter (mtot=4, ntot=2) !vary mmax and nmax independently 2282 parameter (legtot=9) !matches path finder, used in GENFMT 2283 parameter (npatx = 8) !max number of path atoms, used in path 2284 !finder, NOT in genfmt 2285 2286 2287 save /nlm/ 2288 common /nlm/ xnlm(ltot+1,mtot+1) 2289 2290 2291 common /lambda/ 2292 4 mlam(lamtot), !mu for each lambda 2293 5 nlam(lamtot), !nu for each lambda 2294 1 lamx, !max lambda in problem 2295 2 laml0x, !max lambda for vectors involving absorbing atom 2296 3 mmaxp1, nmax !max mu in problem + 1, max nu in problem 2297 2298 2299 save /clmz/ 2300 complex*16 clmi 2301 common /clmz/ clmi(ltot+1,mtot+ntot+1,legtot) 2302 2303 2304 complex*16 fmati 2305 common /fmatrx/ fmati(lamtot,lamtot,legtot) 2306 2307 2308 save /rotmat/ 2309 common /rotmat/ dri(ltot+1,2*mtot+1,2*mtot+1,legtot+1) 2310 2311 2312c Note that leg nleg is the leg ending at the central atom, so that 2313c ipot(nleg) is central atom potential, rat(nleg) position of 2314c central atom. 2315c Central atom has ipot=0 2316c For later convience, rat(,0) and ipot(0) refer to the central 2317c atom, and are the same as rat(,nleg), ipot(nleg). 2318 2319c text and title arrays include carriage control 2320 character*80 text, title 2321 character*6 potlbl 2322 common /str/ text(40), !text header from potph 2323 1 title(5), !title from paths.dat 2324 1 potlbl(0:npotx) ! potential labels for output 2325 2326 complex*16 ph, eref 2327 common /pdata/ 2328 1 ph(nex,ltot+1,0:npotx), !complex phase shifts, 2329 1 !central atom ipot=0 2330 1 rat(3,0:legtot+1), !position of each atom, code units(bohr) 2331 1 eref(nex), !complex energy reference 2332 1 em(nex), !energy mesh 2333 1 ri(legtot), beta(legtot+1), eta(0:legtot+1), !r, beta, eta for each leg 2334 1 deg, rnrmav, xmu, edge, !(output only) 2335 1 lmax(nex,0:npotx), !max l with non-zero phase for each energy 2336 1 ipot(0:legtot), !potential for each atom in path 2337 1 iz(0:npotx), !atomic number (output only) 2338 1 ltext(40), ltitle(5), !length of each string 2339 1 nsc, nleg, !nscatters, nlegs (nleg = nsc+1) 2340 1 npot, ne, !number of potentials, energy points 2341 1 ik0, !index of energy grid corresponding to k=0 (edge) 2342 1 ipath, !index of current path (output only) 2343 1 ihole, !(output only) 2344 1 l0, il0, !lfinal and lfinal+1 (used for indices) 2345 1 lmaxp1, !largest lmax in problem + 1 2346 1 ntext, ntitle !number of text and title lines 2347 2348 2349 complex*16 cam, camt, cterm, tltl 2350 complex*16 gam(ltot+1,mtot+1,ntot+1), 2351 1 gamtl(ltot+1,mtot+1,ntot+1), tl 2352 2353c calculate factors gam and gamtl 2354 iln = 1 2355 ilx = lmax(ie,ipot(ilegp)) + 1 2356 if (iterm .gt. 0) then 2357 iln = il0 2358 ilx = il0 2359 endif 2360 do 30 il = iln, ilx 2361 tltl = 2.0d0*il - 1.0d0 2362 if (iterm .lt. 0) then 2363 tl = (exp(2.0d0*coni*ph(ie,il,ipot(ilegp))) - 1.0d0) 2364 > / (2.0d0*coni) 2365 tltl = tltl * tl 2366 endif 2367 lam12x = max (lam1x, lam2x) 2368 do 20 lam = 1, lam12x 2369 m = mlam(lam) 2370 if (m .lt. 0) goto 20 2371 im = m+1 2372 if (im .gt. il) goto 20 2373 in = nlam(lam) + 1 2374 imn = in + m 2375 if (lam .gt. lam1x) goto 10 2376 cam = xnlm(il,im) * (-1)**m 2377 if (imn .le. il) gam(il,im,in) = cam * clmi(il,imn,ileg) 2378 if (imn .gt. il) gam(il,im,in) = 0 2379 10 if (lam .gt. lam2x) goto 20 2380 camt = tltl / xnlm(il,im) 2381 gamtl(il,im,in) = camt * clmi(il,in,ilegp) 2382 20 continue 2383 30 continue 2384 2385 do 60 lam1 = 1,lam1x 2386 m1 = mlam(lam1) 2387 in1 = nlam(lam1) + 1 2388 iam1 = abs(m1) + 1 2389 do 60 lam2 = 1, lam2x 2390 m2 = mlam(lam2) 2391 in2 = nlam(lam2) + 1 2392 iam2 = iabs(m2) + 1 2393 imn1 = iam1 + in1 - 1 2394 cterm = 0.0d0 2395 ilmin = max (iam1, iam2, imn1, in2, iln) 2396 do 40 il = ilmin, ilx 2397c skip terms with mu > l (NB il=l+1, so mu=il is mu>l) 2398 if (abs(m1).ge.il .or. abs(m2).ge.il) goto 40 2399 m1d = m1 + mtot+1 2400 m2d = m2 + mtot+1 2401 2402 cterm = cterm + gam(il,iam1,in1)*gamtl(il,iam2,in2) 2403 1 *dri(il,m1d,m2d,ilegp) 2404 2405 40 continue 2406 if (eta(ileg) .ne. 0.0d0) then 2407 m1 = mlam(lam1) 2408 cterm = cterm * exp(-coni*eta(ileg)*m1) 2409 endif 2410c Above was org coding, change to use eta(ilegp) as test 2411c based on algebra check. July 20, 1992, siz&jjr 2412c Changed back with redifinition of eta(see rdpath.f) 2413c which is more convinient in polarization case. 2414c August 8,1993, ala. 2415c if (eta(ilegp) .ne. 0.0) then 2416c m1 = mlam(lam1) 2417c cterm = cterm * exp(-coni*eta(ilegp)*m1) 2418c endif 2419 fmati(lam1,lam2,ilegp) = cterm 2420 60 continue 2421 2422c test of fmati(lam,lam',ileg) 2423c plot fmat(lam,lam') = csqrt((z/2)**(m1-m2))*fmat 2424 2425 return 2426 end 2427 subroutine fovrg (il, ihard, rmt, xmt, jri, e, nr, dx, ri, v, dny, 2428 1 pu, qu, p, q, ps, qs, vm) 2429 implicit double precision (a-h, o-z) 2430 2431 character*72 header 2432 common /header_common/ header 2433 2434 2435c Input: 2436c il ang mom number + 1 2437c ihard number of times convergence test fails 2438c rmt muffin tin radius 2439c xmt x such that rmt = exp ((x-1)*dx - 8.8) 2440c jri first interstitial grid point (imt + 1) 2441c e current complex energy 2442c nr number of points in r grid 2443c dx dx in Loucks' grid (usually .05) 2444c ri(nr) Loucks' position grid, r = exp ((i-1)*dx - 8.8) 2445c v(nr) total complex potential including energy dep xc 2446c v is in the form pot*r**2 2447c 2448c Work space: 2449c complex*16 p(nr), q(nr), ps(nr), qs(nr), vm(nr) 2450c Must be dimensioned in calling program. Coded like this 2451c to make using different r-grids with different nrmax easy. 2452c 2453c Output: 2454c ihard incremented each time convergence test fails 2455c dny r*g'/g, see loucks (4-85), q/p = cf/g (eq 4-86) 2456c pu, qu upper and lower components at muffin tin 2457c q and q arrays upper and lower components (see comments) 2458 2459 complex*16 v(nr), e 2460 dimension ri(nr) 2461 complex*16 dny, pu, qu 2462 complex*16 p(nr), q(nr), ps(nr), qs(nr), vm(nr) 2463 2464 2465 parameter (pi = 3.1415926535897932384626433d0) 2466 parameter (one = 1, zero = 0) 2467 parameter (third = 1.0d0/3.0d0) 2468 parameter (raddeg = 180.0d0 / pi) 2469 complex*16 coni 2470 parameter (coni = (0.0d0,1.0d0)) 2471c kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37 2472 parameter (fa = 1.919158292677512811d0) 2473 2474 parameter (bohr = 0.529177249d0, ryd = 13.605698d0) 2475 parameter (alpinv = 137.03598956d0) 2476c fine structure alpha 2477 parameter (alphfs = 1.0d0 / alpinv) 2478c speed of light in louck's units (rydbergs?) 2479 parameter (clight = 2 * alpinv) 2480 2481 parameter (c = clight) 2482 parameter (csq = c**2) 2483 2484 double precision lp1, ldcsq 2485 complex*16 c1,c2,c3,pc,qc,dp1,dq1,dp2,dq2,dp3,dq3,dp4,dq4 2486 complex*16 vh,vmh,vmnp1,psn,qsn,psnm1,qsnm1,psnm2,qsnm2 2487 complex*16 psnm3,qsnm3,psnm4,qsnm4,pp,qp,psnp1,qsnp1,prel,qrel 2488 complex*16 psu,vu,dummy 2489 complex*16 vn,vmn 2490 2491c test=1.e+04 value in loucks 2492 test=1.d+05 2493 nrk=6 2494 2495 expdxh=exp(dx/2.0d0) 2496 dxd4=dx/4.0d0 2497 dxd8=dx/8.0d0 2498 a1=dx*3.30d0 2499 a2=-dx*4.20d0 2500 a3=dx*7.80d0 2501 a4=dx*14.0d0/45.0d0 2502 a5=dx*64.0d0/45.0d0 2503 a6=dx*24.0d0/45.0d0 2504 call feff_diff (v,dx,jri,vm) 2505 twoz=-dble (v(1))/ri(1) 2506 l=il-1 2507 lp1=l+1.0d0 2508 ldcsq=l/csq 2509 ie=1 2510 r=ri(1) 2511 vn=v(1) 2512 vmn=vm(1) 2513cv p(1)=1.0 2514 p(1)=1.d-20 2515 q(1)=-e/(2.0d0*l+3.0d0)*r*p(1) 2516 beta=lp1 2517 if (twoz.eq.0.0d0) go to 10 2518 beta=sqrt(lp1*l+1.0d0-(twoz/c)**2) 2519 sb0=(beta-lp1)*csq/twoz 2520 sa1=(3.0d0*beta-(twoz/c)**2)/(2.0d0*beta+1.0d0) 2521 sb1=csq/twoz*((beta-l)*sa1-1.0)-sb0 2522 sa2=((beta+3.0*lp1)*sa1-3.0d0*l+twoz/csq*(beta+lp1+3.0d0)*sb1)/ 2523 1 (beta+1.0d0)/4.0d0 2524 sb2=(csq/twoz*(2.0d0*l*(beta+2.0d0-lp1)-l-(twoz/c)**2)*sa1-3.0d0*l 2525 1 *csq/twoz*(beta+2.0d0-lp1) 2526 > +(beta+3.0d0-2.0d0*lp1-(twoz/c)**2)*sb1)/ 2527 2 (beta+1.0)/4.0d0 2528 delta=r*csq/twoz 2529 q(1)=(sb0+delta*(sb1+delta*sb2))/ 2530 > (1.0d0+delta*(sa1+delta*sa2))*p(1) 2531 10 continue 2532c runge kutta method (see loucks) 2533 c1=vn/r**2-e 2534 c2=1.0d0-c1/csq 2535 c3=(vmn-2.0d0*vn)/c2/c2*ldcsq 2536 ps(1)=r*c2*q(1)+lp1*p(1) 2537 qs(1)=-lp1*q(1)+(r*c1-c3/r**3)*p(1) 2538 n=1 2539 20 continue 2540 pc=p(n) 2541 qc=q(n) 2542 dp1=dx*(r*c2*qc+lp1*pc) 2543 dq1=dx*(-lp1*qc+(r*c1-c3/r**3)*pc) 2544 pc=pc+0.50d0*dp1 2545 qc=qc+0.50d0*dq1 2546 r=r*expdxh 2547 vnp1=v(n+1) 2548 vmnp1=vm(n+1) 2549 vh=(vn+vnp1)*0.50d0+(vmn-vmnp1)*dxd8 2550 vmh=(1.50d0*(vnp1-vn)-(vmn+vmnp1)*dxd4)/dx 2551 c1=vh/r/r-e 2552 c2=1.0d0-c1/csq 2553 c3=(vmh-2.0d0*vh)/c2/c2*ldcsq 2554 dp2=dx*(r*c2*qc+lp1*pc) 2555 dq2=dx*(-lp1*qc+(r*c1-c3/r**3)*pc) 2556 pc=pc+0.50d0*(dp2-dp1) 2557 qc=qc+0.50d0*(dq2-dq1) 2558 dp3=dx*(r*c2*qc+lp1*pc) 2559 dq3=dx*(-lp1*qc+(r*c1-c3/r**3)*pc) 2560 pc=pc+dp3-0.50d0*dp2 2561 qc=qc+dq3-0.50d0*dq2 2562 n=n+1 2563 r=ri(n) 2564 c1=vnp1/r/r-e 2565 c2=1.0d0-c1/csq 2566 c3=(vmnp1-2.0d0*vnp1)/c2/c2*ldcsq 2567 dp4=dx*(r*c2*qc+lp1*pc) 2568 dq4=dx*(-lp1*qc+(r*c1-c3/r**3)*pc) 2569 p(n)=p(n-1)+(dp1+2.0d0*(dp2+dp3)+dp4)/6.0d0 2570 q(n)=q(n-1)+(dq1+2.0d0*(dq2+dq3)+dq4)/6.0d0 2571 ps(n)=r*c2*q(n)+lp1*p(n) 2572 qs(n)=-lp1*q(n)+(r*c1-c3/r**3)*p(n) 2573 vn=vnp1 2574 vmn=vmnp1 2575 if (n-nrk) 20,30,30 2576 30 if (n.ge.jri) go to 120 2577 psn=ps(nrk) 2578 qsn=qs(nrk) 2579 psnm1=ps(nrk-1) 2580 qsnm1=qs(nrk-1) 2581 psnm2=ps(nrk-2) 2582 qsnm2=qs(nrk-2) 2583 psnm3=ps(nrk-3) 2584 qsnm3=qs(nrk-3) 2585 psnm4=ps(nrk-4) 2586 qsnm4=qs(nrk-4) 2587c milne method 2588 40 r=ri(n+1) 2589 c1=v(n+1)/r/r-e 2590 c2=1.0d0-c1/csq 2591 c3=(vm(n+1)-2.0d0*v(n+1))/c2/c2*ldcsq 2592 pp=p(n-5)+a1*(psn+psnm4)+a2*(psnm1+psnm3)+a3*psnm2 2593 qp=q(n-5)+a1*(qsn+qsnm4)+a2*(qsnm1+qsnm3)+a3*qsnm2 2594 nit=0 2595 50 psnp1=r*c2*qp+lp1*pp 2596 qsnp1=-lp1*qp+(r*c1-c3/r**3)*pp 2597 pc=p(n-3)+a4*(psnp1+psnm3)+a5*(psn+psnm2)+a6*psnm1 2598 qc=q(n-3)+a4*(qsnp1+qsnm3)+a5*(qsn+qsnm2)+a6*qsnm1 2599 if (abs(test*(pc-pp))-abs(pc)) 60,60,70 2600 60 if (abs(test*(qc-qp))-abs(qc)) 110,110,70 2601 70 if (nit-40) 100,80,100 2602c 70 if (nit-5) 100,80,100 value in loucks 2603 80 prel=(pc-pp)/pc 2604 qrel=(qc-qp)/qc 2605c count times hard test fails 2606 ihard = ihard + 1 2607c print90, il,ie,n,prel,qrel 2608 90 format (' hard test in fovrg il=',i2,' ie=',i1,' n=',i3,' prel=' 2609 1 ,e16.8,' qrel=',e16.8,' **********') 2610 go to 110 2611 100 nit=nit+1 2612 pp=pc 2613 qp=qc 2614 go to 50 2615 110 n=n+1 2616 p(n)=pc 2617 q(n)=qc 2618 ps(n)=psnp1 2619 qs(n)=qsnp1 2620 psnm4=psnm3 2621 psnm3=psnm2 2622 psnm2=psnm1 2623 psnm1=psn 2624 psn=psnp1 2625 qsnm4=qsnm3 2626 qsnm3=qsnm2 2627 qsnm2=qsnm1 2628 qsnm1=qsn 2629 qsn=qsnp1 2630c introduce scale factor to prevent overflow on vax jjr 2631 if(abs(pc).lt.1.d+20) go to 119 2632 scale=1.d-20 2633 do 112 mm=1,6 2634 nm=n-mm+1 2635 p(nm)=scale*p(nm) 2636 q(nm)=scale*q(nm) 2637 ps(nm)=scale*ps(nm) 2638 qs(nm)=scale*qs(nm) 2639 112 continue 2640 psnm4=scale*psnm4 2641 psnm3=scale*psnm3 2642 psnm2=scale*psnm2 2643 psnm1=scale*psnm1 2644 psn=scale*psn 2645 qsnm4=scale*qsnm4 2646 qsnm3=scale*qsnm3 2647 qsnm2=scale*qsnm2 2648 qsnm1=scale*qsnm1 2649 qsn=scale*qsn 2650 119 if (n-jri) 40,120,120 2651 120 jm=jri-1 2652 x=dx*(xmt-jm) 2653 call intpol (zero,dx,p(jm),p(jri),ps(jm),ps(jri),x,pu,psu) 2654 call intpol (zero,dx,q(jm),q(jri),qs(jm),qs(jri),x,qu,dummy) 2655 call intpol (zero,dx,v(jm),v(jri),vm(jm),vm(jri),x,vu,dummy) 2656 dny=rmt*(1.0-(vu/rmt**2-e)/csq)*qu/pu+l 2657c dny is r*g'/g, see loucks (4-85), q/p = cf/g (eq 4-86) 2658c (watch for factors of rmt) 2659 return 2660 end 2661 double precision function fpot(r,z,wa) 2662 implicit double precision (a-h,o-z) 2663 save 2664c 2665c thomas fermi potential at the point r; z=atomic number 2666c wa=number of electrons-z-1 2667c ********************************************************************** 2668 wc=sqrt((r*(z+wa)**(1.0d0/3.0d0))/0.88530d0) 2669 wd=wc*(0.601120d0*wc+1.810610d0)+1.0d0 2670 we=wc*(wc*(wc*(wc*(0.04793d0*wc+0.21465d0)+0.77112d0)+1.39515d0) 2671 > +1.81061d0)+1.0d0 2672 wc=(z+wa)*(wd/we)**2-wa 2673 fpot=-wc/r 2674 return 2675 end 2676 subroutine frnrm (rho, iz, rnrm) 2677 implicit double precision (a-h, o-z) 2678 2679 character*72 header 2680 common /header_common/ header 2681 2682 parameter (nphx = 7) !max number of unique potentials (potph) 2683 parameter (npotx = nphx) !max number of unique potentials (genfmt, paths) 2684 parameter (nfrx = nphx) !max number of free atom types 2685 parameter (novrx = 8) !max number of overlap shells 2686 parameter (natx = 250) !max number of atoms in problem 2687 parameter (ltot = 24) !max number of ang mom (arrays 1:ltot+1) 2688 parameter (nrptx = 250) !Loucks r grid used through overlap 2689 parameter (nex = 100) !Number of energy points genfmt, etc. 2690 2691 parameter (lamtot=15) !Max number of distinct lambda's for genfmt 2692 !15 handles iord 2 and exact ss 2693 parameter (mtot=4, ntot=2) !vary mmax and nmax independently 2694 parameter (legtot=9) !matches path finder, used in GENFMT 2695 parameter (npatx = 8) !max number of path atoms, used in path 2696 !finder, NOT in genfmt 2697 2698 dimension rho(nrptx) 2699 2700 real*8 sum,fr,fl 2701 2702c finds norman radius 2703 2704c Need overlapped densities. We'll get them in the form 2705c 4*pi*density = rho. Also need z of atom 2706 2707c Then integrate out to the point where the integral of 2708c 4*pi*density*r**2 is equal to iz 2709 sum = 0.0d0 2710 do 10 i = 1, nrptx-1 2711 fr = rho(i+1) * rr(i+1)**3 2712 fl = rho(i) * rr(i)**3 2713 sumsav = sum 2714 sum = sum + 0.025d0*(fr+fl) 2715 if (sum .ge. iz) then 2716 inrm = i+1 2717 goto 20 2718 endif 2719 10 continue 2720 write(77,*) ' FRNRM Could not integrate enough charge to reach' 2721 write(77,*) ' required z.' 2722 write(77,*) "error sum,iz=",sum,iz 2723 stop 'FRNRM-1' 2724 20 continue 2725c inrm is too big, subtract one from irnm and interpolate 2726c to get correct value 2727 inrm = inrm - 1 2728 deltaq = iz - sumsav 2729 fr = rho(inrm+1) * rr(inrm+1)**3 2730 fl = rho(inrm) * rr(inrm)**3 2731c dipas is delta i * 0.05 2732 dipas = 2*deltaq / (fl + fr) 2733 rnrm = rr(inrm)*(1.0d0 + dipas) 2734 2735 return 2736 end 2737 subroutine genfmt (ipr3, critcw, sig2g, iorder) 2738 implicit double precision (a-h, o-z) 2739 2740 character*72 header 2741 common /header_common/ header 2742 2743 2744 parameter (pi = 3.1415926535897932384626433d0) 2745 parameter (one = 1, zero = 0) 2746 parameter (third = 1.0d0/3.0d0) 2747 parameter (raddeg = 180.0d0 / pi) 2748 complex*16 coni 2749 parameter (coni = (0.0d0,1.0d0)) 2750c kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37 2751 parameter (fa = 1.919158292677512811d0) 2752 2753 parameter (bohr = 0.529177249d0, ryd = 13.605698d0) 2754 parameter (alpinv = 137.03598956d0) 2755c fine structure alpha 2756 parameter (alphfs = 1.0d0 / alpinv) 2757c speed of light in louck's units (rydbergs?) 2758 parameter (clight = 2 * alpinv) 2759 2760 2761 parameter (nphx = 7) !max number of unique potentials (potph) 2762 parameter (npotx = nphx) !max number of unique potentials (genfmt, paths) 2763 parameter (nfrx = nphx) !max number of free atom types 2764 parameter (novrx = 8) !max number of overlap shells 2765 parameter (natx = 250) !max number of atoms in problem 2766 parameter (ltot = 24) !max number of ang mom (arrays 1:ltot+1) 2767 parameter (nrptx = 250) !Loucks r grid used through overlap 2768 parameter (nex = 100) !Number of energy points genfmt, etc. 2769 2770 parameter (lamtot=15) !Max number of distinct lambda's for genfmt 2771 !15 handles iord 2 and exact ss 2772 parameter (mtot=4, ntot=2) !vary mmax and nmax independently 2773 parameter (legtot=9) !matches path finder, used in GENFMT 2774 parameter (npatx = 8) !max number of path atoms, used in path 2775 !finder, NOT in genfmt 2776 2777 2778 save /clmz/ 2779 complex*16 clmi 2780 common /clmz/ clmi(ltot+1,mtot+ntot+1,legtot) 2781 2782 2783 complex*16 fmati 2784 common /fmatrx/ fmati(lamtot,lamtot,legtot) 2785 2786 2787 common /lambda/ 2788 4 mlam(lamtot), !mu for each lambda 2789 5 nlam(lamtot), !nu for each lambda 2790 1 lamx, !max lambda in problem 2791 2 laml0x, !max lambda for vectors involving absorbing atom 2792 3 mmaxp1, nmax !max mu in problem + 1, max nu in problem 2793 2794 2795c Note that leg nleg is the leg ending at the central atom, so that 2796c ipot(nleg) is central atom potential, rat(nleg) position of 2797c central atom. 2798c Central atom has ipot=0 2799c For later convience, rat(,0) and ipot(0) refer to the central 2800c atom, and are the same as rat(,nleg), ipot(nleg). 2801 2802c text and title arrays include carriage control 2803 character*80 text, title 2804 character*6 potlbl 2805 common /str/ text(40), !text header from potph 2806 1 title(5), !title from paths.dat 2807 1 potlbl(0:npotx) ! potential labels for output 2808 2809 complex*16 ph, eref 2810 common /pdata/ 2811 1 ph(nex,ltot+1,0:npotx), !complex phase shifts, 2812 1 !central atom ipot=0 2813 1 rat(3,0:legtot+1), !position of each atom, code units(bohr) 2814 1 eref(nex), !complex energy reference 2815 1 em(nex), !energy mesh 2816 1 ri(legtot), beta(legtot+1), eta(0:legtot+1), !r, beta, eta for each leg 2817 1 deg, rnrmav, xmu, edge, !(output only) 2818 1 lmax(nex,0:npotx), !max l with non-zero phase for each energy 2819 1 ipot(0:legtot), !potential for each atom in path 2820 1 iz(0:npotx), !atomic number (output only) 2821 1 ltext(40), ltitle(5), !length of each string 2822 1 nsc, nleg, !nscatters, nlegs (nleg = nsc+1) 2823 1 npot, ne, !number of potentials, energy points 2824 1 ik0, !index of energy grid corresponding to k=0 (edge) 2825 1 ipath, !index of current path (output only) 2826 1 ihole, !(output only) 2827 1 l0, il0, !lfinal and lfinal+1 (used for indices) 2828 1 lmaxp1, !largest lmax in problem + 1 2829 1 ntext, ntitle !number of text and title lines 2830 2831 2832 save /nlm/ 2833 common /nlm/ xnlm(ltot+1,mtot+1) 2834 2835 2836 save /rotmat/ 2837 common /rotmat/ dri(ltot+1,2*mtot+1,2*mtot+1,legtot+1) 2838 2839 2840 2841 character*12 vfeff, vpotph, vpaths, vgenfm, vff2ch 2842 common /vers/ vfeff, vpotph, vpaths, vgenfm, vff2ch 2843 2844 2845c global polarization data 2846 logical pola 2847 double precision evec,ivec,elpty 2848 complex*16 ptz 2849 common /pol/ evec(3), ivec(3), elpty, ptz(-1:1,-1:1), pola 2850 2851 2852 complex*16 rho(legtot), pmati(lamtot,lamtot,2) 2853 complex*16 pllp, ptrac, srho, prho, cdel1, cfac 2854 complex*16 cchi(nex), cfms, mmati 2855 dimension mmati(-mtot:mtot,-mtot:mtot) 2856 dimension t3j(-mtot-1:mtot+1,-1:1) 2857 dimension xk(nex), ckmag(nex) 2858 complex*16 ck(nex) 2859 dimension ffmag(nex) 2860 2861 character*12 fname 2862 2863 logical done 2864 2865c Input flags: 2866c iorder, order of approx in f-matrix expansion (see setlam) 2867c (normal use, 2. Do ss exactly regardless of iorder) 2868 2869c used for divide-by-zero and trig tests 2870 parameter (eps = 1.0d-16) 2871 2872c Read phase calculation input, data returned via commons 2873 open (unit=1, file=trim(header)//'phase.bin', status='old', 2874 1 access='sequential', form='unformatted', iostat=ios) 2875 call chopen (ios, trim(header)//'phase.bin', 'genfmt') 2876 call rphbin (1) 2877 close (unit=1) 2878 2879c Open path input file (unit in) and read title. Use unit 1. 2880 ntitle = 5 2881 open (unit=1, file=trim(header)//'paths.dat', 2882 > status='old', iostat=ios) 2883 call chopen (ios, trim(header)//'paths.dat', 'genfmt') 2884 call rdhead (1, ntitle, title, ltitle) 2885 if (ntitle .le. 0) then 2886 title(1) = ' ' 2887 ltitle(1) = 1 2888 endif 2889 2890c cgam = gamma in mean free path calc (eV). Set to zero in this 2891c version. Set it to whatever you want if you need it. 2892c cgam = 0 2893c cgam = cgam / ryd 2894c add cnst imag part to eref 2895c do 20 ie = 1, ne 2896c eref(ie) = eref(ie) - coni*cgam/2 2897c 20 continue 2898 2899 50 format (a) 2900 60 format (1x, a) 2901 70 format (1x, 79('-')) 2902 2903c Save filenames of feff.dat files for use by ff2chi 2904 open (unit=2, file=trim(header)//'files.dat', 2905 > status='unknown', iostat=ios) 2906 call chopen (ios, trim(header)//'files.dat', 'genfmt') 2907c Put phase header on top of files.dat 2908 do 100 itext = 1, ntext 2909 write(2,60) text(itext)(1:ltext(itext)) 2910 100 continue 2911 write(2,70) 2912 write(2,120) 2913 120 format (' file sig2 amp ratio ', 2914 1 'deg nlegs r effective') 2915 2916c Set crit0 for keeping feff.dat's 2917 if (ipr3 .le. 0) crit0 = 2*critcw/3 2918c Make a header for the running messages. 2919 write(77,130) critcw 2920 130 format (' Curved wave chi amplitude ratio', f7.2, '%') 2921 if (ipr3 .le. 0) write(77,131) crit0 2922 131 format (' Discard feff.dat for paths with cw ratio <', 2923 1 f7.2, '%') 2924 write(77,132) 2925 132 format (' path cw ratio deg nleg reff') 2926 2927c Set nlm factors in common /nlm/ for use later 2928 call snlm (ltot+1, mtot+1) 2929 2930 if (pola) then 2931c Make 3j factors in t3j (multiplied by sqrt(3*(2l0+1)) for 2932c further convinience - the same expression for chi) 2933c l0 - final momentum, initial momentum = l0-1. 2934 do 140 m0 = -l0+1,l0-1 2935 t3j(m0, 1) = (-1)**(l0+1+m0)*sqrt(3.0d0*(l0+m0)*(l0+m0+1) 2936 1 /(2*l0)/(2*l0-1)) 2937 t3j(m0, 0) = (-1)**(l0+m0)*sqrt(3.0d0*(l0*l0-m0*m0)/ 2938 1 l0/(2*l0-1)) 2939 140 continue 2940 do 145 m0 = -l0+1,l0-1 2941 t3j(m0,-1) = t3j(-m0,1) 2942 145 continue 2943 endif 2944 2945c While not done, read path, find feff. 2946 open (unit=4,file=trim(header)//'nstar.dat', 2947 > status='unknown', iostat=ios) 2948 write(4,198, iostat=ios) evec 2949 198 format('polarization ',3f8.4) 2950 write(4,199, iostat=ios) 2951 199 format('npath nstar') 2952 npath = 0 2953 ntotal = 0 2954 nused = 0 2955 xportx = -1 2956 200 continue 2957 2958c Read current path 2959 call rdpath (1, pola, done,xstar) 2960 icalc = iorder 2961 if (done) goto 1000 2962 npath = npath + 1 2963 ntotal = ntotal + 1 2964 2965 write (4,201,iostat=ios) npath, xstar 2966 201 format (i5, f8.4) 2967 2968c Need reff 2969 reff = 0 2970 do 220 i = 1, nleg 2971 reff = reff + ri(i) 2972 220 continue 2973 reff = reff/2 2974 2975c Set lambda for low k 2976 call setlam (icalc, 1) 2977 2978c Calculate and store rotation matrix elements 2979c Only need to go to (il0, il0, ...) for isc=nleg and 2980c nleg+1 (these are the paths that involve the 'z' atom 2981 call rot3i (il0, il0, nleg) 2982 do 400 isc = 1, nsc 2983 call rot3i (lmaxp1, mmaxp1, isc) 2984 400 continue 2985 if (pola) then 2986c one more rotation in polarization case 2987 call rot3i (il0, il0, nleg+1) 2988 call mmtr(t3j,mmati) 2989 endif 2990 2991 2992c Big energy loop 2993 do 800 ie = 1, ne 2994 2995c real momentum (k) 2996 xk(ie) = getxk (em(ie) - edge) 2997 2998c complex momentum (p) 2999 ck(ie) = sqrt (em(ie) - eref(ie)) 3000 ckmag(ie) = abs(ck(ie)) 3001c complex rho 3002 do 420 ileg = 1, nleg 3003 rho(ileg) = ck(ie) * ri(ileg) 3004 420 continue 3005 3006c if ck is zero, xafs is undefined. Make it zero and jump 3007c to end of calc part of loop. 3008 if (abs(ck(ie)) .le. eps) then 3009 cchi(ie) = 0 3010 goto 620 3011 endif 3012 3013c Calculate and store spherical wave factors c_l^(m)z^m/m! 3014c in a matrix clmi(il,im,ileg), ileg=1...nleg. 3015c Result is that common /clmz/ is updated for use by fmtrxi. 3016 3017c zero clmi arrays 3018 do 440 ileg = 1, legtot 3019 do 440 il = 1, ltot+1 3020 do 440 im = 1, mtot+ntot+1 3021 clmi(il,im,ileg) = 0 3022 440 continue 3023 3024 mnmxp1 = mmaxp1 + nmax 3025 3026 lxp1 = max (lmax(ie,ipot(1))+1, l0+1) 3027 mnp1 = min (lxp1, mnmxp1) 3028 call sclmz (rho, lxp1, mnp1, 1) 3029 3030 lxp1 = max (lmax(ie,ipot(nsc))+1, l0+1) 3031 mnp1 = min (lxp1, mnmxp1) 3032 call sclmz (rho, lxp1, mnp1, nleg) 3033 3034 do 460 ileg = 2, nleg-1 3035 isc0 = ileg-1 3036 isc1 = ileg 3037 lxp1 = max (lmax(ie,ipot(isc0))+1, lmax(ie,ipot(isc1))+1) 3038 mnp1 = min (lxp1, mnmxp1) 3039 call sclmz (rho, lxp1, mnp1, ileg) 3040 460 continue 3041 3042c Calculate and store scattering matrices fmati. 3043 3044 if (pola) then 3045c Polarization version, make new m matrix 3046c this will fill fmati(...,nleg) in common /fmtrxi/ 3047 call mmtrxi (laml0x, mmati, ie, 1, nleg) 3048 else 3049c Termination matrix, fmati(...,nleg) 3050 iterm = 1 3051 call fmtrxi (laml0x, laml0x, ie, iterm, 1, nleg) 3052 endif 3053 3054 iterm = -1 3055c First matrix 3056 call fmtrxi (lamx, laml0x, ie, iterm, 2, 1) 3057c Last matrix if needed 3058 if (nleg .gt. 2) then 3059 call fmtrxi (laml0x, lamx, ie, iterm, nleg, nleg-1) 3060 endif 3061c Intermediate scattering matrices 3062 do 480 ilegp = 2, nsc-1 3063 ileg = ilegp + 1 3064 call fmtrxi (lamx, lamx, ie, iterm, ileg, ilegp) 3065 480 continue 3066 3067c Big matrix multiplication loops. 3068c Calculates trace of matrix product 3069c M(1,N) * f(N,N-1) * ... * f(3,2) * f(2,1), as in reference. 3070c We will (equivalently) calculate the trace over lambda_N of 3071c f(N,N-1) * ... * f(3,2) * f(2,1) * M(1,N), working from 3072c right to left. 3073c Use only 2 pmati arrays, alternating indp (index p) 3074c 1 and 2. 3075 3076c f(2,1) * M(1,N) -> pmat(1) 3077 indp = 1 3078 do 520 lmp = 1, laml0x 3079 do 520 lm = 1, lamx 3080 pllp = 0 3081 do 500 lmi = 1, laml0x 3082 pllp = pllp + fmati(lm,lmi,1) * fmati(lmi,lmp,nleg) 3083 500 continue 3084 pmati(lm,lmp,indp)=pllp 3085 520 continue 3086 3087c f(N,N-1) * ... * f(3,2) * [f(2,1) * M(1,N)] 3088c Term in [] is pmat(1) 3089 do 560 isc = 2, nleg-1 3090c indp is current p matrix, indp0 is previous p matrix 3091 indp = 2 - mod(isc,2) 3092 indp0 = 1 + mod(indp,2) 3093 do 550 lmp = 1, laml0x 3094 do 550 lm = 1, lamx 3095 pllp=0 3096 do 540 lmi = 1, lamx 3097 pllp = pllp + 3098 1 fmati(lm,lmi,isc)*pmati(lmi,lmp,indp0) 3099 540 continue 3100 550 pmati(lm,lmp,indp) = pllp 3101 560 continue 3102 3103c Final trace over matrix 3104 ptrac=0 3105 do 580 lm = 1, laml0x 3106 ptrac = ptrac + pmati(lm,lm,indp) 3107 580 continue 3108 3109c Calculate xafs 3110c srho=sum pr(i), prho = prod pr(i) 3111 srho=0 3112 prho=1 3113 do 600 ileg = 1, nleg 3114 srho = srho + rho(ileg) 3115 prho = prho * rho(ileg) 3116 600 continue 3117c Complex chi (without 2kr term) 3118c ipot(nleg) is central atom 3119 cdel1 = exp(2*coni*ph(ie,il0,ipot(nleg))) 3120 cfac = cdel1 * exp(coni*(srho-2*xk(ie)*reff)) / prho 3121 3122 cchi(ie) = ptrac * cfac/(2*l0+1) 3123 3124c When ck(ie)=0, xafs is set to zero. Calc above undefined. 3125c Jump to here from ck(ie)=0 test above. 3126 620 continue 3127 3128c end of energy loop 3129 800 continue 3130 3131c Make importance factor, deg*(integral (|chi|*d|p|)) 3132c make ffmag (|chi|) 3133c xport importance factor 3134 do 810 ie = 1, ne 3135 ffmag(ie) = abs(cchi(ie)) 3136 810 continue 3137 3138c integrate from edge (ik0) to ne 3139 nemax = ne - ik0 + 1 3140 call feff_trap (ckmag(ik0), ffmag(ik0), nemax, xport) 3141 xport = abs(deg*xport) 3142 if (xport .gt. xportx) xportx = xport 3143 crit = 100 * xport / xportx 3144 3145c Write output if path is important enough (ie, path is 3146 3147c Write feff.dat if we need it. 3148 if (ipr3 .ge. 1 .or. crit .ge. crit0) then 3149c Prepare output file feffnnnn.dat (unit 3) 3150 write(fname,241) ipath 3151 241 format ('feff', i4.4, '.dat') 3152 open (unit=3, file=trim(header)//fname, 3153 > status='unknown', iostat=ios) 3154 call chopen (ios, trim(header)//fname, 'genfmt') 3155c put header on feff.dat 3156 do 245 itext = 1, ntext 3157 write(3,60) text(itext)(1:ltext(itext)) 3158 245 continue 3159 write(3,250) ipath, icalc, vfeff, vgenfm 3160 250 format (' Path', i5, ' icalc ', i7, t57, 2a12) 3161 write(3,70) 3162 write(3,290) nleg, deg, reff*bohr, rnrmav, edge*ryd 3163 290 format (1x, i3, f8.3, f9.4, f10.4, f11.5, 3164 1 ' nleg, deg, reff, rnrmav(bohr), edge') 3165 write(3,300) 3166 300 format (' x y z pot at#') 3167 write(3,310) (rat(j,nleg)*bohr,j=1,3), ipot(nleg), 3168 1 iz(ipot(nleg)), potlbl(ipot(nleg)) 3169 310 format (1x, 3f10.4, i3, i4, 1x, a6, ' absorbing atom') 3170 do 330 ileg = 1, nleg-1 3171 write(3,320) (rat(j,ileg)*bohr,j=1,3), ipot(ileg), 3172 1 iz(ipot(ileg)), potlbl(ipot(ileg)) 3173 320 format (1x, 3f10.4, i3, i4, 1x, a6) 3174 330 continue 3175 3176 write(3,340) 3177 340 format (' k real[2*phc] mag[feff] phase[feff]', 3178 1 ' red factor lambda real[p]@#') 3179 3180c Make the feff.dat stuff and write it to feff.dat 3181 do 900 ie = 1, ne 3182c Consider chi in the standard XAFS form. Use R = rtot/2. 3183 xlam = 1.0d10 3184 if (dabs(dimag(ck(ie))) .gt. eps) 3185 > xlam = 1.0d0/dimag(ck(ie)) 3186 redfac = exp(-2 * dimag (ph(ie,il0,ipot(nleg)))) 3187 cdelt = 2*dble(ph(ie,il0,ipot(nleg))) 3188 cfms = cchi(ie) * xk(ie) * reff**2 * 3189 1 exp(2*reff/xlam) / redfac 3190 if (abs(cchi(ie)) .lt. eps) then 3191 phff = 0 3192 else 3193 phff = atan2(dimag(cchi(ie)), dble(cchi(ie))) 3194 endif 3195c remove 2 pi jumps in phases 3196 if (ie .gt. 1) then 3197 call pijump (phff, phffo) 3198 call pijump (cdelt, cdelto) 3199 endif 3200 phffo = phff 3201 cdelto = cdelt 3202 3203c write 1 k, momentum wrt fermi level k=sqrt(p**2-kf**2) 3204c 2 central atom phase shift (real part), 3205c 3 magnitude of feff, 3206c 4 phase of feff, 3207c 5 absorbing atom reduction factor, 3208c 6 mean free path = 1/(Im (p)) 3209c 7 real part of local momentum p 3210 3211 write(3,640) 3212 1 xk(ie)/bohr, 3213 2 cdelt + l0*pi, 3214 3 abs(cfms) * bohr, 3215 4 phff - cdelt - l0*pi, 3216 5 redfac, 3217 6 xlam * bohr, 3218 7 dble(ck(ie))/bohr 3219 640 format (1x, f6.3, 1x, 3(1pe11.4,1x),0pe11.4,1x, 3220 1 2(1pe11.4,1x)) 3221 900 continue 3222 3223c Done with feff.dat 3224 close (unit=3) 3225 3226c Put feff.dat and stuff into files.dat 3227 write(2,820) fname, sig2g, crit, deg, 3228 1 nleg, reff*bohr 3229 820 format(1x, a, f8.5, 2f10.3, i6, f9.4) 3230 3231c Tell user about the path we just did 3232 write(77,210) ipath, crit, deg, nleg, reff*bohr 3233 210 format (3x, i4, 2f10.3, i6, f9.4) 3234 nused = nused+1 3235 3236 else 3237c path unimportant, tell user 3238 write(77,211) ipath, crit, deg, nleg, reff*bohr 3239 211 format (3x, i4, 2f10.3, i6, f9.4, ' neglected') 3240 endif 3241 3242c Do next path 3243 goto 200 3244 3245c Done with loop over paths 3246 1000 continue 3247c close paths.dat, files.dat 3248 close (unit=1) 3249 close (unit=2) 3250 close (unit=4) 3251 write(77,1010) nused, ntotal 3252 1010 format (1x, i4, ' paths kept, ', i4, ' examined.') 3253 3254 return 3255 end 3256 subroutine getorb (iz, ihole, ion, norb, norbco, 3257 1 den, nqn, nk, nel) 3258 3259 implicit double precision (a-h, o-z) 3260 3261 character*72 header 3262 common /header_common/ header 3263 3264 3265c Save internal variables in case this gets re-entered 3266 save 3267 3268c Gets orbital data for chosen element. Input is iz, atomic number 3269c of desired element, other arguments are output. 3270 3271c Written by Steven Zabinsky, July 1989 3272c 3273c last modified (20 aug 1989) table increased to at no 95 3274 3275c Table for each element has occupation of the various levels. 3276c The order of the levels in each array is: 3277 3278c element level principal qn (nqn), kappa qn (nk) 3279c 1 1s 1 -1 3280c 2 2s 2 -1 3281c 3 2p1/2 2 1 3282c 4 2p3/2 2 -2 3283c 5 3s 3 -1 3284c 6 3p1/2 3 1 3285c 7 3p3/2 3 -2 3286c 8 3d3/2 3 2 3287c 9 3d5/2 3 -3 3288c 10 4s 4 -1 3289c 11 4p1/2 4 1 3290c 12 4p3/2 4 -2 3291c 13 4d3/2 4 2 3292c 14 4d5/2 4 -3 3293c 15 4f5/2 4 3 3294c 16 4f7/2 4 -4 3295c 17 5s 5 -1 3296c 18 5p1/2 5 1 3297c 19 5p3/2 5 -2 3298c 20 5d3/2 5 2 3299c 21 5d5/2 5 -3 3300c 22 5f5/2 5 3 3301c 23 5f7/2 5 -4 3302c 24 6s 6 -1 3303c 25 6p1/2 6 1 3304c 26 6p3/2 6 -2 3305c 27 6d3/2 6 2 3306c 28 6d5/2 6 -3 3307c 29 7s 7 -1 3308 3309 dimension den(30), nqn(30), nk(30), nel(30) 3310 dimension kappa (29) 3311 dimension iocc (95, 29) 3312 dimension nnum (29) 3313c dimension ncore(95) 3314 3315c kappa quantum number for each orbital 3316c k = - (j + 1/2) if l = j - 1/2 3317c k = + (j + 1/2) if l = j + 1/2 3318 data kappa /-1,-1, 1,-2,-1, 1,-2, 2,-3,-1, 1,-2, 2,-3, 3, 3319 1 -4,-1, 1,-2, 2, -3, 3,-4,-1, 1, -2, 2,-3,-1/ 3320 3321c principal quantum number (energy eigenvalue) 3322 data nnum /1,2,2,2,3, 3,3,3,3,4, 4,4,4,4,4, 3323 1 4,5,5,5,5, 5,5,5,6,6, 6,6,6,7/ 3324 3325c number of core orbitals for z = 1 to 95 3326c data ncore 3327c 1 /0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 3328c 2 4, 4, 4, 4, 4, 4, 4, 4, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3329c 3 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3330c 4 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 16,16,16,16,16, 16,16,16,16,16, 3331c 5 16,16,16,16,16, 16,16,16,16,16, 16,16,16,16,16/ 3332 3333c occupation of each level for z = 1, 95 3334 data (iocc( 1,i),i=1,29) /1,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 3335 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3336 data (iocc( 2,i),i=1,29) /2,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 3337 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3338 data (iocc( 3,i),i=1,29) /2,1,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 3339 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3340 data (iocc( 4,i),i=1,29) /2,2,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 3341 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3342 data (iocc( 5,i),i=1,29) /2,2,1,0,0, 0,0,0,0,0, 0,0,0,0,0, 3343 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3344 data (iocc( 6,i),i=1,29) /2,2,2,0,0, 0,0,0,0,0, 0,0,0,0,0, 3345 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3346 data (iocc( 7,i),i=1,29) /2,2,2,1,0, 0,0,0,0,0, 0,0,0,0,0, 3347 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3348 data (iocc( 8,i),i=1,29) /2,2,2,2,0, 0,0,0,0,0, 0,0,0,0,0, 3349 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3350 data (iocc( 9,i),i=1,29) /2,2,2,3,0, 0,0,0,0,0, 0,0,0,0,0, 3351 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3352 data (iocc(10,i),i=1,29) /2,2,2,4,0, 0,0,0,0,0, 0,0,0,0,0, 3353 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3354 data (iocc(11,i),i=1,29) /2,2,2,4,1, 0,0,0,0,0, 0,0,0,0,0, 3355 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3356 data (iocc(12,i),i=1,29) /2,2,2,4,2, 0,0,0,0,0, 0,0,0,0,0, 3357 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3358 data (iocc(13,i),i=1,29) /2,2,2,4,2, 1,0,0,0,0, 0,0,0,0,0, 3359 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3360 data (iocc(14,i),i=1,29) /2,2,2,4,2, 2,0,0,0,0, 0,0,0,0,0, 3361 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3362 data (iocc(15,i),i=1,29) /2,2,2,4,2, 2,1,0,0,0, 0,0,0,0,0, 3363 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3364 data (iocc(16,i),i=1,29) /2,2,2,4,2, 2,2,0,0,0, 0,0,0,0,0, 3365 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3366 data (iocc(17,i),i=1,29) /2,2,2,4,2, 2,3,0,0,0, 0,0,0,0,0, 3367 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3368 data (iocc(18,i),i=1,29) /2,2,2,4,2, 2,4,0,0,0, 0,0,0,0,0, 3369 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3370 data (iocc(19,i),i=1,29) /2,2,2,4,2, 2,4,0,0,1, 0,0,0,0,0, 3371 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3372 data (iocc(20,i),i=1,29) /2,2,2,4,2, 2,4,0,0,2, 0,0,0,0,0, 3373 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3374 data (iocc(21,i),i=1,29) /2,2,2,4,2, 2,4,1,0,2, 0,0,0,0,0, 3375 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3376 data (iocc(22,i),i=1,29) /2,2,2,4,2, 2,4,2,0,2, 0,0,0,0,0, 3377 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3378 data (iocc(23,i),i=1,29) /2,2,2,4,2, 2,4,3,0,2, 0,0,0,0,0, 3379 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3380 data (iocc(24,i),i=1,29) /2,2,2,4,2, 2,4,4,1,1, 0,0,0,0,0, 3381 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3382 data (iocc(25,i),i=1,29) /2,2,2,4,2, 2,4,4,1,2, 0,0,0,0,0, 3383 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3384 data (iocc(26,i),i=1,29) /2,2,2,4,2, 2,4,4,2,2, 0,0,0,0,0, 3385 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3386 data (iocc(27,i),i=1,29) /2,2,2,4,2, 2,4,4,3,2, 0,0,0,0,0, 3387 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3388 data (iocc(28,i),i=1,29) /2,2,2,4,2, 2,4,4,4,2, 0,0,0,0,0, 3389 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3390 data (iocc(29,i),i=1,29) /2,2,2,4,2, 2,4,4,6,1, 0,0,0,0,0, 3391 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3392 data (iocc(30,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 0,0,0,0,0, 3393 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3394 data (iocc(31,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 1,0,0,0,0, 3395 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3396 data (iocc(32,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,0,0,0,0, 3397 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3398 data (iocc(33,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,1,0,0,0, 3399 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3400 data (iocc(34,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,2,0,0,0, 3401 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3402 data (iocc(35,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,3,0,0,0, 3403 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3404 data (iocc(36,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,0,0,0, 3405 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3406 data (iocc(37,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,0,0,0, 3407 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3408 data (iocc(38,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,0,0,0, 3409 1 0,2,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3410 data (iocc(39,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,1,0,0, 3411 1 0,2,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3412 data (iocc(40,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,2,0,0, 3413 1 0,2,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3414 data (iocc(41,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,0,0, 3415 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3416 data (iocc(42,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,1,0, 3417 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3418 data (iocc(43,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,1,0, 3419 1 0,2,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3420 data (iocc(44,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,3,0, 3421 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3422 data (iocc(45,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,4,0, 3423 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3424 data (iocc(46,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, 3425 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3426 data (iocc(47,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, 3427 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3428 data (iocc(48,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, 3429 1 0,2,0,0,0, 0,0,0,0,0, 0,0,0,0/ 3430 data (iocc(49,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, 3431 1 0,2,1,0,0, 0,0,0,0,0, 0,0,0,0/ 3432 data (iocc(50,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, 3433 1 0,2,2,0,0, 0,0,0,0,0, 0,0,0,0/ 3434 data (iocc(51,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, 3435 1 0,2,2,1,0, 0,0,0,0,0, 0,0,0,0/ 3436 data (iocc(52,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, 3437 1 0,2,2,2,0, 0,0,0,0,0, 0,0,0,0/ 3438 data (iocc(53,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, 3439 1 0,2,2,3,0, 0,0,0,0,0, 0,0,0,0/ 3440 data (iocc(54,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, 3441 1 0,2,2,4,0, 0,0,0,0,0, 0,0,0,0/ 3442 data (iocc(55,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, 3443 1 0,2,2,4,0, 0,0,0,1,0, 0,0,0,0/ 3444 data (iocc(56,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, 3445 1 0,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ 3446 data (iocc(57,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, 3447 1 0,2,2,4,1, 0,0,0,2,0, 0,0,0,0/ 3448 data (iocc(58,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,2, 3449 1 0,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ 3450 data (iocc(59,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,3, 3451 1 0,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ 3452 data (iocc(60,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,4, 3453 1 0,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ 3454 data (iocc(61,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,5, 3455 1 0,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ 3456 data (iocc(62,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 3457 1 0,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ 3458 data (iocc(63,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 3459 1 1,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ 3460 data (iocc(64,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 3461 1 1,2,2,4,1, 0,0,0,2,0, 0,0,0,0/ 3462 data (iocc(65,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 3463 1 3,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ 3464 data (iocc(66,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 3465 1 4,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ 3466 data (iocc(67,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 3467 1 5,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ 3468 data (iocc(68,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 3469 1 6,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ 3470 data (iocc(69,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 3471 1 7,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ 3472 data (iocc(70,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 3473 1 8,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ 3474 data (iocc(71,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 3475 1 8,2,2,4,1, 0,0,0,2,0, 0,0,0,0/ 3476 data (iocc(72,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 3477 1 8,2,2,4,2, 0,0,0,2,0, 0,0,0,0/ 3478 data (iocc(73,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 3479 1 8,2,2,4,3, 0,0,0,2,0, 0,0,0,0/ 3480 data (iocc(74,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 3481 1 8,2,2,4,4, 0,0,0,2,0, 0,0,0,0/ 3482 data (iocc(75,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 3483 1 8,2,2,4,4, 1,0,0,2,0, 0,0,0,0/ 3484 data (iocc(76,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 3485 1 8,2,2,4,4, 2,0,0,2,0, 0,0,0,0/ 3486 data (iocc(77,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 3487 1 8,2,2,4,4, 3,0,0,2,0, 0,0,0,0/ 3488 data (iocc(78,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 3489 1 8,2,2,4,4, 5,0,0,1,0, 0,0,0,0/ 3490 data (iocc(79,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 3491 1 8,2,2,4,4, 6,0,0,1,0, 0,0,0,0/ 3492 data (iocc(80,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 3493 1 8,2,2,4,4, 6,0,0,2,0, 0,0,0,0/ 3494 data (iocc(81,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 3495 1 8,2,2,4,4, 6,0,0,2,1, 0,0,0,0/ 3496 data (iocc(82,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 3497 1 8,2,2,4,4, 6,0,0,2,2, 0,0,0,0/ 3498 data (iocc(83,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 3499 1 8,2,2,4,4, 6,0,0,2,2, 1,0,0,0/ 3500 data (iocc(84,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 3501 1 8,2,2,4,4, 6,0,0,2,2, 2,0,0,0/ 3502 data (iocc(85,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 3503 1 8,2,2,4,4, 6,0,0,2,2, 3,0,0,0/ 3504 data (iocc(86,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 3505 1 8,2,2,4,4, 6,0,0,2,2, 4,0,0,0/ 3506 data (iocc(87,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 3507 1 8,2,2,4,4, 6,0,0,2,2, 4,0,0,1/ 3508 data (iocc(88,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 3509 1 8,2,2,4,4, 6,0,0,2,2, 4,0,0,2/ 3510 data (iocc(89,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 3511 1 8,2,2,4,4, 6,0,0,2,2, 4,1,0,2/ 3512 data (iocc(90,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 3513 1 8,2,2,4,4, 6,0,0,2,2, 4,2,0,2/ 3514 data (iocc(91,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 3515 1 8,2,2,4,4, 6,2,0,2,2, 4,1,0,2/ 3516 data (iocc(92,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 3517 1 8,2,2,4,4, 6,3,0,2,2, 4,1,0,2/ 3518 data (iocc(93,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 3519 1 8,2,2,4,4, 6,4,0,2,2, 4,1,0,2/ 3520 data (iocc(94,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 3521 1 8,2,2,4,4, 6,6,0,2,2, 4,0,0,2/ 3522 data (iocc(95,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 3523 1 8,2,2,4,4, 6,6,1,2,2, 4,0,0,2/ 3524 3525 if (iz .lt. 1 .or. iz .gt. 95) then 3526 write(77,*) ' Atomic number ', iz, ' not available.' 3527 stop 3528 endif 3529 3530 index = iz - ion 3531 if (ihole .gt. 0) then 3532 index = index + 1 3533c remove an electron from the level specified by ihole 3534 if (iocc(index,ihole) .lt. 1) then 3535 write(77,*) ' Cannot remove an electron from this level' 3536 stop 'GETORB-1' 3537 endif 3538 iocc(index,ihole) = iocc(index,ihole) - 1 3539 endif 3540 3541 norb = 0 3542 do 10 i = 1, 29 3543 if (iocc(index,i) .ne. 0) then 3544 norb = norb + 1 3545 nqn(norb) = nnum(i) 3546 nk(norb) = kappa(i) 3547 nel(norb) = iocc(index,i) 3548 den(norb) = 0.0d0 3549 endif 3550 10 continue 3551 3552c restore iocc array for neatness 3553 if (ihole .gt. 0) then 3554 iocc(index,ihole) = iocc(index,ihole) + 1 3555 endif 3556 3557 norbco = norb 3558 3559 return 3560 end 3561 double precision function getxk(e) 3562 implicit double precision (a-h, o-z) 3563 3564c Make xk from energy as 3565c k = sqrt( e) for e > 0 (above the edge) 3566c k = -sqrt(-e) for e < 0 (below the edge) 3567 3568 getxk = sqrt(abs(e)) 3569 if (e .lt. 0.0d0) getxk = - getxk 3570 return 3571 end 3572 subroutine sthead (ntitle, title, ltitle, nph, iz, rmt, rnrm, 3573 1 ion, ifrph, ihole, ixc, 3574 2 vr0, vi0, rs0, gamach, xmu, xf, vint, rs, 3575 3 nhead, lhead, head) 3576 3577c SeT HEAD 3578c This routine makes the file header, returned in head array. 3579c header lines do not include a leading blank. 3580c Last header line is not --------- end-of-header line 3581 3582c title lines coming into sthead include carriage control, since 3583c they were read from potph.dat 3584 3585 implicit double precision (a-h, o-z) 3586 3587 character*72 header 3588 common /header_common/ header 3589 3590 3591 parameter (pi = 3.1415926535897932384626433d0) 3592 parameter (one = 1, zero = 0) 3593 parameter (third = 1.0d0/3.0d0) 3594 parameter (raddeg = 180.0d0 / pi) 3595 complex*16 coni 3596 parameter (coni = (0.0d0,1.0d0)) 3597c kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37 3598 parameter (fa = 1.919158292677512811d0) 3599 3600 parameter (bohr = 0.529177249d0, ryd = 13.605698d0) 3601 parameter (alpinv = 137.03598956d0) 3602c fine structure alpha 3603 parameter (alphfs = 1.0d0 / alpinv) 3604c speed of light in louck's units (rydbergs?) 3605 parameter (clight = 2 * alpinv) 3606 3607 3608 parameter (nphx = 7) !max number of unique potentials (potph) 3609 parameter (npotx = nphx) !max number of unique potentials (genfmt, paths) 3610 parameter (nfrx = nphx) !max number of free atom types 3611 parameter (novrx = 8) !max number of overlap shells 3612 parameter (natx = 250) !max number of atoms in problem 3613 parameter (ltot = 24) !max number of ang mom (arrays 1:ltot+1) 3614 parameter (nrptx = 250) !Loucks r grid used through overlap 3615 parameter (nex = 100) !Number of energy points genfmt, etc. 3616 3617 parameter (lamtot=15) !Max number of distinct lambda's for genfmt 3618 !15 handles iord 2 and exact ss 3619 parameter (mtot=4, ntot=2) !vary mmax and nmax independently 3620 parameter (legtot=9) !matches path finder, used in GENFMT 3621 parameter (npatx = 8) !max number of path atoms, used in path 3622 !finder, NOT in genfmt 3623 3624 3625 dimension ifrph(0:nphx) 3626 dimension ion(0:nfrx) 3627 dimension iz(0:nfrx) 3628 dimension rmt(0:nphx) 3629 dimension rnrm(0:nphx) 3630 3631 character*80 title(ntitle) 3632 parameter (nheadx = 30) 3633 character*80 head(nheadx) 3634 dimension lhead(nheadx), ltitle(ntitle) 3635 3636 character*80 heada(nheadx) 3637 dimension lheada(nheadx) 3638 save nheada, lheada, heada 3639c heada, etc., are saved for use by entry wthead 3640 3641 character*10 shole(0:9) 3642 character*8 sout(0:6) 3643 common /labels/ shole, sout 3644 3645 character*12 vfeff, vpotph, vpaths, vgenfm, vff2ch 3646 common /vers/ vfeff, vpotph, vpaths, vgenfm, vff2ch 3647 3648c character*12 vfeff, vpotph, vpaths, vgenfm, vff2ch 3649c common /vers/ vfeff, vpotph, vpaths, vgenfm, vff2ch 3650 3651c FiLl head array with HEADer 3652c Fills head arrray, n = number of lines used. 3653c Does not include line of dashes at the end. 3654 3655 nhead = 1 3656 if (ntitle .ge. 1 .and. ltitle(1).gt.1) then 3657 write(head(nhead),100) title(1)(2:), vfeff, vpotph 3658 else 3659 write(head(nhead),102) vfeff, vpotph 3660 endif 3661 100 format(a55, t56, 2a12) 3662 102 format(t56, 2a12) 3663 do 120 ititle = 2, ntitle 3664 if (ltitle(ititle).le.1) goto 120 3665 nhead = nhead+1 3666 write(head(nhead),110) title(ititle)(2:) 3667 110 format(a79) 3668 120 continue 3669 if (ion(0) .ne. 0) then 3670 nhead = nhead+1 3671 write(head(nhead),130) iz(0), rmt(0)*bohr, 3672 1 rnrm(0)*bohr, ion(0), shole(ihole) 3673 else 3674 nhead = nhead+1 3675 write(head(nhead),140) iz(0), rmt(0)*bohr, 3676 1 rnrm(0)*bohr, shole(ihole) 3677 endif 3678 130 format('Abs Z=',i2,' Rmt=',f6.3,' Rnm=',f6.3,' Ion=',i2,1x,a10) 3679 140 format('Abs Z=',i2,' Rmt=',f6.3,' Rnm=',f6.3, 1x,a10) 3680 3681 do 150 iph = 1, nph 3682 ifr = ifrph(iph) 3683 if (ion(ifr) .ne. 0) then 3684 nhead = nhead+1 3685 write(head(nhead),160) iph, iz(ifr), rmt(iph)*bohr, 3686 1 rnrm(iph)*bohr, ion(ifr) 3687 else 3688 nhead = nhead+1 3689 write(head(nhead),170) iph, iz(ifr), rmt(iph)*bohr, 3690 1 rnrm(iph)*bohr 3691 endif 3692 150 continue 3693 160 format('Pot',i2,' Z=',i2,' Rmt=',f6.3,' Rnm=',f6.3,' Ion=',i2) 3694 170 format('Pot',i2,' Z=',i2,' Rmt=',f6.3,' Rnm=',f6.3) 3695 if (abs(vi0) .gt. 1.0d-8 .or. abs(vr0) .gt. 1.0d-8) then 3696 nhead = nhead+1 3697 write(head(nhead),180) gamach*ryd, sout(ixc), vi0*ryd, 3698 1 vr0*ryd 3699 else 3700 nhead = nhead+1 3701 write(head(nhead),190) gamach*ryd, sout(ixc) 3702 endif 3703 nhead = nhead+1 3704 180 format('Gam_ch=',1pe9.3, 1x,a8, ' Vi=',1pe10.3, ' Vr=',1pe10.3) 3705 190 format('Gam_ch=',1pe9.3, 1x,a8) 3706 200 format('Mu=',1pe10.3, ' kf=',1pe9.3, ' Vint=',1pe10.3, 3707 x ' Rs_int=',0pf6.3) 3708 write(head(nhead),200) xmu*ryd, xf/bohr, vint*ryd, rs 3709 if (ixc .eq. 4) then 3710 nhead = nhead+1 3711 write(head(nhead),210) rs0 3712 210 format ('Experimental DH-HL exch, rs0 = ', 1pe14.6) 3713 endif 3714 do 220 i = 1, nhead 3715 lhead(i) = istrln(head(i)) 3716 heada(i) = head(i) 3717 lheada(i) = lhead(i) 3718 220 continue 3719 nheada = nhead 3720 3721 return 3722 3723 entry wthead (io) 3724c Dump header to unit io, which must be open. Add carraige control 3725c to head array, which doesn't have it. 3726 3727 do 310 i = 1, nheada 3728 ll = lheada(i) 3729 write(io,300) heada(i)(1:ll) 3730 300 format (1x, a) 3731 310 continue 3732 end 3733c These heap routines maintain a heap (array h) and an index 3734c array (array ih) used to keep other data associated with the heap 3735c elements. 3736 3737 subroutine hup (h, ih, n) 3738 implicit double precision (a-h, o-z) 3739c heap is in order except for last element, which is new and must 3740c be bubbled through to its proper location 3741c new element is at i, j = index of parent 3742 integer n,i,j 3743 integer ih(n) 3744 dimension h(n) 3745 3746 3747 i = n 3748 3749 10 j = i/2 3750c if no parent, we're at the top of the heap, and done 3751 if (j .eq. 0) return 3752 if (h(i) .lt. h(j)) then 3753 call swapfeff (h(i), h(j)) 3754 call iswapfeff (ih(i), ih(j)) 3755 i = j 3756 goto 10 3757 endif 3758 return 3759 end 3760 3761 subroutine hdown (h, ih, n) 3762 implicit double precision (a-h, o-z) 3763c h is in order, except that 1st element has been replaced. 3764c Bubble it down to its proper location. New element is i, 3765c children are j and k. 3766 3767 integer n,i,j,k 3768 integer ih(n) 3769 dimension h(n) 3770 3771 i = 1 3772 3773 10 continue 3774 j = 2*i 3775 k = j + 1 3776 3777c if j > n, new element is at bottom, we're done 3778 if (j .gt. n) return 3779c handle case where new element has only one child 3780 if (k .gt. n) k = j 3781 3782 if (h(j) .gt. h(k)) j = k 3783c j is now index of smallest of children 3784 3785 if (h(i) .gt. h(j)) then 3786 call swapfeff (h(i), h(j)) 3787 call iswapfeff (ih(i), ih(j)) 3788 i = j 3789 goto 10 3790 endif 3791 3792 return 3793 end 3794 3795 subroutine swapfeff (a, b) 3796 implicit double precision (a-h, o-z) 3797 t = a 3798 a = b 3799 b = t 3800 return 3801 end 3802 3803 subroutine iswapfeff (i, j) 3804 implicit double precision (a-h, o-z) 3805 integer i,j,k 3806 k = i 3807 i = j 3808 j = k 3809 return 3810 end 3811 subroutine imhl (rs, xk, eim, icusp) 3812 implicit double precision (a-h,o-z) 3813 3814c what is xk? k**2 - mu + kf**2? 3815 3816c written by j. mustre (march 1988) 3817c code is based on analytical expression derived by john rehr. 3818c it leaves the real part, calculated in rhl unchanged. 3819c 3820c modified by j. rehr (oct 1991) - adds quinn approximation for 3821c losses due to electron-hole pairs below the plasmon turn on 3822c see new subroutine quinn.f, which incorporates r. albers coding of 3823c j.j. quinn's approximations for details. 3824 3825 3826 parameter (pi = 3.1415926535897932384626433d0) 3827 parameter (one = 1, zero = 0) 3828 parameter (third = 1.0d0/3.0d0) 3829 parameter (raddeg = 180.0d0 / pi) 3830 complex*16 coni 3831 parameter (coni = (0.0d0,1.0d0)) 3832c kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37 3833 parameter (fa = 1.919158292677512811d0) 3834 3835 parameter (bohr = 0.529177249d0, ryd = 13.605698d0) 3836 parameter (alpinv = 137.03598956d0) 3837c fine structure alpha 3838 parameter (alphfs = 1.0d0 / alpinv) 3839c speed of light in louck's units (rydbergs?) 3840 parameter (clight = 2 * alpinv) 3841 3842c alph is Hedin-Lundquist parameter 3843 parameter (alph = 4.0d0 / 3.0d0) 3844 external ffq 3845 3846 integer icount 3847 save icount 3848 data icount /0/ 3849 3850 icusp=0 3851 xf = fa / rs 3852 ef = xf**2 / 2 3853 3854c xk0 is xk normalized by k fermi. 3855 xk0 = xk/xf 3856c set to fermi level if below fermi level 3857 if (xk0 .lt. 1.00001d0) then 3858 xk0 = 1.00001d0 3859 endif 3860 3861c wp is given in units of the fermi energy in the formula below. 3862 wp = sqrt (3 / rs**3) / ef 3863 xs = wp**2 - (xk0**2 - 1)**2 3864 3865 eim = 0 3866 if (xs .lt. 0.0d0) then 3867 q2 = sqrt ( (sqrt(alph**2-4*xs) - alph) / 2 ) 3868 qu = min (q2, (1+xk0)) 3869 d1 = qu - (xk0 - 1) 3870 if (d1 .gt. 0) then 3871 eim = ffq (qu,ef,xk,wp,alph) - ffq (xk0-1,ef,xk,wp,alph) 3872 endif 3873 endif 3874 call cubic (xk0, wp, alph, rad, qplus, qminus) 3875 3876 if (rad .le. 0) then 3877 d2 = qplus - (xk0 + 1) 3878 if (d2 .gt. 0) then 3879 eim = eim + ffq (qplus,ef,xk,wp,alph) - 3880 1 ffq (xk0+1,ef,xk,wp,alph) 3881 endif 3882 d3 = (xk0-1) - qminus 3883 if (d3 .gt. 0) then 3884 eim = eim + ffq (xk0-1,ef,xk,wp,alph) - 3885 1 ffq (qminus,ef,xk,wp,alph) 3886c beginning of the imaginary part and position of the cusp x0 3887 icusp = 1 3888 endif 3889 endif 3890 3891 call quinn (xk0, rs, wp, ef, ei) 3892 if (eim .ge. ei) eim = ei 3893 3894 icount = icount+1 3895 return 3896 end 3897c major revision, input now comes from main program feff 3898c input data is passed here to indata for processing 3899 3900 subroutine indata (iz, ihole, wsin, ionin) 3901 3902 implicit double precision (a-h, o-z) 3903 save 3904 3905c logical unit from which to read input 3906 parameter (linp = 1) 3907 3908 common /print/ iprint 3909 common /atomco/ den(30), dq1(30), dfl(30), ws, nqn(30), nql(30), 3910 1 nk(30), nmax(30), nel(30), norb, norbco 3911 3912 common /dira/ dv(251), dr(251), dp(251), dq(251), dpas, tets, 3913 1 z, nstop, nes, np, nuc 3914 common /ps2/ dexv, dexe, dcop, test, teste, 3915 1 testy, testv, niter, ion, icut, iprat, irnorm 3916 3917 character*40 ttl 3918 character*2 titre 3919 common /char2/ titre(30), ttl 3920 3921 character*2 ttire(9) 3922 data ttire /'s ', 'p*', 'p ', 'd*', 'd ', 'f*', 'f ','g*', 'g '/ 3923 3924c following variables fixed as data by jm 4/20/87 3925 data i /0/ 3926 data j /0/ 3927 data k /0/ 3928 data l /0/ 3929 3930 idep = 0 3931 icut = 0 3932c Normal use, iprat = 1 3933 iprat = 1 3934 irnorm = 1 3935 iex = 1 3936 nuc = 0 3937 3938c idep=0 starting potential = thomas-fermi potential 3939c idep=1 starting potential read in from cards 3940c if icut is zero one corrects the potential by -(ion+1)/r 3941c if iprat is zero the pratt procedure is used 3942c if iex is zero one uses the unmodified slater exchange 3943c l=0 standard option for the bloc ofs points and their precision 3944c finite nuclear size option if nuc is positive 3945c if irnorm=1 renormalize potential to wigner-seitz radius 3946 3947 dvc=137.0373d0 3948 dsal=dvc+dvc 3949 iz1=0 3950 ion1=0 3951 nuc1=-1 3952 dpas=0.05d0 3953 dr1=0.01d0 3954 nes=15 3955 3956 niter=50 3957 3958c orig values: teste 5.e-6, testy 1.e-5, testv 1.e-5, test 1.e-7 3959c JM used teste 5.0e-5 to treat negative ion, 3960c SZ changed teste to 1.0e-4 for selenium only to avoid convergence 3961c problems with this particular atom. 3962c teste set to 1.0e-4 to reduce run time (sz and jjr) 3963 teste = 1.0d-4 3964 testy=1.d-04 3965 testv=1.d-04 3966 test=1.d-07 3967 3968 np=251 3969 nstop=30 3970 3971c Set dexv to zero for use with exafs model 3972 dexv = 0.0d0 3973 3974 dexe=1.5d0 3975 dcop=0.3d0 3976 3977c i, j, k set to zero when old read statements removed 3978 i=0 3979 j=0 3980 k=0 3981 3982c iz = atomic number 3983c ion = iz-number of electrons 3984c norb = number of orbitals 3985c idep = should be either 0 or 1 3986c i = number of points for the integration = 251 by default 3987c j = number of attempts to adjust the energy = 15 by default 3988c k = number of iterations = 50 by default 3989c norbco = number of core orbitals 3990 3991c put input data passed from feff into the necessary variables 3992 ws = wsin 3993 ion = ionin 3994c given iz, find norb, norbco, then den, nqn, nk and nel for 3995c each orbital. 3996 call getorb (iz, ihole, ion, norb, norbco, 3997 1 den, nqn, nk, nel) 3998 3999 if (norb .gt. nstop) then 4000 if (iprint .ge. 5) write(16,44) norb 4001 write(77,44) norb 4002 44 format (' norb=',i3,'too big') 4003 goto 999 4004 endif 4005 4006c dexv = exchange coefficient for the potential: dexv=1. for slater 4007c dexe = exchange energy coefficient 4008c dexv should be equal to 2.*dexe/3. in order to satisfy the virial theo 4009c dexv=0.0 and iex=1, hedin-barth exchange and correlation is used 4010 4011c dpas = exponential step; dr1 defines the first point = dr1/iz 4012c test = energy precision criteria in dirac 4013c teste = self-consistency criteria for the energies of all the electron 4014c testy = self-consistency criteria for the wavefunctions 4015c testv = self-consistency criteria for the potential 4016 z=iz 4017 4018 if (nuc .gt. 0) then 4019 write(77,118) 4020 118 format(' enter atomic mass ') 4021 read (linp,*,end=900) dval 4022c dval = atomic mass if nuc positive 4023 4024 dval=z*(dval**(1.0d0/3.0d0))*2.267700d-05/exp(4.0d0*dpas) 4025 if (dval .le. dr1) then 4026 dr1=dval 4027 nuc=5 4028 else 4029 dval=dval*exp(4.0d0*dpas) 4030 do 170 i=6,np 4031 d1=dr1*exp((i-1)*dpas) 4032 if (d1.ge.dval) goto 190 4033 170 continue 4034 write(77,180) 4035 if (iprint .ge. 5) write(16,180) 4036 180 format (' error for the atomic mass') 4037 goto 999 4038 4039 190 nuc=i 4040 dr1=dr1*dval/d1 4041 endif 4042 endif 4043 4044 if (iprint .ge. 5) write(16,210) ttl,niter,teste,testy,testv 4045 210 format (1h1,40x,A40,//,5x,'number of iterations',i4,//, 4046 1 5x,'precision of the energies',1pe9.2,//, 4047 2 23x,'wave functions ',1pe9.2,//, 4048 3 23x,'potential',1pe9.2,/) 4049 4050 xtmp = 8.8d0 4051 dr1=z*exp(-xtmp) 4052 4053 if (iprint .ge. 5) write(16,220) np,dr1,iz,dpas 4054 220 format (' the integration is made on ', i3, 4055 1 ' points-the first is equal to ' ,f7.4, '/', i2,/, 4056 2 ' and the step-size pas = ',f7.4,/) 4057 if (iprint .ge. 5) write(16,230) test,nes,idep,icut,iprat 4058 230 format (' dans le sous programme resld la precision relative a', 4059 1 ' obtenir sur l energie est ', 1pe9.2, 4060 2 ' et le nombre d essais ',i3, //, 4061 3 'idep=', i3, 5x, 'icut=', i3, 5x, 'iprat=', i3, /) 4062 if (iprint .ge. 5) write(16,240) dexv,dexe 4063 240 format (' dexv=', 1pe14.7, ' dexe=' ,1pe14.7, 4064 1 ' if dexv=0.0 hedin-barth corr. and exchan. is used'/) 4065 k=0 4066 dval=z*z/(dvc*dvc) 4067 4068 4069 if (nuc.gt.0) then 4070 if (iprint .ge. 5) write(16,250) 4071 250 format (1h0,30x,'finite nucleus case used'/) 4072 endif 4073 4074 do 350 i=1,norb 4075c den = orbital energy in atomic units and negative 4076c nqn = principal quantum number; nk = kappa quantum number 4077c nel = occupation of the orbital 4078 4079 k=k+nel(i) 4080 if (den(i) .ge. 0.0) den(i) = -z*z / (4.0*nqn(i)*nqn(i)) 4081 4082 nql(i)=iabs(nk(i)) 4083 4084 if (nk(i).lt.0) nql(i)=nql(i)-1 4085 if (nuc .le. 0) then 4086 dfl(i)=nk(i)*nk(i) 4087 dfl(i)=sqrt(dfl(i)-dval) 4088 else 4089 dfl(i)=iabs(nk(i)) 4090 endif 4091 l=2*iabs(nk(i)) 4092 4093 4094 if (nql(i).lt.nqn(i) .and. nel(i).le.l .and. 4095 1 nqn(i).gt.0 .and. nql(i).le.4) goto 340 4096 write(77,330) den(i),nqn(i),nql(i),j,nel(i) 4097 if (iprint .ge. 5) write(16,330) den(i),nqn(i),nql(i), 4098 1 j,nel(i) 4099 330 format (' error in the card ',e15.8,i2,3i2) 4100 goto 999 4101 340 continue 4102 j=nql(i)+iabs(nk(i)) 4103 titre(i)=ttire(j) 4104 if (iprint .ge. 5) write(16,345) nqn(i),titre(i),nel(i), 4105 1 den(i) 4106 345 format (7x,i1,a2,i16,1pe23.7) 4107 350 continue 4108 4109 if (iprint .ge. 5) write(16,370) norbco 4110 370 format (' no. of core orbitals=',i3) 4111 if (k.eq.(iz-ion)) goto 390 4112 write(77,380) 4113 if (iprint .ge. 5) write(16,380) 4114 380 format (' error for the number of electrons') 4115 goto 999 4116 390 continue 4117 4118 if (iprat .eq. 0) then 4119 if (iprint .ge. 5) write(16,410) 4120 410 format (1h0,' the pratt procedure is used'/) 4121 else 4122 if (iprint .ge. 5) write(16,430) ws 4123 430 format (1h0,' wigner-seitz radius = ',0pf10.6,/) 4124 endif 4125 4126 if (nuc .eq. nuc1) then 4127 if (iz.eq.iz1.and.ion.eq.ion1) goto 600 4128 if (iz.eq.iz1) goto 470 4129 endif 4130 4131c dr(1)=dr1/z 4132c do 460 i=2,np 4133c dr(i)=dr(1)*exp((i-1)*dpas) 4134c 460 continue 4135c Let's make this consistant with grid in other routines 4136c dr array commeted out above 4137c SIZ December 1990 4138 do 461 i = 1, 251 4139 dr(i) = rr(i) 4140 461 continue 4141 4142c starting potential 4143 4144 470 val=-ion-1 4145 4146c Following code is a block, block ends at line 600 4147 if (idep .eq. 1) then 4148 4149c read in starting potential (in a.u. and negative) if idep=1 4150 read (linp,480,end=900) (dv(i),i=1,np) 4151 480 format (8f9.4) 4152 4153 if (iprint .ge. 5) write(16,490) TTL,(dv(i),i=1,np) 4154 490 format (1h1, 40x, A40, //, 4155 1 5x, 'starting potential multiplied by r ' /, 4156 2 10(2x, f9.4)) 4157 dval = -z/dv(1) 4158 if (nuc.gt.0) dval = 1.0d0 4159 do 500 i=1,np 4160 dv(i)=dv(i)*dval/dr(i) 4161 500 continue 4162 4163 else 4164 4165 if (idep .ne. 0) then 4166 write(77,510) 4167 if (iprint .ge. 5) write(16,510) 4168 510 format (' error for idep') 4169 goto 999 4170 endif 4171 4172 if (iz.ne.iz1 .or . ion.le.ion1 .or. nuc.ne.nuc1) then 4173 do 520 i=1,np 4174 r=dr(i) 4175 dv(i)=fpot(r,z,val) 4176 520 continue 4177 if (nuc .gt. 0) then 4178 do 530 i=1,nuc 4179 dv(i) = dv(i) + z/dr(i) + 4180 1 z*((dr(i)/dr(nuc))**2-3.0)/(dr(nuc)+dr(nuc)) 4181 530 continue 4182 endif 4183 goto 600 4184 endif 4185 endif 4186 if (icut .eq. 0) then 4187 do 540 i=1,np 4188 if ((dr(i)*dv(i)).gt.val) dv(i)=val/dr(i) 4189 540 continue 4190 endif 4191 val=z+dv(1)*dr(1) 4192 if (nuc.gt.0) val=z+dv(nuc)*dr(nuc) 4193 if (abs(val) .ge. 0.1d0) then 4194 write(77,550) 4195 if (iprint .ge. 5) write(16,550) 4196 550 format (' error for the potential ') 4197 goto 999 4198 endif 4199 4200 600 continue 4201c End of block above 4202 4203 4204 if (norb .ne. 1) then 4205 do 620 i=2,norb 4206 k=i-1 4207 do 620 j=1,k 4208 if (nqn(i).eq.nqn(j) .and. nk(i).eq.nk(j)) then 4209 write(77,610) 4210 if (iprint .ge. 5) write(16,610) 4211 610 format (' standard configuration') 4212 goto 999 4213 endif 4214 620 continue 4215 endif 4216 4217 630 iz1=iz 4218 ion1=ion 4219 nuc1=nuc 4220 do 660 i=1,norb 4221 nmax(i)=np 4222 l=1 4223 j=nqn(i)-nql(i) 4224 if ((j-2*(j/2)).eq.0) l=-l 4225 dq1(i)=l*nk(i)/iabs(nk(i)) 4226 if (nuc .ne. 0 .and. nk(i) .lt. 0) then 4227 dq1(i)=dq1(i)*(nk(i)-dfl(i))*dvc/z 4228 endif 4229 660 continue 4230 4231 4232c -- Normal return 4233 return 4234 4235 4236c -- Error condition, stop program 4237 4238c Unexpected end of file during read -- stop program 4239 900 continue 4240 write(77,910) 4241 910 format (' Unexpected end of file') 4242 4243c Fatal error, stop gracefully (sic) 4244 999 continue 4245 stop 'INDATA-1' 4246 end 4247 subroutine inouh (dp,dq,dr,dq1,dfl,dv,z,test,nuc,nstop,jc) 4248c 4249c initial values for the outward integration 4250c dp=large component; dq=small component; dr=radial mesh 4251c dq1=slope at the origin of dp or dq; dfl=power of the first term 4252c du=developpement limite; dv=potential at the first point 4253c z=atomic number test=test of the precision 4254c finite nuclear size if nuc is non-zero 4255c nstop controls the convergence du developpement limite 4256c ********************************************************************** 4257 implicit double precision (a-h,o-z) 4258 save 4259 common /ps1/ dep(5), deq(5), dd, dvc, dsal, dk, dm 4260c 4261c dep,deq=derivatives of dp and dq; dd=energy/dvc; 4262c dvc=speed of light in a.u.; 4263c dsal=2.*dvc dk=kappa quantum number 4264c dm=exponential step/720. 4265c ********************************************************************** 4266 common /trois/ dpno(4,30), dqno(4,30) 4267 dimension dp(251), dq(251), dr(251) 4268 do 10 i=1,10 4269 dp(i)=0.0 4270 10 dq(i)=0.0 4271 if (nuc) 20,20,60 4272 20 dval=z/dvc 4273 deva1=-dval 4274 deva2=dv/dvc+dval/dr(1)-dd 4275 deva3=0.0 4276 if (dk) 30,30,40 4277 30 dbe=(dk-dfl)/dval 4278 go to 50 4279 40 dbe=dval/(dk+dfl) 4280 50 dq(10)=dq1 4281 dp(10)=dbe*dq1 4282 go to 90 4283 60 dval=dv+z*(3.0d0-dr(1)*dr(1)/(dr(nuc)*dr(nuc)))/(dr(nuc)+dr(nuc)) 4284 deva1=0.0d0 4285 deva2=(dval-3.0d0*z/(dr(nuc)+dr(nuc)))/dvc-dd 4286 deva3=z/(dr(nuc)*dr(nuc)*dr(nuc)*dsal) 4287 if (dk) 70,70,80 4288 70 dp(10)=dq1 4289 go to 90 4290 80 dq(10)=dq1 4291 90 do 100 i=1,5 4292 dp(i)=dp(10) 4293 dq(i)=dq(10) 4294 dep(i)=dp(i)*dfl 4295 100 deq(i)=dq(i)*dfl 4296 m=1 4297 110 dm=m+dfl 4298 dsum=dm*dm-dk*dk+deva1*deva1 4299 dqr=(dsal-deva2)*dq(m+9)-deva3*dq(m+7) 4300 dpr=deva2*dp(m+9)+deva3*dp(m+7) 4301 dval=((dm-dk)*dqr-deva1*dpr)/dsum 4302 dsum=((dm+dk)*dpr+deva1*dqr)/dsum 4303 j=-1 4304 do 130 i=1,5 4305 dpr=dr(i)**m 4306 dqr=dsum*dpr 4307 dpr=dval*dpr 4308 if (m.eq.1) go to 120 4309 120 dp(i)=dp(i)+dpr 4310 dq(i)=dq(i)+dqr 4311 if (abs(dpr/dp(i)).le.test.and.abs(dqr/dq(i)).le.test) j=1 4312 dep(i)=dep(i)+dpr*dm 4313 130 deq(i)=deq(i)+dqr*dm 4314 if (j.eq.1) go to 140 4315 dp(m+10)=dval 4316 dq(m+10)=dsum 4317 m=m+1 4318 if (m.le.20) go to 110 4319 nstop=45 4320 140 do 150 i=1,4 4321 dpno(i,jc)=dp(i+9) 4322 150 dqno(i,jc)=dq(i+9) 4323 return 4324 end 4325 subroutine inth (dp,dq,dv,dr) 4326c 4327c integration by the 5-point method of adams for the large 4328c component dp and the small component dq at the point dr; 4329c dv being the potential at this point 4330c ********************************************************************** 4331 implicit double precision (a-h,o-z) 4332 save 4333 common /ps1/ dep(5), deq(5), db, dvc, dsal, dk, dm 4334c 4335c dep,deq the derivatives of dp and dq; db=energy/dvc; 4336c dvc=speed of light in atomic units; dsal=2.*dvc; dk=kappa quantum numb 4337c dm=exponential step/720. 4338c dkoef1=405./502., dkoef2=27./502. 4339c ********************************************************************** 4340 data dkoef1 /0.9462151394422310d0/, dkoef2 /0.5378486055776890d-1/ 4341 dpr=dp+dm*((251.0d0*dep(1)+2616.0d0*dep(3) 4342 > +1901.0d0*dep(5))-(1274.0d0 4343 1 *dep(2)+2774.0d0*dep(4))) 4344 dqr=dq+dm*((251.0d0*deq(1)+2616.0d0*deq(3) 4345 > +1901.0d0*deq(5))-(1274.0d0 4346 1 *deq(2)+2774.0d0*deq(4))) 4347 do 10 i=2,5 4348 dep(i-1)=dep(i) 4349 10 deq(i-1)=deq(i) 4350 dsum=(db-dv/dvc)*dr 4351 dep(5)=-dk*dpr+(dsal*dr+dsum)*dqr 4352 deq(5)=dk*dqr-dsum*dpr 4353 dp=dp+dm*((106.0d0*dep(2)+646.0d0*dep(4) 4354 > +251.0d0*dep(5))-(19.0d0*dep(1 4355 1 )+264.0d0*dep(3))) 4356 dq=dq+dm*((106.0d0*deq(2)+646.0d0*deq(4) 4357 > +251.0d0*deq(5))-(19.0d0*deq(1 4358 1 )+264.0d0*deq(3))) 4359 dp=dkoef1*dp+dkoef2*dpr 4360 dq=dkoef1*dq+dkoef2*dqr 4361 dep(5)=-dk*dp+(dsal*dr+dsum)*dq 4362 deq(5)=dk*dq-dsum*dp 4363 return 4364 end 4365 subroutine intpol (a,b,fa,fb,fma,fmb,x,fx,fmx) 4366 implicit double precision (a-h,o-z) 4367c Only output is fx, fmx 4368 complex*16 fa,fb,fma,fmb,fx,fmx 4369 dx=b-a 4370 d=(x-a)/dx 4371c if (d*(1.0-d).lt.0.0) stop 'Died in intpol' 4372 if (d*(1.0d0-d).lt.0.0d0) then 4373 write(77,*) 'a, b, dx' 4374 write(77,*) a, b, dx 4375 write(77,*) 'x, x-a' 4376 write(77,*) x, x-a 4377 write(77,*) 'd, d*(1-d)' 4378 write(77,*) d, d*(1-d) 4379 stop 'Died in intpol' 4380 endif 4381 c2=3.0d0*(fb-fa)-(fmb+2.0d0*fma)*dx 4382 c3=2.0d0*(fa-fb)+(fma+fmb)*dx 4383 fx=fa+d*(dx*fma+d*(c2+d*c3)) 4384 fmx=fma+d*(2.0d0*c2+3.0d0*c3*d)/dx 4385 return 4386 end 4387 subroutine ipack (iout, n, ipat) 4388 implicit double precision (a-h, o-z) 4389 4390c Input: n number of things to pack, nmax=8 4391c ipat(1:n) integers to pack 4392c Output: iout(3) packed version of n and ipat(1:n) 4393c 4394c Packs n and ipat(1:n) into 3 integers, iout(1:3). Algorithm 4395c packs three integers (each between 0 and 1289 inclusive) into a 4396c single integer. Single integer must be INT*4 or larger, we assume 4397c that one bit is wasted as a sign bit so largest positive int 4398c is 2,147,483,647 = (2**31 - 1). 4399c This version is specifically for the path finder and 4400c degeneracy checker. 4401 4402 dimension iout(3), ipat(n) 4403 dimension itmp(8) 4404 parameter (ifac1 = 1290, ifac2 = 1290**2) 4405 4406 if (n .gt. 8) stop 'ipack n too big' 4407 4408 do 10 i = 1, n 4409 itmp(i) = ipat(i) 4410 10 continue 4411 do 20 i = n+1, 8 4412 itmp(i) = 0 4413 20 continue 4414 4415 iout(1) = n + itmp(1)*ifac1 + itmp(2)*ifac2 4416 iout(2) = itmp(3) + itmp(4)*ifac1 + itmp(5)*ifac2 4417 iout(3) = itmp(6) + itmp(7)*ifac1 + itmp(8)*ifac2 4418 4419 return 4420 end 4421 subroutine upack (iout, n, ipat) 4422 implicit double precision (a-h, o-z) 4423 4424c retrieve n and ipat from iout 4425c Input: iout(3) packed integers 4426c n max number to get, must be .le. 8 4427c Output: n number unpacked 4428c ipat(1:n) unpacked integers 4429 4430 dimension iout(3), ipat(n) 4431 dimension itmp(8) 4432 parameter (ifac1 = 1290, ifac2 = 1290**2) 4433 4434 nmax = n 4435 if (nmax .gt. 8) stop 'nmax .gt. 8 in upack' 4436 4437 n = mod (iout(1), ifac1) 4438 if (n .gt. nmax) stop 'nmax in upack too small' 4439 4440 itmp(1) = mod (iout(1), ifac2) / ifac1 4441 itmp(2) = iout(1) / ifac2 4442 itmp(3) = mod (iout(2), ifac1) 4443 itmp(4) = mod (iout(2), ifac2) / ifac1 4444 itmp(5) = iout(2) / ifac2 4445 itmp(6) = mod (iout(3), ifac1) 4446 itmp(7) = mod (iout(3), ifac2) / ifac1 4447 itmp(8) = iout(3) / ifac2 4448 4449 do 10 i = 1, n 4450 ipat(i) = itmp(i) 4451 10 continue 4452 4453 return 4454 end 4455 subroutine istprm(nph, nat, iphat, rat, iatph, xnatph, 4456 1 novr, iphovr, nnovr, rovr, folp, edens, 4457 2 vclap, vtot, imt, inrm, rmt, rnrm, 4458 2 rhoint, 4459 3 vint, rs, xf, xmu, rnrmav, intclc) 4460 4461c Finds interstitial parameters, rmt, vint, etc. 4462 implicit double precision (a-h, o-z) 4463 4464 4465 parameter (pi = 3.1415926535897932384626433d0) 4466 parameter (one = 1, zero = 0) 4467 parameter (third = 1.0d0/3.0d0) 4468 parameter (raddeg = 180.0d0 / pi) 4469 complex*16 coni 4470 parameter (coni = (0.0d0,1.0d0)) 4471c kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37 4472 parameter (fa = 1.919158292677512811d0) 4473 4474 parameter (bohr = 0.529177249d0, ryd = 13.605698d0) 4475 parameter (alpinv = 137.03598956d0) 4476c fine structure alpha 4477 parameter (alphfs = 1.0d0 / alpinv) 4478c speed of light in louck's units (rydbergs?) 4479 parameter (clight = 2 * alpinv) 4480 4481 4482 parameter (nphx = 7) !max number of unique potentials (potph) 4483 parameter (npotx = nphx) !max number of unique potentials (genfmt, paths) 4484 parameter (nfrx = nphx) !max number of free atom types 4485 parameter (novrx = 8) !max number of overlap shells 4486 parameter (natx = 250) !max number of atoms in problem 4487 parameter (ltot = 24) !max number of ang mom (arrays 1:ltot+1) 4488 parameter (nrptx = 250) !Loucks r grid used through overlap 4489 parameter (nex = 100) !Number of energy points genfmt, etc. 4490 4491 parameter (lamtot=15) !Max number of distinct lambda's for genfmt 4492 !15 handles iord 2 and exact ss 4493 parameter (mtot=4, ntot=2) !vary mmax and nmax independently 4494 parameter (legtot=9) !matches path finder, used in GENFMT 4495 parameter (npatx = 8) !max number of path atoms, used in path 4496 !finder, NOT in genfmt 4497 4498 4499 dimension iphat(natx) 4500 dimension rat(3,natx) 4501 dimension iatph(0:nphx) 4502 dimension xnatph(0:nphx) 4503 dimension novr(0:nphx) 4504 dimension iphovr(novrx,0:nphx) 4505 dimension nnovr(novrx,0:nphx) 4506 dimension rovr(novrx,0:nphx) 4507 dimension folp(0:nphx) 4508 dimension edens(nrptx,0:nphx) 4509 dimension vclap(nrptx,0:nphx) 4510 dimension vtot (nrptx,0:nphx) 4511 dimension imt(0:nphx) 4512 dimension inrm(0:nphx) 4513 dimension rmt(0:nphx) 4514 dimension rnrm(0:nphx) 4515 4516c intclc = 0, average evenly over all atoms 4517c 1, weight be lorentzian, 1 / (1 + 3*x**2), x = r/rnn, 4518c r = distance to central atom, 4519c rnn = distance of near neighbor to central atom 4520 4521c Find muffin tin radii. We'll find rmt based on norman prescription, 4522c ie, rmt(i) = R * folp * rnrm(i) / (rnrm(i) + rnrm(j)), 4523c a simple average 4524c based on atoms i and j. We average the rmt's from each pair of 4525c atoms, weighting by the volume of the lense shape formed by the 4526c overlap of the norman spheres. 4527c NB, if folp=1, muffin tins touch without overlap, folp>1 gives 4528c overlapping muffin tins. 4529c 4530c rnn is distance between sphere centers 4531c rnrm is the radius of the norman sphere 4532c xl_i is the distance to the plane containing the circle of the 4533c intersection 4534c h_i = rnrm_i - xl_i is the height of the ith atom's part of 4535c the lense 4536c vol_i = (pi/3)*(h_i**2 * (3*rnrm_i - h_i)) 4537c 4538c xl_i = (rnrm_i**2 - rnrm_j**2 + rnn**2) / (2*rnn) 4539 4540 do 140 iph = 0, nph 4541 voltot = 0 4542 rmtavg = 0 4543 if (novr(iph) .gt. 0) then 4544c Overlap explicitly defined by overlap card 4545 do 124 iovr = 1, novr(iph) 4546 rnn = rovr(iovr,iph) 4547 inph = iphovr(iovr,iph) 4548c Don't avg if norman spheres don't overlap 4549 if (rnrm(iph)+rnrm(inph) .le. rnn) goto 124 4550 voltmp = calcvl (rnrm(iph), rnrm(inph), rnn) 4551 voltmp = voltmp + calcvl (rnrm(inph), rnrm(iph), rnn) 4552 rmttmp = rnn * folp(iph) * rnrm(iph) / 4553 1 (rnrm(iph) + rnrm(inph)) 4554 ntmp = nnovr(iovr,iph) 4555 rmtavg = rmtavg + rmttmp*voltmp*ntmp 4556 voltot = voltot + voltmp*ntmp 4557 124 continue 4558 else 4559 iat = iatph(iph) 4560 do 130 inat = 1, nat 4561 if (inat .eq. iat) goto 130 4562 rnn = feff_dist(rat(1,inat), rat(1,iat)) 4563 inph = iphat(inat) 4564c Don't avg if norman spheres don't overlap 4565 if (rnrm(iph)+rnrm(inph) .lt. rnn) goto 130 4566 voltmp = calcvl (rnrm(iph), rnrm(inph), rnn) 4567 voltmp = voltmp + calcvl (rnrm(inph), rnrm(iph), rnn) 4568 rmttmp = rnn * folp(iph) * rnrm(iph) / 4569 1 (rnrm(iph) + rnrm(inph)) 4570 rmtavg = rmtavg + rmttmp*voltmp 4571 voltot = voltot + voltmp 4572 130 continue 4573 endif 4574 if (rmtavg .le. 0.0d0) then 4575 write(77,132) iat, iph 4576 132 format (' WARNING: NO ATOMS CLOSE ENOUGH TO OVERLAP ATOM', 4577 1 i5, ', UNIQUE POT', i5, '!!', /, 4578 2 ' Rmt set to Rnorman. May be error in ', 4579 3 'input file.') 4580 rmt(iph) = rnrm(iph) 4581 else 4582 rmt(iph) = rmtavg / voltot 4583 endif 4584 140 continue 4585 4586c Need potential with ground state xc, put it into vtot 4587 do 160 iph = 0, nph 4588 call sidx (edens(1,iph), 250, rmt(iph), rnrm(iph), 4589 1 imax, imt(iph), inrm(iph)) 4590 do 150 i = 1, imax 4591 rs = (edens(i,iph)/3)**(-third) 4592c vhedbr from Von Barth Hedin paper, 1971 4593 vhedbr = -1.22177412d0/rs - 0.0504d0*log(30.0d0/rs + 1) 4594 vtot(i,iph) = vclap(i,iph) + vhedbr 4595 150 continue 4596 160 continue 4597 4598c What to do about interstitial values? 4599c Calculate'em for all atoms, print'em out for all unique pots along 4600c with derivative quantities, like fermi energy, etc. 4601c Interstitial values will be average over all atoms in problem. 4602 4603c rnrmav is averge norman radius, 4604c (4pi/3)rnrmav**3 = (sum((4pi/3)rnrm(i)**3)/n, sum over all atoms 4605c in problem 4606 rnrmav = 0.0d0 4607 xn = 0.0d0 4608 rs = 0.0d0 4609 vint = 0.0d0 4610 rhoint = 0.0d0 4611c volint is total interstitial volume 4612 volint = 0 4613 4614 do 170 iph = 0, nph 4615c Use all atoms 4616 call istval(vtot(1,iph), edens(1,iph), rmt(iph), imt(iph), 4617 2 rnrm(iph), inrm(iph), vintx, rhintx, ierr) 4618c if no contribution to interstitial region, skip this unique pot 4619 if (ierr .ne. 0) goto 170 4620 call fermi (rhintx, vintx, xmu, rs, xf) 4621c (factor 4pi/3 cancel in numerator and denom, so leave out) 4622 volx = (rnrm(iph)**3 - rmt(iph)**3) 4623 if (volx .le. 0) goto 170 4624 volint = volint + volx * xnatph(iph) 4625 vint = vint + vintx * volx * xnatph(iph) 4626 rhoint = rhoint + rhintx* volx * xnatph(iph) 4627 170 continue 4628c If no contribution to interstitial from any atom, die. 4629 if (volint .le. 0) then 4630 write(77,*) ' No interstitial density. Check input file.' 4631 stop 'ISTPRM' 4632 endif 4633 vint = vint / volint 4634 rhoint = rhoint / volint 4635 call fermi (rhoint, vint, xmu, rs, xf) 4636 do 180 iph = 0, nph 4637 rnrmav = rnrmav + xnatph(iph) * rnrm(iph)**3 4638 xn = xn + xnatph(iph) 4639 180 continue 4640 rnrmav = (rnrmav/xn) ** third 4641 4642 4643 return 4644 end 4645 4646 double precision function calcvl(r1, r2, r) 4647 implicit double precision (a-h, o-z) 4648 4649 parameter (pi = 3.1415926535897932384626433d0) 4650 parameter (one = 1, zero = 0) 4651 parameter (third = 1.0d0/3.0d0) 4652 parameter (raddeg = 180.0d0 / pi) 4653 complex*16 coni 4654 parameter (coni = (0.0d0,1.0d0)) 4655c kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37 4656 parameter (fa = 1.919158292677512811d0) 4657 4658 parameter (bohr = 0.529177249d0, ryd = 13.605698d0) 4659 parameter (alpinv = 137.03598956d0) 4660c fine structure alpha 4661 parameter (alphfs = 1.0d0 / alpinv) 4662c speed of light in louck's units (rydbergs?) 4663 parameter (clight = 2 * alpinv) 4664 4665 xl = (r1**2 - r2**2 + r**2) / (2*r) 4666 h = r1 - xl 4667 calcvl = (pi/3) * h**2 * (3*r1 - h) 4668 return 4669 end 4670 subroutine istval (vtot, rholap, rmt, imt, rws, iws, vint, rhoint, 4671 1 ierr) 4672 4673c This subroutine calculates interstitial values of v and rho 4674c for an overlapped atom. Inputs are everything except vint and 4675c rhoint, which are returned. vtot includes ground state xc. 4676c rhoint is form density*4*pi, same as rholap 4677c 4678c ierr = 0, normal exit 4679c =-1, rmt=rws, no calculation possible 4680 4681 implicit double precision (a-h, o-z) 4682 4683 4684 parameter (nphx = 7) !max number of unique potentials (potph) 4685 parameter (npotx = nphx) !max number of unique potentials (genfmt, paths) 4686 parameter (nfrx = nphx) !max number of free atom types 4687 parameter (novrx = 8) !max number of overlap shells 4688 parameter (natx = 250) !max number of atoms in problem 4689 parameter (ltot = 24) !max number of ang mom (arrays 1:ltot+1) 4690 parameter (nrptx = 250) !Loucks r grid used through overlap 4691 parameter (nex = 100) !Number of energy points genfmt, etc. 4692 4693 parameter (lamtot=15) !Max number of distinct lambda's for genfmt 4694 !15 handles iord 2 and exact ss 4695 parameter (mtot=4, ntot=2) !vary mmax and nmax independently 4696 parameter (legtot=9) !matches path finder, used in GENFMT 4697 parameter (npatx = 8) !max number of path atoms, used in path 4698 !finder, NOT in genfmt 4699 4700 parameter (delta = 0.050000000000000d0) 4701 4702 dimension vtot (nrptx) 4703 dimension rholap (nrptx) 4704 4705c Integrations are done in x (r = exp(x), see Louck's grid) 4706c Trapezoidal rule, end caps use linear interpolation. 4707c imt is grid point immediately below rmt, etc. 4708c We will integrate over spherical shell and divide by volume of 4709c shell, so leave out factor 4pi, vol = r**3/3, not 4pi*r**3/3, 4710c similarly leave out 4pi in integration. 4711 4712c If rmt and rws are the same, cannot contribute to interstitial 4713c stuff, set error flag 4714 vol = (rws**3 - rmt**3) / 3.0d0 4715 if (vol .le. 0.0d0) then 4716 ierr = -1 4717 return 4718 endif 4719 ierr = 0 4720 4721c Calculation of vint including exchange correlation 4722c Trapezoidal rule from imt+1 to iws 4723 vint = 0.0d0 4724 do 100 i = imt, iws-1 4725 fr = rr(i+1)**3 * vtot(i+1) 4726 fl = rr(i)**3 * vtot(i) 4727 vint = vint + (fr+fl)*delta/2.0d0 4728 100 continue 4729c End cap at rws (rr(iws) to rws) 4730 xws = log (rws) 4731 xiws = xx(iws) 4732 g = xws - xiws 4733 fr = rr(iws+1)**3 * vtot(iws+1) 4734 fl = rr(iws)**3 * vtot(iws) 4735 vint = vint + (g/2.0d0) * ( (2.0d0-(g/delta))*fl + (g/delta)*fr) 4736c End cap at rmt (rmt to rr(imt+1)) 4737 xmt = log (rmt) 4738 ximt = xx(imt) 4739 g = xmt - ximt 4740 fr = rr(imt+1)**3 * vtot(imt+1) 4741 fl = rr(imt)**3 * vtot(imt) 4742 vint = vint - (g/2.0d0) * ( (2.0d0-(g/delta))*fl + (g/delta)*fr) 4743 vint = vint / vol 4744 4745c Calculation of rhoint 4746c Trapezoidal rule from imt+1 to iws 4747 rhoint = 0 4748 do 200 i = imt, iws-1 4749 fr = rr(i+1)**3 * rholap(i+1) 4750 fl = rr(i)**3 * rholap(i) 4751 rhoint = rhoint + (fr+fl)*delta/2.0d0 4752 200 continue 4753c End cap at rws (rr(iws) to rws) 4754 xws = log (rws) 4755 xiws = xx(iws) 4756 g = xws - xiws 4757 fr = rr(iws+1)**3 * rholap(iws+1) 4758 fl = rr(iws)**3 * rholap(iws) 4759 rhoint = rhoint + (g/2.0d0) 4760 > * ( (2.0d0-(g/delta))*fl + (g/delta)*fr) 4761c End cap at rmt (rmt to rr(imt+1)) 4762 xmt = log (rmt) 4763 ximt = xx(imt) 4764 g = xmt - ximt 4765 fr = rr(imt+1)**3 * rholap(imt+1) 4766 fl = rr(imt)**3 * rholap(imt) 4767 rhoint = rhoint - (g/2.0d0) 4768 > * ( (2.0d0-(g/delta))*fl + (g/delta)*fr) 4769 rhoint = rhoint / vol 4770 4771 return 4772 end 4773 subroutine mcrith (npat, ipat, ri, indbet, 4774 1 ipot, nncrit, fbetac, ckspc, xheap) 4775 implicit double precision (a-h, o-z) 4776 4777 4778 parameter (pi = 3.1415926535897932384626433d0) 4779 parameter (one = 1, zero = 0) 4780 parameter (third = 1.0d0/3.0d0) 4781 parameter (raddeg = 180.0d0 / pi) 4782 complex*16 coni 4783 parameter (coni = (0.0d0,1.0d0)) 4784c kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37 4785 parameter (fa = 1.919158292677512811d0) 4786 4787 parameter (bohr = 0.529177249d0, ryd = 13.605698d0) 4788 parameter (alpinv = 137.03598956d0) 4789c fine structure alpha 4790 parameter (alphfs = 1.0d0 / alpinv) 4791c speed of light in louck's units (rydbergs?) 4792 parameter (clight = 2 * alpinv) 4793 4794 4795 parameter (nphx = 7) !max number of unique potentials (potph) 4796 parameter (npotx = nphx) !max number of unique potentials (genfmt, paths) 4797 parameter (nfrx = nphx) !max number of free atom types 4798 parameter (novrx = 8) !max number of overlap shells 4799 parameter (natx = 250) !max number of atoms in problem 4800 parameter (ltot = 24) !max number of ang mom (arrays 1:ltot+1) 4801 parameter (nrptx = 250) !Loucks r grid used through overlap 4802 parameter (nex = 100) !Number of energy points genfmt, etc. 4803 4804 parameter (lamtot=15) !Max number of distinct lambda's for genfmt 4805 !15 handles iord 2 and exact ss 4806 parameter (mtot=4, ntot=2) !vary mmax and nmax independently 4807 parameter (legtot=9) !matches path finder, used in GENFMT 4808 parameter (npatx = 8) !max number of path atoms, used in path 4809 !finder, NOT in genfmt 4810 4811 dimension ipat(npatx) 4812 dimension ri(npatx+1), indbet(npatx+1) 4813 dimension ipot(0:natx) 4814 parameter (necrit=9, nbeta=40) 4815 dimension fbetac(-nbeta:nbeta,0:npotx,necrit), ckspc(necrit) 4816 4817c Decide if we want the path added to the heap. 4818 4819 if (ipat(npat) .eq. 0 .or. npat.le.2) then 4820c Partial path is used for xheap, not defined for ss and 4821c triangles. Special case: central atom added to end of path 4822c necessary for complete tree, but not a real path, again, 4823c xheap not defined. Return -1 as not-defined flag. 4824 xheap = -1 4825 else 4826c Calculate xheap and see if we want to add path to heap. 4827c Factor for comparison is sum over nncrit of 4828c f(beta1)*f(beta2)*..*f(beta npat-2)/(rho1*rho2*..*rho npat-1). 4829c Compare this to sum(1/p), multiply by 100 so we can think 4830c in percent. Allow for degeneracy when setting crit. 4831 xheap = 0 4832 spinv = 0 4833 do 340 icrit = 1, nncrit 4834 x = ckspc(icrit) ** (-(npat-1)) * ri(npat-1) 4835 do 320 i = 1, npat-2 4836 ipot0 = ipot(ipat(i)) 4837 x = x * fbetac(indbet(i),ipot0,icrit) / ri(i) 4838 320 continue 4839 spinv = spinv + 1/ckspc(icrit) 4840 xheap = xheap + x 4841 340 continue 4842 xheap = 100 * xheap / spinv 4843 4844c Factor for comparison is sum over nncrit of 4845c New xheap: 4846c Full chi is 4847c f(beta1)*f(beta2)*..*f(beta npat)cos(beta0)/(rho1*rho2*..*rho nleg). 4848c Some of this stuff may change when the path is modified -- 4849c we can't use rho nleg or nleg-1, beta0, beta(npat) or beta(npat-1). 4850c We DO want to normalize wrt first ss path, f(pi)/(rho nn)**2. 4851c 4852c So save f(pi)/(rho nn)**2, 4853c calculate 4854c f(beta1)*f(beta2)*..*f(beta npat-2)/(rho1*rho2*..*rho npat-1). 4855c divide nn ss term by stuff we left out -- beta(npat), beta(npat-1), 4856c cos(beta0), rho nleg, rho nleg-1. 4857c 4858c Sum this over nncrit and try it out. 4859* 4860c Sum over nncrit of 4861c 1/(rho1+rho2+..+rho npat-1). 4862* reff = 0 4863* do 350 i = 1, npat-1 4864* reff = reff + ri(i) 4865* 350 continue 4866* xss = 0 4867* do 360 icrit = 1, nncrit 4868* rho = ckspc(icrit) * reff 4869* xss = xss + 1/rho 4870* 360 continue 4871* xheap = 100 * xheap / xss 4872 endif 4873 4874 return 4875 end 4876 subroutine mcritk (npat, ipat, ri, beta, indbet, 4877 1 ipot, nncrit, fbetac, ckspc, xout, xcalcx) 4878 implicit double precision (a-h, o-z) 4879 4880 4881 parameter (pi = 3.1415926535897932384626433d0) 4882 parameter (one = 1, zero = 0) 4883 parameter (third = 1.0d0/3.0d0) 4884 parameter (raddeg = 180.0d0 / pi) 4885 complex*16 coni 4886 parameter (coni = (0.0d0,1.0d0)) 4887c kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37 4888 parameter (fa = 1.919158292677512811d0) 4889 4890 parameter (bohr = 0.529177249d0, ryd = 13.605698d0) 4891 parameter (alpinv = 137.03598956d0) 4892c fine structure alpha 4893 parameter (alphfs = 1.0d0 / alpinv) 4894c speed of light in louck's units (rydbergs?) 4895 parameter (clight = 2 * alpinv) 4896 4897 4898 parameter (nphx = 7) !max number of unique potentials (potph) 4899 parameter (npotx = nphx) !max number of unique potentials (genfmt, paths) 4900 parameter (nfrx = nphx) !max number of free atom types 4901 parameter (novrx = 8) !max number of overlap shells 4902 parameter (natx = 250) !max number of atoms in problem 4903 parameter (ltot = 24) !max number of ang mom (arrays 1:ltot+1) 4904 parameter (nrptx = 250) !Loucks r grid used through overlap 4905 parameter (nex = 100) !Number of energy points genfmt, etc. 4906 4907 parameter (lamtot=15) !Max number of distinct lambda's for genfmt 4908 !15 handles iord 2 and exact ss 4909 parameter (mtot=4, ntot=2) !vary mmax and nmax independently 4910 parameter (legtot=9) !matches path finder, used in GENFMT 4911 parameter (npatx = 8) !max number of path atoms, used in path 4912 !finder, NOT in genfmt 4913 4914 dimension ipat(npatx) 4915 dimension ri(npatx+1), beta(npatx+1), indbet(npatx+1) 4916 dimension ipot(0:natx) 4917 parameter (necrit=9, nbeta=40) 4918 dimension fbetac(-nbeta:nbeta,0:npotx,necrit), ckspc(necrit) 4919 4920c xcalcx is max xcalc encountered so far. Set to -1 to reset it -- 4921c otherwise it gets passed in and out as mcritk gets called. 4922 4923c We may want path in heap so that other paths built from this 4924c path will be considered, but do not want this path to be 4925c written out for itself. Decide that now and save the flag 4926c in the heap, so we won't have to re-calculate the mpprm 4927c path parameters later. 4928 4929c Do not want it for output if last atom is central atom, 4930c use xout = -1 as flag for undefined, don't keep it. 4931 if (ipat(npat) .eq. 0) then 4932 xout = -1 4933 return 4934 endif 4935 4936c Make xout, output inportance factor. This is sum over p of 4937c (product of f(beta)/rho for the scatterers) * 4938c (cos(beta0)/rho(npat+1). 4939c Compare this to xoutx, max xout encountered so far. 4940c Multiply by 100 so we can think in percent. 4941 xcalc = 0 4942 do 460 icrit = 1, nncrit 4943 rho = ri(npat+1) * ckspc(icrit) 4944c when beta(0)=90 degrees, get zero, so fudge with cos=.2 4945 x = max (abs(beta(npat+1)), 0.2d0) / rho 4946 do 420 iat = 1, npat 4947 rho = ri(iat) * ckspc(icrit) 4948 ipot0 = ipot(ipat(iat)) 4949 x = x * fbetac(indbet(iat),ipot0,icrit) / rho 4950 420 continue 4951 xcalc = xcalc + x 4952 460 continue 4953 if (xcalc .gt. xcalcx) xcalcx = xcalc 4954 xout = 100 * xcalc / xcalcx 4955 return 4956 end 4957 subroutine mkptz 4958c makes polarization temsor ptz if necessary 4959 implicit double precision (a-h, o-z) 4960 4961c all input and output through common area /pol/ 4962 4963c global polarization data 4964 logical pola 4965 double precision evec,ivec,elpty 4966 complex*16 ptz 4967 common /pol/ evec(3), ivec(3), elpty, ptz(-1:1,-1:1), pola 4968 4969 4970 parameter (pi = 3.1415926535897932384626433d0) 4971 parameter (one = 1, zero = 0) 4972 parameter (third = 1.0d0/3.0d0) 4973 parameter (raddeg = 180.0d0 / pi) 4974 complex*16 coni 4975 parameter (coni = (0.0d0,1.0d0)) 4976c kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37 4977 parameter (fa = 1.919158292677512811d0) 4978 4979 parameter (bohr = 0.529177249d0, ryd = 13.605698d0) 4980 parameter (alpinv = 137.03598956d0) 4981c fine structure alpha 4982 parameter (alphfs = 1.0d0 / alpinv) 4983c speed of light in louck's units (rydbergs?) 4984 parameter (clight = 2 * alpinv) 4985 4986 4987c addittonal local stuff to create polarization tensor ptz(i,j) 4988 real*8 e2(3) 4989 complex*16 e(3),eps,epc 4990 dimension eps(-1:1),epc(-1:1) 4991 4992 4993c Begin to make polarization tensor 4994c Normalize polarization vector 4995 x = sqrt(evec(1)**2 + evec(2)**2 + evec(3)**2) 4996 if (x .eq. 0.0d0) then 4997 write(77,*) 'STOP Polarization vector of zero length' 4998 stop 4999 endif 5000 do 290 i = 1, 3 5001 evec(i) = evec(i) / x 5002 290 continue 5003 if (elpty .eq. 0.0d0) then 5004c run linear polarization code 5005 do 291 i = 1, 3 5006 ivec(i) = 0.0d0 5007 291 continue 5008 endif 5009 x = sqrt (ivec(1)**2 + ivec(2)**2 + ivec(3)**2) 5010 if (x .gt. 0) then 5011c run elliptical polarization code 5012 do 293 i = 1, 3 5013 ivec(i) = ivec(i) / x 5014 293 continue 5015 x = evec(1)*ivec(1)+evec(2)*ivec(2)+evec(3)*ivec(3) 5016 if (abs(x) .gt. 0.9d0) then 5017 write(77,*) 5018 1 'STOP polarization almost parallel to the incidence' 5019 write(77,*) ' polarization',(evec(i), i=1,3) 5020 write(77,*) ' incidence ',(ivec(i), i=1,3) 5021 write(77,*) ' dot product ', x 5022 stop 5023 endif 5024 if (x .ne. 0.0d0) then 5025c if ivec not normal to evec then make in normal, keeping the 5026c plane based on two vectors 5027 do 294 i = 1,3 5028 ivec(i) = ivec(i) - x*evec(i) 5029 294 continue 5030 x = sqrt (ivec(1)**2 + ivec(2)**2 + ivec(3)**2) 5031 do 295 i = 1, 3 5032 ivec(i) = ivec(i) / x 5033 295 continue 5034 endif 5035 else 5036 elpty = 0.0 5037 endif 5038 5039 e2(1) = ivec(2)*evec(3)-ivec(3)*evec(2) 5040 e2(2) = ivec(3)*evec(1)-ivec(1)*evec(3) 5041 e2(3) = ivec(1)*evec(2)-ivec(2)*evec(1) 5042 do 296 i = 1,3 5043 e(i) = (evec(i)+elpty*e2(i)*coni) 5044 296 continue 5045 eps(-1) = (e(1)-coni*e(2))/sqrt(2.0) 5046 eps(0) = e(3) 5047 eps(1) = -(e(1)+coni*e(2))/sqrt(2.0) 5048 do 297 i = 1,3 5049 e(i) = (evec(i)-elpty*e2(i)*coni) 5050 297 continue 5051 epc(-1) = (e(1)-coni*e(2))/sqrt(2.0) 5052 epc(0) = e(3) 5053 epc(1) = -(e(1)+coni*e(2))/sqrt(2.0) 5054 do 298 i = -1,1 5055 do 298 j = -1,1 5056c ptz(i,j) = ((-1.0)**i)*epc(-i)*eps(j)/(1+elpty**2) 5057c above - true polarization tensor for given ellipticity, 5058c below - average over left and right in order to have 5059c path reversal simmetry 5060 ptz(i,j) = ((-1.0d0)**i)*(epc(-i)*eps(j)+eps(-i)*epc(j)) 5061 1 /(1+elpty**2)/2.0d0 5062 298 continue 5063c end of making polarization tensor 5064 5065 return 5066 end 5067 subroutine mmtr(t3j,mmati) 5068c calculates the part of matrix M which does not depend on energy 5069c point.( see Rehr and Albers paper) 5070 5071 implicit double precision (a-h, o-z) 5072 5073c all commons are inputs 5074c inputs: 5075c t3j: appropriate table of the 3j symbols 5076c Inputs from common: 5077c rotation matrix for ilegp 5078c path data, eta(ilegp) and ipot(ilegp) 5079c mtot,l0 5080c Output: mmati(...) 5081 5082 5083 parameter (pi = 3.1415926535897932384626433d0) 5084 parameter (one = 1, zero = 0) 5085 parameter (third = 1.0d0/3.0d0) 5086 parameter (raddeg = 180.0d0 / pi) 5087 complex*16 coni 5088 parameter (coni = (0.0d0,1.0d0)) 5089c kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37 5090 parameter (fa = 1.919158292677512811d0) 5091 5092 parameter (bohr = 0.529177249d0, ryd = 13.605698d0) 5093 parameter (alpinv = 137.03598956d0) 5094c fine structure alpha 5095 parameter (alphfs = 1.0d0 / alpinv) 5096c speed of light in louck's units (rydbergs?) 5097 parameter (clight = 2 * alpinv) 5098 5099 5100 parameter (nphx = 7) !max number of unique potentials (potph) 5101 parameter (npotx = nphx) !max number of unique potentials (genfmt, paths) 5102 parameter (nfrx = nphx) !max number of free atom types 5103 parameter (novrx = 8) !max number of overlap shells 5104 parameter (natx = 250) !max number of atoms in problem 5105 parameter (ltot = 24) !max number of ang mom (arrays 1:ltot+1) 5106 parameter (nrptx = 250) !Loucks r grid used through overlap 5107 parameter (nex = 100) !Number of energy points genfmt, etc. 5108 5109 parameter (lamtot=15) !Max number of distinct lambda's for genfmt 5110 !15 handles iord 2 and exact ss 5111 parameter (mtot=4, ntot=2) !vary mmax and nmax independently 5112 parameter (legtot=9) !matches path finder, used in GENFMT 5113 parameter (npatx = 8) !max number of path atoms, used in path 5114 !finder, NOT in genfmt 5115 5116 5117c global polarization data 5118 logical pola 5119 double precision evec,ivec,elpty 5120 complex*16 ptz 5121 common /pol/ evec(3), ivec(3), elpty, ptz(-1:1,-1:1), pola 5122 5123 5124 save /rotmat/ 5125 common /rotmat/ dri(ltot+1,2*mtot+1,2*mtot+1,legtot+1) 5126 5127 5128c Note that leg nleg is the leg ending at the central atom, so that 5129c ipot(nleg) is central atom potential, rat(nleg) position of 5130c central atom. 5131c Central atom has ipot=0 5132c For later convience, rat(,0) and ipot(0) refer to the central 5133c atom, and are the same as rat(,nleg), ipot(nleg). 5134 5135c text and title arrays include carriage control 5136 character*80 text, title 5137 character*6 potlbl 5138 common /str/ text(40), !text header from potph 5139 1 title(5), !title from paths.dat 5140 1 potlbl(0:npotx) ! potential labels for output 5141 5142 complex*16 ph, eref 5143 common /pdata/ 5144 1 ph(nex,ltot+1,0:npotx), !complex phase shifts, 5145 1 !central atom ipot=0 5146 1 rat(3,0:legtot+1), !position of each atom, code units(bohr) 5147 1 eref(nex), !complex energy reference 5148 1 em(nex), !energy mesh 5149 1 ri(legtot), beta(legtot+1), eta(0:legtot+1), !r, beta, eta for each leg 5150 1 deg, rnrmav, xmu, edge, !(output only) 5151 1 lmax(nex,0:npotx), !max l with non-zero phase for each energy 5152 1 ipot(0:legtot), !potential for each atom in path 5153 1 iz(0:npotx), !atomic number (output only) 5154 1 ltext(40), ltitle(5), !length of each string 5155 1 nsc, nleg, !nscatters, nlegs (nleg = nsc+1) 5156 1 npot, ne, !number of potentials, energy points 5157 1 ik0, !index of energy grid corresponding to k=0 (edge) 5158 1 ipath, !index of current path (output only) 5159 1 ihole, !(output only) 5160 1 l0, il0, !lfinal and lfinal+1 (used for indices) 5161 1 lmaxp1, !largest lmax in problem + 1 5162 1 ntext, ntitle !number of text and title lines 5163 5164 5165 complex*16 mmati 5166 dimension mmati(-mtot:mtot,-mtot:mtot),t3j(-mtot-1:mtot+1,-1:1) 5167 5168 do 10 i = -mtot,mtot 5169 do 10 j = -mtot,mtot 5170 mmati(i,j)=0 5171 10 continue 5172 li = l0-1 5173c l0 is final orb. momentum. Thus here we need to change code 5174c in case when initial momemtum larger than final one. 5175 lx = min(mtot,l0) 5176 5177 do 60 mu1 = -lx,lx 5178 mu1d = mu1+mtot+1 5179 do 50 mu2 = -lx,lx 5180 mu2d = mu2+mtot+1 5181 do 35 m0 = -li,li 5182 do 34 i = -1,1 5183 do 34 j = -1,1 5184 m1 = m0-j 5185 m2 = m0-i 5186 m1d = m1 + mtot+1 5187 m2d = m2 + mtot+1 5188 if (abs(m1).gt.lx .or. abs(m2).gt.lx) goto 34 5189 mmati(mu1,mu2) = mmati(mu1,mu2) + 5190 1 dri(il0,mu1d,m1d,nsc+2)*dri(il0,m2d,mu2d,nleg) 5191 2 *exp(-coni*(eta(nsc+2)*m2+eta(0)*m1)) 5192 3 *t3j(-m0,i)*t3j(-m0,j)*ptz(i,j) 5193 5194c dri(nsc+2) is angle between z and leg1 5195c dri(nsc+1) is angle between last leg and z 5196c eta(nsc+3) is gamma between eps and rho1, 5197c eta(nsc+2) is alpha between last leg and eps 5198c t3j(m0,i) are 3j symbols multiplied by sqrt(3) 5199 34 continue 5200 35 continue 5201 mmati(mu1,mu2) = mmati(mu1,mu2)*exp(-coni*eta(1)*mu1) 5202 50 continue 5203 60 continue 5204 5205 return 5206 end 5207 subroutine mmtrxi (lam1x, mmati, ie, ileg, ilegp) 5208c calculates matrix M in Rehr,Albers paper. 5209c in polarization case 5210 implicit double precision (a-h, o-z) 5211 5212c all commons except for /fmat/ are inputs 5213 5214c inputs: 5215c lam1x: limits on lambda and lambda' 5216c ie: energy grid points 5217c ileg, ilegp: leg and leg' 5218c 5219c Inputs from common: 5220c phases, use ph(ie,...,ilegp), and lmax(ie,ilegp) 5221c lambda arrays 5222c rotation matrix for ilegp 5223c clmz for ileg and ilegp 5224c path data, eta(ilegp) and ipot(ilegp) 5225c xnlm array 5226c 5227c Output: fmati(...,ilegp) in common /fmatrx/ is set for 5228c current energy point. 5229 5230c calculate scattering amplitude matrices 5231c f(lam,lam') = sum_l tl gam(l,m,n)dri(l,m,m',ileg)gamt(l,m',n') 5232c *cexp(-i*m*eta), eta = gamma+alpha' 5233c lam lt lam1x, lam' lt lam2x such that m(lam) lt l0, n(lam) lt l0 5234c gam = (-)**m c_l,n+m*xnlm, gamt = (2l+1)*c_ln/xnlm, 5235c gamtl = gamt*tl 5236 5237 5238 parameter (pi = 3.1415926535897932384626433d0) 5239 parameter (one = 1, zero = 0) 5240 parameter (third = 1.0d0/3.0d0) 5241 parameter (raddeg = 180.0d0 / pi) 5242 complex*16 coni 5243 parameter (coni = (0.0d0,1.0d0)) 5244c kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37 5245 parameter (fa = 1.919158292677512811d0) 5246 5247 parameter (bohr = 0.529177249d0, ryd = 13.605698d0) 5248 parameter (alpinv = 137.03598956d0) 5249c fine structure alpha 5250 parameter (alphfs = 1.0d0 / alpinv) 5251c speed of light in louck's units (rydbergs?) 5252 parameter (clight = 2 * alpinv) 5253 5254 5255 parameter (nphx = 7) !max number of unique potentials (potph) 5256 parameter (npotx = nphx) !max number of unique potentials (genfmt, paths) 5257 parameter (nfrx = nphx) !max number of free atom types 5258 parameter (novrx = 8) !max number of overlap shells 5259 parameter (natx = 250) !max number of atoms in problem 5260 parameter (ltot = 24) !max number of ang mom (arrays 1:ltot+1) 5261 parameter (nrptx = 250) !Loucks r grid used through overlap 5262 parameter (nex = 100) !Number of energy points genfmt, etc. 5263 5264 parameter (lamtot=15) !Max number of distinct lambda's for genfmt 5265 !15 handles iord 2 and exact ss 5266 parameter (mtot=4, ntot=2) !vary mmax and nmax independently 5267 parameter (legtot=9) !matches path finder, used in GENFMT 5268 parameter (npatx = 8) !max number of path atoms, used in path 5269 !finder, NOT in genfmt 5270 5271 5272 save /nlm/ 5273 common /nlm/ xnlm(ltot+1,mtot+1) 5274 5275 5276 common /lambda/ 5277 4 mlam(lamtot), !mu for each lambda 5278 5 nlam(lamtot), !nu for each lambda 5279 1 lamx, !max lambda in problem 5280 2 laml0x, !max lambda for vectors involving absorbing atom 5281 3 mmaxp1, nmax !max mu in problem + 1, max nu in problem 5282 5283 5284 save /clmz/ 5285 complex*16 clmi 5286 common /clmz/ clmi(ltot+1,mtot+ntot+1,legtot) 5287 5288 5289c global polarization data 5290 logical pola 5291 double precision evec,ivec,elpty 5292 complex*16 ptz 5293 common /pol/ evec(3), ivec(3), elpty, ptz(-1:1,-1:1), pola 5294 5295 5296 complex*16 fmati 5297 common /fmatrx/ fmati(lamtot,lamtot,legtot) 5298 5299 5300 save /rotmat/ 5301 common /rotmat/ dri(ltot+1,2*mtot+1,2*mtot+1,legtot+1) 5302 5303 5304c Note that leg nleg is the leg ending at the central atom, so that 5305c ipot(nleg) is central atom potential, rat(nleg) position of 5306c central atom. 5307c Central atom has ipot=0 5308c For later convience, rat(,0) and ipot(0) refer to the central 5309c atom, and are the same as rat(,nleg), ipot(nleg). 5310 5311c text and title arrays include carriage control 5312 character*80 text, title 5313 character*6 potlbl 5314 common /str/ text(40), !text header from potph 5315 1 title(5), !title from paths.dat 5316 1 potlbl(0:npotx) ! potential labels for output 5317 5318 complex*16 ph, eref 5319 common /pdata/ 5320 1 ph(nex,ltot+1,0:npotx), !complex phase shifts, 5321 1 !central atom ipot=0 5322 1 rat(3,0:legtot+1), !position of each atom, code units(bohr) 5323 1 eref(nex), !complex energy reference 5324 1 em(nex), !energy mesh 5325 1 ri(legtot), beta(legtot+1), eta(0:legtot+1), !r, beta, eta for each leg 5326 1 deg, rnrmav, xmu, edge, !(output only) 5327 1 lmax(nex,0:npotx), !max l with non-zero phase for each energy 5328 1 ipot(0:legtot), !potential for each atom in path 5329 1 iz(0:npotx), !atomic number (output only) 5330 1 ltext(40), ltitle(5), !length of each string 5331 1 nsc, nleg, !nscatters, nlegs (nleg = nsc+1) 5332 1 npot, ne, !number of potentials, energy points 5333 1 ik0, !index of energy grid corresponding to k=0 (edge) 5334 1 ipath, !index of current path (output only) 5335 1 ihole, !(output only) 5336 1 l0, il0, !lfinal and lfinal+1 (used for indices) 5337 1 lmaxp1, !largest lmax in problem + 1 5338 1 ntext, ntitle !number of text and title lines 5339 5340 5341 complex*16 cam, camt, tltl,mmati 5342 dimension mmati(-mtot:mtot,-mtot:mtot) 5343 complex*16 gam(ltot+1,mtot+1,ntot+1), 5344 1 gamtl(ltot+1,mtot+1,ntot+1) 5345 5346c calculate factors gam and gamtl 5347 iln = il0 5348 ilx = il0 5349 do 30 il = iln, ilx 5350 tltl = 2*il - 1 5351 do 20 lam = 1, lam1x 5352 m = mlam(lam) 5353 if (m .lt. 0) goto 20 5354 im = m+1 5355 if (im .gt. il) goto 20 5356 in = nlam(lam) + 1 5357 imn = in + m 5358 if (lam .gt. lam1x) goto 10 5359 cam = xnlm(il,im) * (-1)**m 5360 if (imn .le. il) gam(il,im,in) = cam * clmi(il,imn,ileg) 5361 if (imn .gt. il) gam(il,im,in) = 0 5362 10 if (lam .gt. lam1x) goto 20 5363 camt = tltl / xnlm(il,im) 5364 gamtl(il,im,in) = camt * clmi(il,in,ilegp) 5365 20 continue 5366 30 continue 5367 5368 do 60 lam1 = 1,lam1x 5369 m1 = mlam(lam1) 5370 in1 = nlam(lam1) + 1 5371 iam1 = abs(m1) + 1 5372 do 50 lam2 = 1, lam1x 5373 m2 = mlam(lam2) 5374 in2 = nlam(lam2) + 1 5375 iam2 = iabs(m2) + 1 5376 imn1 = iam1 + in1 - 1 5377 fmati(lam1,lam2,ilegp) = mmati(m1,m2)* 5378 1 gam(il0,iam1,in1)*gamtl(il0,iam2,in2) 5379 50 continue 5380 60 continue 5381 5382 return 5383 end 5384 subroutine mpprmd (npat, ipat, ri, beta, eta) 5385 implicit double precision (a-h, o-z) 5386c double precision version so angles come out right 5387c for output... 5388 5389c Used with pathsd, a single precision code, so BE CAREFUL!! 5390c No implicit, all variables declared explicitly. 5391 5392c make path parameters, ie, ri, beta, eta for each leg for a given 5393c path. 5394 5395c Input is list of atoms (npat, ipat(npat)), output is 5396c ri(npat+1), beta, eta. 5397 5398 dimension ipat(npat) 5399 5400 parameter (nphx = 7) !max number of unique potentials (potph) 5401 parameter (npotx = nphx) !max number of unique potentials (genfmt, paths) 5402 parameter (nfrx = nphx) !max number of free atom types 5403 parameter (novrx = 8) !max number of overlap shells 5404 parameter (natx = 250) !max number of atoms in problem 5405 parameter (ltot = 24) !max number of ang mom (arrays 1:ltot+1) 5406 parameter (nrptx = 250) !Loucks r grid used through overlap 5407 parameter (nex = 100) !Number of energy points genfmt, etc. 5408 5409 parameter (lamtot=15) !Max number of distinct lambda's for genfmt 5410 !15 handles iord 2 and exact ss 5411 parameter (mtot=4, ntot=2) !vary mmax and nmax independently 5412 parameter (legtot=9) !matches path finder, used in GENFMT 5413 parameter (npatx = 8) !max number of path atoms, used in path 5414 !finder, NOT in genfmt 5415 5416 5417c /atoms/ is single precision from pathsd 5418 common /atoms/ rat(3,0:natx), ipot(0:natx), i1b(0:natx) 5419 5420 complex*16 coni 5421 parameter (coni = (0,1)) 5422 5423 complex*16 alph(npatx+1), gamm(npatx+2), eieta 5424 double precision beta(npatx+1) 5425 double precision ri(npatx+1), eta(npatx+1) 5426 5427 double precision x, y, z 5428 double precision ct, st, cp, sp, ctp, stp, cpp, spp 5429 double precision cppp, sppp 5430 5431 n = npat + 1 5432 do 100 j = 1, n 5433 5434c get the atoms in this path 5435c we actually have them already via the ipat array 5436c remember that we'll want rat(,npat+1)=rat(,0) and 5437c rat(,npat+2)=rat(,1) later on 5438c make alpha, beta, and gamma for point i from 1 to N 5439c NB: N is npat+1, since npat is number of bounces and N is 5440c number of legs, or think of N=npat+1 as the central atom 5441c that is the end of the path. 5442c 5443c for euler angles at point i, need th and ph (theta and phi) 5444c from rat(i+1)-rat(i) and thp and php 5445c (theta prime and phi prime) from rat(i)-rat(i-1) 5446c 5447c Actually, we need cos(th), sin(th), cos(phi), sin(phi) and 5448c also for angles prime. Call these ct, st, cp, sp and 5449c ctp, stp, cpp, spp. 5450c 5451c We'll need angles from n-1 to n to 1, 5452c so use rat(n+1) = rat(1), so we don't have to write code 5453c later to handle these cases. 5454 5455c i = ipat(j) 5456c ip1 = ipat(j+1) 5457c im1 = ipat(j-1) 5458c except for special cases... 5459 if (j .eq. n) then 5460c j central atom, j+1 first atom, j-1 last path atom 5461 i = 0 5462 ip1 = ipat(1) 5463 im1 = ipat(npat) 5464 elseif (j .eq. npat) then 5465c j last path atom, j+1 central, j-1 next-to last atom 5466c unless only one atom, then j-1 central 5467 i = ipat(j) 5468 ip1 = 0 5469 if (npat .eq. 1) then 5470 im1 = 0 5471 else 5472 im1 = ipat(npat-1) 5473 endif 5474 elseif (j .eq. 1) then 5475c j first atom, j+1 second unless only one, 5476c then j+1 central, j-1 central 5477 i = ipat(j) 5478 if (npat .eq. 1) then 5479 ip1 = 0 5480 else 5481 ip1 = ipat (j+1) 5482 endif 5483 im1 = 0 5484 else 5485 i = ipat(j) 5486 ip1 = ipat(j+1) 5487 im1 = ipat(j-1) 5488 endif 5489 5490 x = rat(1,ip1) - rat(1,i) 5491 y = rat(2,ip1) - rat(2,i) 5492 z = rat(3,ip1) - rat(3,i) 5493 call strigd (x, y, z, ct, st, cp, sp) 5494 x = rat(1,i) - rat(1,im1) 5495 y = rat(2,i) - rat(2,im1) 5496 z = rat(3,i) - rat(3,im1) 5497 call strigd (x, y, z, ctp, stp, cpp, spp) 5498 5499c cppp = cos (phi prime - phi) 5500c sppp = sin (phi prime - phi) 5501 cppp = cp*cpp + sp*spp 5502 sppp = spp*cp - cpp*sp 5503 5504c alph = exp**(i alpha) in ref eqs 18 5505c beta = cos(beta) 5506c gamm = exp**(i gamma) 5507 alph(j) = st*ctp - ct*stp*cppp - coni*stp*sppp 5508 beta(j) = ct*ctp + st*stp*cppp 5509c Watch out for roundoff errors 5510 if (beta(j) .lt. -1) beta(j) = -1 5511 if (beta(j) .gt. 1) beta(j) = 1 5512 gamm(j) = st*ctp*cppp - ct*stp + coni*st*sppp 5513 ri(j) = sdist (rat(1,i), rat(1,im1)) 5514 100 continue 5515 5516c Make eta(i) = alpha(i) + gamma(i+1). We only really need 5517c exp(i*eta)=eieta, so that's what we'll calculate. 5518c We'll need gamm(N+1)=gamm(npat+2)=gamm(1) 5519 gamm(npat+2) = gamm(1) 5520 do 150 j = 1, npat+1 5521 eieta = alph(j) * gamm(j+1) 5522 call sargd(eieta, eta(j)) 5523 150 continue 5524 5525c Return beta as an angle, ie, acos(beta). Check for beta >1 or 5526c beta <1 (roundoff nasties) 5527 do 160 j = 1, npat+1 5528 if (beta(j) .gt. 1) beta(j) = 1 5529 if (beta(j) .lt. -1) beta(j) = -1 5530 beta(j) = dacos(beta(j)) 5531 160 continue 5532 5533 return 5534 end 5535 subroutine strigd (x, y, z, ct, st, cp, sp) 5536 implicit double precision (a-h, o-z) 5537 double precision x, y, z, ct, st, cp, sp, r, rxy 5538c returns cos(theta), sin(theta), cos(phi), sin(ph) for (x,y,z) 5539c convention - if x=y=0, phi=0, cp=1, sp=0 5540c - if x=y=z=0, theta=0, ct=1, st=0 5541 parameter (eps = 1.0d-6) 5542 r = sqrt (x**2 + y**2 + z**2) 5543 rxy = sqrt (x**2 + y**2) 5544 if (r .lt. eps) then 5545 ct = 1 5546 st = 0 5547 else 5548 ct = z/r 5549 st = rxy/r 5550 endif 5551 if (rxy .lt. eps) then 5552 cp = 1 5553 sp = 0 5554 else 5555 cp = x / rxy 5556 sp = y / rxy 5557 endif 5558 5559 return 5560 end 5561 subroutine sargd (c, th) 5562 implicit double precision (a-h, o-z) 5563 5564 double precision x, y, th 5565 complex*16 c 5566 parameter (eps = 1.0d-6) 5567 x = dble(c) 5568 y = dimag(c) 5569 if (abs(x) .lt. eps) x = 0 5570 if (abs(y) .lt. eps) y = 0 5571 if (abs(x) .lt. eps .and. abs(y) .lt. eps) then 5572 th = 0 5573 else 5574 th = atan2 (y, x) 5575 endif 5576 return 5577 end 5578 subroutine mpprmp (npat, ipat, xp, yp, zp) 5579 implicit double precision (a-h, o-z) 5580 5581c make path parameters, xp, yp,zp for each atom for a given 5582c path. 5583 5584c Input is list of atoms (npat, ipat(npat)), output are 5585c x,y,z coord. of path in standard frame of reference 5586c (see comments in timrep.f or here below) 5587 5588 5589 parameter (nphx = 7) !max number of unique potentials (potph) 5590 parameter (npotx = nphx) !max number of unique potentials (genfmt, paths) 5591 parameter (nfrx = nphx) !max number of free atom types 5592 parameter (novrx = 8) !max number of overlap shells 5593 parameter (natx = 250) !max number of atoms in problem 5594 parameter (ltot = 24) !max number of ang mom (arrays 1:ltot+1) 5595 parameter (nrptx = 250) !Loucks r grid used through overlap 5596 parameter (nex = 100) !Number of energy points genfmt, etc. 5597 5598 parameter (lamtot=15) !Max number of distinct lambda's for genfmt 5599 !15 handles iord 2 and exact ss 5600 parameter (mtot=4, ntot=2) !vary mmax and nmax independently 5601 parameter (legtot=9) !matches path finder, used in GENFMT 5602 parameter (npatx = 8) !max number of path atoms, used in path 5603 !finder, NOT in genfmt 5604 5605 5606c global polarization data 5607 logical pola 5608 double precision evec,ivec,elpty 5609 complex*16 ptz 5610 common /pol/ evec(3), ivec(3), elpty, ptz(-1:1,-1:1), pola 5611 5612 double precision ro2, norm, zvec, xvec, yvec, ri, xp1, yp1, zp1 5613 dimension ipat(npatx+1), zvec(3), xvec(3), yvec(3) 5614 5615 common /atoms/ rat(3,0:natx), ipot(0:natx), i1b(0:natx) 5616 5617 dimension xp(npatx), yp(npatx), zp(npatx) 5618 dimension xp1(npatx), yp1(npatx), zp1(npatx) 5619 dimension ri(3,npatx) 5620 5621 parameter (eps4 = 1.0E-4) 5622 5623c get the atoms in this path 5624c we actually have them already via the ipat array 5625 5626c initialize staff 5627 do 10 j = 1, npatx 5628 xp(j) = 0 5629 yp(j) = 0 5630 zp(j) = 0 5631 xp1(j) = 0 5632 yp1(j) = 0 5633 zp1(j) = 0 5634 10 continue 5635 nleg = npat + 1 5636 do 20 j = 1, npat 5637 do 20 i = 1, 3 5638 ri(i,j) = rat(i,ipat(j)) - rat(i,0) 5639 20 continue 5640 do 30 j = nleg, npatx 5641 do 30 i = 1, 3 5642 ri(i,j) = 0 5643 30 continue 5644 do 40 i =1, 3 5645 xvec(i) = 0.0 5646 yvec(i) = 0.0 5647 zvec(i) = 0.0 5648 40 continue 5649 5650 if (.not. pola) then 5651c z-axis along first leg 5652 norm = ri(1,1)*ri(1,1)+ri(2,1)*ri(2,1)+ri(3,1)*ri(3,1) 5653 norm = sqrt(norm) 5654 do 140 i = 1, 3 5655 zvec(i) = ri(i,1)/norm 5656 140 continue 5657 else 5658c z-axis in direction of polarization 5659 do 120 i = 1, 3 5660 zvec(i) = evec(i) 5661 120 continue 5662 endif 5663 5664 do 160 j = 1,npat 5665 do 160 i = 1, 3 5666 zp1(j) = zp1(j) + zvec(i)*ri(i,j) 5667 160 continue 5668 5669 num = 1 5670 if (.not. pola) then 5671c first nonzero z-coord. is already positive 5672 goto 240 5673 endif 5674 200 continue 5675 if (abs(zp1(num)) .gt. eps4) then 5676 if (zp1(num) .lt. 0.0) then 5677c inverse all z-coordinates and zvec, if 5678c first nonzero z-coordinate is negative 5679 do 210 j = 1, 3 5680 zvec(j) = - zvec(j) 5681 210 continue 5682 do 220 j = 1, npat 5683 zp1(j) = - zp1(j) 5684 220 continue 5685 endif 5686 goto 240 5687 endif 5688 num = num +1 5689 if (num .lt. nleg) then 5690 goto 200 5691 endif 5692c here first nonzero z-coordinate is positive 5693 240 continue 5694 5695 num = 1 5696 300 continue 5697 ro2 = 0.0 5698 do 310 i =1, 3 5699 ro2 = ro2 + ri(i,num)*ri(i,num) 5700 310 continue 5701c looking for first atom which is not on z-axis 5702 ro2 = ro2 - zp1(num)*zp1(num) 5703 ro2 = sqrt(abs(ro2)) 5704 if (ro2 .ge. eps4) then 5705c if atom not on the z-axis then 5706 if (elpty .eq. 0.0) then 5707c if not elliptical polarization then 5708c choose x-axis so that x-coord. positive and y=0. 5709 do 320 i = 1, 3 5710 xvec(i) = ri(i,num) - zvec(i)*zp1(num) 5711 320 continue 5712 do 330 i = 1, 3 5713 xvec(i) = xvec(i)/ro2 5714 330 continue 5715 else 5716c if elliptical polarization then 5717c choose x-axis along incident beam 5718 do 350 i =1, 3 5719 xvec(i) = ivec(i) 5720 350 continue 5721 endif 5722 yvec(1) = zvec(2)*xvec(3) - zvec(3)*xvec(2) 5723 yvec(2) = zvec(3)*xvec(1) - zvec(1)*xvec(3) 5724 yvec(3) = zvec(1)*xvec(2) - zvec(2)*xvec(1) 5725 goto 390 5726 endif 5727 num = num + 1 5728 if (num .lt. nleg) then 5729 goto 300 5730 endif 5731 390 continue 5732 5733c calculate x,y coord for each atom in chosen frame of reference 5734 do 400 j = 1, npat 5735 do 400 i =1,3 5736 xp1(j) = xp1(j) + xvec(i)*ri(i,j) 5737 yp1(j) = yp1(j) + yvec(i)*ri(i,j) 5738 400 continue 5739 5740 if ( elpty .ne. 0.0) then 5741c if no polarization or linear polarization then first nonzero 5742c x-coordinate is already positive, no need to check it. 5743 num = 1 5744 500 continue 5745 if (abs(xp1(num)) .ge. eps4) then 5746 if (xp1(num) .lt. 0.0) then 5747 do 510 j = 1, npat 5748 xp1(j) = - xp1(j) 5749 510 continue 5750 endif 5751 goto 520 5752 endif 5753 num = num + 1 5754 if (num .lt. nleg) then 5755 goto 500 5756 endif 5757 520 continue 5758 endif 5759 5760 num = 1 5761 570 continue 5762c inverse all y-coordinates if first nonzero y-coord is negative 5763 if (abs(yp1(num)) .ge. eps4) then 5764 if (yp1(num) .lt. 0.0) then 5765 do 580 j = 1, npat 5766 yp1(j) = - yp1(j) 5767 580 continue 5768 endif 5769 goto 590 5770 endif 5771 num = num + 1 5772 if (num .lt. nleg) then 5773 goto 570 5774 endif 5775 590 continue 5776 5777 do 595 j = 1, npat 5778 xp(j) = xp1(j) 5779 yp(j) = yp1(j) 5780 zp(j) = zp1(j) 5781 595 continue 5782c now xp,yp,zp represent the path in standard order 5783 return 5784 end 5785 subroutine mrb (npat, ipat, ri, beta) 5786 implicit double precision (a-h, o-z) 5787 5788c Make ri, beta and rpath path parameters for crit calculations. 5789 5790c Input is list of atoms (npat, ipat(npat)), output is 5791c ri(npat+1), beta, eta. 5792 5793 5794 parameter (nphx = 7) !max number of unique potentials (potph) 5795 parameter (npotx = nphx) !max number of unique potentials (genfmt, paths) 5796 parameter (nfrx = nphx) !max number of free atom types 5797 parameter (novrx = 8) !max number of overlap shells 5798 parameter (natx = 250) !max number of atoms in problem 5799 parameter (ltot = 24) !max number of ang mom (arrays 1:ltot+1) 5800 parameter (nrptx = 250) !Loucks r grid used through overlap 5801 parameter (nex = 100) !Number of energy points genfmt, etc. 5802 5803 parameter (lamtot=15) !Max number of distinct lambda's for genfmt 5804 !15 handles iord 2 and exact ss 5805 parameter (mtot=4, ntot=2) !vary mmax and nmax independently 5806 parameter (legtot=9) !matches path finder, used in GENFMT 5807 parameter (npatx = 8) !max number of path atoms, used in path 5808 !finder, NOT in genfmt 5809 5810 dimension ipat(npatx) 5811 5812 common /atoms/ rat(3,0:natx), ipot(0:natx), i1b(0:natx) 5813 5814 dimension beta(npatx+1), ri(npatx+1), ipat0(npatx+1) 5815 5816 nleg = npat+1 5817c central atom is atom 0 in rat array 5818c need local ipat0 array since we use ipat0(npat+1), final atom 5819c in path (final atom is, of course, the central atom) 5820 do 10 i = 1, npat 5821 ipat0(i) = ipat(i) 5822 10 continue 5823 ipat0(nleg) = 0 5824 5825 do 30 ileg = 1, nleg 5826c make beta and ri for point i from 1 to N 5827c NB: N is npat+1, since npat is number of bounces and N is 5828c number of legs, or think of N=npat+1 as the central atom 5829c that is the end of the path. 5830c 5831c We'll need angles from n-1 to n to 1, 5832c so use rat(n+1) = rat(1), so we don't have to write code 5833c later to handle these cases. 5834 5835c Work with atom j 5836c jp1 = (j+1) 5837c jm1 = (j-1) 5838 j = ileg 5839 jm1 = j-1 5840 jp1 = j+1 5841c Fix special cases (wrap around when j is near central atom, 5842c also handle ss and triangular cases). 5843 if (jm1 .le. 0) jm1 = nleg 5844 if (jp1 .gt. nleg) jp1 = 1 5845 5846 jat = ipat0(j) 5847 jm1at = ipat0(jm1) 5848 jp1at = ipat0(jp1) 5849 5850 ri(ileg) = sdist (rat(1,jat), rat(1,jm1at)) 5851 5852c Make cos(beta) from dot product 5853 call dotcos(rat(1,jm1at), rat(1,jat), rat(1,jp1at), 5854 1 beta(ileg)) 5855 30 continue 5856 5857 rpath = 0 5858 do 60 ileg = 1, nleg 5859 rpath = rpath + ri(ileg) 5860 60 continue 5861 5862 return 5863 end 5864 subroutine dotcos (rm1, r, rp1, cosb) 5865 implicit double precision (a-h, o-z) 5866 dimension rm1(3), r(3), rp1(3) 5867 5868 parameter (eps = 1.0d-8) 5869 5870 cosb = 0 5871 do 100 i = 1, 3 5872 cosb = cosb + (r(i)-rm1(i)) * (rp1(i)-r(i)) 5873 100 continue 5874 5875c if denom is zero (and it may be if 2 atoms are in the same place, 5876c which will happen when last path atom is central atom), set 5877c cosb = 0, so it won't be undefined. 5878 5879 denom = (sdist(r,rm1) * sdist(rp1,r)) 5880 if (denom .gt. eps) then 5881 cosb = cosb / denom 5882 else 5883 cosb = 0 5884 endif 5885 return 5886 end 5887 subroutine outcrt (npat, ipat, ckspc, 5888 1 nncrit, fbetac, ne, ik0, cksp, fbeta, ipotnn, ipot, 5889 1 xport, xheap, xheapr, 5890 1 xout, xcalcx) 5891 implicit double precision (a-h, o-z) 5892 5893c This make pw importance factor for pathsd, also recalculates 5894c pathfinder criteria for output. Pathfinder recalculation 5895c is hacked from ccrit, so be sure to update this if ccrit 5896c is changed. 5897 5898 5899 parameter (pi = 3.1415926535897932384626433d0) 5900 parameter (one = 1, zero = 0) 5901 parameter (third = 1.0d0/3.0d0) 5902 parameter (raddeg = 180.0d0 / pi) 5903 complex*16 coni 5904 parameter (coni = (0.0d0,1.0d0)) 5905c kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37 5906 parameter (fa = 1.919158292677512811d0) 5907 5908 parameter (bohr = 0.529177249d0, ryd = 13.605698d0) 5909 parameter (alpinv = 137.03598956d0) 5910c fine structure alpha 5911 parameter (alphfs = 1.0d0 / alpinv) 5912c speed of light in louck's units (rydbergs?) 5913 parameter (clight = 2 * alpinv) 5914 5915 5916 parameter (nphx = 7) !max number of unique potentials (potph) 5917 parameter (npotx = nphx) !max number of unique potentials (genfmt, paths) 5918 parameter (nfrx = nphx) !max number of free atom types 5919 parameter (novrx = 8) !max number of overlap shells 5920 parameter (natx = 250) !max number of atoms in problem 5921 parameter (ltot = 24) !max number of ang mom (arrays 1:ltot+1) 5922 parameter (nrptx = 250) !Loucks r grid used through overlap 5923 parameter (nex = 100) !Number of energy points genfmt, etc. 5924 5925 parameter (lamtot=15) !Max number of distinct lambda's for genfmt 5926 !15 handles iord 2 and exact ss 5927 parameter (mtot=4, ntot=2) !vary mmax and nmax independently 5928 parameter (legtot=9) !matches path finder, used in GENFMT 5929 parameter (npatx = 8) !max number of path atoms, used in path 5930 !finder, NOT in genfmt 5931 5932 dimension ipat(npatx) 5933 dimension ipot(0:natx) 5934 parameter (necrit=9, nbeta=40) 5935 dimension fbetac(-nbeta:nbeta,0:npotx,necrit), ckspc(necrit) 5936 dimension fbeta(-nbeta:nbeta,0:npotx,nex), cksp(nex) 5937 5938c local variables 5939 dimension ri(npatx+1), beta(npatx+1), indbet(npatx+1) 5940 dimension xporti(nex) 5941 parameter (eps = 1.0d-6) 5942 5943c Space for variables for time reversed path (used in xheapr 5944c calculation below) 5945 dimension ipat0(npatx) 5946 dimension ri0(npatx+1), indbe0(npatx+1) 5947 5948c mrb is 'efficient' way to get only ri and beta 5949c note that beta is cos(beta) 5950 call mrb (npat, ipat, ri, beta) 5951 5952c Make index into fbeta array (this is nearest cos(beta) grid point, 5953c code is a bit cute [sorry!], see prcrit for grid). 5954 do 290 i = 1, npat+1 5955 tmp = abs(beta(i)) 5956 n = tmp / 0.025d0 5957 del = tmp - n*0.025d0 5958 if (del .gt. 0.0125d0) n = n+1 5959 if (beta(i) .lt. 0) n = -n 5960 indbet(i) = n 5961 290 continue 5962 5963c Make pw importance factor by integrating over all points 5964c above the edge 5965c Path importance factor is integral d|p| of 5966c (product of f(beta)/rho for the scatterers) * cos(beta0)/rho0 5967 do 560 ie = ik0, ne 5968 rho = ri(npat+1) * cksp(ie) 5969 crit = max (abs(beta(npat+1)), 0.2d0) / rho 5970 do 520 iat = 1, npat 5971 rho = ri(iat) * cksp(ie) 5972 ipot0 = ipot(ipat(iat)) 5973 crit = crit * fbeta(indbet(iat),ipot0,ie) / rho 5974 520 continue 5975 xporti(ie) = abs(crit) 5976 560 continue 5977c integrate from ik0 to ne 5978 nmax = ne - ik0 + 1 5979 call strap (cksp(ik0), xporti(ik0), nmax, xport) 5980 5981c Stuff for output. 5982c Heap crit thing (see ccrit and mcrith for comments) 5983c If a path got time reversed, its xheap may be smaller than 5984c it was before it got time-reversed. So calculate it both 5985c ways. 5986c xheap for path, xheapr for time-reversed path 5987 5988 xheap = -1 5989 xheapr = -1 5990 call mcrith (npat, ipat, ri, indbet, 5991 1 ipot, nncrit, fbetac, ckspc, xheap) 5992 5993c Prepare arrays for time reversed path and make xheapr 5994c See timrev.f for details on indexing here. 5995 5996 nleg = npat+1 5997c ri 5998 do 200 i = 1, nleg 5999 ri0(i) = ri(nleg+1-i) 6000 200 continue 6001c indbet and ipat 6002 indbe0(nleg) = indbet(nleg) 6003 do 210 i = 1, nleg-1 6004 indbe0(i) = indbet(nleg-i) 6005 ipat0(i) = ipat(nleg-i) 6006 210 continue 6007 6008 call mcrith(npat, ipat0, ri0, indbe0, 6009 1 ipot, nncrit, fbetac, ckspc, xheapr) 6010 6011c Keep crit thing (see mcritk for comments) 6012 call mcritk (npat, ipat, ri, beta, indbet, 6013 1 ipot, nncrit, fbetac, ckspc, xout, xcalcx) 6014c print*, npat, xout, xcalcx 6015 6016 return 6017 end 6018 subroutine ovrlp (iph, iphat, rat, iatph, ifrph, novr, 6019 1 iphovr, nnovr, rovr, iz, nat, rho, vcoul, 6020 2 edens, vclap, rnrm) 6021 6022c Overlaps coulomb potentials and electron densities for current 6023c unique potential 6024 implicit double precision (a-h, o-z) 6025 6026 6027 parameter (pi = 3.1415926535897932384626433d0) 6028 parameter (one = 1, zero = 0) 6029 parameter (third = 1.0d0/3.0d0) 6030 parameter (raddeg = 180.0d0 / pi) 6031 complex*16 coni 6032 parameter (coni = (0,1)) 6033c kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37 6034 parameter (fa = 1.919158292677512811d0) 6035 6036 parameter (bohr = 0.529177249d0, ryd = 13.605698d0) 6037 parameter (alpinv = 137.03598956d0) 6038c fine structure alpha 6039 parameter (alphfs = 1.0d0 / alpinv) 6040c speed of light in louck's units (rydbergs?) 6041 parameter (clight = 2 * alpinv) 6042 6043 6044 parameter (nphx = 7) !max number of unique potentials (potph) 6045 parameter (npotx = nphx) !max number of unique potentials (genfmt, paths) 6046 parameter (nfrx = nphx) !max number of free atom types 6047 parameter (novrx = 8) !max number of overlap shells 6048 parameter (natx = 250) !max number of atoms in problem 6049 parameter (ltot = 24) !max number of ang mom (arrays 1:ltot+1) 6050 parameter (nrptx = 250) !Loucks r grid used through overlap 6051 parameter (nex = 100) !Number of energy points genfmt, etc. 6052 6053 parameter (lamtot=15) !Max number of distinct lambda's for genfmt 6054 !15 handles iord 2 and exact ss 6055 parameter (mtot=4, ntot=2) !vary mmax and nmax independently 6056 parameter (legtot=9) !matches path finder, used in GENFMT 6057 parameter (npatx = 8) !max number of path atoms, used in path 6058 !finder, NOT in genfmt 6059 6060 6061 dimension iphat(natx) 6062 dimension rat(3,natx) 6063 dimension iatph(0:nphx) 6064 dimension ifrph(0:nphx) 6065 dimension novr(0:nphx) 6066 dimension iphovr(novrx,0:nphx) 6067 dimension nnovr(novrx,0:nphx) 6068 dimension rovr(novrx,0:nphx) 6069 dimension iz(0:nfrx) 6070 dimension rho(251,0:nfrx) 6071 dimension vcoul(251,0:nfrx) 6072 dimension edens(nrptx,0:nphx) 6073 dimension vclap(nrptx,0:nphx) 6074 dimension rnrm(0:nphx) 6075 6076c find out which free atom we're dealing with 6077 ifr = ifrph(iph) 6078 6079c start with free atom values for current atom 6080 do 100 i = 1, 250 6081 vclap(i,iph) = vcoul(i,ifr) 6082 edens(i,iph) = rho (i,ifr) 6083 100 continue 6084 6085 if (novr(iph) .gt. 0) then 6086 do 104 iovr = 1, novr(iph) 6087 rnn = rovr(iovr,iph) 6088 ann = nnovr(iovr,iph) 6089 infr = ifrph(iphovr(iovr,iph)) 6090 call sumax (250, rnn, ann, vcoul(1,infr), vclap(1,iph)) 6091 call sumax (250, rnn, ann, rho (1,infr), edens(1,iph)) 6092 104 continue 6093 else 6094c Do overlapping from geometry with model atom iat 6095 iat = iatph(iph) 6096 6097c overlap with all atoms within r overlap max (rlapx) 6098c 12 au = 6.35 ang This number pulled out of a hat... 6099 rlapx = 12 6100c inat is Index of Neighboring ATom 6101 do 110 inat = 1, nat 6102c don't overlap atom with itself 6103 if (inat .eq. iat) goto 110 6104 6105c if neighbor is too far away, don't overlap it 6106 rnn = feff_dist(rat(1,inat), rat(1,iat)) 6107 if (rnn .gt. rlapx) goto 110 6108 6109 infr = ifrph(iphat(inat)) 6110 call sumax (250, rnn, one, vcoul(1,infr), vclap(1,iph)) 6111 call sumax (250, rnn, one, rho (1,infr), edens(1,iph)) 6112 110 continue 6113 endif 6114 6115c set norman radius 6116 call frnrm (edens(1,iph), iz(ifr), rnrm(iph)) 6117 6118 return 6119 end 6120 subroutine paths(ckspc, fbetac, pcritk, pcrith, nncrit, 6121 1 rmax, nlegxx, ipotnn) 6122 6123 implicit double precision (a-h, o-z) 6124 6125c finds multiple scattering paths 6126c This is single precision, units are Angstroms. BE CAREFUL! 6127 6128c pcrith is cut-off fraction used when building paths 6129c (path criterion for heap) 6130c pcritk is cut-off fraction used on output 6131c (path criterion for keeping) 6132 6133c ipotnn is output, used by pathsd to duplicate paths criteria, 6134c which are used only for diagnostic output. 6135 6136 6137 character*72 header 6138 common /header_common/ header 6139 6140 6141 parameter (nphx = 7) !max number of unique potentials (potph) 6142 parameter (npotx = nphx) !max number of unique potentials (genfmt, paths) 6143 parameter (nfrx = nphx) !max number of free atom types 6144 parameter (novrx = 8) !max number of overlap shells 6145 parameter (natx = 250) !max number of atoms in problem 6146 parameter (ltot = 24) !max number of ang mom (arrays 1:ltot+1) 6147 parameter (nrptx = 250) !Loucks r grid used through overlap 6148 parameter (nex = 100) !Number of energy points genfmt, etc. 6149 6150 parameter (lamtot=15) !Max number of distinct lambda's for genfmt 6151 !15 handles iord 2 and exact ss 6152 parameter (mtot=4, ntot=2) !vary mmax and nmax independently 6153 parameter (legtot=9) !matches path finder, used in GENFMT 6154 parameter (npatx = 8) !max number of path atoms, used in path 6155 !finder, NOT in genfmt 6156 6157 parameter (necrit=9, nbeta=40) 6158 dimension fbetac(-nbeta:nbeta,0:npotx,necrit), ckspc(necrit) 6159 6160 6161 character*12 vfeff, vpotph, vpaths, vgenfm, vff2ch 6162 common /vers/ vfeff, vpotph, vpaths, vgenfm, vff2ch 6163 6164 6165c This common in pathsd, mpprm 6166 common /atoms/ rat(3,0:natx), ipot(0:natx), i1b(0:natx) 6167 6168 dimension m(-1:natx,0:natx) 6169 dimension mindex(natx+1) 6170c Used for packed integers 6171 dimension iout(3) 6172 6173c ok true if all paths to rmax found. If heap full, npx exceeded, 6174c etc., last general shell may be incomplete, set ok=.false. 6175 logical ok 6176 6177c Heap data structure: 6178c index is the pointer to the element of the data structure. 6179c Each element contains 6180c r total path length 6181c Note that r is sorted along with index -- this keeps 6182c the heap maintenance routines fast. 6183c mi, mj m matrix elements used to place last atom in this path 6184c npat number of atoms in this path 6185c ipat(npatx) indices of atoms in this path 6186c next is the index of the next data structure element available. 6187c If an element is freed, npat is the index of the free element 6188c to use after using current next element. 6189c nx is max number in heap 6190 integer nx 6191 parameter (nx = 10000) 6192c parameter (nx = 60 000) 6193c r also used in making m matrix, must have nx >= natx+1 6194 integer index(nx), npx, np, n, ip, i 6195c parameter (npx = 100 000) 6196 parameter (npx = 4000000) 6197 dimension r(nx), mi(nx), mj(nx) 6198 dimension npat(nx) 6199 dimension ipat (npatx,nx) 6200c Keep this path on output 6201 logical keep1(nx), kp1tmp 6202 6203c Used with ipack, so need ipat(8) 6204 dimension ipat0(8) 6205 6206c paths are typically about 10 or 20 Ang 6207 parameter (big = 1.0d3) 6208 6209 parameter (nheadx = 30) 6210 character*80 head(nheadx) 6211 character*80 title 6212 dimension lhead(nheadx) 6213 6214c Returned from criterion checker, false if path fails criterion 6215 logical keep 6216 6217c read input 6218c header... 6219c i, x, y, z, ipot, i1b of nat+1 atoms (i=0 is central atom) 6220 open (1, file=trim(header)//'geom.dat', status='old', iostat=ios) 6221 call chopen (ios, trim(header)//'geom.dat', 'paths') 6222 nhead = nheadx 6223 call rdhead (1, nhead, head, lhead) 6224c header from geom.dat includes carriage control... 6225c nlegxx is max number of legs user wants to consider. 6226c nlegs = npat+1, so set npatxx = min (npatx, nlegxx-1) 6227 npatxx = min (npatx, nlegxx-1) 6228c Input rmax is one-way distances 6229 rmax = rmax*2 6230 nat = -1 6231c ratx is distance to most distant atom, used to check rmax 6232 ratx = 0 6233 10 continue 6234 nat = nat+1 6235 if (nat .gt. natx) then 6236 write(77,*) ' nat, natx ', nat, natx 6237 stop 'Bad input' 6238 endif 6239 read(1,*,end=20) idum, (rat(j,nat),j=1,3), ipot(nat), i1b(nat) 6240 rtmp = sdist(rat(1,nat),rat(1,0)) 6241 if (rtmp .gt. ratx) ratx = rtmp 6242 goto 10 6243 20 continue 6244 nat = nat-1 6245 close (unit=1) 6246 6247c Warn user if rmax > dist to most distant atom 6248 if (rmax/2.0d0 .gt. ratx+0.02d0) then 6249 write(77,*) ' WARNING: rmax > distance to most distant atom.' 6250 write(77,*) ' Some paths may be missing.' 6251 write(77,*) ' rmax, ratx ', rmax/2, ratx 6252 endif 6253 6254c Count number of 1st bounce atoms (at least 1 required). 6255 n1b = 0 6256 do 30 i = 1, nat 6257 if (i1b(i) .gt. 0) n1b = n1b + 1 6258 30 continue 6259 if (n1b .lt. 1) stop 'At least one 1st bounce atoms required.' 6260 6261 if (rmax .ge. big) stop 'Hey, get real with rmax!' 6262 6263c Make title for this run, include carriage control because head 6264c (read above) includes carriage control. 6265 write(title,32) rmax/2, pcritk, pcrith, vfeff, vpaths 6266 32 format(' Rmax', f8.4, ', keep limit', f7.3, 6267 1 ', heap limit', f7.3, t57, 2a12) 6268 6269 write(77,34) rmax/2, pcritk, pcrith 6270 34 format (' Rmax', f8.4, 6271 1 ' keep and heap limits', 2f12.7) 6272 6273 write(77,36) ' Preparing neighbor table' 6274 36 format (1x, a) 6275c prepare table telling distance from atom i to atom j and then 6276c back to central atom 6277c First bounce is m(-1,...), m(0,...) is bounces from central 6278c atom that are not first bounces. 6279 do 60 i = -1, nat 6280 ir = i 6281 if (i .eq. -1) ir = 0 6282 do 40 j = 0, nat 6283c r begins with element 1 so sort routine later will work 6284 r(j+1) = sdist (rat(1,ir), rat(1,j)) 6285 r(j+1) = r(j+1) + sdist (rat(1,j), rat(1,0)) 6286c we don't need m(i,i), since this will be = shortest 6287c of the r(j), so just set it to something very big, 6288c it will sort to the end of this row and it won't 6289c bother us 6290 if (j .eq. ir) r(j+1) = big 6291c If we're doing first bounce, use only the allowed first 6292c bounce paths. 6293 if (i .eq. -1) then 6294 if (i1b(j) .le. 0) r(j+1) = big 6295 endif 6296 40 continue 6297 6298c prepare row i of m table 6299c m is a distance table ordered such that distance from 6300c i to m(i,0) to 0 < 6301c i to m(i,1) to 0 < 6302c i m(i,2) 0 < 6303c : : : 6304c i m(i,nat) 0 6305c 6306c That is, m(i,0) is index of atom that gives shortest path, 6307c m(i,1) next shortest path, etc. 6308c Note that m(0,0) is shortest single bounce path. 6309 6310c Again, r and mindex go from 1 to nat+1, m goes from 0 to nat 6311 call sortir (nat+1, mindex, r) 6312 do 50 j = 0, nat 6313 m(i,j) = mindex(j+1)-1 6314 50 continue 6315 60 continue 6316 6317 write(77,61) 6318 61 format (' nfound nheap nheapx nsc r') 6319 6320c initialize heap data space next pointers 6321 do 70 i = 1, nx-1 6322 npat(i) = i+1 6323 70 continue 6324 npat(nx) = -1 6325c initial condition: make the first path 6326c n number in heap 6327c nna number skipped counter 6328c nhx number used in heap max, a counter 6329 n = 1 6330 nna = 0 6331 nhx = n 6332 nwrote = 0 6333 index(n) = 1 6334 ip = index(n) 6335 next = 2 6336 mi(ip) = -1 6337 mj(ip) = 0 6338 npat(ip) = 1 6339 ipat(npat(ip),1) = m(mi(ip),mj(ip)) 6340 6341c near neighbor is atom ipat(npat(ip),1) for first path into heap 6342 ipotnn = ipot(ipat(npat(ip),1)) 6343 6344c Someday change keep and keep1 to lkeep and lheap to match 6345c ccrit variable names. 6346c Initialize keep criterion 6347 xcalcx = -1 6348 call ccrit(npat(ip), ipat(1,ip), ckspc, 6349 1 fbetac, rmax, pcrith, pcritk, nncrit, ipotnn, ipot, 6350 2 r(n), keep, keep1(ip), xcalcx) 6351 6352 open (file=trim(header)//'paths.bin', unit=3, access='sequential', 6353 1 form='unformatted', status='unknown', iostat=ios) 6354 call chopen (ios, trim(header)//'paths.bin', 'paths') 6355c These strings are all char*80 and include carriage control 6356 write(3) nhead+1 6357 do 88 ihead = 1, nhead 6358 write(3) head(ihead) 6359 write(3) lhead(ihead) 6360 88 continue 6361 write(3) title 6362 write(3) istrln(title) 6363 write(3) nat 6364 do 90 i = 0, nat 6365 write(3) (rat(j,i),j=1,3), ipot(i), i1b(i) 6366 90 continue 6367 6368c r is the heap, index is the pointer to the rest of the data 6369c np is the number of paths found and saved 6370 np = 0 6371c nbx mpat max (Number of Bounces maX) 6372 nbx = 0 6373 6374c done if path at top of heap is longer than longest path we're 6375c interested in 6376c done if max number of paths we want have been found 6377c begin 'while not done' loop 6378 ok = .false. 6379 800 continue 6380 if (r(1) .gt. rmax .or. np .ge. npx .or. n.le.0) then 6381c n=0 means heap is empty 6382 if (n.le.0) ok=.true. 6383c if (n.le.0) print*, ' Heap empty' 6384 goto 2000 6385 endif 6386 6387c save element at top of heap in arrays labeled 0 6388c dump to unit 3 (unformatted) 6389 ip = index(1) 6390 npat0 = npat(ip) 6391 do 100 i = 1, npat0 6392 ipat0(i) = ipat(i,ip) 6393 100 continue 6394 r0 = r(1) 6395 6396c Don't write out path if last atom is central atom, or 6397c if it doesn't meet pcritk 6398 if (ipat0(npat0).eq.0 .and. keep1(ip)) then 6399 write(77,*) ipat0(npat0), keep1(ip), ' odd case...' 6400 endif 6401 if (ipat0(npat0).ne.0 .and. keep1(ip)) then 6402 np = np+1 6403c pack integers 6404 call ipack (iout, npat0, ipat0) 6405 write(3) r0, iout 6406 nwrote = nwrote+1 6407c write status report to screen 6408 if (mod(np,1000) .eq. 0) then 6409 write(77,132) np, n, nhx, nbx, r0/2 6410 132 format (4x, i6, i7, i8, i4, f10.4) 6411 endif 6412 endif 6413 6414 if (np .ge. npx) then 6415 write(77,*) np, ' paths found. (np .ge. npx)' 6416 goto 2000 6417 endif 6418 6419c Make new path by replacing last atom in path from top of heap, 6420c put this path on top of heap and buble it down. If row is 6421c finished, or new path is too long, don't add it, instead 6422c move last path in heap to the top. 6423c If working on row mi=-1 (first bounce atoms), don't 6424c use them if not allowed 1st bounce atoms. 6425 mj(ip) = mj(ip) + 1 6426 if (mi(ip).eq.-1 .and. i1b(m(mi(ip),mj(ip))).le.0) then 6427c not allowed first bounce atom 6428 r(1) = big 6429 keep = .false. 6430c print*, '1st bounce limit!' 6431 elseif (mj(ip) .ge. nat) then 6432c we've finished a row of m matrix 6433 r(1) = big 6434 keep = .false. 6435 else 6436c new path has same indices, etc. Only need to replace 6437c last atom. 6438 ipat(npat(ip),ip) = m(mi(ip),mj(ip)) 6439 call ccrit (npat(ip), ipat(1,ip), ckspc, 6440 1 fbetac, rmax, pcrith, pcritk, nncrit, 6441 1 ipotnn, ipot, 6442 2 r(1), keep, keep1(ip), xcalcx) 6443 endif 6444 6445c If r is bigger than rmax or keep=false, remove element from 6446c heap by taking the last element in the heap and moving it to 6447c the top. Then bubble it down. When removing an element 6448c from the heap, be sure to save the newly freed up index. 6449c r(1) and index(1) are new path, set above 6450 if (r(1).gt.rmax .and. keep) then 6451 write(77,*) 'odd case rmax...' 6452 endif 6453 if (r(1).gt.rmax .or. .not.keep) then 6454 index(1) = index(n) 6455 r(1) = r(n) 6456c use npat as pointer to next free location 6457 npat(ip) = next 6458 next = ip 6459 n = n-1 6460c nna is Number Not Added to heap 6461 nna = nna + 1 6462c Maybe heap may be empty here, but that's alright 6463 endif 6464 if (npat(index(1)).gt.nbx .and. n.gt.0) nbx = npat(index(1)) 6465 6466c If heap is empty, don't call hdown. 6467 if (n.gt.0) call hdown (r, index, n) 6468 6469c and make a new path by adding an atom onto the end of the path 6470c we saved, put this at the end of the heap and bubble it up. 6471c Do this only if it won't be too many bounces. 6472 if (npat0+1 .le. npatxx) then 6473 ip = next 6474 if (ip .lt. 0) then 6475c print*, ' Heap full' 6476 goto 2000 6477 endif 6478 next0 = npat(ip) 6479 do 200 i = 1, npat0 6480 ipat(i,ip) = ipat0(i) 6481 200 continue 6482 mi(ip) = ipat0(npat0) 6483 mj(ip) = 0 6484 npat(ip) = npat0+1 6485 ipat(npat(ip),ip) = m(mi(ip),mj(ip)) 6486 call ccrit (npat(ip), ipat(1,ip), ckspc, 6487 1 fbetac, rmax, pcrith, pcritk, nncrit, 6488 1 ipotnn, ipot, 6489 2 rtmp, keep, kp1tmp, xcalcx) 6490 if (rtmp .gt. rmax .and. keep) then 6491 write(77,*) 'odd case rmax and tmp...' 6492 endif 6493 if (rtmp .gt. rmax .or. .not.keep) then 6494 npat(ip) = next0 6495 nna = nna+1 6496 else 6497c add it to the heap 6498 next = next0 6499 n = n+1 6500 if (n .gt. nhx) nhx = n 6501 index(n) = ip 6502 r(n) = rtmp 6503 keep1(ip) = kp1tmp 6504 if (npat(index(n)) .gt. nbx) nbx = npat(index(n)) 6505 call hup (r, index, n) 6506 endif 6507 endif 6508 6509 goto 800 6510 2000 continue 6511c end of 'while not done' loop 6512 if (.not. ok) then 6513 write(77,*) ' Internal path finder limit exceeded -- ', 6514 1 'path list may be incomplete.' 6515 endif 6516 close (unit=3) 6517 write(77,2010) np, nhx, nbx 6518 2010 format (' Paths found', i9, 3x, 6519 1 '(nheapx, nbx', i8, i4, ')') 6520 6521 end 6522 subroutine pathsd(ckspc, fbetac, ne, ik0, cksp, fbeta, 6523 1 critpw, ipotnn, ipr2, 6524 1 pcritk, pcrith, nncrit, potlbl) 6525 6526 implicit double precision (a-h, o-z) 6527c New degeneracy checker, cute and hopefully fast for large 6528c problems 6529 6530c pcritk and pcrith used only for analysis after outcrt 6531 6532 character*72 header 6533 common /header_common/ header 6534 6535 6536 parameter (pi = 3.1415926535897932384626433d0) 6537 parameter (one = 1, zero = 0) 6538 parameter (third = 1.0d0/3.0d0) 6539 parameter (raddeg = 180.0d0 / pi) 6540 complex*16 coni 6541 parameter (coni = (0.0d0,1.0d0)) 6542c kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37 6543 parameter (fa = 1.919 158 292 677 512 811) 6544 6545 parameter (bohr = 0.529177249d0, ryd = 13.605698d0) 6546 parameter (alpinv = 137.03598956d0) 6547c fine structure alpha 6548 parameter (alphfs = 1.0d0 / alpinv) 6549c speed of light in louck's units (rydbergs?) 6550 parameter (clight = 2 * alpinv) 6551 6552 6553 parameter (nphx = 7) !max number of unique potentials (potph) 6554 parameter (npotx = nphx) !max number of unique potentials (genfmt, paths) 6555 parameter (nfrx = nphx) !max number of free atom types 6556 parameter (novrx = 8) !max number of overlap shells 6557 parameter (natx = 250) !max number of atoms in problem 6558 parameter (ltot = 24) !max number of ang mom (arrays 1:ltot+1) 6559 parameter (nrptx = 250) !Loucks r grid used through overlap 6560 parameter (nex = 100) !Number of energy points genfmt, etc. 6561 6562 parameter (lamtot=15) !Max number of distinct lambda's for genfmt 6563 !15 handles iord 2 and exact ss 6564 parameter (mtot=4, ntot=2) !vary mmax and nmax independently 6565 parameter (legtot=9) !matches path finder, used in GENFMT 6566 parameter (npatx = 8) !max number of path atoms, used in path 6567 !finder, NOT in genfmt 6568 6569 6570c global polarization data 6571 logical pola 6572 double precision evec,ivec,elpty 6573 complex*16 ptz 6574 common /pol/ evec(3), ivec(3), elpty, ptz(-1:1,-1:1), pola 6575 6576 common /atoms/ rat(3,0:natx), ipot(0:natx), i1b(0:natx) 6577 6578c np1x number of paths to consider at 1 time 6579 parameter (np1x = 12 000) 6580c parameter (np1x = 60 000) 6581 dimension iout(3,np1x), iout0(3) 6582 6583 dimension index(np1x) 6584 double precision dhash(np1x), dcurr, ddum 6585 dimension rx(npatx), ry(npatx), rz(npatx), ipat(npatx+1) 6586 dimension rx0(npatx), ry0(npatx), rz0(npatx), ipat0(npatx+1) 6587 double precision rid(npatx+1), betad(npatx+1), etad(npatx+1) 6588 6589 parameter (nheadx = 40) 6590 character*80 head(nheadx) 6591 dimension lhead(nheadx) 6592 6593 character*6 potlbl(0:npotx) 6594 6595c eps5 for rtotal range, eps3 for individual leg parameters. 6596c eps3 large since code single precision and don't want round-off 6597c error to reduce degeneracy. 6598 parameter (eps5 = 2.0d-5) 6599 parameter (eps3 = 2.0d-3) 6600 6601 logical ldiff, last 6602 parameter (necrit=9, nbeta=40) 6603 real*8 fbetac(-nbeta:nbeta,0:npotx,necrit), ckspc(necrit) 6604 real*8 fbeta(-nbeta:nbeta,0:npotx,nex), cksp(nex) 6605 6606 write(77,30) critpw 6607 30 format (' Plane wave chi amplitude filter', f7.2, '%') 6608 6609c Read atoms info 6610 open (file=trim(header)//'paths.bin', unit=3, access='sequential', 6611 1 form='unformatted', status='old', iostat=ios) 6612 call chopen (ios, trim(header)//'paths.bin', 'pathsd') 6613 read(3) nhead 6614 do 40 ihead = 1, nhead 6615 read(3) head(ihead) 6616 read(3) lhead(ihead) 6617 40 continue 6618c Header lines above include carriage control 6619 read(3) nat 6620 do 50 i = 0, nat 6621 read(3) (rat(j,i),j=1,3), ipot(i), i1b(i) 6622 50 continue 6623 6624c Initialize stuff... 6625c nptot number of total paths, incl all degeneracies 6626c nuptot number of unique paths for which must calc xafs 6627c ngs number of generalized shells (unique distances) 6628 nptot = 0 6629 nuptot = 0 6630 ngs = 0 6631 xportx = eps5 6632 ndegx = 1 6633 c0lim = 1.0d10 6634 c1lim = 1.0d10 6635c Initialize keep criterion 6636 xcalcx = -1 6637 6638c write output to paths.dat 6639 if (ipr2 .ne. 5) then 6640 open (unit=1, file=trim(header)//'paths.dat', 6641 > status='unknown', iostat=ios) 6642 call chopen (ios, trim(header)//'paths.dat', 'pathsd') 6643 do 60 ihead = 1, nhead 6644 write(1,58) head(ihead)(1:lhead(ihead)) 6645 58 format(a) 6646 60 continue 6647 write(1,61) critpw 6648 61 format (' Plane wave chi amplitude filter', f7.2, '%') 6649 write(1,62) 6650 62 format (1x, 79('-')) 6651 endif 6652 6653c Write crit.dat (criteria information) 6654 if (ipr2 .ge. 1) then 6655 open (unit=4, file=trim(header)//'crit.dat', 6656 > status='unknown', iostat=ios) 6657 call chopen (ios, trim(header)//'crit.dat', 'pathsd') 6658 do 65 ihead = 1, nhead 6659 write(4,58) head(ihead)(1:lhead(ihead)) 6660 65 continue 6661 write(4,61) critpw 6662 write(4,62) 6663 write(4,80) 6664 80 format (' ipath nleg ndeg r pwcrit ', 6665 1 'xkeep accuracy xheap accuracy') 6666 endif 6667 6668c Read path data for each total path length range 6669 6670c Prepare for first path. 6671 read(3,end=999) r0, iout0 6672 6673c Begin next total path length range 6674 last = .false. 6675 100 continue 6676 ngs = ngs+1 6677 rcurr = r0 6678 np = 1 6679 do 110 i = 1,3 6680 iout(i,np) = iout0(i) 6681 110 continue 6682 120 read(3,end=140) r0, iout0 6683 if (abs(r0-rcurr) .lt. eps3) then 6684 np = np+1 6685 if (np .gt. np1x) then 6686 write(77,*) ' np, np1x ', np, np1x 6687 stop 'np > np1x' 6688 endif 6689 do 130 i = 1, 3 6690 iout(i,np) = iout0(i) 6691 130 continue 6692 else 6693c r0 is the rtot for the next set 6694c iout0 is the packed atom list for the first path of the 6695c next set 6696 goto 200 6697 endif 6698 goto 120 6699 140 continue 6700c Get here only if end-of-file during read 6701 last = .true. 6702 6703 200 continue 6704 6705 nupr = 0 6706c variable nuprtt was nuprtot, changed to be six chars, SIZ 12/93 6707 nuprtt = 0 6708 6709c Hash each path into an integer 6710 iscale = 1000 6711 do 230 ip = 1, np 6712 6713 npat = npatx 6714 call upack (iout(1,ip), npat, ipat) 6715 6716c Get hash key for this path. 6717c If two paths are the same, except time-reversed, the xafs 6718c will be the same, so check for this type of degeneracy. 6719c We do this by choosing a 'standard order' for a path -- 6720c if it's the other-way-around, we time-reverse here. 6721 call timrep (npat, ipat, rx, ry, rz, dhash(ip)) 6722 6723 230 continue 6724 6725c Do a heap sort on these things 6726 call sortid (np, index, dhash) 6727 6728c Find beginning and end of range with same hash key 6729c i0 is beginning of hash range, i1 is end of the range 6730 6731 i0 = 1 6732 300 continue 6733 i1 = np + 1 6734 dcurr = dhash(index(i0)) 6735 do 310 ip = i0+1, np 6736 if (dhash(index(ip)) .ne. dcurr) then 6737c end of a hash range 6738 i1 = ip 6739 goto 311 6740 endif 6741 310 continue 6742 311 continue 6743 i1 = i1-1 6744 6745c At this point, i0 is the first path and i1 the last 6746c of a hash range. Do whatever you want with them! 6747 6748c Sum degeneracy, including degeneracy from 1st bounce atom. 6749c Check this range to see if all of the paths are actually 6750c degenerate. Make sure time-ordering is standard. 6751 npat0 = npatx 6752 call upack (iout(1,index(i0)), npat0, ipat0) 6753 call timrep (npat0, ipat0, rx0, ry0, rz0, ddum) 6754 6755 ndeg = 0 6756 do 430 ii = i0, i1 6757 npat = npatx 6758 call upack (iout(1,index(ii)), npat, ipat) 6759c Note that if path gets time-reversed, we lose 1st bounce 6760c flag (since first atom is now last...), so save path deg 6761 ndpath = i1b(ipat(1)) 6762 call timrep (npat, ipat, rx, ry, rz, ddum) 6763c Sum degeneracy here. 6764 ndeg = ndeg + ndpath 6765c Check for hash collisons begins here. 6766 ldiff = .false. 6767 if (npat .ne. npat0) then 6768 ldiff = .true. 6769 goto 430 6770 endif 6771 do 320 iat = 1, npat 6772 if (ipot(ipat(iat)) .ne. ipot(ipat0(iat))) then 6773 ldiff = .true. 6774 goto 400 6775 endif 6776 320 continue 6777 do 330 ileg = 1, npat 6778 if (abs(rx(ileg)-rx0(ileg)) .gt. eps3 .or. 6779 1 abs(ry(ileg)-ry0(ileg)) .gt. eps3 .or. 6780 2 abs(rz(ileg)-rz0(ileg)) .gt. eps3) then 6781 ldiff = .true. 6782 goto 400 6783 endif 6784 330 continue 6785 400 continue 6786 if (ldiff) then 6787 write(77,*) 'WARNING!! Two non-degenerate paths hashed ', 6788 1 'to the same hash key!!' 6789 write(77,*) dhash(index(i0)), dhash(index(ii)) 6790 write(77,*) npat0, npat, ' npat0, npat' 6791 write(77,*) ' iat, ipot0, ipot, ipat0, ipat' 6792 do 410 iat = 1, npat 6793 write(77,*) iat, ipot(ipat0(iat)), ipot(ipat(iat)), 6794 1 ipat0(iat), ipat(iat) 6795 410 continue 6796 write(77,*) 'ileg, rx0,ry0,rz0, rx1,ry1,rz1' 6797 do 420 ileg = 1, npat 6798 write(77,*) ileg, rx0(ileg), rx(ileg) 6799 write(77,*) ileg, ry0(ileg), ry(ileg) 6800 write(77,*) ileg, rz0(ileg), rz(ileg) 6801 420 continue 6802 stop 'hash error' 6803 endif 6804 430 continue 6805 6806c Find path pw importance factors, and recalculate 6807c pathfinder crits for output 6808 call outcrt (npat0, ipat0, ckspc, 6809 1 nncrit, fbetac, ne, ik0, cksp, fbeta, 6810 1 ipotnn, ipot, 6811 1 xport, xheap, xheapr, xkeep, xcalcx) 6812 6813 if (xport*ndeg .gt. xportx*ndegx) then 6814 xportx = xport 6815c ndegx is degeneracy of path that makes xportx, used for 6816c testing new path keep crit 6817 ndegx = ndeg 6818 endif 6819c frac is fraction of max importance to use for test 6820 frac = 100*ndeg*xport/(ndegx*xportx) 6821 6822c Write output if path is important enough (ie, path is 6823c at least critpw % important as most important path found 6824c so far.) 6825 if (frac .ge. critpw) then 6826 nupr = nupr+1 6827 nuprtt = nuprtt+ndeg 6828 nptot = nptot + ndeg 6829 nuptot = nuptot + 1 6830 6831c Write path info to paths.dat 6832c mpprmd is double precision, used to get angles 6833c 180.000 instead of 179.983, etc. 6834 call mpprmd (npat0, ipat0, rid, betad, etad) 6835c skip paths.dat if not necessary 6836 if (ipr2 .eq. 5) goto 576 6837 write(1,500) nuptot, npat0+1, real(ndeg), 6838 1 rcurr/2 6839 500 format (1x, 2i5, f8.3, 6840 1 ' index, nleg, degeneracy, r=', f8.4) 6841 write(1,502) 6842 502 format (' x y z ipot ', 6843 1 'label rleg beta eta') 6844 do 510 i = 1, npat0 6845 iat = ipat0(i) 6846 write(1,506) rat(1,iat), rat(2,iat), 6847 1 rat(3,iat), ipot(iat), potlbl(ipot(iat)), 6848 1 rid(i), betad(i)*raddeg, etad(i)*raddeg 6849 506 format (3f12.6, i4, 1x, '''', a6, '''', 1x, 3f10.4) 6850 510 continue 6851 write(1,506) rat(1,0), rat(2,0), rat(3,0), ipot(0), 6852 1 potlbl(ipot(0)), 6853 1 rid(npat0+1), betad(npat0+1)*raddeg, etad(npat0+1)*raddeg 6854c End of paths.dat writing for this path 6855 6856c Write to crit.dat here (unit 4, opened above) 6857 576 continue 6858 6859c cmpk is degeneracy corrected xkeep, should equal frac 6860 cmpk = xkeep*ndeg/ndegx 6861c cmpk is accuracy of xkeep, 100 is perfect 6862 cmpk = 100.0d0 - 100.0d0*(abs(frac-cmpk)/frac) 6863 6864c cmph is same thing for xheap 6865 if (xheap .lt. 0.0d0) then 6866 cmph = 100.0d0 6867 else 6868 cmph = xheap*ndeg/ndegx 6869 cmph = 100.0d0 - 100.0d0*(abs(frac-cmph)/frac) 6870 endif 6871 6872 if (ipr2 .ge. 1) then 6873 write(4,560) nuptot, npat0+1, ndeg, rcurr/2, frac, 6874 1 xkeep, cmpk, xheap, cmph 6875 560 format (i6, i4, i6, 3f10.4, f8.2, f10.4, 1pe14.3) 6876 endif 6877 6878c write out fraction error between xkeep and critpw 6879 endif 6880 6881c And do next ihash range 6882 i0 = i1+1 6883 if (i0 .le. np) goto 300 6884 6885c print 600, ngs, rcurr, nupr 6886 600 format (1x, i5, f12.6, i7, ' igs, rcurr, nupr') 6887c write(80,601) ngs, rcurr/2, nupr, nuprtt 6888 601 format (1x, i8, f12.6, 2i9) 6889 6890 if (.not. last) goto 100 6891 6892 if (ipr2 .ne. 5) close (unit=1) 6893c delete paths.bin when done... 6894 close (unit=3, status='delete') 6895 close (unit=4) 6896 6897 write(77,620) nuptot, nptot 6898 620 format (' Unique paths', i7, ', total paths', i8) 6899 6900c Do not let user accidently fill up their disk 6901 if (nuptot .gt. 3200) then 6902 write(77,*) 'You have found more than 1200 paths. Genfmt' 6903 write(77,*) 'could require a lot of time and more than 6 meg of' 6904 write(77,*) 'storage. Suggest a larger critpw to reduce number' 6905 write(77,*) 'of paths. To continue this calculation, restart' 6906 write(77,*) 'with current paths.dat and module genfmt (3rd module' 6907 write(77,*) 'on CONTROL card).' 6908 stop 'User must verify very large run.' 6909 endif 6910 return 6911 999 stop 'no input' 6912 end 6913c Periodic table of the elements 6914c Written by Steven Zabinsky, Feb 1992. Deo Soli Gloria 6915 6916c atwts(iz) single precision fn, returns atomic weight 6917c atwtd(iz) double precision fn, returns atomic weight 6918c atsym(iz) character*2 fn, returns atomic symbol 6919 6920 double precision function atwtd(iz) 6921 implicit double precision (a-h, o-z) 6922 double precision weight 6923 save /atwtco/ 6924 common /atwtco/ weight(103) 6925 atwtd = weight(iz) 6926 return 6927 end 6928 6929 real*8 function atwts(iz) 6930 implicit double precision (a-h, o-z) 6931 double precision weight 6932 save /atwtco/ 6933 common /atwtco/ weight(103) 6934 atwts = weight(iz) 6935 return 6936 end 6937 6938 character*2 function atsym (iz) 6939 implicit double precision (a-h, o-z) 6940 character*2 sym 6941 save /atsyco/ 6942 common /atsyco/ sym(103) 6943 atsym = sym(iz) 6944 return 6945 end 6946 6947 block data prtbbd 6948c PeRiodic TaBle Block Data 6949 6950c Atomic weights from inside front cover of Ashcroft and Mermin. 6951 6952 double precision weight 6953 save /atwtco/ 6954 common /atwtco/ weight(103) 6955 6956 character*2 sym 6957 save /atsyco/ 6958 common /atsyco/ sym(103) 6959 6960 data weight / 6961 1 1.0079d0, 4.0026d0, 6.941d0, 9.0122d0, 10.81d0, 12.01d0, 6962 2 14.007d0, 15.999d0, 18.998d0, 20.18d0, 22.9898d0, 24.305d0, 6963 3 26.982d0, 28.086d0, 30.974d0, 32.064d0, 35.453d0, 39.948d0, 6964 4 39.09d0, 40.08d0, 44.956d0, 47.90d0, 50.942d0, 52.00d0, 6965 5 54.938d0, 55.85d0, 58.93d0, 58.71d0, 63.55d0, 65.38d0, 6966 6 69.72d0, 72.59d0, 74.922d0, 78.96d0, 79.91d0, 83.80d0, 6967 7 85.47d0, 87.62d0, 88.91d0, 91.22d0, 92.91d0, 95.94d0, 6968 8 98.91d0, 101.07d0, 102.90d0, 106.40d0, 107.87d0, 112.40d0, 6969 9 114.82d0, 118.69d0, 121.75d0, 127.60d0, 126.90d0, 131.30d0, 6970 x 132.91d0, 137.34d0, 138.91d0, 140.12d0, 140.91d0, 144.24d0, 6971 1 145.0d0, 150.35d0, 151.96d0, 157.25d0, 158.92d0, 162.50d0, 6972 2 164.93d0, 167.26d0, 168.93d0, 173.04d0, 174.97d0, 178.49d0, 6973 3 180.95d0, 183.85d0, 186.2d0, 190.20d0, 192.22d0, 195.09d0, 6974 4 196.97d0, 200.59d0, 204.37d0, 207.19d0, 208.98d0, 210.0d0, 6975 5 210.0d0, 222.0d0, 223.0d0, 226.0d0, 227.0d0, 232.04d0, 6976 6 231.0d0, 238.03d0, 237.05d0, 244.0d0, 243.0d0, 247.0d0, 6977 7 247.0d0, 251.0d0, 254.0d0, 257.0d0, 256.0d0, 254.0d0, 6978 8 257.0d0/ 6979 6980 data sym / 'H', 'He','Li','Be','B', 'C', 'N', 'O', 'F', 'Ne', 6981 1 'Na','Mg','Al','Si','P', 'S', 'Cl','Ar','K', 'Ca', 6982 2 'Sc','Ti','V', 'Cr','Mn','Fe','Co','Ni','Cu','Zn', 6983 3 'Ga','Ge','As','Se','Br','Kr','Rb','Sr','Y', 'Zr', 6984 4 'Nb','Mo','Tc','Ru','Rh','Pd','Ag','Cd','In','Sn', 6985 5 'Sb','Te','I', 'Xe','Cs','Ba','La','Ce','Pr','Nd', 6986 6 'Pm','Sm','Eu','Gd','Tb','Dy','Ho','Er','Tm','Yb', 6987 7 'Lu','Hf','Ta','W', 'Te','Os','Ir','Pt','Au','Hg', 6988 8 'Tl','Pb','Bi','Po','At','Rn','Fr','Ra','Ac','Th', 6989 9 'Pa','U', 'Np','Pu','Am','Cm','Bk','Cf','Es','Fm', 6990 x 'Md','No','Lw'/ 6991 6992 end 6993 subroutine phase (iph, nr, dx, x0, ri, ne, em, edge, 6994 1 index, rmt, xmu, vi0, rs0, gamach, 6995 2 vtot, edens, 6996 3 eref, ph, lmax) 6997 6998 implicit double precision (a-h, o-z) 6999 7000 character*72 header 7001 common /header_common/ header 7002 7003 7004c INPUT 7005c iph unique pot index (used for messages only) 7006c nr, dx, x0, ri(nr) 7007c Loucks r-grid, ri=exp((i-1)*dx-x0) 7008c ne, em(ne) number of energy points, real energy grid 7009c edge energy for k=0 (note, edge=xmu-vr0) 7010c index 0 Hedin-Lunqist + const real & imag part 7011c 1 Dirac-Hara + const real & imag part 7012c 2 ground state + const real & imag part 7013c 3 Dirac-Hara + HL imag part + const real & imag part 7014c 4, 5, 6, see rdinp or xcpot 7015c rmt r muffin tin 7016c xmu fermi level 7017c vi0 const imag part to add to complex potential 7018c rs0 user input density cutoff, used only with ixc=4 7019c gamach core hole lifetime 7020c vtot(nr) total potential, including gsxc 7021c edens(nr) density 7022c 7023c OUTPUT 7024c eref(ne) complex energy reference including energy dep xc 7025c ph(nex,ltot+1) complex scattering phase shifts 7026c lmax max l (lmax = kmax*rmt) 7027 7028 7029 parameter (nphx = 7) !max number of unique potentials (potph) 7030 parameter (npotx = nphx) !max number of unique potentials (genfmt, paths) 7031 parameter (nfrx = nphx) !max number of free atom types 7032 parameter (novrx = 8) !max number of overlap shells 7033 parameter (natx = 250) !max number of atoms in problem 7034 parameter (ltot = 24) !max number of ang mom (arrays 1:ltot+1) 7035 parameter (nrptx = 250) !Loucks r grid used through overlap 7036 parameter (nex = 100) !Number of energy points genfmt, etc. 7037 7038 parameter (lamtot=15) !Max number of distinct lambda's for genfmt 7039 !15 handles iord 2 and exact ss 7040 parameter (mtot=4, ntot=2) !vary mmax and nmax independently 7041 parameter (legtot=9) !matches path finder, used in GENFMT 7042 parameter (npatx = 8) !max number of path atoms, used in path 7043 !finder, NOT in genfmt 7044 7045 parameter (bohr = 0.529177249d0, ryd = 13.605698d0) 7046 7047 dimension ri(nr), em(nex), vtot(nr), edens(nr) 7048 complex*16 eref(nex) 7049 complex*16 ph(nex,ltot+1) 7050 7051c work space for xcpot 7052 dimension vxcrmu(nrptx), vxcimu(nrptx) 7053c work space for fovrg 7054 complex*16 p(nrptx), q(nrptx), ps(nrptx), qs(nrptx), vm(nrptx) 7055 7056 complex*16 p2, xkmt, temp, dny, pu, qu 7057 complex*16 jl(ltot+2), nl(ltot+2) 7058 complex*16 v(nrptx) 7059 external besjn 7060 7061 ihard = 0 7062c zero phase shifts (some may not be set below) 7063 do 100 ie = 1, ne 7064 do 90 il = 1, ltot+1 7065 ph(ie,il) = dcmplx(0.0d0,0.0d0) 7066 90 continue 7067 100 continue 7068 7069c limit l, lmax = kmax * rmt 7070c lmax = rmt * sqrt(em(ne)-edge) 7071c Use kmax = 20 so we get enough l-points even if kmax is small 7072 lmax = rmt * (20 * bohr) 7073 lmax = min (lmax, ltot) 7074 7075c set imt and jri (use general Loucks grid) 7076c rmt is between imt and jri (see function ii(r) in file xx.f) 7077 imt = (log(rmt) + x0) / dx + 1 7078 jri = imt+1 7079 if (jri .gt. nr) stop 'jri .gt. nr in phase' 7080c xmt is floating point version of imt, so that 7081c rmt = (exp (x-1)*dx - x0). xmt used in fovrg 7082 xmt = (log(rmt) + x0) / dx + 1 7083 7084 ifirst = 0 7085c calculate phase shifts 7086 do 220 ie = 1, ne 7087 7088 call xcpot (iph, ie, nr, index, ifirst, jri, 7089 1 em(ie), xmu, vi0, rs0, gamach, 7090 2 vtot, edens, 7091 3 eref(ie), v, 7092 4 vxcrmu, vxcimu) 7093 7094c fovrg needs v in form pot*r**2 7095 do 120 i = 1, jri 7096 v(i) = v(i) * ri(i)**2 7097 120 continue 7098 7099c p2 is (complex momentum)**2 referenced to energy dep xc 7100 p2 = em(ie) - eref(ie) 7101 xkmt = rmt * sqrt (p2) 7102 call besjn (xkmt, jl, nl) 7103 7104 do 210 il = 1, lmax+1 7105 l = il - 1 7106 7107 call fovrg(il, ihard, rmt, xmt, jri, p2, 7108 1 nr, dx, ri, v, dny, 7109 1 pu, qu, p, q, ps, qs, vm) 7110 7111 7112 temp = (jl(il)*(dny-l) + xkmt*jl(il+1)) / 7113 1 (nl(il)*(dny-l) + xkmt*nl(il+1)) 7114 xx = dble (temp) 7115 yy = dimag(temp) 7116 if (xx .ne. 0) then 7117 alph = (1 - xx**2 - yy**2) 7118 alph = sqrt(alph**2 + 4*xx**2) - alph 7119 alph = alph / (2 * xx) 7120 alph = atan (alph) 7121 else 7122 alph = 0 7123 endif 7124 beta = (xx**2 + (yy+1)**2) / 7125 1 (xx**2 + (yy-1)**2) 7126 beta = log(beta) / 4 7127 7128 ph(ie,il) = dcmplx (alph, beta) 7129 7130c cut phaseshift calculation if they become too small 7131 if (abs(ph(ie,il)) .lt. 1.0d-6) goto 220 7132 7133 210 continue 7134 7135 220 continue 7136 7137 7138c Warn user if fovrg failed ihard test. 7139 if (ihard .gt. 0) then 7140 write(77,*) ' Hard test failed in fovrg ', ihard, ' times.' 7141 write(77,*) ' Muffin-tin radius may be too large;', 7142 1 ' coordination number too small.' 7143 endif 7144 7145 return 7146 end 7147 subroutine phash (npat, ipat, rx, ry, rz, dhash) 7148c hashes a path into double precision real dhash 7149 implicit double precision (a-h, o-z) 7150 7151 7152 character*72 header 7153 common /header_common/ header 7154 7155 7156 parameter (nphx = 7) !max number of unique potentials (potph) 7157 parameter (npotx = nphx) !max number of unique potentials (genfmt, paths) 7158 parameter (nfrx = nphx) !max number of free atom types 7159 parameter (novrx = 8) !max number of overlap shells 7160 parameter (natx = 250) !max number of atoms in problem 7161 parameter (ltot = 24) !max number of ang mom (arrays 1:ltot+1) 7162 parameter (nrptx = 250) !Loucks r grid used through overlap 7163 parameter (nex = 100) !Number of energy points genfmt, etc. 7164 7165 parameter (lamtot=15) !Max number of distinct lambda's for genfmt 7166 !15 handles iord 2 and exact ss 7167 parameter (mtot=4, ntot=2) !vary mmax and nmax independently 7168 parameter (legtot=9) !matches path finder, used in GENFMT 7169 parameter (npatx = 8) !max number of path atoms, used in path 7170 !finder, NOT in genfmt 7171 7172 double precision dhash 7173 dimension rx(npatx), ry(npatx), rz(npatx), ipat(npatx+1) 7174 7175 common /atoms/ rat(3,0:natx), ipot(0:natx), i1b(0:natx) 7176 7177 double precision xx 7178 7179 parameter (iscale = 1000) 7180 parameter (factor = 16.12345678d0) 7181 7182c Hashing scheme: Assume about 15 significant digits in a double 7183c precision number. This is 53 bit mantissa and 11 bits for sign 7184c and exponent, vax g_floating and probably most other machines. 7185c With max of 9 legs, 47**9 = 1.12e15, so with a number less than 7186c 47, we can use all these digits, scaling each leg's data by 7187c 47**(j-1). Actually, since our numbers can go up to about 10,000, 7188c we should keep total number < 1.0e11, 17**9 = 1.18e11, which means 7189c a factor a bit less than 17. Choose 16.12345678, a non-integer, 7190c to help avoid hash collisions. 7191 7192c iscale and 'int' below are to strip off trailing digits, which 7193c may contain roundoff errors 7194 7195 dhash = 0 7196 do 210 j = 1, npat 7197 xx = factor**(j-1) 7198 dhash = dhash + xx * (nint(rx(j)*iscale) + 7199 1 nint(ry(j)*iscale)*0.894375 + 7200 2 nint(rz(j)*iscale)*0.573498) 7201 210 continue 7202 do 220 j = 1, npat 7203 xx = factor**(j-1) 7204 dhash = dhash + xx * ipot(ipat(j)) 7205 220 continue 7206 dhash = dhash + npat * 40 000 000 7207 7208 return 7209 end 7210c make e and r mesh for phase 7211c input: nr, dx, x0, nemax, iprint, 7212c ixanes, edge, xmu, vint, vr0, imt, edens, nph 7213c edge, xmu... used only with ixanes = 1 7214c output: ri(nr), ne, em(ne), ik0 [grid point with k=0] 7215c 7216c set nemax = nex (from dim.h) for max number of points 7217 7218 subroutine phmesh (nr, dx, x0, nemax, iprint, 7219 1 ixanes, edge, xmu, vint, vr0, 7220 1 imt, edens, nph, 7221 2 ri, ne, em, ik0) 7222 implicit double precision (a-h, o-z) 7223 7224 character*72 header 7225 common /header_common/ header 7226 7227 7228 parameter (pi = 3.1415926535897932384626433d0) 7229 parameter (one = 1, zero = 0) 7230 parameter (third = one/3) 7231 parameter (raddeg = 180 / pi) 7232 complex*16 coni 7233 parameter (coni = (0,1)) 7234c kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37 7235 parameter (fa = 1.919158292677512811d0) 7236 7237 parameter (bohr = 0.529177249d0, ryd = 13.605698d0) 7238 parameter (alpinv = 137.03598956d0) 7239c fine structure alpha 7240 parameter (alphfs = 1 / alpinv) 7241c speed of light in louck's units (rydbergs?) 7242 parameter (clight = 2 * alpinv) 7243 7244 7245 parameter (nphx = 7) !max number of unique potentials (potph) 7246 parameter (npotx = nphx) !max number of unique potentials (genfmt, paths) 7247 parameter (nfrx = nphx) !max number of free atom types 7248 parameter (novrx = 8) !max number of overlap shells 7249 parameter (natx = 250) !max number of atoms in problem 7250 parameter (ltot = 24) !max number of ang mom (arrays 1:ltot+1) 7251 parameter (nrptx = 250) !Loucks r grid used through overlap 7252 parameter (nex = 100) !Number of energy points genfmt, etc. 7253 7254 parameter (lamtot=15) !Max number of distinct lambda's for genfmt 7255 !15 handles iord 2 and exact ss 7256 parameter (mtot=4, ntot=2) !vary mmax and nmax independently 7257 parameter (legtot=9) !matches path finder, used in GENFMT 7258 parameter (npatx = 8) !max number of path atoms, used in path 7259 !finder, NOT in genfmt 7260 7261 dimension ri(nr), em(nex) 7262 7263c edens overlapped density*4*pi 7264c imt r mesh index just inside rmt 7265c see arrays.h 7266 dimension edens(nrptx,0:nphx) 7267 dimension imt(0:nphx) 7268 7269c r mesh 7270 do 100 i = 1, nr 7271 ri(i) = rr(i) 7272 100 continue 7273 7274c xkmin needed only with ixanes 7275 if (ixanes .gt. 0) then 7276c Need xf**2 min for all unique potentials, take rho(imt) as 7277c min rho 7278 xf2int = xmu-vint 7279 xf2min = xf2int 7280 do 400 i = 0, nph 7281 rs = (3 / edens(imt(i),i)) ** third 7282 xf2 = (fa / rs) ** 2 7283 if (xf2 .le. xf2min) xf2min = xf2 7284 400 continue 7285 7286 xkmin2 = xf2min - vr0 7287 if (xkmin2 .lt. 0) then 7288 write(77,*) ' xf2min, vr0, xkmin2' 7289 write(77,*) xf2min, vr0, xkmin2 7290 write(77,*) 'bad vr0 in phmesh' 7291 stop 'bad vr0 in phmesh' 7292 endif 7293 7294 delk = bohr/5.0d0 7295 xkmin = sqrt (xkmin2) 7296 n = int(xkmin/delk) - 1 7297 else 7298 xkmin = 0.0d0 7299 n = 0 7300 endif 7301 7302c energy mesh 7303c n pts (-2 le k lt 0, delk=0.2 ang(-1) ) (only if xanes) 7304c 30 pts (0 le k le 5.8, delk=0.2 ang(-1) ) 7305c 9 pts (6 le k le 10., delk=0.5 ang(-1) ) 7306c 10 pts (11 le k le 20.0, delk=1.0 ang(-1) ) 7307 ne = 0 7308 delk = bohr/5.0d0 7309 if (ixanes .gt. 0) then 7310 xkmin = n*delk 7311 do 110 i=1,n 7312 tempk=-xkmin+(i-1)*delk 7313 ne = ne+1 7314 em(ne)=-tempk**2+edge 7315 110 continue 7316 endif 7317 delk = bohr/5 7318 do 112 i=1,30 7319 tempk=(i-1)*delk 7320 ne = ne+1 7321 em(ne)=tempk**2+edge 7322 if (i.eq.1) ik0 = ne 7323 112 continue 7324 delk = bohr/2 7325 do 113 i=1,9 7326 tempk=6.*bohr + (i-1)*delk 7327 ne = ne+1 7328 em(ne)=tempk**2+edge 7329 113 continue 7330 delk=bohr 7331 do 114 i=1,10 7332 tempk=11.0d0*bohr + (i-1)*delk 7333 ne = ne+1 7334 em(ne)=tempk**2+edge 7335 114 continue 7336 7337c print*, 'phmesh: ne, nex, nemax before setting ne ', 7338c 1 ne, nex, nemax 7339 ne = min (ne, nemax) 7340c print*, 'phmesh: ne, nex, nemax after setting ne ', 7341c 1 ne, nex, nemax 7342 7343 7344 if (iprint .ge. 3) then 7345 open (unit=44, file=trim(header)//'emesh.dat') 7346 write(44,*) 'edge, bohr, edge*ryd ', edge, bohr, edge*ryd 7347 write(44,*) 'ixanes, ik0 ', ixanes, ik0 7348 write(44,*) vint, xkmin, n, ' vint, xkmin, n' 7349 write(44,*) 'ie, em(ie), xk(ie)' 7350 do 230 ie = 1, ne 7351 write(44,220) ie, em(ie), getxk(em(ie)-edge)/bohr 7352 220 format (i5, 2f20.5) 7353 230 continue 7354 close (unit=44) 7355 endif 7356 7357 return 7358 end 7359 subroutine pijump (ph, old) 7360 implicit double precision (a-h, o-z) 7361 7362 7363 character*72 header 7364 common /header_common/ header 7365 7366c removes jumps of 2*pi in phases 7367 7368c ph = current value of phase (may be modified on output, but 7369c only by multiples of 2*pi) 7370c old = previous value of phase 7371 7372 7373 parameter (pi = 3.1415926535897932384626433d0) 7374 parameter (one = 1, zero = 0) 7375 parameter (third = one/3) 7376 parameter (raddeg = 180 / pi) 7377 complex*16 coni 7378 parameter (coni = (0,1)) 7379c kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37 7380 parameter (fa = 1.919158292677512811d0) 7381 7382 parameter (bohr = 0.529177249d0, ryd = 13.605698d0) 7383 parameter (alpinv = 137.03598956d0) 7384c fine structure alpha 7385 parameter (alphfs = 1.0d0 / alpinv) 7386c speed of light in louck's units (rydbergs?) 7387 parameter (clight = 2 * alpinv) 7388 7389 parameter (twopi = 2 * pi) 7390 dimension xph(3) 7391 7392 xph(1) = ph - old 7393 jump = (abs(xph(1))+ pi) / twopi 7394 xph(2) = xph(1) - jump*twopi 7395 xph(3) = xph(1) + jump*twopi 7396 7397 7398 xphmin = min (abs(xph(1)), abs(xph(2)), abs(xph(3))) 7399 isave = 0 7400 do 10 i = 1, 3 7401 if (abs (xphmin - abs(xph(i))) .le. 0.01) isave = i 7402 10 continue 7403 if (isave .eq. 0) then 7404 write(77,*) 'isave ', isave 7405 write(77,*) xph(1) 7406 write(77,*) xph(2) 7407 write(77,*) xph(3) 7408 stop 'pijump' 7409 endif 7410 7411 ph = old + xph(isave) 7412 7413 return 7414 end 7415 subroutine potph (isporb) 7416 7417c Cluster code -- multiple shell single scattering version of FEFF 7418c This program (or subroutine) calculates potentials and phase 7419c shifts for unique potentials specifed by atoms and overlap cards. 7420c 7421c Input files: potph.inp input data, atoms, overlaps, etc. 7422c Output: phases.bin phase shifts for use by the rest of the 7423c program 7424c xxx.dat various diagnostics 7425 7426 implicit double precision (a-h, o-z) 7427 7428 character*72 header 7429 common /header_common/ header 7430 7431 7432 parameter (pi = 3.1415926535897932384626433d0) 7433 parameter (one = 1, zero = 0) 7434 parameter (third = one/3) 7435 parameter (raddeg = 180 / pi) 7436 complex*16 coni 7437 parameter (coni = (0,1)) 7438c kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37 7439 parameter (fa = 1.919158292677512811d0) 7440 7441 parameter (bohr = 0.529177249d0, ryd = 13.605698d0) 7442 parameter (alpinv = 137.03598956d0) 7443c fine structure alpha 7444 parameter (alphfs = 1.0d0 / alpinv) 7445c speed of light in louck's units (rydbergs?) 7446 parameter (clight = 2 * alpinv) 7447 7448 7449 parameter (nphx = 7) !max number of unique potentials (potph) 7450 parameter (npotx = nphx) !max number of unique potentials (genfmt, paths) 7451 parameter (nfrx = nphx) !max number of free atom types 7452 parameter (novrx = 8) !max number of overlap shells 7453 parameter (natx = 250) !max number of atoms in problem 7454 parameter (ltot = 24) !max number of ang mom (arrays 1:ltot+1) 7455 parameter (nrptx = 250) !Loucks r grid used through overlap 7456 parameter (nex = 100) !Number of energy points genfmt, etc. 7457 7458 parameter (lamtot=15) !Max number of distinct lambda's for genfmt 7459 !15 handles iord 2 and exact ss 7460 parameter (mtot=4, ntot=2) !vary mmax and nmax independently 7461 parameter (legtot=9) !matches path finder, used in GENFMT 7462 parameter (npatx = 8) !max number of path atoms, used in path 7463 !finder, NOT in genfmt 7464 7465 7466 7467c Notes: 7468c nat number of atoms in problem 7469c nph number of unique potentials 7470c nfr number of unique free atoms 7471c ihole hole code of absorbing atom 7472c iph=0 for central atom 7473c ifr=0 for central atom 7474 7475c Specific atom input data 7476 dimension iphat(natx) !given specific atom, which unique pot? 7477 dimension rat(3,natx) !cartesian coords of specific atom 7478 7479c Unique potential input data 7480 dimension iatph(0:nphx) !given unique pot, which atom is model? 7481 !(0 if none specified for this unique pot) 7482 dimension ifrph(0:nphx) !given unique pot, which free atom? 7483 dimension xnatph(0:nphx) !given unique pot, how many atoms are there 7484 !of this type? (used for interstitial calc) 7485 character*6 potlbl(0:nphx) !label for user convienence 7486 7487 dimension folp(0:nphx) !overlap factor for rmt calculation 7488 dimension novr(0:nphx) !number of overlap shells for unique pot 7489 dimension iphovr(novrx,0:nphx) !unique pot for this overlap shell 7490 dimension nnovr(novrx,0:nphx) !number of atoms in overlap shell 7491 dimension rovr(novrx,0:nphx) !r for overlap shell 7492 7493c Free atom data 7494 dimension ion(0:nfrx) !ionicity, input 7495 dimension iz(0:nfrx) !atomic number, input 7496 7497c ATOM output 7498c Note that ATOM output is dimensioned 251, all other r grid 7499c data is set to nrptx, currently 250 7500 dimension rho(251,0:nfrx) !density*4*pi 7501 dimension vcoul(251,0:nfrx) !coulomb potential 7502 7503c Overlap calculation results 7504 dimension edens(nrptx,0:nphx) !overlapped density*4*pi 7505 dimension vclap(nrptx,0:nphx) !overlapped coul pot 7506 dimension vtot (nrptx,0:nphx) !overlapped total potential 7507 7508c Muffin tin calculation results 7509 dimension imt(0:nphx) !r mesh index just inside rmt 7510 dimension inrm(0:nphx) !r mesh index just inside rnorman 7511 dimension rmt(0:nphx) !muffin tin radius 7512 dimension rnrm(0:nphx) !norman radius 7513 7514c PHASE output 7515 complex*16 eref(nex) !interstitial energy ref 7516 complex*16 ph(nex,ltot+1,0:nphx) !phase shifts 7517 dimension lmax(0:nphx) !number of ang mom levels 7518 7519 common /print/ iprint 7520 7521 parameter (nheadx = 30) 7522 character*80 head(nheadx) 7523 dimension lhead(nheadx) 7524 7525c head0 is header from potph.dat, include carriage control 7526 character*80 head0(nheadx) 7527 dimension lhead0(nheadx) 7528 7529 dimension em(nex) 7530 dimension dgc0(251), dpc0(251) 7531 dimension xsec(nex), xsatan(nex) 7532 7533c nrx = max number of r points for phase r grid 7534 parameter (nrx = 250) 7535 dimension ri(nrptx), vtotph(nrx), rhoph(nrx) 7536 7537 10 format (4x, a, i5) 7538 7539c Read input from file potph.inp 7540 open (unit=1, file=trim(header)//'potph.dat', 7541 > status='old', iostat=ios) 7542 call chopen (ios, trim(header)//'potph.dat', 'potph') 7543 nhead0 = nheadx 7544 call rpotph (1, nhead0, head0, lhead0, nat, nph, 7545 1 nfr, ihole, gamach, iafolp, intclc, 7546 1 ixc, vr0, vi0, rs0, iphat, rat, iatph, ifrph, 7547 1 xnatph, novr, 7548 2 iphovr, nnovr, rovr, folp, ion, iz, iprint, 7549 2 ixanes, nemax, xkmin, xkmax, potlbl) 7550 close (unit=1) 7551 7552c Free atom potentials and densities 7553c NB wsatom is needed in SUMAX, if changed here, change it there 7554 wsatom = 15 7555c do not save spinors 7556 ispinr = 0 7557 do 20 ifr = 0, nfr 7558 itmp = 0 7559 if (ifr .eq. 0) itmp = ihole 7560 write(77,10) 'free atom potential and density for atom type', ifr 7561 call feff_atom(head0(1)(1:40), ifr, iz(ifr), itmp, wsatom, 7562 1 ion(ifr), vcoul(1,ifr), rho(1,ifr), 7563 2 ispinr, dgc0, dpc0, et) 7564c etfin is absorbing atom final state total energy 7565c etinit is absorbing atom initial state (no hole) 7566 if (ifr .eq. 0) etfin = et 7567 20 continue 7568 if (ixanes .gt. 0) then 7569 write(77,10) 'initial state energy' 7570c save spinor for core hole orbital 7571 ispinr = ihole 7572c if no hole, use orbital from isporb 7573 if (ihole .eq. 0) ispinr = isporb 7574 itmp = 0 7575 call feff_atom (head0(1)(1:40), 0, iz(0), itmp, wsatom, 7576 1 ion(0), vcoul(1,nfr+1), rho(1,nfr+1), 7577 2 ispinr, dgc0, dpc0, etinit) 7578 endif 7579c Need etfin if xanes and no hole, use K shell for this 7580 if (ixanes .gt. 0 .and. ihole .eq. 0) then 7581c K hole 7582 itmp = 1 7583 ispinr = 0 7584 call feff_atom (head0(1)(1:40), 0, iz(0), itmp, wsatom, 7585 1 ion(0), vcoul(1,nfr+1), rho(1,nfr+1), 7586 2 ispinr, dgc0, dpc0, etfin) 7587 endif 7588 7589c Overlap potentials and densitites 7590 do 40 iph = 0, nph 7591 write(77,10) 7592 1 'overlapped potential and density for unique potential', iph 7593 call ovrlp (iph, iphat, rat, iatph, ifrph, novr, 7594 1 iphovr, nnovr, rovr, iz, nat, rho, vcoul, 7595 2 edens, vclap, rnrm) 7596 40 continue 7597 7598c Find muffin tin radii, add gsxc to potentials, and find 7599c interstitial parameters 7600 write(77,10) 'muffin tin radii and interstitial parameters' 7601 call istprm (nph, nat, iphat, rat, iatph, xnatph, 7602 1 novr, iphovr, nnovr, rovr, folp, edens, 7603 2 vclap, vtot, imt, inrm, rmt, rnrm, rhoint, 7604 3 vint, rs, xf, xmu, rnrmav, intclc) 7605 7606c Automatic max reasonable overlap 7607 if (iafolp .eq. 1) then 7608 write(77,10) 'automatic overlapping' 7609 write(77,*) 'iph, rnrm(iph)*bohr, rmt(iph)*bohr, folp(iph)' 7610 do 400 iph = 0, nph 7611 folp(iph) = 1 + 0.7*(rnrm(iph)/rmt(iph) - 1) 7612 write(77,*) iph, rnrm(iph)*bohr, rmt(iph)*bohr, folp(iph) 7613 400 continue 7614 call istprm (nph, nat, iphat, rat, iatph, xnatph, 7615 1 novr, iphovr, nnovr, rovr, folp, edens, 7616 2 vclap, vtot, imt, inrm, rmt, rnrm, rhoint, 7617 3 vint, rs, xf, xmu, rnrmav, intclc) 7618 endif 7619 7620c Initialize header routine and write misc.dat 7621 call sthead (nhead0, head0, lhead0, nph, iz, rmt, rnrm, 7622 1 ion, ifrph, ihole, ixc, 7623 2 vr0, vi0, rs0, gamach, xmu, xf, vint, rs, 7624 3 nhead, lhead, head) 7625 if (iprint .ge. 1) then 7626 open (unit=1, file=trim(header)//'misc.dat', 7627 > status='unknown', iostat=ios) 7628 call chopen (ios, trim(header)//'misc.dat', 'potph') 7629 call wthead(1) 7630 close (unit=1) 7631 endif 7632 7633 if (iprint .ge. 2) then 7634 call wpot (nph, edens, ifrph, imt, inrm, 7635 1 rho, vclap, vcoul, vtot) 7636 endif 7637 7638c Phase shift calculation 7639c Make energy mesh and position grid 7640 nr = 250 7641 dx = .05 7642 x0 = 8.8 7643 edge = xmu - vr0 7644 call phmesh (nr, dx, x0, nemax, iprint, 7645 1 ixanes, edge, xmu, vint, vr0, 7646 1 imt, edens, nph, 7647 2 ri, ne, em, ik0) 7648 7649c Cross section calculation, use phase mesh for now 7650c remove xanes calculation in feff6l 7651 7652 do 60 iph = 0, nph 7653 write(77,10) 'phase shifts for unique potential', iph 7654c fix up variable for phase 7655 call fixvar (rmt(iph), edens(1,iph), vtot(1,iph), 7656 1 vint, rhoint, nr, dx, x0, ri, 7657 2 vtotph, rhoph) 7658 7659 call phase (iph, nr, dx, x0, ri, ne, em, edge, 7660 1 ixc, rmt(iph), xmu, vi0, rs0, gamach, 7661 2 vtotph, rhoph, 7662 3 eref, ph(1,1,iph), lmax(iph)) 7663 60 continue 7664 7665 if (iprint .ge. 2) then 7666 call wphase (nph, em, eref, lmax, ne, ph) 7667 endif 7668 7669c Write out phases for genfmt 7670c May need stuff for use with headers only 7671 open (unit=1, file=trim(header)//'phase.bin', access='sequential', 7672 1 form='unformatted', status='unknown', iostat=ios) 7673 call chopen (ios, trim(header)//'phase.bin', 'potph') 7674 write(1) nhead 7675 do 62 i = 1, nhead 7676 write(1) head(i) 7677 write(1) lhead(i) 7678 62 continue 7679 write(1) ne, nph, ihole, rnrmav, xmu, edge, ik0 7680 write(1) (em(ie),ie=1,ne) 7681 write(1) (eref(ie),ie=1,ne) 7682 do 80 iph = 0, nph 7683 write(1) lmax(iph), iz(ifrph(iph)) 7684 write(1) potlbl(iph) 7685 do 70 ie = 1, ne 7686 write(1) (ph(ie,ll,iph), ll=1,lmax(iph)+1) 7687 70 continue 7688 80 continue 7689 close (unit=1) 7690 7691 return 7692 end 7693 subroutine potsl (dv,d,dp,dr,dpas,dexv,z,np,ion,icut,dvn) 7694c 7695c coulomb potential uses a 4-point integration method 7696c dv=potential; d=density; dp=bloc de travail; dr=radial mesh; 7697c dpas=exponential step; dexv=multiplicative coefficient for the exchang 7698c z=atomic number; np=number of points; ion=z-number of electrons 7699c if icut is zero one corrects the potential by -(ion+1)/r 7700c ********************************************************************** 7701 implicit double precision (a-h,o-z) 7702 save 7703 dimension dv(251), d(251), dp(251), dr(251), dvn(251) 7704 das=dpas/24.0d0 7705 do 10 i=1,np 7706 10 dv(i)=d(i)*dr(i) 7707 dlo=exp(dpas) 7708 dlo2=dlo*dlo 7709 dp(2)=dr(1)*(d(2)-d(1)*dlo2)/(12.0*(dlo-1.0)) 7710 dp(1)=dv(1)/3.0-dp(2)/dlo2 7711 dp(2)=dv(2)/3.0-dp(2)*dlo2 7712 j=np-1 7713 do 20 i=3,j 7714 20 dp(i)=dp(i-1)+das*(13.0*(dv(i)+dv(i-1))-(dv(i-2)+dv(i+1))) 7715 dp(np)=dp(j) 7716 dv(j)=dp(j) 7717 dv(np)=dp(j) 7718 do 30 i=3,j 7719 k=np+1-i 7720 30 dv(k)=dv(k+1)/dlo+das*(13.0*(dp(k+1)/dlo+dp(k))-(dp(k+2)/dlo2+dp 7721 1 (k-1)*dlo)) 7722 dv(1)=dv(3)/dlo2+dpas*(dp(1)+4.0*dp(2)/dlo+dp(3)/dlo2)/3.0 7723 dlo=-(ion+1) 7724 do 40 i=1,np 7725 dvn(i)=dv(i)/dr(i) 7726 dv(i)=dv(i)-(z+exchan(d(i),dr(i),dexv)) 7727 if (icut.ne.0) go to 40 7728 if (dv(i).gt.dlo) dv(i)=dlo 7729 40 dv(i)=dv(i)/dr(i) 7730 return 7731 end 7732 subroutine potslw (dv,d,dp,dr,dpas,np) 7733c 7734c coulomb potential uses a 4-point integration method 7735c dv=potential; d=density; dp=bloc de travail; dr=radial mesh 7736c dpas=exponential step; 7737c np=number of points 7738c ********************************************************************** 7739 7740 implicit double precision (a-h,o-z) 7741 save 7742 dimension dv(251), d(251), dp(251), dr(251) 7743 das=dpas/24.0d0 7744 do 10 i=1,np 7745 10 dv(i)=d(i)*dr(i) 7746 dlo=exp(dpas) 7747 dlo2=dlo*dlo 7748 dp(2)=dr(1)*(d(2)-d(1)*dlo2)/(12.0*(dlo-1.0)) 7749 dp(1)=dv(1)/3.0d0-dp(2)/dlo2 7750 dp(2)=dv(2)/3.0d0-dp(2)*dlo2 7751 j=np-1 7752 do 20 i=3,j 7753 20 dp(i)=dp(i-1)+das*(13.0d0*(dv(i)+dv(i-1))-(dv(i-2)+dv(i+1))) 7754 dp(np)=dp(j) 7755 dv(j)=dp(j) 7756 dv(np)=dp(j) 7757 do 30 i=3,j 7758 k=np+1-i 7759 30 dv(k)=dv(k+1)/dlo+das*(13.0d0*(dp(k+1)/dlo+dp(k))-(dp(k+2)/dlo2+dp 7760 1 (k-1)*dlo)) 7761 dv(1)=dv(3)/dlo2+dpas*(dp(1)+4.0d0*dp(2)/dlo+dp(3)/dlo2)/3.0d0 7762 do 40 i=1,np 7763 40 dv(i)=dv(i)/dr(i) 7764 return 7765 end 7766 subroutine prcrit (neout, nncrit, ik0out, cksp, fbeta, ckspc, 7767 1 fbetac, potlb0) 7768 implicit double precision (a-h, o-z) 7769 7770 character*72 header 7771 common /header_common/ header 7772 7773 7774c Prepare fbeta arrays, etc., for pathfinder criteria 7775c 7776c Note that path finder is single precision, so be sure that 7777c things are correct precision in calls and declarations! 7778c See declarations below for details. 7779c 7780c Inputs: Reads phase.bin 7781c Output: neout 'ne', number of energy grid points 7782c ik0out index of energy grid with k=0 7783c cksp |p| at each energy grid point in single precision 7784c fbeta |f(beta)| for each angle, npot, energy point, sp 7785c ckspc |p| at each necrit point in single precision 7786c fbetac |f(beta)| for each angle, npot, nncrit point, sp 7787c potlb0 unique potential labels 7788 7789 7790 parameter (pi = 3.1415926535897932384626433d0) 7791 parameter (one = 1, zero = 0) 7792 parameter (third = 1.0d0/3.0d0) 7793 parameter (raddeg = 180.0d0 / pi) 7794 complex*16 coni 7795 parameter (coni = (0,1)) 7796c kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37 7797 parameter (fa = 1.919158292677512811d0) 7798 7799 parameter (bohr = 0.529177249d0, ryd = 13.605698d0) 7800 parameter (alpinv = 137.03598956d0) 7801c fine structure alpha 7802 parameter (alphfs = 1.0d0 / alpinv) 7803c speed of light in louck's units (rydbergs?) 7804 parameter (clight = 2 * alpinv) 7805 7806 7807 parameter (nphx = 7) !max number of unique potentials (potph) 7808 parameter (npotx = nphx) !max number of unique potentials (genfmt, paths) 7809 parameter (nfrx = nphx) !max number of free atom types 7810 parameter (novrx = 8) !max number of overlap shells 7811 parameter (natx = 250) !max number of atoms in problem 7812 parameter (ltot = 24) !max number of ang mom (arrays 1:ltot+1) 7813 parameter (nrptx = 250) !Loucks r grid used through overlap 7814 parameter (nex = 100) !Number of energy points genfmt, etc. 7815 7816 parameter (lamtot=15) !Max number of distinct lambda's for genfmt 7817 !15 handles iord 2 and exact ss 7818 parameter (mtot=4, ntot=2) !vary mmax and nmax independently 7819 parameter (legtot=9) !matches path finder, used in GENFMT 7820 parameter (npatx = 8) !max number of path atoms, used in path 7821 !finder, NOT in genfmt 7822 7823 7824c Note that leg nleg is the leg ending at the central atom, so that 7825c ipot(nleg) is central atom potential, rat(nleg) position of 7826c central atom. 7827c Central atom has ipot=0 7828c For later convience, rat(,0) and ipot(0) refer to the central 7829c atom, and are the same as rat(,nleg), ipot(nleg). 7830 7831c text and title arrays include carriage control 7832 character*80 text, title 7833 character*6 potlbl 7834 common /str/ text(40), !text header from potph 7835 1 title(5), !title from paths.dat 7836 1 potlbl(0:npotx) ! potential labels for output 7837 7838 complex*16 ph, eref 7839 common /pdata/ 7840 1 ph(nex,ltot+1,0:npotx), !complex phase shifts, 7841 1 !central atom ipot=0 7842 1 rat(3,0:legtot+1), !position of each atom, code units(bohr) 7843 1 eref(nex), !complex energy reference 7844 1 em(nex), !energy mesh 7845 1 ri(legtot), beta(legtot+1), eta(0:legtot+1), !r, beta, eta for each leg 7846 1 deg, rnrmav, xmu, edge, !(output only) 7847 1 lmax(nex,0:npotx), !max l with non-zero phase for each energy 7848 1 ipot(0:legtot), !potential for each atom in path 7849 1 iz(0:npotx), !atomic number (output only) 7850 1 ltext(40), ltitle(5), !length of each string 7851 1 nsc, nleg, !nscatters, nlegs (nleg = nsc+1) 7852 1 npot, ne, !number of potentials, energy points 7853 1 ik0, !index of energy grid corresponding to k=0 (edge) 7854 1 ipath, !index of current path (output only) 7855 1 ihole, !(output only) 7856 1 l0, il0, !lfinal and lfinal+1 (used for indices) 7857 1 lmaxp1, !largest lmax in problem + 1 7858 1 ntext, ntitle !number of text and title lines 7859 7860 7861c Output variables SINGLE PRECISION for use with path finder. 7862c BE CAREFUL!! 7863 parameter (necrit=9, nbeta=40) 7864 real*8 fbetac(-nbeta:nbeta,0:npotx,necrit), ckspc(necrit) 7865 real*8 fbeta(-nbeta:nbeta,0:npotx,nex), cksp(nex) 7866 character*6 potlb0(0:npotx) 7867 7868c Local variables 7869 complex*16 cfbeta, tl 7870 dimension dcosb(-nbeta:nbeta) 7871 dimension pl(ltot+1) 7872 dimension iecrit(necrit) 7873 7874 7875c Need stuff from phase.bin 7876c Read phase calculation input, data returned via commons 7877 open (unit=1, file=trim(header)//'phase.bin', status='old', 7878 1 access='sequential', form='unformatted', iostat=ios) 7879 call chopen (ios, trim(header)//'phase.bin', 'prcrit') 7880 call rphbin (1) 7881 close (unit=1) 7882c Pass out ne, ik0, potlbl (from rphbin via /pdata/) 7883 neout = ne 7884 ik0out = ik0 7885 do 40 i = 0, npotx 7886 potlb0(i) = potlbl(i) 7887 40 continue 7888 7889c |p| at each energy point (path finder uses invA, convert here) 7890 do 100 ie = 1, ne 7891 cksp(ie) = abs (sqrt (em(ie) - eref(ie))) / bohr 7892 100 continue 7893 7894c Make the cos(beta)'s 7895c Grid is from -40 to 40, 81 points from -1 to 1, spaced .025 7896 do 200 ibeta = -nbeta, nbeta 7897 dcosb(ibeta) = 0.025d0 * ibeta 7898 200 continue 7899c watch out for round-off error 7900 dcosb(-nbeta) = -1 7901 dcosb(nbeta) = 1 7902 7903c make fbeta (f(beta) for all energy points 7904 do 280 ibeta = -nbeta, nbeta 7905 call cpl0 (dcosb(ibeta), pl, lmaxp1) 7906 do 260 iii = 0, npot 7907 do 250 ie = 1, ne 7908 cfbeta = 0 7909 do 245 il = 1, lmax(ie,iii)+1 7910 tl = (exp(2.0d0*coni*ph(ie,il,iii)) - 1.0d0)/(2*coni) 7911 cfbeta = cfbeta + tl*pl(il)*(2*il-1) 7912 245 continue 7913 fbeta(ibeta,iii,ie) = abs(cfbeta) 7914 250 continue 7915 260 continue 7916 280 continue 7917 7918c Make similar arrays for only the icrit points 7919 7920c Use 9 points at k=0,1,2,3,4,6,8,10,12 invA 7921c See phmesh for energy gid definition. These seem to work fine, 7922c and results aren't too sensitive to choices of k. As few as 4 7923c points work well (used 0,3,6,9), but time penalty for 9 points 7924c is small and increased safety seems to be worth it. 7925 iecrit(1) = ik0 7926 iecrit(2) = ik0 + 5 7927 iecrit(3) = ik0 + 10 7928 iecrit(4) = ik0 + 15 7929 iecrit(5) = ik0 + 20 7930 iecrit(6) = ik0 + 30 7931 iecrit(7) = ik0 + 34 7932 iecrit(8) = ik0 + 38 7933 iecrit(9) = ik0 + 40 7934 7935c make sure that we have enough energy grid points to use all 7936c 9 iecrits 7937 nncrit = 0 7938 do 290 ie = 1, necrit 7939 if (iecrit(ie) .gt. ne) goto 295 7940 nncrit = ie 7941 290 continue 7942 295 continue 7943 if (nncrit .eq. 0) stop 'bad nncrit in prcrit' 7944 write(77,*) ' nncrit in prcrit ', nncrit 7945 7946 7947 do 320 icrit = 1, nncrit 7948 ie = iecrit(icrit) 7949 ckspc(icrit) = cksp(ie) 7950 do 310 ibeta = -nbeta, nbeta 7951 do 300 iii = 0, npot 7952 fbetac(ibeta,iii,icrit) = fbeta(ibeta,iii,ie) 7953 300 continue 7954 310 continue 7955 320 continue 7956 7957 return 7958 end 7959 subroutine quinn (x, rs, wp, ef, ei) 7960 implicit double precision (a-h, o-z) 7961 7962c input x, rs, wp, ef 7963c output ei 7964 7965c*********************************************************************** 7966c 7967c quinn: calculates low energy gamma (approx. proportional to e**2) 7968c formula taken from john j. quinn, phys. rev. 126, 7969c 1453 (1962); equation (7). 7970c a cut-off is set up at quinn's cutoff + ef = ekc; it is a 7971c rounded inverted step function (a fermi function) 7972c theta = 1/( 1 + exp((e-ekc)/gam)) ) 7973c where the rounding factor gam is set to be about 0.3 ekc. 7974c modified by j. rehr (oct 1991) based on coding of r. albers 7975c subroutines quinn.f and quinnc.f 7976c 7977c variables: 7978c x = p/pf 7979c rs = ws density parameter 7980c ei = imaginary self energy 7981c pfqryd = quinn's prefactor in atomic-rydberg units 7982c wkc = quinn's plasmon threshold 7983c 7984c*********************************************************************** 7985 7986 character*72 header 7987 common /header_common/ header 7988 7989 7990 parameter (pi = 3.1415926535897932384626433d0) 7991 parameter (one = 1, zero = 0) 7992 parameter (third = 1.0d0/3.0d0) 7993 parameter (raddeg = 180.0d0 / pi) 7994 complex*16 coni 7995 parameter (coni = (0.0d0,1.0d0)) 7996c kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37 7997 parameter (fa = 1.919158292677512811d0) 7998 7999 parameter (bohr = 0.529177249d0, ryd = 13.605698d0) 8000 parameter (alpinv = 137.03598956d0) 8001c fine structure alpha 8002 parameter (alphfs = 1.0d0 / alpinv) 8003c speed of light in louck's units (rydbergs?) 8004 parameter (clight = 2 * alpinv) 8005 8006 8007 parameter (alphaq = 1.0d0/ fa) 8008 8009c calculate quinn prefactor in atomin Hartree units 8010 pisqrt = sqrt(pi) 8011 pfq = pisqrt / (32.0d0 * (alphaq*rs)**1.5d0) 8012 temp1 = atan (sqrt (pi / (alphaq*rs))) 8013 temp2 = sqrt(alphaq*rs/pi) / (1 + alphaq*rs/pi) 8014 pfq = pfq * (temp1 + temp2) 8015 8016c calculate quinn cutoff 8017c wkc = quinn's plasmon threshold 8018c wkc is cut-off of quinn, pr126, 1453, 1962, eq. (11) 8019c in formulae below wp=omegap/ef 8020 wkc = (sqrt(1+wp) - 1)**2 8021 wkc = (1 + (6.0d0/5.0d0) * wkc / wp**2) * wp * ef 8022 8023c we add fermi energy to get correct energy for 8024c plasma excitations to turn on 8025 ekc = wkc + ef 8026 8027c calculate gamma 8028c gamryd = 2 * (pfqryd/x) * (x**2-1)**2 8029 gam = (pfq/x) * (x**2-1)**2 8030 8031c put in fermi function cutoff 8032 eabs = ef * x**2 8033 arg = (eabs-ekc) / (0.3d0*ekc) 8034 f = 0 8035 if (arg .lt. 80) f = 1.0d0 / (1.0d0 + exp(arg)) 8036 8037 ei = -gam * f / 2.0d0 8038 8039 return 8040 end 8041 subroutine rdhead (io, nhead, head, lhead) 8042 implicit double precision (a-h, o-z) 8043 8044 8045 character*72 header 8046 common /header_common/ header 8047 8048c Reads title line(s) from unit io. Returns number of lines 8049c read. If more than nheadx lines, skips over them. End-of-header 8050c marker is a line of 1 blank, 79 '-'s. 8051c lhead is length of each line w/o trailing blanks. 8052c header lines returned will have 1st space on line blank for 8053c carriage control 8054 8055 character*(*) head(nhead) 8056 dimension lhead(nhead) 8057 character*80 line 8058 8059 n = 0 8060 nheadx = nhead 8061 nhead = 0 8062 10 read(io,20) line 8063 20 format(a) 8064 if (line(4:11) .eq. '--------') goto 100 8065 n = n+1 8066 if (n .le. nheadx) then 8067 head(n) = line 8068 lhead(n) = istrln(head(n)) 8069 nhead = n 8070 endif 8071 goto 10 8072 100 continue 8073 return 8074 end 8075 subroutine rdinp(mphase, mpath, mfeff, mchi, ms, 8076 1 ntitle, title, ltit, 8077 2 critcw, 8078 1 ipr2, ipr3, ipr4, 8079 1 s02, tk, thetad, sig2g, 8080 1 nlegxx, 8081 1 rmax, critpw, pcritk, pcrith, nncrit, 8082 2 icsig, iorder, vrcorr, vicorr, isporb) 8083 8084c Read input for multiple scattering feff 8085 implicit double precision (a-h, o-z) 8086 8087 character*72 header 8088 common /header_common/ header 8089 8090 8091 parameter (pi = 3.1415926535897932384626433d0) 8092 parameter (one = 1, zero = 0) 8093 parameter (third = 1.0d0/3.0d0) 8094 parameter (raddeg = 180.0d0 / pi) 8095 complex*16 coni 8096 parameter (coni = (0.0d0,1.0d0)) 8097c kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37 8098 parameter (fa = 1.919158292677512811d0) 8099 8100 parameter (bohr = 0.529177249d0, ryd = 13.605698d0) 8101 parameter (alpinv = 137.03598956d0) 8102c fine structure alpha 8103 parameter (alphfs = 1.0d0 / alpinv) 8104c speed of light in louck's units (rydbergs?) 8105 parameter (clight = 2 * alpinv) 8106 8107 8108 parameter (nphx = 7) !max number of unique potentials (potph) 8109 parameter (npotx = nphx) !max number of unique potentials (genfmt, paths) 8110 parameter (nfrx = nphx) !max number of free atom types 8111 parameter (novrx = 8) !max number of overlap shells 8112 parameter (natx = 250) !max number of atoms in problem 8113 parameter (ltot = 24) !max number of ang mom (arrays 1:ltot+1) 8114 parameter (nrptx = 250) !Loucks r grid used through overlap 8115 parameter (nex = 100) !Number of energy points genfmt, etc. 8116 8117 parameter (lamtot=15) !Max number of distinct lambda's for genfmt 8118 !15 handles iord 2 and exact ss 8119 parameter (mtot=4, ntot=2) !vary mmax and nmax independently 8120 parameter (legtot=9) !matches path finder, used in GENFMT 8121 parameter (npatx = 8) !max number of path atoms, used in path 8122 !finder, NOT in genfmt 8123 8124 8125c global polarization data 8126 logical pola 8127 double precision evec,ivec,elpty 8128 complex*16 ptz 8129 common /pol/ evec(3), ivec(3), elpty, ptz(-1:1,-1:1), pola 8130 8131 8132c Following passed to pathfinder, which is single precision. 8133c Be careful to always declare these! 8134 real*8 rmax, critpw, pcritk, pcrith 8135 8136c Data for potph (see arrays.h for comments) 8137 dimension iphat(natx) 8138 dimension rat(3,natx) 8139 dimension iatph(0:nphx) 8140 dimension ifrph(0:nphx) 8141 dimension xnatph(0:nphx) 8142 dimension folp(0:nphx) 8143 dimension novr(0:nphx) 8144 dimension iphovr(novrx,0:nphx) 8145 dimension nnovr(novrx,0:nphx) 8146 dimension rovr(novrx,0:nphx) 8147 dimension ion(0:nfrx) 8148 dimension iz(0:nfrx) 8149 8150 character*6 potlbl(0:nphx) 8151 8152c Local stuff 8153 character*150 line 8154 parameter (nwordx = 12) 8155 character*15 words(nwordx) 8156 8157 parameter (ntitx = 10) 8158 character*79 title(ntitx) 8159 dimension ltit(ntitx) 8160 dimension ionph(0:nphx), izph(0:nphx) 8161 logical iscomm 8162 parameter (nssx = 16) 8163 dimension indss(nssx), iphss(nssx) 8164 dimension degss(nssx), rss(nssx) 8165 logical nogeom 8166 8167 10 format (a) 8168 20 format (bn, i15) 8169 30 format (bn, f15.0) 8170 8171c initialize things 8172 8173 ihole = 1 8174 ntitle = 0 8175 ixc = 0 8176 vr0 = 0 8177 vi0 = 0 8178 rs0 = 0 8179 rmax = -1 8180 tk = 0 8181 thetad = 0 8182 sig2g = 0 8183 rmult = 1 8184 s02 = 1 8185 mphase = 1 8186 mpath = 1 8187 mfeff = 1 8188 mchi = 1 8189 ms = 0 8190 ipr1 = 0 8191 ipr2 = 0 8192 ipr3 = 0 8193 ipr4 = 0 8194 nlegxx = 10 8195 xkmin = 0 8196 xkmax = 20 8197 critcw = 4.0d0 8198 critpw = 2.5d0 8199 pcritk = 0 8200 pcrith = 0 8201 nogeom = .false. 8202 icsig = 1 8203 iorder = 2 8204 ixanes = 0 8205 vrcorr = 0 8206 vicorr = 0 8207 iafolp = 0 8208 intclc = 0 8209 nemax = nex 8210 isporb = -1 8211 8212c average over polarization by default 8213 pola = .false. 8214 elpty = 0 8215 do 50 i = 1, 3 8216 evec(i) = 0 8217 ivec(i) = 0 8218 50 continue 8219 8220c nncrit is number of necrit points to use. necrit is 8221c currently 9, this was at once an input used for testing. 8222 nncrit = 9 8223 8224 nat = 0 8225 do 100 iat = 1, natx 8226 iphat(iat) = -1 8227 100 continue 8228 8229 nss = 0 8230 do 102 iss = 1, nssx 8231 indss(iss) = 0 8232 iphss(iss) = 0 8233 degss(iss) = 0 8234 rss(iss) = 0 8235 102 continue 8236 8237 nph = 0 8238 do 110 iph = 0, nphx 8239 iatph(iph) = 0 8240 ifrph(iph) = -1 8241 xnatph(iph) = 0 8242 folp(iph) = 1 8243 novr(iph) = 0 8244 ionph(iph) = 0 8245 izph(iph) = 0 8246 potlbl(iph) = ' ' 8247 110 continue 8248 8249 nfr = 0 8250 do 120 ifr = 0, nfrx 8251 ion(ifr) = 0 8252 iz(ifr) = 0 8253 120 continue 8254 8255c Open feff.inp, the input file we're going to read 8256 open (unit=1, file=trim(header)//'feff.inp', 8257 > status='old', iostat=ios) 8258 call chopen (ios, trim(header)//'feff.inp', 'rdinp') 8259 8260c tokens 0 if not a token 8261c 1 if ATOM (ATOMS) 8262c 2 if HOLE 8263c 3 if OVER (OVERLAP) 8264c 4 if CONT (CONTROL) 8265c 5 if EXCH (EXCHANGE) 8266c 6 if ION 8267c 7 if TITL (TITLE) 8268c 8 if FOLP 8269c 9 if RMAX 8270c 10 if DEBY (DEBYE) 8271c 11 if RMUL (RMULTIPLIER) 8272c 12 if SS 8273c 13 if PRIN (PRINT) 8274c 14 if POTE (POTENTIALS) 8275c 15 if NLEG 8276c 16 if REQU (REQUIRE), now dead 8277c 17 if KLIM (KLIMIT) 8278c 18 if CRIT (CRITERIA) 8279c 19 if NOGEOM 8280c 20 if CSIG 8281c 21 if IORDER 8282c 22 if PCRI (PCRITERIA) 8283c 23 if SIG2 8284c 24 if XANE (XANES), disabled for current release 8285c 25 if CORR (CORRECTIONS) 8286c 26 if AFOL (AFOLP) 8287c 27 if NEMA (NEMAX) 8288c 28 if INTCALC 8289c 29 if POLA (POLARIZATION) 8290c 30 if ELLI (ELLIPTICITY) 8291c 31 if ISPO (ISPORB) 8292c -1 if END (end) 8293c mode flag 0 ready to read a keyword card 8294c 1 reading atom positions 8295c 2 reading overlap instructions for unique pot 8296c 3 reading unique potential definitions 8297 8298 mode = 0 8299 200 read(1,10,iostat=ios) line 8300 if (ios .lt. 0) line='END' 8301 call triml (line) 8302 if (iscomm(line)) goto 200 8303 nwords = nwordx 8304 call bwords (line, nwords, words) 8305 itok = itoken (words(1)) 8306 8307c process the card using current mode 8308 210 continue 8309 8310 if (mode .eq. 0) then 8311 if (itok .eq. 1) then 8312c ATOM 8313c Following lines are atom postions, one per line 8314 mode = 1 8315 elseif (itok .eq. 2) then 8316c HOLE 1 1.0 8317c holecode s02 8318 read(words(2),20,err=900) ihole 8319 read(words(3),30,err=900) s02 8320 mode = 0 8321 elseif (itok .eq. 3) then 8322c OVERLAP iph 8323c iph n r 8324 read(words(2),20,err=900) iph 8325 call phstop(iph,line) 8326 mode = 2 8327 elseif (itok .eq. 4) then 8328c CONTROL mphase, mpath, mfeff, mchi 8329c 0 - do not run modules, 1 - run module 8330 read(words(2),20,err=900) mphase 8331 read(words(3),20,err=900) mpath 8332 read(words(4),20,err=900) mfeff 8333 read(words(5),20,err=900) mchi 8334 mode = 0 8335 elseif (itok .eq. 5) then 8336c EXCHANGE ixc vr0 vi0 8337c ixc=0 Hedin-Lunqvist + const real & imag part 8338c ixc=1 Dirac-Hara + const real & imag part 8339c ixc=2 ground state + const real & imag part 8340c ixc=3 Dirac-Hara + HL imag part + const real & imag part 8341c ixc=4 DH below rs0 + HL above rs0 + const real 8342c & imag part, form is 8343c EXCHANGE 4 vr0 vi0 rs0 8344c vr0 is const imag part of potential 8345c vi0 is const imag part of potential 8346c Default is HL. 8347 read(words(2),20,err=900) ixc 8348 read(words(3),30,err=900) vr0 8349 read(words(4),30,err=900) vi0 8350 if (ixc .eq. 4) read(words(5),30,err=900) rs0 8351 if (ixc .ge. 3) call warnex(1) 8352 mode = 0 8353 elseif (itok .eq. 6) then 8354c ION iph ionph(iph) 8355 read(words(2),20,err=900) iph 8356 call phstop(iph,line) 8357 read(words(3),20,err=900) ionph(iph) 8358 mode = 0 8359 elseif (itok .eq. 7) then 8360c TITLE title... 8361 ntitle = ntitle + 1 8362 if (ntitle .le. ntitx) then 8363 title(ntitle) = line(6:) 8364 call triml (title(ntitle)) 8365 else 8366 write(77,*) 'Too many title lines, title ignored' 8367 write(77,*) line(1:79) 8368 endif 8369 mode = 0 8370 elseif (itok .eq. 8) then 8371c FOLP iph folp (overlap factor, default 1) 8372 read(words(2),20,err=900) iph 8373 call phstop(iph,line) 8374 read(words(3),30,err=900) folp(iph) 8375 mode = 0 8376 elseif (itok .eq. 9) then 8377c RMAX rmax (max r for ss and pathfinder) 8378 read(words(2),30,err=900) rmax 8379 mode = 0 8380 elseif (itok .eq. 10) then 8381c DEBYE temp debye-temp 8382c temps in kelvin 8383c if tk and thetad > 0, use these instead of sig2g 8384 read(words(2),30,err=900) tk 8385 read(words(3),30,err=900) thetad 8386 mode = 0 8387 elseif (itok .eq. 11) then 8388c RMULTIPLIER rmult 8389c Multiples atom coord, rss, overlap and rmax distances by 8390c rmult (default 1). DOES NOT modify sig2g 8391 read(words(2),30,err=900) rmult 8392 mode = 0 8393 elseif (itok .eq. 12) then 8394c SS index ipot deg rss 8395 nss = nss + 1 8396 if (nss .gt. nssx) then 8397 write(77,*) 8398 > 'Too many ss paths requested, max is ', nssx 8399 stop 'RDINP' 8400 endif 8401 read(words(2),20,err=900) indss(nss) 8402 read(words(3),20,err=900) iphss(nss) 8403 read(words(4),30,err=900) degss(nss) 8404 read(words(5),30,err=900) rss(nss) 8405 mode = 0 8406 elseif (itok .eq. 13) then 8407c PRINT ipr1 ipr2 ipr3 ipr4 8408c print flags for various modules 8409c ipr1 potph 0 phase.bin only 8410c 1 add misc.dat 8411c 2 add pot.dat, phase.dat 8412c 5 add atom.dat 8413c 6 add central atom dirac stuff 8414c 7 stop after doing central atom dirac stuff 8415c ipr2 pathfinder 0 paths.dat only 8416c 1 add crit.dat 8417c 2 keep geom.dat 8418c 3 add fbeta files 8419c 5 special magic code, crit&geom only 8420c not paths.dat. Use for path studies 8421c ipr3 genfmt 0 files.dat, feff.dats that pass 2/3 of 8422c curved wave importance ratio 8423c 1 keep all feff.dats 8424c ipr4 ff2chi 0 chi.dat 8425c 1 add sig2.dat with debye waller factors 8426c 2 add chipnnnn.dat for each path 8427 read(words(2),20,err=900) ipr1 8428 read(words(3),20,err=900) ipr2 8429 read(words(4),20,err=900) ipr3 8430 read(words(5),20,err=900) ipr4 8431 mode = 0 8432 elseif (itok .eq. 14) then 8433c POTENTIALS 8434c Following lines are unique potential defs, 1 per line 8435 mode = 3 8436 elseif (itok .eq. 15) then 8437c NLEG nlegmax (for pathfinder) 8438 read(words(2),20,err=900) nlegxx 8439 mode = 0 8440 elseif (itok .eq. 16) then 8441c REQUIRE rreq, ipot (for pathfinder, require than ms paths 8442c length >rreq contain atom ipot) 8443 write(77,*) 'REQUIRE no longer available' 8444 stop 8445 elseif (itok .eq. 17) then 8446c KLIMIT xkmin, xkmax 8447 write(77,*) 'KLIMIT no longer available, run continues.' 8448 mode = 0 8449 elseif (itok .eq. 18) then 8450c CRIT critcw critpw 8451 read(words(2),30,err=900) critcw 8452 read(words(3),30,err=900) critpw 8453 mode = 0 8454 elseif (itok .eq. 19) then 8455c NOGEOM (do not write geom.dat) 8456 nogeom = .true. 8457 mode = 0 8458 elseif (itok .eq. 20) then 8459c CSIG (use complex momentum with debye waller factor) 8460c note: this is always on anyway, so this card unnecessary 8461 icsig = 1 8462 mode = 0 8463 elseif (itok .eq. 21) then 8464c IORDER iorder (used in genfmt, see setlam for meaning) 8465 read(words(2),20,err=900) iorder 8466 call warnex(2) 8467 mode = 0 8468 elseif (itok .eq. 22) then 8469c PCRIT pcritk pcrith 8470c (keep and heap criteria for pathfinder) 8471 read(words(2),30,err=900) pcritk 8472 read(words(3),30,err=900) pcrith 8473 mode = 0 8474 elseif (itok .eq. 23) then 8475c SIG2 sig2g global sig2 written to files.dat 8476 read(words(2),30,err=900) sig2g 8477 mode = 0 8478 elseif (itok .eq. 24) then 8479c XANES 8480c Use extended k range for xanes 8481 ixanes = 1 8482c to avoid problems with debye waller factors below the 8483c edge, always use complex p for debye waller 8484 icsig = 1 8485 call warnex(3) 8486 write(77,212) 8487 212 format ( ' CORRECTIONS and other cards may be needed.', 8488 1 ' See FEFF6 document for', /, 8489 2 ' details and a discussion of approximations.') 8490 mode = 0 8491 elseif (itok .eq. 25) then 8492c CORRECTIONS e0-shift, lambda correction 8493c e0 shift is in eV, edge will be edge-e0 8494c lambda corr is a const imag energy in eV 8495c e0 and lambda corr same as vr0 and vi0 in EXCH card 8496 read(words(2),30,err=900) vrcorr 8497 read(words(3),30,err=900) vicorr 8498 mode = 0 8499 elseif (itok .eq. 26) then 8500c AFOLP use generalized automatic folp 8501 iafolp = 1 8502 mode =0 8503 elseif (itok .eq. 27) then 8504c NEMAX nemax for energy grid 8505 read(words(2),20,err=900) nemax 8506 call warnex(4) 8507 if (nemax .gt. nex) then 8508 write(77,*) 'nemax too big, nemax, nex, ', nemax, nex 8509 nemax = nex 8510 write(77,*) 'nemax reset to ', nemax 8511 endif 8512 mode = 0 8513 elseif (itok .eq. 28) then 8514c INTCALC intclc 8515c 0 use average over all atoms 8516c 1 use current experimental method 1 8517c 2 use current experimental method 2 8518c read(words(2),20,err=900) intclc 8519 write(77,*) 'INTCALC not implemented -- card ignored.' 8520 mode = 0 8521 elseif (itok .eq. 29) then 8522c POLARIZATION X Y Z 8523 pola = .true. 8524c run polarization code if 'pola' is true 8525c run usual feff otherwise 8526 read(words(2),30,err=900) evec(1) 8527 read(words(3),30,err=900) evec(2) 8528 read(words(4),30,err=900) evec(3) 8529 mode = 0 8530 elseif (itok .eq. 30) then 8531c ELLIPTICITY E incident direction 8532 read(words(2),30,err=900) elpty 8533 read(words(3),30,err=900) ivec(1) 8534 read(words(4),30,err=900) ivec(2) 8535 read(words(5),30,err=900) ivec(3) 8536 mode = 0 8537 elseif (itok .eq. 31) then 8538c ISPORB isporb 8539 read(words(2),20,err=900) isporb 8540 write(77,*) ' isporb set ', isporb 8541 mode = 0 8542 elseif (itok .eq. -1) then 8543c END 8544 goto 220 8545 else 8546 write(77,*) line(1:70) 8547 write(77,*) words(1) 8548 write(77,*) 'Token ', itok 8549 write(77,*) 'Keyword unrecognized.' 8550 write(77,*) 'See FEFF document -- some old features' 8551 write(77,*) 'are no longer available.' 8552 stop 'RDINP-2' 8553 endif 8554 elseif (mode .eq. 1) then 8555 if (itok .ne. 0) then 8556c We're done reading atoms. 8557c Change mode and process current card. 8558 mode = 0 8559 goto 210 8560 endif 8561 nat = nat+1 8562 if (nat .gt. natx) then 8563 write(77,*) 'Too many atoms, max is ', natx 8564 stop 'RDINP-3' 8565 endif 8566 read(words(1),30,err=900) rat(1,nat) 8567 read(words(2),30,err=900) rat(2,nat) 8568 read(words(3),30,err=900) rat(3,nat) 8569 read(words(4),20,err=900) iphat(nat) 8570 elseif (mode .eq. 2) then 8571 if (itok .ne. 0) then 8572c We're done reading these overlap instructions. 8573c Change mode and process current card. 8574 mode = 0 8575 goto 210 8576 endif 8577 novr(iph) = novr(iph)+1 8578 iovr = novr(iph) 8579 if (iovr .gt. novrx) then 8580 write(77,*) 'Too many overlap shells, max is ', novrx 8581 stop 'RDINP-5' 8582 endif 8583 read(words(1),20,err=900) iphovr(iovr,iph) 8584 read(words(2),20,err=900) nnovr(iovr,iph) 8585 read(words(3),30,err=900) rovr(iovr,iph) 8586 elseif (mode .eq. 3) then 8587 if (itok .ne. 0) then 8588c We're done reading unique potential definitions 8589c Change mode and process current card. 8590 mode = 0 8591 goto 210 8592 endif 8593 read(words(1),20,err=900) iph 8594 if (iph .lt. 0 .or. iph .gt. nphx) then 8595 write(77,*) 'Unique potentials must be between 0 and ', 8596 1 nphx 8597 write(77,*) iph, ' not allowed' 8598 write(77,*) line(1:79) 8599 stop 'RDINP' 8600 endif 8601 read(words(2),20,err=900) izph(iph) 8602c No potential label if user didn't give us one 8603c Default set above is potlbl=' ' 8604 if (nwords .ge. 3) potlbl(iph) = words(3) 8605 else 8606 write(77,*) 'Mode unrecognized, mode ', mode 8607 stop 'RDINP-6' 8608 endif 8609 goto 200 8610 220 continue 8611 8612c We're done reading the input file, close it. 8613 close (unit=1) 8614 8615c Fix up defaults, error check limits, figure out free atoms, etc. 8616 8617 if (pola) then 8618c make polarization tensor 8619 call mkptz 8620 endif 8621 8622c Find out how many unique potentials we have 8623 nph = 0 8624 do 300 iph = nphx, 0, -1 8625 if (izph(iph) .gt. 0) then 8626 nph = iph 8627 goto 301 8628 endif 8629 300 continue 8630 301 continue 8631c Must have central atom 8632 if (izph(0) .le. 0) then 8633 write(77,*) 'Absorbing atom, unique potential 0, is not defined.' 8634 stop 'RDINP' 8635 endif 8636 8637c Then find model atoms for unique pots that have them 8638 do 330 iph = 0, nphx 8639c Use first atom in atom list that is of unique pot iph 8640 do 320 iat = 1, nat 8641 if (iph .eq. iphat(iat)) then 8642 iatph(iph) = iat 8643 goto 321 8644 endif 8645 320 continue 8646 321 continue 8647 330 continue 8648c if iatph > 0, a model atom has been found. 8649 8650c No gaps allowed in unique pots. Make sure we have enough 8651c to overlap all unique pots 0 to nph. 8652 do 340 iph = 0, nph 8653 if (iatph(iph) .le. 0 .and. novr(iph) .le. 0) then 8654c No model atom, no overlap cards, can't do this unique pot 8655 write(77,*) ' No atoms or overlap cards for unique pot ', iph 8656 write(77,*) ' Cannot calculate potentials, etc.' 8657 stop 'RDINP-' 8658 endif 8659 340 continue 8660 8661c Need number of atoms of each unique pot, count them. If none, 8662c set to one. 8663 do 350 iph = 0, nph 8664 xnatph(iph) = 0 8665 do 346 iat = 1, nat 8666 if (iphat(iat) .eq. iph) xnatph(iph) = xnatph(iph)+1 8667 346 continue 8668 if (xnatph(iph) .le. 0) xnatph(iph) = 1 8669 350 continue 8670 8671c Do the free atom shuffling, do central atom as special case 8672 iz(0) = izph(0) 8673 ion(0) = ionph(0) 8674 ifrph(0) = 0 8675 nfr = 0 8676 do 390 iph = 1, nph 8677 ifrph(iph) = -1 8678 do 380 ifr = 1, nfr 8679 if (iz(ifr).eq.izph(iph) .and. ion(ifr).eq.ionph(iph)) then 8680 ifrph(iph) = ifr 8681 goto 381 8682 endif 8683 380 continue 8684 381 continue 8685c add free atom type if necessary 8686 if (ifrph(iph) .lt. 0) then 8687 nfr = nfr+1 8688 if (nfr .gt. nfrx) then 8689 write(77,*) ' Too many free atoms, max is ', nfrx 8690 stop 'RDINP10' 8691 endif 8692 ion(nfr) = ionph(iph) 8693 iz(nfr) = izph(iph) 8694 ifrph(iph) = nfr 8695 endif 8696 390 continue 8697 8698c Find central atom (only 1 permitted) 8699 iatabs = -1 8700 do 400 iat = 1, nat 8701 if (iphat(iat) .eq. 0) then 8702 if (iatabs .lt. 0) then 8703 iatabs = iat 8704 else 8705 write(77,*) 'More than one absorbing atom (potential 0)' 8706 write(77,*) 'Only one absorbing atom allowed' 8707 stop 'RDINP' 8708 endif 8709 endif 8710 400 continue 8711 8712c Find distance to nearest and most distant atom (use overlap card 8713c if no atoms specified.) 8714 if (iatabs .lt. 0 .or. nat .lt. 2) then 8715 ratmin = rovr(1,0) 8716 ratmax = rovr(novr(0),0) 8717 else 8718 ratmax = 0 8719 ratmin = 1.0d10 8720 do 412 iat = 1, nat 8721c skip absorbing atom 8722 if (iat .eq. iatabs) goto 412 8723 tmp = feff_dist(rat(1,iat), rat(1,iatabs)) 8724 if (tmp .gt. ratmax) ratmax = tmp 8725 if (tmp .lt. ratmin) ratmin = tmp 8726 412 continue 8727 endif 8728 8729c Set rmax if necessary 8730 if (rmax.le.0 .and. nss.le.0) then 8731c set to min (2+ times ratmin, ratmax) 8732 rmax = min (2.001 * ratmin, ratmax) 8733 endif 8734 8735c Set core hole lifetime (central atom quantity) 8736 ifr = ifrph(0) 8737 call setgam (iz(ifr), ihole, gamach) 8738 8739c Set s02 if necessary 8740 if (s02 .le. 1.0d-10) s02 = 1 8741 8742c Convert everything to code units, and use rmult factor 8743c rmax is for pathfinder, so leave it in Ang. 8744 rmax = rmax * rmult 8745 vr0 = vr0 / ryd 8746 vi0 = vi0 / ryd 8747 vrcorr = vrcorr / ryd 8748 vicorr = vicorr / ryd 8749 xkmin = xkmin * bohr 8750 xkmax = xkmax * bohr 8751 do 430 iat = 1, nat 8752 do 420 i = 1, 3 8753 rat(i,iat) = rat(i,iat) * rmult / bohr 8754 420 continue 8755 430 continue 8756 do 460 iph = 0, nph 8757 do 450 iovr = 1, novr(iph) 8758 rovr(iovr,iph) = rovr(iovr,iph) * rmult / bohr 8759 450 continue 8760 460 continue 8761 do 462 iss = 1, nss 8762c rss used only to make paths.dat, so leave it in Angstroms. 8763 rss(iss) = rss(iss) * rmult 8764 462 continue 8765 8766c Check if 2 atoms are closer together than 1.75 ryd (~.93 Ang) 8767 ratmin = 1.0d20 8768 do 480 iat = 1, nat 8769 do 470 jat = iat+1, nat 8770 rtmp = feff_dist(rat(1,iat),rat(1,jat)) 8771 if (rtmp .lt. ratmin) ratmin = rtmp 8772 if (rtmp .lt. 1.75d0) then 8773c if (dist(rat(1,iat),rat(1,jat)) .lt. 1.5) then 8774 write(77,*) 'WARNING: TWO ATOMS VERY CLOSE TOGETHER.', 8775 1 ' CHECK INPUT.' 8776 write(77,*) ' atoms ', iat, jat 8777 write(77,*) iat, (rat(i,iat)*bohr,i=1,3) 8778 write(77,*) jat, (rat(i,jat)*bohr,i=1,3) 8779 write(77,*) 'Run continues in case you really meant it.' 8780 endif 8781 470 continue 8782 480 continue 8783 8784c default to k shell 8785 if (isporb .lt. 0) isporb = 1 8786 8787c Clean up control flags 8788 if (mphase .ne. 0) mphase = 1 8789 if (mpath .ne. 0) mpath = 1 8790 if (mfeff .ne. 0) mfeff = 1 8791 if (mchi .ne. 0) mchi = 1 8792 if (nss .le. 0) ms = 1 8793 8794 if (ntitle .le. 0) then 8795 ntitle = 1 8796 title(i) = 'No title input' 8797 endif 8798 do 490 i = 1, ntitle 8799 ltit(i) = istrln (title(i)) 8800 490 continue 8801 8802c Write output files 8803 8804c For potph... 8805 if (mphase .eq. 1) then 8806 open (unit=1, file=trim(header)//'potph.dat', 8807 > status='unknown', iostat=ios) 8808 call chopen (ios, trim(header)//'potph.dat', 'rdinp') 8809 do 705 i = 1, ntitle 8810 write(1,700) title(i)(1:ltit(i)) 8811 700 format (1x, a) 8812 705 continue 8813 write(1,706) 8814 706 format (1x, 79('-')) 8815 write(1,709) ihole, gamach, ipr1, iafolp, intclc 8816 709 format(i5, 1p, e14.6, 3i4, 8817 1 ' ihole, gamach, iprint, iafolp, intclc') 8818 write(1,702) ixc, vr0, vi0, rs0 8819 702 format (i5, 1p, 3e14.6, ' ixc, vr0, vi0, rs0') 8820 write(1,701) ixanes, nemax, xkmin, xkmax 8821 701 format (2i5, 1p, 2e14.6, 8822 1 ' ixanes, nemax, xkmin, xkmax (inv bohr)') 8823 write(1,707) nfr, ' nfr' 8824 707 format (i5, a) 8825 do 710 ifr = 0, nfr 8826 write(1,708) ifr, iz(ifr), ion(ifr) 8827 708 format (3i5, ' ifr, iz, ion') 8828 710 continue 8829 write(1,707) nat, ' nat. iat, iph, x, y, z' 8830 do 720 iat = 1, nat 8831 write(1,715) iat, iphat(iat), (rat(j,iat),j=1,3) 8832 715 format (2i5, 3f12.6) 8833 720 continue 8834 write(1,707) nph, ' nph' 8835 do 740 iph = 0, nph 8836 write(1,722) iph, iatph(iph), ifrph(iph), xnatph(iph), 8837 1 folp(iph), novr(iph), 8838 2 ' iph, iat, ifr, xnat, folp, novr' 8839 722 format (3i5, 2f12.6, i5, a) 8840 write(1,723) potlbl(iph) 8841 723 format (' ''', a6, ''' potlbl') 8842 do 730 iovr = 1, novr(iph) 8843 write(1,724) iphovr(iovr,iph), nnovr(iovr,iph), 8844 1 rovr(iovr,iph), 8845 2 ' ovr... iph, n, r' 8846 724 format (2i5, f12.6, a) 8847 730 continue 8848 740 continue 8849 close (unit=1) 8850 endif 8851 8852c Single scattering paths for genfmt 8853 if (nss .gt. 0 .and. mpath .eq. 1) then 8854 open (unit=1, file=trim(header)//'paths.dat', 8855 > status='unknown', iostat=ios) 8856 call chopen (ios, trim(header)//'paths.dat', 'rdinp') 8857 do 750 i = 1, ntitle 8858 write(1,748) title(i)(1:ltit(i)) 8859 748 format (1x, a) 8860 750 continue 8861 write(1,751) 8862 751 format (' Single scattering paths from ss lines cards', 8863 1 ' in feff input') 8864 write(1,706) 8865 do 760 iss = 1, nss 8866 if (rmax.le.0 .or. rss(iss).le.rmax) then 8867c NB, rmax and rss are in angstroms 8868 write(1,752) indss(iss), 2, degss(iss), 8869 2 rss(iss) 8870 752 format ( 2i4, f8.3, 8871 1 ' index,nleg,degeneracy,r=', f8.4) 8872 write(1,766) 8873 766 format (' single scattering') 8874 write(1,754) rss(iss)*bohr, zero, zero, iphss(iss), 8875 1 potlbl(iphss(iss)) 8876 write(1,753) zero, zero, zero, 0, potlbl(0) 8877 753 format (3f12.6, i4, 1x, '''', a6, '''', ' x,y,z,ipot') 8878 754 format (3f12.6, i4, 1x, '''', a6, '''') 8879 endif 8880 760 continue 8881 close (unit=1) 8882 endif 8883 8884c Atoms for the pathfinder 8885 if (nss.le.0 .and. mpath.eq.1 .and. nat.gt.0) then 8886 if (iatabs .le. 0) then 8887 write(77,*) 'Absorbing atom coords not specified.' 8888 write(77,*) 'Cannot find multiple scattering paths.' 8889 stop 'RDINP' 8890 endif 8891c if user doesn't want geom.dat, don't do it 8892 if (nogeom) goto 792 8893 open (unit=1, file=trim(header)//'geom.dat', 8894 > status='unknown', iostat=ios) 8895 call chopen (ios, trim(header)//'geom.dat', 'rdinp') 8896c Echo title cards to geom.dat 8897 do 770 i = 1, ntitle 8898 write(1,700) title(i)(1:ltit(i)) 8899 770 continue 8900 write(1,706) 8901c Central atom first 8902 ii = 0 8903 write(1,780) ii, (rat(j,iatabs)*bohr,j=1,3), 0, 1 8904c Rest of the atoms (skip central atom) 8905 do 790 iat = 1, nat 8906 if (iat .eq. iatabs) goto 790 8907 ii = ii+1 8908 write(1,780) ii, (rat(j,iat)*bohr,j=1,3), iphat(iat), 1 8909 780 format (i4, 3f12.6, 2i4) 8910 790 continue 8911 close (unit=1) 8912 endif 8913 792 continue 8914 8915 return 8916 8917 900 continue 8918 write(77,*) 'Error reading input, bad line follows:' 8919 write(77,*) line(1:79) 8920 stop 'RDINP fatal error.' 8921 8922 end 8923 8924 function itoken (word) 8925 implicit double precision (a-h, o-z) 8926c chars in word assumed upper case, left justified 8927c returns 0 if not a token, otherwise returns token 8928 8929 character*(*) word 8930 character*4 w 8931 8932 w = word(1:4) 8933 if (w .eq. 'ATOM') then 8934 itoken = 1 8935 elseif (w .eq. 'HOLE') then 8936 itoken = 2 8937 elseif (w .eq. 'OVER') then 8938 itoken = 3 8939 elseif (w .eq. 'CONT') then 8940 itoken = 4 8941 elseif (w .eq. 'EXCH') then 8942 itoken = 5 8943 elseif (w .eq. 'ION ') then 8944 itoken = 6 8945 elseif (w .eq. 'TITL') then 8946 itoken = 7 8947 elseif (w .eq. 'FOLP') then 8948 itoken = 8 8949 elseif (w .eq. 'RMAX') then 8950 itoken = 9 8951 elseif (w .eq. 'DEBY') then 8952 itoken = 10 8953 elseif (w .eq. 'RMUL') then 8954 itoken = 11 8955 elseif (w .eq. 'SS ') then 8956 itoken = 12 8957 elseif (w .eq. 'PRIN') then 8958 itoken = 13 8959 elseif (w .eq. 'POTE') then 8960 itoken = 14 8961 elseif (w .eq. 'NLEG') then 8962 itoken = 15 8963 elseif (w .eq. 'REQU') then 8964 itoken = 16 8965 elseif (w .eq. 'KLIM') then 8966 itoken = 17 8967 elseif (w .eq. 'CRIT') then 8968 itoken = 18 8969 elseif (w .eq. 'NOGE') then 8970 itoken = 19 8971 elseif (w .eq. 'CSIG') then 8972 itoken = 20 8973 elseif (w .eq. 'IORD') then 8974 itoken = 21 8975 elseif (w .eq. 'PCRI') then 8976 itoken = 22 8977 elseif (w .eq. 'SIG2') then 8978 itoken = 23 8979 elseif (w .eq. 'XANE') then 8980 itoken = 24 8981 elseif (w .eq. 'CORR') then 8982 itoken = 25 8983 elseif (w .eq. 'AFOL') then 8984 itoken = 26 8985 elseif (w .eq. 'NEMA') then 8986 itoken = 27 8987 elseif (w .eq. 'INTC') then 8988 itoken = 28 8989 elseif (w .eq. 'POLA') then 8990 itoken = 29 8991 elseif (w .eq. 'ELLI') then 8992 itoken = 30 8993 elseif (w .eq. 'ISPO') then 8994 itoken = 31 8995 elseif (w .eq. 'END ') then 8996 itoken = -1 8997 else 8998 itoken = 0 8999 endif 9000 return 9001 end 9002 logical function iscomm (line) 9003 implicit double precision (a-h, o-z) 9004c returns true if line is a comment or blank line, false otherwise 9005 character*(*) line 9006 iscomm = .false. 9007 if (istrln(line).le.0 .or. line(1:1).eq.'*') iscomm = .true. 9008 return 9009 end 9010 subroutine phstop (iph,line) 9011 implicit double precision (a-h, o-z) 9012 character*(*) line 9013 9014 character*72 header 9015 common /header_common/ header 9016 9017 9018 parameter (nphx = 7) !max number of unique potentials (potph) 9019 parameter (npotx = nphx) !max number of unique potentials (genfmt, paths) 9020 parameter (nfrx = nphx) !max number of free atom types 9021 parameter (novrx = 8) !max number of overlap shells 9022 parameter (natx = 250) !max number of atoms in problem 9023 parameter (ltot = 24) !max number of ang mom (arrays 1:ltot+1) 9024 parameter (nrptx = 250) !Loucks r grid used through overlap 9025 parameter (nex = 100) !Number of energy points genfmt, etc. 9026 9027 parameter (lamtot=15) !Max number of distinct lambda's for genfmt 9028 !15 handles iord 2 and exact ss 9029 parameter (mtot=4, ntot=2) !vary mmax and nmax independently 9030 parameter (legtot=9) !matches path finder, used in GENFMT 9031 parameter (npatx = 8) !max number of path atoms, used in path 9032 !finder, NOT in genfmt 9033 9034 if (iph .lt. 0 .or. iph .gt. nphx) then 9035 write(77,10) iph, nphx, line 9036 10 format (' Unique potential index', i5, ' out of range.', /, 9037 1 ' Must be between 0 and', i5, '. Input line:', /, 9038 2 1x, a) 9039 stop 'RDINP - PHSTOP' 9040 endif 9041 return 9042 end 9043 subroutine warnex (i) 9044 implicit double precision (a-h, o-z) 9045c This prints a warning message if the user is using an 9046c expert option. 9047c i expert option card 9048c 1 EXCHANGE with code >= 3 9049c 2 IORDER 9050c 3 XANES 9051c 4 NEMAX 9052c 5 INTCALC 9053 9054c message max of 22 characters to keep warning on 80 char line. 9055 100 format (1x, a, 9056 1 ': Expert user option, please read documentation', /, 9057 2 ' carefully and check your results.') 9058 9059 if (i .eq. 1) then 9060 write(77,100) 'EXCHANGE code >= 3' 9061 elseif (i .eq. 2) then 9062 write(77,100) 'IORDER' 9063 elseif (i .eq. 3) then 9064 write(77,100) 'XANES' 9065 elseif (i .eq. 4) then 9066 write(77,100) 'NEMAX' 9067 elseif (i .eq. 5) then 9068 write(77,100) 'INTCALC' 9069 endif 9070 return 9071 end 9072 subroutine rdpath (in, pol, done,xstar) 9073 implicit double precision (a-h, o-z) 9074 logical done, pol 9075 9076 9077 parameter (pi = 3.1415926535897932384626433d0) 9078 parameter (one = 1, zero = 0) 9079 parameter (third = 1.0d0/3.0d0) 9080 parameter (raddeg = 180.0d0 / pi) 9081 complex*16 coni 9082 parameter (coni = (0.0d0,1.0d0)) 9083c kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37 9084 parameter (fa = 1.919158292677512811d0) 9085 9086 parameter (bohr = 0.529177249d0, ryd = 13.605698d0) 9087 parameter (alpinv = 137.03598956d0) 9088c fine structure alpha 9089 parameter (alphfs = 1.0d0 / alpinv) 9090c speed of light in louck's units (rydbergs?) 9091 parameter (clight = 2 * alpinv) 9092 9093 9094 parameter (nphx = 7) !max number of unique potentials (potph) 9095 parameter (npotx = nphx) !max number of unique potentials (genfmt, paths) 9096 parameter (nfrx = nphx) !max number of free atom types 9097 parameter (novrx = 8) !max number of overlap shells 9098 parameter (natx = 250) !max number of atoms in problem 9099 parameter (ltot = 24) !max number of ang mom (arrays 1:ltot+1) 9100 parameter (nrptx = 250) !Loucks r grid used through overlap 9101 parameter (nex = 100) !Number of energy points genfmt, etc. 9102 9103 parameter (lamtot=15) !Max number of distinct lambda's for genfmt 9104 !15 handles iord 2 and exact ss 9105 parameter (mtot=4, ntot=2) !vary mmax and nmax independently 9106 parameter (legtot=9) !matches path finder, used in GENFMT 9107 parameter (npatx = 8) !max number of path atoms, used in path 9108 !finder, NOT in genfmt 9109 9110 9111c Note that leg nleg is the leg ending at the central atom, so that 9112c ipot(nleg) is central atom potential, rat(nleg) position of 9113c central atom. 9114c Central atom has ipot=0 9115c For later convience, rat(,0) and ipot(0) refer to the central 9116c atom, and are the same as rat(,nleg), ipot(nleg). 9117 9118c text and title arrays include carriage control 9119 character*80 text, title 9120 character*6 potlbl 9121 common /str/ text(40), !text header from potph 9122 1 title(5), !title from paths.dat 9123 1 potlbl(0:npotx) ! potential labels for output 9124 9125 complex*16 ph, eref 9126 common /pdata/ 9127 1 ph(nex,ltot+1,0:npotx), !complex phase shifts, 9128 1 !central atom ipot=0 9129 1 rat(3,0:legtot+1), !position of each atom, code units(bohr) 9130 1 eref(nex), !complex energy reference 9131 1 em(nex), !energy mesh 9132 1 ri(legtot), beta(legtot+1), eta(0:legtot+1), !r, beta, eta for each leg 9133 1 deg, rnrmav, xmu, edge, !(output only) 9134 1 lmax(nex,0:npotx), !max l with non-zero phase for each energy 9135 1 ipot(0:legtot), !potential for each atom in path 9136 1 iz(0:npotx), !atomic number (output only) 9137 1 ltext(40), ltitle(5), !length of each string 9138 1 nsc, nleg, !nscatters, nlegs (nleg = nsc+1) 9139 1 npot, ne, !number of potentials, energy points 9140 1 ik0, !index of energy grid corresponding to k=0 (edge) 9141 1 ipath, !index of current path (output only) 9142 1 ihole, !(output only) 9143 1 l0, il0, !lfinal and lfinal+1 (used for indices) 9144 1 lmaxp1, !largest lmax in problem + 1 9145 1 ntext, ntitle !number of text and title lines 9146 9147 9148c global polarization data 9149 logical pola 9150 double precision evec,ivec,elpty 9151 complex*16 ptz 9152 common /pol/ evec(3), ivec(3), elpty, ptz(-1:1,-1:1), pola 9153 9154 9155 complex*16 alph, gamm 9156 dimension alpha(0:legtot), gamma(legtot) 9157 9158 read(in,*,end=200) ipath, nleg, deg 9159 if (nleg .gt. legtot) then 9160 write(77,*) 'nleg .gt. legtot, nleg, legtot ', nleg, legtot 9161 write(77,*) 'ERROR' 9162 goto 200 9163 endif 9164c skip label (x y z ipot rleg beta eta) 9165 read(in,*) 9166 do 20 ileg = 1, nleg 9167 read(in,*,end=999) (rat(j,ileg),j=1,3), ipot(ileg), 9168 1 potlbl(ipot(ileg)) 9169c convert to code units 9170 do 10 j = 1, 3 9171 rat(j,ileg) = rat(j,ileg)/bohr 9172 10 continue 9173 if (ipot(ileg) .gt. npot) then 9174 write(77,*) 'ipot(ileg) too big, ipot, ileg, npot ', 9175 1 ipot(ileg), ileg, npot 9176 write(77,*) 'ERROR' 9177 goto 200 9178 endif 9179 20 continue 9180 nsc = nleg-1 9181 9182c We need the 'z' atom so we can use it below. Put 9183c it in rat(nleg+1). No physical significance, just a handy 9184c place to put it. 9185 if (pol) then 9186 rat(1,nleg+1) = rat(1,nleg) 9187 rat(2,nleg+1) = rat(2,nleg) 9188 rat(3,nleg+1) = rat(3,nleg) + 1.0d0 9189 endif 9190 9191c add rat(0) and ipot(0) (makes writing output easier) 9192 do 22 j = 1, 3 9193 rat(j,0) = rat(j,nleg) 9194 22 continue 9195 ipot(0) = ipot(nleg) 9196 9197c beginnnig of calculating nstar=deg*cos(eps r1)*cos(eps rN) 9198 x1 = 0.0 9199 do 23 j = 1,3 9200 x1 = x1 + evec(j) * ( rat(j,1) - rat(j,0) ) 9201 23 continue 9202 xnorm = 0.0 9203 do 24 j = 1,3 9204 xnorm = xnorm + (rat(j,1) - rat(j,0))**2 9205 24 continue 9206 x1 = x1/sqrt(xnorm) 9207 x2 = 0.0 9208 do 25 j = 1,3 9209 x2 = x2 + evec(j) * ( rat(j,nleg-1) - rat(j,0) ) 9210 25 continue 9211 xnorm = 0.0 9212 do 26 j = 1,3 9213 xnorm = xnorm + (rat(j,nleg-1) - rat(j,0))**2 9214 26 continue 9215 x2 = x2/sqrt(xnorm) 9216 xstar = deg* abs(x1*x2) 9217c end of calculating nstar 9218 9219 nangle = nleg 9220 if (pol) then 9221c in polarization case we need one more rotation 9222 nangle = nleg + 1 9223 endif 9224 do 100 j = 1, nangle 9225 9226c for euler angles at point i, need th and ph (theta and phi) 9227c from rat(i+1)-rat(i) and thp and php 9228c (theta prime and phi prime) from rat(i)-rat(i-1) 9229c 9230c Actually, we need cos(th), sin(th), cos(phi), sin(phi) and 9231c also for angles prime. Call these ct, st, cp, sp 9232 9233c i = (j) 9234c ip1 = (j+1) 9235c im1 = (j-1) 9236c except for special cases... 9237 ifix = 0 9238 if (j .eq. nsc+1) then 9239c j+1 'z' atom, j central atom, j-1 last path atom 9240 i = 0 9241 ip1 = 1 9242 if (pol) then 9243 ip1 = nleg+1 9244 endif 9245 im1 = nsc 9246 9247 elseif (j .eq. nsc+2) then 9248c j central atom, j+1 first path atom, j-1 'z' atom 9249 i = 0 9250 ip1 = 1 9251 im1 = nleg+1 9252 ifix = 1 9253 else 9254 i = j 9255 ip1 = j+1 9256 im1 = j-1 9257 endif 9258 9259 x = rat(1,ip1) - rat(1,i) 9260 y = rat(2,ip1) - rat(2,i) 9261 z = rat(3,ip1) - rat(3,i) 9262 call trig (x, y, z, ctp, stp, cpp, spp) 9263 x = rat(1,i) - rat(1,im1) 9264 y = rat(2,i) - rat(2,im1) 9265 z = rat(3,i) - rat(3,im1) 9266 call trig (x, y, z, ct, st, cp, sp) 9267 9268c Handle special case, j=central atom, j+1 first 9269c path atom, j-1 is 'z' atom. Need minus sign 9270c for location of 'z' atom to get signs right. 9271 if (ifix .eq. 1) then 9272 x = 0 9273 y = 0 9274 z = 1.0 9275 call trig (x, y, z, ct, st, cp, sp) 9276 ifix = 0 9277 endif 9278 9279c cppp = cos (phi prime - phi) 9280c sppp = sin (phi prime - phi) 9281 cppp = cp*cpp + sp*spp 9282 sppp = spp*cp - cpp*sp 9283 phi = atan2(sp,cp) 9284 phip = atan2(spp,cpp) 9285 9286c alph = exp(i alpha) in ref eqs 18 9287c beta = cos (beta) 9288c gamm = exp(i gamma) 9289 alph = -(st*ctp - ct*stp*cppp - coni*stp*sppp) 9290 beta(j) = ct*ctp + st*stp*cppp 9291c watch out for roundoff errors 9292 if (beta(j) .lt. -1) beta(j) = -1 9293 if (beta(j) .gt. 1) beta(j) = 1 9294 gamm = -(st*ctp*cppp - ct*stp + coni*st*sppp) 9295 call feff_arg(alph,phip-phi,alpha(j)) 9296 beta(j) = acos(beta(j)) 9297 call feff_arg(gamm,phi-phi,gamma(j)) 9298c Convert from the rotation of FRAME used before to the rotation 9299c of VECTORS used in ref. 9300 dumm = alpha(j) 9301 alpha(j) = pi- gamma(j) 9302 gamma(j) = pi- dumm 9303 9304 if (j .le. nleg) then 9305 ri(j) = feff_dist(rat(1,i), rat(1,im1)) 9306 endif 9307 100 continue 9308 9309c Make eta(i) = alpha(i-1) + gamma(i). 9310c We'll need alph(nangle)=alph(0) 9311 alpha(0) = alpha(nangle) 9312 do 150 j = 1, nleg 9313 eta(j) = alpha(j-1) + gamma(j) 9314 150 continue 9315 if (pol) then 9316 eta(0) = gamma(nleg+1) 9317 eta(nleg+1) = alpha(nleg) 9318 endif 9319 9320c eta and beta in radians at this point. 9321 done = .false. 9322 return 9323 9324c If no more data, tell genfmt we're done 9325 200 continue 9326 done = .true. 9327 return 9328 9329c If unexpected end of file, die 9330 999 continue 9331 write(77,*) 'Unexpected end of file' 9332 stop 'ERROR' 9333 end 9334 subroutine trig (x, y, z, ct, st, cp, sp) 9335 implicit double precision (a-h, o-z) 9336c returns cos(theta), sin(theta), cos(phi), sin(ph) for (x,y,z) 9337c convention - if x=y=0 and z>0, phi=0, cp=1, sp=0 9338c if x=y=0 and z<0, phi=180, cp=-1,sp=0 9339c - if x=y=z=0, theta=0, ct=1, st=0 9340 parameter (eps = 1.0d-6) 9341 r = sqrt (x**2 + y**2 + z**2) 9342 rxy = sqrt (x**2 + y**2) 9343 if (r .lt. eps) then 9344 ct = 1 9345 st = 0 9346 else 9347 ct = z/r 9348 st = rxy/r 9349 endif 9350 if (rxy .lt. eps) then 9351 cp = 1 9352 if (ct .lt. 0) cp = -1 9353 sp = 0 9354 else 9355 cp = x / rxy 9356 sp = y / rxy 9357 endif 9358 return 9359 end 9360 subroutine feff_arg(c,fi,th) 9361 implicit double precision (a-h, o-z) 9362 complex*16 c 9363 parameter (eps = 1.0d-6) 9364 x = dble(c) 9365 y = dimag(c) 9366 if (abs(x) .lt. eps) x = 0 9367 if (abs(y) .lt. eps) y = 0 9368 if (abs(x) .lt. eps .and. abs(y) .lt. eps) then 9369 th = fi 9370 else 9371 th = atan2(y,x) 9372 endif 9373 return 9374 end 9375 subroutine renorm (dexv, vcoul, srho) 9376 9377 implicit double precision (a-h,o-z) 9378 save 9379 9380 common /print/ iprint 9381 common /atomco/ den(30), dq1(30), dfl(30), ws, nqn(30), nql(30), 9382 1 nk(30), nmax(30), nel(30), norb, norbco 9383 common /dira/ dv(251), dr(251), dp(251), dq(251), dpas, tets, 9384 1 z, nstop, nes, np, nuc 9385 common /deux/ dvn(251), dvf(251), d(251), dc(251), dgc(251,30), 9386 1 dpc(251,30) 9387 9388c vcoul is the coulomb potential (no factor of r**2) (output) 9389 dimension vcoul(251) 9390c srho is charge density in form 4*pi*density*r**2 output) 9391 dimension srho(251) 9392c jm 9/23/87 added srho renormalized charge density to be used 9393c in cphase 9394 9395 do 10 i=1,np 9396 dv(i)=0.0 9397 d(i)=0.0 9398 10 continue 9399 ddjri=log(ws/dr(1))/dpas 9400 jri=1.0+ddjri 9401 jr1=jri 9402 ddjr1=ddjri-jr1+1.0 9403 9404 if (jri-2*(jri/2).ne.0) go to 20 9405 jri=jri+1 9406 20 continue 9407 9408 ddjri=ddjri-jri+1.0 9409c ddjri = (log(ws)-dri)/dpas 9410c dri = log(dr(jri)) 9411 9412 da=0.0 9413 do 30 j=1,norb 9414 do 30 i=1,np 9415 30 d(i)=d(i)+nel(j)*(dgc(i,j)**2+dpc(i,j)**2) 9416 9417 do 50 i=jri,np 9418 dl=dr(i) 9419 if (i.eq.jri.or.i.eq.np) go to 40 9420 dl=dl+dl 9421 if ((i-2*(i/2)).eq.0) dl=dl+dl 9422 40 dd=d(i)*dl 9423 da=da+dd 9424 50 continue 9425 9426 da=dpas*da/3.0 9427 dfo=dr(jri-1)*d(jri-1) 9428 df1=dr(jri)*d(jri) 9429 df2=dr(jri+1)*d(jri+1) 9430 dcor=-dpas*(df1*ddjri+(df2+dfo-2.0*df1)*ddjri**3/6.0+(df2-dfo) 9431 1 *ddjri**2*.25) 9432 da=da+dcor 9433 if (iprint .ge. 5) write(16,60) da 9434 60 format (1h ,' no. of electrons outside the ws-radius',e16.8) 9435 db=0.0 9436 9437 do 80 i=jri,np 9438 dl=1.0 9439 if (i.eq.jri.or.i.eq.np) go to 70 9440 dl=dl+dl 9441 if ((i-2*(i/2)).eq.0) dl=dl+dl 9442 70 dd=d(i)*dl 9443 db=db+dd 9444 80 continue 9445 9446 db=dpas*db/3.0 9447 df0=d(jri-1) 9448 df1=d(jri) 9449 df2=d(jri+1) 9450 dcor=-dpas*(df1*ddjri+(df2+df0-2.0*df1)*ddjri**3/6.0+(df2-df0) 9451 1 *ddjri**2*.25) 9452 db=db+dcor 9453 if (iprint .ge. 5) write(16,90) db 9454 90 format (1h ,' db= ',e16.8) 9455 9456 call potslw (dvn,d,dp,dr,dpas,np) 9457 9458 du=da*3.0/(ws**3) 9459 9460 do 120 i=1,np 9461 if (i.gt.jr1+1) then 9462 srho(i)=0.0 9463 go to 100 9464 endif 9465 d(i)=d(i)+du*dr(i)**2 9466 srho(i)=d(i) 9467 100 continue 9468 dumm=-exchan(d(i),dr(i),dexv)/dr(i) 9469 dvf(i)=dumm 9470 if (i.gt.jr1) go to 110 9471 dvn(i)=dvn(i)-z/dr(i)+da*(1.50/ws-.50*dr(i)**2/ws**3)-db 9472 go to 120 9473 110 continue 9474 dvn(i)=0.0 9475 120 dv(i)=dvn(i)+dumm 9476 9477c ad1 write the mt index and radius 9478 if (iprint .ge. 5) write(16,55)jr1,dr(jr1) 9479 55 format(' jr1 = ',i10,10x,'wigner-seitz radius = ',e16.8) 9480 9481c ad1 output 2.*dvn*r**2 for use in phase (dvn = normalised coulomb) 9482c write(17,200)((2.0*dvn(i)*dr(i)*dr(i)),i=1,np) 9483c 200 format(1p5e16.8) 9484c passvc formerly used to pass data directly to PHASE 9485c do 151 i = 1, np 9486c passvc (i) = 2.0 * dvn(i) * dr(i) * dr(i) 9487c 151 continue 9488c 9489c passvc above is vcoul*r**2 9490 do 151 i = 1, np 9491 vcoul(i) = 2 * dvn(i) 9492 151 continue 9493 9494 9495c jm output renormalized charge density for use in cphase 9496c (d=4pi*rho*r^2) 9497c write(18,200) srho 9498 9499cjm write out rs as function of r 9500c do 8934 i=1,jr1 9501c xxrs=(3*dr(i)*dr(i)/srho(i))**.33333333 9502c8934 write(29,140) dr(i), xxrs 9503 return 9504 end 9505 subroutine rhl (rs, xk, erl, eim) 9506 implicit double precision (a-h, o-z) 9507 9508c input: rs, xk 9509c output: erl, eim 9510 9511c This is a new hl subroutine, using interpolation for the 9512c real part while the imaginary part is calculated analytically. 9513c It uses hl to calculate values at the mesh points for the inter- 9514c polation of the real part. The imaginary part is calculated 9515c using subroutine imhl. 9516c 9517c written by jose mustre 9518c polynomial in rs has a 3/2 power term. j.m. 9519 9520 9521c for the right branch the interpolation has the form: 9522c hl(rs,x) = e/x + f/x**2 + g/x**3 9523c where e is known and 9524c f = sum (i=1,3) ff(i) rs**(i+1)/2 9525c g = sum (i=1,3) gg(i) rs**(i+1)/2 9526c 9527c 9528c lrs=number of rs panels, in this case one has 4 panels 9529c nrs=number of standard rs values, also order of rs expansion 9530c if you change nrs you need to change the expansion of hl 9531c in powers of rs that only has 3 terms! 9532c nleft=number of coefficients for x<x0 9533c nright=number of coefficients for x>x0 9534 9535 parameter (lrs=4, nrs=3, nleft=4, nright=2) 9536 9537 parameter (pi = 3.1415926535897932384626433d0) 9538 parameter (one = 1, zero = 0) 9539 parameter (third = 1.0d0/3.0d0) 9540 parameter (raddeg = 180.0d0 / pi) 9541 complex*16 coni 9542 parameter (coni = (0.0d0,1.0d0)) 9543c kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37 9544 parameter (fa = 1.919158292677512811d0) 9545 9546 parameter (bohr = 0.529177249d0, ryd = 13.605698d0) 9547 parameter (alpinv = 137.03598956d0) 9548c fine structure alpha 9549 parameter (alphfs = 1.0d0 / alpinv) 9550c speed of light in louck's units (rydbergs?) 9551 parameter (clight = 2 * alpinv) 9552 9553 9554 dimension cleft(nleft), cright(nright) 9555 9556 save rcfl, rcfr 9557 dimension rcfl(lrs,nrs,nleft), rcfr(lrs,nrs,nright) 9558 data rcfr/-0.173963d+00,-0.173678d+00,-0.142040d+00,-0.101030d+00, 9559 1 -0.838843d-01,-0.807046d-01,-0.135577d+00,-0.177556d+00, 9560 2 -0.645803d-01,-0.731172d-01,-0.498823d-01,-0.393108d-01, 9561 3 -0.116431d+00,-0.909300d-01,-0.886979d-01,-0.702319d-01, 9562 4 0.791051d-01,-0.359401d-01,-0.379584d-01,-0.419807d-01, 9563 5 -0.628162d-01, 0.669257d-01, 0.667119d-01, 0.648175d-01/ 9564 data rcfl/ 0.590195d+02, 0.478860d+01, 0.812813d+00, 0.191145d+00, 9565 1 -0.291180d+03,-0.926539d+01,-0.858348d+00,-0.246947d+00, 9566 2 0.363830d+03, 0.460433d+01, 0.173067d+00, 0.239738d-01, 9567 3 -0.181726d+03,-0.169709d+02,-0.409425d+01,-0.173077d+01, 9568 4 0.886023d+03, 0.301808d+02, 0.305836d+01, 0.743167d+00, 9569 5 -0.110486d+04,-0.149086d+02,-0.662794d+00,-0.100106d+00, 9570 6 0.184417d+03, 0.180204d+02, 0.450425d+01, 0.184349d+01, 9571 7 -0.895807d+03,-0.318696d+02,-0.345827d+01,-0.855367d+00, 9572 8 0.111549d+04, 0.156448d+02, 0.749582d+00, 0.117680d+00, 9573 9 -0.620411d+02,-0.616427d+01,-0.153874d+01,-0.609114d+00, 9574 1 0.300946d+03, 0.109158d+02, 0.120028d+01, 0.290985d+00, 9575 2 -0.374494d+03,-0.535127d+01,-0.261260d+00,-0.405337d-01/ 9576 9577c 9578c calculate hl using interpolation coefficients 9579 rkf = fa/rs 9580 ef = rkf**2/2 9581 wp = sqrt (3/rs**3) 9582 call imhl (rs, xk, eim, icusp) 9583 9584c eim already has a factor of ef in it j.m. 9585c eim also gives the position of the cusp 9586 9587 xx = xk / rkf 9588c set to fermi level if below fermi level 9589 if (xx .lt. 1.00001) then 9590 xx = 1.00001 9591 endif 9592c calculate right hand side coefficients 9593 if (rs .lt. 0.2) then 9594 mrs=1 9595 elseif (rs .lt. 1.0) then 9596 mrs=2 9597 elseif (rs .lt. 5.0) then 9598 mrs=3 9599 else 9600 mrs=4 9601 endif 9602 9603 do 210 j=1,nright 9604 cright(j) = rcfr(mrs,1,j)*rs + rcfr(mrs,2,j)*rs*sqrt(rs) 9605 1 + rcfr(mrs,3,j)*rs**2 9606 210 continue 9607 eee=-pi*wp/(4*rkf*ef) 9608 9609 if (icusp .ne. 1) then 9610 do 230 j=1,nleft 9611 cleft(j) = rcfl(mrs,1,j)*rs + rcfl(mrs,2,j)*rs**1.5 9612 1 + rcfl(mrs,3,j)*rs**2 9613 230 continue 9614 erl=cleft(1) 9615 do 250 j=2,nleft 9616 erl=erl+cleft(j)*xx**(j-1) 9617 250 continue 9618 else 9619c right branch 9620 erl=eee/xx 9621 do 280 j=1,nright 9622 erl=erl+cright(j)/xx**(j+1) 9623 280 continue 9624 endif 9625 9626 erl = erl * ef 9627 9628 return 9629 end 9630 subroutine rot3i (lxp1, mxp1, ileg) 9631 implicit double precision (a-h,o-z) 9632 9633c input: lxp1, mxp1, ileg (lmax+1, mmax+1) 9634c also beta(ileg) used from common /pdata/ 9635c output: dri(...ileg) in common /rotmat/ 9636 9637c subroutine rot3 calculates rotation matrices for l = 0,lxp1-1 9638 9639c subroutine rot3 calculates the beta dependence of rotation 9640c matrix elements using recursion of an iterated version of 9641c formula (4.4.1) in edmonds. 9642c 9643c first written:(september 17,1986) by j. mustre 9644c version 2 (17 sep 86) 9645c version 3 (22 feb 87) modified by j. rehr 9646c version for genfmt, modified by s. zabinsky, Sept 1991 9647c Initialized dri0. Some elements may be used before being 9648c initialized elsewhere -- rot3i needs to be carefully 9649c checked. S. Zabinsky, April 1993 9650c 9651c******************** warning****************************************** 9652c ltot must be at least lxp1 or overwriting will occur 9653c nmax must be at least nm or overwriting will occur 9654c---------------------------------------------------------------------- 9655c notation dri0(l,m,n) = drot_i(l'm'n') 9656c l = l'+1, n' = n-l, m' = m-l, primes denoting subscripts 9657c thus dri0(1,1,1) corresponds to the rotation matrix with 9658c l' = 0, and n' and m' = 0; dri0(3,5,5) : l' = 2,n' = 2,m' = 2. 9659c-------------------------------------------------------------------- 9660 9661 9662 parameter (nphx = 7) !max number of unique potentials (potph) 9663 parameter (npotx = nphx) !max number of unique potentials (genfmt, paths) 9664 parameter (nfrx = nphx) !max number of free atom types 9665 parameter (novrx = 8) !max number of overlap shells 9666 parameter (natx = 250) !max number of atoms in problem 9667 parameter (ltot = 24) !max number of ang mom (arrays 1:ltot+1) 9668 parameter (nrptx = 250) !Loucks r grid used through overlap 9669 parameter (nex = 100) !Number of energy points genfmt, etc. 9670 9671 parameter (lamtot=15) !Max number of distinct lambda's for genfmt 9672 !15 handles iord 2 and exact ss 9673 parameter (mtot=4, ntot=2) !vary mmax and nmax independently 9674 parameter (legtot=9) !matches path finder, used in GENFMT 9675 parameter (npatx = 8) !max number of path atoms, used in path 9676 !finder, NOT in genfmt 9677 9678 9679 save /rotmat/ 9680 common /rotmat/ dri(ltot+1,2*mtot+1,2*mtot+1,legtot+1) 9681 9682 9683c Note that leg nleg is the leg ending at the central atom, so that 9684c ipot(nleg) is central atom potential, rat(nleg) position of 9685c central atom. 9686c Central atom has ipot=0 9687c For later convience, rat(,0) and ipot(0) refer to the central 9688c atom, and are the same as rat(,nleg), ipot(nleg). 9689 9690c text and title arrays include carriage control 9691 character*80 text, title 9692 character*6 potlbl 9693 common /str/ text(40), !text header from potph 9694 1 title(5), !title from paths.dat 9695 1 potlbl(0:npotx) ! potential labels for output 9696 9697 complex*16 ph, eref 9698 common /pdata/ 9699 1 ph(nex,ltot+1,0:npotx), !complex phase shifts, 9700 1 !central atom ipot=0 9701 1 rat(3,0:legtot+1), !position of each atom, code units(bohr) 9702 1 eref(nex), !complex energy reference 9703 1 em(nex), !energy mesh 9704 1 ri(legtot), beta(legtot+1), eta(0:legtot+1), !r, beta, eta for each leg 9705 1 deg, rnrmav, xmu, edge, !(output only) 9706 1 lmax(nex,0:npotx), !max l with non-zero phase for each energy 9707 1 ipot(0:legtot), !potential for each atom in path 9708 1 iz(0:npotx), !atomic number (output only) 9709 1 ltext(40), ltitle(5), !length of each string 9710 1 nsc, nleg, !nscatters, nlegs (nleg = nsc+1) 9711 1 npot, ne, !number of potentials, energy points 9712 1 ik0, !index of energy grid corresponding to k=0 (edge) 9713 1 ipath, !index of current path (output only) 9714 1 ihole, !(output only) 9715 1 l0, il0, !lfinal and lfinal+1 (used for indices) 9716 1 lmaxp1, !largest lmax in problem + 1 9717 1 ntext, ntitle !number of text and title lines 9718 9719c dri0 is larger than needed for genfmt, but necessary for 9720c this calculation algorithm. Copy result into smaller 9721c dri arrays (in common) at end of this routine. 9722 dimension dri0 (ltot+1, 2*ltot+1, 2*ltot+1) 9723 9724c initialize dri0 9725 do 200 il = 1, ltot+1 9726 do 200 im = 1, 2*ltot+1 9727 do 200 in = 1, 2*ltot+1 9728 dri0(il,im,in) = 0 9729 200 continue 9730 9731 nm = mxp1 9732 ndm = lxp1+nm-1 9733 xc = cos(beta(ileg)/2) 9734 xs = sin(beta(ileg)/2) 9735 s = sin(beta(ileg)) 9736 dri0(1,1,1) = 1 9737 dri0(2,1,1) = xc**2 9738 dri0(2,1,2) = s/sqrt(2.0d0) 9739 dri0(2,1,3) = xs**2 9740 dri0(2,2,1) = -dri0(2,1,2) 9741 dri0(2,2,2) = cos(beta(ileg)) 9742 dri0(2,2,3) = dri0(2,1,2) 9743 dri0(2,3,1) = dri0(2,1,3) 9744 dri0(2,3,2) = -dri0(2,2,3) 9745 dri0(2,3,3) = dri0(2,1,1) 9746 do 30 l = 3, lxp1 9747 ln = 2*l - 1 9748 lm = 2*l - 3 9749 if (ln .gt. ndm) ln = ndm 9750 if (lm .gt. ndm) lm = ndm 9751 do 20 n = 1, ln 9752 do 10 m = 1, lm 9753 t1 = (2*l-1-n) * (2*l-2-n) 9754 t = (2*l-1-m) * (2*l-2-m) 9755 f1 = sqrt (t1/t) 9756 f2 = sqrt ((2*l-1-n) * (n-1) / t) 9757 t3 = (n-2) * (n-1) 9758 f3 = sqrt(t3/t) 9759 dlnm = f1 * xc**2 * dri0(l-1,n,m) 9760 if (n-1 .gt. 0) dlnm = dlnm - f2*s*dri0(l-1,n-1,m) 9761 if (n-2 .gt. 0) dlnm = dlnm + f3*xs**2*dri0(l-1,n-2,m) 9762 dri0(l,n,m) = dlnm 9763 if (n .gt. (2*l-3)) 9764 1 dri0(l,m,n) = (-1)**(n-m) * dri0(l,n,m) 9765 10 continue 9766 if (n .gt. (2*l-3)) then 9767 dri0(l,2*l-2,2*l-2) = dri0(l,2,2) 9768 dri0(l,2*l-1,2*l-2) = -dri0(l,1,2) 9769 dri0(l,2*l-2,2*l-1) = -dri0(l,2,1) 9770 dri0(l,2*l-1,2*l-1) = dri0(l,1,1) 9771 endif 9772 20 continue 9773 30 continue 9774 40 continue 9775 9776c-----test sum rule on d 9777c open (29,file='rotmat.dat',status='new',carriagecontrol='list') 9778c write(29,*) ' l, m, sum' 9779c write(29,*) ' (dri0(il,im,in),in = 1,ln)' 9780c do 70 il = 1,lxp1 9781c l = il-1 9782c ln = 2*l+1 9783c if(ln.gt.ndm) ln = ndm 9784c do 37 im = 1,ln 9785c sum = 0 9786c do 50 in = 1,ln 9787c m = im-il 9788c term = dri0(il,im,in) 9789c 50 sum = sum+term**2 9790c write(29,60) l,m,sum 9791c write(29,62) (dri0(il,im,in),in = 1,ln) 9792c 60 format(2i3,e30.20) 9793c 62 format(5e14.6) 9794c 70 continue 9795c close(29) 9796c-----end test------------------------ 9797 9798c Copy result into dri(...ileg) in /rotmat/ (zero it first...) 9799 do 90 il = 1, ltot+1 9800 do 90 m1 = 1, 2*mtot+1 9801 do 90 m2 = 1, 2*mtot+1 9802 dri(il,m1,m2,ileg) = 0 9803 90 continue 9804 9805 do 120 il = 1, lxp1 9806 mx = min (il-1, mxp1-1) 9807 do 110 m1 = -mx, mx 9808 do 100 m2 = -mx, mx 9809 dri(il,m1+mtot+1,m2+mtot+1,ileg)=dri0(il,m1+il,m2+il) 9810 100 continue 9811 110 continue 9812 120 continue 9813 9814 return 9815 end 9816 subroutine rphbin (in) 9817 implicit double precision (a-h, o-z) 9818 9819c Reads input from unit in. Returns (via /pdata/) 9820c energy mesh (ne, em and eref), 9821c ph (npot, lmax, lmaxp1, ph), 9822c final state (l0, il0) 9823c 9824c phmin is min value to use for |phase shift| 9825 9826 9827 parameter (nphx = 7) !max number of unique potentials (potph) 9828 parameter (npotx = nphx) !max number of unique potentials (genfmt, paths) 9829 parameter (nfrx = nphx) !max number of free atom types 9830 parameter (novrx = 8) !max number of overlap shells 9831 parameter (natx = 250) !max number of atoms in problem 9832 parameter (ltot = 24) !max number of ang mom (arrays 1:ltot+1) 9833 parameter (nrptx = 250) !Loucks r grid used through overlap 9834 parameter (nex = 100) !Number of energy points genfmt, etc. 9835 9836 parameter (lamtot=15) !Max number of distinct lambda's for genfmt 9837 !15 handles iord 2 and exact ss 9838 parameter (mtot=4, ntot=2) !vary mmax and nmax independently 9839 parameter (legtot=9) !matches path finder, used in GENFMT 9840 parameter (npatx = 8) !max number of path atoms, used in path 9841 !finder, NOT in genfmt 9842 9843 9844c Note that leg nleg is the leg ending at the central atom, so that 9845c ipot(nleg) is central atom potential, rat(nleg) position of 9846c central atom. 9847c Central atom has ipot=0 9848c For later convience, rat(,0) and ipot(0) refer to the central 9849c atom, and are the same as rat(,nleg), ipot(nleg). 9850 9851c text and title arrays include carriage control 9852 character*80 text, title 9853 character*6 potlbl 9854 common /str/ text(40), !text header from potph 9855 1 title(5), !title from paths.dat 9856 1 potlbl(0:npotx) ! potential labels for output 9857 9858 complex*16 ph, eref 9859 common /pdata/ 9860 1 ph(nex,ltot+1,0:npotx), !complex phase shifts, 9861 1 !central atom ipot=0 9862 1 rat(3,0:legtot+1), !position of each atom, code units(bohr) 9863 1 eref(nex), !complex energy reference 9864 1 em(nex), !energy mesh 9865 1 ri(legtot), beta(legtot+1), eta(0:legtot+1), !r, beta, eta for each leg 9866 1 deg, rnrmav, xmu, edge, !(output only) 9867 1 lmax(nex,0:npotx), !max l with non-zero phase for each energy 9868 1 ipot(0:legtot), !potential for each atom in path 9869 1 iz(0:npotx), !atomic number (output only) 9870 1 ltext(40), ltitle(5), !length of each string 9871 1 nsc, nleg, !nscatters, nlegs (nleg = nsc+1) 9872 1 npot, ne, !number of potentials, energy points 9873 1 ik0, !index of energy grid corresponding to k=0 (edge) 9874 1 ipath, !index of current path (output only) 9875 1 ihole, !(output only) 9876 1 l0, il0, !lfinal and lfinal+1 (used for indices) 9877 1 lmaxp1, !largest lmax in problem + 1 9878 1 ntext, ntitle !number of text and title lines 9879 9880 9881 parameter (phmin = 1.0d-8) 9882 9883c These header lines do not include carriage control 9884 read(in) ntext 9885 do 62 i = 1, ntext 9886 read(in) text(i) 9887 read(in) ltext(i) 9888 62 continue 9889 read(in) ne, npot, ihole, rnrmav, xmu, edge, ik0 9890 read(in) (em(ie),ie=1,ne) 9891 read(in) (eref(ie),ie=1,ne) 9892 lmaxp1 = 0 9893 do 80 iph = 0, npot 9894 read(in) lmax0, iz(iph) 9895 read(in) potlbl(iph) 9896 do 70 ie = 1, ne 9897 read(in) (ph(ie,ll,iph), ll=1,lmax0+1) 9898 lmax(ie,iph) = 0 9899c Set lmax to include only non-zero phases 9900 do 60 il = 1, lmax0+1 9901 if (abs(ph(ie,il,iph)) .lt. phmin) goto 61 9902 lmax(ie,iph) = il-1 9903 60 continue 9904 61 continue 9905 if (lmax(ie,iph)+1 .gt. lmaxp1) lmaxp1 = lmax(ie,iph)+1 9906 70 continue 9907 80 continue 9908 9909c-----l0 is angular momentum of final state 9910c Selection rule says that final state has angmom = l_init+1 9911c ihole initial state from ihole final state 9912c 1 K 1s L=0 -> linit=0 L0=1 -> lfinal=1 9913c 2 LI 2s L=0 -> linit=0 L0=1 -> lfinal=1 9914c 3 LII 2p 1/2 L=1 -> linit=1 L0=2 -> lfinal=2 9915c 4 LIII 2p 3/2 L=1 -> linit=1 L0=2 -> lfinal=2 9916c 5+ M -- think about this later... 9917 if (ihole .le. 2) then 9918c hole in s state (1s or 2s) 9919 linit = 0 9920 lfinal = 1 9921 elseif (ihole .le. 4) then 9922c hole in p state (2p 1/2 or 2p 3/2) 9923 linit = 1 9924 lfinal = 2 9925 else 9926c some m hole, n=3, could go to d state 9927 stop 'Can not handle M shell.' 9928 endif 9929 l0 = lfinal 9930 il0 = l0 + 1 9931 9932 return 9933 end 9934 subroutine rpotph (io, nhead0, head0, lhead0, 9935 1 nat, nph, nfr, ihole, gamach, iafolp, intclc, 9936 1 ixc, vr0, vi0, rs0, iphat, rat, iatph, ifrph, 9937 1 xnatph, novr, 9938 2 iphovr, nnovr, rovr, folp, ion, iz, iprint, 9939 2 ixanes, nemax, xkmin, xkmax, potlbl) 9940 implicit double precision (a-h, o-z) 9941 9942c Notes: 9943c nat number of atoms in problem 9944c nph number of unique potentials 9945c nfr number of unique free atoms 9946c ihole hole code of absorbing atom 9947c iph=0 for central atom 9948c ifr=0 for central atom 9949c xkmin, xkmax min and max energy mesh points to consider 9950 9951 9952 parameter (nphx = 7) !max number of unique potentials (potph) 9953 parameter (npotx = nphx) !max number of unique potentials (genfmt, paths) 9954 parameter (nfrx = nphx) !max number of free atom types 9955 parameter (novrx = 8) !max number of overlap shells 9956 parameter (natx = 250) !max number of atoms in problem 9957 parameter (ltot = 24) !max number of ang mom (arrays 1:ltot+1) 9958 parameter (nrptx = 250) !Loucks r grid used through overlap 9959 parameter (nex = 100) !Number of energy points genfmt, etc. 9960 9961 parameter (lamtot=15) !Max number of distinct lambda's for genfmt 9962 !15 handles iord 2 and exact ss 9963 parameter (mtot=4, ntot=2) !vary mmax and nmax independently 9964 parameter (legtot=9) !matches path finder, used in GENFMT 9965 parameter (npatx = 8) !max number of path atoms, used in path 9966 !finder, NOT in genfmt 9967 9968 9969 character*(*) head0(nhead0) 9970 dimension lhead0(nhead0) 9971 9972c End of line comments removed -- see include file arrays.h for 9973c comments. 9974c Specific atom input data 9975 dimension iphat(natx) 9976 dimension rat(3,natx) 9977 9978c Unique potential input data 9979 dimension iatph(0:nphx) 9980 dimension ifrph(0:nphx) 9981 dimension xnatph(0:nphx) 9982 character*6 potlbl(0:nphx) 9983 9984 dimension folp(0:nphx) 9985 dimension novr(0:nphx) 9986 dimension iphovr(novrx,0:nphx) 9987 dimension nnovr(novrx,0:nphx) 9988 dimension rovr(novrx,0:nphx) 9989 9990c Free atom data 9991 dimension ion(0:nfrx) 9992 dimension iz(0:nfrx) 9993 9994c read and save header from old file, has carriage control char 9995 head0(1) = ' ' 9996 call rdhead (io, nhead0, head0, lhead0) 9997 read(io,*) ihole, gamach, iprint, iafolp, intclc 9998 read(io,*) ixc, vr0, vi0, rs0 9999 read(io,*) ixanes, nemax, xkmin, xkmax 10000 read(io,*) nfr 10001 do 710 ifr = 0, nfr 10002 read(io,*) index, iz(ifr), ion(ifr) 10003 710 continue 10004 read(io,*) nat 10005 do 720 iat = 1, nat 10006 read(io,*) index, iphat(iat), (rat(j,iat),j=1,3) 10007 720 continue 10008 read(io,*) nph 10009 do 740 iph = 0, nph 10010 read(io,*) index, iatph(iph), ifrph(iph), xnatph(iph), 10011 1 folp(iph), novr(iph) 10012 read(io,*) potlbl(iph) 10013 do 730 iovr = 1, novr(iph) 10014 read(io,*) iphovr(iovr,iph), nnovr(iovr,iph), 10015 1 rovr(iovr,iph) 10016 730 continue 10017 740 continue 10018 10019 return 10020 end 10021 subroutine sclmz (rho, lmaxp1, mmaxp1, ileg) 10022 implicit double precision (a-h, o-z) 10023 10024c Set CLM(Z) for current leg. 10025c Makes clm(z) (eq B11). Fills array clmi in /clmz/ for ileg, 10026c elements clm(0,0) -> clm(lmax+1,mmax+1). 10027c If mmaxp1 > lmaxp1, fills m only to lmaxp1. 10028 10029c calculates energy dependent factors 10030c c(il,im) = c_l^(m)z**m/m! = c_lm by recursion 10031c c_l+1,m = c_l-1,m-(2l+1)z(c_l,m-c_l,m-1, l ne m 10032c c_m,m = (-z)**m (2m)!/(2**m m!) with z = 1/i rho 10033c 10034c To test pw approx, set z = 0 10035 10036 10037 parameter (pi = 3.1415926535897932384626433d0) 10038 parameter (one = 1, zero = 0) 10039 parameter (third = 1.0d0/3.0d0) 10040 parameter (raddeg = 180.0d0 / pi) 10041 complex*16 coni 10042 parameter (coni = (0.0d0,1.0d0)) 10043c kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37 10044 parameter (fa = 1.919158292677512811d0) 10045 10046 parameter (bohr = 0.529177249d0, ryd = 13.605698d0) 10047 parameter (alpinv = 137.03598956d0) 10048c fine structure alpha 10049 parameter (alphfs = 1.0d0 / alpinv) 10050c speed of light in louck's units (rydbergs?) 10051 parameter (clight = 2 * alpinv) 10052 10053 10054 parameter (nphx = 7) !max number of unique potentials (potph) 10055 parameter (npotx = nphx) !max number of unique potentials (genfmt, paths) 10056 parameter (nfrx = nphx) !max number of free atom types 10057 parameter (novrx = 8) !max number of overlap shells 10058 parameter (natx = 250) !max number of atoms in problem 10059 parameter (ltot = 24) !max number of ang mom (arrays 1:ltot+1) 10060 parameter (nrptx = 250) !Loucks r grid used through overlap 10061 parameter (nex = 100) !Number of energy points genfmt, etc. 10062 10063 parameter (lamtot=15) !Max number of distinct lambda's for genfmt 10064 !15 handles iord 2 and exact ss 10065 parameter (mtot=4, ntot=2) !vary mmax and nmax independently 10066 parameter (legtot=9) !matches path finder, used in GENFMT 10067 parameter (npatx = 8) !max number of path atoms, used in path 10068 !finder, NOT in genfmt 10069 10070 10071 save /clmz/ 10072 complex*16 clmi 10073 common /clmz/ clmi(ltot+1,mtot+ntot+1,legtot) 10074 10075 10076 complex*16 rho(legtot) 10077 complex*16 z, cmm 10078 10079 cmm = 1 10080 z = -coni / rho(ileg) 10081 10082 clmi(1,1,ileg) = (1,0) 10083 clmi(2,1,ileg) = clmi(1,1,ileg) - z 10084 10085 lmax = lmaxp1-1 10086 10087 do 10 il = 2, lmax 10088 clmi(il+1,1,ileg) = 10089 1 clmi(il-1,1,ileg) - z*(2*il-1)*clmi(il,1,ileg) 10090 10 continue 10091 mmxp1 = min (mmaxp1, lmaxp1) 10092 do 20 im = 2, mmxp1 10093 m = im-1 10094 imp1 = im+1 10095 cmm = -cmm * (2*m-1) * z 10096 clmi(im,im,ileg) = cmm 10097 clmi(imp1,im,ileg) = cmm * (2*m+1) * (1-im*z) 10098 do 20 il = imp1, lmax 10099 l = il-1 10100 clmi(il+1,im,ileg) = clmi(l,im,ileg) - 10101 1 (2*l+1) * z * (clmi(il,im,ileg) + clmi(il,m,ileg)) 10102 20 continue 10103 10104 return 10105 end 10106 double precision function sdist(r0, r1) 10107 implicit double precision (a-h, o-z) 10108c find distance squared between cartesian points r0 and r1 10109c single precision 10110 dimension r0(3), r1(3) 10111 sdist = 0 10112 do 10 i = 1, 3 10113 sdist = sdist + (r0(i) - r1(i))**2 10114 10 continue 10115 sdist = sqrt(sdist) 10116 return 10117 end 10118 subroutine setgam (iz, ihole, gamach) 10119 10120c Sets gamach, core hole lifetime. Data comes from graphs in 10121c K. Rahkonen and K. Krause, 10122c Atomic Data and Nuclear Data Tables, Vol 14, Number 2, 1974. 10123 10124 implicit double precision (a-h, o-z) 10125 10126 dimension gamk(6), zk(6), famk(6) 10127 dimension gaml1(6), zl1(6),faml1(6) 10128 dimension gaml2(6), zl2(6),faml2(6) 10129 parameter (ryd = 13.6058) 10130 10131 save ienter 10132 10133c Note that 0.99 replaces 1.0, 95.1 replaces 95.0 to avoid roundoff 10134c trouble. 10135c Gam arrays contain the gamma values. 10136c We will take log10 of the gamma values so we can do linear 10137c interpolation from a log plot. 10138 10139 data zk / 0.99d0, 10.0d0, 20.0d0, 40.0d0, 60.0d0, 95.1d0/ 10140c data gamk / 0.07, 0.3, 0.75, 5.0, 20.0, 100.0/ 10141 data famk / 0.07d0, 0.3d0, 0.75d0, 5.0d0, 20.0d0, 100.0d0/ 10142 10143 data zl1 / 0.99d0, 20.0d0, 35.0d0, 50.0d0, 75.0d0, 95.1d0/ 10144c data gaml1 / 0.07, 4.0, 7.0, 4.0, 8.0, 19.0/ 10145 data faml1 / 0.07d0, 4.0d0, 7.0d0, 4.0d0, 8.0d0, 19.0d0/ 10146 10147 data zl2 / 0.99d0, 26.0d0, 31.0d0, 60.0d0, 80.0d0, 95.1d0/ 10148c data gaml2 / 0.001, 1.7, 0.8, 3.5, 5.0, 10.0/ 10149 data faml2 / 0.001d0, 1.7d0, 0.8d0, 3.5d0, 5.0d0, 10.0d0/ 10150 10151 data ienter /0/ 10152 10153c Call this only once, if it gets called a second time the gamma 10154c values will be messed up by repeated taking of log10 10155 10156c if (ienter .gt. 0) then 10157c write(77,*) ' Re-entered SETGAM' 10158c stop 'SETGAM-1' 10159c endif 10160c ienter = 1 10161 10162 if (ihole .le. 0) then 10163 gamach = 0 10164 write(77,*) 'No hole in SETGAM, gamach = ', gamach 10165 return 10166 endif 10167 if (ihole .gt. 4) then 10168 write(77,*) ' This version of FEFF only handles through L III', 10169 1 ' shell absorption.' 10170 stop 'SETGAM-2' 10171 endif 10172 10173 zz = iz 10174 if (ihole .le. 1) then 10175 do 10 i = 1, 6 10176c gamk(i) = log10 (gamk(i)) 10177 gamk(i) = log10 (famk(i)) 10178 10 continue 10179 call terp (zk, gamk, 6, zz, gamach) 10180 else if (ihole .le. 2) then 10181 do 20 i = 1, 6 10182c gaml1(i) = log10 (gaml1(i)) 10183 gaml1(i) = log10 (faml1(i)) 10184 20 continue 10185 call terp (zl1, gaml1, 6, zz, gamach) 10186 else if (ihole .le. 4) then 10187c note that LII and LIII have almost exactly the same 10188c core hole lifetimes 10189 do 30 i = 1, 6 10190c gaml2(i) = log10 (gaml2(i)) 10191 gaml2(i) = log10 (faml2(i)) 10192 30 continue 10193 call terp (zl2, gaml2, 6, zz, gamach) 10194 endif 10195 10196c Change from log10 (gamma) to gamma 10197 gamach = 10.0 ** gamach 10198 10199c Table values are in eV, code requires atomic units 10200 gamach = gamach / ryd 10201 10202 return 10203 end 10204 subroutine setlam (icalc, ie) 10205 implicit double precision (a-h, o-z) 10206 10207c Set lambda array based on icalc and ie 10208c icalc what to do 10209c 0 i0, ss exact 10210c 1 i1, ss exact 10211c 2 i2, ss exact 10212c 10 cute algorithm 10213c <0 do exactly as told, decode as: 10214c icalc = -(nmax + 100*mmax + 10 000*(iord+1)) 10215c Note that iord=0 <=> nmax=mmax=0, so use 10216c icalc = -10 000 for this case. 10217c iord = 2*nmax + mmax, so if you want iord to control, 10218c set nmax and mmax large enough-- if you want nmax and 10219c mmax to control, set iord = 2*nmax + mmax... 10220 10221c inputs: ie used for cute algorithm 10222c nsc used from /pdata/ to recognize ss paths 10223c output: variables in /lambda/ set 10224 10225 10226 parameter (pi = 3.1415926535897932384626433d0) 10227 parameter (one = 1, zero = 0) 10228 parameter (third = 1.0d0/3.0d0) 10229 parameter (raddeg = 180.0d0 / pi) 10230 complex*16 coni 10231 parameter (coni = (0.0d0,1.0d0)) 10232c kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37 10233 parameter (fa = 1.919158292677512811d0) 10234 10235 parameter (bohr = 0.529177249d0, ryd = 13.605698d0) 10236 parameter (alpinv = 137.03598956d0) 10237c fine structure alpha 10238 parameter (alphfs = 1.0d0 / alpinv) 10239c speed of light in louck's units (rydbergs?) 10240 parameter (clight = 2 * alpinv) 10241 10242 10243 parameter (nphx = 7) !max number of unique potentials (potph) 10244 parameter (npotx = nphx) !max number of unique potentials (genfmt, paths) 10245 parameter (nfrx = nphx) !max number of free atom types 10246 parameter (novrx = 8) !max number of overlap shells 10247 parameter (natx = 250) !max number of atoms in problem 10248 parameter (ltot = 24) !max number of ang mom (arrays 1:ltot+1) 10249 parameter (nrptx = 250) !Loucks r grid used through overlap 10250 parameter (nex = 100) !Number of energy points genfmt, etc. 10251 10252 parameter (lamtot=15) !Max number of distinct lambda's for genfmt 10253 !15 handles iord 2 and exact ss 10254 parameter (mtot=4, ntot=2) !vary mmax and nmax independently 10255 parameter (legtot=9) !matches path finder, used in GENFMT 10256 parameter (npatx = 8) !max number of path atoms, used in path 10257 !finder, NOT in genfmt 10258 10259 10260 common /lambda/ 10261 4 mlam(lamtot), !mu for each lambda 10262 5 nlam(lamtot), !nu for each lambda 10263 1 lamx, !max lambda in problem 10264 2 laml0x, !max lambda for vectors involving absorbing atom 10265 3 mmaxp1, nmax !max mu in problem + 1, max nu in problem 10266 10267 10268c Note that leg nleg is the leg ending at the central atom, so that 10269c ipot(nleg) is central atom potential, rat(nleg) position of 10270c central atom. 10271c Central atom has ipot=0 10272c For later convience, rat(,0) and ipot(0) refer to the central 10273c atom, and are the same as rat(,nleg), ipot(nleg). 10274 10275c text and title arrays include carriage control 10276 character*80 text, title 10277 character*6 potlbl 10278 common /str/ text(40), !text header from potph 10279 1 title(5), !title from paths.dat 10280 1 potlbl(0:npotx) ! potential labels for output 10281 10282 complex*16 ph, eref 10283 common /pdata/ 10284 1 ph(nex,ltot+1,0:npotx), !complex phase shifts, 10285 1 !central atom ipot=0 10286 1 rat(3,0:legtot+1), !position of each atom, code units(bohr) 10287 1 eref(nex), !complex energy reference 10288 1 em(nex), !energy mesh 10289 1 ri(legtot), beta(legtot+1), eta(0:legtot+1), !r, beta, eta for each leg 10290 1 deg, rnrmav, xmu, edge, !(output only) 10291 1 lmax(nex,0:npotx), !max l with non-zero phase for each energy 10292 1 ipot(0:legtot), !potential for each atom in path 10293 1 iz(0:npotx), !atomic number (output only) 10294 1 ltext(40), ltitle(5), !length of each string 10295 1 nsc, nleg, !nscatters, nlegs (nleg = nsc+1) 10296 1 npot, ne, !number of potentials, energy points 10297 1 ik0, !index of energy grid corresponding to k=0 (edge) 10298 1 ipath, !index of current path (output only) 10299 1 ihole, !(output only) 10300 1 l0, il0, !lfinal and lfinal+1 (used for indices) 10301 1 lmaxp1, !largest lmax in problem + 1 10302 1 ntext, ntitle !number of text and title lines 10303 10304 dimension mlam0(lamtot), nlam0(lamtot) 10305 10306c one degree in radians 10307 parameter (onedeg = .01745329252d0) 10308 10309c Set iord, nmax and mmax based on icalc 10310 if (icalc .lt. 0) then 10311c decode it and do what user wants 10312 icode = -icalc 10313 nmax = mod(icode,100) 10314 mmax = mod(icode,10000)/100 10315 iord = icode/10000 -1 10316 elseif (nsc .eq. 1) then 10317 mmax = il0-1 10318 nmax = il0-1 10319 iord = 2*nmax + mmax 10320 elseif (icalc .lt. 10) then 10321 iord = icalc 10322 mmax = iord 10323 nmax = iord/2 10324 elseif (icalc .eq. 10) then 10325c do cute algorithm 10326c set mmax = L0 if straight line path, otherwise set mmax = 3 10327 mmax = il0-1 10328 do 10 ileg = 1, nleg 10329 mag1 = abs(beta(ileg)) 10330 mag2 = abs(mag1 - pi) 10331c if beta is not 0 or pi, path is non-linear 10332 if (mag1.gt.onedeg .and. mag2.gt.onedeg) mmax = 3 10333 10 continue 10334c Set nmax based on ie and l0. 10335c k <= 12 invA (ie=41) nmax = L0 10336c k >= 13 invA (ie=42) nmax = 9 10337 nmax = il0-1 10338 if (ie .ge. 42) nmax = 9 10339 iord = 2*nmax + mmax 10340 else 10341 write(77,*) 'undefined icalc ', icalc 10342 stop 'setlam' 10343 endif 10344 10345c-----construct index lambda (lam), (mu, nu) = mlam(lam), nlam(lam) 10346c lamtot, ntot, mtot are maximum lambda, mu and nu to consider 10347c Use ...0 for making indices, then sort into arrays with no 10348c trailing 0 so laml0x is minimimized. (note: this is a crude 10349c n**2 sort -- can 'improve' to nlog_2(n) if necessary) 10350 lam = 0 10351 do 20 in = 1, nmax+1 10352 n = in - 1 10353 do 20 im = 1, mmax+1 10354 m = im-1 10355 jord = 2*n+m 10356 if (jord .gt. iord) goto 20 10357 if (lam .ge. lamtot) then 10358 write(77,*) 'Lambda array filled, some order lost' 10359 goto 21 10360 endif 10361 lam = lam+1 10362 mlam0(lam) = -m 10363 nlam0(lam) = n 10364 if (m .eq. 0) goto 20 10365 if (lam .ge. lamtot) then 10366 write(77,*) 'Lambda array filled, some order lost' 10367 goto 21 10368 endif 10369 lam = lam+1 10370 mlam0(lam) = m 10371 nlam0(lam) = n 10372 20 continue 10373 21 continue 10374 lamx=lam 10375c lamx must be less than lamtot 10376 if (lamx .gt. lamtot) stop 'SETLAM lamx > lamtot' 10377 10378c laml0x is biggest lam for non-zero fmatrix, also set mmax and nmax 10379c Sort mlam0 and nlam0 to use min possible laml0x 10380 lam = 0 10381 do 30 lam0 = 1, lamx 10382 if ((nlam0(lam0).le.l0) .and. (iabs(mlam0(lam0)).le.l0)) then 10383 lam = lam+1 10384 nlam(lam) = nlam0(lam0) 10385 mlam(lam) = mlam0(lam0) 10386 nlam0(lam0) = -1 10387 endif 10388 30 continue 10389 laml0x = lam 10390 do 40 lam0 = 1, lamx 10391 if (nlam0(lam0) .ge. 0) then 10392 lam = lam+1 10393 nlam(lam) = nlam0(lam0) 10394 mlam(lam) = mlam0(lam0) 10395 endif 10396 40 continue 10397 10398 mmaxp1 = 0 10399 nmax = 0 10400 do 50 lam = 1, lamx 10401 if (mlam(lam)+1 .gt. mmaxp1) mmaxp1 = mlam(lam)+1 10402 if (nlam(lam) .gt. nmax) nmax = nlam(lam) 10403 50 continue 10404 10405 if (nmax.gt.ntot .or. mmaxp1.gt.mtot+1) then 10406 write(77,*) 'mmaxp1, nmax, mtot, ntot ', 10407 1 mmaxp1, nmax, mtot, ntot 10408 write(77,*) 'icalc ', icalc 10409 stop 'setlam' 10410 endif 10411 10412 return 10413 end 10414 subroutine sidx (rholap, npts, rmt, rnrm, imax, imt, inrm) 10415 implicit double precision (a-h, o-z) 10416 dimension rholap (npts) 10417 10418 imt = ii (rmt) 10419 inrm = ii (rnrm) 10420 10421c Set imax (last non-zero rholap data) 10422 do 220 i = 1, npts 10423 if (rholap(i) .le. 1.0d-5) goto 230 10424 imax = i 10425 220 continue 10426 230 continue 10427 10428c We need data up to the norman radius, so move norman 10429c radius if density is zero inside rnrm. 10430 if (inrm .gt. imax) then 10431 inrm = imax 10432 rnrm = rr (inrm) 10433 write(77,*) ' Moved rnrm. New rnrm (au) ', rnrm 10434 endif 10435 if (imt .gt. imax) then 10436 imt = imax 10437 rmt = rr (imt) 10438 write(77,*) ' Moved rmt. New rmt (au) ', rmt 10439 endif 10440 return 10441 end 10442c--------------------------------------------------------------------- 10443c program sigms.f 10444c 10445c calculates debye-waller factors for each multiple 10446c scattering path using Debye-Model correlations 10447c 10448c files: input pathd_all.dat multiple scattering path data 10449c output fort.3 sig**2 vs path 10450c fort.2 long output 10451c 10452c version 1 (29 july 91) 10453c 10454c coded by j. rehr 10455c path data from s. zabinsky 10456c 10457c modified to use pdata.inp, Dec 1991, siz 10458c Subroutine version, Dec 1991, siz 10459c 10460c--------------------------------------------------------------------- 10461 10462 subroutine sigms (tk, thetad, rs, nlegx, nleg, rat, iz, sig2) 10463c tk temperature in degrees K 10464c thetad debye temp in degrees K 10465c rs=wigner seitz or norman radius in bohr, averaged 10466c over entire problem 10467c (4pi/3)*rs**3 = sum( (4pi/3)rnrm**3 ) / N 10468c (sum is over all atoms in the problem) 10469c nlegx used in dimensions of rat and iz 10470c nleg nlegs in path 10471c rat positions of each atom in path (in bohr) 10472c iz atomic number of each atom in path 10473c NB Units of distance in this routine 10474c are angstroms, including sig**2 10475c sig2 is output, debye waller factor in bohr**-2 10476 10477 implicit double precision (a-h,o-z) 10478 10479 10480 parameter (pi = 3.1415926535897932384626433d0) 10481 parameter (one = 1, zero = 0) 10482 parameter (third = 1.0d0/3.0d0) 10483 parameter (raddeg = 180.0d0 / pi) 10484 complex*16 coni 10485 parameter (coni = (0.0d0,1.0d0)) 10486c kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37 10487 parameter (fa = 1.919158292677512811d0) 10488 10489 parameter (bohr = 0.529177249d0, ryd = 13.605698d0) 10490 parameter (alpinv = 137.03598956d0) 10491c fine structure alpha 10492 parameter (alphfs = 1.0d0 / alpinv) 10493c speed of light in louck's units (rydbergs?) 10494 parameter (clight = 2 * alpinv) 10495 10496 10497c nlegx is max number of atoms in any one path 10498 dimension rat(3,0:nlegx) 10499 dimension iz(0:nlegx) 10500 10501c parameters 10502c x = k_d*R (distance parameter) 10503c R distance in angstroms 10504c y = hbar omegad/kT = thetad/t 10505c thetad debye temp in degrees K 10506c tk temperature in degrees K 10507c k_d = (6*pi**2 N/V) = debye wave number 10508c N/V=1/(4pi/3rs**3) 10509c rs=wigner seitz or norman radius in bohr 10510c ami, amj masses at sites i and j in amu 10511c I = int_0^1 (y/x) dw sin(wx)coth(wy/2) 10512 10513c Note: There are nleg atoms including the central atom 10514c index 0 and index nleg both refer to central atom, 10515c which makes special code unnecessary later. 10516 sum = 0.0d0 10517 ntot = 0 10518 10519 sigtot=0 10520 do 800 il=1,nleg 10521 do 800 jl=il,nleg 10522 10523c calculate r_i-r_i-1 and r_j-r_j-1 10524 10525 rij = feff_dist (rat(1,il), rat(1,jl)) 10526 call corrfn (rij, cij, thetad, tk, iz(il), iz(jl), rs) 10527 sig2ij=cij 10528 10529 rimjm = feff_dist (rat(1,il-1), rat(1,jl-1)) 10530 call corrfn (rimjm, cimjm, thetad, tk, iz(il-1), iz(jl-1), rs) 10531 sig2ij=sig2ij+cimjm 10532 10533 rijm = feff_dist (rat(1,il), rat(1,jl-1)) 10534 call corrfn (rijm, cijm, thetad, tk, iz(il), iz(jl-1), rs) 10535 sig2ij=sig2ij-cijm 10536 10537 rimj = feff_dist (rat(1,il-1), rat(1,jl)) 10538 call corrfn (rimj, cimj, thetad, tk, iz(il-1), iz(jl), rs) 10539 sig2ij=sig2ij-cimj 10540 10541 riim = feff_dist (rat(1,il), rat(1,il-1)) 10542 rjjm = feff_dist (rat(1,jl), rat(1,jl-1)) 10543 10544 ridotj=(rat(1,il)-rat(1,il-1))*(rat(1,jl)-rat(1,jl-1))+ 10545 1 (rat(2,il)-rat(2,il-1))*(rat(2,jl)-rat(2,jl-1))+ 10546 2 (rat(3,il)-rat(3,il-1))*(rat(3,jl)-rat(3,jl-1)) 10547 ridotj=ridotj/(riim*rjjm) 10548 10549c double count i .ne. j terms 10550 if(jl.ne.il) sig2ij=2*sig2ij 10551 sig2ij=sig2ij*ridotj 10552 sigtot=sigtot+sig2ij 10553 10554 800 continue 10555 sig2=sigtot/4.0d0 10556 10557c sig2 is in bohr**2, just as we wanted for ff2chi 10558 return 10559 end 10560 10561 10562 10563 subroutine corrfn(rij,cij,thetad,tk,iz1,iz2,rsavg) 10564c subroutine calculates correlation function 10565c c(ri,rj)=<xi xj> in the Debye approximation 10566c 10567c =(1/N)sum_k exp(ik.(Ri-Rj))(1/sqrt(mi*mj))* 10568c (hbar/2w_k)*coth(beta hbar w_k/2) 10569c = (3kT/mu w_d**2)*sqrt(mu**2/mi*mj)*I 10570c 10571c parameters 10572c x = k_d*R (distance parameter) 10573c R distance in angstroms 10574c y = hbar omegad/kT = thetad/t 10575c thetad debye temp in degrees K 10576c tk temperature in degrees K 10577c k_d = (6*pi**2 N/V) = debye wave number 10578c N/V=1/(4pi/3rs**3) 10579c rs=wigner seitz or norman radius in bohr 10580c ami, amj masses at sites i and j in amu 10581c I = int_0^1 (y/x) dw sin(wx)coth(wy/2) 10582c 10583c solution by numerical integration 10584c 10585 implicit double precision (a-h, o-z) 10586 common /xy/ x, yinv 10587 10588 10589 parameter (pi = 3.1415926535897932384626433d0) 10590 parameter (one = 1, zero = 0) 10591 parameter (third = 1.0d0/3.0d0) 10592 parameter (raddeg = 180.0d0 / pi) 10593 complex*16 coni 10594 parameter (coni = (0.0d0,1.0d0)) 10595c kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37 10596 parameter (fa = 1.919158292677512811d0) 10597 10598 parameter (bohr = 0.529177249d0, ryd = 13.605698d0) 10599 parameter (alpinv = 137.03598956d0) 10600c fine structure alpha 10601 parameter (alphfs = 1.0d0 / alpinv) 10602c speed of light in louck's units (rydbergs?) 10603 parameter (clight = 2 * alpinv) 10604 10605 10606c con=hbar**2/kB*amu)*10**20 in ang**2 units 10607c hbar = 1.054 572 666 e-34, amu = 1.660 540 e-27, 10608c kB = 1.380 6581 d-23 10609 parameter (con = 48.508459393094d0) 10610 10611c external fn 10612c rij=2.55 10613c tk=295 10614c thetad=315 10615c ami=amj=63.55 at wt for Cu 10616c rs=2.7 10617 10618 ami=atwtd(iz1) 10619 amj=atwtd(iz2) 10620 rs=rsavg 10621c thetad in degrees K, t temperature in degrees K 10622c y=thetad/tk 10623 yinv=tk/thetad 10624 xkd=(9.0d0*pi/2.0d0)**(third)/(rs*bohr) 10625 fac=(3.0d0/2.0d0)*con/(thetad*sqrt(ami*amj)) 10626 rj=rij 10627 x=xkd*rj 10628c call numerical integration 10629 call bingrt (grater, eps, nx) 10630 cij=fac*grater 10631 return 10632 end 10633 double precision function fn(w) 10634 implicit double precision (a-h,o-z) 10635 common/xy/x,yinv 10636c fn=(sin(wx)/x)*coth(wy/2) 10637c change code to allow t=0 without bombing 10638c fn=2/y 10639 fn=2.0d0*yinv 10640 if(w.lt.1.d-20) return 10641 fac=w 10642 if(x.gt.0.0d0) fac=sin(w*x)/x 10643 emwy=0.0d0 10644 if(yinv.gt.0.0125d0) emwy=exp(-w/yinv) 10645 emwy=exp(-w/yinv) 10646 fn=fac*(1.0d0+emwy)/(1.0d0-emwy) 10647 return 10648 end 10649c----------------------------------------------- 10650 subroutine bingrt (b, eps, n) 10651c subroutine calculates integrals between [0,1] 10652c b = int_0^1 f(z) dz 10653c by trapezoidal rule and binary refinement 10654c (romberg integration) 10655c coded by j rehr (10 Feb 92) 10656c see, e.g., numerical recipes for discussion 10657c and a much fancier version 10658c----------------------------------------------- 10659c del=dz itn=2**n tol=1.e-5 10660c starting values 10661 implicit double precision (a-h,o-z) 10662 common /xy/x,yinv 10663c external fn 10664c error is approximately 2**(-2n) ~ 10**(-.6n) 10665c so nmax=10 implies an error of 1.e-6 10666 parameter(nmax = 10, tol = 1.d-5) 10667 parameter(zero=0, one=1) 10668 n=0 10669 itn=1 10670 del=1.0d0 10671 bn=(fn(zero)+fn(one))/2.0d0 10672 bo=bn 10673 10 continue 10674c nth iteration 10675c b_n+1=(b_n)/2+deln*sum_0^2**n f([2n-1]deln) 10676 n=n+1 10677 if(n.gt.nmax) go to 40 10678 del=del/2.0d0 10679 sum=0.0d0 10680 do 20 i=1, itn 10681 zi=(2*i-1)*del 10682 20 sum=sum+fn(zi) 10683c bnp1=b_n+1 is current value of integral 10684 bnp1=bn/2.0d0+del*sum 10685c cancel leading error terms b=[4b-bn]/3 10686c note: this is the first term in the 10687c neville table - remaining errors were 10688c found too small to justify the added code 10689 b=(4*bnp1-bn)/3.0d0 10690 eps=abs((b-bo)/b) 10691 if(eps.lt.tol) goto 60 10692 bn=bnp1 10693 bo=b 10694 itn=itn*2 10695 goto 10 10696 40 write(77,50) n,itn, b,eps 10697 50 format(' not converged, n,itn,b,eps=', 10698 1 2i4,2e14.6) 10699 return 10700 60 continue 10701c print70, n, itn, b, eps 10702c70 format(' n,itn,b,eps=' 2i4,2e16.8) 10703 return 10704 end 10705 subroutine snlm (lmaxp1, mmaxp1) 10706 implicit double precision(a-h,o-z) 10707 10708c Set nlm, legendre normalization factors, xnlm in common /nlm/ 10709c Calculates legendre norm factors 10710c xnlm= sqrt ((2l+1)(l-m)!/(l+m)!) 10711 10712 10713 parameter (nphx = 7) !max number of unique potentials (potph) 10714 parameter (npotx = nphx) !max number of unique potentials (genfmt, paths) 10715 parameter (nfrx = nphx) !max number of free atom types 10716 parameter (novrx = 8) !max number of overlap shells 10717 parameter (natx = 250) !max number of atoms in problem 10718 parameter (ltot = 24) !max number of ang mom (arrays 1:ltot+1) 10719 parameter (nrptx = 250) !Loucks r grid used through overlap 10720 parameter (nex = 100) !Number of energy points genfmt, etc. 10721 10722 parameter (lamtot=15) !Max number of distinct lambda's for genfmt 10723 !15 handles iord 2 and exact ss 10724 parameter (mtot=4, ntot=2) !vary mmax and nmax independently 10725 parameter (legtot=9) !matches path finder, used in GENFMT 10726 parameter (npatx = 8) !max number of path atoms, used in path 10727 !finder, NOT in genfmt 10728 10729 10730 save /nlm/ 10731 common /nlm/ xnlm(ltot+1,mtot+1) 10732 10733 10734c flg(i) = i! * afac**i, set in factst 10735 dimension flg(0:210) 10736 10737 call factst (afac, flg) 10738 10739c initialize xnlm explicitly 10740 do 5 il = 1, ltot+1 10741 do 5 im = 1, mtot+1 10742 xnlm(il,im) = 0 10743 5 continue 10744 10745 do 10 il = 1, lmaxp1 10746 mmxp1 = min (mmaxp1, il) 10747 do 10 im = 1, mmxp1 10748 l = il-1 10749 m = im-1 10750 cnlm = (2*l+1) * flg(l-m) / flg(l+m) 10751 cnlm = sqrt(cnlm) * afac**m 10752 xnlm(il,im) = cnlm 10753 10 continue 10754 10755 return 10756 end 10757 subroutine factst (afac, flg) 10758 implicit double precision (a-h,o-z) 10759 10760c FACTorial SeT, flg(i) = i! * afac**i 10761 dimension flg(0:210) 10762 10763c afac = 1/64 works with double precision on a VAX 10764 afac = 1.0d0/64.0d0 10765 10766 flzero = 1 10767 flg(0) = 1 10768 flg(1) = afac 10769 10770 do 10 i = 2, 210 10771 10 flg(i) = flg(i-1) * i * afac 10772 10773 return 10774 end 10775 subroutine somm (dr,dp,dq,dpas,da,m,np) 10776c 10777c integration by the method of simpson of (dp+dq)*dr**m from 10778c 0 to r=dr(np) 10779c dpas=exponential step; 10780c for r in the neighborhood of zero (dp+dq)=cte*r**da 10781c ********************************************************************** 10782 implicit double precision (a-h,o-z) 10783 save 10784 dimension dr(251), dp(251), dq(251) 10785 mm=m+1 10786 d1=da+mm 10787 da=0.0d0 10788 db=0.0d0 10789 do 70 i=1,np 10790 dl=dr(i)**mm 10791 if (i.eq.1.or.i.eq.np) go to 10 10792 dl=dl+dl 10793 if ((i-2*(i/2)).eq.0) dl=dl+dl 10794 10 dc=dp(i)*dl 10795 if (dc) 20,40,30 10796 20 db=db+dc 10797 go to 40 10798 30 da=da+dc 10799 40 dc=dq(i)*dl 10800 if (dc) 50,70,60 10801 50 db=db+dc 10802 go to 70 10803 60 da=da+dc 10804 70 continue 10805 da=dpas*(da+db)/3.0d0 10806 dc=exp(dpas)-1.0d0 10807 db=d1*(d1+1.0d0)*dc*exp((d1-1.0d0)*dpas) 10808 db=dr(1)*(dr(2)**m)/db 10809 dc=(dr(1)**mm)*(1.0d0+1.0d0/(dc*(d1+1.0d0)))/d1 10810 da=da+dc*(dp(1)+dq(1))-db*(dp(2)+dq(2)) 10811 return 10812 end 10813 subroutine sortir (n, index, r) 10814 implicit double precision (a-h, o-z) 10815 10816c SORT by rearranges Indices, keys are Real numbers 10817c Heap sort, following algorithm in Knuth using r as key 10818c Knuth, The Art of Computer Programming, 10819c Vol 3 / Sorting and Searching, pp 146-7 10820c Array r is not modified, instead array index is returned 10821c ordered so that r(index(1)) is smallest, etc. 10822c rr is temporary r storage (Knuth's R), irr is index of stored r 10823 10824 dimension r(n), index(n) 10825 10826c Initialize index array 10827 do 10 i = 1, n 10828 index(i) = i 10829 10 continue 10830c only 1 element is already sorted 10831 if (n .eq. 1) return 10832 10833c H1: initialize 10834 l = n/2 + 1 10835 ir = n 10836 10837c H2: Decrease l or ir 10838 20 continue 10839 if (l .gt. 1) then 10840 l = l-1 10841 irr = index(l) 10842 rr = r(irr) 10843 else 10844 irr = index(ir) 10845 rr = r(irr) 10846 index(ir) = index(1) 10847 ir = ir-1 10848 if (ir .eq. 1) then 10849 index(1) = irr 10850 return 10851 endif 10852 endif 10853 10854c H3: Prepare for sift-up 10855 j = l 10856 10857c H4: Advance downward 10858 40 continue 10859 i = j 10860 j = 2 * j 10861 if (j .eq. ir) goto 60 10862 if (j .gt. ir) goto 80 10863 10864c H5: Find larger son of i 10865 if (r(index(j)) .lt. r(index(j+1))) j = j+1 10866 10867c H6: Son larger than rr? 10868 60 continue 10869 if (rr .ge. r(index(j))) goto 80 10870 10871c H7: Move son up 10872 index(i) = index(j) 10873 goto 40 10874 10875c H8: Store rr in it's proper place 10876 80 continue 10877 index(i) = irr 10878 goto 20 10879 10880 end 10881 subroutine sortii (n, index, k) 10882 implicit double precision (a-h, o-z) 10883 10884c SORT by rearranges Indices, keys are Integers 10885c Heap sort, following algorithm in Knuth using r as key 10886c Knuth, The Art of Computer Programming, 10887c Vol 3 / Sorting and Searching, pp 146-7 10888c Array r is not modified, instead array index is returned 10889c ordered so that r(index(1)) is smallest, etc. 10890c rr is temporary r storage (Knuth's R), irr is index of stored r 10891 10892 dimension k(n) 10893 dimension index(n) 10894 10895c Initialize index array 10896 do 10 i = 1, n 10897 index(i) = i 10898 10 continue 10899c only 1 element is already sorted 10900 if (n .eq. 1) return 10901 10902c H1: initialize 10903 l = n/2 + 1 10904 ir = n 10905 10906c H2: Decrease l or ir 10907 20 continue 10908 if (l .gt. 1) then 10909 l = l-1 10910 irr = index(l) 10911 kk = k(irr) 10912 else 10913 irr = index(ir) 10914 kk = k(irr) 10915 index(ir) = index(1) 10916 ir = ir-1 10917 if (ir .eq. 1) then 10918 index(1) = irr 10919 return 10920 endif 10921 endif 10922 10923c H3: Prepare for sift-up 10924 j = l 10925 10926c H4: Advance downward 10927 40 continue 10928 i = j 10929 j = 2 * j 10930 if (j .eq. ir) goto 60 10931 if (j .gt. ir) goto 80 10932 10933c H5: Find larger son of i 10934 if (k(index(j)) .lt. k(index(j+1))) j = j+1 10935 10936c H6: Son larger than kk? 10937 60 continue 10938 if (kk .ge. k(index(j))) goto 80 10939 10940c H7: Move son up 10941 index(i) = index(j) 10942 goto 40 10943 10944c H8: Store kk in it's proper place 10945 80 continue 10946 index(i) = irr 10947 goto 20 10948 10949 end 10950 subroutine sortid (n, index, r) 10951 10952c SORT by rearranges Indices, keys are Double precision numbers 10953c Heap sort, following algorithm in Knuth using r as key 10954c Knuth, The Art of Computer Programming, 10955c Vol 3 / Sorting and Searching, pp 146-7 10956c Array r is not modified, instead array index is returned 10957c ordered so that r(index(1)) is smallest, etc. 10958c rr is temporary r storage (Knuth's R), irr is index of stored r 10959 10960 implicit double precision (a-h, o-z) 10961 dimension r(n), index(n) 10962 10963c Initialize index array 10964 do 10 i = 1, n 10965 index(i) = i 10966 10 continue 10967c only 1 element is already sorted 10968 if (n .eq. 1) return 10969 10970c H1: initialize 10971 l = n/2 + 1 10972 ir = n 10973 10974c H2: Decrease l or ir 10975 20 continue 10976 if (l .gt. 1) then 10977 l = l-1 10978 irr = index(l) 10979 rr = r(irr) 10980 else 10981 irr = index(ir) 10982 rr = r(irr) 10983 index(ir) = index(1) 10984 ir = ir-1 10985 if (ir .eq. 1) then 10986 index(1) = irr 10987 return 10988 endif 10989 endif 10990 10991c H3: Prepare for sift-up 10992 j = l 10993 10994c H4: Advance downward 10995 40 continue 10996 i = j 10997 j = 2 * j 10998 if (j .eq. ir) goto 60 10999 if (j .gt. ir) goto 80 11000 11001c H5: Find larger son of i 11002 if (r(index(j)) .lt. r(index(j+1))) j = j+1 11003 11004c H6: Son larger than rr? 11005 60 continue 11006 if (rr .ge. r(index(j))) goto 80 11007 11008c H7: Move son up 11009 index(i) = index(j) 11010 goto 40 11011 11012c H8: Store rr in it's proper place 11013 80 continue 11014 index(i) = irr 11015 goto 20 11016 11017 end 11018C FUNCTION ISTRLN (STRING) Returns index of last non-blank 11019C character. Returns zero if string is 11020C null or all blank. 11021 11022 FUNCTION ISTRLN (STRING) 11023 CHARACTER*(*) STRING 11024 11025C -- If null string or blank string, return length zero. 11026 ISTRLN = 0 11027 IF (STRING (1:1) .EQ. CHAR(0)) RETURN 11028 IF (STRING .EQ. ' ') RETURN 11029 11030C -- Find rightmost non-blank character. 11031 ILEN = LEN (STRING) 11032 DO 20 I = ILEN, 1, -1 11033 IF (STRING (I:I) .NE. ' ') GOTO 30 11034 20 CONTINUE 11035 30 ISTRLN = I 11036 11037 RETURN 11038 END 11039C SUBROUTINE TRIML (STRING) Removes leading blanks. 11040 11041 SUBROUTINE TRIML (STRING) 11042 CHARACTER*(*) STRING 11043 CHARACTER*200 TMP 11044 11045 JLEN = ISTRLN (STRING) 11046 11047C -- All blank and null strings are special cases. 11048 IF (JLEN .EQ. 0) RETURN 11049 11050C -- FInd first non-blank char 11051 DO 10 I = 1, JLEN 11052 IF (STRING (I:I) .NE. ' ') GOTO 20 11053 10 CONTINUE 11054 20 CONTINUE 11055 11056C -- If I is greater than JLEN, no non-blanks were found. 11057 IF (I .GT. JLEN) RETURN 11058 11059C -- Remove the leading blanks. 11060 TMP = STRING (I:) 11061 STRING = TMP 11062 RETURN 11063 END 11064C*********************************************************************** 11065C 11066 SUBROUTINE BWORDS (S, NWORDS, WORDS) 11067C 11068C Breaks string into words. Words are seperated by one or more 11069C blanks, or a comma and zero or more blanks. 11070C 11071C ARGS I/O DESCRIPTION 11072C ---- --- ----------- 11073C S I CHAR*(*) String to be broken up 11074C NWORDS I/O Input: Maximum number of words to get 11075C Output: Number of words found 11076C WORDS(NWORDS) O CHAR*(*) WORDS(NWORDS) 11077C Contains words found. WORDS(J), where J is 11078C greater then NWORDS found, are undefined on 11079C output. 11080C 11081C Written by: Steven Zabinsky, September 1984 11082C 11083C************************** Deo Soli Gloria ************************** 11084 11085C -- No floating point numbers in this routine. 11086 IMPLICIT INTEGER (A-Z) 11087 11088 CHARACTER*(*) S, WORDS(NWORDS) 11089 11090 CHARACTER BLANK, COMMA 11091 PARAMETER (BLANK = ' ', COMMA = ',') 11092 11093C -- BETW .TRUE. if between words 11094C COMFND .TRUE. if between words and a comma has already been found 11095 LOGICAL BETW, COMFND 11096 11097C -- Maximum number of words allowed 11098 WORDSX = NWORDS 11099 11100C -- SLEN is last non-blank character in string 11101 SLEN = ISTRLN (S) 11102 11103C -- All blank string is special case 11104 IF (SLEN .EQ. 0) THEN 11105 NWORDS = 0 11106 RETURN 11107 ENDIF 11108 11109C -- BEGC is beginning character of a word 11110 BEGC = 1 11111 NWORDS = 0 11112 11113 BETW = .TRUE. 11114 COMFND = .TRUE. 11115 11116 DO 10 I = 1, SLEN 11117 IF (S(I:I) .EQ. BLANK) THEN 11118 IF (.NOT. BETW) THEN 11119 NWORDS = NWORDS + 1 11120 WORDS (NWORDS) = S (BEGC : I-1) 11121 BETW = .TRUE. 11122 COMFND = .FALSE. 11123 ENDIF 11124 ELSEIF (S(I:I) .EQ. COMMA) THEN 11125 IF (.NOT. BETW) THEN 11126 NWORDS = NWORDS + 1 11127 WORDS (NWORDS) = S(BEGC : I-1) 11128 BETW = .TRUE. 11129 ELSEIF (COMFND) THEN 11130 NWORDS = NWORDS + 1 11131 WORDS (NWORDS) = BLANK 11132 ENDIF 11133 COMFND = .TRUE. 11134 ELSE 11135 IF (BETW) THEN 11136 BETW = .FALSE. 11137 BEGC = I 11138 ENDIF 11139 ENDIF 11140 11141 IF (NWORDS .GE. WORDSX) RETURN 11142 11143 10 CONTINUE 11144 11145 IF (.NOT. BETW .AND. NWORDS .LT. WORDSX) THEN 11146 NWORDS = NWORDS + 1 11147 WORDS (NWORDS) = S (BEGC :SLEN) 11148 ENDIF 11149 11150 RETURN 11151 END 11152 subroutine strap (x, y, n, sum) 11153 implicit double precision (a-h, o-z) 11154 11155c Trapeziodal integration of y(x), result in sum 11156c SINGLE PRECISION 11157 11158 dimension x(n), y(n) 11159 11160 sum = y(1) * (x(2) - x(1)) 11161 do 10 i = 2, n-1 11162 sum = sum + y(i) * (x(i+1) - x(i-1)) 11163 10 continue 11164 sum = sum + y(n) * (x(n) - x(n-1)) 11165 sum = sum/2.0d0 11166 11167 return 11168 end 11169c SUBROUTINE SUMAX (NPTS, RN, ANN, AA2, AASUM) 11170c This is a version of the subroutine sumax found on page 110 of 11171c Louck's book. It performs eq 3.22, using simpson's rule and 11172c taking advantage of the logarithmic grid so that sum f(r)*dr becomes 11173c sum over f(r)*r*(0.05). Linear interpolation is used at the end 11174c caps. This version does not sum over 14 shells of identical 11175c atoms, instead it averages the contribution of one or more atoms 11176c of type 2 at the location of atom 1. Louck's description (except 11177c for his integration algorithm) is very clear. 11178c 11179c input: npts number of points to consider 11180c rn distance from atom 1 to atom 2 in au 11181c ann number of type 2 atoms to add to atom 1, can 11182c be fractional 11183c aa2(i) potential or density at atom 2 11184c output: aasum(i) spherically summed contribution added into this 11185c array so that sumax can be called repeatedly 11186c and the overlapped values summed into aasum 11187c 11188c Note that this routine requires that all position data be on a 11189c grid rr(j) = exp (-8.8d0 + (j-1)*0.05d0), which is the grid 11190c used by Louck, and also used by ATOM if nuclear options not used. 11191c 11192c Coded by Steven Zabinsky, December 1989 11193c Modified for FEFF cluster code, August 1990, siz 11194c Bug fixed, May 1991, SIZ 11195c Another bug fixed, Mar 1992, SIZ 11196c 11197c T.L.Louck, Augmented Plane Wave Method, W.A.Benjamin, Inc., 1967 11198 11199 subroutine sumax (npts, rn, ann, aa2, aasum) 11200 implicit double precision (a-h, o-z) 11201 parameter (nptx=250) 11202 dimension aa2(nptx), aasum(nptx) 11203 dimension stor(nptx) 11204 11205c jjchi index beyond which aa2 is zero 11206c jtop index just below distance to neighbor 11207c aasum is calculated only up to index jtop 11208 11209c Wigner-Seitz radius is set to 15 in ATOM. 11210 rws = 15.0d0 11211 jjchi = ii(rws) 11212 jtop = ii(rn) 11213 11214 topx = xx(jjchi) 11215 11216 do 120 i = 1, jtop 11217 x = xx(i) 11218 xint = 0.0d0 11219 et = exp(x) 11220 blx = log(rn-et) 11221 if (blx .ge. topx) goto 119 11222 jbl = 2.0d0+20.0d0*(blx+8.8d0) 11223 if (jbl .lt. 1) jbl=1 11224 if (jbl .ge. 2) then 11225c use linear interp to make end cap near center of neighbor 11226 xjbl = jbl 11227 xbl = 0.05d0 * (xjbl-1.0d0) - 8.8d0 11228 g = xbl-blx 11229 xint =xint+0.5d0*g*(aa2(jbl)*(2.0d0-20.0d0*g)*exp(2.0d0*xbl) 11230 1 +20.0d0*g*aa2(jbl-1)*exp(2.0d0*(xbl-0.05d0))) 11231 endif 11232 tlx = log(rn+et) 11233 if (tlx .ge. topx) then 11234 jtl = jjchi 11235 go to 90 11236 endif 11237 jtl = 1.0d0 + 20.0d0*(tlx+8.8d0) 11238 if (jtl .lt. jbl) then 11239c handle peculiar special case at center of atom 1 11240 fzn = aa2(jtl)*exp(2.0d0*(xbl-0.05d0)) 11241 fz3 = aa2(jbl)*exp(2.0d0*xbl) 11242 fz2 = fzn+20.0d0*(fz3-fzn)*(tlx-xbl+0.05d0) 11243 fz1 = fzn+20.0d0*(fz3-fzn)*(blx-xbl+0.05d0) 11244 xint = 0.5d0*(fz1+fz2)*(tlx-blx) 11245 go to 119 11246 endif 11247 xjtl = jtl 11248 xtl = 0.05d0*(xjtl-1.0d0)-8.8d0 11249 c = tlx-xtl 11250 xint = xint+0.5d0*c*(aa2(jtl)*(2.0d0-20.0d0*c) 11251 1 *exp(2.0d0*xtl)+aa2(jtl+1)*20.0d0*c 11252 2 *exp(2.0d0*(xtl+0.05d0))) 11253 11254 90 if (jtl .gt. jbl) then 11255 100 xint = xint+0.5d0*(aa2(jbl)*exp(2.0d0*xbl)+aa2(jbl+1) 11256 1 *exp(2.0d0*(xbl+0.05d0)))*0.05d0 11257 jbl = jbl+1 11258 if (jbl .lt. jtl) then 11259 xbl = xbl+0.05d0 11260 go to 100 11261 endif 11262 endif 11263 119 stor(i) = 0.5d0*xint*ann/(rn*et) 11264 120 continue 11265 11266 do 190 i = 1, jtop 11267 aasum(i) = aasum(i) + stor(i) 11268 190 continue 11269 11270 return 11271 end 11272c Linear interpolation and extrapolation. 11273c Input x and y arrays, returns y value y0 at requested x value x0. 11274c Dies on error. 11275 11276 subroutine terp (x, y, n, x0, y0) 11277 implicit double precision (a-h, o-z) 11278 11279 dimension x(n), y(n) 11280 11281c Find out between which x points x0 lies 11282 i = locat (x0, n, x) 11283c if i < 1, set i=1, if i > n-1, set i=n-1 11284 i = max (i, 1) 11285 i = min (i, n-1) 11286 11287 if (x(i+1) - x(i) .eq. 0) stop 'TERP-1' 11288 11289 y0 = y(i) + (x0 - x(i)) * (y(i+1) - y(i)) / (x(i+1) - x(i)) 11290 11291 return 11292 end 11293 11294 integer function locat(x, n, xx) 11295 implicit double precision (a-h, o-z) 11296 double precision x, xx(n) 11297 integer u, m, n 11298 11299c Binary search for index of grid point immediately below x. 11300c Array xx required to be monotonic increasing. 11301c Returns 11302c 0 x < xx(1) 11303c 1 x = xx(1) 11304c i x = xx(i) 11305c n x >= xx(n) 11306 11307 locat = 0 11308 u = n+1 11309 11310 10 if (u-locat .gt. 1) then 11311 m = (u + locat) / 2 11312 if (x .lt. xx(m)) then 11313 u = m 11314 else 11315 locat = m 11316 endif 11317 goto 10 11318 endif 11319 11320 return 11321 end 11322 subroutine timrep (npat, ipat, rx, ry, rz, dhash) 11323 implicit double precision (a-h, o-z) 11324 11325c subroutine timrev(...) is modified for polarization case 11326c Time-orders path and returns path in standard order, 11327c standard order defined below. 11328c Input: npat, ipat 11329c Output: ipat in standard order (time reversed if necessary) 11330c rx, ry, rz contain x,y,z coordinates of the path atoms, 11331c where z-axis is along polarization vector or first leg, if 11332c running usual feff, 11333c x-axis is chosen so that first atom, which does not lie on 11334c z-axis, lies in xz-plane, 11335c for elliptically polarized light, x-axis is along the 11336c incidence direction 11337c y-axis is cross product of two previos unit vectors 11338c Standarrd order is defined so that first nonzero x,y and z 11339c coords are positive.(Otherwise we use the inversion of 11340c the corresponding unit vector) 11341c dhash double precision hash key for path in standard 11342c order 11343 11344 11345 parameter (nphx = 7) !max number of unique potentials (potph) 11346 parameter (npotx = nphx) !max number of unique potentials (genfmt, paths) 11347 parameter (nfrx = nphx) !max number of free atom types 11348 parameter (novrx = 8) !max number of overlap shells 11349 parameter (natx = 250) !max number of atoms in problem 11350 parameter (ltot = 24) !max number of ang mom (arrays 1:ltot+1) 11351 parameter (nrptx = 250) !Loucks r grid used through overlap 11352 parameter (nex = 100) !Number of energy points genfmt, etc. 11353 11354 parameter (lamtot=15) !Max number of distinct lambda's for genfmt 11355 !15 handles iord 2 and exact ss 11356 parameter (mtot=4, ntot=2) !vary mmax and nmax independently 11357 parameter (legtot=9) !matches path finder, used in GENFMT 11358 parameter (npatx = 8) !max number of path atoms, used in path 11359 !finder, NOT in genfmt 11360 11361 common /atoms/ rat(3,0:natx), ipot(0:natx), ilb(0:natx) 11362 dimension ipat(npatx+1), rx(npatx), ry(npatx), rz(npatx) 11363 dimension ipat0(npatx+1), rx0(npatx), ry0(npatx), rz0(npatx) 11364 11365 double precision dhash, dhash0 11366 11367c Time reverses path if time reversing it will put it 11368c in standard order. Standard order is defined by min hash 11369c number, using path hash algorithm developed for the path 11370c degeneracy checker. See subroutine phash for details. 11371c Symmetrical paths are, of course, always standard ordered. 11372c Also returns hash number for standard ordered path. 11373 11374c Use suffix 0 for (') in variable names 11375 11376c If no time-reversal standard ordering needed, make hash number 11377c and return. No timrev needed if 2 leg path (symmetrical). 11378 nleg = npat + 1 11379 ipat(nleg) = 0 11380 do 10 i = 1, npatx 11381 rx(i) = 0.0d0 11382 ry(i) = 0.0d0 11383 rz(i) = 0.0d0 11384 rx0(i) = 0.0d0 11385 ry0(i) = 0.0d0 11386 rz0(i) = 0.0d0 11387 10 continue 11388 call mpprmp(npat, ipat, rx, ry, rz) 11389 call phash (npat, ipat, rx, ry, rz, dhash) 11390 11391 if (npat .le. 1) then 11392 return 11393 endif 11394 11395c Make time reversed path 11396 11397 ipat0(nleg) = ipat(nleg) 11398 do 210 i = 1, npat 11399 ipat0(i) = ipat(nleg-i) 11400 210 continue 11401 call mpprmp(npat, ipat0, rx0, ry0, rz0) 11402 call phash (npat, ipat0, rx0, ry0, rz0, dhash0) 11403 11404c Do the comparison using hash numbers 11405c Want representation with smallest hash number 11406 if (dhash0 .lt. dhash) then 11407c time reversed representation is smaller, so return 11408c that version of the path 11409 dhash = dhash0 11410 do 300 i = 1, npat 11411 ipat(i) = ipat0(i) 11412 rx(i) = rx0(i) 11413 ry(i) = ry0(i) 11414 rz(i) = rz0(i) 11415 300 continue 11416 endif 11417 11418 return 11419 end 11420 subroutine totale (dval) 11421 implicit double precision (a-h,o-z) 11422 save 11423 common /print/ iprint 11424 common /dira/ dv(251), dr(251), dp(251), dq(251), dpas, tets, 11425 1 z, nstop, nes, np, nuc 11426 common /deux/ dvn(251), dvf(251), d(251), dc(251), dgc(251,30), 11427 1 dpc(251,30) 11428 dc(1)=1.0d0 11429 do 10 i=1,np 11430 10 dp(i)=d(i)/dr(i) 11431 if (nuc.le.0) go to 30 11432 do 20 i=1,nuc 11433 20 dp(i)=d(i)*(3.0d0-dr(i)*dr(i)/(dr(nuc)*dr(nuc)))/(dr(nuc)+dr(nuc)) 11434 dc(1)=4.0d0 11435 30 call somm (dr,dp,dq,dpas,dc(1),0,np) 11436 dc(1)=-z*dc(1) 11437 do 40 i=1,np 11438 dp(i)=d(i)*dvf(i) 11439 dvn(i)=d(i)*dvn(i) 11440 40 d(i)=d(i)*exchee(d(i),dr(i)) 11441 dc(2)=2.0d0 11442 dc(3)=1.0d0 11443 dc(5)=2.0d0 11444 if (nuc.ne.0) dc(3)=4.0d0 11445 call somm (dr,dp,dq,dpas,dc(3),0,np) 11446 call somm (dr,dvn,dq,dpas,dc(5),0,np) 11447 call somm (dr,d,dq,dpas,dc(2),0,np) 11448 dc(4)=dval-dc(3) 11449 dval=dval-0.50d0*dc(5)-dc(2) 11450 dc(2)=dc(3)-dc(1)-dc(5)-dc(2) 11451 dc(3)=0.50d0*dc(5) 11452 if (iprint .ge. 5) write(16,50) dval,dc(4),dc(3),dc(2),dc(1) 11453 50 format (1h0,5x,'et=',1pe14.7,5x,'ec=',1pe14.7,5x,'ee=',1pe14.7,5x, 11454 1 'ex=',1pe14.7,5x,'en=',1pe14.7) 11455 return 11456 end 11457 subroutine feff_trap (x, y, n, sum) 11458 implicit double precision (a-h, o-z) 11459 11460c Trapeziodal integration of y(x), result in sum 11461 11462 dimension x(n), y(n) 11463 11464 sum = y(1) * (x(2) - x(1)) 11465 do 10 i = 2, n-1 11466 sum = sum + y(i) * (x(i+1) - x(i-1)) 11467 10 continue 11468 sum = sum + y(n) * (x(n) - x(n-1)) 11469 sum = sum/2 11470 11471 return 11472 end 11473 subroutine wphase (nph, em, eref, lmax, ne, ph) 11474 11475c Writes phase data to file PHASExx.DAT for each shell 11476 11477 implicit double precision (a-h, o-z) 11478 11479 character*72 header 11480 common /header_common/ header 11481 11482 11483 parameter (nphx = 7) !max number of unique potentials (potph) 11484 parameter (npotx = nphx) !max number of unique potentials (genfmt, paths) 11485 parameter (nfrx = nphx) !max number of free atom types 11486 parameter (novrx = 8) !max number of overlap shells 11487 parameter (natx = 250) !max number of atoms in problem 11488 parameter (ltot = 24) !max number of ang mom (arrays 1:ltot+1) 11489 parameter (nrptx = 250) !Loucks r grid used through overlap 11490 parameter (nex = 100) !Number of energy points genfmt, etc. 11491 11492 parameter (lamtot=15) !Max number of distinct lambda's for genfmt 11493 !15 handles iord 2 and exact ss 11494 parameter (mtot=4, ntot=2) !vary mmax and nmax independently 11495 parameter (legtot=9) !matches path finder, used in GENFMT 11496 parameter (npatx = 8) !max number of path atoms, used in path 11497 !finder, NOT in genfmt 11498 11499 11500 complex*16 eref(nex) 11501 complex*16 ph(nex,ltot+1,0:nphx) 11502 dimension em(nex) 11503 dimension lmax(0:nphx) 11504 character*30 fname 11505 11506c Dump phase data, eref and complex phase for each shell 11507 do 260 iph = 0, nph 11508c prepare file for shell's phase data 11509 write(fname,242) iph 11510 242 format('phase', i2.2, '.dat') 11511 open (unit=1, file=trim(header)//fname, 11512 > status='unknown', iostat=ios) 11513 call chopen (ios, trim(header)//fname, 'wphase') 11514 call wthead (1) 11515c write out unique pot and lmax 11516 write(1,244) iph, lmax(iph), ne 11517 244 format (1x, 3i4, ' unique pot, lmax, ne ') 11518c for each energy 11519c ie, em, eref, p=sqrt(em-eref) 11520c ph array to ltot+1, 5 values per line 11521 do 250 ie = 1, ne 11522 xp = sqrt(em(ie) - eref(ie)) 11523 write(1,246) ie, em(ie), eref(ie), sqrt(em(ie)-eref(ie)) 11524 246 format (' ie energy re(eref)', 11525 1 ' im(eref)', 11526 2 ' re(p) im(p)', /, 11527 3 1x, i4, 1p, 5e14.6) 11528 write(1,248) (ph(ie,ll,iph), ll=1,lmax(iph)+1) 11529 248 format (1x, 1p, 4e14.6) 11530 250 continue 11531 close(unit=1) 11532 260 continue 11533 11534 return 11535 end 11536 subroutine wpot (nph, edens, ifrph, imt, inrm, 11537 1 rho, vclap, vcoul, vtot) 11538 11539c Writes potentials to file name POTxx.DAT for each unique pot. 11540 11541 implicit double precision (a-h, o-z) 11542 11543 character*72 header 11544 common /header_common/ header 11545 11546 11547 parameter (pi = 3.1415926535897932384626433d0) 11548 parameter (one = 1, zero = 0) 11549 parameter (third = 1.0d0/3.0d0) 11550 parameter (raddeg = 180.0d0 / pi) 11551 complex*16 coni 11552 parameter (coni = (0.0d0,1.0d0)) 11553c kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37 11554 parameter (fa = 1.919158292677512811d0) 11555 11556 parameter (bohr = 0.529177249d0, ryd = 13.605698d0) 11557 parameter (alpinv = 137.03598956d0) 11558c fine structure alpha 11559 parameter (alphfs = 1.0d0 / alpinv) 11560c speed of light in louck's units (rydbergs?) 11561 parameter (clight = 2 * alpinv) 11562 11563 11564 parameter (nphx = 7) !max number of unique potentials (potph) 11565 parameter (npotx = nphx) !max number of unique potentials (genfmt, paths) 11566 parameter (nfrx = nphx) !max number of free atom types 11567 parameter (novrx = 8) !max number of overlap shells 11568 parameter (natx = 250) !max number of atoms in problem 11569 parameter (ltot = 24) !max number of ang mom (arrays 1:ltot+1) 11570 parameter (nrptx = 250) !Loucks r grid used through overlap 11571 parameter (nex = 100) !Number of energy points genfmt, etc. 11572 11573 parameter (lamtot=15) !Max number of distinct lambda's for genfmt 11574 !15 handles iord 2 and exact ss 11575 parameter (mtot=4, ntot=2) !vary mmax and nmax independently 11576 parameter (legtot=9) !matches path finder, used in GENFMT 11577 parameter (npatx = 8) !max number of path atoms, used in path 11578 !finder, NOT in genfmt 11579 11580 11581 dimension ifrph(0:nphx) 11582 dimension rho(251,0:nfrx) 11583 dimension vcoul(251,0:nfrx) 11584 dimension edens(nrptx,0:nphx) 11585 dimension vclap(nrptx,0:nphx) 11586 dimension vtot (nrptx,0:nphx) 11587 dimension imt(0:nphx) 11588 dimension inrm(0:nphx) 11589 11590 character*30 fname 11591 11592c note units -- 11593c potentials in rydbergs, so that v * 13.6 -> eV 11594c density in #/(bohr)**3, so rho * e / (.529)**3 -> e/(Ang)**3 11595 11596 do 180 iph = 0, nph 11597 ifr = ifrph(iph) 11598c prepare file for unique potential data 11599 write(fname,172) iph 11600 172 format('pot', i2.2, '.dat') 11601 open (unit=1, file=trim(header)//fname, 11602 > status='unknown', iostat=ios) 11603 call chopen (ios, trim(header)//fname, 'wpot') 11604 call wthead(1) 11605 write(1,173) iph, imt(iph), inrm(iph) 11606 173 format (1x, 3i4, ' Unique potential, I_mt, I_norman.', 11607 1 ' Following data in atomic units.') 11608 write(1,*) ' ifr ', ifr 11609 write(1,174) 11610 174 format (' i r vcoul rho', 11611 1 ' ovrlp vcoul ovrlp vtot ovrlp rho') 11612 do 178 i = 1, nrptx 11613 write(1,176) i, rr(i), vcoul(i,ifr), rho(i,ifr)/(4*pi), 11614 1 vclap(i,iph), vtot(i,iph), edens(i,iph)/(4*pi) 11615 176 format (1x, i3, 1p, 6e12.4) 11616 178 continue 11617 close(unit=1) 11618 180 continue 11619 11620 return 11621 end 11622 subroutine xcpot (iph, ie, nr, index, ifirst, jri, 11623 1 em, xmu, vi0, rs0, gamach, 11624 2 vr, densty, 11625 3 eref, v, 11626 4 vxcrmu, vxcimu) 11627 11628 implicit double precision (a-h, o-z) 11629 11630 character*72 header 11631 common /header_common/ header 11632 11633 11634c INPUT 11635c iph, ie used only for debug and labels. 11636c nr number of points in current Loucks r-grid 11637c index 0 Hedin-Lunqvist + const real & imag part 11638c 1 Dirac-Hara + const real & imag part 11639c 2 ground state + const real & imag part 11640c 3 Dirac-Hara + HL imag part + const real & imag part 11641c 4 See rdinp for comment 11642c ifirst first entry flag, set to zero before first call for 11643c each unique potential, see vxcrmu and vxcimu below 11644c jri index of first interstitial point in current 11645c Loucks r grid 11646c em current energy grid point 11647c xmu fermi level 11648c vi0 const imag part to subtract from potential 11649c rs0 user input density cutoff, index=4 only 11650c gamach core hole lifetime 11651c vr(nr) total potential (coulomb and gs exchange corr) 11652c densty(nr) electron density 11653c 11654c OUTPUT 11655c eref complex energy reference for current energy 11656c v(nr) complex potential including energy dep xc 11657c 11658c WORKSPACE 11659c vxcrmu and vxcimu are calculated only on first entry for a 11660c particular unique potential, re-used on subsequent entries. 11661c vxcrmu(nr) real part of xc at fermi level 11662c vxcimu(nr) imag part of xc at fermi level 11663c 11664c This subroutine uses atomic (hartree) units for energy, 11665c phase uses rydbergs. All inputs to and outputs from xcpot are 11666c in rydbergs. (Factor of 2 to convert from one to the other.) 11667 11668 11669 11670 parameter (pi = 3.1415926535897932384626433d0) 11671 parameter (one = 1, zero = 0) 11672 parameter (third = 1.0d0/3.0d0) 11673 parameter (raddeg = 180.0d0 / pi) 11674 complex*16 coni 11675 parameter (coni = (0.0d0,1.0d0)) 11676c kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37 11677 parameter (fa = 1.919158292677512811d0) 11678 11679 parameter (bohr = 0.529177249d0, ryd = 13.605698d0) 11680 parameter (alpinv = 137.03598956d0) 11681c fine structure alpha 11682 parameter (alphfs = 1.0d0 / alpinv) 11683c speed of light in louck's units (rydbergs?) 11684 parameter (clight = 2 * alpinv) 11685 11686 11687 parameter (nphx = 7) !max number of unique potentials (potph) 11688 parameter (npotx = nphx) !max number of unique potentials (genfmt, paths) 11689 parameter (nfrx = nphx) !max number of free atom types 11690 parameter (novrx = 8) !max number of overlap shells 11691 parameter (natx = 250) !max number of atoms in problem 11692 parameter (ltot = 24) !max number of ang mom (arrays 1:ltot+1) 11693 parameter (nrptx = 250) !Loucks r grid used through overlap 11694 parameter (nex = 100) !Number of energy points genfmt, etc. 11695 11696 parameter (lamtot=15) !Max number of distinct lambda's for genfmt 11697 !15 handles iord 2 and exact ss 11698 parameter (mtot=4, ntot=2) !vary mmax and nmax independently 11699 parameter (legtot=9) !matches path finder, used in GENFMT 11700 parameter (npatx = 8) !max number of path atoms, used in path 11701 !finder, NOT in genfmt 11702 11703 11704 dimension vr(nr), densty(nr) 11705 complex*16 eref, v(nr) 11706 dimension vxcrmu(nr), vxcimu(nr) 11707 11708 complex*16 delta 11709 11710c First calculate vxc to correct the local momentum dispersion 11711c relation, delta = vxc(e,k) - vxc(mu,k), and 11712c p^2 = k^2 -mu + kf^2 - delta. 11713c In jr theory, v(e,r) = vcoul(r) + vxc(e,r) = 11714c = vcoul(r) + vxcgs(r) + delta(e,r). 11715 11716 if (index .eq. 2) then 11717c Ground state exchange, no self energy calculation 11718 do 10 i = 1, jri 11719 v(i) = vr(i) 11720 10 continue 11721 else 11722c Add the self energy correction 11723 do 20 i = 1, jri 11724 rs = (3 / (4*pi*densty(i))) ** third 11725c xf = 1.9191.../rs 11726 xf = fa / rs 11727 11728c xk2 is the local momentum squared, p^2 = k^2 - mu + kf^2, 11729c k^2 represents energy measured from vacuum. 11730c See formula 2.15 in Lee and Beni's paper with the last 2 11731c terms neglected. (complete reference?) 11732 xk2 = em + xf**2 - xmu 11733 11734 if (xk2 .lt. 0) then 11735 write(77,*) 'i, jri' 11736 write(77,*) i, jri 11737 write(77,*) 'rs, densty(i)' 11738 write(77,*) rs, densty(i) 11739 write(77,*) 'xf, fa' 11740 write(77,*) xf, fa 11741 write(77,*) 'em, xmu, xk2' 11742 write(77,*) em, xmu, xk2 11743 stop 'XCPOT-1' 11744 endif 11745 xk = sqrt(xk2) 11746 if (index .eq. 0) call rhl(rs,xk,vxcr,vxci) 11747 if (index .eq. 1) call edp(rs,xk,vi0,vxcr,vxci) 11748 if (index .eq. 3) then 11749 call edp(rs,xk,vi0,vxcr,vxci) 11750 call imhl(rs,xk,vxci,icusp) 11751 elseif (index .eq. 4) then 11752 rstmp = (1.0d0/rs**3 - 1.0d0/rs0**3) ** (-third) 11753 call edp(rstmp,xk,vi0,vxcr1,vxci1) 11754 call rhl(rs0,xk,vxcr2,vxci2) 11755 vxcr = vxcr1 + vxcr2 11756 vxci = vxci1 + vxci2 11757 endif 11758 11759 if (ifirst .eq. 0) then 11760c vxc_mu indep of energy, calc only once 11761c Calculate vxc at fermi level e = mu, j.m. 1/12/89 11762 xk = xf * 1.00001d0 11763 if (index .eq. 0) call rhl(rs,xk,vxcrmu(i),vxcimu(i)) 11764 if (index .eq. 1) call edp(rs,xk,vi0,vxcrmu(i),vxcimu(i)) 11765 if (index .eq. 3) then 11766 call edp(rs,xk,vi0,vxcrmu(i),vxcimu(i)) 11767 call imhl (rs,xk,vxcimu(i),icusp) 11768 elseif (index .eq. 4) then 11769 rstmp = (1.0d0/rs**3 - 1.0d0/rs0**3) ** (-third) 11770 call edp(rstmp,xk,vi0,vxcr1,vxci1) 11771 call rhl(rs0,xk,vxcr2,vxci2) 11772 vxcrmu(i) = vxcr1 + vxcr2 11773 vxcimu(i) = vxci1 + vxci2 11774 endif 11775 endif 11776 11777 delta = dcmplx (vxcr-vxcrmu(i), vxci-vxcimu(i)) 11778 11779c Correct local momentum according to the formula 11780c p^2 = k^2 - mu + kf^2 - delta. Note that imag part 11781c of delta is ignored, since xk2 is a real quantity. 11782 xk2 = em + xf**2 - xmu - delta 11783 if (xk2 .lt. 0) then 11784 write(77,*) xk2, i, ie, iph, ' xk2, i, ie, iph' 11785 write(77,*) 'em, xf**2, xmu, delta' 11786 write(77,*) em, xf**2, xmu, delta 11787 stop 'XCPOT-2' 11788 endif 11789 xk = sqrt (xk2) 11790 11791c recalculate vxc(e,k) and vxc(mu,k) with the corrected 11792c local momentum 11793 if (index .eq. 0) call rhl(rs,xk,vxcr, vxci) 11794 if (index .eq. 1) call edp(rs,xk,vi0,vxcr,vxci) 11795 if (index .eq. 3) then 11796 call edp(rs,xk,vi0,vxcr,vxci) 11797 call imhl (rs,xk,vxci,icusp) 11798 elseif (index .eq. 4) then 11799 rstmp = (1.0d0/rs**3 - 1.0d0/rs0**3) ** (-third) 11800 call edp(rstmp,xk,vi0,vxcr1,vxci1) 11801 call rhl(rs0,xk,vxcr2,vxci2) 11802 vxcr = vxcr1 + vxcr2 11803 vxci = vxci1 + vxci2 11804 endif 11805 11806c delta corrected calculated with new local momentum 11807 delta = dcmplx (vxcr-vxcrmu(i), vxci-vxcimu(i)) 11808 11809c Note multiplication by 2 in the exchange correlation part to 11810c to convert it to rydberg units. 11811 19 continue 11812 v(i) = vr(i) + 2*delta 11813 11814 20 continue 11815 endif 11816 11817c Reference the potential with respect to mt potential, ie, 11818c first interstitial point. v(jri) = 0 11819 11820c Note that the reference does not contain the core hole lifetime 11821c since the total atomic potential should have it. However in the 11822c perturbation deltav = v - vmt it cancels out. 11823c ( deltav = vat - igamma - (vatmt-igamma) ). 11824 11825 eref = v(jri) 11826 do 11 i = 1, jri 11827 v(i) = v(i) - eref 11828 11 continue 11829 11830c igamma added to the reference so that k^2 = E - Eref, where 11831c Eref = Vat(mt) - igamma / 2 11832 eref = eref - coni * gamach / 2 11833 11834c Add const imag part 11835 eref = eref - coni * vi0 11836 11837 ifirst = 1 11838 return 11839 end 11840 double precision function xx (j) 11841 implicit double precision (a-h, o-z) 11842c x grid point at index j, x = log(r), r=exp(x) 11843 parameter (delta = 0.050000000000000d0) 11844 parameter (c88 = 8.800000000000000d0) 11845c xx = -8.8 + (j-1)*0.05 11846 xx = -c88 + (j-1)*delta 11847 return 11848 end 11849 11850 double precision function rr(j) 11851 implicit double precision (a-h, o-z) 11852c r grid point at index j 11853 rr = exp (xx(j)) 11854 return 11855 end 11856 11857 integer function ii(r) 11858 implicit double precision (a-h, o-z) 11859c index of grid point immediately below postion r 11860 parameter (delta = 0.050000000000000d0) 11861 parameter (c88 = 8.800000000000000d0) 11862c ii = (log(r) + 8.8) / 0.05 + 1 11863 ii = (log(r) + c88) / delta + 1 11864 return 11865 end 11866 subroutine ykdir (ia,ib,nk1,nag) 11867 11868 implicit double precision (a-h,o-z) 11869 save 11870 common /atomco/ den(30), dq1(30), dfl(30), ws, nqn(30), nql(30), 11871 1 nk(30), nmax(30), nel(30), norb, norbco 11872 common /dira/ dv(251), dr(251), dp(251), dq(251), dpas, tets, 11873 1 z, nstop, nes, np, nuc 11874 common /deux/ dvn(251), dvf(251), d(251), dc(251), dgc(251,30), 11875 1 dpc(251,30) 11876 common /trois/ dpno(4,30), dqno(4,30) 11877 dimension dpn1(4) 11878 dpah=exp(dpas) 11879 dpyk=dpas/24.0d0 11880 id=min0(nmax(ia)+2,nmax(ib)+2,np) 11881 idm1=id-1 11882 if (nag.ne.0) go to 30 11883 do 10 i=1,id 11884 10 dq(i)=dr(i)*(dgc(i,ia)*dgc(i,ib)+dpc(i,ia)*dpc(i,ib)) 11885 do 20 i=1,4 11886 dpn1(i)=0.0d0 11887 do 20 j=1,i 11888 20 dpn1(i)=dpn1(i)+dpno(j,ia)*dpno(i+1-j,ib)+dqno(j,ia)*dqno(i+1-j,ib 11889 1 ) 11890 go to 60 11891 30 do 40 i=1,id 11892 40 dq(i)=dr(i)*dgc(i,ia)*dpc(i,ib) 11893 do 50 i=1,4 11894 dpn1(i)=0.0d0 11895 do 50 j=1,i 11896 50 dpn1(i)=dpn1(i)+dpno(j,ia)*dqno(i+1-j,ib) 11897 60 di=dfl(ia)+dfl(ib)+nk1 11898 dp(1)=0.0d0 11899 dp(2)=0.0d0 11900 do 70 i=1,4 11901 di=di+1.0d0 11902 dp(1)=dp(1)+(dr(1)**di)*dpn1(i)/di 11903 70 dp(2)=dp(2)+(dr(2)**di)*dpn1(i)/di 11904 dm=dpah**(-nk1) 11905 dim2=-dpyk*dm*dm 11906 dim1=13.0d0*dpyk*dm 11907 di=13.0d0*dpyk 11908 dip1=-dpyk/dm 11909 do 80 i=3,idm1 11910 80 dp(i)=dp(i-1)*dm+dim2*dq(i-2)+dip1*dq(i+1)+dim1*dq(i-1)+di*dq(i) 11911 dq(id-2)=dp(id-2) 11912 do 90 i=idm1,np 11913 90 dq(i)=dq(i-1)*dm 11914 i=nk1+nk1+1 11915 dm=dm/dpah 11916 dim2=i*dim2/(dpah*dpah) 11917 dim1=i*dim1/dpah 11918 di=i*di 11919 dip1=i*dip1*dpah 11920 i=id-3 11921 100 dq(i)=dq(i+1)*dm+dim2*dp(i+2)+dip1*dp(i-1)+dim1*dp(i+1)+di*dp(i) 11922 i=i-1 11923 if (i-1) 110,110,100 11924 110 dq(1)=dq(3)*dm*dm+8.0d0*((di*dp(1) 11925 > +4.0d0*dim1*dp(2))/13.0d0-dim2*dp(3)) 11926 return 11927 end 11928 11929 11930 subroutine feff6(header_in) 11931c EXAFS only lite version of FEFF6 11932c see LICENSE for copying details 11933 implicit double precision (a-h, o-z) 11934 character*(*) header_in 11935 11936 11937 character*12 vfeff, vpotph, vpaths, vgenfm, vff2ch 11938 common /vers/ vfeff, vpotph, vpaths, vgenfm, vff2ch 11939 11940 11941 parameter (nphx = 7) !max number of unique potentials (potph) 11942 parameter (npotx = nphx) !max number of unique potentials (genfmt, paths) 11943 parameter (nfrx = nphx) !max number of free atom types 11944 parameter (novrx = 8) !max number of overlap shells 11945 parameter (natx = 250) !max number of atoms in problem 11946 parameter (ltot = 24) !max number of ang mom (arrays 1:ltot+1) 11947 parameter (nrptx = 250) !Loucks r grid used through overlap 11948 parameter (nex = 100) !Number of energy points genfmt, etc. 11949 11950 parameter (lamtot=15) !Max number of distinct lambda's for genfmt 11951 !15 handles iord 2 and exact ss 11952 parameter (mtot=4, ntot=2) !vary mmax and nmax independently 11953 parameter (legtot=9) !matches path finder, used in GENFMT 11954 parameter (npatx = 8) !max number of path atoms, used in path 11955 !finder, NOT in genfmt 11956 11957 11958 parameter (pi = 3.1415926535897932384626433d0) 11959 parameter (one = 1, zero = 0) 11960 parameter (third = 1.0d0/3.0d0) 11961 parameter (raddeg = 180.0d0 / pi) 11962 complex*16 coni 11963 parameter (coni = (0.0d0,1.0d0)) 11964c kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37 11965 parameter (fa = 1.919158292677512811d0) 11966 11967 parameter (bohr = 0.529177249d0, ryd = 13.605698d0) 11968 parameter (alpinv = 137.03598956d0) 11969c fine structure alpha 11970 parameter (alphfs = 1.0d0 / alpinv) 11971c speed of light in louck's units (rydbergs?) 11972 parameter (clight = 2 * alpinv) 11973 11974 11975 parameter (ntitx = 10) 11976 character*79 title(ntitx) 11977 dimension ltit(ntitx) 11978 character*12 tmpstr 11979 character*30 fname 11980 11981c Following passed to pathfinder, which is single precision. 11982c Be careful to always declare these! 11983 parameter (necrit=9, nbeta=40) 11984 real*8 fbetac(-nbeta:nbeta,0:npotx,necrit), ckspc(necrit) 11985 real*8 fbeta(-nbeta:nbeta,0:npotx,nex), cksp(nex) 11986 real*8 rmax, critpw, pcritk, pcrith 11987 character*6 potlbl(0:npotx) 11988 11989 character*72 header 11990 common /header_common/ header 11991 11992 10 format (1x, a) 11993 11994 header = header_in 11995 11996 open (unit=77,file=trim(header)//'feff.stdout',status='unknown') 11997 11998 tmpstr = vfeff 11999 call triml (tmpstr) 12000 write(77,10) tmpstr 12001 call rdinp(mphase, mpath, mfeff, mchi, ms, 12002 1 ntitle, title, ltit, 12003 2 critcw, 12004 1 ipr2, ipr3, ipr4, 12005 1 s02, tk, thetad, sig2g, 12006 1 nlegxx, 12007 1 rmax, critpw, pcritk, pcrith, nncrit, 12008 2 icsig, iorder, vrcorr, vicorr, isporb) 12009 12010 do 20 i = 1, ntitle 12011 write(77,10) title(i)(1:ltit(i)) 12012 20 continue 12013 12014 if (mphase .eq. 1) then 12015 write(77,10) 'Calculating potentials and phases...' 12016 call potph (isporb) 12017 open (unit=1, file=trim(header)//'potph.dat', 12018 > status='old', iostat=ios) 12019 call chopen (ios, trim(header)//'potph.dat', 'feff') 12020 close (unit=1, status='delete') 12021 endif 12022 12023 if (ms.eq.1 .and. mpath.eq.1) then 12024 12025 write(77,10) 'Preparing plane wave scattering amplitudes...' 12026 call prcrit(ne, nncrit, ik0, cksp, fbeta, ckspc, 12027 1 fbetac, potlbl) 12028 12029c Dump out fbetac for central atom and first pot 12030 if (ipr2 .ge. 3 .and. ipr2.ne.5) then 12031 do 260 ipot = 0, 1 12032 do 250 ie = 1, nncrit 12033 write(fname,200) ie, ipot 12034 200 format ('fbeta', i1, 'p', i1, '.dat') 12035 open (unit=1, file=trim(header)//fname) 12036 write(1,210) ipot, ie, ckspc(ie) 12037 210 format ('# ipot, ie, ckspc(ie) ', 2i5, 1pe20.6, / 12038 1 '# angle(degrees), fbeta/|p|, fbeta') 12039 do 240 ibeta = -nbeta, nbeta 12040 cosb = .025 * ibeta 12041 if (cosb .gt. 1) cosb = 1 12042 if (cosb .lt. -1) cosb = -1 12043 angle = acos (cosb) 12044 write(1,230) angle*raddeg, 12045 1 fbetac(ibeta,ipot,ie)/ckspc(ie), 12046 2 fbetac(ibeta,ipot,ie) 12047 230 format (f10.4, 1p, 2e15.6) 12048 240 continue 12049 close (unit=1) 12050 250 continue 12051 260 continue 12052 endif 12053 12054 write(77,10) 'Searching for paths...' 12055 call paths(ckspc, fbetac, pcritk, pcrith, nncrit, 12056 1 rmax, nlegxx, ipotnn) 12057 12058 write(77,10) 'Eliminating path degeneracies...' 12059 call pathsd(ckspc, fbetac, ne, ik0, cksp, fbeta, 12060 1 critpw, ipotnn, ipr2, 12061 1 pcritk, pcrith, nncrit, potlbl) 12062 12063 if (ipr2 .lt. 2) then 12064 open (unit=1, file=trim(header)//'geom.dat', status='old') 12065 call chopen (ios, trim(header)//'geom.dat', 'feff') 12066 close (unit=1, status='delete') 12067 endif 12068 endif 12069 12070 if (mfeff .eq. 1) then 12071 write(77,10) 'Calculating EXAFS parameters...' 12072 call genfmt (ipr3, critcw, sig2g, iorder) 12073 endif 12074 12075 if (mchi .eq. 1) then 12076 write(77,10) 'Calculating chi...' 12077 call ff2chi (ipr4, critcw, s02, tk, thetad, icsig, 12078 1 vrcorr, vicorr) 12079 endif 12080 12081 write(77,500) 12082 500 format (1x, 'Feff done. Have a nice day.') 12083 12084 close(77) 12085 12086 return 12087 end 12088 12089 12090 character*2 function upperlower(string) 12091 implicit none 12092 character*2 string 12093 character*2 item 12094 character t1,t2 12095 integer uca,ucz,lca,lcz,shift 12096 uca = ichar('A') 12097 ucz = ichar('Z') 12098 lca = ichar('a') 12099 lcz = ichar('z') 12100 shift = lca - uca 12101 item = ' ' 12102 t1 = string(1:1) 12103 t2 = string(2:2) 12104 if ((ichar(t1).ge.lca).and.(ichar(t1).le.lcz)) 12105 > t1 = char(ichar(t1)-shift) 12106 if ((ichar(t2).ge.uca).and.(ichar(t2).le.ucz)) 12107 > t2 = char(ichar(t2)+shift) 12108 item(1:1) = t1 12109 item(2:2) = t2 12110 upperlower = item 12111 return 12112 end 12113 12114 12115 logical function str_compare(a,b) 12116 implicit none 12117 character*(*) a 12118 character*(*) b 12119 character t1,t2 12120 integer la,lb,uca,ucz,lca,i,shift 12121 str_compare = .false. 12122 la = len_trim(a) 12123 lb = len_trim(b) 12124 if (la.eq.lb) then 12125 uca = ichar('A') 12126 ucz = ichar('Z') 12127 lca = ichar('a') 12128 shift = lca-uca 12129 do i=1,la 12130 t1 = a(i:i) 12131 t2 = b(i:i) 12132 if ((ichar(t1).ge.uca).and.(ichar(t1).le.ucz)) 12133 > t1 = char(ichar(t1)+shift) 12134 if ((ichar(t2).ge.uca).and.(ichar(t2).le.ucz)) 12135 > t2 = char(ichar(t2)+shift) 12136 if (t1.ne.t2) return 12137 end do 12138 str_compare = .true. 12139 end if 12140 12141 return 12142 end 12143 12144 12145 12146 subroutine feff_codeversion(version) 12147 implicit none 12148 character*(*) version 12149 12150 character*12 vfeff, vpotph, vpaths, vgenfm, vff2ch 12151 common /vers/ vfeff, vpotph, vpaths, vgenfm, vff2ch 12152 12153 version = vfeff 12154 return 12155 end 12156 12157 12158 12159 subroutine feff_serial(dict_in,outtype,dict_out,nkf,kf,chi) 12160 implicit none 12161 character*(*) dict_in 12162 integer outtype 12163 character*(*) dict_out 12164 integer nkf 12165 real*8 kf(*),chi(*) 12166 12167 12168* **** local variables **** 12169 character*2 symbols(112) 12170 data symbols/ 12171 $ 'H ', 'He', 'Li', 'Be', 'B ', 'C ', 'N ', 'O ', 'F ', 'Ne', 12172 $ 'Na', 'Mg', 'Al', 'Si', 'P ', 'S ', 'Cl', 'Ar', 'K ', 'Ca', 12173 $ 'Sc', 'Ti', 'V ', 'Cr', 'Mn', 'Fe', 'Co', 'Ni', 'Cu', 'Zn', 12174 $ 'Ga', 'Ge', 'As', 'Se', 'Br', 'Kr', 'Rb', 'Sr', 'Y ', 'Zr', 12175 $ 'Nb', 'Mo', 'Tc', 'Ru', 'Rh', 'Pd', 'Ag', 'Cd', 'In', 'Sn', 12176 $ 'Sb', 'Te', 'I ', 'Xe', 'Cs', 'Ba', 'La', 'Ce', 'Pr', 'Nd', 12177 $ 'Pm', 'Sm', 'Eu', 'Gd', 'Tb', 'Dy', 'Ho', 'Er', 'Tm', 'Yb', 12178 $ 'Lu', 'Hf', 'Ta', 'W ', 'Re', 'Os', 'Ir', 'Pt', 'Au', 'Hg', 12179 $ 'Tl', 'Pb', 'Bi', 'Po', 'At', 'Rn', 'Fr', 'Ra', 'Ac', 'Th', 12180 $ 'Pa', 'U ', 'Np', 'Pu', 'Am', 'Cm', 'Bk', 'Cf', 'Es', 'Fm', 12181 $ 'Md', 'No', 'Lr', 'Rf', 'Db', 'Sg', 'Bh', 'Hs', 'Mt', 'Ds', 12182 $ 'Rg', 'Cn'/ 12183 12184 logical done,found 12185 character*100 buf 12186 character*80 header 12187 character*80 spectroscopy 12188 12189 integer nedge 12190 character*80 edge 12191 12192 integer nabsorber 12193 character*80 absorber 12194 character*2 item 12195 integer ncenter 12196 integer center(20) 12197 character*12 cnum 12198 12199 real*8 rmax 12200 12201 integer nkatm 12202 integer katm(1000) 12203 integer ipot(50),zkatm(50) 12204 integer nion 12205 character*30 cnum1 12206 real*8 x,y,z,dist,rion(3,1000) 12207 integer zi,zion(1000) 12208 12209 integer ind,ind0,ind1,ind2,ind3,ind4,ind4a,ind4b 12210 integer i,j,ii,ia,ip 12211 12212* **** external functions **** 12213 character*2 upperlower 12214 external upperlower 12215 logical str_compare 12216 external str_compare 12217 12218 12219c **** parse "scratch_dir": json item**** 12220 header = ' ' 12221 ind = index(dict_in,"""scratch_dir"":") 12222 if (ind.gt.0) then 12223 ind2 = ind+16 12224 ind3 = ind+14+index(dict_in(ind+16:),"""") 12225 header = dict_in(ind2:ind3) 12226 else 12227 header = ' ' 12228 end if 12229 12230 12231c **** parse "spectroscopy": json item **** 12232 spectroscopy = ' ' 12233 ind = index(dict_in,"""spectroscopy"":") 12234 if (ind.gt.0) then 12235 ind2 = ind+17 12236 ind3 = ind+16+index(dict_in(ind+18:),"""") 12237 spectroscopy = dict_in(ind2:ind3) 12238 else 12239 spectroscopy = "exafs" 12240 end if 12241 12242 12243c **** parse "edge": json item **** 12244 edge = ' ' 12245 ind = index(dict_in,"""edge"":") 12246 if (ind.gt.0) then 12247 ind2 = ind+9 12248 ind3 = ind+7+index(dict_in(ind+9:),"""") 12249 edge = dict_in(ind2:ind3) 12250 else 12251 edge = "k" 12252 end if 12253 12254c **** parse "rmax": json item **** 12255 ind = index(dict_in,"""rmax"":") 12256 if (ind.gt.0) then 12257 ind1 = ind + 7 12258 ind4a = index(dict_in(ind1:),",") 12259 ind4b = index(dict_in(ind1:),"}") 12260 if ((ind4a.lt.ind4b).and.(ind4a.gt.0)) then 12261 ind2 = ind1+ind4a 12262 else 12263 ind2 = ind1+ind4b 12264 end if 12265 cnum1 = trim(adjustl(dict_in(ind1:ind2-2))) 12266 read(cnum1,*) rmax 12267 else 12268 rmax = 10.0d0 12269 end if 12270 12271 12272c **** parse "absorber": json item **** 12273 absorber = repeat(' ',80) 12274 nabsorber = 0 12275 ind0 = index(dict_in,"""absorber"":") 12276 if (ind0.gt.0) then 12277 ind1 = ind0 + index(dict_in(ind0:),"[") 12278 done = .false. 12279 do while (.not.done) 12280 ind2 = ind1 + index(dict_in(ind1:),"""") 12281 ind3 = ind2 + index(dict_in(ind2:),"""")-2 12282 item = ' ' 12283 item = dict_in(ind2:ind3) 12284 absorber(1+2*nabsorber:2+2*nabsorber) = item 12285 nabsorber = nabsorber + 1 12286 12287 ind4a = index(dict_in(ind3:),",") 12288 ind4b = index(dict_in(ind3:),"]") 12289 if ((ind4a.lt.ind4b).and.(ind4a.gt.0)) then 12290 ind4a = ind4a + ind3 12291 ind1 = ind4a 12292 else 12293 ind4b = ind4b + ind3 12294 ind1 = ind4b 12295 done = .true. 12296 end if 12297 end do 12298 end if 12299 12300 12301c **** parse "center": json item **** 12302 ncenter = 0 12303 ind0 = index(dict_in,"""center"":") 12304 if (ind0.gt.0) then 12305 ind1 = ind0 + index(dict_in(ind0:),"[") 12306 done = .false. 12307 do while (.not.done) 12308 ind4a = index(dict_in(ind1:),",") 12309 ind4b = index(dict_in(ind1:),"]") 12310 if ((ind4a.lt.ind4b).and.(ind4a.gt.0)) then 12311 ind4a = ind4a + ind1 12312 cnum = trim(adjustl(dict_in(ind1:ind4a-2))) 12313 ind1 = ind4a 12314 else 12315 ind4b = ind4b + ind1 12316 cnum = trim(adjustl(dict_in(ind1:ind4b-2))) 12317 ind1 = ind4b 12318 done = .true. 12319 end if 12320 ncenter = ncenter + 1 12321 read(cnum,'(I12)') center(ncenter) 12322 end do 12323 end if 12324 if (ncenter.lt.1) then 12325 ncenter = 1 12326 center(1) = 1 12327 end if 12328 12329c **** parse "geometry": json item **** 12330 nion = 0 12331 ind0 = index(dict_in,"""geometry"":") 12332 if (ind0.gt.0) then 12333 ind0 = ind0 + index(dict_in(ind0:),"[") 12334 done = .false. 12335 do while (.not.done) 12336 ind0 = ind0 + index(dict_in(ind0:),"[") 12337 12338 ind1 = ind0 + index(dict_in(ind0:),",") 12339 ind2 = ind1 + index(dict_in(ind1:),",") 12340 ind3 = ind2 + index(dict_in(ind2:),",") 12341 ind4 = ind3 + index(dict_in(ind3:),"]") 12342 12343 item = ' ' 12344 item = dict_in(ind0+1:ind1-3) 12345 item = upperlower(item) 12346 zi = -1 12347 do ii=1,112 12348 if (item.eq.symbols(ii)) zi = ii 12349 end do 12350 12351 cnum1 = trim(adjustl(dict_in(ind0:ind1-2))) 12352 12353 cnum1 = trim(adjustl(dict_in(ind1:ind2-2))) 12354 read(cnum1,*) x 12355 12356 cnum1 = trim(adjustl(dict_in(ind2:ind3-2))) 12357 read(cnum1,*) y 12358 12359 cnum1 = trim(adjustl(dict_in(ind3:ind4-2))) 12360 read(cnum1,*) z 12361 12362 12363 ind4a = index(dict_in(ind4:),",") 12364 ind4b = index(dict_in(ind4:),"]") 12365 if ((ind4a.lt.ind4b).and.(ind4a.gt.0)) then 12366 ind0 = ind4+ind4a 12367 else 12368 ind0 = ind4+ind4b 12369 done = .true. 12370 end if 12371 nion = nion + 1 12372 rion(1,nion) = x 12373 rion(2,nion) = y 12374 rion(3,nion) = z 12375 zion(nion) = zi 12376 end do 12377 end if 12378 12379 nkatm = 0 12380 do ii=1,nion 12381 found = .false. 12382 do j=1,nkatm 12383 if (zion(ii).eq.zkatm(j)) then 12384 found = .true. 12385 ia = j 12386 end if 12387 end do 12388 if (found) then 12389 katm(ii) = ia 12390 else 12391 nkatm = nkatm + 1 12392 zkatm(nkatm) = zion(ii) 12393 katm(ii) = nkatm 12394 end if 12395 end do 12396 12397 do ia=1,nkatm 12398 ipot(ia) = -1 12399 end do 12400 ip = 1 12401 do ii=1,nion 12402 if (ii.ne.center(1)) then 12403 ia = katm(ii) 12404 if (ipot(ia).eq.-1) then 12405 ipot(ia) = ip 12406 ip = ip + 1 12407 end if 12408 end if 12409 end do 12410 12411 nedge = 1 12412 if (str_compare(edge,"k")) nedge = 1 12413 if (str_compare(edge,"l1")) nedge = 2 12414 if (str_compare(edge,"l2")) nedge = 3 12415 if (str_compare(edge,"l3")) nedge = 4 12416 if (str_compare(edge,"m1")) nedge = 5 12417 if (str_compare(edge,"m2")) nedge = 6 12418 if (str_compare(edge,"m3")) nedge = 7 12419 if (str_compare(edge,"m4")) nedge = 8 12420 if (str_compare(edge,"m5")) nedge = 9 12421 12422 12423 open (unit=76,file=trim(header)//'feff.inp',status='unknown') 12424 write(76,'("TITLE ...")') 12425 write(76,*) 12426 write(76,'("HOLE ",I2," 1.0")') nedge 12427 write(76,*) 12428 write(76,*) "* mphase,mpath,mfeff,mchi" 12429 write(76,'("CONTROL 1 1 1 1")') 12430 write(76,'("PRINT 1 0 0 0")') 12431 write(76,*) 12432 write(76,'("RMAX ",F10.3)') rmax 12433 write(76,*) 12434 if (nkatm.gt.0) then 12435 write(76,'("POTENTIALS")') 12436 write(76,*) "* ipot Z element" 12437 write(76,100) 0,zion(center(1)),symbols(zion(center(1))) 12438 do ia=1,nkatm 12439 if (ipot(ia).ne.-1) 12440 > write(76,100) ipot(ia), zkatm(ia),symbols(zkatm(ia)) 12441 end do 12442 100 format(I8,I8,9x,A2) 12443 end if 12444 if (nion.gt.0) then 12445 write(76,*) 12446 write(76,'("ATOMS")') 12447 write(76,200) 'x','y','z','ipot','tag','distance' 12448 do ii=1,nion 12449 ia = katm(ii) 12450 ip = ipot(ia) 12451 if (ii.eq.center(1)) ip = 0 12452 x = rion(1,ii)-rion(1,center(1)) 12453 y = rion(2,ii)-rion(2,center(1)) 12454 z = rion(3,ii)-rion(3,center(1)) 12455 dist = sqrt(x**2 + y**2 + z**2) 12456 write(76,201) rion(1,ii),rion(2,ii),rion(3,ii), 12457 > ip,symbols(zion(ii)),dist 12458 end do 12459 200 format('*',A19,2A20,A5,2x,A4,A20) 12460 201 format(3E20.9,I5,2x,A4,E20.9) 12461 end if 12462 close(76) 12463 12464 !*** call feff6 **** 12465 call feff6(header) 12466 12467* **** just cat "chi.dat" to dict_out **** 12468 if (outtype.eq.1) then 12469 dict_out = " " 12470 open(15,file=trim(header)//'chi.dat') 12471 do 12472 read(15,'(A)',end=311,err=311) buf 12473 !dict_out = trim(dict_out)//trim(buf)//NEW_LINE('A') 12474 end do 12475 311 close(15) 12476 else 12477 nkf = 0 12478 open(15,file=trim(header)//'chi.dat') 12479 do 12480 read(15,'(f10.4,3e13.6)',end=411,err=410) x,y,z,dist 12481 nkf = nkf+1 12482 kf(nkf) = x 12483 chi(nkf) = y 12484 410 continue 12485 end do 12486 411 close(15) 12487 end if 12488 12489 return 12490 end 12491 12492 12493 12494 12495 subroutine feff_fortran(header,spectroscopy,absorption,edge, 12496 > center,rmax,e0,s0, 12497 > nkatm,katm,zkatm,nion,zion,rion, 12498 > nohydrogen, 12499 > nkf,kf,chi) 12500 implicit none 12501 character*(*) header 12502 character*(*) spectroscopy 12503 character*(*) absorption 12504 character*(*) edge 12505 integer center 12506 real*8 rmax,e0,s0 12507 integer nkatm 12508 integer katm(*) 12509 integer zkatm(*) 12510 integer nion 12511 integer zion(*) 12512 real*8 rion(3,*) 12513 logical nohydrogen 12514 12515 integer nkf 12516 real*8 kf(*),chi(*) 12517 12518* **** local variables **** 12519 real*8 autoang 12520 parameter (autoang = 0.529177d0) 12521 12522 character*2 symbols(112) 12523 data symbols/ 12524 $ 'H ', 'He', 'Li', 'Be', 'B ', 'C ', 'N ', 'O ', 'F ', 'Ne', 12525 $ 'Na', 'Mg', 'Al', 'Si', 'P ', 'S ', 'Cl', 'Ar', 'K ', 'Ca', 12526 $ 'Sc', 'Ti', 'V ', 'Cr', 'Mn', 'Fe', 'Co', 'Ni', 'Cu', 'Zn', 12527 $ 'Ga', 'Ge', 'As', 'Se', 'Br', 'Kr', 'Rb', 'Sr', 'Y ', 'Zr', 12528 $ 'Nb', 'Mo', 'Tc', 'Ru', 'Rh', 'Pd', 'Ag', 'Cd', 'In', 'Sn', 12529 $ 'Sb', 'Te', 'I ', 'Xe', 'Cs', 'Ba', 'La', 'Ce', 'Pr', 'Nd', 12530 $ 'Pm', 'Sm', 'Eu', 'Gd', 'Tb', 'Dy', 'Ho', 'Er', 'Tm', 'Yb', 12531 $ 'Lu', 'Hf', 'Ta', 'W ', 'Re', 'Os', 'Ir', 'Pt', 'Au', 'Hg', 12532 $ 'Tl', 'Pb', 'Bi', 'Po', 'At', 'Rn', 'Fr', 'Ra', 'Ac', 'Th', 12533 $ 'Pa', 'U ', 'Np', 'Pu', 'Am', 'Cm', 'Bk', 'Cf', 'Es', 'Fm', 12534 $ 'Md', 'No', 'Lr', 'Rf', 'Db', 'Sg', 'Bh', 'Hs', 'Mt', 'Ds', 12535 $ 'Rg', 'Cn'/ 12536 12537 logical done,found 12538 integer nedge 12539 integer ipot(50) 12540 real*8 x,y,z,dist 12541 integer i,j,ii,ia,ip 12542 12543* **** external functions **** 12544 character*2 upperlower 12545 external upperlower 12546 logical str_compare 12547 external str_compare 12548 12549 12550 if (rmax.le.0.0d0) rmax = 10.0d0 12551 if (center.lt.1) center = 1 12552 12553 if (str_compare(edge,"k")) nedge = 1 12554 if (str_compare(edge,"l1")) nedge = 2 12555 if (str_compare(edge,"l2")) nedge = 3 12556 if (str_compare(edge,"l3")) nedge = 4 12557 if (str_compare(edge,"m1")) nedge = 5 12558 if (str_compare(edge,"m2")) nedge = 6 12559 if (str_compare(edge,"m3")) nedge = 7 12560 if (str_compare(edge,"m4")) nedge = 8 12561 if (str_compare(edge,"m5")) nedge = 9 12562 12563 12564 do ia=1,nkatm 12565 ipot(ia) = -1 12566 end do 12567 12568 if (nohydrogen) then 12569 do ia=1,nkatm 12570 if (zkatm(ia).eq.1) ipot(ia) = -2 12571 end do 12572 end if 12573 12574 ip = 1 12575 do ii=1,nion 12576 if (ii.ne.center) then 12577 ia = katm(ii) 12578 if (ipot(ia).eq.-1) then 12579 ipot(ia) = ip 12580 ip = ip + 1 12581 end if 12582 end if 12583 end do 12584 12585 open (unit=76,file=trim(header)//'feff.inp',status='unknown') 12586 write(76,'("TITLE ...")') 12587 write(76,*) 12588 write(76,'("HOLE ",I2,F10.3)') nedge,s0 12589 write(76,*) 12590 write(76,*) "* mphase,mpath,mfeff,mchi" 12591 write(76,'("CONTROL 1 1 1 1")') 12592 write(76,'("PRINT 1 0 0 0")') 12593 write(76,*) 12594 write(76,'("RMAX ",F10.3)') rmax 12595 if (dabs(e0).gt.1.0e-3) write(76,'("CORRECTIONS ",F10.3)') e0 12596 write(76,*) 12597 if (nkatm.gt.0) then 12598 write(76,'("POTENTIALS")') 12599 write(76,*) "* ipot Z element" 12600 write(76,100) 0,zion(center),symbols(zion(center)) 12601 do ia=1,nkatm 12602 if (ipot(ia).gt.-1) 12603 > write(76,100) ipot(ia), zkatm(ia),symbols(zkatm(ia)) 12604 end do 12605 100 format(I8,I8,9x,A2) 12606 end if 12607 if (nion.gt.0) then 12608 write(76,*) 12609 write(76,'("ATOMS")') 12610 write(76,200) 'x','y','z','ipot','tag','distance' 12611 do ii=1,nion 12612 ia = katm(ii) 12613 ip = ipot(ia) 12614 if (ii.eq.center) ip = 0 12615 x = rion(1,ii)-rion(1,center) 12616 y = rion(2,ii)-rion(2,center) 12617 z = rion(3,ii)-rion(3,center) 12618 dist = sqrt(x**2 + y**2 + z**2) 12619 if (ip.gt.-1) then 12620 write(76,201) rion(1,ii)*autoang, 12621 > rion(2,ii)*autoang, 12622 > rion(3,ii)*autoang, 12623 > ip,symbols(zion(ii)),dist*autoang 12624 end if 12625 end do 12626 200 format('*',A19,2A20,A5,2x,A4,A20) 12627 201 format(3F20.9,I5,2x,A4,E20.9) 12628 end if 12629 close(76) 12630 12631 !*** call feff6 **** 12632 call feff6(header) 12633 12634* **** read chi.dat to generate nkf, kf, and chi **** 12635 nkf = 0 12636 open(unit=15,file=trim(header)//'chi.dat') 12637 do 12638 read(15,*,end=411,err=410) x,y,z,dist 12639 nkf = nkf+1 12640 kf(nkf) = x 12641 chi(nkf) = y 12642 410 continue 12643 end do 12644 411 close(15) 12645 12646 return 12647 end 12648 12649