1 program atm 2c ______________ 3c / \ 4c / Main - ATM \ 5c \ START / 6c \______________/ 7c | 8c ______V_____ 9c | | __________ _______ ______ 10c | Zesec | | | | | / \ 11c |____________| |--->| Charge |-error->| Ext |-->| STOP | 12c | | |__________| |_______| \______/ 13c ______V______ | 14c / /<--| __________ 15c / / | | 16c / Input /<------>| Zedate | 17c / / |__________| 18c /_____________/------| _______ _____ 19c | | | | / \ 20c |---->---------->| |-error->| Ext |--->| STOP | 21c | | |_______| \______/ 22c | _V_ ____________ 23c | / \ _________ _______ / \ 24c | / More \ | | | | / Main - ATM \ 25c | < >-no->| Zesec |--->| Ext |--->| | 26c A \ Data? / |_________| |_______| \ STOP / 27c | \ ___ / \____________/ 28c | | yes 29c | _V_ 30c | / \ 31c A /Config-\ 32c | < uration >yes->| 33c | \ Test? / | 34c | \ ___ / | 35c | | no | 36c | _____V_____ | 37c A | | | 38c | | Vionic | | __________ 39c | |___________| | | | 40c | | V |--->| Splift | 41c | |<---------| | |__________| 42c | _____V_____ | 43c | | |<------| _______ ______ 44c A | | | | / \ 45c | | Velect |--error-->| Ext |--->| STOP | 46c | | | |_______| \______/ 47c | |___________|<------| _________ 48c | | | | | 49c | | |--->| Spliq | 50c A |--->------->| |_________| 51c | A | __________ 52c | | _V_ | | 53c | | / 1'st\ __________ |---->| Tridib | 54c | | /or 2'nd\ | |<---| |__________| 55c | | < Itera- >--yes->| Dsolv1 | __________ 56c | | \ tion? / |__________|<---| | | 57c A | \ ___ / | |---->| Tinvit | 58c | A |no | |__________| 59c | | | V 60c | | | |--->------>----->----->---->----->----- 61c | | V ___ 62c | | | / \ __________ _______ 63c | | | / Rela- \ | | | | 64c | | _____V____ |-->< tivis- ><-yes->| Difrel |-error>| Ext | 65c | A | |<-| \ tic? / |__________| |_______| 66c | | | Dsolv2 | \ ___ / | 67c A | |__________|<-| A __V___ 68c | | | | | no / \ 69c | | | | | | STOP | 70c | | | | | \______/ 71c | | | | _____V____ _______ ______ 72c | A V | | | | | / \ 73c | | | | | Difnrl |-error->| Ext |-->| STOP | 74c | | | | |__________| |_______| \______/ 75c A | | | ___ 76c | | | | / \ _________ 77c | | V | / Con- \ | | 78c | | | |->< verg ><-yes->| Orban | 79c | A | \ ed? / |_________| 80c | | | \ ___ / 81c | | | 82c | | |<------<-----<-------<-------<-------<------<------<-----< 83c | | | __________ 84c | | | | | 85c | A | |--->| Splift | 86c | | _____V_____ | |__________| 87c | | | |<------| _______ ______ 88c A | | | | | / \ 89c | | | Velect |--error-->| Ext |--->| STOP | 90c | | | | |_______| \______/ 91c | A |___________|<------| _________ 92c | | | | | | 93c | | | |--->| Spliq | 94c | | | |_________| 95c A | _V_ ___ 96c | A / \ __________ /Val- \ __________ 97c | | / Con- \ | | / ence \ | | 98c | | < verg >--->| Etotal |--->< Modify? >-yes->| Vionic | 99c | | \ ed? / |__________| \ / |__________| 100c | | \ ___ / \ ___ / | 101c A A | no |no | 102c | | ____V____ V V 103c | | | | |<------------<--------------<-| 104c | | | Dmixp | | __________________________ 105c | | |_________| _V_ | 0)Pseudo | 106c | | | / \ | 1)Pseudk | 107c | A _V_ /Pseudo \ | Pseudo- 2)Pseudt | 108c | | /Pass \ < Generate>-yes>| Potential 3)Pseudv | 109c A | / Max. \ \ ? / | Generation 4)Datout | 110c | |<--no--< Itera- > \ ___ / | Block 5)Pseudb | 111c | \ tion? / |no | 6)Pseud2 | 112c | \ ___ / V |__________________________| 113c | | yes |---<----------<-------| 114c | ___V___ _V_ 115c A | | / \ __________ 116c | | Ext | /Config-\ | | 117c | |_______| < uration >-yes>| Prdiff | 118c | | \ Test? / |__________| 119c | ___V__ \ ___ / | 120c | / \ |no | 121c | | STOP | | V 122c A \______/ |<---------<----| 123c | V 124c |---------<------------<-----------| 125c 126c 127c ************************************************************* 128c * Program for atomic calculations * 129c * Copyright Norman J. Troullier Jr & * 130c * Jose Luis Martins * 131c * Written by Norman J. Troullier Jr., Sept 89 * 132c * while at U of Minn, from a Sverre Froyen * 133c * UC Berkeley code. Program input/output is * 134c * compatible with earlier Berkeley versions. * 135c * * 136c * Send comments/suggestions/bug reports to: * 137c * troullie@csfsa.cs.umn.edu * 138c * 612 625-0392 * 139c * * 140c * Version 5.06, Dated Oct. 19, 1990 * 141c * * 142c ************************************************************* 143c 144c Some parameters are set inside the program, 145c the most important ones are: 146c 1)the tolerance for selfconsistency in the screening 147c potential (set in the main-atm program-named tol), 148c 2)the accuracy in the eigenvalue for a given potential 149c (set in difnrl-named tol or difrel-named tol), 150c 3)the dimensions of the work space used: nrmax, 151c norbmx, lmax(needs to be set only in main-atm), 152c 4)the machine precision - MACHEP, for use in the 153c eispack group of fuctions: tinvit, and tridib. 154c (The current value is ok for this application.) 155c 5)the machine precision exp(-2*expzer), set in difnrl 156c and difrel for the predictor-corrector methods 157c (both named expzer), 158c 159c For traditional applications the default values 160c should be enough for 1-4. For 5, expzer should be 161c found for the system in use. 162c NOTE: that for most VAX systems the value of expzer 163c can be very very small !! 164c 165c The subroutine orban is called once for each orbital 166c after selfconsistency has been achieved. 167c Any additional analysis of the orbitals should therefore 168c be placed in orban. Note that arrays ar and br have 169c different meaning for non-relativistic (ar-wave, 170c br-d(wave)/dj) and relativistic (ar-major, br-minor) 171c calculations. 172c 173c There are six ways to generate the pseudopotential : 174c ikerk = 6 Improved Troullier and Martins 175c ikerk = 5 Bachelet, Hamann, and Schluter 176c ikerk = 4 generates data file another pseudopotential 177c generation program. 178c ikerk = 3 Vanderbilt 179c ikerk = 2 Troullier and Martins 180c ikerk = 1 Kerker 181c ikerk = 0 Hamann Schluter and Chiang 182c 183c This main - atm routine has had extremly major 184c modifications with respect to the Berkeley version. 185c However, all input and output files are still compatible 186c with earlier Berkeley versions of this program. 187c 188c 1)Machine dependent timing calls were placed 189c in the program so it could be used as a machine 190c perfomance indicatior. The user will either have 191c to change these calls for his machine or 192c comment them out. Corresponding subroutines 193c are included for the Apollo, Cray, Sun, and Vax 194c computers. 195c 2)The plot.dat file is now opened as a formatted file, 196c this is user/plot method dependent. The atom.job 197c file is no longer used. Note that the Apollo 198c system does not use standard Fortran methods to 199c open unformatted files. 200c 3)The charge density startup is scaled with 201c an empirical formula that reduces the 202c number of iterations needed for the screening 203c potential convergence. 204c 4)The screening potential mixing parameter is 205c an empirical function of the nuclear charge. 206c Larger atoms require a slower convergence 207c then smaller atoms. 208c 5)The screening potential is intially mixed with a 209c percentage of old and new for the first itsm 210c iterations. This brings the potential to a stable 211c region after which an Anderson's extrapolation scheme 212c is used. 213c 6)The files pseudo.dat and plot.dat files are closed 214c and new ones are opened before the generation of a 215c pseudopotential. This allows the generation of 216c multiple pseudopotentials(up to 99). 217c 7)The pseudopotentail generation scheme of Troullier 218c and Martins is added - pseudt. The pseudopotential 219c scheme of Vanderbilt has been added - pseudv. 220c The improved pseudopotential scheme of Troullier 221c and Martins has been added - pseud2. 222c The datout routine generates a data file for use 223c in external pseudopotential generation programs. 224c The user may wish to alter for his own use or ignore. 225c 8)Only the major modifications(not programming style) 226c to the algorithms of each subroutine are commented 227c in that routine. 228c 9)Cray(and other machines) conversions are indicated 229c at the begining of each routine. 230c 10)The difrel and difnrl allow for the calculation of 231c a nonbound state(zero eigenvalue). These states 232c can only be used in the pseudt, pseudk and 233c pseud2 generation 234c routines. The pseudo, pseudb and pseudv will fail with 235c a zero eigenvalue due to the generation method. 236c The user should be very careful in using a nonbound 237c state, and should always compare the resulting pseudopotential 238c to a bound state pseudopotential calculation. 239c 11)What comes free comes with no guarantee!! 240c 241c njtj 242c ### Cray conversions 243c ### 1)Comment out implicit double precision. 244c ### 2)Make sure the 2 open(unit=1) statements are 245c ### a non-recl (non-Apollo type) format. 246c ### 3)Switch the 2 double precision parameters 247c ### to single precision parameter statements. 248c ### Cray conversions 249c njtj 250c 251c tolerance for self-consistency 252c 253 implicit double precision (a-h,o-z) 254 parameter (tol=1.E-8) 255c 256 parameter (zero=0.0,one=1.0) 257c 258 parameter(lmax=5,nrmax=1000,norbmx=40) 259c 260c 261 dimension r(nrmax),rab(nrmax),no(norbmx),lo(norbmx), 262 1 so(norbmx),zo(norbmx),cdd(nrmax),cdu(nrmax),cdc(nrmax), 263 2 viod(lmax,nrmax),viou(lmax,nrmax),vid(nrmax),viu(nrmax), 264 3 vod(nrmax),vou(nrmax),vn1d(nrmax),vn1u(nrmax), 265 4 vn11d(nrmax),vn11u(nrmax),vn2d(nrmax),vn2u(nrmax), 266 5 vn22d(nrmax),vn22u(nrmax),ev(norbmx),evi(norbmx),ek(norbmx), 267 6 ep(norbmx),wk1(nrmax),wk2(nrmax),wk3(nrmax),wk4(nrmax), 268 7 wk5(nrmax),wk6(nrmax),wk7(nrmax),wk8(nrmax),wk9(nrmax), 269 8 wkb(6*nrmax) 270c 271 dimension econf(100),etot(10) 272c 273 character*1 ispp 274 character*2 naold,icold,icorr,nameat 275 character*10 plotfile 276 character*12 pseudofile 277c 278c CALL DROPFILE(0) 279c njtj *** machine call *** 280c Call to machine dependent cpu time routine. 281c User may want to comment out timing calls - 282c here and at exit of main - atm 283c 284 CALL ZESEC(t1) 285c 286c njtj *** machine call *** 287c 288c Startup values for doing multiple input data sets. 289c 290 naold = ' ' 291 icold = ' ' 292 zsold = zero 293 nconf = 0 294c 295c open files 296c 297 isize = 8*nrmax 298c 299c Note that the open(unit=1,...,recl..) is needed 300c by the Apollo systems. For other systems the 301c Cray statements(standard Fortran 77) should be 302c the ones used. 303c 304 open(unit=1,file='pseudo.dat',form='unformatted', 305 1 status='unknown') 306c 307c njtj *** modification start *** 308c The plot.dat file is now opened as a formatted file. 309c This is user/plot method dependent. The atom.job 310c file is no longer used. 311c 312 open(unit=3,file='plot.dat',status='new',form='formatted') 313 open(unit=5,file='atom.dat',status='old',form='formatted') 314 open(unit=6,file='atom.out',status='new',form='formatted') 315c 316c njtj *** modification end *** 317c 318c Start of loop over configuration. 319c Read the input data. 320c 321 322 20 nr = nrmax 323 norb = norbmx 324 call input(itype,ikerk,icorr,ispp,zsh,rsh, 325 1 nr,a,b,r,rab,nameat,norb,ncore,no,lo,so,zo, 326 2 znuc,zel,evi) 327c 328c njtj *** machine call *** 329c Stop - no more data in input file, 330c Find time taken for total calculation. 331c second - machine dependent routine 332c 333 if (itype .lt. 0) then 334 CALL ZESEC(t2) 335 write(6,2000)t2-t1 336 2000 format(//,' The total time for the calculation is ', 337 1 f12.5,' seconds') 338 call ext(0) 339 endif 340c 341c njtj *** machine call *** 342c 343c Jump charge density 'set up' and ionic data input if 344c configuration test. 345c 346 itsm=znuc/9+3 347 if (zsold .eq. zsh .and. naold .eq. nameat 348 1 .and. itype .lt. 1 ) then 349 else 350 if (itype .lt. 4) then 351c 352c Set up the initial charge density. 353c cdd and cdu = (4 pi r**2 rho(r))/2 354c 355c njtj *** modification *** 356c The charge density setup (aa) is scaled with 357c an empirical formula that reduces the 358c number of iterations needed for the screening 359c potential convergence. 360c 361 aa = sqrt(sqrt(znuc))/2+one 362 do 30 i=1,nr 363 cdd(i) = zel*aa**3*exp(-aa*r(i))*r(i)**2/4 364 cdu(i) = cdd(i) 365 30 continue 366 endif 367c 368c njtj *** modification end *** 369c 370c set up ionic potentials 371c 372 call vionic(ispp,itype,icorr,ifcore,zsh,rsh, 373 1 lmax,nr,a,b,r,rab,nameat,ncore,znuc, 374 2 cdd,cdu,cdc,viod,viou) 375 endif 376c 377c Set up the electronic potential. 378c 379 call velect(0,0,icorr,ispp,ifcore, 380 1 nr,r,rab,zel,cdd,cdu,cdc,vod,vou,etot,wk1,wk2, 381 2 wk3,wk4,wk5,wkb) 382c 383 do 50 i=1,nr 384 vid(i) = vod(i) 385 viu(i) = vou(i) 386 50 continue 387c 388c Start the iteration loop for electronic convergence. 389c 390 iconv = 0 391 icon2 = 0 392 maxit = 100 393c 394c njtj *** modification start *** 395c The screening potential mixing parameter is 396c an empirical function of the nuclear charge. 397c Larger atoms require a slower convergence 398c then smaller atoms. 399c 400 xmixo = one/log(znuc+7*one) 401c 402c njtj *** modifications end *** 403c 404 do 100 iter=1,maxit 405 if (iter .eq. maxit) iconv=1 406c 407c compute orbitals 408c 409 if (icon2 .lt. 2) then 410 call dsolv1(lmax,nr,a,b,r,rab,norb,ncore, 411 1 no,lo,so,zo,cdd,cdu,viod,viou,vid,viu,ev, 412 2 wk1,wk2,wk3,wk4,wk5,wk6,wk7,wk8,wk9,wkb) 413 else 414 call dsolv2(iter,iconv,ispp,ifcore,lmax,nr, 415 1 a,b,r,rab,norb,ncore,no,lo,so,zo,znuc,cdd, 416 2 cdu,cdc,viod,viou,vid,viu,ev,ek,ep,wk1,wk2, 417 3 wk3,wk4,wk5,wk6,wk7,evi) 418 endif 419c 420c set up output electronic potential from charge density 421c 422 call velect(iter,iconv,icorr,ispp,ifcore, 423 1 nr,r,rab,zel,cdd,cdu,cdc,vod,vou,etot,wk1,wk2, 424 2 wk3,wk4,wk5,wkb) 425c 426c check for convergence 427c 428 if (iconv .gt. 0) goto 120 429 dvmax = zero 430 do 60 i=1,nr 431 dv = (vod(i)-vid(i))/(1.D0+vod(i)+vou(i)) 432 if (abs(dv) .gt. dvmax) dvmax=abs(dv) 433 dv = (vou(i)-viu(i))/(1.D0+vou(i)+vod(i)) 434 if (abs(dv) .gt. dvmax) dvmax=abs(dv) 435 60 continue 436 icon2 = icon2+1 437 if (dvmax .le. tol) iconv=1 438c 439c Mix the input and output electronic potentials. 440c 441c njtj *** modification start *** 442c The screening potential is initially mixed with a 443c percentage of old and new for itsm iterations. 444c This brings the potential to a stable region 445c after which an Anderson's extrapolation scheme 446c is used. 447c 448 if (iter .lt. itsm) then 449 iiter=2 450 else 451 iiter=iter-itsm+3 452 endif 453 call dmixp(vod,vid,xmixo,iiter,3,nr,wk1,wk2, 454 1 vn1d,vn11d,vn2d,vn22d) 455 call dmixp(vou,viu,xmixo,iiter,3,nr,wk1,wk2, 456 1 vn1u,vn11u,vn2u,vn22u) 457 100 continue 458c 459c End of iteration of electronic convergence loop. 460c 461 write(6,110) dvmax,xmixo 462 110 format(/,' potential not converged - dvmax =',e10.4, 463 1 ' xmixo =',f5.3) 464 call ext(1) 465c 466c njtj *** modification end *** 467c 468c Find the total energy. 469c 470 120 write(6,121)icon2 471 121 format(/,'Total number of iterations needed for', 472 1 ' electron screening potential is ',i2,/) 473 call etotal(itype,zsh,nameat,norb, 474 1 no,lo,so,zo,etot,ev,ek,ep) 475c 476c Replace the valence charge density. 477c 478 if (itype .eq. 5) call vionic(ispp,6,icorr, 479 1 ifcore,zsh,rsh,lmax,nr,a,b,r,rab,nameat, 480 2 ncore,znuc,cdd,cdu,cdc,viod,viou) 481c 482c Pseudopotential generation. 483c 484c njtj *** modification start *** 485c Current pseudo.dat and plot.dat files are closed 486c and new ones are opened. This allows the 487c generation of multiple pseudopotentials(up to 99). 488c 489 if (itype .ge.1 .and. itype .le. 3) then 490 if (ikerk .ne. 4 ) then 491 close(unit=1) 492 close(unit=3) 493 if (nconf .le. 8) then 494 write(pseudofile,8000)nconf+1 495 write(plotfile,8002)nconf+1 496 else 497 write(pseudofile,8001)nconf+1 498 write(plotfile,8003)nconf+1 499 endif 500 write(6,8004)nconf+1 501 8000 format('pseudo.dat0',i1) 502 8001 format('pseudo.dat',i2) 503 8002 format('plot.dat0',i1) 504 8003 format('plot.dat',i2) 505 8004 format(//,' Pseudopotential generation file number ',i2) 506 507c 508c Note that the open(unit17,...,recl..) is needed 509c by the Apollo systems. For other systems the 510c Cray statements(standard Fortran 77) should be the 511c ones used. 512c 513 open(unit=1,file=pseudofile,form='unformatted') 514 open(unit=3,file=plotfile,status='new', 515 1 form='formatted') 516 endif 517c 518c njtj *** modification end *** 519c 520c njtj *** modification start *** 521c The pseudopotentail generation scheme of Troullier 522c and Martins is added - pseudt. The pseudopotential 523c scheme of Vanderbilt is added - pseudv. The 524c pseudopotential scheme of BHS is added - pseudb. 525c The improved pseudopotential scheme of Troullier 526c and Martins is added - pseud2. The 527c dataout routine generates a data file for use in 528c external pseudopotential generation programs. 529c The user may wish to alter for their own use or ignore. 530c 531 if(ikerk.eq.0) then 532 call pseudo(itype,icorr,ispp,lmax,nr,a,b,r,rab, 533 1 nameat,norb,ncore,no,lo,so,zo,znuc,zel,cdd,cdu,cdc, 534 2 viod,viou,vid,viu,vod,vou,etot,ev,ek,ep,wk1,wk2, 535 3 wk3,wk4,wk5,wk6,wk7,wk8,wk9,vn1d,vn1u,vn2d,vn2u, 536 4 vn11d,wkb,evi) 537 elseif (ikerk .eq. 1) then 538 call pseudk(itype,icorr,ispp,lmax,nr,a,b,r,rab, 539 1 nameat,norb,ncore,no,lo,so,zo,znuc,zel,cdd,cdu,cdc, 540 2 viod,viou,vid,viu,vod,vou,etot,ev,ek,ep,wk1,wk2, 541 3 wk3,wk4,wk5,wk6,wk7,wk8,wk9,vn1d,vn1u,wkb,evi) 542 elseif (ikerk .eq. 2) then 543 call pseudt(itype,icorr,ispp,lmax,nr,a,b,r,rab, 544 1 nameat,norb,ncore,no,lo,so,zo,znuc,zel,cdd,cdu,cdc, 545 2 viod,viou,vid,viu,vod,vou,etot,ev,ek,ep,wk1,wk2, 546 3 wk3,wk4,wk5,wk6,wk7,wk8,wk9,vn1d,vn1u,wkb,evi) 547 elseif (ikerk .eq. 3) then 548 call pseudv(itype,icorr,ispp,lmax,nr,a,b,r,rab, 549 1 nameat,norb,ncore,no,lo,so,zo,znuc,zel,cdd,cdu,cdc, 550 2 viod,viou,vid,viu,vod,vou,etot,ev,ek,ep,wk1,wk2, 551 3 wk3,wk4,wk5,wk6,wk7,wk8,wk9,vn1d,vn1u,vn2d,vn2u, 552 4 vn11d,wkb,evi) 553 elseif (ikerk .eq. 4) then 554 call datout(itype,icorr,ispp,lmax,nr,a,b,r,rab, 555 1 nameat,norb,ncore,no,lo,so,zo,znuc,zel,cdc, 556 2 viod,viou,vid,viu,ev) 557 elseif (ikerk .eq. 5) then 558 call pseudb(itype,icorr,ispp,lmax,nr,a,b,r,rab, 559 1 nameat,norb,ncore,no,lo,so,zo,znuc,zel,cdd,cdu,cdc, 560 2 viod,viou,vid,viu,vod,vou,etot,ev,ek,ep,wk1,wk2, 561 3 wk3,wk4,wk5,wk6,wk7,wk8,wk9,vn1d,vn1u,vn2d,vn2u, 562 4 vn11d,wkb,evi) 563 elseif (ikerk .eq. 6) then 564 call pseud2(itype,icorr,ispp,lmax,nr,a,b,r,rab, 565 1 nameat,norb,ncore,no,lo,so,zo,znuc,zel,cdd,cdu,cdc, 566 2 viod,viou,vid,viu,vod,vou,etot,ev,ek,ep,wk1,wk2, 567 3 wk3,wk4,wk5,wk6,wk7,wk8,wk9,vn1d,vn1u,wkb,evi) 568 endif 569 endif 570c 571c njtj *** modification end *** 572c 573c printout difference from first configuration 574c 575 nconf = nconf + 1 576 econf(nconf) = etot(10) 577 if(naold .eq. nameat .and. icold .eq. icorr .and. nconf .ne. 1 578 1 .and. (itype .lt. 1 .or. itype .gt. 3)) then 579 call prdiff(nconf,econf) 580 write(6,130) etot(10)-econf(1) 581 endif 582 write(6,135) 583 130 format(//,' excitation energy =',f18.8,/) 584 135 format(//,60('%'),//) 585 naold = nameat 586 icold = icorr 587 zsold = zsh 588c 589c End loop of configuration. 590c 591 goto 20 592 end 593C 594C 595C 596 double precision function charge(name) 597Cray function charge(name) 598c 599c function determines the nuclear charge of an element 600c 601c njtj *** modifications *** 602c All elements from H to Lr are included 603c njtj *** modifications *** 604c 605c njtj 606c ### Cray conversions 607c ### 1)Switch double precision function to function. 608c ### 2)Switch double precision parameter 609c ### to single precision parameter statement. 610c ### Cray conversions 611c njtj 612c 613 parameter (one=1.0) 614c 615 character*2 name 616c 617 if (name .eq. 'H ' .or. name .eq. ' H') then 618 charge = 1*one 619 elseif (name .eq. 'He') then 620 charge = 2*one 621 elseif (name .eq. 'Li') then 622 charge = 3*one 623 elseif (name .eq. 'Be') then 624 charge = 4*one 625 elseif (name .eq. 'B ' .or. name .eq. ' B') then 626 charge = 5*one 627 elseif (name .eq. 'C ' .or. name .eq. ' C') then 628 charge = 6*one 629 elseif (name .eq. 'N ' .or. name .eq. ' N') then 630 charge = 7*one 631 elseif (name .eq. 'O ' .or. name .eq. ' O') then 632 charge = 8*one 633 elseif (name .eq. 'F ' .or. name .eq. ' F') then 634 charge = 9*one 635 elseif (name .eq. 'Ne') then 636 charge = 10*one 637 elseif (name .eq. 'Na') then 638 charge = 11*one 639 elseif (name .eq. 'Mg') then 640 charge = 12*one 641 elseif (name .eq. 'Al') then 642 charge = 13*one 643 elseif (name .eq. 'Si') then 644 charge = 14*one 645 elseif (name .eq. 'P ' .or. name .eq. ' P') then 646 charge = 15*one 647 elseif (name .eq. 'S ' .or. name .eq. ' S') then 648 charge = 16*one 649 elseif (name .eq. 'Cl') then 650 charge = 17*one 651 elseif (name .eq. 'Ar') then 652 charge = 18*one 653 elseif (name .eq. 'K ' .or. name .eq. ' K') then 654 charge = 19*one 655 elseif (name .eq. 'Ca') then 656 charge = 20*one 657 elseif (name .eq. 'Sc') then 658 charge = 21*one 659 elseif (name .eq. 'Ti') then 660 charge = 22*one 661 elseif (name .eq. 'V ' .or. name .eq. ' V') then 662 charge = 23*one 663 elseif (name .eq. 'Cr') then 664 charge = 24*one 665 elseif (name .eq. 'Mn') then 666 charge = 25*one 667 elseif (name .eq. 'Fe') then 668 charge = 26*one 669 elseif (name .eq. 'Co') then 670 charge = 27*one 671 elseif (name .eq. 'Ni') then 672 charge = 28*one 673 elseif (name .eq. 'Cu') then 674 charge = 29*one 675 elseif (name .eq. 'Zn') then 676 charge = 30*one 677 elseif (name .eq. 'Ga') then 678 charge = 31*one 679 elseif (name .eq. 'Ge') then 680 charge = 32*one 681 elseif (name .eq. 'As') then 682 charge = 33*one 683 elseif (name .eq. 'Se') then 684 charge = 34*one 685 elseif (name .eq. 'Br') then 686 charge = 35*one 687 elseif (name .eq. 'Kr') then 688 charge = 36*one 689 elseif (name .eq. 'Rb') then 690 charge = 37*one 691 elseif (name .eq. 'Sr') then 692 charge = 38*one 693 elseif (name .eq. 'Y ' .or. name .eq. ' Y') then 694 charge = 39*one 695 elseif (name .eq. 'Zr') then 696 charge = 40*one 697 elseif (name .eq. 'Nb') then 698 charge = 41*one 699 elseif (name .eq. 'Mo') then 700 charge = 42*one 701 elseif (name .eq. 'Tc') then 702 charge = 43*one 703 elseif (name .eq. 'Ru') then 704 charge = 44*one 705 elseif (name .eq. 'Rh') then 706 charge = 45*one 707 elseif (name .eq. 'Pd') then 708 charge = 46*one 709 elseif (name .eq. 'Ag') then 710 charge = 47*one 711 elseif (name .eq. 'Cd') then 712 charge = 48*one 713 elseif (name .eq. 'In') then 714 charge = 49*one 715 elseif (name .eq. 'Sn') then 716 charge = 50*one 717 elseif (name .eq. 'Sb') then 718 charge = 51*one 719 elseif (name .eq. 'Te') then 720 charge = 52*one 721 elseif (name .eq. 'I ' .or. name .eq. ' I') then 722 charge = 53*one 723 elseif (name .eq. 'Xe') then 724 charge = 54*one 725 elseif (name .eq. 'Cs') then 726 charge = 55*one 727 elseif (name .eq. 'Ba') then 728 charge = 56*one 729 elseif (name .eq. 'La') then 730 charge = 57*one 731 elseif (name .eq. 'Ce') then 732 charge = 58*one 733 elseif (name .eq. 'Pr') then 734 charge = 59*one 735 elseif (name .eq. 'Nd') then 736 charge = 60*one 737 elseif (name .eq. 'Pm') then 738 charge = 61*one 739 elseif (name .eq. 'Sm') then 740 charge = 62*one 741 elseif (name .eq. 'Eu') then 742 charge = 63*one 743 elseif (name .eq. 'Gd') then 744 charge = 64*one 745 elseif (name .eq. 'Tb') then 746 charge = 65*one 747 elseif (name .eq. 'Dy') then 748 charge = 66*one 749 elseif (name .eq. 'Ho') then 750 charge = 67*one 751 elseif (name .eq. 'Er') then 752 charge = 68*one 753 elseif (name .eq. 'Tm') then 754 charge = 69*one 755 elseif (name .eq. 'Yb') then 756 charge = 70*one 757 elseif (name .eq. 'Lu') then 758 charge = 71*one 759 elseif (name .eq. 'Hf') then 760 charge = 72*one 761 elseif (name .eq. 'Ta') then 762 charge = 73*one 763 elseif (name .eq. 'W ' .or. name .eq. ' W') then 764 charge = 74*one 765 elseif (name .eq. 'Re') then 766 charge = 75*one 767 elseif (name .eq. 'Os') then 768 charge = 76*one 769 elseif (name .eq. 'Ir') then 770 charge = 77*one 771 elseif (name .eq. 'Pt') then 772 charge = 78*one 773 elseif (name .eq. 'Au') then 774 charge = 79*one 775 elseif (name .eq. 'Hg') then 776 charge = 80*one 777 elseif (name .eq. 'Tl') then 778 charge = 81*one 779 elseif (name .eq. 'Pb') then 780 charge = 82*one 781 elseif (name .eq. 'Bi') then 782 charge = 83*one 783 elseif (name .eq. 'Po') then 784 charge = 84*one 785 elseif (name .eq. 'At') then 786 charge = 85*one 787 elseif (name .eq. 'Rn') then 788 charge = 86*one 789 elseif (name .eq. 'Fr') then 790 charge = 87*one 791 elseif (name .eq. 'Ra') then 792 charge = 88*one 793 elseif (name .eq. 'Ac') then 794 charge = 89*one 795 elseif (name .eq. 'Th') then 796 charge = 90*one 797 elseif (name .eq. 'Pa') then 798 charge = 91*one 799 elseif (name .eq. ' U' .or. name .eq. 'U ') then 800 charge = 92*one 801 elseif (name .eq. 'Np') then 802 charge = 93*one 803 elseif (name .eq. 'Pu') then 804 charge = 94*one 805 elseif (name .eq. 'Am') then 806 charge = 95*one 807 elseif (name .eq. 'Cm') then 808 charge = 96*one 809 elseif (name .eq. 'Bk') then 810 charge = 97*one 811 elseif (name .eq. 'Cf') then 812 charge = 98*one 813 elseif (name .eq. 'Es') then 814 charge = 99*one 815 elseif (name .eq. 'Fm') then 816 charge = 100*one 817 elseif (name .eq. 'Md') then 818 charge = 101*one 819 elseif (name .eq. 'No') then 820 charge = 102*one 821 elseif (name .eq. 'Lr') then 822 charge = 103*one 823 else 824 write(6,100) name 825 100 format(//,'element ',a2,' unknown') 826 call ext(200) 827 endif 828 return 829 end 830C 831C 832C 833 subroutine datout(itype,icorr,ispp,lmax,nr,a,b,r,rab, 834 1 nameat,norb,ncore,no,lo,so,zo,znuc,zel,cdc,viod,viou, 835 2 vid,viu,ev) 836c 837c ********************************************************* 838c * 839c * njtj 840c * The routine writes needed data to file 'datafile.dat' 841c * for latter use in a minimization program. 842c * Users may want to remove or modify this routine 843c * depending on their needs. 844c * njtj 845c * 846c *********************************************************** 847c 848c njtj 849c ### Cray conversions 850c ### 1)Comment out implicit double precision. 851c ### 2)Make sure the open(unit=7) is a non-recl 852c ### (non-Apollo type) format. 853c ### Cray conversions 854c njtj 855c 856 implicit double precision (a-h,o-z) 857c 858 dimension r(nr),rab(nr),no(norb),lo(norb),so(norb),zo(norb), 859 1 cdc(nr),viod(lmax,nr),viou(lmax,nr),vid(nr),viu(nr), 860 2 ev(norb) 861c 862 character*1 ispp 863 character*2 icorr,nameat 864c 865c Open and write out data to current file datafile.dat. 866c Note that the open(unit=7,...,recl..) is needed 867c by the Apollo systems. For other systems the 868c Cray statements(standard Fortran 77) should be used. 869c 870 open (unit=7,file='datafile.dat',status='new', 871 1 form='unformatted') 872 write(7)itype,icorr,ispp,nr,a,b 873 write(7)(r(i),i=1,nr) 874 write(7)(rab(i),i=1,nr) 875 write(7)lmax,nameat,norb,ncore 876 write(7)(no(i),i=1,norb) 877 write(7)(lo(i),i=1,norb) 878 write(7)(so(i),i=1,norb) 879 write(7)(zo(i),i=1,norb) 880 write(7)znuc,zel 881 write(7)(cdc(i),i=1,nr) 882 do 1,j=1,lmax 883 write(7)(viod(j,i),i=1,nr) 884 1 continue 885 do 2,j=1,lmax 886 write(7)(viou(j,i),i=1,nr) 887 2 continue 888 write(7)(vid(i),i=1,nr) 889 write(7)(viu(i),i=1,nr) 890 write(7)(ev(i),i=1,norb) 891 close (unit=7) 892c 893 return 894 end 895c 896c 897c 898 subroutine difnrl(iter,iorb,v,ar,br,lmax, 899 1 nr,a,b,r,rab,norb,no,lo,so,znuc,viod,viou, 900 2 vid,viu,ev,iflag,rab2,fa,fb,evi) 901c 902c difnrl integrates the Schroedinger equation 903c if finds the eigenvalue ev, the wavefunction ar 904c and the derivative br = d(ar)/dr 905c 906c njtj *** modifications *** 907c This routine has had major modifications. Some 908c of the data used inside the main loop has been 909c calculated outside the main loop to reduce the number 910c of operations(uses extra array space to gain speed) 911c and are passed as work arrays form the main. 912c The predictor-corrector functions have been put 913c into a array. 914c The iflag variable was added to indicate nonconvergence 915c for other programs. It has no use in the atom program 916c and can be removed by the user. 917c All output from the routine is compatible to 918c the Berkeley/Sverre Froyen version. 919c njtj *** modifications *** 920c 921c njtj 922c ### Cray conversions 923c ### 1)Comment out implicit double precision. 924c ### 2)Switch the double precision parameter statements 925c ### to single precision parameter statements. 926c ### Cray conversions 927c njtj 928c 929c njtj 930c &&& Machine dependent Parameter 931c &&& The value of expzer is machine dependent. 932c &&& The user must switch in the correct value for 933c &&& the machine in use from the list, or find 934c &&& it for their machine. 935c &&& Machine dependent Parameter 936c njtj 937c 938 implicit double precision (a-h,o-z) 939 parameter(zero=0.0,pnine=0.9,two=2.0,etol=-1.E-7) 940c 941c Tolerence 942c 943 parameter(tol=1.E-10,five=5.0) 944c 945c Integration coefficients 946c 947 parameter(abc1=190.1/72,abc2=-138.7/36,abc3=10.9/3, 948 1 abc4=-63.7/36,abc5=25.1/72,amc0=25.1/72,amc1=32.3/36, 949 2 amc2=-1.1/3,amc3=5.3/36,amc4=-1.9/72) 950c 951c 952 dimension v(nr),ar(nr),br(nr),r(nr),rab(nr),no(norb), 953 1 lo(norb),so(norb),viod(lmax,nr),viou(lmax,nr), 954 2 vid(nr),viu(nr),ev(norb),evi(norb) 955c 956c njtj *** start modification *** 957c Arrays added to gain speed. 958c 959 dimension rabrlo(5),rlp(5),rab2(nr),fa(nr),fb(nr) 960c 961c njtj *** end modification *** 962c 963c------Machine dependent parameter- 964c------Require exp(-2*expzer) to be within the range of the machine 965c 966cApollo expzer = 3.7D2 967cSun expzer = 3.7D2 968 expzer = 3.7D2 969cVax expzer = 44.D0 970Cray expzer = 2.8E3 971c 972c njtj *** major modification start *** 973c Loop data calculated outside loop to gain speed. 974c 975 itmax = 100 976 iflag = 0 977 lp = lo(iorb)+1 978 ar(1) = zero 979 if (lo(iorb) .eq. 0) then 980 br(1) = b*a 981 else 982 br(1) = zero 983 endif 984 do 1 j=2,nr 985 ar(j) = zero 986 1 continue 987 do 2 j=2,nr 988 br(j) =zero 989 2 continue 990 do 4 j=2,5 991 rlp(j)=r(j)**lp 992 4 continue 993 do 5 j=2,5 994 rabrlo(j)=rab(j)*r(j)**lo(iorb) 995 5 continue 996 do 6 j=1,nr 997 rab2(j)=rab(j)*rab(j) 998 6 continue 999c 1000c set underflow trap, error from Berkeley version, 1001c fixed by Troy Barbee sqrt(expzer) should be expzer/2 1002c 4/17/90 1003c 1004 juflow=1 1005 do 42 j=2,nr 1006 if (lp*abs(log(r(j))) .ge. expzer/2) juflow = j 1007 42 continue 1008c 1009c njtj *** end major modification *** 1010c 1011c determine effective charge and vzero for startup of 1012c outward integration 1013c ar = r**(l+1) * (1 + aa r + bb r**2 + ... ) 1014c aa = -znuc / lp bb = (-2 znuc aa + v(0) - e)/(4 l + 6) 1015c 1016 zeff = zero 1017 if (so(iorb) .lt. 0.1 .and. viod(lp,2) .lt. -0.1) zeff=znuc 1018 if (so(iorb) .gt. 0.1 .and. viou(lp,2) .lt. -0.1) zeff=znuc 1019 aa = -zeff/lp 1020 vzero = -2*zeff*aa 1021 if (zeff .eq. zero) then 1022 if (so(iorb) .lt. 0.1 ) then 1023 vzero=vzero+viod(lp,2)/r(2) 1024 else 1025 vzero=vzero+viou(lp,2)/r(2) 1026 endif 1027 endif 1028 if (so(iorb) .lt. 0.1) then 1029 vzero=vzero+vid(2) 1030 else 1031 vzero=vzero+viu(2) 1032 endif 1033 var0 = zero 1034 if (lo(iorb) .eq. 0) var0=-2*zeff 1035 if (lo(iorb) .eq. 1) var0=two 1036c 1037 emax = zero 1038 emin = -two*100000 1039 if (ev(iorb) .gt. emax) ev(iorb) = emax 1040 10 if (itmax .lt. 2) write(6,15) iorb,iter,ev(iorb),nodes 1041 15 format(' iorb =',i3,' iter =',i3,' ev =',e18.10,' nodes =',i2) 1042 if (itmax .eq. 0) then 1043 iflag =1 1044 return 1045 endif 1046 if (ev(iorb) .gt. zero) then 1047 write(6,1000)iorb 1048 call ext(620+iorb) 1049 endif 1050 1000 format(//,' error in difnrl - ev(',i2, 1051 1 ') greater then v(infinty)') 1052c 1053c find practical infinity ninf and classical turning 1054c point nctp for orbital 1055c 1056 icount=0 1057 20 icount=icount+1 1058 do 22 j=nr,2,-1 1059 temp = v(j) -ev(iorb) 1060 if (temp .lt. zero) temp = zero 1061 if (r(j)*sqrt(temp) .lt. expzer) goto 23 1062 22 continue 1063 23 ninf=j 1064 nctp = ninf - 5 1065 do 25 j=2,ninf-5 1066 if (v(j) .lt. ev(iorb)) nctp = j 1067 25 continue 1068 if (ev(iorb) .ge. etol*10) nctp=ninf-5 1069 if (ev(iorb) .ge. etol) ev(iorb)=zero 1070 if (evi(iorb) .ne. zero) then 1071 ev(iorb) = evi(iorb) 1072 do 26 j=1,nr 1073 if (r(j) .lt. five) nctp=j 1074 26 continue 1075 endif 1076 if (nctp .le. 6) then 1077 ev(iorb) = pnine*ev(iorb) 1078 if (icount .gt. 100) then 1079 write(6,1010)iorb 1080 call ext(650+iorb) 1081 endif 1082 goto 20 1083 endif 1084 1010 format(//,'error in difnrl - cannot find the classical ' 1085 1 ,/' turning point for orbital ',i2) 1086c 1087c outward integration from 1 to nctp 1088c startup 1089c 1090 bb = (vzero-ev(iorb))/(4*lp+2) 1091 do 35 j=2,5 1092 ar(j) = rlp(j) * (1+(aa+bb*r(j))*r(j)) 1093 br(j) = rabrlo(j) * (lp+(aa*(lp+1)+bb*(lp+2)*r(j))*r(j)) 1094 35 continue 1095c 1096c njtj *** start major modification *** 1097c Predictor-corrector array added. 1098c 1099 fa(1) = br(1) 1100 fb(1) = b*br(1) + rab2(1)*var0 1101 fa(2) = br(2) 1102 fb(2) = b*br(2) + rab2(2)*(v(2)-ev(iorb))*ar(2) 1103 fa(3) = br(3) 1104 fb(3) = b*br(3) + rab2(3)*(v(3)-ev(iorb))*ar(3) 1105 fa(4) = br(4) 1106 fb(4) = b*br(4) + rab2(4)*(v(4)-ev(iorb))*ar(4) 1107 fa(5) = br(5) 1108 fb(5) = b*br(5) + rab2(5)*(v(5)-ev(iorb))*ar(5) 1109c 1110c intergration loop 1111c 1112 nodes = 0 1113 do 40 j=6,nctp 1114c 1115c predictor (Adams-Bashforth) 1116c 1117 j1=j-1 1118 j2=j-2 1119 j3=j-3 1120 j4=j-4 1121 j5=j-5 1122 vev=v(j)-ev(iorb) 1123 arp = ar(j1) + abc1*fa(j1)+abc2*fa(j2)+abc3*fa(j3)+ 1124 1 abc4*fa(j4)+abc5*fa(j5) 1125 brp = br(j1) + abc1*fb(j1)+abc2*fb(j2)+abc3*fb(j3)+ 1126 1 abc4*fb(j4)+abc5*fb(j5) 1127 fb1 = b*brp + rab2(j)*vev*arp 1128c 1129c corrector (Adams-Moulton) 1130c 1131 arc = ar(j1) + amc0*brp+amc1*fa(j1)+amc2*fa(j2)+ 1132 1 amc3*fa(j3)+amc4*fa(j4) 1133 brc = br(j1) + amc0*fb1+amc1*fb(j1)+amc2*fb(j2)+ 1134 1 amc3*fb(j3)+amc4*fb(j4) 1135 fb0 = b*brc + rab2(j)*vev*arc 1136c 1137c error reduction step 1138c 1139 ar(j) = arc + amc0*(brc-brp) 1140 br(j) = brc + amc0*(fb0-fb1) 1141 fa(j) = br(j) 1142 fb(j) = b*br(j) + rab2(j)*vev*ar(j) 1143c 1144c count nodes - if no underflow 1145c 1146 if(j.gt.juflow.and.ar(j)*ar(j-1).lt.zero)nodes=nodes+1 1147 40 continue 1148c 1149c njtj *** end major modification *** 1150c 1151 arctp = ar(nctp) 1152 brctp = br(nctp) 1153c 1154c end outward integration 1155c 1156c if number of nodes correct, start inward integration 1157c else modify energy stepwise and try again 1158c 1159 if (evi(iorb) .ne. zero) goto 111 1160 if (nodes .ne. no(iorb)-lo(iorb)-1) then 1161 if (nodes .lt. no(iorb)-lo(iorb)-1) then 1162c 1163c too few nodes; increase ev 1164c 1165 if (ev(iorb) .gt. emin) emin = ev(iorb) 1166 ev(iorb) = ev(iorb) - ev(iorb)/10 1167 else 1168c 1169c too many nodes; decrease ev 1170c 1171 if (ev(iorb) .lt. emax) emax = ev(iorb) 1172 ev(iorb) = ev(iorb) + ev(iorb)/10 1173 endif 1174 itmax = itmax-1 1175 goto 10 1176 endif 1177c 1178c inward integration from ninf to nctp 1179c startup 1180c 1181 do 71 j=ninf,ninf-4,-1 1182 alf = v(j) - ev(iorb) 1183 if (alf .lt. zero) alf = zero 1184 alf = sqrt(alf) 1185 ar(j) = exp(-alf*r(j)) 1186 br(j) = -rab(j)*alf*ar(j) 1187 71 continue 1188c 1189c njtj *** start major modification *** 1190c Array for predictor-corrector added. 1191c 1192 fa(ninf) = br(ninf) 1193 fb(ninf) = b*br(ninf) + rab2(ninf)* 1194 1 (v(ninf)-ev(iorb))*ar(ninf) 1195 ninf1 = ninf - 1 1196 fa(ninf1) = br(ninf1) 1197 fb(ninf1) = b*br(ninf1) + rab2(ninf1)* 1198 1 (v(ninf1)-ev(iorb))*ar(ninf1) 1199 ninf2 = ninf - 2 1200 fa(ninf2) = br(ninf2) 1201 fb(ninf2) = b*br(ninf2) + rab2(ninf2)* 1202 1 (v(ninf2)-ev(iorb))*ar(ninf2) 1203 ninf3 = ninf - 3 1204 fa(ninf3) = br(ninf3) 1205 fb(ninf3) = b*br(ninf3) + rab2(ninf3)* 1206 1 (v(ninf3)-ev(iorb))*ar(ninf3) 1207 ninf4 = ninf - 4 1208 fa(ninf4) = br(ninf4) 1209 fb(ninf4) = b*br(ninf4) + rab2(ninf4)* 1210 1 (v(ninf4)-ev(iorb))*ar(ninf4) 1211c 1212c integration loop 1213c 1214 istop = ninf - nctp 1215 if (istop .lt. 5) goto 222 1216 do 80 j=ninf-5,nctp,-1 1217c 1218c predictor (Adams-Bashforth) 1219c 1220 j1 = j + 1 1221 j2 = j + 2 1222 j3 = j + 3 1223 j4 = j + 4 1224 j5 = j + 5 1225 vev = v(j)-ev(iorb) 1226 arp = ar(j1) - (abc1*fa(j1)+abc2*fa(j2)+abc3*fa(j3)+ 1227 1 abc4*fa(j4)+abc5*fa(j5)) 1228 brp = br(j1) - (abc1*fb(j1)+abc2*fb(j2)+abc3*fb(j3)+ 1229 1 abc4*fb(j4)+abc5*fb(j5)) 1230 fb0 = b*brp + rab2(j)*vev*arp 1231c 1232c corrector (Adams-Moulton) 1233c 1234 arc = ar(j1) - (amc0*brp+amc1*fa(j1)+amc2*fa(j2)+ 1235 1 amc3*fa(j3)+amc4*fa(j4)) 1236 brc = br(j1) - (amc0*fb0+amc1*fb(j1)+amc2*fb(j2)+ 1237 1 amc3*fb(j3)+amc4*fb(j4)) 1238c 1239 fb1 = b*brc + rab2(j)*vev*arc 1240c 1241c error reduction step 1242c 1243 ar(j) = arc - amc0*(brc-brp) 1244 br(j) = brc - amc0*(fb1-fb0) 1245 fa(j) = br(j) 1246 fb(j) = b*br(j) + rab2(j)*vev*ar(j) 1247 80 continue 1248c 1249c end inward integration 1250c 1251c njtj *** end major modification *** 1252c 1253c rescale ar and br outside nctp to match ar(nctp) from 1254c outward integration 1255c 1256 222 factor = arctp/ar(nctp) 1257 do 90 j=nctp,ninf 1258 ar(j) = factor * ar(j) 1259 br(j) = factor * br(j) 1260 90 continue 1261c 1262c find normalizing factor 1263c 1264 factor = zero 1265 ll = 4 1266 do 100 j=2,ninf 1267 factor = factor + ll*ar(j)*ar(j)*rab(j) 1268 ll = 6 - ll 1269 100 continue 1270 factor = factor / 3 1271c 1272c modify eigenvalue ev 1273c 1274 dev = arctp * (brctp-br(nctp)) / (factor * rab(nctp)) 1275 if (5*abs(dev) .gt. -ev(iorb)) dev=dsign(ev(iorb),dev)/5 1276 itmax = itmax-1 1277 evold = ev(iorb) 1278 ev(iorb) = ev(iorb) + dev 1279 if (ev(iorb) .gt. emax) ev(iorb) = (evold + emax) / 2 1280 if (ev(iorb) .lt. emin) ev(iorb) = (evold + emin) / 2 1281 if (abs(dev) .gt. tol*(1-ev(iorb))) goto 10 1282c 1283c normalize wavefunction and change br from d(ar)/dj to d(ar)/dr 1284c 1285 factor = 1 / sqrt(factor) 1286 do 110 j=1,ninf 1287 ar(j) = factor*ar(j) 1288 br(j) = factor*br(j) / rab(j) 1289 110 continue 1290 111 continue 1291 if (evi(iorb) .ne. zero) then 1292 factor = zero 1293 ll = 4 1294 do 112 j=2,nctp 1295 factor = factor + ll*ar(j)*ar(j)*rab(j) 1296 ll = 6 - ll 1297 112 continue 1298 factor = factor / 3 1299 factor = 1 / sqrt(factor) 1300 do 113 j=1,nctp 1301 ar(j) = factor*ar(j) 1302 br(j) = factor*br(j) / rab(j) 1303 113 continue 1304 endif 1305 return 1306 end 1307C 1308C 1309C 1310 subroutine difrel(iter,iorb,v,ar,br,lmax,nr,a,b,r,rab, 1311 1 norb,no,lo,so,znuc,viod,viou,vid,viu,ev,rabkar, 1312 2 rabai,fa,fb,evi) 1313c 1314c difrel integrates the relativistic Dirac equation 1315c it finds the eigenvalue ev, the major and minor component 1316c of the wavefunction, ar and br. It uses an intial guess 1317c for the eigenvalues from dsolv1 1318c 1319c njtj *** modifications *** 1320c This routine has major modifications. 1321c 1)The data needed inside the loops has been calculated 1322c outside the main loop(increases speed for non-opt 1323c compiliers, i.e. dumb compiliers). 1324c 2)The predict/correct values are placed in an array. 1325c Output is unchanged 1326c njtj *** modifications *** 1327c 1328c njtj 1329c ### Cray conversions 1330c ### 1)Comment out implicit double precision. 1331c ### 2)Switch the 3 double precision parameter 1332c ### to single precision parameter statements. 1333c ### Cray conversions 1334c njtj 1335c 1336c njtj 1337c &&& Machine dependent Parameter 1338c &&& The value of expzer is machine dependent. 1339c &&& The user must switch in the correct value for 1340c &&& the machine in use from the list, or find 1341c &&& it for their machine. 1342c &&& Machine dependent Parameter 1343c njtj 1344c 1345 implicit double precision (a-h,o-z) 1346 parameter (zero=0.0,pnine=0.9,one=1.0,ai=2*137.0360411) 1347 parameter (etol=-1.E-7) 1348c 1349c Tolernce 1350c 1351 parameter (tol = 1.D-10,five=5.0D0) 1352Cray parameter (tol = 1.E-10,five=5.0) 1353c 1354c Integration coefficients 1355c 1356 parameter(abc1=190.1/72,abc2=-138.7/36,abc3=10.9/3, 1357 1 abc4=-63.7/36,abc5=25.1/72,amc0=25.1/72,amc1=32.3/36, 1358 2 amc2=-1.1/3,amc3=5.3/36,amc4=-1.9/72) 1359c 1360c 1361 dimension v(nr),ar(nr),br(nr),r(nr),rab(nr), 1362 1 no(norb),lo(norb),so(norb),viod(lmax,nr),viou(lmax,nr), 1363 2 vid(nr),viu(nr),ev(norb),rabkar(nr),rabai(nr), 1364 3 fa(nr),fb(nr),evi(norb) 1365c 1366 dimension rs(5) 1367c 1368c------Machine dependent parameter- 1369c------Require exp(-2*expzer) to be within the range of the machine 1370c 1371cApollo expzer = 3.7D2 1372cSun expzer = 3.7D2 1373 expzer = 3.7D2 1374cVax expzer = 44.D0 1375Cray expzer = 2.8E3 1376c 1377 itmax = 100 1378 ai2 = ai * ai 1379 az = znuc/(2*ai) 1380 ka = lo(iorb)+1 1381 if (so(iorb) .lt. 0.1 .and. lo(iorb) .ne. 0) ka=-lo(iorb) 1382c 1383c determine effective charge and vzero for startup of 1384c outward integration 1385c ar = r**s * (1 + a1 r + a2 r**2 + ... ) 1386c br = r**s * (b0 + b1 r + b2 r**2 + ... ) 1387c s = sqrt (ka**2 - az**2) b0 = - az / (s + ka) 1388c an = (az (v0 - e) a(n-1) - (s + n + ka) (v0 - e - ai**2) b(n-1)) 1389c / (n ai (2 s + n)) 1390c bn = ((v0 - e) a(n-1) - 2 znuc an ) / ( ai (s + n + ka)) 1391c 1392 s = sqrt(ka*ka-az*az) 1393 if (ka .gt. 0) then 1394 b0 = -az/(s+ka) 1395 else 1396 b0 = (s-ka)/az 1397 endif 1398 if (so(iorb) .lt. 0.1) then 1399 vzero=vid(2) 1400 else 1401 vzero=viu(2) 1402 endif 1403c 1404c njtj *** start major modification *** 1405c Loop data calculated only once. 1406c Set ar() and br() to zero. 1407c 1408 do 1 j=1,nr 1409 ar(j) = zero 1410 br(j) = zero 1411 1 continue 1412 do 3 j=2,nr 1413 rabkar(j)=rab(j)*ka/r(j) 1414 3 continue 1415 do 4 j=2,nr 1416 rabai(j)=rab(j)/ai 1417 4 continue 1418 do 5 j=2,5 1419 rs(j)=r(j)**s 1420 5 continue 1421c 1422c set the underflow trap, error from Berkeley version, 1423c fixed by Troy Barbee, sqrt(expzer) should be expzer/2, 1424c 4/17/90. 1425c 1426 juflow=1 1427 do 42 j=2,nr 1428 if (s*abs(log(r(j))) .ge. expzer/2) juflow = j 1429 42 continue 1430c njtj *** end major modification *** 1431c 1432 emax = zero 1433 emin = -one*100000 1434 if (ev(iorb) .gt. emax) ev(iorb) = emax 1435 10 if (itmax .lt. 2) write(6,15) iorb,iter,ev(iorb),nodes 1436 15 format(' iorb =',i3,' iter =',i3,' ev =',e18.10,' nodes =',i2) 1437 if (itmax .eq. 0) return 1438 if (ev(iorb) .gt. zero) then 1439 write(6,1000)iorb 1440 call ext(620+iorb) 1441 endif 1442 1000 format(//,' error in difrel - ev(',i2, 1443 1 ') greater then v(infinty)') 1444c 1445c Find practical infinity ninf and classical turning 1446c point nctp for orbital. 1447c 1448 icount=0 1449 20 icount=icount+1 1450 do 22 j=nr,2,-1 1451 temp = v(j) - ev(iorb) 1452 if (temp .lt. zero) temp = zero 1453 if (r(j)*sqrt(temp) .lt. expzer) goto 23 1454 22 continue 1455 23 ninf=j 1456 nctp = ninf - 5 1457 do 25 j=2,ninf-5 1458 if (v(j) .lt. ev(iorb)) nctp = j 1459 25 continue 1460 if (ev(iorb) .ge. etol*100) nctp=ninf-5 1461 if (ev(iorb) .ge. etol) ev(iorb)=zero 1462 if (evi(iorb) .ne. zero) then 1463 ev(iorb)=evi(iorb) 1464 do 26 j=2,nr 1465 if (r(j) .lt. five) nctp=j 1466 26 continue 1467 endif 1468 if (nctp .le. 6) then 1469 ev(iorb) = pnine*ev(iorb) 1470 if (icount .gt. 100) then 1471 write(6,1010)iorb 1472 call ext(650+iorb) 1473 endif 1474 goto 20 1475 endif 1476 1010 format(//,'error in difrel - cannot find classical', 1477 1 /,'turning point in orbital ',i2) 1478c 1479c Outward integration from 1 to nctp, startup. 1480c 1481 a1 = (az*(vzero-ev(iorb))-(s+1+ka)*(vzero-ev(iorb)-ai2)*b0) 1482 1 / (ai*(2*s+1)) 1483 b1 = ((vzero-ev(iorb))-2*znuc*a1) / (ai*(s+1+ka)) 1484 a2 = (az*(vzero-ev(iorb))*a1-(s+2+ka)*(vzero-ev(iorb)-ai2)*b1) 1485 1 / (2*ai*(2*s+2)) 1486 b2 = ((vzero-ev(iorb))*a1-2*znuc*a2) / (ai*(s+2+ka)) 1487 do 35 j=2,5 1488 ar(j) = rs(j) * (1 +(a1+a2*r(j))*r(j)) 1489 br(j) = rs(j) * (b0+(b1+b2*r(j))*r(j)) 1490 35 continue 1491 fa(1) = zero 1492 fb(1) = zero 1493 fa(2) = rabkar(2)*ar(2)+(ev(iorb)-v(2)+ai2)*br(2)*rabai(2) 1494 fb(2) = -rabkar(2)*br(2)-(ev(iorb)-v(2))*ar(2)*rabai(2) 1495 fa(3) = rabkar(3)*ar(3)+(ev(iorb)-v(3)+ai2)*br(3)*rabai(3) 1496 fb(3) = -rabkar(3)*br(3)-(ev(iorb)-v(3))*ar(3)*rabai(3) 1497 fa(4) = rabkar(4)*ar(4)+(ev(iorb)-v(4)+ai2)*br(4)*rabai(4) 1498 fb(4) = -rabkar(4)*br(4)-(ev(iorb)-v(4))*ar(4)*rabai(4) 1499 fa(5) = rabkar(5)*ar(5)+(ev(iorb)-v(5)+ai2)*br(5)*rabai(5) 1500 fb(5) = -rabkar(5)*br(5)-(ev(iorb)-v(5))*ar(5)*rabai(5) 1501c 1502c Intergration loop. 1503c 1504 nodes = 0 1505 do 40 j=6,nctp 1506c 1507c Predictor (Adams-Bashforth). 1508c 1509 evvai2=ev(iorb)-v(j)+ai2 1510 evv=ev(iorb)-v(j) 1511 arp = ar(j-1) + abc1*fa(j-1)+abc2*fa(j-2)+abc3*fa(j-3) 1512 1 +abc4*fa(j-4)+abc5*fa(j-5) 1513 brp = br(j-1) + abc1*fb(j-1)+abc2*fb(j-2)+abc3*fb(j-3) 1514 1 +abc4*fb(j-4)+abc5*fb(j-5) 1515 fa(j) = rabkar(j)*arp+evvai2*brp*rabai(j) 1516 fb(j) = -rabkar(j)*brp-evv*arp*rabai(j) 1517c 1518c Corrector (Adams-Moulton). 1519c 1520 arc = ar(j-1) + amc0*fa(j)+amc1*fa(j-1)+amc2*fa(j-2) 1521 1 +amc3*fa(j-3)+amc4*fa(j-4) 1522 brc = br(j-1) + amc0*fb(j)+amc1*fb(j-1)+amc2*fb(j-2) 1523 1 +amc3*fb(j-3)+amc4*fb(j-4) 1524 faj = rabkar(j)*arc+evvai2*brc*rabai(j) 1525 fbj = -rabkar(j)*brc-evv*arc*rabai(j) 1526c 1527c Error reduction step. 1528c 1529 ar(j) = arc + amc0*(faj-fa(j)) 1530 br(j) = brc + amc0*(fbj-fb(j)) 1531 fa(j) = rabkar(j)*ar(j)+evvai2*br(j)*rabai(j) 1532 fb(j) = -rabkar(j)*br(j)-evv*ar(j)*rabai(j) 1533c 1534c Count nodes - if no underflow. 1535c 1536 if(j.gt.juflow.and.ar(j)*ar(j-1).lt.zero)nodes=nodes+1 1537 40 continue 1538 arout = ar(nctp) 1539 arpout = fa(nctp) 1540c 1541c End outward integration. 1542c If number of nodes correct, start inward integration 1543c else modify energy stepwise and try again. 1544c 1545 if (evi(iorb) .ne. zero) goto 111 1546 if (nodes .ne. no(iorb)-lo(iorb)-1) then 1547c 1548c too many nodes decrease ev 1549c 1550 if (nodes .gt. no(iorb)-lo(iorb)-1) then 1551 if (ev(iorb) .lt. emax) emax = ev(iorb) 1552 ev(iorb) = ev(iorb) + ev(iorb)/10 1553c 1554c too few nodes increase ev 1555c 1556 else 1557 if (ev(iorb) .gt. emin) emin = ev(iorb) 1558 ev(iorb) = ev(iorb) - ev(iorb)/10 1559 endif 1560 itmax = itmax-1 1561 goto 10 1562 endif 1563c 1564c Inward integration from ninf to nctp startup. 1565c 1566 do 70 j=ninf,ninf-4,-1 1567 alf = v(j) - ev(iorb) 1568 if (alf .lt. zero) alf = zero 1569 alf = sqrt(alf) 1570 ar(j) = exp(-alf*r(j)) 1571 br(j) = ai*(alf+ka/r(j))*ar(j)/(v(j)-ev(iorb)-ai2) 1572 70 continue 1573 fa(ninf) = rabkar(ninf)*ar(ninf)+ 1574 1 (ev(iorb)-v(ninf)+ai2)*br(ninf)*rabai(ninf) 1575 fb(ninf) = -rabkar(ninf)*br(ninf) 1576 1 -(ev(iorb)-v(ninf))*ar(ninf)*rabai(ninf) 1577 fa(ninf-1) = rabkar(ninf-1)*ar(ninf-1)+ 1578 1 (ev(iorb)-v(ninf-1)+ai2)*br(ninf-1)*rabai(ninf-1) 1579 fb(ninf-1) = -rabkar(ninf-1)*br(ninf-1) 1580 1 -(ev(iorb)-v(ninf-1))*ar(ninf-1)*rabai(ninf-1) 1581 fa(ninf-2) = rabkar(ninf-2)*ar(ninf-2) 1582 1 +(ev(iorb)-v(ninf-2)+ai2)*br(ninf-2)*rabai(ninf-2) 1583 fb(ninf-2) = -rabkar(ninf-2)*br(ninf-2) 1584 1 -(ev(iorb)-v(ninf-2))*ar(ninf-2)*rabai(ninf-2) 1585 fa(ninf-3) = rabkar(ninf-3)*ar(ninf-3) 1586 1 +(ev(iorb)-v(ninf-3)+ai2)*br(ninf-3)*rabai(ninf-3) 1587 fb(ninf-3) = -rabkar(ninf-3)*br(ninf-3) 1588 1 -(ev(iorb)-v(ninf-3))*ar(ninf-3)*rabai(ninf-3) 1589 fa(ninf-4) = rabkar(ninf-4)*ar(ninf-4) 1590 1 +(ev(iorb)-v(ninf-4)+ai2)*br(ninf-4)*rabai(ninf-4) 1591 fb(ninf-4) = -rabkar(ninf-4)*br(ninf-4) 1592 1 -(ev(iorb)-v(ninf-4))*ar(ninf-4)*rabai(ninf-4) 1593c 1594c Integration loop. 1595c 1596 istop = ninf-nctp 1597 if (istop .lt. 5) goto 222 1598 do 80 j=ninf-5,nctp,-1 1599c 1600c Predictor (Adams-Bashforth). 1601c 1602 evvai2=ev(iorb)-v(j)+ai2 1603 evv=ev(iorb)-v(j) 1604 arp = ar(j+1)-(abc1*fa(j+1)+abc2*fa(j+2)+abc3*fa(j+3) 1605 1 +abc4*fa(j+4)+abc5*fa(j+5)) 1606 brp = br(j+1)-(abc1*fb(j+1)+abc2*fb(j+2)+abc3*fb(j+3) 1607 1 +abc4*fb(j+4)+abc5*fb(j+5)) 1608 fa(j) = rabkar(j)*arp+evvai2*brp*rabai(j) 1609 fb(j) = -rabkar(j)*brp-evv*arp*rabai(j) 1610c 1611c Corrector (Adams-Moulton). 1612c 1613 arc = ar(j+1)-(amc0*fa(j)+amc1*fa(j+1)+amc2*fa(j+2) 1614 1 +amc3*fa(j+3)+amc4*fa(j+4)) 1615 brc = br(j+1)-(amc0*fb(j)+amc1*fb(j+1)+amc2*fb(j+2) 1616 1 +amc3*fb(j+3)+amc4*fb(j+4)) 1617 faj = rabkar(j)*arc+evvai2*brc*rabai(j) 1618 fbj = -rabkar(j)*brc-evv*arc*rabai(j) 1619c 1620c Error reduction step. 1621c 1622 ar(j) = arc + amc0*(faj-fa(j)) 1623 br(j) = brc + amc0*(fbj-fb(j)) 1624 fa(j) = rabkar(j)*ar(j)+evvai2*br(j)*rabai(j) 1625 fb(j) = -rabkar(j)*br(j)-evv*ar(j)*rabai(j) 1626 80 continue 1627 222 arin = ar(nctp) 1628 arpin = fa(nctp) 1629c 1630c End inward integration 1631c Rescale ar and br outside nctp to match ar(nctp) from 1632c outward integration. 1633c 1634 factor = arout/arin 1635 do 90 j=nctp,ninf 1636 ar(j) = factor * ar(j) 1637 br(j) = factor * br(j) 1638 90 continue 1639 arpin = factor * arpin 1640c 1641c Find the normalizing factor. 1642c 1643 factor = zero 1644 ll = 4 1645 do 100 j=2,ninf 1646 factor = factor + ll*(ar(j)*ar(j)+br(j)*br(j))*rab(j) 1647 ll = 6 - ll 1648 100 continue 1649 factor = factor / 3 1650c 1651c Modify the eigenvalue ev. 1652c 1653 dev = arout * (arpout-arpin) / (factor * rab(nctp)) 1654 if (5*abs(dev) .gt. -ev(iorb)) dev=dsign(ev(iorb),dev)/5 1655 itmax = itmax-1 1656 evold = ev(iorb) 1657 ev(iorb) = ev(iorb) + dev 1658 if (ev(iorb) .gt. emax) then 1659 ev(iorb) = (evold + emax) / 2 1660 elseif (ev(iorb) .lt. emin) then 1661 ev(iorb) = (evold + emin) / 2 1662 endif 1663 if (abs(dev) .gt. tol*(1-ev(iorb))) goto 10 1664c 1665c Normalize the wavefunction. 1666c 1667 factor = 1 / sqrt(factor) 1668 do 110 j=1,ninf 1669 ar(j) = factor*ar(j) 1670 br(j) = factor*br(j) 1671 110 continue 1672 111 continue 1673 if (evi(iorb) .ne. zero) then 1674 factor = zero 1675 ll = 4 1676 do 112 j=2,nctp 1677 factor = factor + ll*(ar(j)*ar(j)+br(j)*br(j))*rab(j) 1678 ll = 6 - ll 1679 112 continue 1680 factor = factor / 3 1681 factor = 1 / sqrt(factor) 1682 do 113 j=1,nctp 1683 ar(j) = factor*ar(j) 1684 br(j) = factor*br(j) 1685 113 continue 1686 endif 1687 return 1688 end 1689C 1690C 1691C 1692 SUBROUTINE DMIXP(A,B,BETA,ICY,ID,NMSH, 1693 1 C,D,VN1,VN12,VN2,VN22) 1694C* ADAPTED FROM K.C.PANDEY 1695C* USING ANDERSON'S EXTRAPOLATION SCHEME 1696C* EQS 4.1-4.9,4.15-4.18 OF 1697C* D.G.ANDERSON J.ASSOC.COMPUTING MACHINERY,12,547(1965) 1698C* COMPUTES A NEW VECTOR IN A ITERATIVE SCHEME 1699C* INPUT A=NEWPOT B=OLDPOT 1700C* OUTPUT A=A-B B=NEWPOT 1701C* BETA=MIXING,IN=ITER. NUMBER 1702C* ID=1,2 OR 3 DIFF CONV METH. 1703C* ICY CYCLE NUMBER ,ICY=1 ON FIRST/ZEROTH CALL 1704C* C,D WORK ARRAYS OF SIZE NMSH 1705C* VN1,VN12,VN2,VN22 STORAGE ARRAYS OF SIZE NMSH 1706C 1707C njtj 1708C ### Cray conversions 1709C ### 1)Comment out implicit double precision. 1710C ### 2)Switch double precision parameter 1711C ### to single precision parameter statement. 1712C ### Cray conversions 1713C njtj 1714C 1715C 1716 implicit double precision (a-h,o-z) 1717 PARAMETER (UZE=0.0D0,UM=1.0D0,DETOL=1.D-9) 1718Cray PARAMETER (UZE=0.0,UM=1.0,DETOL=1.E-9) 1719C 1720 DIMENSION A(NMSH),B(NMSH),C(NMSH),D(NMSH) 1721 DIMENSION VN1(NMSH),VN12(NMSH),VN2(NMSH),VN22(NMSH) 1722 IN=ICY-1 1723 IF(IN.EQ.0) THEN 1724 CALL TRNSVV(B,A,UM,NMSH) 1725 RETURN 1726 ENDIF 1727 CALL TRNSVV(A,B,-UM,NMSH) 1728 CALL DOTTVV(A,A,R2,NMSH) 1729 IF(ID.EQ.1) THEN 1730 CALL TRNSVV(B,A,BETA,NMSH) 1731 RETURN 1732 ENDIF 1733 IF(IN.EQ.1) THEN 1734 DO 100 I=1,NMSH 1735 VN1(I)=A(I) 1736 100 CONTINUE 1737 DO 105 I=1,NMSH 1738 VN2(I)=B(I) 1739 105 CONTINUE 1740 CALL TRNSVV(B,A,BETA,NMSH) 1741 RETURN 1742 ENDIF 1743 DO 110 I=1,NMSH 1744 C(I)=VN1(I) 1745 110 CONTINUE 1746 IF(ID.EQ.3.AND.IN.GT.2) THEN 1747 DO 115 I=1,NMSH 1748 D(I)=VN12(I) 1749 115 CONTINUE 1750 ENDIF 1751 DO 120 I=1,NMSH 1752 VN1(I)=A(I) 1753 120 CONTINUE 1754 IF(ID.GT.2.AND.IN.GT.1) THEN 1755 DO 125 I=1,NMSH 1756 VN12(I)=C(I) 1757 125 CONTINUE 1758 ENDIF 1759 CALL TRNSVV(C,A,-UM,NMSH) 1760 CALL DOTTVV(C,C,D11,NMSH) 1761 CALL DOTTVV(A,C,RD1M,NMSH) 1762 IF(IN.LE.2.OR.ID.LE.2) THEN 1763 T1=-RD1M/D11 1764 X=UM-T1 1765 BT1=BETA*T1 1766 DO 5 I=1,NMSH 1767 A(I)=BETA*A(I) 1768 5 CONTINUE 1769 CALL TRNSVV(A,C,BT1,NMSH) 1770 DO 130 I=1,NMSH 1771 D(I)=VN2(I) 1772 130 CONTINUE 1773 CALL TRNSVV(A,D,T1,NMSH) 1774 DO 135 I=1,NMSH 1775 VN2(I)=B(I) 1776 135 CONTINUE 1777 IF(ID.GT.2.AND.IN.EQ.2) THEN 1778 DO 140 I=1,NMSH 1779 VN22(I)=D(I) 1780 140 CONTINUE 1781 ENDIF 1782 DO 10 I=1,NMSH 1783 B(I)=X*B(I)+A(I) 1784 10 CONTINUE 1785 RETURN 1786 ENDIF 1787 CALL TRNSVV(D,A,-UM,NMSH) 1788 CALL DOTTVV(D,D,D22,NMSH) 1789 CALL DOTTVV(C,D,D12,NMSH) 1790 CALL DOTTVV(A,D,RD2M,NMSH) 1791 A2=D11*D22 1792 DET=A2-D12*D12 1793 DETT=DET/A2 1794 IF(ABS(DETT).GE.DETOL) THEN 1795 T1=(-RD1M*D22+RD2M*D12)/DET 1796 T2=( RD1M*D12-RD2M*D11)/DET 1797 ELSE 1798 T1=-RD1M/D11 1799 T2=UZE 1800 ENDIF 1801 X=UM-T1-T2 1802 BT1=BETA*T1 1803 BT2=BETA*T2 1804 DO 15 I=1,NMSH 1805 A(I)=BETA*A(I) 1806 15 CONTINUE 1807 CALL TRNSVV(A,C,BT1,NMSH) 1808 CALL TRNSVV(A,D,BT2,NMSH) 1809 CALL TRNSVV(A,VN2,T1,NMSH) 1810 CALL TRNSVV(A,VN22,T2,NMSH) 1811 DO 145 I=1,NMSH 1812 VN22(I)=VN2(I) 1813 145 CONTINUE 1814 DO 155 I=1,NMSH 1815 VN2(I)=B(I) 1816 155 CONTINUE 1817 DO 20 I=1,NMSH 1818 B(I)=X*B(I)+A(I) 1819 20 CONTINUE 1820 RETURN 1821 END 1822C 1823C 1824C 1825 subroutine dottvv(a,b,c,n) 1826c 1827c njtj 1828c ### Cray conversions 1829c ### 1)Comment out implicit double precision. 1830c ### 2)Switch 1 function line from double 1831c ### precision to a single precision statement. 1832c ### Cray conversions 1833c njtj 1834c 1835 implicit double precision (a-h,o-z) 1836c 1837 dimension a(n),b(n) 1838c 1839 c=0.0 1840c 1841 do 10 i=1,n 1842 c=c+a(i)*b(i) 1843 10 continue 1844 return 1845 end 1846C 1847C 1848C 1849 subroutine dsolv1(lmax,nr,a,b,r,rab,norb,ncore, 1850 1 no,lo,so,zo,cdd,cdu,viod,viou,vid,viu, 1851 3 ev,dk,d,sd,sd2,rv1,rv2,rv3,rv4,rv5,z) 1852c 1853c dsolv1 finds the (non)-relativistic wave function 1854c using finite differences and matrix diagonalization. 1855c An initial guess for the eigenvalues need not be supplied. 1856c 1857c njtj 1858c ### Cray conversions 1859c ### 1)Comment out implicit double precision. 1860c ### 2)Switch double precision parameter 1861c ### to single precision parameter statement. 1862c ### Cray conversions 1863c njtj 1864c 1865 implicit double precision (a-h,o-z) 1866c 1867 parameter (zero=0.D0,one=1.D0,pone=0.1D0,opf=1.5D0) 1868Cray parameter (zero=0.0,one=1.0,pone=0.1,opf=1.5) 1869c 1870 dimension r(nr),rab(nr),no(norb),lo(norb),so(norb), 1871 1 zo(norb),cdd(nr),cdu(nr),viod(lmax,nr),viou(lmax,nr), 1872 2 vid(nr),viu(nr),ev(norb),dk(nr),d(nr),sd(nr),sd2(nr), 1873 2 z(6*nr),rv1(nr),rv2(nr),rv3(nr),rv4(nr),rv5(nr) 1874c 1875 dimension nmax(2,5),e(10),ind(10) 1876c 1877c Initialize the charge density arrays. 1878c 1879 do 10 i=1,nr 1880 cdd(i) = zero 1881 cdu(i) = zero 1882 10 continue 1883c 1884c Find the max n given l and s. 1885c Zero spin is treated as down. 1886c 1887 do 20 i=1,2 1888 do 20 j=1,lmax 1889 nmax(i,j) = 0 1890 do 20 k=1,norb 1891 if (no(k) .le. 0) goto 20 1892 if (lo(k) .ne. j-1) goto 20 1893 if ((so(k)-pone)*(i-opf) .lt. zero) goto 20 1894 nmax(i,j)=no(k) 1895 20 continue 1896c 1897c Set up hamiltonian matrix for kinetic energy. 1898c Only the diagonal depends on the potential. 1899c 1900 c2 = -one/b**2 1901 c1 = -2*one*c2 + one/4 1902 dk(1) = c1 / (r(2)+a)**2 1903 sd(1) = zero 1904 sd2(1) = zero 1905 do 30 i=3,nr 1906 dk(i-1) = c1 / (r(i)+a)**2 1907 sd(i-1) = c2 / ((r(i)+a)*(r(i-1)+a)) 1908 sd2(i-1) = sd(i-1)**2 1909 30 continue 1910c 1911c Start loop over spin down=1 and spin up=2. 1912c 1913 nrm = nr - 1 1914 do 80 i=1,2 1915c 1916c Start loop over s p d... states. 1917c 1918 do 80 j=1,lmax 1919 if (nmax(i,j) .eq. 0) goto 80 1920 llp = j*(j-1) 1921 do 40 k=2,nr 1922 if (i .eq. 1) then 1923 d(k-1)=dk(k-1)+(viod(j,k)+llp/r(k))/r(k)+vid(k) 1924 else 1925 d(k-1)=dk(k-1)+(viou(j,k)+llp/r(k))/r(k)+viu(k) 1926 endif 1927 40 continue 1928c 1929c Diagonalize the matrix. 1930c 1931 eps = -one 1932 call tridib(nrm,eps,d,sd,sd2,bl,bu,1, 1933 1 nmax(i,j),e,ind,ierr,rv4,rv5) 1934 if (ierr .ne. 0) write(6,50) ierr 1935 50 format(/,' error in tridib ****** ierr =',i3,/) 1936 call tinvit(nrm,nrm,d,sd,sd2,nmax(i,j),e,ind,z,ierr, 1937 1 rv1,rv2,rv3,rv4,rv5) 1938 if (ierr .ne. 0) write(6,55) ierr 1939 55 format(/,' error in tinvit ****** ierr =',i3,/) 1940c 1941c Save the energy levels and add to charge density. 1942c 1943 ki = 1 1944 kn = 0 1945 do 70 k=1,norb 1946 if (no(k) .le. 0) goto 70 1947 if (lo(k) .ne. j-1) goto 70 1948 if ((so(k)-pone)*(i-opf) .lt. zero) goto 70 1949 ev(k) = e(ki) 1950 do 60 l=2,nr 1951 denr = zo(k) * z(kn+l-1)**2 / rab(l) 1952 if (i .eq. 1) then 1953 cdd(l) = cdd(l) + denr 1954 else 1955 cdu(l) = cdu(l) + denr 1956 endif 1957 60 continue 1958 ki = ki + 1 1959 kn = kn + nrm 1960 70 continue 1961 80 continue 1962c 1963c End loop over s p and d states. 1964c 1965 return 1966 end 1967C 1968C 1969C 1970 subroutine dsolv2(iter,iconv,ispp,ifcore,lmax,nr,a,b,r, 1971 1 rab,norb,ncore,no,lo,so,zo,znuc,cdd,cdu,cdc,viod, 1972 2 viou,vid,viu,ev,ek,ep,wk1,wk2,wk3,wk4,v,ar,br,evi) 1973c 1974c dsolv2 finds the (non) relativistic wave function using 1975c difnrl to intgrate the Scroedinger equation or 1976c difrel to intgrate the Dirac equation. 1977c The energy level from the previous iteration is used 1978c as initial guess, and it must therefore be reasonable 1979c accurate. 1980c 1981c njtj 1982c ### Cray conversions 1983c ### 1)Comment out implicit double precision. 1984c ### 2)Switch double precision parameter 1985c ### to single precision parameter statement. 1986c ### Cray conversions 1987c njtj 1988c 1989 implicit double precision (a-h,o-z) 1990c 1991 character*1 ispp 1992c 1993 parameter (zero=0.D0,smev=1.D-4) 1994Cray parameter (zero=0.0,smev=1.E-4) 1995c 1996 dimension r(nr),rab(nr),no(norb),lo(norb),so(norb),zo(norb), 1997 1 cdd(nr),cdu(nr),cdc(nr),viod(lmax,nr),viou(lmax,nr), 1998 2 vid(nr),viu(nr),ev(norb),ek(norb),ep(norb),evi(norb), 1999 3 wk1(nr),wk2(nr),wk3(nr),wk4(nr),v(nr),ar(nr),br(nr) 2000c 2001c Initialize arrays for charge density. 2002c 2003 do 5 i=1,nr 2004 cdd(i) = zero 2005 5 continue 2006 do 10 i=1,nr 2007 cdu(i) = zero 2008 10 continue 2009 if (ifcore .eq. 0) then 2010 do 15 i=1,nr 2011 cdc(i)= zero 2012 15 continue 2013 endif 2014c 2015c Start the loop over orbitals. 2016c Note that spin zero is treated as down. 2017c 2018 do 50 i=1,norb 2019 if (no(i) .le. 0) goto 50 2020 if (zo(i) .eq. 0.0 .and. iconv .eq. 0) goto 50 2021 if (ev(i) .ge. 0.0) ev(i)=-smev 2022c 2023c Set up the potential, set the wave functionc array to zero-ar. 2024c 2025 lp = lo(i)+1 2026 llp = lo(i)*lp 2027 do 17 j=1,nr 2028 ar(j)=zero 2029 17 continue 2030 if (so(i) .lt. 0.1) then 2031 do 18 j=2,nr 2032 v(j) = viod(lp,j)/r(j) + vid(j) 2033 18 continue 2034 else 2035 do 19 j=2,nr 2036 v(j) = viou(lp,j)/r(j) + viu(j) 2037 19 continue 2038 endif 2039 if (ispp .ne. 'r') then 2040 do 20 j=2,nr 2041 v(j) = v(j) + llp/r(j)**2 2042 20 continue 2043 endif 2044c 2045c Call the integration routine. 2046c 2047 if (ispp .ne. 'r') then 2048 call difnrl(iter,i,v,ar,br,lmax,nr,a,b,r, 2049 1 rab,norb,no,lo,so,znuc,viod,viou,vid,viu, 2050 2 ev,iflag,wk1,wk2,wk3,evi) 2051 else 2052 call difrel(iter,i,v,ar,br,lmax,nr,a,b,r, 2053 1 rab,norb,no,lo,so,znuc,viod,viou,vid,viu, 2054 2 ev,wk1,wk2,wk3,wk4,evi) 2055 endif 2056c 2057c Add to the charge density. 2058c 2059 if (ispp .eq. 'r') then 2060 if (so(i) .lt. 0.1) then 2061 do 30 j=1,nr 2062 denr = zo(i) *(br(j) * br(j) + ar(j) * ar(j)) 2063 cdd(j) = cdd(j) + denr 2064 30 continue 2065 else 2066 do 31 j=1,nr 2067 denr = zo(i) *(br(j) * br(j) + ar(j) * ar(j)) 2068 cdu(j) = cdu(j) + denr 2069 31 continue 2070 endif 2071 else 2072 if (so(i) .lt. 0.1) then 2073 do 32 j=1,nr 2074 denr = zo(i) * ar(j) * ar(j) 2075 cdd(j) = cdd(j) + denr 2076 32 continue 2077 else 2078 do 33 j=1,nr 2079 denr = zo(i) * ar(j) * ar(j) 2080 cdu(j) = cdu(j) + denr 2081 33 continue 2082 endif 2083 endif 2084 if (ifcore .eq. 0 .and. i .le. ncore) then 2085 do 34 j=1,nr 2086 denr = zo(i) * ar(j) * ar(j) 2087 cdc(j)=cdc(j)+denr 2088 34 continue 2089 endif 2090c 2091c Compute various quantitities if last iteration. 2092c 2093 if (iconv .eq. 1) call orban(ispp,i,ar,br, 2094 1 lmax,nr,a,b,r,rab,norb,no,lo,zo,so,viod,viou, 2095 2 vid,viu,ev,ek,ep) 2096 50 continue 2097c 2098c End loop over orbitals. 2099c 2100 return 2101 end 2102C 2103C 2104C 2105 subroutine etotal(itype,zsh,nameat,norb, 2106 1 no,lo,so,zo,etot,ev,ek,ep) 2107c 2108c etotal computes the total energy from the 2109c electron charge density. 2110c 2111c njtj 2112c ### Cray conversions 2113c ### 1)Comment out implicit double precision. 2114c ### 2)Switch double precision parameter 2115c ### to single precision parameter statement. 2116c ### Cray conversions 2117c njtj 2118c 2119 implicit double precision (a-h,o-z) 2120 parameter (zero=0.D0) 2121Cray parameter (zero=0.0) 2122c 2123c 2124 character*1 il(5) 2125 character*2 nameat 2126c 2127 dimension no(norb),lo(norb),so(norb),zo(norb), 2128 1 etot(10),ev(norb),ek(norb),ep(norb) 2129c 2130c etot(i) i=1,10 contains various contributions to the total 2131c energy. 2132c (1) sum of eigenvalues ev 2133c (2) sum of orbital kinetic energies ek 2134c (3) el-ion interaction from sum of orbital 2135c potential energies ep 2136c (4) electrostatic el-el interaction (from velect) 2137c (5) vxc (exchange-correlation) correction to sum 2138c of eigenvalues (from velect) 2139c (6) 3 * vc - 4 * ec 2140c correction term for virial theorem 2141c when correlation is included (from velect) 2142c (7) exchange and correlation energy (from velect) 2143c (8) kinetic energy from eigenvalues (1,3,4,5) 2144c (9) potential energy 2145c (10) total energy 2146c 2147c 2148c sum up eigenvalues ev, kinetic energies ek, and 2149c el-ion interaction ep 2150c 2151 etot(1) = zero 2152 etot(2) = zero 2153 etot(3) = zero 2154 do 10 i=1,norb 2155 etot(1) = etot(1) + zo(i)*ev(i) 2156 etot(2) = etot(2) + zo(i)*ek(i) 2157 etot(3) = etot(3) + zo(i)*ep(i) 2158 10 continue 2159c 2160c kinetic energy 2161c 2162 etot(8) = etot(1) - etot(3) - 2*etot(4) - etot(5) 2163c 2164c potential energy 2165c 2166 etot(9) = etot(3) + etot(4) + etot(7) 2167c 2168c total energy 2169c 2170 etot(10) = etot(1) - etot(4) - etot(5) + etot(7) 2171c 2172c printout 2173c 2174 il(1) = 's' 2175 il(2) = 'p' 2176 il(3) = 'd' 2177 il(4) = 'f' 2178 il(5) = 'g' 2179 write(6,20) nameat 2180 20 format(//,1x,a2,' output data for orbitals',/,1x,28('-'),//, 2181 1 ' nl s occ',9x,'eigenvalue',4x,'kinetic energy', 2182 2 6x,'pot energy',/) 2183 do 40 i=1,norb 2184 write(6,30) no(i),il(lo(i)+1),so(i),zo(i),ev(i),ek(i),ep(i) 2185 30 format(1x,i1,a1,f6.1,f10.4,3f17.8) 2186 40 continue 2187 write(6,50) (etot(i),i=1,10) 2188 50 format(//,' total energies',/,1x,14('-'),/, 2189 1 /,' sum of eigenvalues =',f18.8, 2190 2 /,' kinetic energy from ek =',f18.8, 2191 3 /,' el-ion interaction energy =',f18.8, 2192 4 /,' el-el interaction energy =',f18.8, 2193 5 /,' vxc correction =',f18.8, 2194 6 /,' virial correction =',f18.8, 2195 7 /,' exchange + corr energy =',f18.8, 2196 8 /,' kinetic energy from ev =',f18.8, 2197 9 /,' potential energy =',f18.8,/,1x,45('-'), 2198 X /,' total energy =',f18.8) 2199 if (itype .ge. 4 .or. abs(zsh) .gt. 0.00001) return 2200c 2201c virial theorem 2202c 2203 vsum = 2*etot(8) + etot(9) + etot(6) 2204 write(6,60) 2*etot(8),etot(9),etot(6),vsum 2205 60 format(//,' virial theorem(nonrelativistic)',/,1x,14('-'),/, 2206 1 /,' kinetic energy * 2 =',f18.8, 2207 2 /,' potential energy =',f18.8, 2208 3 /,' virial correction =',f18.8,/,1x,45('-'), 2209 4 /,' virial sum =',f18.8) 2210 return 2211 end 2212C 2213C 2214C 2215 subroutine ext(i) 2216c 2217c Stops program in case of errors or completion. 2218c 2219c i is a stop parameter 2220c 000-099 main (0 is normal exit) 2221c 100-199 input 2222c 200-299 charge 2223c 300-399 vionic 2224c 400-499 velect 2225c 500-599 dsolv1 2226c 600-699 dsolv2 (including difnrl and difrel) 2227c 700-799 etotal 2228c 800-899 pseudo, pseudk, pseudt and pseudv 2229c 2230 if (i .ne. 0) write(6,10) i 2231 10 format('stop parameter =',i3) 2232 close (unit=1) 2233 close (unit=3) 2234 close (unit=5) 2235 close (unit=6) 2236 call exit 2237 end 2238C 2239C 2240C 2241 subroutine gamfn2(rc1,rc2,rc3,rc4,rc5,rc6,rc7,rc8,lp, 2242 1 arc,brc,vrc,vap,vapp,ev,cdrc,r,rab,jrc,delta,gamma, 2243 2 alpha,alpha1,alpha2,alpha3,alpha4,v0pp,ar) 2244c 2245c ********************************************************* 2246c * * 2247c * njtj * 2248c * Retuns the values of delta, alpha, alpha1, alpha2, * 2249c * alpha3, and alpha4 given a fixed value of gamma. * 2250c * Returns V"(0) for the braketing and bisection * 2251c * routines. Subroutine used in pseudtk routine. * 2252c * njtj * 2253c * * 2254c ********************************************************* 2255c 2256c njtj 2257c ### Cray conversions 2258c ### 1)Comment out implicit double precision. 2259c ### 2)Switch double precision parameter 2260c ### to single precision parameter statement. 2261c ### Cray conversions 2262c njtj 2263c 2264 implicit double precision (a-h,o-z) 2265c 2266 dimension r(jrc),rab(jrc),aj(5,5),bj(5),ar(jrc) 2267c 2268 parameter (zero=0.D0,pfive=0.5D0,one=1.D0,errmin=1.D-12) 2269Cray parameter (zero=0.0,pfive=0.5,one=1.0,errmin=1.E-12) 2270c 2271 rc9 = rc8*rc1 2272 rc10 = rc8*rc2 2273 rc11 = rc8*rc3 2274 rc12 = rc8*rc4 2275 delta=zero 2276 bj(1)=log(arc/rc1**lp)-gamma*rc2 2277 bj1=bj(1) 2278 bj(2)=brc-lp/rc1-2*gamma*rc1 2279 bj2a=bj(2)+2*gamma*rc1 2280 bj2=bj(2) 2281 bj(3)=vrc-ev-2*lp/rc1*bj2a-bj2a**2-2*gamma 2282 bj3=bj(3) 2283 bj3a=bj(3)+2*gamma 2284 bj(4)=vap+2*lp/rc2*bj2a-2*lp/rc1*bj3a-2*bj2a*bj3a 2285 bj4=bj(4) 2286 bj(5)=vapp-4*lp/rc3*bj2a+4*lp/rc2*bj3a-2*lp/rc1*bj4-2*bj3a**2 2287 1 -2*bj2a*bj4 2288 bj5=bj(5) 2289 aj(1,1)=rc4 2290 aj(1,2)=rc6 2291 aj(1,3)=rc8 2292 aj(1,4)=rc10 2293 aj(1,5)=rc12 2294 aj(2,1)=4*rc3 2295 aj(2,2)=6*rc5 2296 aj(2,3)=8*rc7 2297 aj(2,4)=10*rc9 2298 aj(2,5)=12*rc11 2299 aj(3,1)=12*rc2 2300 aj(3,2)=30*rc4 2301 aj(3,3)=56*rc6 2302 aj(3,4)=90*rc8 2303 aj(3,5)=132*rc10 2304 aj(4,1)=24*rc1 2305 aj(4,2)=120*rc3 2306 aj(4,3)=336*rc5 2307 aj(4,4)=720*rc7 2308 aj(4,5)=1320*rc9 2309 aj(5,1)=24*one 2310 aj(5,2)=360*rc2 2311 aj(5,3)=1680*rc4 2312 aj(5,4)=5040*rc6 2313 aj(5,5)=11880*rc8 2314 call gaussj(aj,5,5,bj,1,1) 2315 alpha=bj(1) 2316 alpha1=bj(2) 2317 alpha2=bj(3) 2318 alpha3=bj(4) 2319 alpha4=bj(5) 2320c 2321c start iteration loop to find delta(with gamma fixed) 2322c 2323 do 550 j=1,200 2324c 2325c generate pseudo wavefunction-note missing factor exp(delta) 2326c 2327 do 560 k=1,jrc 2328 rp=r(k) 2329 r2=rp*rp 2330 polyr = r2*(((((alpha4*r2+alpha3)*r2+alpha2)*r2+ 2331 1 alpha1)*r2+ alpha)*r2+gamma) 2332 ar(k) = rp**lp * exp(polyr) 2333 560 continue 2334c 2335c integrate pseudo charge density from r = 0 to rc 2336c 2337 ll = 2 2338 cdps = - ar(jrc) * ar(jrc) * rab(jrc) 2339 if (jrc .ne. 2*(jrc/2)) then 2340 do 120 k=jrc,1,-1 2341 cdps = cdps + ll * ar(k) * ar(k) * rab(k) 2342 ll = 6 - ll 2343 120 continue 2344 else 2345 do 121 k=jrc,4,-1 2346 cdps = cdps + ll * ar(k) * ar(k) * rab(k) 2347 ll = 6 - ll 2348 121 continue 2349 cdps = cdps - ar(4) * ar(4) * rab(4) 2350 cdps = cdps + 9 * ( ar(1) * ar(1) * rab(1) + 2351 1 3 * ar(2) *ar(2) * rab(2) + 2352 2 3 * ar(3) *ar(3) * rab(3) + 2353 3 ar(4) * ar(4) * rab(4))/8 2354 endif 2355 cdps = cdps/3 2356c 2357c Calculate new delta(with gamma fixed), uses false position 2358c 2359 fdnew = log(cdrc/cdps) - 2*delta 2360 if (abs(fdnew) .lt. errmin) then 2361 v0pp=8*((2*one*(lp-one)+5*one)*alpha+gamma**2) 2362 return 2363 endif 2364 if (j .eq. 1) then 2365 ddelta=-pfive 2366 else 2367 ddelta = - fdnew * ddelta / (fdnew-fdold) 2368 endif 2369 delta = delta + ddelta 2370 bj(1)=bj1-delta 2371 bj(2)=bj2 2372 bj(3)=bj3 2373 bj(4)=bj4 2374 bj(5)=bj5 2375 aj(1,1)=rc4 2376 aj(1,2)=rc6 2377 aj(1,3)=rc8 2378 aj(1,4)=rc10 2379 aj(1,5)=rc12 2380 aj(2,1)=4*rc3 2381 aj(2,2)=6*rc5 2382 aj(2,3)=8*rc7 2383 aj(2,4)=10*rc9 2384 aj(2,5)=12*rc11 2385 aj(3,1)=12*rc2 2386 aj(3,2)=30*rc4 2387 aj(3,3)=56*rc6 2388 aj(3,4)=90*rc8 2389 aj(3,5)=132*rc10 2390 aj(4,1)=24*rc1 2391 aj(4,2)=120*rc3 2392 aj(4,3)=336*rc5 2393 aj(4,4)=720*rc7 2394 aj(4,5)=1320*rc9 2395 aj(5,1)=24*one 2396 aj(5,2)=360*rc2 2397 aj(5,3)=1680*rc4 2398 aj(5,4)=5040*rc6 2399 aj(5,5)=11880*rc8 2400 call gaussj(aj,5,5,bj,1,1) 2401 alpha=bj(1) 2402 alpha1=bj(2) 2403 alpha2=bj(3) 2404 alpha3=bj(4) 2405 alpha4=bj(5) 2406 fdold = fdnew 2407 550 continue 2408 write(6,1000) 2409 1000 format(//, 'error in gamfind - delta not found') 2410 call ext(860+lp) 2411 end 2412C 2413C 2414C 2415 subroutine gamfnd(rc1,rc2,rc3,rc4,rc5,rc6,rc7,rc8,lp, 2416 1 arc,brc,vrc,vap,vapp,ev,cdrc,r,rab,jrc,delta,gamma, 2417 2 alpha,alpha1,alpha2,alpha3,alpha4,v0pp,ar) 2418c 2419c ********************************************************* 2420c * * 2421c * njtj * 2422c * Retuns the values of delta, alpha, alpha1, alpha2, * 2423c * alpha3, and alpha4 given a fixed value of gamma. * 2424c * Returns V"(0) for the braketing and bisection * 2425c * routines. Subroutine used in pseudtk routine. * 2426c * njtj * 2427c * * 2428c ********************************************************* 2429c 2430c njtj 2431c ### Cray conversions 2432c ### 1)Comment out implicit double precision. 2433c ### 2)Switch double precision parameter 2434c ### to single precision parameter statement. 2435c ### Cray conversions 2436c njtj 2437c 2438 implicit double precision (a-h,o-z) 2439c 2440 dimension r(jrc),rab(jrc),aj(5,5),bj(5),ar(jrc) 2441c 2442 parameter (zero=0.D0,pfive=0.5D0,one=1.D0,errmin=1.D-12) 2443Cray parameter (zero=0.0,pfive=0.5,one=1.0,errmin=1.E-12) 2444c 2445 delta=zero 2446 bj(1)=log(arc/rc1**lp)-gamma*rc2 2447 bj(2)=brc-lp/rc1-2*gamma*rc1 2448 bj(3)=vrc-ev+(lp/rc1)**2-brc**2-2*gamma 2449 vt=vrc-ev+lp*(lp-1)/rc2 2450 bj(4)=vap-2*(vt*brc+lp**2/rc3-brc**3) 2451 bj(5)=vapp-2*((vap-2*lp*(lp-1)/rc3)*brc+(vt-3*brc**2)* 2452 1 (vt-brc**2)-3*lp**2/rc4) 2453 aj(1,1)=rc4 2454 aj(1,2)=rc5 2455 aj(1,3)=rc6 2456 aj(1,4)=rc7 2457 aj(1,5)=rc8 2458 aj(2,1)=4*rc3 2459 aj(2,2)=5*rc4 2460 aj(2,3)=6*rc5 2461 aj(2,4)=7*rc6 2462 aj(2,5)=8*rc7 2463 aj(3,1)=12*rc2 2464 aj(3,2)=20*rc3 2465 aj(3,3)=30*rc4 2466 aj(3,4)=42*rc5 2467 aj(3,5)=56*rc6 2468 aj(4,1)=24*rc1 2469 aj(4,2)=60*rc2 2470 aj(4,3)=120*rc3 2471 aj(4,4)=210*rc4 2472 aj(4,5)=336*rc5 2473 aj(5,1)=24*one 2474 aj(5,2)=120*rc1 2475 aj(5,3)=360*rc2 2476 aj(5,4)=840*rc3 2477 aj(5,5)=1680*rc4 2478 call gaussj(aj,5,5,bj,1,1) 2479 alpha=bj(1) 2480 alpha1=bj(2) 2481 alpha2=bj(3) 2482 alpha3=bj(4) 2483 alpha4=bj(5) 2484c 2485c start iteration loop to find delta(with gamma fixed) 2486c 2487 do 550 j=1,200 2488c 2489c generate pseudo wavefunction-note missing factor exp(delta) 2490c 2491 do 560 k=1,jrc 2492 rp=r(k) 2493 r2=rp*rp 2494 polyr = r2*(((((alpha4*rp+alpha3)*rp+alpha2)*rp+ 2495 1 alpha1)*rp+ alpha)*r2+gamma) 2496 ar(k) = rp**lp * exp(polyr) 2497 560 continue 2498c 2499c integrate pseudo charge density from r = 0 to rc 2500c 2501 ll = 2 2502 cdps = - ar(jrc) * ar(jrc) * rab(jrc) 2503 if (jrc .ne. 2*(jrc/2)) then 2504 do 120 k=jrc,1,-1 2505 cdps = cdps + ll * ar(k) * ar(k) * rab(k) 2506 ll = 6 - ll 2507 120 continue 2508 else 2509 do 121 k=jrc,4,-1 2510 cdps = cdps + ll * ar(k) * ar(k) * rab(k) 2511 ll = 6 - ll 2512 121 continue 2513 cdps = cdps - ar(4) * ar(4) * rab(4) 2514 cdps = cdps + 9 * ( ar(1) * ar(1) * rab(1) + 2515 1 3 * ar(2) *ar(2) * rab(2) + 2516 2 3 * ar(3) *ar(3) * rab(3) + 2517 3 ar(4) * ar(4) * rab(4))/8 2518 endif 2519 cdps = cdps/3 2520c 2521c Calculate new delta(with gamma fixed), uses false position 2522c 2523 fdnew = log(cdrc/cdps) - 2*delta 2524 if (abs(fdnew) .lt. errmin) then 2525 v0pp=8*((2*one*(lp-one)+5*one)*alpha+gamma**2) 2526 return 2527 endif 2528 if (j .eq. 1) then 2529 ddelta=-pfive 2530 else 2531 ddelta = - fdnew * ddelta / (fdnew-fdold) 2532 endif 2533 delta = delta + ddelta 2534 bj(1)=log(arc/rc1**lp)-delta-gamma*rc2 2535 bj(2)=brc-lp/rc1-2*gamma*rc1 2536 bj(3)=vrc-ev+(lp/rc1)**2-brc**2-2*gamma 2537 vt=vrc-ev+lp*(lp-1)/rc2 2538 bj(4)=vap-2*(vt*brc+lp**2/rc3-brc**3) 2539 bj(5)=vapp-2*((vap-2*lp*(lp-1)/rc3)*brc+(vt-3*brc**2)* 2540 1 (vt-brc**2)-3*lp**2/rc4) 2541 aj(1,1)=rc4 2542 aj(1,2)=rc5 2543 aj(1,3)=rc6 2544 aj(1,4)=rc7 2545 aj(1,5)=rc8 2546 aj(2,1)=4*rc3 2547 aj(2,2)=5*rc4 2548 aj(2,3)=6*rc5 2549 aj(2,4)=7*rc6 2550 aj(2,5)=8*rc7 2551 aj(3,1)=12*rc2 2552 aj(3,2)=20*rc3 2553 aj(3,3)=30*rc4 2554 aj(3,4)=42*rc5 2555 aj(3,5)=56*rc6 2556 aj(4,1)=24*rc1 2557 aj(4,2)=60*rc2 2558 aj(4,3)=120*rc3 2559 aj(4,4)=210*rc4 2560 aj(4,5)=336*rc5 2561 aj(5,1)=24*one 2562 aj(5,2)=120*rc1 2563 aj(5,3)=360*rc2 2564 aj(5,4)=840*rc3 2565 aj(5,5)=1680*rc4 2566 call gaussj(aj,5,5,bj,1,1) 2567 alpha=bj(1) 2568 alpha1=bj(2) 2569 alpha2=bj(3) 2570 alpha3=bj(4) 2571 alpha4=bj(5) 2572 fdold = fdnew 2573 550 continue 2574 write(6,1000) 2575 1000 format(//, 'error in gamfind - delta not found') 2576 call ext(860+lp) 2577 end 2578C 2579C 2580C 2581 subroutine gaussj(a,n,np,b,m,mp) 2582c 2583c **************************************************************** 2584c * * 2585c * njtj * 2586c * Gauss-Jordan routine used by pseudt to find polynominal * 2587c * constants. Taken from Numerical Recipes, page 28. * 2588c * njtj * 2589c * * 2590c **************************************************************** 2591c 2592c njtj 2593c ### Cray conversions 2594c ### 1)Comment out implicit double precision. 2595c ### 2)Switch double precision parameter 2596c ### to single precision parameter statement. 2597c ### Cray conversions 2598c njtj 2599c 2600 implicit double precision (a-h,o-z) 2601c 2602 parameter (nmax=50,zero=0.D0,one=1.D0) 2603Cray parameter (nmax=50,zero=0.0,one=1.0) 2604c 2605 dimension a(np,np),b(np,mp),ipiv(nmax),indxr(nmax),indxc(nmax) 2606c 2607 do 11 j=1,n 2608 ipiv(j)=0 260911 continue 2610 do 22 i=1,n 2611 big=zero 2612 do 13 j=1,n 2613 if(ipiv(j).ne.1)then 2614 do 12 k=1,n 2615 if (ipiv(k).eq.0) then 2616 if (abs(a(j,k)).ge.big)then 2617 big=abs(a(j,k)) 2618 irow=j 2619 icol=k 2620 endif 2621 else if (ipiv(k).gt.1) then 2622 write(6,100) 2623 call ext(890) 2624 endif 262512 continue 2626 endif 262713 continue 2628 ipiv(icol)=ipiv(icol)+1 2629 if (irow.ne.icol) then 2630 do 14 l=1,n 2631 dum=a(irow,l) 2632 a(irow,l)=a(icol,l) 2633 a(icol,l)=dum 263414 continue 2635 do 15 l=1,m 2636 dum=b(irow,l) 2637 b(irow,l)=b(icol,l) 2638 b(icol,l)=dum 263915 continue 2640 endif 2641 indxr(i)=irow 2642 indxc(i)=icol 2643 if (a(icol,icol).eq.zero) then 2644 write(6,100) 2645 call ext(891) 2646 endif 2647 pivinv=one/a(icol,icol) 2648 a(icol,icol)=one 2649 do 16 l=1,n 2650 a(icol,l)=a(icol,l)*pivinv 265116 continue 2652 do 17 l=1,m 2653 b(icol,l)=b(icol,l)*pivinv 265417 continue 2655 do 21 ll=1,n 2656 if(ll.ne.icol)then 2657 dum=a(ll,icol) 2658 a(ll,icol)=zero 2659 do 18 l=1,n 2660 a(ll,l)=a(ll,l)-a(icol,l)*dum 266118 continue 2662 do 19 l=1,m 2663 b(ll,l)=b(ll,l)-b(icol,l)*dum 266419 continue 2665 endif 266621 continue 266722 continue 2668 do 24 l=n,1,-1 2669 if(indxr(l).ne.indxc(l))then 2670 do 23 k=1,n 2671 dum=a(k,indxr(l)) 2672 a(k,indxr(l))=a(k,indxc(l)) 2673 a(k,indxc(l))=dum 267423 continue 2675 endif 267624 continue 2677 return 2678 100 format(//,'Singular matrix, stopped in gaussj') 2679 end 2680C 2681C 2682C 2683 subroutine input(itype,ikerk,icorr,ispp,zsh,rsh, 2684 1 nr,a,b,r,rab,nameat,norb,ncore,no,lo,so,zo, 2685 2 znuc,zel,evi) 2686c 2687c subroutine to read input parameters 2688c 2689c njtj *** modifications *** 2690c The input and output variables passed have been changed. 2691c There are five new pseudopotential generation options 2692c The input variables znuc,zsh,rsh,rmax,aa,bb are 2693c compared to a small positive value - eliminates 2694c floating point comparisions errors(zero is 2695c not always zero). 2696c njtj *** modifications *** 2697c 2698c njtj 2699c ### Cray conversions 2700c ### 1)Comment out implicit double precision. 2701c ### 2)Switch double precision parameter 2702c ### to single precision parameter statement. 2703c ### Cray conversions 2704c njtj 2705c 2706 implicit double precision (a-h,o-z) 2707c 2708 parameter (one=1.D0,zero=0.D0,pfive=0.5D0) 2709Cray parameter (one=1.0,zero=0.0,pfive=0.5) 2710 2711 character*1 ispp 2712 character*2 type,icorr,nameat 2713 character*3 name,kerker 2714 character*10 iray(5),ititle(5) 2715c 2716c dimension of transfered data 2717c 2718 dimension r(nr),rab(nr),no(norb),lo(norb),so(norb), 2719 1 zo(norb),evi(norb) 2720c 2721c dimensions of data used in routine 2722c 2723 dimension nc(15),lc(15),nomin(5) 2724c 2725c data for orbitals, 1s,2s,2p,3s,3p,3d,4s,4p,4d,5s,5p,4f,5d,6s,6p 2726c 2727 data nc /1,2,2,3,3,3,4,4,4,5,5,4,5,6,6/ 2728 data lc /0,0,1,0,1,2,0,1,2,0,1,3,2,0,1/ 2729c 2730 do 5 i=1,5 2731 nomin(i)=10 2732 5 continue 2733 do 6 i=1,norb 2734 no(i)=0 2735 lo(i)=0 2736 so(i)=zero 2737 zo(i)=zero 2738 evi(i)=zero 2739 6 continue 2740c 2741c read the type of calculation and title card 2742c itype = 2743c ae = 0 all electron calculation 2744c pg = 1 pseudopotential generation w/o core correction 2745c pe = 2 pseudopotential generation w/ core correction exchange 2746c ph = 3 pseudopotential generation w/ core correction hartree/exc 2747c pt = 4 pseudopotential test 2748c pm = 5 pseudopotential test + valence charge modify 2749c 2750 read(5,10) type,ititle 2751 10 format(3x,a2,5a10) 2752c 2753c if type = ' ' , no more data, program ends 2754c 2755 if (type .eq. 'ae') then 2756 itype=0 2757 elseif (type .eq. 'pg') then 2758 itype=1 2759 elseif (type .eq. 'pe') then 2760 itype=2 2761 elseif (type .eq. 'ph') then 2762 itype=3 2763 elseif (type .eq. 'pt') then 2764 itype=4 2765 elseif (type .eq. 'pm') then 2766 itype=5 2767 else 2768 itype=-1 2769 return 2770 endif 2771c 2772c njtj *** major modification start *** 2773c There are seven ways to generate the pseudopotential : 2774c kerker = van Vanderbilt 2775c kerker = tam Troullier and Martins 2776c kerker = ker (yes) Kerker 2777c kerker = hsc (no) Hamann Schluter and Chiang 2778c kerker = min (oth) datafile made for minimization 2779c kerker = bhs Bachelet, Hamann and Schluter 2780c kerker = tm2 Improved Troullier and Martins 2781c 2782 if (itype.gt.0) then 2783 read(5,11)kerker 2784 11 format(8x,a3) 2785 if(kerker .eq. 'tm2' .or. kerker .eq. 'TM2') then 2786 ikerk = 6 2787 elseif(kerker .eq. 'bhs' .or. kerker .eq. 'BHS') then 2788 ikerk = 5 2789 elseif(kerker .eq. 'oth' .or. kerker .eq. 'OTH' .or. 2790 1 kerker .eq. 'min' .or. kerker .eq. 'MIN') then 2791 ikerk = 4 2792 elseif (kerker .eq. 'van' .or. kerker .eq.'VAN') then 2793 ikerk = 3 2794 elseif (kerker .eq. 'tbk' .or. kerker .eq. 'TBK' 2795 1 .or. kerker .eq. 'tam' .or. kerker .eq. 'TAM') then 2796 ikerk = 2 2797 elseif (kerker .eq. 'yes' .or. kerker .eq. 'YES' .or. 2798 1 kerker .eq. 'ker' .or. kerker .eq. 'KER') then 2799 ikerk = 1 2800 elseif (kerker .eq. 'no ' .or. kerker .eq. ' no' .or. 2801 1 kerker .eq. 'NO ' .or. kerker .eq. ' NO' .or. kerker 2802 2 .eq. 'hsc' .or. kerker .eq. 'HSC') then 2803 ikerk = 0 2804 else 2805 write(6,1000)kerker 2806 call ext(150) 2807 endif 2808 endif 2809 1000 format(//,'error in input - kerker =',a3,' unknown') 2810c njtj *** major modification end *** 2811c 2812c read element name and correlation type 2813c ispp = ' ' - nonspin calculation 2814c ispp = s - spin polarized calculation 2815c ispp = r - relativistic calculation 2816c 2817 read(5,15) nameat,icorr,ispp 2818 15 format(3x,a2,3x,a2,a1) 2819 if (ispp .ne. 's' .and. ispp .ne. 'r') ispp=' ' 2820 if (ispp .eq. 's' .and. icorr .eq. 'xa') ispp=' ' 2821 if (ispp .eq. 's' .and. icorr .eq. 'wi') ispp=' ' 2822 if (ispp .eq. 's' .and. icorr .eq. 'hl') ispp=' ' 2823c 2824c njtj *** major modification start *** 2825c Floating point comparison error modification. 2826c Read the atomic number (nuclear charge), 2827c shell charge and radius (added to the nuclear potential), 2828c and radial grid parameters. 2829c 2830 read(5,20) znuc,zsh,rsh,rmax,aa,bb 2831 20 format(6f10.3) 2832 if (abs(znuc) .le. 0.00001) znuc=charge(nameat) 2833 if (itype .lt. 4) then 2834c 2835c set up grid 2836c 2837 if (abs(rmax) .lt. 0.00001) rmax=80*one 2838 if (abs(aa) .lt. 0.00001) aa=6*one 2839 if (abs(bb) .lt. 0.00001) bb=40*one 2840 a = exp(-aa)/znuc 2841 b = 1/bb 2842 do 30 i=1,nr 2843 if (i .eq. nr) then 2844 write(6,50) 2845 call ext(100) 2846 endif 2847 r(i) = a*(exp(b*(i-1))-1) 2848 rab(i) = (r(i)+a)*b 2849 if (r(i) .gt. rmax) goto 60 2850 30 continue 2851 60 nr = i-1 2852 endif 2853 50 format(/,' error in input - arraylimits', 2854 1 ' for radial array exceeded',/) 2855c njtj *** major modification end *** 2856c 2857c read the number of core and valence orbitals 2858c 2859 2860 read(5,70) ncore,nval 2861 70 format(2i5,4f10.3) 2862 if (ncore .gt. 15) then 2863 write(6,1010) 2864 call ext(101) 2865 endif 2866 1010 format(//,'error in input - max number of core orbitals', 2867 1 'is 15') 2868c 2869c compute occupation numbers and orbital energies for the core 2870c 2871 zcore = zero 2872 if (ncore .eq. 0) goto 85 2873 sc = zero 2874 if (ispp .ne. ' ') sc=-pfive 2875 norb = 0 2876 do 80 i=1,ncore 2877 do 80 j=1,2 2878 if (ispp .eq. ' ' .and. j .eq. 2) goto 80 2879 norb = norb + 1 2880 no(norb) = nc(i) 2881 lo(norb) = lc(i) 2882 so(norb) = sc 2883 zo(norb) = 2*lo(norb)+1 2884 if (ispp .eq. ' ') zo(norb) = 2*zo(norb) 2885 if (ispp .eq. 'r') zo(norb) = 2*(lo(norb)+sc)+1 2886 zcore = zcore + zo(norb) 2887 if (abs(zo(norb)) .lt. 0.1) norb=norb-1 2888 if (ispp .ne. ' ') sc=-sc 2889 80 continue 2890 ncore = norb 2891c 2892c for the valence orbitals 2893c 2894 85 if (itype .ge. 4) ncore =0 2895 norb = ncore 2896 zval = zero 2897 if (nval .eq. 0) goto 105 2898 do 90 i=1,nval 2899 read(5,70) ni,li,zd,zu,evd 2900 si = zero 2901 if (ispp .ne. ' ') si=pfive 2902 do 90 j=1,2 2903 if (ispp .eq. ' ' .and. j .eq. 2) goto 90 2904 norb = norb + 1 2905 if (ispp .ne. ' ') si=-si 2906 no(norb) = ni 2907 lo(norb) = li 2908 so(norb) = si 2909 zo(norb) = zd+zu 2910 if (zo(norb) .eq. zero) evi(norb)=evd 2911 if (ispp .eq. 's') then 2912 if (si .lt. 0.1) then 2913 zo(norb) = zd 2914 else 2915 zo(norb) = zu 2916 endif 2917 elseif (ispp .eq. 'r') then 2918 zo(norb)=zo(norb)*(2*(li+si)+1)/(4*li+2) 2919 endif 2920 zval = zval + zo(norb) 2921 if (ispp .eq. 'r' .and. li+si .lt. zero) norb=norb-1 2922 if (norb .eq. 0) goto 90 2923 if (nomin(lo(norb)+1) .gt. no(norb)) 2924 1 nomin(lo(norb)+1)=no(norb) 2925 90 continue 2926c 2927c abort if two orbitals are equal 2928c 2929 nval = norb - ncore 2930 do 100 i=1,norb 2931 do 100 j=1,norb 2932 if (i .le. j) goto 100 2933 if (no(i) .ne. no(j)) goto 100 2934 if (lo(i) .ne. lo(j)) goto 100 2935 if (abs(so(i)-so(j)) .gt. 0.001) goto 100 2936 write(6,1020)i 2937 call ext(110+i) 2938 100 continue 2939 1020 format(//,'error in input - orbital ',i2, 2940 1 'is already occupied') 2941c 2942c reduce n quantum number if pseudoatom 2943c 2944 if (itype .ge. 4) then 2945 do 103 i=1,nval 2946 no(i) = no(i)-nomin(lo(i)+1)+lo(i)+1 2947 103 continue 2948 endif 2949 105 zion = znuc - zcore - zval 2950 zel = zval 2951 if (itype .lt. 4) then 2952 zel=zel+zcore 2953 else 2954 znuc=znuc-zcore 2955 endif 2956c 2957c find jobname and date and printout, zedate is a machine dependent 2958c routine 2959c 2960 iray(1)='atom-lda ' 2961 call zedate(iray(2)) 2962c 2963c printout 2964c 2965 write(6,110) iray(1),iray(2),ititle 2966 110 format(1x,a10,a10,5x,5a10,/,21('*'),/) 2967 if (itype .eq. 0) then 2968 write(6,120) nameat 2969 elseif (itype .lt. 4) then 2970 write(6,121) nameat 2971 elseif (itype .eq. 4) then 2972 write(6,124) nameat 2973 elseif (itype .eq. 5) then 2974 write(6,125) nameat 2975 endif 2976 120 format(1x,a2,' all electron calculation ',/,1x,27('-'),/) 2977 121 format(1x,a2,' pseudopotential generation',/,1x,29('-'),/) 2978 124 format(1x,a2,' pseudopotential test',/,1x,23('-'),/) 2979 125 format(1x,a2,' pseudo test + charge mod ',/,1x,27('-'),/) 2980 if (ispp .eq. 'r') then 2981 write(6,150) 2982 150 format(' r e l a t i v i s t i c ! !',/) 2983 name = ' ' 2984 elseif (ispp .eq. ' ') then 2985 name = 'non' 2986 else 2987 name = ' ' 2988 endif 2989 write(6,160) icorr,name 2990 160 format(' correlation = ',a2,3x,a3,'spin-polarized',/) 2991 write(6,170) znuc,ncore,nval,zel,zion 2992 170 format(' nuclear charge =',f10.6,/, 2993 1 ' number of core orbitals =',i3,/, 2994 2 ' number of valence orbitals =',i3,/, 2995 3 ' electronic charge =',f10.6,/, 2996 4 ' ionic charge =',f10.6,//) 2997 if (zsh .gt. 0.00001) write(6,175) zsh,rsh 2998 175 format(' shell charge =',f6.2,' at radius =',f6.2,//) 2999 write(6,180) 3000 180 format(' input data for orbitals',//, 3001 1 ' i n l s j occ',/) 3002 xji = zero 3003 do 200 i=1,norb 3004 if (ispp .eq. 'r') xji = lo(i) + so(i) 3005 write(6,190) i,no(i),lo(i),so(i),xji,zo(i) 3006 190 format(1x,i2,2i5,2f6.1,f10.4) 3007 200 continue 3008 if (itype .lt. 4) write(6,210) r(2),nr,r(nr),aa,bb 3009 210 format(//,' radial grid parameters',//, 3010 1 ' r(1) = .0 , r(2) =',e8.2,' , ... , r(',i3,') =',f6.2, 3011 2 /,' a =',f5.2,' b =',f6.2,/) 3012 return 3013 end 3014C 3015C 3016C 3017 subroutine orban(ispp,iorb,ar,br,lmax,nr,a,b,r,rab, 3018 1 norb,no,lo,zo,so,viod,viou,vid,viu,ev,ek,ep) 3019c 3020c orban is used to analyze and printout data 3021c about the orbital. 3022c 3023c njtj 3024c ### Cray conversions 3025c ### 1)Comment out implicit double precision. 3026c ### 2)Switch double precision parameter 3027c ### to single precision parameter statement. 3028c ### Cray conversions 3029c njtj 3030c 3031 implicit double precision (a-h,o-z) 3032c 3033 parameter (ai=2*137.0360411D0,zero=0.D0) 3034Cray parameter (ai=2*137.0360411,zero=0.0) 3035c 3036 character*1 ispp 3037 character*10 name 3038c 3039 dimension ar(nr),br(nr),r(nr),rab(nr),no(norb), 3040 1 lo(norb),zo(norb),so(norb),viod(lmax,nr),viou(lmax,nr), 3041 2 vid(nr),viu(nr),ev(norb),ek(norb),ep(norb) 3042c 3043 dimension rzero(10),rextr(10),aextr(10),bextr(10) 3044c 3045c dimension wk1(1000),wk2(1000),wk3(1000),v(1000) 3046c 3047 ka = lo(iorb)+1 3048 lp = ka 3049 if (so(iorb) .lt. 0.1 .and. lo(iorb) .ne. 0) ka=-lo(iorb) 3050c 3051c compute zeroes and extrema 3052c 3053 nzero = 0 3054 nextr = 0 3055 rzero(1) = zero 3056 arp = br(2) 3057 if (ispp .eq. 'r') then 3058 if (so(iorb) .lt. 0.1) then 3059 arp = ka*ar(2)/r(2) + (ev(iorb) - viod(lp,2)/r(2) 3060 1 - vid(2) + ai*ai) * br(2) / ai 3061 else 3062 arp = ka*ar(2)/r(2) + (ev(iorb) - viou(lp,2)/r(2) 3063 1 - viu(2) + ai*ai) * br(2) / ai 3064 endif 3065 endif 3066 do 20 i=3,nr 3067 if (nextr .ge. no(iorb)-lo(iorb)) goto 30 3068 if (ar(i)*ar(i-1) .gt. zero) goto 10 3069c 3070c zero 3071c 3072 nzero = nzero + 1 3073 rzero(nzero) = (ar(i)*r(i-1)-ar(i-1)*r(i)) / (ar(i)-ar(i-1)) 3074 10 arpm = arp 3075 arp = br(i) 3076 if (ispp .eq. 'r') then 3077 if ( so(iorb) .lt. 0.1) then 3078 arp = ka*ar(i)/r(i) + (ev(iorb) - viod(lp,i)/r(i) 3079 1 - vid(i) + ai*ai) * br(i) / ai 3080 else 3081 arp = ka*ar(i)/r(i) + (ev(iorb) - viou(lp,i)/r(i) 3082 1 - viu(i) + ai*ai) * br(i) / ai 3083 endif 3084 endif 3085 if (arp*arpm .gt. zero) goto 20 3086c 3087c extremum 3088c 3089 nextr = nextr + 1 3090 rextr(nextr) = (arp*r(i-1)-arpm*r(i)) / (arp-arpm) 3091 aextr(nextr) = (ar(i)+ar(i-1))/2 3092 1 - (arp**2+arpm**2) * (r(i)-r(i-1)) / (4*(arp-arpm)) 3093 bextr(nextr) = br(i) 3094 20 continue 3095c 3096c find orbital kinetic and potential energy 3097c the potential part includes only the interaction with 3098c the nuclear part 3099c 3100 30 ek(iorb) = br(1)*br(1)*rab(1) 3101 ep(iorb) = zero 3102 sa2 = zero 3103 lp = lo(iorb)+1 3104 llp = lo(iorb)*lp 3105 ll = 2 3106 if (2*(nr/2) .eq. nr) ll=4 3107 i90=nr 3108 i99=nr 3109 do 40 i=nr,2,-1 3110 ar2 = ar(i)*ar(i) 3111 br2 = br(i)*br(i) 3112 deni = ar2 3113 if (ispp .eq. 'r') deni=deni+br2 3114 ek(iorb) = ek(iorb) + ll * (br2 + ar2*llp/r(i)**2)*rab(i) 3115 if (so(iorb) .lt. 0.1) then 3116 ep(iorb) = ep(iorb) + ll * deni*viod(lp,i)*rab(i)/r(i) 3117 else 3118 ep(iorb) = ep(iorb) + ll * deni*viou(lp,i)*rab(i)/r(i) 3119 endif 3120 ll = 6 - ll 3121 if (sa2 .gt. 0.1) goto 40 3122 sa2 = sa2 + deni*rab(i) 3123 if (sa2 .le. 0.01) i99 = i 3124 i90 = i 3125 40 continue 3126 ek(iorb) = ek(iorb) / 3 3127 ep(iorb) = ep(iorb) / 3 3128 if (ispp .eq. 'r') ek(iorb) = zero 3129c 3130c printout 3131c 3132 write(6,80) no(iorb),lo(iorb),so(iorb) 3133 80 format(/,' n =',i2,' l =',i2,' s =',f4.1) 3134 name = 'a extr ' 3135 write(6,100) name,(aextr(i),i=1,nextr) 3136 name = 'b extr ' 3137 if (ispp .eq. 'r') write(6,100) name,(bextr(i),i=1,nextr) 3138 name = 'r extr ' 3139 write(6,100) name,(rextr(i),i=1,nextr) 3140 name = 'r zero ' 3141 write(6,100) name,(rzero(i),i=1,nzero) 3142 name = 'r 90/99 % ' 3143 write(6,100) name,r(i90),r(i99) 3144 if (ev(iorb) .eq. zero) then 3145 if (zo(iorb) .ne. zero) then 3146 write(6,110)zo(iorb) 3147 else 3148 write(6,120) 3149 endif 3150 endif 3151 100 format(8x,a10,2x,8f8.3) 3152 110 format(8x,'WARNING: This orbital is not bound', 3153 1 ' and contains ',f6.4,' electrons!!') 3154 120 format(8x,'WARNING: This orbital is not bound!') 3155c 3156c njtj *** plotting routines *** 3157c Save plotting information to current plot.dat file 3158c (unit = 3), User must specify what orbital 3159c is to be saved(or all). 3160c 3161c iorbplot=3 3162c ist=1 3163c if (ar(nr-80) .lt. 0.0) ist=-1 3164c call potrw(ar,r,nr-85,lo(iorb),1,ist) 3165c call wtrans(ar,r,nr,rab,lo(iorb),ist,wk1) 3166c do 125 i=2,nr 3167c v(i)=viod(lo(iorb)+1,i)/r(i) 3168c 125 continue 3169c zion=4 3170c call potran(lo(iorb)+1,v,r,nr,zion,wk1,wk2,wk3) 3171c call potrv(v,r,nr-120,lo(iorb)) 3172c 3173c njtj *** user should adjust for their needs *** 3174c 3175 return 3176 end 3177C 3178C 3179C 3180 subroutine polcoe(x,y,n,cof) 3181c 3182c ************************************************ 3183c * njtj * 3184c * Returns the coefficients of a polynominal. * 3185c * Taken from numerical recipes, page 93. * 3186c * njtj * 3187c ************************************************ 3188c 3189c njtj 3190c ### Cray conversions 3191c ### 1)Comment out implicit double precision. 3192c ### 2)Switch double precision parameter 3193c ### to single precision parameter statement. 3194c ### Cray conversions 3195c njtj 3196c 3197 implicit double precision (a-h,o-z) 3198c 3199 parameter (nmax=10,zero=0.D0,one=1.D0) 3200Cray parameter (nmax=10,zero=0.0,one=1.0) 3201c 3202 dimension x(n),y(n),cof(n),s(nmax) 3203 do 11 i=1,n 3204 s(i)=zero 3205 cof(i)=zero 320611 continue 3207 s(n)=-x(1) 3208 do 13 i=2,n 3209 do 12 j=n+1-i,n-1 3210 s(j)=s(j)-x(i)*s(j+1) 321112 continue 3212 s(n)=s(n)-x(i) 321313 continue 3214 do 16 j=1,n 3215 phi=n 3216 do 14 k=n-1,1,-1 3217 phi=k*s(k+1)+x(j)*phi 321814 continue 3219 ff=y(j)/phi 3220 b=one 3221 do 15 k=n,1,-1 3222 cof(k)=cof(k)+b*ff 3223 b=s(k)+x(j)*b 322415 continue 322516 continue 3226 return 3227 end 3228C 3229C 3230C 3231 subroutine potran(i,vd,r,nr,zion,a,b,c) 3232c 3233c *********************************************************** 3234c * * 3235c * This is a plotting routine; the user should adjust * 3236c * for their own needs. The potential is fitted with a * 3237c * second degree polynomial, which is muliplied with the * 3238c * appropriate functions and then integrated by parts * 3239c * to find the fourier transform. The result is then * 3240c * printed to the current plot.dat file (unit=3) for * 3241c * later plotting. A marker(marker fn#) is placed at * 3242c * the end of each set of data. * 3243c * * 3244c *********************************************************** 3245c 3246c njtj 3247c ### Cray conversions 3248c ### 1)Comment out implicit double precision. 3249c ### 2)Switch double precision parameter 3250c ### to single precision parameter statement. 3251c ### Cray conversions 3252c njtj 3253c 3254 implicit double precision (a-h,o-z) 3255c 3256 parameter (zero=0.D0,one=1.D0) 3257Cray parameter (zero=0.0,one=1.0) 3258c 3259 dimension vd(nr),r(nr),a(nr),b(nr),c(nr),vql(100) 3260c 3261c The potential times r is fitted to the polynominal 3262c a + bx + cx^2 at every other point. 3263c 3264 rm=zero 3265 vm=2*zion 3266 do 130 k=2,nr,2 3267 r0=r(k) 3268 v0=r0*vd(k)+2*zion 3269 rp=r(k+1) 3270 vp=rp*vd(k+1)+2*zion 3271 d1=1/((rp-rm)*(r0-rm)) 3272 d2=1/((rp-r0)*(rm-r0)) 3273 d3=1/((r0-rp)*(rm-rp)) 3274 a(k)=vm*d1+v0*d2+vp*d3 3275 b(k)=-vm*(r0+rp)*d1-v0*(rm+rp)*d2-vp*(rm+r0)*d3 3276 c(k)=vm*r0*rp*d1+v0*rm*rp*d2+vp*rm*r0*d3 3277 rm=rp 3278 vm=vp 3279 130 continue 3280c 3281c Find the fourier transform q^2/4pi/zion*vql. Everything is 3282c rescaled by zion. 3283c 3284 do 150 j=1,94 3285 q=one/4*j 3286 q2=q*q 3287 vql(j)=zero 3288 rm=zero 3289 do 140 k=2,nr-1,2 3290 rp=r(k+1) 3291 vql(j)=vql(j)+(2*a(k)*rp+b(k))/q*sin(q*rp) 3292 1 -((a(k)*rp+b(k))*rp+c(k)-2*a(k)/q2)*cos(q*rp) 3293 2 -(2*a(k)*rm+b(k))/q*sin(q*rm) 3294 3 +((a(k)*rm+b(k))*rm+c(k)-2*a(k)/q2)*cos(q*rm) 3295 rm=rp 3296 140 continue 3297 vql(j)=vql(j)/2/zion-one 3298 150 continue 3299c 3300c Print out the transforms( really q^2/(4pi*zion)*v(q) ) to 3301c the current plot.dat file (unit=3) for latter plotting. 3302c 3303 do 170 j=1,48 3304 write(3,6000)one/4*j,vql(j) 3305 170 continue 3306 write(3,6008)i 3307 return 3308c 3309c format statements 3310c 3311 6000 format(1x,f7.4,3x,f10.6) 3312 6008 format(1x,'marker fn',i1) 3313c 3314 end 3315C 3316C 3317C 3318 subroutine potrv(vd,r,nr,k) 3319c 3320c *********************************************************** 3321c * * 3322c * This is a plotting routine; the user should * 3323c * adjust for their own needs. Prints * 3324c * out the potential to the current plot.dat * 3325c * file (unit=3) for later ploting. A marker (marker) * 3326c * is placed at the end of each group of data. * 3327c * * 3328c *********************************************************** 3329c 3330c njtj 3331c ### Cray conversions 3332c ### 1)Comment out implicit double precision. 3333c ### Cray conversions 3334c njtj 3335c 3336 implicit double precision (a-h,o-z) 3337c 3338 character*3 marker 3339c 3340 dimension vd(nr),r(nr) 3341c 3342c Step size of 0.05 is adjustable as seen fit to give 3343c a reasonalble plot. 3344c 3345 step=0.0 3346 do 150,j=5,nr 3347 if (r(j) .ge. step) then 3348 write(3,6000)r(j),vd(j) 3349 step=step+0.05 3350 endif 3351 150 continue 3352 if (k .eq. 0) then 3353 marker='vns' 3354 elseif (k .eq. 1) then 3355 marker='vnp' 3356 elseif (k .eq. 2) then 3357 marker='vnd' 3358 elseif (k .eq. 3) then 3359 marker='vnf' 3360 elseif (k .eq. 4) then 3361 marker='vng' 3362 endif 3363 write(3,6001)marker 3364 return 3365c 3366c Format statements 3367c 3368 6000 format(1x,f7.4,3x,f10.5) 3369 6001 format(1x,'marker ',a3) 3370 end 3371C 3372C 3373C 3374 subroutine potrw(vd,r,nr,k,kj,ist) 3375c 3376c *********************************************************** 3377c * * 3378c * This is a plotting routine; the user should * 3379c * adjust/eliminatebfor their own needs. Prints * 3380c * out the wave functions to the current plot.dat * 3381c * file (unit=3) for later ploting. A marker (marker) * 3382c * is placed at the end of each group of data. * 3383c * * 3384c *********************************************************** 3385c 3386c njtj 3387c ### Cray conversions 3388c ### 1)Comment out implicit double precision. 3389c ### 2)Switch double precision parameter statement 3390c ### to single precision statement. 3391c ### Cray conversions 3392c njtj 3393c 3394 implicit double precision (a-h,o-z) 3395 parameter (zero=0.D0,pzf=0.05D0) 3396Cray parameter (zero=0.0,pzf=0.05) 3397c 3398c 3399 character*3 marker 3400c 3401 dimension vd(nr),r(nr) 3402c 3403c Step size of 0.05 is adjustable as seen fit to give 3404c a reasonalble plot. 3405c 3406 step=zero 3407 do 150,j=2,nr 3408 if (r(j) .ge. step) then 3409 write(3,6000)r(j),vd(j)*ist 3410 step=step+pzf 3411 endif 3412 150 continue 3413 if (kj .eq. 0) then 3414 if (k .eq. 0) then 3415 marker='wsp' 3416 elseif (k .eq. 1) then 3417 marker='wpp' 3418 elseif (k .eq. 2) then 3419 marker='wdp' 3420 elseif (k .eq. 3) then 3421 marker='wfp' 3422 elseif (k .eq. 4) then 3423 marker='wgp' 3424 endif 3425 else 3426 if (k .eq. 0) then 3427 marker='wst' 3428 elseif (k .eq. 1) then 3429 marker='wpt' 3430 elseif (k .eq. 2) then 3431 marker='wdt' 3432 elseif (k .eq. 3) then 3433 marker='wft' 3434 elseif (k .eq. 4) then 3435 marker='wgt' 3436 endif 3437 endif 3438 write(3,6001)marker 3439 return 3440c 3441c Format statements 3442c 3443 6000 format(1x,f7.4,3x,f18.14) 3444 6001 format(1x,'marker ',a3) 3445 end 3446C 3447C 3448C 3449 subroutine prdiff(nconf,econf) 3450c 3451c Prints out the energy differences between 3452c different atomic configurations. 3453c 3454c njtj *** modifications *** 3455c econf is able to handle larger numbers 3456c of configurations. 3457c njtj *** modifications *** 3458c 3459c njtj 3460c ### Cray conversions 3461c ### 1)Comment out implicit double precision. 3462c ### Cray conversions 3463c njtj 3464c 3465 implicit double precision (a-h,o-z) 3466c 3467 dimension econf(100) 3468c 3469 write(6,10) (i,i=1,nconf) 3470 do 30 i=1,nconf 3471 write(6,20) i,(econf(i)-econf(j),j=1,i) 3472 30 continue 3473 10 format(/,' total energy difference',//,2x,9i9) 3474 20 format(1x,i2,1x,9f9.4) 3475 return 3476 end 3477C 3478C 3479C 3480 subroutine pseud2(itype,icorr,ispp,lmax,nr,a,b,r,rab, 3481 1 nameat,norb,ncore,no,lo,so,zo,znuc,zel,cdd,cdu,cdc, 3482 2 viod,viou,vid,viu,vod,vou,etot,ev,ek,ep,wk1,wk2, 3483 3 wk3,wk4,wk5,wk6,wk7,nops,v,ar,br,wkb,evi) 3484c 3485c ************************************************************* 3486c * * 3487c * This routine was written by Norman J. Troullier Jr. * 3488c * April 1990, while at the U. of Minnesota, all * 3489c * comments concerning this routine should be directed * 3490c * to him. * 3491c * * 3492c * troullie@128.101.224.101 * 3493c * troullie@csfsa.cs.umn.edu * 3494c * 612 625-0392 * 3495c * * 3496c * pseud2 generates a pseudopotential using the * 3497c * improved scheme of N. Troullier and J. L. Martins. * 3498c * The general format of this routine is the same as the * 3499c * pseudo and pseudk routines. Output/input is * 3500c * compatible. * 3501c * * 3502c ************************************************************* 3503c 3504c njtj 3505c ### Cray conversions 3506c ### 1)Comment out implicit double precision. 3507c ### 2)Switch double precision parameter 3508c ### to single precision parameter statement. 3509c ### Cray conversions 3510c njtj 3511c 3512 implicit double precision (a-h,o-z) 3513c 3514 parameter (zero=0.D0,one=1.D0,tpfive=2.5D0,ecuts=1.0D-3) 3515 parameter (small=1.D-12,pnine=0.9D0,ai=2*137.0360411D0,sml=0.1D0) 3516Cray parameter (zero=0.0,one=1.0,tpfive=2.5,ecuts=1.0E-3) 3517Cray parameter (small=1.E-12,pnine=0.9,ai=2*137.0360411,sml=0.1) 3518c 3519 character*1 ispp,blank,il(5) 3520 character*2 icorr,nameat 3521 character*3 irel 3522 character*4 nicore 3523 character*10 iray(6),ititle(7) 3524c 3525 dimension r(nr),rab(nr),no(norb),lo(norb),so(norb),zo(norb), 3526 1 cdd(nr),cdu(nr),cdc(nr),viod(lmax,nr),viou(lmax,nr), 3527 2 vid(nr),viu(nr),vod(nr),vou(nr),ev(norb),ek(norb),ep(norb), 3528 3 wk1(nr),wk2(nr),wk3(nr),wk4(nr),wk5(nr),wk6(nr),wk7(nr), 3529 4 wkb(3*nr),nops(norb),v(nr),ar(nr),br(nr),evi(norb) 3530c 3531 dimension indd(5),indu(5),rc(5),rcut(10),vstore(1000), 3532 1 etot(10),aa(7),rr(7),coe(7),aj(5,5),bj(5) 3533c 3534 data il/'s','p','d','f','g'/ 3535 if (ncore .eq. norb) return 3536 ifcore = itype-1 3537 pi = 4*atan(one) 3538 do 3 i=1,5 3539 indd(i)=0 3540 indu(i)=0 3541 3 continue 3542 do 4 i=1,40 3543 nops(i) = 0 3544 4 continue 3545c 3546c read rc(s),rc(p),rc(d),rc(f),rc(g),cfac,rcfac 3547c 3548c cfac is used for the pseudocore - the pseudocore stops where 3549c the core charge density equals cfac times the renormalized 3550c valence charge density (renormalized to make the atom neutral). 3551c If cfac is input as negative, the full core charge is used, 3552c if cfac is input as zero, it is set equal to one. 3553c rcfac is used for the pseudocore cut off radius. If set 3554c to less then or equal to zero cfac is used. cfac must be 3555c set to greater then zero. 3556c 3557 read(5,10) (rc(i),i=1,5),cfac,rcfac 3558 10 format(7f10.5) 3559 if (cfac .eq. 0.D0) cfac=one 3560c 3561c Reset vod and vou to zero, 3562c they are here used to store the pseudo valence charge density. 3563c 3564 do 15 i=1,nr 3565 vod(i) = zero 3566 15 continue 3567 do 16 i=1,nr 3568 vou(i) = zero 3569 16 continue 3570c 3571c print heading 3572c 3573 write(6,20) nameat 3574 20 format(//,1x,a2,' pseudopotential generation using the ', 3575 1 'Improved Troullier and Martins method',/,1x,60('-'),//, 3576 2 ' nl s eigenvalue',6x,'rc',10x,'cdrc',7x,'delta',/) 3577c 3578c Start loop over valence orbitals, only one orbital for each 3579c angular momentum and spin can exist. 3580c 3581 ncp = ncore+1 3582 do 190 i=ncp,norb 3583 lp = lo(i) + 1 3584 llp = lo(i)*lp 3585 if (so(i) .lt. 0.1) then 3586 if (indd(lp) .ne. 0) then 3587 write(6,1000)lp-1 3588 call ext(800+lp) 3589 else 3590 indd(lp) = i 3591 endif 3592 else 3593 if (indu(lp) .ne. 0) then 3594 write(6,1010)lp-1 3595 call ext(810+lp) 3596 else 3597 indu(lp) = i 3598 endif 3599 endif 3600 1000 format(//,'error in pseud2 - two down spin orbitals of the same ', 3601 1 /,'angular momentum (',i1,') exist') 3602 1010 format(//,'error in pseud2 - two up spin orbitals of the same ', 3603 1 /,'angular momentum (',i1,') exist') 3604c 3605c Find the all electron wave function. 3606c 3607 do 29 j=1,nr 3608 ar(j) = zero 3609 29 continue 3610 if (so(i) .lt. 0.1) then 3611 do 30 j=2,nr 3612 v(j) = viod(lp,j)/r(j) + vid(j) 3613 30 continue 3614 else 3615 do 31 j=2,nr 3616 v(j) = viou(lp,j)/r(j) + viu(j) 3617 31 continue 3618 endif 3619 if (ispp .ne. 'r') then 3620 do 32 j=2,nr 3621 v(j) = v(j) + llp/r(j)**2 3622 32 continue 3623 endif 3624c 3625c The parameter iflag has been added as a nonconvegence 3626c indicator for auxillary routines. Its value does 3627c not change its operation. iflag is a returned value, 3628c set to 1 for none convergence. 3629c 3630 if (ispp .ne. 'r') then 3631 iflag=0 3632 call difnrl(0,i,v,ar,br,lmax,nr,a,b, 3633 1 r,rab,norb,no,lo,so,znuc,viod,viou, 3634 2 vid,viu,ev,iflag,wk1,wk2,wk3,evi) 3635 else 3636 call difrel(0,i,v,ar,br,lmax,nr,a,b,r, 3637 1 rab,norb,no,lo,so,znuc,viod,viou,vid,viu, 3638 2 ev,wk1,wk2,wk3,wk4,evi) 3639 endif 3640c 3641c Find last zero and extremum 3642c 3643 ka = lo(i)+1 3644 if (so(i) .lt. 0.1 .and. lo(i) .ne. 0) ka=-lo(i) 3645 nextr = no(i)-lo(i) 3646 rzero = zero 3647 arp = br(2) 3648c 3649 if (ispp .eq. 'r') then 3650 if (so(i) .lt. 0.1) then 3651 arp = ka*ar(2)/r(2) + (ev(i) - viod(lp,2)/r(2) 3652 1 - vid(2) + ai*ai) * br(2) / ai 3653 else 3654 arp = ka*ar(2)/r(2) + (ev(i) - viou(lp,2)/r(2) 3655 1 - viu(2) + ai*ai) * br(2) / ai 3656 endif 3657 endif 3658c 3659 do 40 j=3,nr-7 3660 if (nextr .eq. 0) goto 50 3661 if (ar(j-1)*ar(j) .le. zero .and. evi(i) .eq. zero) 3662 1 rzero = (ar(j)*r(j-1)-ar(j-1)*r(j)) / (ar(j)-ar(j-1)) 3663 arpm = arp 3664 arp = br(j) 3665c 3666 if (ispp .eq. 'r') then 3667 if(so(i) .lt. 0.1) then 3668 arp = ka*ar(j)/r(j) + (ev(i) - viod(lp,j)/r(j) 3669 1 - vid(j) + ai*ai) * br(j) / ai 3670 else 3671 arp = ka*ar(j)/r(j) + (ev(i) - viou(lp,j)/r(j) 3672 1 - viu(j) + ai*ai) * br(j) / ai 3673 endif 3674 endif 3675c 3676 if (arp*arpm .gt. zero) goto 40 3677 rextr = (arp*r(j-1)-arpm*r(j)) / (arp-arpm) 3678 nextr = nextr - 1 3679 40 continue 3680 50 if (rzero .lt. r(2)) rzero = r(2) 3681c 3682c Check rc if inside rzero, 3683c reset to .9 between rmax and rzero if inside 3684c if rc(lp) is negative, rc(lp) is percent of way 3685c betweeen rzero and rmax. 3686c 3687 if (rc(lp) .gt. rzero) then 3688 elseif(rc(lp) .ge. zero) then 3689 rc(lp) = rzero + pnine*(rextr-rzero) 3690 else 3691 rc(lp) = rzero - rc(lp)*(rextr-rzero) 3692 endif 3693c 3694c Find the index for odd grid point closest to rc. 3695c 3696 do 70 j=1,nr 3697 if (r(j) .gt. rc(lp)) goto 80 3698 70 continue 3699 80 jrc=j-1 3700 rc(lp)=r(jrc) 3701c 3702c njtj *** plotting routines *** 3703c potrw is called to save an usefull number of points 3704c of the wave function to make a plot. The info is 3705c written to the current plot.dat file. 3706c 3707 ist=1 3708 if (ar(jrc) .lt. zero) ist=-1 3709 call potrw(ar,r,nr-85,lo(i),1,ist) 3710 do 41 j=1,nr 3711 ar(j)=ar(j)*ist 3712 br(j)=br(j)*ist 3713 41 continue 3714c 3715c njtj *** user should adjust for their needs *** 3716c 3717c 3718c Reset n quantum numbers. 3719c 3720 nops(i) = lp 3721c 3722c Find the integrated charge inside rc(1-charge outside). 3723c 3724 ll = 2 3725 if (ispp .eq. 'r') then 3726 cdrc = -(ar(jrc)*ar(jrc)+br(jrc)*br(jrc))*rab(jrc) 3727 if (jrc .ne. 2*(jrc/2)) then 3728 do 102 k=jrc,1,-1 3729 cdrc = cdrc+ll*(ar(k)*ar(k)+br(k)*br(k))*rab(k) 3730 ll = 6 - ll 3731 102 continue 3732 else 3733 do 103 k=jrc,4,-1 3734 cdrc = cdrc+ll*(ar(k)*ar(k)+br(k)*br(k))*rab(k) 3735 ll = 6 - ll 3736 103 continue 3737 cdrc = cdrc-(ar(4)*ar(4)+br(4)*br(4))*rab(4) 3738 cdrc = cdrc+9*((ar(1)*ar(1)+br(1)*br(1))*rab(1)+ 3739 1 3*(ar(2)*ar(2)+br(2)*br(2))*rab(2)+ 3740 2 3*(ar(3)*ar(3)+br(3)*br(3))*rab(3)+ 3741 3 (ar(4)*ar(4)+br(4)*br(4))*rab(4))/8 3742 endif 3743 cdrc = cdrc/3 3744 else 3745 cdrc = - ar(jrc) * ar(jrc) * rab(jrc) 3746 if (jrc .ne. 2*(jrc/2)) then 3747 do 100 k=jrc,1,-1 3748 cdrc = cdrc + ll * ar(k) * ar(k) * rab(k) 3749 ll = 6 - ll 3750 100 continue 3751 else 3752 do 101 k=jrc,4,-1 3753 cdrc = cdrc + ll * ar(k) * ar(k) * rab(k) 3754 ll = 6 - ll 3755 101 continue 3756 cdrc = cdrc - ar(4) * ar(4) * rab(4) 3757 cdrc = cdrc + 9 * ( ar(1) * ar(1) * rab(1) + 3758 1 3 * ar(2) *ar(2) * rab(2) + 3759 2 3 * ar(3) *ar(3) * rab(3) + 3760 3 ar(4) * ar(4) * rab(4))/8 3761 endif 3762 cdrc = cdrc/3 3763 endif 3764c 3765c Find the values for wave(arc), d(wave)/dr(arp), potential(vrc), 3766c d(potential)/dr(vrp), and d2(potential)/dr2(vrpp) 3767c 3768 rc1 = r(jrc) 3769 rc2 = rc1 * rc1 3770 rc3 = rc2 * rc1 3771 rc4 = rc2 * rc2 3772 rc5 = rc4 * rc1 3773 rc6 = rc4 * rc2 3774 rc7 = rc4 * rc3 3775 rc8 = rc4 * rc4 3776 rc9 = rc4 * rc5 3777 rc10= rc4 * rc6 3778 arc = ar(jrc) 3779 arp = br(jrc) 3780 if (ispp .eq. 'r') then 3781 if (so(i) .lt. 0.1) then 3782 arp=ka*ar(jrc)/r(jrc) + (ev(i) - viod(lp,jrc)/r(jrc) 3783 1 - vid(jrc) + ai*ai) * br(jrc)/ai 3784 else 3785 arp=ka*ar(jrc)/r(jrc) + (ev(i) - viou(lp,jrc)/r(jrc) 3786 1 - viu(jrc) + ai*ai) * br(jrc)/ai 3787 endif 3788 endif 3789 arp =arp 3790 brc = arp / arc 3791c 3792 if (so(i) .lt. 0.1) then 3793 vrc = viod(lp,jrc)/r(jrc) + vid(jrc) 3794 aa(1)=viod(lp,jrc-3)/r(jrc-3) + vid(jrc-3) 3795 aa(2)=viod(lp,jrc-2)/r(jrc-2) + vid(jrc-2) 3796 aa(3)=viod(lp,jrc-1)/r(jrc-1) + vid(jrc-1) 3797 aa(4)=vrc 3798 aa(5)=viod(lp,jrc+1)/r(jrc+1) + vid(jrc+1) 3799 aa(6)=viod(lp,jrc+2)/r(jrc+2) + vid(jrc+2) 3800 aa(7)=viod(lp,jrc+3)/r(jrc+3) + vid(jrc+3) 3801 else 3802 vrc = viou(lp,jrc)/r(jrc) + viu(jrc) 3803 aa(1)=viou(lp,jrc-3)/r(jrc-3) + viu(jrc-3) 3804 aa(2)=viou(lp,jrc-2)/r(jrc-2) + viu(jrc-2) 3805 aa(3)=viou(lp,jrc-1)/r(jrc-1) + viu(jrc-1) 3806 aa(4)=vrc 3807 aa(5)=viou(lp,jrc+1)/r(jrc+1) + viu(jrc+1) 3808 aa(6)=viou(lp,jrc+2)/r(jrc+2) + viu(jrc+2) 3809 aa(7)=viou(lp,jrc+3)/r(jrc+3) + viu(jrc+3) 3810 endif 3811 rr(1)=r(jrc-3)-r(jrc) 3812 rr(2)=r(jrc-2)-r(jrc) 3813 rr(3)=r(jrc-1)-r(jrc) 3814 rr(4)=zero 3815 rr(5)=r(jrc+1)-r(jrc) 3816 rr(6)=r(jrc+2)-r(jrc) 3817 rr(7)=r(jrc+3)-r(jrc) 3818 call polcoe(rr,aa,7,coe) 3819 vap = coe(2) 3820 vapp = 2*coe(3) 3821c 3822c Set up matrix without the d2(potential(0)/dr2=0 condition 3823c to find an intial guess for gamma. 3824c 3825 delta=zero 3826 bj(1)=log(arc/rc1**lp) 3827 bj1=bj(1) 3828 bj(2)=brc-lp/rc1 3829 bj2=bj(2) 3830 bj(3)=vrc-ev(i)-2*lp/rc1*bj2-bj2**2 3831 bj3=bj(3) 3832 bj(4)=vap+2*lp/rc2*bj2-2*lp/rc1*bj3-2*bj2*bj3 3833 bj4=bj(4) 3834 bj(5)=vapp-4*lp/rc3*bj2+4*lp/rc2*bj3-2*lp/rc1*bj4-2*bj3**2 3835 1 -2*bj2*bj4 3836 bj5=bj(5) 3837 aj(1,1)=rc2 3838 aj(1,2)=rc4 3839 aj(1,3)=rc6 3840 aj(1,4)=rc8 3841 aj(1,5)=rc10 3842 aj(2,1)=2*rc1 3843 aj(2,2)=4*rc3 3844 aj(2,3)=6*rc5 3845 aj(2,4)=8*rc7 3846 aj(2,5)=10*rc9 3847 aj(3,1)=2*one 3848 aj(3,2)=12*rc2 3849 aj(3,3)=30*rc4 3850 aj(3,4)=56*rc6 3851 aj(3,5)=90*rc8 3852 aj(4,1)=zero 3853 aj(4,2)=24*rc1 3854 aj(4,3)=120*rc3 3855 aj(4,4)=336*rc5 3856 aj(4,5)=720*rc7 3857 aj(5,1)=zero 3858 aj(5,2)=24*one 3859 aj(5,3)=360*rc2 3860 aj(5,4)=1680*rc4 3861 aj(5,5)=5040*rc6 3862 call gaussj(aj,5,5,bj,1,1) 3863 gamma=bj(1) 3864 alpha=bj(2) 3865 alpha1=bj(3) 3866 alpha2=bj(4) 3867 alpha3=bj(5) 3868c 3869c Start iteration loop to find delta, uses false postion. 3870c 3871 do 150 j=1,50 3872c 3873c Generate pseudo wavefunction-note missing factor exp(delta). 3874c 3875 do 110 k=1,jrc 3876 rp=r(k) 3877 r2=rp*rp 3878 polyr = r2*((((alpha3*r2+alpha2)*r2+ 3879 1 alpha1)*r2+ alpha)*r2+gamma) 3880 ar(k) = rp**lp * exp(polyr) 3881 110 continue 3882c 3883c Integrate pseudo charge density from r = 0 to rc. 3884c 3885 ll = 2 3886 cdps = - ar(jrc) * ar(jrc) * rab(jrc) 3887 if (jrc .ne. 2*(jrc/2)) then 3888 do 120 k=jrc,1,-1 3889 cdps = cdps + ll * ar(k) * ar(k) * rab(k) 3890 ll = 6 - ll 3891 120 continue 3892 else 3893 do 121 k=jrc,4,-1 3894 cdps = cdps + ll * ar(k) * ar(k) * rab(k) 3895 ll = 6 - ll 3896 121 continue 3897 cdps = cdps - ar(4) * ar(4) * rab(4) 3898 cdps = cdps + 9 * ( ar(1) * ar(1) * rab(1) + 3899 1 3 * ar(2) *ar(2) * rab(2) + 3900 2 3 * ar(3) *ar(3) * rab(3) + 3901 3 ar(4) * ar(4) * rab(4))/8 3902 endif 3903 cdps = cdps/3 3904c 3905c Calculate new delta 3906c 3907 fdnew = log(cdrc/cdps) - 2*delta 3908 if (abs(fdnew) .lt. small) goto 160 3909 if (j .eq. 1) then 3910 ddelta=-one/2 3911 else 3912 ddelta = - fdnew * ddelta / (fdnew-fdold) 3913 endif 3914 delta = delta + ddelta 3915 bj(1)=bj1-delta 3916 bj(2)=bj2 3917 bj(3)=bj3 3918 bj(4)=bj4 3919 bj(5)=bj5 3920 aj(1,1)=rc2 3921 aj(1,2)=rc4 3922 aj(1,3)=rc6 3923 aj(1,4)=rc8 3924 aj(1,5)=rc10 3925 aj(2,1)=2*rc1 3926 aj(2,2)=4*rc3 3927 aj(2,3)=6*rc5 3928 aj(2,4)=8*rc7 3929 aj(2,5)=10*rc9 3930 aj(3,1)=2*one 3931 aj(3,2)=12*rc2 3932 aj(3,3)=30*rc4 3933 aj(3,4)=56*rc6 3934 aj(3,5)=90*rc8 3935 aj(4,1)=zero 3936 aj(4,2)=24*rc1 3937 aj(4,3)=120*rc3 3938 aj(4,4)=336*rc5 3939 aj(4,5)=720*rc7 3940 aj(5,1)=zero 3941 aj(5,2)=24*one 3942 aj(5,3)=360*rc2 3943 aj(5,4)=1680*rc4 3944 aj(5,5)=5040*rc6 3945 call gaussj(aj,5,5,bj,1,1) 3946 gamma=bj(1) 3947 alpha=bj(2) 3948 alpha1=bj(3) 3949 alpha2=bj(4) 3950 alpha3=bj(5) 3951 fdold = fdnew 3952 150 continue 3953c 3954c End iteration loop for delta. 3955c 3956 write(6,1020)lp-1 3957 call ext(820+lp) 3958 1020 format(//,'error in pseud2 - nonconvergence in finding', 3959 1 /,' starting delta for angular momentum ',i1) 3960c 3961c Bracket the correct gamma, use gamma and -gamma 3962c from above as intial brackets, expands brackets 3963c until a root is found.. 3964c 3965 160 alpha4=zero 3966 x1=gamma 3967 x2=-gamma 3968c 3969 call zrbac2(x1,x2,rc1,rc2,rc3,rc4,rc5,rc6,rc7, 3970 1 rc8,lp,arc,brc,vrc,vap,vapp,ev(i),cdrc,r,rab, 3971 2 jrc,delta,gamma,alpha,alpha1,alpha2,alpha3, 3972 3 alpha4,ar) 3973c 3974c Iteration loop to find correct gamma, uses 3975c bisection to find gamma. 3976c 3977 call rtbis2(x1,x2,rc1,rc2,rc3,rc4,rc5,rc6,rc7, 3978 1 rc8,lp,arc,brc,vrc,vap,vapp,ev(i),cdrc,r,rab,jrc,delta, 3979 2 gamma,alpha,alpha1,alpha2,alpha3,alpha4,ar) 3980c 3981c Augment charge density and invert schroedinger equation 3982c to find new potential. 3983c 3984 645 expd = exp(delta) 3985 if (so(i) .lt. 0.1) then 3986 do 169 j=1,jrc 3987 r2=r(j)*r(j) 3988 poly=r2*(((((alpha4*r2+alpha3)*r2+alpha2)*r2+alpha1)* 3989 1 r2+alpha)*r2+gamma) 3990 ar(j) = r(j)**lp * expd * exp(poly) 3991 vod(j) = vod(j) + zo(i)*ar(j)*ar(j) 3992 xlamda=((((12*alpha4*r2+10*alpha3)*r2+8*alpha2)*r2+ 3993 1 6*alpha1)*r2+4*alpha)*r2+2*gamma 3994 vj = ev(i) + xlamda * (2 * lp + xlamda * r2) 3995 1 +((((132*alpha4*r2+90*alpha3)*r2+56*alpha2)*r2+30*alpha1)* 3996 2 r2+12*alpha)*r2+2*gamma 3997 viod(lp,j) = (vj-vid(j)) * r(j) 3998 169 continue 3999 do 168 j=jrc+1,nr 4000 vod(j) = vod(j) + zo(i)*ar(j)*ar(j) 4001 168 continue 4002 else 4003 do 170 j=1,jrc 4004 r2=r(j)*r(j) 4005 poly=r2*(((((alpha4*r2+alpha3)*r2+alpha2)*r2+alpha1)* 4006 1 r2+alpha)*r2+gamma) 4007 ar(j) = r(j)**lp * expd * exp(poly) 4008c 4009c bug fix Alberto Garcia 5/11/90 4010c 4011 vou(j) = vou(j) + zo(i)*ar(j)*ar(j) 4012 xlamda=((((12*alpha4*r2+10*alpha3)*r2+8*alpha2)*r2+ 4013 1 6*alpha1)*r2+4*alpha)*r2+2*gamma 4014 vj = ev(i) + xlamda * (2 * lp + xlamda * r(j)**2) 4015 1 +((((132*alpha4*r2+90*alpha3)*r2+56*alpha2)*r2+30*alpha1)* 4016 2 r2+12*alpha)*r2+2*gamma 4017 viou(lp,j) = (vj-viu(j)) * r(j) 4018 170 continue 4019 do 171 j=jrc+1,nr 4020 vou(j) = vou(j) + zo(i)*ar(j)*ar(j) 4021 171 continue 4022 endif 4023c 4024c njtj *** plotting routines *** 4025c potrw is called to save a usefull number of points 4026c of the pseudowave function to make a plot. The 4027c info is written to the current plot.dat file. 4028c wtrans is called to fourier transform the the pseudo 4029c wave function and save it to the current plot.dat file. 4030c 4031 ist=1 4032 call potrw(ar,r,nr-85,lo(i),0,ist) 4033 if (ev(i) .eq. zero .or. evi(i) .ne. zero) ist=2 4034 call wtrans(ar,r,nr,rab,lo(i),ist,wk1) 4035c 4036c njtj *** user should adjust for their needs *** 4037c 4038 write(6,180) nops(i),il(lp),so(i),ev(i),rc(lp),cdrc,delta 4039 180 format(1x,i1,a1,f6.1,5f12.6) 4040 190 continue 4041c 4042c End loop over valence orbitals. 4043c 4044c Reset the n quantum numbers to include all valence orbitals. 4045c Compute the ratio between the valence charge present and the 4046c valence charge of a neutral atom. 4047c Transfer pseudo valence charge to charge array 4048c 4049 zval = zero 4050 zratio = zero 4051 do 200 i=ncp,norb 4052 nops(i) = lo(i) + 1 4053 zval = zval + zo(i) 4054 200 continue 4055 zion = zval+znuc-zel 4056 if (zval .ne. zero) zratio=zion/zval 4057 do 210 i=1,nr 4058 cdd(i) = vod(i) 4059 210 continue 4060 do 211 i=1,nr 4061 cdu(i) = vou(i) 4062 211 continue 4063c 4064c If a core correction is indicated construct pseudo core charge 4065c cdc(r) = ac*r * sin(bc*r) inside r(icore) 4066c if cfac < 0 or the valence charge is zero the full core is used 4067c 4068 if (ifcore .ne. 0) then 4069 ac = zero 4070 bc = zero 4071 icore = 1 4072 if (cfac .le. zero .or. zratio .eq. zero) then 4073 write(6,280) r(icore),ac,bc 4074 else 4075 if (rcfac .le. zero) then 4076 do 220 i=nr,2,-1 4077 if (cdc(i) .gt. cfac*zratio*(cdd(i)+cdu(i))) goto 230 4078 220 continue 4079 else 4080 do 221 i=nr,2,-1 4081 if (r(i) .le. rcfac ) goto 230 4082 221 continue 4083 endif 4084 230 icore = i 4085 cdcp = (cdc(icore+1)-cdc(icore)) / (r(icore+1)-r(icore)) 4086 tanb = cdc(icore) / (r(icore)*cdcp-cdc(icore)) 4087 rbold = tpfive 4088 do 240 i=1,50 4089 rbnew = pi+atan(tanb*rbold) 4090 if (abs(rbnew-rbold) .lt. .00001) then 4091 bc = rbnew / r(icore) 4092 ac = cdc(icore) / (r(icore)*sin(rbnew)) 4093 do 260 j=1,icore 4094 cdc(j) = ac*r(j)*sin(bc*r(j)) 4095 260 continue 4096 write(6,280) r(icore),ac,bc 4097 goto 290 4098 else 4099 rbold=rbnew 4100 endif 4101 240 continue 4102 write(6,1030) 4103 call ext(830) 4104 endif 4105 endif 4106 280 format(//,' core correction used',/, 4107 1 ' pseudo core inside r =',f6.3,/,' ac =',f6.3,' bc =',f6.3,/) 4108 1030 format(//,' error in pseud2 - noncovergence in finding ', 4109 1 /,'pseudo-core values') 4110c 4111c End the pseudo core charge. 4112c Compute the potential due to pseudo valence charge. 4113c 4114c njtj *** NOTE *** 4115c Spin-polarized potentails should be unscreend with 4116c spin-polarized valence charge. This was not 4117c done in pseudo and pseudok in earlier versions 4118c of this program. 4119c njtj *** NOTE *** 4120c 4121 290 if (ispp .eq. 's') then 4122 blank='s' 4123 else 4124 blank=' ' 4125 endif 4126 zval2=zval 4127 call velect(0,1,icorr,blank,ifcore,nr,r,rab,zval, 4128 1 cdd,cdu,cdc,vod,vou,etot,wk1,wk2,wk3,wk4,wk5,wkb) 4129 if (ifcore .eq. 2) zion=zion+zval-zval2 4130c 4131c Construct the ionic pseudopotential and find the cutoff, 4132c ecut should be adjusted to give a reassonable ionic cutoff 4133c radius, but should not alter the pseudopotential, ie., 4134c the ionic cutoff radius should not be inside the pseudopotential 4135c cutoff radius 4136c 4137 ecut=ecuts 4138 do 315 i=ncp,norb 4139 lp = lo(i)+1 4140 if (so(i) .lt. 0.1) then 4141 do 300 j=2,nr 4142 viod(lp,j)=viod(lp,j) + (vid(j)-vod(j))*r(j) 4143 vp2z = viod(lp,j) + 2*zion 4144 if (abs(vp2z) .gt. ecut) jcut = j 4145 300 continue 4146 rcut(i-ncore) = r(jcut) 4147 do 310 j=jcut,nr 4148 fcut = exp(-5*(r(j)-r(jcut))) 4149 viod(lp,j) = - 2*zion + fcut * (viod(lp,j)+2*zion) 4150 310 continue 4151 do 311 j=2,nr 4152 v(j) = viod(lp,j)/r(j) 4153 311 continue 4154c 4155c njtj *** plotting routines *** 4156c 4157 call potran(lo(i)+1,v,r,nr,zion,wk1,wk2,wk3) 4158 call potrv(v,r,nr-120,lo(i)) 4159c 4160c njtj *** user should adjust for their needs *** 4161c 4162 else 4163 do 312 j=2,nr 4164 viou(lp,j)=viou(lp,j)+ (viu(j)-vou(j))*r(j) 4165 vp2z = viou(lp,j) + 2*zion 4166 if (abs(vp2z) .gt. ecut) jcut = j 4167 312 continue 4168 rcut(i-ncore) = r(jcut) 4169 do 313 j=jcut,nr 4170 fcut = exp(-5*(r(j)-r(jcut))) 4171 viou(lp,j) = - 2*zion + fcut * (viou(lp,j)+2*zion) 4172 313 continue 4173 do 314 j=2,nr 4174 v(j) = viou(lp,j)/r(j) 4175 314 continue 4176c 4177c njtj *** plotting routines *** 4178c 4179 call potran(lo(i)+1,v,r,nr,zion,wk1,wk2,wk3) 4180 call potrv(v,r,nr-110,lo(i)) 4181c 4182c njtj *** user should adjust for their needs *** 4183c 4184 endif 4185 315 continue 4186c 4187c njtj *** plotting routines *** 4188c The calls to 1)potran take the fourier transform of 4189c the potential and saves it in the current plot.dat file, 4190c 2)potrv saves the potential in the current plot.dat file 4191c 3)zion is saved to the current plot.dat file wtih a 4192c marker 'zio' for latter plotting 4193c 4194 write(3,4559) 4195 write(3,4560) zion 4196 4559 format(1x,'marker zio') 4197 4560 format(2x,f5.2) 4198c 4199c njtj *** user should adjust for their needs *** 4200c 4201c Convert spin-polarized potentials back to nonspin-polarized 4202c by occupation weight(zo). Assumes core polarization is 4203c zero, ie. polarization is only a valence effect. 4204c 4205 if (ispp .eq. 's' ) then 4206 do 500 i=ncp,norb,2 4207 lp = lo(i)+1 4208 zot=zo(i)+zo(i+1) 4209 if (zot .ne. zero) then 4210 do 505 j=2,nr 4211 viod(lp,j)=(viod(lp,j)*zo(i)+viou(lp,j) 4212 1 *zo(i+1))/zot 4213 viou(lp,j)=viod(lp,j) 4214 505 continue 4215 else 4216 do 506 j=2,nr 4217 viod(lp,j)=viod(lp,j)/2+viou(lp,j)/2 4218 viou(lp,j)=viod(lp,j) 4219 506 continue 4220 endif 4221 500 continue 4222 endif 4223c 4224 do 320 i=2,nr 4225 vid(i) = vod(i) 4226 viu(i) = vou(i) 4227 320 continue 4228c 4229c Test the pseudopotential self consistency. Spin-polarized 4230c is tested as spin-polarized(since up/down potentials are 4231c now the same) 4232c 4233 call dsolv2(0,1,blank,ifcore,lmax,nr,a,b,r,rab, 4234 1 norb-ncore,0,nops(ncp),lo(ncp),so(ncp),zo(ncp), 4235 2 znuc,cdd,cdu,cdc,viod,viou,vid,viu,ev(ncp),ek(ncp), 4236 3 ep(ncp),wk1,wk2,wk3,wk4,wk5,wk6,wk7,evi(ncp)) 4237c 4238c Printout the pseudo eigenvalues after cutoff. 4239c 4240 write(6,325) (il(lo(i)+1),rcut(i-ncore),i=ncp,norb) 4241 write(6,326) (ev(i),i=ncp,norb) 4242 325 format(//,' test of eigenvalues',//,' rcut =',8(2x,a1,f7.2)) 4243 326 format(' eval =',8(2x,f8.5)) 4244c 4245c Printout the data for potentials. 4246c 4247 write(6,330) 4248 330 format(///,' l vps(0) vpsmin at r',/) 4249 do 370 i=1,lmax 4250 if (indd(i)+indu(i) .eq. 0) goto 370 4251 if (indd(i) .ne. 0) then 4252 vpsdm = zero 4253 do 350 j=2,nr 4254 if (r(j) .lt. .00001) goto 350 4255 vps = viod(i,j)/r(j) 4256 if (vps .lt. vpsdm) then 4257 vpsdm = vps 4258 rmind = r(j) 4259 endif 4260 350 continue 4261 write(6,360) il(i),viod(i,2)/r(2),vpsdm,rmind 4262 endif 4263 if (indu(i) .ne. 0) then 4264 vpsum = zero 4265 do 351 j=2,nr 4266 if (r(j) .lt. .00001) goto 351 4267 vps = viou(i,j)/r(j) 4268 if (vps .lt. vpsum) then 4269 vpsum = vps 4270 rminu = r(j) 4271 endif 4272 351 continue 4273 write(6,360) il(i),viou(i,2)/r(2),vpsum,rminu 4274 endif 4275 360 format(1x,a1,3f10.3) 4276 370 continue 4277c 4278c Print out the energies from etotal. 4279c 4280 call etotal(itype,one,nameat,norb-ncore, 4281 1 nops(ncp),lo(ncp),so(ncp),zo(ncp), 4282 2 etot,ev(ncp),ek(ncp),ep(ncp)) 4283c 4284c Find the jobname and date, date is a machine 4285c dependent routine and must be chosen/written/ 4286c comment in/out in the zedate section. 4287c 4288 iray(1) = 'atom-lda ' 4289 call zedate(iray(2)) 4290 iray(3) = ' Improved' 4291 iray(4) = ' Troullier' 4292 iray(5) = ' - Martins' 4293 iray(6) = ' potential' 4294c 4295c Encode the title array. 4296c 4297 do 390 i=1,7 4298 ititle(i) = ' ' 4299 390 continue 4300 do 420 i=1,lmax 4301 if (indd(i) .eq. 0 .and. indu(i) .eq. 0) goto 420 4302 zelu = zero 4303 zeld = zero 4304 if (indd(i) .ne. 0) then 4305 noi = no(indd(i)) 4306 zeld = zo(indd(i)) 4307 endif 4308 if (indu(i) .ne. 0) then 4309 noi = no(indu(i)) 4310 zelu = zo(indu(i)) 4311 endif 4312 zelt = zeld + zelu 4313 if (ispp .ne. 's') then 4314 write(ititle(2*i-1),400) noi,il(i),zelt 4315 write(ititle(2*i),401)ispp,rc(i) 4316 400 format(i1,a1,'(',f6.2,')') 4317 401 format(a1,' rc=',f5.2) 4318 else 4319 write(ititle(2*i-1),410) noi,il(i),zeld 4320 write(ititle(2*i),411)zelu,ispp,rc(i) 4321 410 format(i1,a1,' (',f4.2,',') 4322 411 format(f4.2,')',a1,f4.2) 4323 endif 4324 420 continue 4325c 4326c Construct relativistic sum and difference potentials. 4327c 4328 if (ispp .eq. 'r') then 4329 if (indu(1) .eq. 0) goto 429 4330 indd(1)=indu(1) 4331 indu(1)=0 4332 do 428 j=2,nr 4333 viod(1,j) = viou(1,j) 4334 viou(1,j) = zero 4335 428 continue 4336 429 do 431 i=2,lmax 4337 if (indd(i) .eq. 0 .or. indu(i) .eq. 0) goto 431 4338 do 430 j=2,nr 4339 viodj = viod(i,j) 4340 viouj = viou(i,j) 4341 viod(i,j) = ((i-1)*viodj + i*viouj) / (2*i-1) 4342 viou(i,j) = 2 * (viouj - viodj) / (2*i-1) 4343 430 continue 4344 431 continue 4345 endif 4346c 4347c Determine the number of potentials. Coded them as 4348c two digits, where the first digit is the number 4349c of down or sum potentials and the second the number of 4350c up or difference potentials. 4351c 4352 npotd = 0 4353 npotu = 0 4354 do 450 i=1,lmax 4355 if (indd(i) .ne. 0) npotd=npotd+1 4356 if (indu(i) .ne. 0) npotu=npotu+1 4357 450 continue 4358c 4359c Write the heading to the current pseudo.dat 4360c file (unit=1). 4361c 4362 ifull = 0 4363 if (cfac .le. zero .or. zratio .eq. zero) ifull = 1 4364 if (ifcore .eq. 1) then 4365 if (ifull .eq. 0) then 4366 nicore = 'pcec' 4367 else 4368 nicore = 'fcec' 4369 endif 4370 elseif (ifcore .eq. 2) then 4371 if (ifull .eq. 0) then 4372 nicore = 'pche' 4373 else 4374 nicore = 'fche' 4375 endif 4376 else 4377 nicore = 'nc ' 4378 endif 4379 if (ispp .eq. 's') then 4380 irel='isp' 4381 elseif (ispp .eq. 'r') then 4382 irel='rel' 4383 else 4384 irel = 'nrl' 4385 endif 4386 rewind 1 4387 write(1) nameat,icorr,irel,nicore,(iray(i),i=1,6), 4388 1 (ititle(i),i=1,7),npotd,npotu,nr-1,a,b,zion 4389 write(1) (r(i),i=2,nr) 4390c 4391c Write the potentials to the current pseudo.dat 4392c file (unit=1). 4393c 4394 do 460 i=1,lmax 4395 if (indd(i) .eq. 0) goto 460 4396 write(1) i-1,(viod(i,j),j=2,nr) 4397 460 continue 4398 do 465 i=1,lmax 4399 if (indu(i) .eq. 0) goto 465 4400 write(1) i-1,(viou(i,j),j=2,nr) 4401 465 continue 4402c 4403c Write the charge densities to the current pseudo.dat 4404c file (unit=1). 4405c 4406 if (ifcore .eq. 0) then 4407 write(1) (zero,i=2,nr) 4408 else 4409 write(1) (cdc(i),i=2,nr) 4410 endif 4411 write(1) (zratio*(cdd(i)+cdu(i)),i=2,nr) 4412c 4413 return 4414 end 4415C 4416C 4417C 4418 subroutine pseudb(itype,icorr,ispp,lmax,nr,a,b,r,rab, 4419 1 nameat,norb,ncore,no,lo,so,zo,znuc,zel,cdd,cdu,cdc, 4420 2 viod,viou,vid,viu,vod,vou,etot,ev,ek,ep,wk1,wk2,wk3, 4421 3 wk4,wk5,wk6,wk7,f,g,nops,v,ar,br,arps,wkb,evi) 4422c 4423c ************************************************************* 4424c * * 4425c * pseudo generates the pseudo potential using * 4426c * the scheme of Bachelet, Hamann, and Schluter - * 4427c * Phys. Rev. B. 26, 4199. * 4428c * * 4429c ************************************************************* 4430c 4431c njtj *** modifications *** 4432c The only major modifications are in the spin-polarized 4433c treatment of the el-el unscreening of the pseudopotential 4434c A spin-polarized pseudopotential is unscreened 4435c with a spin-polarized valence charge. This was not done 4436c in pseudo or pseudok in earlier versions of this 4437c program. 4438c njtj *** modifications *** 4439c 4440c njtj 4441c ### Cray conversions 4442c ### 1)Comment out implicit double precision. 4443c ### 2)Switch double precision parameter 4444c ### to single precision parameter statement. 4445c ### Cray conversions 4446c njtj 4447c 4448 implicit double precision (a-h,o-z) 4449c 4450 parameter(zero=0.D0,ecuts=1.0D-3,tpfive=2.5D0,one=1.D0) 4451 parameter(small=1.D-13,small2=1.D-10,small3=1.D-18,pzfive=.05D0) 4452 parameter(pfive=0.5D0,small4=1.D-6,ai=2*137.0360411D0) 4453Cray parameter(zero=0.0,ecuts=1.0E-3,tpfive=2.5,one=1.0) 4454Cray parameter(small=1.E-13,small2=1.E-10,small3=1.E-18,pzfive=.05) 4455Cray parameter(pfive=0.5,small4=1.E-6,ai=2*137.0360411) 4456c 4457 character*1 ispp,blank,il(5) 4458 character*2 icorr,nameat 4459 character*3 irel 4460 character*4 nicore 4461 character*10 ititle(7),iray(6) 4462c 4463 dimension r(nr),rab(nr),no(norb),lo(norb),so(norb),zo(norb), 4464 1 cdd(nr),cdu(nr),cdc(nr),viod(lmax,nr),viou(lmax,nr), 4465 2 vid(nr),viu(nr),vod(nr),vou(nr),ev(norb),ek(norb),ep(norb), 4466 3 wk1(nr),wk2(nr),wk3(nr),wk4(nr),wk5(nr),wk6(nr),wk7(nr), 4467 4 wkb(6*nr),f(nr),g(nr),nops(norb),v(nr), 4468 5 ar(nr),br(nr),arps(nr),evi(norb) 4469c 4470 dimension etot(10),indd(5),indu(5),rc(5),rcut(10) 4471c 4472 data il/'s','p','d','f','g'/ 4473 do 3 i=1,5 4474 indd(i)=0 4475 indu(i)=0 4476 3 continue 4477 if (ncore .eq. norb) return 4478 if (itype .ne. 1 .and. itype .ne. 2 .and. itype .ne. 3) return 4479 ifcore = itype - 1 4480 pi = 4*atan(one) 4481c 4482c Spin-polarized potentails should be unscreened with 4483c a spin-polarized valence charge. This was not 4484c done in pseudo and pseudk in earlier versions 4485c of this program. 4486c 4487 if (ispp .eq. 's' ) then 4488 blank = 's' 4489 else 4490 blank = ' ' 4491 endif 4492c 4493c read rc(s),rc(p),rc(d),rc(f),rc(g),cfac,rcfac 4494c 4495c cfac is used for the pseudocore - the pseudocore stops where 4496c the core charge density equals cfac times the renormalized 4497c valence charge density (renormalized to make the atom neutral). 4498c If cfac is input as negative, the full core charge is used, 4499c if cfac is input as zero, it is set equal to one. 4500c rcfac is used for the pseudocore cut off radius. If set 4501c to less then or equal to zero cfac is used. cfac must be 4502c set to greater then zero. 4503c 4504 read(5,10) (rc(i),i=1,5),cfac,rcfac 4505 10 format(7f10.5) 4506 if (cfac .eq. zero) cfac=one 4507c 4508c Reset vod and vou to zero. They are here used to store 4509c the pseudo valence charge density. 4510c 4511 do 15 i=1,nr 4512 vod(i) = zero 4513 vou(i) = zero 4514 15 continue 4515c 4516c Print the heading. 4517c 4518 write(6,20) nameat 4519 20 format(//,a2,' Pseudopotential BHS generation',/,1x,35('-'),//, 4520 1 ' nl s eigenvalue',6x,'rc',4x,6x,'cl',9x,'gamma', 4521 2 7x,'delta',/) 4522c 4523c start loop over valence orbitals 4524c 4525 ncp = ncore+1 4526 do 190 i=ncp,norb 4527 lp = lo(i) + 1 4528 llp = lo(i)*lp 4529 if (so(i) .lt. 0.1) then 4530 if (indd(lp) .ne. 0) then 4531 write(6,1000)lp-1 4532 call ext(800+lp) 4533 else 4534 indd(lp) = i 4535 endif 4536 else 4537 if (indu(lp) .ne. 0) then 4538 write(6,1010)lp-1 4539 call ext(810+lp) 4540 else 4541 indu(lp) = i 4542 endif 4543 endif 4544 1000 format(//,'error in pseudb - two down spin orbitals of the same ', 4545 1 /,'angular momentum (',i1,') exist') 4546 1010 format(//,'error in pseudb - two up spin orbitals of the same ', 4547 1 /,'angular momentum (',i1,') exist') 4548c 4549c find all electron wave function 4550c 4551 do 25 j=1,nr 4552 ar(j)=zero 4553 25 continue 4554 if (so(i) .lt. 0.1) then 4555 do 27 j=2,nr 4556 v(j) = viod(lp,j)/r(j) + vid(j) 4557 27 continue 4558 else 4559 do 30 j=2,nr 4560 v(j) = viou(lp,j)/r(j) + viu(j) 4561 30 continue 4562 endif 4563 if (ispp .ne. 'r') then 4564 do 32 j=2,nr 4565 v(j) = v(j) + llp/r(j)**2 4566 32 continue 4567 endif 4568 if (ispp .ne. 'r') then 4569 call difnrl(0,i,v,ar,br,lmax,nr,a,b,r,rab,norb,no,lo,so, 4570 1 znuc,viod,viou,vid,viu,ev,iflag,wk1,wk2,wk3,evi) 4571 else 4572 call difrel(0,i,v,ar,br,lmax,nr,a,b,r,rab,norb,no,lo,so, 4573 1 znuc,viod,viou,vid,viu,ev,wk1,wk2,wk3,wk4,evi) 4574 endif 4575c 4576c njtj *** plotting routines *** 4577c potrw is called to save an usefull number of points 4578c of the wave function to make a plot. The info is 4579c written to the current plot.dat file. 4580c 4581 ist=1 4582 if (ar(nr-85) .lt. zero) ist=-1 4583 call potrw(ar,r,nr-85,lo(i),1,ist) 4584c 4585c njtj *** user should adjust for their needs *** 4586c 4587c Find the last zero and extremum. 4588c 4589 ka = lo(i)+1 4590 if (so(i) .lt. 0.1 .and. lo(i) .ne. 0) ka=-lo(i) 4591 nextr = no(i)-lo(i) 4592 rzero = zero 4593 arp = br(2) 4594c 4595 if (ispp .eq. 'r') then 4596 if (so(i) .lt. 0.1) then 4597 arp = ka*ar(2)/r(2) + (ev(i) - viod(lp,2)/r(2) 4598 1 - vid(2) + ai*ai) * br(2) / ai 4599 else 4600 arp = ka*ar(2)/r(2) + (ev(i) - viou(lp,2)/r(2) 4601 1 - viu(2) + ai*ai) * br(2) / ai 4602 endif 4603 endif 4604c 4605 do 40 j=3,nr-7 4606 if (nextr .eq. 0) goto 50 4607 if (ar(j-1)*ar(j) .le. zero) 4608 1 rzero = (ar(j)*r(j-1)-ar(j-1)*r(j)) / (ar(j)-ar(j-1)) 4609 arpm = arp 4610 arp = br(j) 4611c 4612 if (ispp .eq. 'r') then 4613 if (so(i) .lt. 0.1) then 4614 arp = ka*ar(j)/r(j) + (ev(i) - viod(lp,j)/r(j) 4615 1 - vid(j) + ai*ai) * br(j) / ai 4616 else 4617 arp = ka*ar(j)/r(j) + (ev(i) - viou(lp,j)/r(j) 4618 1 - viu(j) + ai*ai) * br(j) / ai 4619 endif 4620 endif 4621c 4622 if (arp*arpm .gt. zero) goto 40 4623 rextr = (arp*r(j-1)-arpm*r(j)) / (arp-arpm) 4624 nextr = nextr - 1 4625 40 continue 4626c 4627c Check rc, if outside bounds reset. 4628c 4629 50 if (rzero .lt. r(2)) rzero = r(2) 4630 if (rc(lp) .gt. rzero .and. rc(lp) .lt. rextr) goto 60 4631 if (rc(lp) .ge. rzero) then 4632 write(6,2001)rc(lp),rextr 4633 goto 60 4634 endif 4635 2001 format(/,'Warning, the Core radius =',f5.2, 4636 1 /,' is larger then wave function', 4637 1 ' extrema position =',f5.2,/) 4638 if (rc(lp) .lt. zero) rc(lp) = rzero - rc(lp)*(rextr-rzero) 4639c 4640c Reset the n quantum numbers. 4641c 4642 60 do 70 j=1,norb 4643 nops(j) = 0 4644 70 continue 4645 nops(i) = lp 4646c 4647c njtj *** modification start *** 4648c Sset up the functions f(r/rc) and g(r/rc) and 4649c modify the ionic potential. 4650c 4651 aa = (7*one)/2 4652 dcl = -6*one*lp 4653 cl = dcl 4654c 4655 do 80 j=1,nr 4656 rrc = r(j)/rc(lp) 4657 rra = rrc**aa 4658 f(j) = zero 4659 if (rra .lt. 88*one) f(j)=exp(-rra) 4660 g(j) = rrc**lp * f(j) 4661 fjm1 = one-f(j) 4662 if (fjm1 .lt. small4) fjm1=(one-pfive*rra)*rra 4663 if (so(i) .lt. 0.1) then 4664 viod(lp,j)=fjm1*viod(lp,j)-f(j)*r(j)*vid(j)+dcl*r(j)*f(j) 4665 else 4666c 4667c bug fix Alberto Garcia 5/11/90 4668c 4669 viou(lp,j)=fjm1*viou(lp,j)-f(j)*r(j)*viu(j)+dcl*r(j)*f(j) 4670 endif 4671 if (rrc .lt. 3*one) j3rc = j 4672 80 continue 4673 dcl=dcl/2 4674c 4675c Start the iteration loop to find cl. 4676c 4677 eviae = ev(i) 4678 devold = zero 4679 do 130 j=1,100 4680 call dsolv2(j,2,blank,ifcore,lmax, 4681 1 nr,a,b,r,rab,norb,ncore,nops,lo,so,zo,znuc,cdd,cdu,cdc, 4682 2 viod,viou,vid,viu,ev,ek,ep,wk1,wk2,wk3,wk4,wk5,wk6, 4683 3 wk7,evi) 4684 dev = eviae-ev(i) 4685c 4686c The abs(dev-devold) condition was added to eliminate 4687c division by zero errors in the calculation of 4688c dcl = -dev*dcl / (dev-devold). 4689c 4690 if ((abs(dev) .lt. small2 .or. abs(dev-devold) 4691 1 .lt. small3) .and. j .ne. 1) then 4692 goto 140 4693 else 4694 if (j .gt. 20 .or. abs(dev) .lt. 0.001) then 4695c 4696c Use newton raphson iteration to change cl. 4697c 4698 dcl = -dev*dcl / (dev-devold) 4699 else 4700 if (dev*dcl .lt. zero) then 4701 dcl=-dcl/3 4702 endif 4703 endif 4704 endif 4705c 4706c njtj *** modification end *** 4707c 4708c Find the new potential. 4709c 4710 100 if (so(i) .lt. 0.1) then 4711 do 110 k=2,nr 4712 viod(lp,k) = viod(lp,k) + dcl*r(k)*f(k) 4713 110 continue 4714 else 4715 do 111 k=2,nr 4716 viou(lp,k) = viou(lp,k) + dcl*r(k)*f(k) 4717 111 continue 4718 endif 4719 cl = cl + dcl 4720 devold = dev 4721 130 continue 4722c 4723c End the iteration loop for cl. 4724c 4725 call ext(820+lp) 4726c 4727c Find the pseudo-wavefunction. 4728c 4729 140 if (so(i) .lt. 0.1) then 4730 do 150 j=2,nr 4731 v(j) = (viod(lp,j)+llp/r(j))/r(j) + vid(j) 4732 150 continue 4733 else 4734 do 151 j=2,nr 4735 v(j) = (viou(lp,j)+llp/r(j))/r(j) + viu(j) 4736 151 continue 4737 endif 4738 call difnrl(0,i,v,arps,br,lmax,nr,a,b,r,rab,norb, 4739 1 nops,lo,so,znuc,viod,viou,vid,viu,ev,iflag,wk1, 4740 2 wk2,wk3,evi) 4741c 4742c Compute delta and gamma. 4743c 4744 gamma = abs(ar(j3rc)/arps(j3rc)+ar(j3rc+1)/arps(j3rc+1))/2 4745 ag = zero 4746 gg = zero 4747 ll = 4 4748 do 160 j=2,nr 4749 ag = ag + ll*arps(j)*g(j)*rab(j) 4750 gg = gg + ll*g(j)*g(j)*rab(j) 4751 ll = 6 - ll 4752 160 continue 4753 ag = ag/3 4754 gg = gg/3 4755 delta = sqrt((ag/gg)**2+(1/gamma**2-1)/gg) - ag/gg 4756c 4757c Modify the pseudo-wavefunction and pseudo-potential and 4758c add to charge density. 4759c 4760 if (so(i) .lt. 0.1) then 4761 do 170 j=2,nr 4762 arps(j) = gamma*(arps(j)+delta*g(j)) 4763 vod(j)=vod(j)+zo(i)*arps(j)*arps(j) 4764 if (arps(j) .lt. small .and. r(j) .gt. one) arps(j)=small 4765 rrp = r(j)/rc(lp) 4766 gpp=(llp-aa*(2*lp+aa-1)*rrp**aa+(aa*rrp**aa)**2) 4767 1 *g(j)/r(j)**2 4768 viod(lp,j) = viod(lp,j)+gamma*delta*((ev(i)- 4769 1 v(j))*g(j)+gpp)*r(j)/arps(j) 4770 170 continue 4771 else 4772 do 171 j=2,nr 4773 arps(j) = gamma*(arps(j)+delta*g(j)) 4774 vou(j)=vou(j)+zo(i)*arps(j)*arps(j) 4775 if (arps(j) .lt. small .and. r(j) .gt. one) arps(j)=small 4776 rrp = r(j)/rc(lp) 4777 gpp=(llp-aa*(2*lp+aa-1)*rrp**aa+(aa*rrp**aa)**2) 4778 1 *g(j)/r(j)**2 4779 viou(lp,j) = viou(lp,j)+gamma*delta*((ev(i)- 4780 1 v(j))*g(j)+gpp)*r(j)/arps(j) 4781 171 continue 4782 endif 4783c 4784c njtj *** plotting routines *** 4785c potrw is called to save a usefull number of points 4786c of the pseudowave function to make a plot. The 4787c info is written to the current plot.dat file. 4788c wtrans is called to fourier transform the the pseudo 4789c wave function and save it to the current plot.dat file. 4790c 4791 ist=1 4792 if (arps(nr-85) .lt. zero) ist=-1 4793 call potrw(arps,r,nr-85,lo(i),0,ist) 4794 if (ev(i) .eq. zero .or. evi(i) .ne. zero) ist=2 4795 call wtrans(arps,r,nr,rab,lo(i),ist,wk1) 4796c 4797c njtj *** user should adjust for their needs *** 4798c 4799 write(6,180) nops(i),il(lp),so(i),ev(i),rc(lp),cl,gamma,delta 4800 180 format(1x,i1,a1,f6.1,5f12.6) 4801 190 continue 4802c 4803c End loop over valence orbitals. 4804c 4805c Reset the n quantum numbers to include all valence orbitals. 4806c Compute the ratio between the valence charge present and the 4807c valence charge of a neutral atom. 4808c Transfer pseudo valence charge to charge array 4809c 4810 zval = zero 4811 zratio = zero 4812 do 200 i=ncp,norb 4813 nops(i) = lo(i) + 1 4814 zval = zval + zo(i) 4815 200 continue 4816 zion = zval+znuc-zel 4817 if (zval .ne. zero) zratio=zion/zval 4818 do 210 i=1,nr 4819 cdd(i) = vod(i) 4820 210 continue 4821 do 211 i=1,nr 4822 cdu(i) = vou(i) 4823 211 continue 4824c 4825c If a core correction is indicated construct pseudo core charge 4826c cdc(r) = ac*r * sin(bc*r) inside r(icore) 4827c if cfac < 0 or the valence charge is zero the full core is used 4828c 4829 if (ifcore .ne. 0) then 4830 ac = zero 4831 bc = zero 4832 icore = 1 4833 if (cfac .le. zero .or. zratio .eq. zero) then 4834 write(6,280) r(icore),ac,bc 4835 else 4836 if (rcfac .le. zero) then 4837 do 220 i=nr,2,-1 4838 if (cdc(i) .gt. cfac*zratio*(cdd(i)+cdu(i))) goto 230 4839 220 continue 4840 else 4841 do 221 i=nr,2,-1 4842 if (r(i) .le. rcfac ) goto 230 4843 221 continue 4844 endif 4845 230 icore = i 4846 cdcp = (cdc(icore+1)-cdc(icore)) / (r(icore+1)-r(icore)) 4847 tanb = cdc(icore) / (r(icore)*cdcp-cdc(icore)) 4848 rbold = tpfive 4849 do 240 i=1,50 4850 rbnew = pi+atan(tanb*rbold) 4851 if (abs(rbnew-rbold) .lt. .00001) then 4852 bc = rbnew / r(icore) 4853 ac = cdc(icore) / (r(icore)*sin(rbnew)) 4854 do 260 j=1,icore 4855 cdc(j) = ac*r(j)*sin(bc*r(j)) 4856 260 continue 4857 write(6,280) r(icore),ac,bc 4858 goto 290 4859 else 4860 rbold=rbnew 4861 endif 4862 240 continue 4863 write(6,1030) 4864 call ext(830) 4865 endif 4866 endif 4867 280 format(//,' core correction used',/, 4868 1 ' pseudo core inside r =',f6.3,/,' ac =',f6.3,' bc =',f6.3,/) 4869 1030 format(//,' error in pseudb - noncovergence in finding ', 4870 1 /,'pseudo-core values') 4871c 4872c End the pseudo core charge. 4873c Compute the potential due to pseudo valence charge. 4874c 4875c njtj *** NOTE *** 4876c Spin-polarized potentails should be unscreend with 4877c spin-polarized valence charge. This was not 4878c done in pseudo and pseudok in earlier versions 4879c of this program. 4880c njtj *** NOTE *** 4881c 4882 290 if (ispp .eq. 's') then 4883 blank='s' 4884 else 4885 blank=' ' 4886 endif 4887 call velect(0,1,icorr,blank,ifcore,nr,r,rab,zval, 4888 1 cdd,cdu,cdc,vod,vou,etot,wk1,wk2,wk3,wk4,wk5,wkb) 4889c 4890c Construct the ionic pseudopotential and find the cutoff, 4891c ecut should be adjusted to give a reassonable ionic cutoff 4892c radius, but should not alter the pseudopotential, ie., 4893c the ionic cutoff radius should not be inside the pseudopotential 4894c cutoff radius 4895c 4896 ecut=ecuts 4897 do 315 i=ncp,norb 4898 lp = lo(i)+1 4899 if (so(i) .lt. 0.1) then 4900 do 300 j=2,nr 4901 viod(lp,j)=viod(lp,j) + (vid(j)-vod(j))*r(j) 4902 vp2z = viod(lp,j) + 2*zion 4903 if (abs(vp2z) .gt. ecut) jcut = j 4904 300 continue 4905 rcut(i-ncore) = r(jcut) 4906 do 310 j=jcut,nr 4907 fcut = exp(-5*(r(j)-r(jcut))) 4908 viod(lp,j) = - 2*zion + fcut * (viod(lp,j)+2*zion) 4909 310 continue 4910 do 311 j=2,nr 4911 v(j) = viod(lp,j)/r(j) 4912 311 continue 4913c 4914c njtj *** plotting routines *** 4915c 4916 call potran(lo(i)+1,v,r,nr,zion,wk1,wk2,wk3) 4917 call potrv(v,r,nr-120,lo(i)) 4918c 4919c njtj *** user should adjust for their needs *** 4920c 4921 else 4922 do 312 j=2,nr 4923 viou(lp,j)=viou(lp,j)+ (viu(j)-vou(j))*r(j) 4924 vp2z = viou(lp,j) + 2*zion 4925 if (abs(vp2z) .gt. ecut) jcut = j 4926 312 continue 4927 rcut(i-ncore) = r(jcut) 4928 do 313 j=jcut,nr 4929 fcut = exp(-5*(r(j)-r(jcut))) 4930 viou(lp,j) = - 2*zion + fcut * (viou(lp,j)+2*zion) 4931 313 continue 4932 do 314 j=2,nr 4933 v(j) = viou(lp,j)/r(j) 4934 314 continue 4935c 4936c njtj *** plotting routines *** 4937c 4938 call potran(lo(i)+1,v,r,nr,zion,wk1,wk2,wk3) 4939 call potrv(v,r,nr-120,lo(i)) 4940c 4941c njtj *** user should adjust for their needs *** 4942c 4943 endif 4944 315 continue 4945c 4946c njtj *** plotting routines *** 4947c The calls to 1)potran take the fourier transform of 4948c the potential and saves it in the current plot.dat file, 4949c 2)potrv saves the potential in the current plot.dat file 4950c 3)zion is saved to the current plot.dat file wtih a 4951c marker 'zio' for latter plotting 4952c 4953 write(3,4559) 4954 write(3,4560) zion 4955 4559 format(1x,'marker zio') 4956 4560 format(2x,f5.2) 4957c 4958c njtj *** user should adjust for their needs *** 4959c 4960c Convert spin-polarized potentials back to nonspin-polarized 4961c by occupation weight(zo). Assumes core polarization is 4962c zero, ie. polarization is only a valence effect. 4963c 4964 if (ispp .eq. 's' ) then 4965 do 500 i=ncp,norb,2 4966 lp = lo(i)+1 4967 zot=zo(i)+zo(i+1) 4968 if (zot .ne. zero) then 4969 do 505 j=2,nr 4970 viod(lp,j)=(viod(lp,j)*zo(i)+viou(lp,j) 4971 1 *zo(i+1))/zot 4972 viou(lp,j)=viod(lp,j) 4973 505 continue 4974 else 4975 do 506 j=2,nr 4976 viod(lp,j)=viod(lp,j)/2+viou(lp,j)/2 4977 viou(lp,j)=viod(lp,j) 4978 506 continue 4979 endif 4980 500 continue 4981 endif 4982c 4983 do 320 i=2,nr 4984 vid(i) = vod(i) 4985 viu(i) = vou(i) 4986 320 continue 4987c 4988c Test the pseudopotential self consistency. Spin-polarized 4989c is tested as spin-polarized(since up/down potentials are 4990c now the same) 4991c 4992 call dsolv2(0,1,blank,ifcore,lmax,nr,a,b,r,rab, 4993 1 norb-ncore,0,nops(ncp),lo(ncp),so(ncp),zo(ncp), 4994 2 znuc,cdd,cdu,cdc,viod,viou,vid,viu,ev(ncp),ek(ncp), 4995 3 ep(ncp),wk1,wk2,wk3,wk4,wk5,wk6,wk7,evi(ncp)) 4996c 4997c Printout the pseudo eigenvalues after cutoff. 4998c 4999 write(6,325) (il(lo(i)+1),rcut(i-ncore),i=ncp,norb) 5000 write(6,326) (ev(i),i=ncp,norb) 5001 325 format(//,' test of eigenvalues',//,' rcut =',8(2x,a1,f7.2)) 5002 326 format(' eval =',8(2x,f8.5)) 5003c 5004c Printout the data for potentials. 5005c 5006 write(6,330) 5007 330 format(///,' l vps(0) vpsmin at r',/) 5008 do 370 i=1,lmax 5009 if (indd(i)+indu(i) .eq. 0) goto 370 5010 if (indd(i) .ne. 0) then 5011 vpsdm = zero 5012 do 350 j=2,nr 5013 if (r(j) .lt. .00001) goto 350 5014 vps = viod(i,j)/r(j) 5015 if (vps .lt. vpsdm) then 5016 vpsdm = vps 5017 rmind = r(j) 5018 endif 5019 350 continue 5020 write(6,360) il(i),viod(i,2)/r(2),vpsdm,rmind 5021 endif 5022 if (indu(i) .ne. 0) then 5023 vpsum = zero 5024 do 351 j=2,nr 5025 if (r(j) .lt. .00001) goto 351 5026 vps = viou(i,j)/r(j) 5027 if (vps .lt. vpsum) then 5028 vpsum = vps 5029 rminu = r(j) 5030 endif 5031 351 continue 5032 write(6,360) il(i),viou(i,2)/r(2),vpsum,rminu 5033 endif 5034 360 format(1x,a1,3f10.3) 5035 370 continue 5036c 5037c Print out the energies from etotal. 5038c 5039 call etotal(itype,one,nameat,norb-ncore, 5040 1 nops(ncp),lo(ncp),so(ncp),zo(ncp), 5041 2 etot,ev(ncp),ek(ncp),ep(ncp)) 5042c 5043c Find the jobname and date, date is a machine 5044c dependent routine and must be chosen/written/ 5045c comment in/out in the zedate section. 5046c 5047 iray(1) = 'atom-lda ' 5048 call zedate(iray(2)) 5049 iray(3) = 'Bachelet, ' 5050 iray(4) = 'Hamann,and' 5051 iray(5) = ' Schluter ' 5052 iray(6) = ' potential' 5053c 5054c Encode the title array. 5055c 5056 do 390 i=1,7 5057 ititle(i) = ' ' 5058 390 continue 5059 do 420 i=1,lmax 5060 if (indd(i) .eq. 0 .and. indu(i) .eq. 0) goto 420 5061 zelu = zero 5062 zeld = zero 5063 if (indd(i) .ne. 0) then 5064 noi = no(indd(i)) 5065 zeld = zo(indd(i)) 5066 endif 5067 if (indu(i) .ne. 0) then 5068 noi = no(indu(i)) 5069 zelu = zo(indu(i)) 5070 endif 5071 zelt = zeld + zelu 5072 if (ispp .ne. 's') then 5073 write(ititle(2*i-1),400) noi,il(i),zelt 5074 write(ititle(2*i),401)ispp,rc(i) 5075 400 format(i1,a1,'(',f6.2,')') 5076 401 format(a1,' rc=',f5.2) 5077 else 5078 write(ititle(2*i-1),410) noi,il(i),zeld 5079 write(ititle(2*i),411)zelu,ispp,rc(i) 5080 410 format(i1,a1,' (',f4.2,',') 5081 411 format(f4.2,')',a1,f4.2) 5082 endif 5083 420 continue 5084c 5085c Construct relativistic sum and difference potentials. 5086c 5087 if (ispp .eq. 'r') then 5088 if (indu(1) .eq. 0) goto 429 5089 indd(1)=indu(1) 5090 indu(1)=0 5091 do 428 j=2,nr 5092 viod(1,j) = viou(1,j) 5093 viou(1,j) = zero 5094 428 continue 5095 429 do 431 i=2,lmax 5096 if (indd(i) .eq. 0 .or. indu(i) .eq. 0) goto 431 5097 do 430 j=2,nr 5098 viodj = viod(i,j) 5099 viouj = viou(i,j) 5100 viod(i,j) = ((i-1)*viodj + i*viouj) / (2*i-1) 5101 viou(i,j) = 2 * (viouj - viodj) / (2*i-1) 5102 430 continue 5103 431 continue 5104 endif 5105c 5106c Determine the number of potentials. Coded them as 5107c two digits, where the first digit is the number 5108c of down or sum potentials and the second the number of 5109c up or difference potentials. 5110c 5111 npotd = 0 5112 npotu = 0 5113 do 450 i=1,lmax 5114 if (indd(i) .ne. 0) npotd=npotd+1 5115 if (indu(i) .ne. 0) npotu=npotu+1 5116 450 continue 5117c 5118c Write the heading to the current pseudo.dat 5119c file (unit=1). 5120c 5121 ifull = 0 5122 if (cfac .le. zero .or. zratio .eq. zero) ifull = 1 5123 if (ifcore .eq. 1) then 5124 if (ifull .eq. 0) then 5125 nicore = 'pcec' 5126 else 5127 nicore = 'fcec' 5128 endif 5129 elseif (ifcore .eq. 2) then 5130 if (ifull .eq. 0) then 5131 nicore = 'pche' 5132 else 5133 nicore = 'fche' 5134 endif 5135 else 5136 nicore = 'nc ' 5137 endif 5138 if (ispp .eq. 's') then 5139 irel='isp' 5140 elseif (ispp .eq. 'r') then 5141 irel='rel' 5142 else 5143 irel = 'nrl' 5144 endif 5145 rewind 1 5146 write(1) nameat,icorr,irel,nicore,(iray(i),i=1,6), 5147 1 (ititle(i),i=1,7),npotd,npotu,nr-1,a,b,zion 5148 write(1) (r(i),i=2,nr) 5149c 5150c Write the potentials to the current pseudo.dat 5151c file (unit=1). 5152c 5153 do 460 i=1,lmax 5154 if (indd(i) .eq. 0) goto 460 5155 write(1) i-1,(viod(i,j),j=2,nr) 5156 460 continue 5157 do 465 i=1,lmax 5158 if (indu(i) .eq. 0) goto 465 5159 write(1) i-1,(viou(i,j),j=2,nr) 5160 465 continue 5161c 5162c Write the charge densities to the current pseudo.dat 5163c file (unit=1). 5164c 5165 if (ifcore .eq. 0) then 5166 write(1) (zero,i=2,nr) 5167 else 5168 write(1) (cdc(i),i=2,nr) 5169 endif 5170 write(1) (zratio*(cdd(i)+cdu(i)),i=2,nr) 5171c 5172 return 5173 end 5174C 5175C 5176C 5177 subroutine pseudk(itype,icorr,ispp,lmax,nr,a,b, 5178 1 r,rab,nameat,norb,ncore,no,lo,so,zo,znuc,zel, 5179 2 cdd,cdu,cdc,viod,viou,vid,viu,vod,vou,etot,ev, 5180 3 ek,ep,wk1,wk2,wk3,wk4,wk5,wk6,wk7,nops,v,ar,br, 5181 4 wkb,evi) 5182c 5183c ************************************************************* 5184c * * 5185c * pseudk generates the pseudo potential using the * 5186c * scheme of G. P. Kerker, J. Phys. C13, L189 (1980). * 5187c * * 5188c ************************************************************* 5189c 5190c njtj *** modifications *** 5191c The only major modification is in the spin-polarization 5192c treatment of the unscreening of the pseudopotential. 5193c Spin-polarized potentails should be unscreend with 5194c spin-polarized valence charge. This was not 5195c done in pseudo and pseudk in earlier Berkeley/Froyen 5196c versions of this program. 5197c njtj *** modifications *** 5198c 5199c njtj 5200c ### Cray conversions 5201c ### 1)Comment out implicit double precision. 5202c ### 2)Switch double precision parameter 5203c ### to single precision parameter statement. 5204c ### Cray conversions 5205c njtj 5206c 5207 implicit double precision (a-h,o-z) 5208c 5209 parameter (zero=0.D0,tpfive=2.5D0,pfive=0.5D0,smtol=1.D-12) 5210 parameter (one=1.D0,ai=2*137.0360411D0,ecuts=1.0D-3) 5211Cray parameter (zero=0.0,tpfive=2.5,pfive=0.5,smtol=1.E-12) 5212Cray parameter (one=1.0,ai=2*137.0360411,ecuts=1.0D-3) 5213c 5214 character*1 ispp,blank,il(5) 5215 character*2 icorr,nameat 5216 character*3 irel 5217 character*4 nicore 5218 character*10 iray(6),ititle(7) 5219c 5220 dimension r(nr),rab(nr),no(norb),lo(norb),so(norb),zo(norb), 5221 1 cdd(nr),cdu(nr),cdc(nr),viod(lmax,nr),viou(lmax,nr), 5222 2 vid(nr),viu(nr),vod(nr),vou(nr),ev(norb),ek(norb),ep(norb), 5223 3 wk1(nr),wk2(nr),wk3(nr),wk4(nr),wk5(nr),wk6(nr),wk7(nr), 5224 4 wkb(3*nr),nops(norb),v(nr),ar(nr),br(nr),evi(norb) 5225c 5226 dimension indd(5),indu(5),rc(5),rcut(10),etot(10) 5227c 5228 data il/'s','p','d','f','g'/ 5229 do 3 i=1,5 5230 indd(i)=0 5231 indu(i)=0 5232 3 continue 5233 if (ncore .eq. norb) return 5234 if (itype .lt. 1 .or. itype .gt. 3) return 5235 ifcore = itype-1 5236 pi = 4*atan(one) 5237c 5238c read rc(s),rc(p),rc(d),rc(f),rc(g),cfac,rcfac 5239c 5240c cfac is used for the pseudocore - the pseudocore stops where 5241c the core charge density equals cfac times the renormalized 5242c valence charge density (renormalized to make the atom neutral). 5243c If cfac is input as negative, the full core charge is used, 5244c if cfac is input as zero, it is set equal to one. 5245c rcfac is used for the pseudocore cut off radius. If set 5246c to less then or equal to zero cfac is used. cfac must be 5247c set to greater then zero. 5248c 5249 read(5,10) (rc(i),i=1,5),cfac,rcfac 5250 10 format(7f10.5) 5251 if (cfac .eq. zero) cfac=one 5252c 5253c Reset vod and vou to zero, they are used to store the pseudo 5254c valence charge density. 5255c 5256 do 15 i=1,nr 5257 vod(i) = zero 5258 vou(i) = zero 5259 15 continue 5260c 5261c Print the heading. 5262c 5263 write(6,20) nameat 5264 20 format(//,a2,' Pseudopotential generation using the method', 5265 1 ' of Kerker',/,1x,60('-'),//, 5266 2 ' nl s eigenvalue',6x,'rc',4x,6x,'cdrc',7x,'delta', 5267 3 7x,/) 5268c 5269c start loop over valence orbitals 5270c 5271 ncp = ncore+1 5272 do 190 i=ncp,norb 5273 lp = lo(i) + 1 5274 llp = lo(i)*lp 5275 if (so(i) .lt. 0.1 .and. indd(lp) .ne. 0) call ext(800+lp) 5276 if (so(i) .gt. 0.1 .and. indu(lp) .ne. 0) call ext(810+lp) 5277 if (so(i) .lt. 0.1) then 5278 indd(lp) = i 5279 else 5280 indu(lp) = i 5281 endif 5282c 5283c Find the all-electron wave function. 5284c 5285 if (so(i) .lt. 0.1) then 5286 do 30 j=2,nr 5287 v(j) = viod(lp,j)/r(j) + vid(j) 5288 30 continue 5289 else 5290 do 31 j=2,nr 5291 v(j) = viou(lp,j)/r(j) + viu(j) 5292 31 continue 5293 endif 5294 if (ispp .ne. 'r') then 5295 do 32 j=2,nr 5296 v(j) = v(j) + llp/r(j)**2 5297 32 continue 5298 endif 5299 if (ispp .ne. 'r') then 5300 call difnrl(0,i,v,ar,br,lmax,nr,a,b,r,rab,norb,no,lo,so, 5301 1 znuc,viod,viou,vid,viu,ev,iflag,wk1,wk2,wk3,evi) 5302 else 5303 call difrel(0,i,v,ar,br,lmax,nr,a,b,r,rab,norb,no,lo,so, 5304 1 znuc,viod,viou,vid,viu,ev,wk1,wk2,wk3,wk4,evi) 5305 endif 5306c 5307c njtj *** plotting routines *** 5308c potrw is called to save an usefull number of points 5309c of the wave function to make a plot. The info is 5310c written to the current plot.dat file. 5311c 5312 ist=1 5313 if (ar(nr-85) .lt. zero) ist=-1 5314 call potrw(ar,r,nr-85,lo(i),1,ist) 5315c 5316c njtj *** user should adjust for their needs *** 5317c 5318c Find the last zero and extremum point. 5319c 5320 ka = lo(i)+1 5321 if (so(i) .lt. 0.1 .and. lo(i) .ne. 0) ka=-lo(i) 5322 nextr = no(i)-lo(i) 5323 rzero = zero 5324 arp = br(2) 5325c 5326 if (ispp .eq. 'r') then 5327 if (so(i) .lt. 0.1) then 5328 arp=ka*ar(2)/r(2)+(ev(i)-viod(lp,2)/r(2)-vid(2)+ai*ai)*br(2)/ai 5329 else 5330 arp=ka*ar(2)/r(2)+(ev(i)-viou(lp,2)/r(2)-viu(2)+ai*ai)*br(2)/ai 5331 endif 5332 endif 5333c 5334 do 40 j=3,nr-7 5335 if (nextr .eq. 0) goto 50 5336 if (ar(j-1)*ar(j) .le. zero) 5337 1 rzero = (ar(j)*r(j-1)-ar(j-1)*r(j)) / (ar(j)-ar(j-1)) 5338 arpm = arp 5339 arp = br(j) 5340c 5341 if (ispp .eq. 'r') then 5342 if(so(i) .lt. 0.1) then 5343 arp=ka*ar(j)/r(j)+(ev(i)-viod(lp,j)/r(j)- 5344 1 vid(j)+ai*ai)*br(j)/ai 5345 else 5346 arp=ka*ar(j)/r(j)+(ev(i)-viou(lp,j)/r(j)- 5347 1 viu(j)+ai*ai)*br(j)/ai 5348 endif 5349 endif 5350c 5351 if (arp*arpm .gt. zero) goto 40 5352 rextr = (arp*r(j-1)-arpm*r(j)) / (arp-arpm) 5353 nextr = nextr - 1 5354 40 continue 5355c 5356c Check rc, if outside bounds reset. 5357c 5358 50 if (rzero .lt. r(2)) rzero = r(2) 5359 if (rc(lp) .gt. rzero .and. rc(lp) .lt. rextr) goto 60 5360 if (rc(lp) .lt. zero) rc(lp) = rzero - rc(lp)*(rextr-rzero) 5361c 5362c Find index for grid point closest to rc. 5363c 5364 60 do 70 j=1,nr 5365 if (r(j) .gt. rc(lp)) goto 80 5366 jrc = j 5367 70 continue 5368c 5369c Reset the n quantum numbers. 5370c 5371 80 rc(lp)=r(jrc) 5372 do 90 j=1,norb 5373 nops(j) = 0 5374 90 continue 5375 nops(i) = lp 5376c 5377c Find the integrated charge inside rc. 5378c 5379 ll = 2 5380 if (ispp .eq. 'r') then 5381 cdrc = -(ar(jrc)*ar(jrc)+br(jrc)*br(jrc))*rab(jrc) 5382 if (jrc .ne. 2*(jrc/2)) then 5383 do 102 k=jrc,1,-1 5384 cdrc = cdrc+ll*(ar(k)*ar(k)+br(k)*br(k))*rab(k) 5385 ll = 6 - ll 5386 102 continue 5387 else 5388 do 103 k=jrc,4,-1 5389 cdrc = cdrc+ll*(ar(k)*ar(k)+br(k)*br(k))*rab(k) 5390 ll = 6 - ll 5391 103 continue 5392 cdrc = cdrc-(ar(4)*ar(4)+br(4)*br(4))*rab(4) 5393 cdrc = cdrc+9*((ar(1)*ar(1)+br(1)*br(1))*rab(1)+ 5394 1 3*(ar(2)*ar(2)+br(2)*br(2))*rab(2)+ 5395 2 3*(ar(3)*ar(3)+br(3)*br(3))*rab(3)+ 5396 3 (ar(4)*ar(4)+br(4)*br(4))*rab(4))/8 5397 endif 5398 cdrc = cdrc/3 5399 else 5400 cdrc = - ar(jrc) * ar(jrc) * rab(jrc) 5401 if (jrc .ne. 2*(jrc/2)) then 5402 do 100 k=jrc,1,-1 5403 cdrc = cdrc + ll * ar(k) * ar(k) * rab(k) 5404 ll = 6 - ll 5405 100 continue 5406 else 5407 do 101 k=jrc,4,-1 5408 cdrc = cdrc + ll * ar(k) * ar(k) * rab(k) 5409 ll = 6 - ll 5410 101 continue 5411 cdrc = cdrc - ar(4) * ar(4) * rab(4) 5412 cdrc = cdrc + 9 * ( ar(1) * ar(1) * rab(1) + 5413 1 3 * ar(2) *ar(2) * rab(2) + 5414 2 3 * ar(3) *ar(3) * rab(3) + 5415 3 ar(4) * ar(4) * rab(4))/8 5416 endif 5417 cdrc = cdrc/3 5418 endif 5419c 5420c The initial values for alpha, beta, gamma and delta. 5421c 5422 rc2 = r(jrc) * r(jrc) 5423 rc3 = r(jrc) * rc2 5424 rc4 = r(jrc) * rc3 5425 iswtch = 1 5426 if (ar(jrc) .lt. zero) iswtch = -1 5427 arc = iswtch * ar(jrc) 5428 arp = br(jrc) 5429c 5430 if (ispp .eq. 'r') then 5431 if(so(i) .lt. 0.1) then 5432 arp=ka*ar(jrc)/r(jrc)+(ev(i)-viod(lp,jrc)/r(jrc)- 5433 1 vid(jrc) + ai*ai) * br(jrc)/ai 5434 else 5435 arp=ka*ar(jrc)/r(jrc)+(ev(i)-viou(lp,jrc)/r(jrc)- 5436 1 viu(jrc) + ai*ai) * br(jrc)/ai 5437 endif 5438 endif 5439c 5440 brc = arp / ar(jrc) 5441 if (so(i) .lt. 0.1) then 5442 vrc = viod(lp,jrc)/r(jrc) + vid(jrc) 5443 else 5444 vrc = viou(lp,jrc)/r(jrc) + viu(jrc) 5445 endif 5446 alpha = ( 3*log(arc/r(jrc)**lp) - 2*(r(jrc)*brc-lp) 5447 1 + (rc2*vrc+lp*lp-rc2*(ev(i)+brc*brc))/2 ) / rc4 5448 beta = (-8*log(arc/r(jrc)**lp) + 5*(r(jrc)*brc-lp) 5449 1 - (rc2*vrc+lp*lp-rc2*(ev(i)+brc*brc)) ) / rc3 5450 gamma = ( 6*log(arc/r(jrc)**lp) - 3*(r(jrc)*brc-lp) 5451 1 + (rc2*vrc+lp*lp-rc2*(ev(i)+brc*brc))/2 ) / rc2 5452 delta = zero 5453c 5454c Start the iteration loop to find delta. 5455c 5456 do 150 j=1,50 5457c 5458c Generate the pseudo-wavefunction (note missing factor exp(delta)). 5459c 5460 do 110 k=1,jrc 5461 polyr=r(k)*r(k)*((alpha*r(k)+beta)*r(k)+gamma) 5462 ar(k) = iswtch * r(k)**lp * exp(polyr) 5463 110 continue 5464c 5465c Integrate the pseudo charge density from r = 0 to rc. 5466c 5467 ll = 2 5468 cdps = - ar(jrc) * ar(jrc) * rab(jrc) 5469 if (jrc .ne. 2*(jrc/2)) then 5470 do 120 k=jrc,1,-1 5471 cdps = cdps + ll * ar(k) * ar(k) * rab(k) 5472 ll = 6 - ll 5473 120 continue 5474 else 5475 do 121 k=jrc,4,-1 5476 cdps = cdps + ll * ar(k) * ar(k) * rab(k) 5477 ll = 6 - ll 5478 121 continue 5479 cdps = cdps - ar(4) * ar(4) * rab(4) 5480 cdps = cdps + 9 * ( ar(1) * ar(1) * rab(1) + 5481 1 3 * ar(2) *ar(2) * rab(2) + 5482 2 3 * ar(3) *ar(3) * rab(3) + 5483 3 ar(4) * ar(4) * rab(4))/8 5484 endif 5485 cdps = cdps/3 5486c 5487c Find the new delta. 5488c 5489 fdnew = log(cdrc/cdps) - 2*delta 5490 if (abs(fdnew) .lt. smtol) goto 160 5491 if (j .eq. 1) then 5492 ddelta = pfive 5493 else 5494 ddelta = - fdnew * ddelta / (fdnew-fdold) 5495 endif 5496 alpha = alpha - 3*ddelta/rc4 5497 beta = beta + 8*ddelta/rc3 5498 gamma = gamma - 6*ddelta/rc2 5499 delta = delta + ddelta 5500 fdold = fdnew 5501 150 continue 5502c 5503c End the iteration loop for delta. 5504c 5505 call ext(820+lp) 5506c 5507c Augment the charge density and invert schroedinger equation 5508c to find new potential. 5509c 5510 160 expd = exp(delta) 5511 if (so(i) .lt. 0.1) then 5512 do 170 j=1,jrc 5513 ar(j) = expd * ar(j) 5514 xlamda=(4*alpha*r(j)+3*beta)*r(j)+2*gamma 5515 vj = ev(i) + xlamda * (2 * lp + xlamda * r(j)**2) 5516 1 + (12 * alpha * r(j) + 6 * beta) * r(j) + 2 * gamma 5517 viod(lp,j) = (vj - vid(j)) * r(j) 5518 vod(j) = vod(j) + zo(i)*ar(j)*ar(j) 5519 170 continue 5520 do 171 j=jrc+1,nr 5521 vod(j) = vod(j) + zo(i)*ar(j)*ar(j) 5522 171 continue 5523 else 5524 do 175 j=1,jrc 5525 ar(j) = expd * ar(j) 5526 xlamda=(4*alpha*r(j)+3*beta)*r(j)+2*gamma 5527 vj = ev(i) + xlamda * (2 * lp + xlamda * r(j)**2) 5528 1 + (12 * alpha * r(j) + 6 * beta) * r(j) + 2 * gamma 5529 viou(lp,j) = (vj - viu(j)) * r(j) 5530 vou(j) = vou(j) + zo(i)*ar(j)*ar(j) 5531 175 continue 5532 do 176 j=jrc+1,nr 5533 vou(j) = vou(j) + zo(i)*ar(j)*ar(j) 5534 176 continue 5535 endif 5536 write(6,180) nops(i),il(lp),so(i),ev(i),rc(lp),cdrc,delta 5537 180 format(1x,i1,a1,f6.1,5f12.6) 5538c 5539c njtj *** plotting routines *** 5540c potrw is called to save a usefull number of points 5541c of the pseudowave function to make a plot. The 5542c info is written to the current plot.dat file. 5543c wtrans is called to fourier transform the the pseudo 5544c wave function and save it to the current plot.dat file. 5545c 5546 ist=1 5547 if (ar(nr-85) .lt. zero) ist=-1 5548 call potrw(ar,r,nr-85,lo(i),0,ist) 5549 if (ev(i) .eq. zero .or. evi(i) .ne. zero) ist=2 5550 call wtrans(ar,r,nr,rab,lo(i),ist,wk1) 5551c 5552c njtj *** user should adjust for their needs *** 5553c 5554 5555 190 continue 5556c 5557c End loop over valence orbitals. 5558c 5559c Reset the n quantum numbers to include all valence orbitals. 5560c Compute the ratio between the valence charge present and the 5561c valence charge of a neutral atom. 5562c Transfer pseudo valence charge to charge array 5563c 5564 zval = zero 5565 zratio = zero 5566 do 200 i=ncp,norb 5567 nops(i) = lo(i) + 1 5568 zval = zval + zo(i) 5569 200 continue 5570 zion = zval+znuc-zel 5571 if (zval .ne. zero) zratio=zion/zval 5572 do 210 i=1,nr 5573 cdd(i) = vod(i) 5574 210 continue 5575 do 211 i=1,nr 5576 cdu(i) = vou(i) 5577 211 continue 5578c 5579c If a core correction is indicated construct pseudo core charge 5580c cdc(r) = ac*r * sin(bc*r) inside r(icore) 5581c if cfac < 0 or the valence charge is zero the full core is used 5582c 5583 if (ifcore .ne. 0) then 5584 ac = zero 5585 bc = zero 5586 icore = 1 5587 if (cfac .le. zero .or. zratio .eq. zero) then 5588 write(6,280) r(icore),ac,bc 5589 else 5590 if (rcfac .le. zero) then 5591 do 220 i=nr,2,-1 5592 if (cdc(i) .gt. cfac*zratio*(cdd(i)+cdu(i))) goto 230 5593 220 continue 5594 else 5595 do 221 i=nr,2,-1 5596 if (r(i) .le. rcfac ) goto 230 5597 221 continue 5598 endif 5599 230 icore = i 5600 cdcp = (cdc(icore+1)-cdc(icore)) / (r(icore+1)-r(icore)) 5601 tanb = cdc(icore) / (r(icore)*cdcp-cdc(icore)) 5602 rbold = tpfive 5603 do 240 i=1,50 5604 rbnew = pi+atan(tanb*rbold) 5605 if (abs(rbnew-rbold) .lt. .00001) then 5606 bc = rbnew / r(icore) 5607 ac = cdc(icore) / (r(icore)*sin(rbnew)) 5608 do 260 j=1,icore 5609 cdc(j) = ac*r(j)*sin(bc*r(j)) 5610 260 continue 5611 write(6,280) r(icore),ac,bc 5612 goto 290 5613 else 5614 rbold=rbnew 5615 endif 5616 240 continue 5617 write(6,1030) 5618 call ext(830) 5619 endif 5620 endif 5621 280 format(//,' core correction used',/, 5622 1 ' pseudo core inside r =',f6.3,/,' ac =',f6.3,' bc =',f6.3,/) 5623 1030 format(//,' error in pseudk - noncovergence in finding ', 5624 1 /,'pseudo-core values') 5625c 5626c End the pseudo core charge. 5627c Compute the potential due to pseudo valence charge. 5628c 5629c njtj *** NOTE *** 5630c Spin-polarized potentails should be unscreend with 5631c spin-polarized valence charge. This was not 5632c done in pseudo and pseudok in earlier versions 5633c of this program. 5634c njtj *** NOTE *** 5635c 5636 290 if (ispp .eq. 's') then 5637 blank='s' 5638 else 5639 blank=' ' 5640 endif 5641 call velect(0,1,icorr,blank,ifcore,nr,r,rab,zval, 5642 1 cdd,cdu,cdc,vod,vou,etot,wk1,wk2,wk3,wk4,wk5,wkb) 5643c 5644c Construct the ionic pseudopotential and find the cutoff, 5645c ecut should be adjusted to give a reassonable ionic cutoff 5646c radius, but should not alter the pseudopotential, ie., 5647c the ionic cutoff radius should not be inside the pseudopotential 5648c cutoff radius 5649c 5650 ecut=ecuts 5651 do 315 i=ncp,norb 5652 lp = lo(i)+1 5653 if (so(i) .lt. 0.1) then 5654 do 500 j=2,nr 5655 viod(lp,j)=viod(lp,j) + (vid(j)-vod(j))*r(j) 5656 vp2z = viod(lp,j) + 2*zion 5657 if (abs(vp2z) .gt. ecut) jcut = j 5658 500 continue 5659 rcut(i-ncore) = r(jcut) 5660 do 510 j=jcut,nr 5661 fcut = exp(-5*(r(j)-r(jcut))) 5662 viod(lp,j) = - 2*zion + fcut * (viod(lp,j)+2*zion) 5663 510 continue 5664 do 511 j=2,nr 5665 v(j) = viod(lp,j)/r(j) 5666 511 continue 5667c 5668c njtj *** plotting routines *** 5669c 5670 call potran(lo(i)+1,v,r,nr,zion,wk1,wk2,wk3) 5671 call potrv(v,r,nr-120,lo(i)) 5672c 5673c njtj *** user should adjust for their needs *** 5674c 5675 else 5676 do 512 j=2,nr 5677 viou(lp,j)=viou(lp,j)+ (viu(j)-vou(j))*r(j) 5678 vp2z = viou(lp,j) + 2*zion 5679 if (abs(vp2z) .gt. ecut) jcut = j 5680 512 continue 5681 rcut(i-ncore) = r(jcut) 5682 do 513 j=jcut,nr 5683 fcut = exp(-5*(r(j)-r(jcut))) 5684 viou(lp,j) = - 2*zion + fcut * (viou(lp,j)+2*zion) 5685 513 continue 5686 do 514 j=2,nr 5687 v(j) = viou(lp,j)/r(j) 5688 514 continue 5689c 5690c njtj *** plotting routines *** 5691c 5692 call potran(lo(i)+1,v,r,nr,zion,wk1,wk2,wk3) 5693 call potrv(v,r,nr-120,lo(i)) 5694c 5695c njtj *** user should adjust for their needs *** 5696c 5697 endif 5698 315 continue 5699c 5700c njtj *** plotting routines *** 5701c The calls to 1)potran take the fourier transform of 5702c the potential and saves it in the current plot.dat file, 5703c 2)potrv saves the potential in the current plot.dat file 5704c 3)zion is saved to the current plot.dat file wtih a 5705c marker 'zio' for latter plotting 5706c 5707 write(3,4559) 5708 write(3,4560) zion 5709 4559 format(1x,'marker zio') 5710 4560 format(2x,f5.2) 5711c 5712c njtj *** user should adjust for their needs *** 5713c 5714c Convert spin-polarized potentials back to nonspin-polarized 5715c by occupation weight(zo). Assumes core polarization is 5716c zero, ie. polarization is only a valence effect. 5717c 5718 if (ispp .eq. 's' ) then 5719 do 700 i=ncp,norb,2 5720 lp = lo(i)+1 5721 zot=zo(i)+zo(i+1) 5722 if (zot .ne. zero) then 5723 do 705 j=2,nr 5724 viod(lp,j)=(viod(lp,j)*zo(i)+viou(lp,j) 5725 1 *zo(i+1))/zot 5726 viou(lp,j)=viod(lp,j) 5727 705 continue 5728 else 5729 do 706 j=2,nr 5730 viod(lp,j)=viod(lp,j)/2+viou(lp,j)/2 5731 viou(lp,j)=viod(lp,j) 5732 706 continue 5733 endif 5734 700 continue 5735 endif 5736c 5737 do 320 i=2,nr 5738 vid(i) = vod(i) 5739 viu(i) = vou(i) 5740 320 continue 5741c 5742c Test the pseudopotential self consistency. Spin-polarized 5743c is tested as spin-polarized(since up/down potentials are 5744c now the same) 5745c 5746 call dsolv2(0,1,blank,ifcore,lmax,nr,a,b,r,rab, 5747 1 norb-ncore,0,nops(ncp),lo(ncp),so(ncp),zo(ncp), 5748 2 znuc,cdd,cdu,cdc,viod,viou,vid,viu,ev(ncp),ek(ncp), 5749 3 ep(ncp),wk1,wk2,wk3,wk4,wk5,wk6,wk7,evi(ncp)) 5750c 5751c Printout the pseudo eigenvalues after cutoff. 5752c 5753 write(6,325) (il(lo(i)+1),rcut(i-ncore),i=ncp,norb) 5754 write(6,326) (ev(i),i=ncp,norb) 5755 325 format(//,' test of eigenvalues',//,' rcut =',8(2x,a1,f7.2)) 5756 326 format(' eval =',8(2x,f8.5)) 5757c 5758c Printout the data for potentials. 5759c 5760 write(6,330) 5761 330 format(///,' l vps(0) vpsmin at r',/) 5762 do 370 i=1,lmax 5763 if (indd(i)+indu(i) .eq. 0) goto 370 5764 if (indd(i) .ne. 0) then 5765 vpsdm = zero 5766 do 350 j=2,nr 5767 if (r(j) .lt. .00001) goto 350 5768 vps = viod(i,j)/r(j) 5769 if (vps .lt. vpsdm) then 5770 vpsdm = vps 5771 rmind = r(j) 5772 endif 5773 350 continue 5774 write(6,360) il(i),viod(i,2)/r(2),vpsdm,rmind 5775 endif 5776 if (indu(i) .ne. 0) then 5777 vpsum = zero 5778 do 351 j=2,nr 5779 if (r(j) .lt. .00001) goto 351 5780 vps = viou(i,j)/r(j) 5781 if (vps .lt. vpsum) then 5782 vpsum = vps 5783 rminu = r(j) 5784 endif 5785 351 continue 5786 write(6,360) il(i),viou(i,2)/r(2),vpsum,rminu 5787 endif 5788 360 format(1x,a1,3f10.3) 5789 370 continue 5790c 5791c Print out the energies from etotal. 5792c 5793 call etotal(itype,one,nameat,norb-ncore, 5794 1 nops(ncp),lo(ncp),so(ncp),zo(ncp), 5795 2 etot,ev(ncp),ek(ncp),ep(ncp)) 5796c 5797c Find the jobname and date, date is a machine 5798c dependent routine and must be chosen/written/ 5799c comment in/out in the zedate section. 5800c 5801 iray(1) = 'atom-lda ' 5802 call zedate(iray(2)) 5803 iray(3) = ' Kerker-' 5804 iray(4) = 'potential ' 5805 do 380 i=5,6 5806 iray(i) = ' ' 5807 380 continue 5808c 5809c Encode the title array. 5810c 5811 do 390 i=1,7 5812 ititle(i) = ' ' 5813 390 continue 5814 do 420 i=1,lmax 5815 if (indd(i) .eq. 0 .and. indu(i) .eq. 0) goto 420 5816 zelu = zero 5817 zeld = zero 5818 if (indd(i) .ne. 0) then 5819 noi = no(indd(i)) 5820 zeld = zo(indd(i)) 5821 endif 5822 if (indu(i) .ne. 0) then 5823 noi = no(indu(i)) 5824 zelu = zo(indu(i)) 5825 endif 5826 zelt = zeld + zelu 5827 if (ispp .ne. 's') then 5828 write(ititle(2*i-1),400) noi,il(i),zelt 5829 write(ititle(2*i),401)ispp,rc(i) 5830 400 format(i1,a1,'(',f6.2,')') 5831 401 format(a1,' rc=',f5.2) 5832 else 5833 write(ititle(2*i-1),410) noi,il(i),zeld 5834 write(ititle(2*i),411)zelu,ispp,rc(i) 5835 410 format(i1,a1,' (',f4.2,',') 5836 411 format(f4.2,')',a1,f4.2) 5837 endif 5838 420 continue 5839c 5840c Construct relativistic sum and difference potentials. 5841c 5842 if (ispp .eq. 'r') then 5843 if (indu(1) .eq. 0) goto 429 5844 indd(1)=indu(1) 5845 indu(1)=0 5846 do 428 j=2,nr 5847 viod(1,j) = viou(1,j) 5848 viou(1,j) = zero 5849 428 continue 5850 429 do 431 i=2,lmax 5851 if (indd(i) .eq. 0 .or. indu(i) .eq. 0) goto 431 5852 do 430 j=2,nr 5853 viodj = viod(i,j) 5854 viouj = viou(i,j) 5855 viod(i,j) = ((i-1)*viodj + i*viouj) / (2*i-1) 5856 viou(i,j) = 2 * (viouj - viodj) / (2*i-1) 5857 430 continue 5858 431 continue 5859 endif 5860c 5861c Determine the number of potentials. Coded them as 5862c two digits, where the first digit is the number 5863c of down or sum potentials and the second the number of 5864c up or difference potentials. 5865c 5866 npotd = 0 5867 npotu = 0 5868 do 450 i=1,lmax 5869 if (indd(i) .ne. 0) npotd=npotd+1 5870 if (indu(i) .ne. 0) npotu=npotu+1 5871 450 continue 5872c 5873c Write the heading to the current pseudo.dat 5874c file (unit=1). 5875c 5876 ifull = 0 5877 if (cfac .le. zero .or. zratio .eq. zero) ifull = 1 5878 if (ifcore .eq. 1) then 5879 if (ifull .eq. 0) then 5880 nicore = 'pcec' 5881 else 5882 nicore = 'fcec' 5883 endif 5884 elseif (ifcore .eq. 2) then 5885 if (ifull .eq. 0) then 5886 nicore = 'pche' 5887 else 5888 nicore = 'fche' 5889 endif 5890 else 5891 nicore = 'nc ' 5892 endif 5893 if (ispp .eq. 's') then 5894 irel='isp' 5895 elseif (ispp .eq. 'r') then 5896 irel='rel' 5897 else 5898 irel = 'nrl' 5899 endif 5900 rewind 1 5901 write(1) nameat,icorr,irel,nicore,(iray(i),i=1,6), 5902 1 (ititle(i),i=1,7),npotd,npotu,nr-1,a,b,zion 5903 write(1) (r(i),i=2,nr) 5904c 5905c Write the potentials to the current pseudo.dat 5906c file (unit=1). 5907c 5908 do 460 i=1,lmax 5909 if (indd(i) .eq. 0) goto 460 5910 write(1) i-1,(viod(i,j),j=2,nr) 5911 460 continue 5912 do 465 i=1,lmax 5913 if (indu(i) .eq. 0) goto 465 5914 write(1) i-1,(viou(i,j),j=2,nr) 5915 465 continue 5916c 5917c Write the charge densities to the current pseudo.dat 5918c file (unit=1). 5919c 5920 if (ifcore .eq. 0) then 5921 write(1) (zero,i=2,nr) 5922 else 5923 write(1) (cdc(i),i=2,nr) 5924 endif 5925 write(1) (zratio*(cdd(i)+cdu(i)),i=2,nr) 5926c 5927 return 5928 end 5929C 5930C 5931C 5932 subroutine pseudo(itype,icorr,ispp,lmax,nr,a,b,r,rab, 5933 1 nameat,norb,ncore,no,lo,so,zo,znuc,zel,cdd,cdu,cdc, 5934 2 viod,viou,vid,viu,vod,vou,etot,ev,ek,ep,wk1,wk2,wk3, 5935 3 wk4,wk5,wk6,wk7,f,g,nops,v,ar,br,arps,wkb,evi) 5936c 5937c ************************************************************* 5938c * * 5939c * pseudo generates the pseudo potential using * 5940c * the scheme of Hamann, Schluter and Chiang - * 5941c * Phys. Rev. Lett. 43, 1494 (1979). * 5942c * * 5943c ************************************************************* 5944c 5945c njtj *** modifications *** 5946c The only major modifications are in the spin-polarized 5947c treatment of the el-el unscreening of the pseudopotential 5948c A spin-polarized pseudopotential is unscreened 5949c with a spin-polarized valence charge. This was not done 5950c in pseudo or pseudok in earlier versions of this 5951c program. 5952c njtj *** modifications *** 5953c 5954c njtj 5955c ### Cray conversions 5956c ### 1)Comment out implicit double precision. 5957c ### 2)Switch double precision parameter 5958c ### to single precision parameter statement. 5959c ### Cray conversions 5960c njtj 5961c 5962 implicit double precision (a-h,o-z) 5963c 5964 parameter(zero=0.D0,ecuts=1.0D-3,tpfive=2.5D0,one=1.D0) 5965 parameter(small=1.D-13,small2=1.D-10,small3=1.D-18,pzfive=.05D0) 5966 parameter(pfive=0.5D0,small4=1.D-6,ai=2*137.0360411D0) 5967Cray parameter(zero=0.0,ecuts=1.0E-3,tpfive=2.5,one=1.0) 5968Cray parameter(small=1.E-13,small2=1.E-10,small3=1.E-18,pzfive=.05) 5969Cray parameter(pfive=0.5,small4=1.E-6,ai=2*137.0360411) 5970c 5971 character*1 ispp,blank,il(5) 5972 character*2 icorr,nameat 5973 character*3 irel 5974 character*4 nicore 5975 character*10 ititle(7),iray(6) 5976c 5977 dimension r(nr),rab(nr),no(norb),lo(norb),so(norb),zo(norb), 5978 1 cdd(nr),cdu(nr),cdc(nr),viod(lmax,nr),viou(lmax,nr), 5979 2 vid(nr),viu(nr),vod(nr),vou(nr),ev(norb),ek(norb),ep(norb), 5980 3 wk1(nr),wk2(nr),wk3(nr),wk4(nr),wk5(nr),wk6(nr),wk7(nr), 5981 4 wkb(6*nr),f(nr),g(nr),nops(norb),v(nr), 5982 5 ar(nr),br(nr),arps(nr),evi(norb) 5983c 5984 dimension etot(10),indd(5),indu(5),rc(5),rcut(10) 5985c 5986 data il/'s','p','d','f','g'/ 5987 do 3 i=1,5 5988 indd(i)=0 5989 indu(i)=0 5990 3 continue 5991 if (ncore .eq. norb) return 5992 if (itype .ne. 1 .and. itype .ne. 2 .and. itype .ne. 3) return 5993 ifcore = itype - 1 5994 pi = 4*atan(one) 5995c 5996c Spin-polarized potentails should be unscreened with 5997c a spin-polarized valence charge. This was not 5998c done in pseudo and pseudk in earlier versions 5999c of this program. 6000c 6001 if (ispp .eq. 's' ) then 6002 blank = 's' 6003 else 6004 blank = ' ' 6005 endif 6006c 6007c read rc(s),rc(p),rc(d),rc(f),rc(g),cfac,rcfac 6008c 6009c cfac is used for the pseudocore - the pseudocore stops where 6010c the core charge density equals cfac times the renormalized 6011c valence charge density (renormalized to make the atom neutral). 6012c If cfac is input as negative, the full core charge is used, 6013c if cfac is input as zero, it is set equal to one. 6014c rcfac is used for the pseudocore cut off radius. If set 6015c to less then or equal to zero cfac is used. cfac must be 6016c set to greater then zero. 6017c 6018 read(5,10) (rc(i),i=1,5),cfac,rcfac 6019 10 format(7f10.5) 6020 if (cfac .eq. zero) cfac=one 6021c 6022c Reset vod and vou to zero. They are here used to store 6023c the pseudo valence charge density. 6024c 6025 do 15 i=1,nr 6026 vod(i) = zero 6027 vou(i) = zero 6028 15 continue 6029c 6030c Print the heading. 6031c 6032 write(6,20) nameat 6033 20 format(//,a2,' Pseudopotential HSC generation',/,1x,35('-'),//, 6034 1 ' nl s eigenvalue',6x,'rc',4x,6x,'cl',9x,'gamma', 6035 2 7x,'delta',/) 6036c 6037c start loop over valence orbitals 6038c 6039 ncp = ncore+1 6040 do 190 i=ncp,norb 6041 lp = lo(i) + 1 6042 llp = lo(i)*lp 6043 if (so(i) .lt. 0.1) then 6044 if (indd(lp) .ne. 0) then 6045 write(6,1000)lp-1 6046 call ext(800+lp) 6047 else 6048 indd(lp) = i 6049 endif 6050 else 6051 if (indu(lp) .ne. 0) then 6052 write(6,1010)lp-1 6053 call ext(810+lp) 6054 else 6055 indu(lp) = i 6056 endif 6057 endif 6058 1000 format(//,'error in pseudo - two down spin orbitals of the same ', 6059 1 /,'angular momentum (',i1,') exist') 6060 1010 format(//,'error in pseudo - two up spin orbitals of the same ', 6061 1 /,'angular momentum (',i1,') exist') 6062c 6063c find all electron wave function 6064c 6065 do 25 j=1,nr 6066 ar(j)=zero 6067 25 continue 6068 if (so(i) .lt. 0.1) then 6069 do 27 j=2,nr 6070 v(j) = viod(lp,j)/r(j) + vid(j) 6071 27 continue 6072 else 6073 do 30 j=2,nr 6074 v(j) = viou(lp,j)/r(j) + viu(j) 6075 30 continue 6076 endif 6077 if (ispp .ne. 'r') then 6078 do 32 j=2,nr 6079 v(j) = v(j) + llp/r(j)**2 6080 32 continue 6081 endif 6082 if (ispp .ne. 'r') then 6083 call difnrl(0,i,v,ar,br,lmax,nr,a,b,r,rab,norb,no,lo,so, 6084 1 znuc,viod,viou,vid,viu,ev,iflag,wk1,wk2,wk3,evi) 6085 else 6086 call difrel(0,i,v,ar,br,lmax,nr,a,b,r,rab,norb,no,lo,so, 6087 1 znuc,viod,viou,vid,viu,ev,wk1,wk2,wk3,wk4,evi) 6088 endif 6089c 6090c njtj *** plotting routines *** 6091c potrw is called to save an usefull number of points 6092c of the wave function to make a plot. The info is 6093c written to the current plot.dat file. 6094c 6095 ist=1 6096 if (ar(nr-85) .lt. zero) ist=-1 6097 call potrw(ar,r,nr-85,lo(i),1,ist) 6098c 6099c njtj *** user should adjust for their needs *** 6100c 6101c Find the last zero and extremum. 6102c 6103 ka = lo(i)+1 6104 if (so(i) .lt. 0.1 .and. lo(i) .ne. 0) ka=-lo(i) 6105 nextr = no(i)-lo(i) 6106 rzero = zero 6107 arp = br(2) 6108c 6109 if (ispp .eq. 'r') then 6110 if (so(i) .lt. 0.1) then 6111 arp = ka*ar(2)/r(2) + (ev(i) - viod(lp,2)/r(2) 6112 1 - vid(2) + ai*ai) * br(2) / ai 6113 else 6114 arp = ka*ar(2)/r(2) + (ev(i) - viou(lp,2)/r(2) 6115 1 - viu(2) + ai*ai) * br(2) / ai 6116 endif 6117 endif 6118c 6119 do 40 j=3,nr-7 6120 if (nextr .eq. 0) goto 50 6121 if (ar(j-1)*ar(j) .le. zero) 6122 1 rzero = (ar(j)*r(j-1)-ar(j-1)*r(j)) / (ar(j)-ar(j-1)) 6123 arpm = arp 6124 arp = br(j) 6125c 6126 if (ispp .eq. 'r') then 6127 if (so(i) .lt. 0.1) then 6128 arp = ka*ar(j)/r(j) + (ev(i) - viod(lp,j)/r(j) 6129 1 - vid(j) + ai*ai) * br(j) / ai 6130 else 6131 arp = ka*ar(j)/r(j) + (ev(i) - viou(lp,j)/r(j) 6132 1 - viu(j) + ai*ai) * br(j) / ai 6133 endif 6134 endif 6135c 6136 if (arp*arpm .gt. zero) goto 40 6137 rextr = (arp*r(j-1)-arpm*r(j)) / (arp-arpm) 6138 nextr = nextr - 1 6139 40 continue 6140c 6141c Check rc, if outside bounds reset. 6142c 6143 50 if (rzero .lt. r(2)) rzero = r(2) 6144 if (rc(lp) .gt. rzero .and. rc(lp) .lt. rextr) goto 60 6145 if (rc(lp) .ge. rzero) then 6146 write(6,2001)rc(lp),rextr 6147 endif 6148 2001 format(/,'Warning, the Core radius =',f5.2, 6149 1 /,' is larger then wave function', 6150 1 ' extrema position =',f5.2,/) 6151 if (rc(lp) .lt. zero) rc(lp) = rzero - rc(lp)*(rextr-rzero) 6152c 6153c Reset the n quantum numbers. 6154c 6155 60 do 70 j=1,norb 6156 nops(j) = 0 6157 70 continue 6158 nops(i) = lp 6159c 6160c njtj *** modification start *** 6161c Sset up the functions f(r/rc) and g(r/rc) and 6162c modify the ionic potential. 6163c 6164 aa = 4*one 6165 dcl = -6*one*lp 6166 cl = dcl 6167c 6168 do 80 j=1,nr 6169 rrc = r(j)/rc(lp) 6170 rra = rrc**aa 6171 f(j) = zero 6172 if (rra .lt. 88*one) f(j)=exp(-rra) 6173 g(j) = rrc**lp * f(j) 6174 fjm1 = one-f(j) 6175 if (fjm1 .lt. small4) fjm1=(one-pfive*rra)*rra 6176 if (so(i) .lt. 0.1) then 6177 viod(lp,j)=fjm1*viod(lp,j)-f(j)*r(j)*vid(j)+dcl*r(j)*f(j) 6178 else 6179c 6180c bug fix Alberto Garcia 5/11/90 6181c 6182 viou(lp,j)=fjm1*viou(lp,j)-f(j)*r(j)*viu(j)+dcl*r(j)*f(j) 6183 endif 6184 if (rrc .lt. 3*one) j3rc = j 6185 80 continue 6186 dcl=dcl/2 6187c 6188c Start the iteration loop to find cl. 6189c 6190 eviae = ev(i) 6191 devold = zero 6192 do 130 j=1,100 6193 call dsolv2(j,2,blank,ifcore,lmax, 6194 1 nr,a,b,r,rab,norb,ncore,nops,lo,so,zo,znuc,cdd,cdu,cdc, 6195 2 viod,viou,vid,viu,ev,ek,ep,wk1,wk2,wk3,wk4,wk5,wk6, 6196 3 wk7,evi) 6197 dev = eviae-ev(i) 6198c 6199c The abs(dev-devold) condition was added to eliminate 6200c division by zero errors in the calculation of 6201c dcl = -dev*dcl / (dev-devold). 6202c 6203 if ((abs(dev) .lt. small2 .or. abs(dev-devold) 6204 1 .lt. small3) .and. j .ne. 1) then 6205 goto 140 6206 else 6207 if (j .gt. 20 .or. abs(dev) .lt. 0.001) then 6208c 6209c Use newton raphson iteration to change cl. 6210c 6211 dcl = -dev*dcl / (dev-devold) 6212 else 6213 if (dev*dcl .lt. zero) then 6214 dcl=-dcl/3 6215 endif 6216 endif 6217 endif 6218c 6219c njtj *** modification end *** 6220c 6221c Find the new potential. 6222c 6223 100 if (so(i) .lt. 0.1) then 6224 do 110 k=2,nr 6225 viod(lp,k) = viod(lp,k) + dcl*r(k)*f(k) 6226 110 continue 6227 else 6228 do 111 k=2,nr 6229 viou(lp,k) = viou(lp,k) + dcl*r(k)*f(k) 6230 111 continue 6231 endif 6232 cl = cl + dcl 6233 devold = dev 6234 130 continue 6235c 6236c End the iteration loop for cl. 6237c 6238 call ext(820+lp) 6239c 6240c Find the pseudo-wavefunction. 6241c 6242 140 if (so(i) .lt. 0.1) then 6243 do 150 j=2,nr 6244 v(j) = (viod(lp,j)+llp/r(j))/r(j) + vid(j) 6245 150 continue 6246 else 6247 do 151 j=2,nr 6248 v(j) = (viou(lp,j)+llp/r(j))/r(j) + viu(j) 6249 151 continue 6250 endif 6251 call difnrl(0,i,v,arps,br,lmax,nr,a,b,r,rab,norb, 6252 1 nops,lo,so,znuc,viod,viou,vid,viu,ev,iflag,wk1, 6253 2 wk2,wk3,evi) 6254c 6255c Compute delta and gamma. 6256c 6257 gamma = abs(ar(j3rc)/arps(j3rc)+ar(j3rc+1)/arps(j3rc+1))/2 6258 ag = zero 6259 gg = zero 6260 ll = 4 6261 do 160 j=2,nr 6262 ag = ag + ll*arps(j)*g(j)*rab(j) 6263 gg = gg + ll*g(j)*g(j)*rab(j) 6264 ll = 6 - ll 6265 160 continue 6266 ag = ag/3 6267 gg = gg/3 6268 delta = sqrt((ag/gg)**2+(1/gamma**2-1)/gg) - ag/gg 6269c 6270c Modify the pseudo-wavefunction and pseudo-potential and 6271c add to charge density. 6272c 6273 if (so(i) .lt. 0.1) then 6274 do 170 j=2,nr 6275 arps(j) = gamma*(arps(j)+delta*g(j)) 6276 vod(j)=vod(j)+zo(i)*arps(j)*arps(j) 6277 if (arps(j) .lt. small .and. r(j) .gt. one) arps(j)=small 6278 rrp = r(j)/rc(lp) 6279 gpp=(llp-aa*(2*lp+aa-1)*rrp**aa+(aa*rrp**aa)**2) 6280 1 *g(j)/r(j)**2 6281 viod(lp,j) = viod(lp,j)+gamma*delta*((ev(i)- 6282 1 v(j))*g(j)+gpp)*r(j)/arps(j) 6283 170 continue 6284 else 6285 do 171 j=2,nr 6286 arps(j) = gamma*(arps(j)+delta*g(j)) 6287 vou(j)=vou(j)+zo(i)*arps(j)*arps(j) 6288 if (arps(j) .lt. small .and. r(j) .gt. one) arps(j)=small 6289 rrp = r(j)/rc(lp) 6290 gpp=(llp-aa*(2*lp+aa-1)*rrp**aa+(aa*rrp**aa)**2) 6291 1 *g(j)/r(j)**2 6292 viou(lp,j) = viou(lp,j)+gamma*delta*((ev(i)- 6293 1 v(j))*g(j)+gpp)*r(j)/arps(j) 6294 171 continue 6295 endif 6296c 6297c njtj *** plotting routines *** 6298c potrw is called to save a usefull number of points 6299c of the pseudowave function to make a plot. The 6300c info is written to the current plot.dat file. 6301c wtrans is called to fourier transform the the pseudo 6302c wave function and save it to the current plot.dat file. 6303c 6304 ist=1 6305 if (arps(nr-85) .lt. zero) ist=-1 6306 call potrw(arps,r,nr-85,lo(i),0,ist) 6307 if (ev(i) .eq. zero .or. evi(i) .ne. zero) ist=2 6308 call wtrans(arps,r,nr,rab,lo(i),ist,wk1) 6309c 6310c njtj *** user should adjust for their needs *** 6311c 6312 write(6,180) nops(i),il(lp),so(i),ev(i),rc(lp),cl,gamma,delta 6313 180 format(1x,i1,a1,f6.1,5f12.6) 6314 190 continue 6315c 6316c End loop over valence orbitals. 6317c 6318c Reset the n quantum numbers to include all valence orbitals. 6319c Compute the ratio between the valence charge present and the 6320c valence charge of a neutral atom. 6321c Transfer pseudo valence charge to charge array 6322c 6323 zval = zero 6324 zratio = zero 6325 do 200 i=ncp,norb 6326 nops(i) = lo(i) + 1 6327 zval = zval + zo(i) 6328 200 continue 6329 zion = zval+znuc-zel 6330 if (zval .ne. zero) zratio=zion/zval 6331 do 210 i=1,nr 6332 cdd(i) = vod(i) 6333 210 continue 6334 do 211 i=1,nr 6335 cdu(i) = vou(i) 6336 211 continue 6337c 6338c If a core correction is indicated construct pseudo core charge 6339c cdc(r) = ac*r * sin(bc*r) inside r(icore) 6340c if cfac < 0 or the valence charge is zero the full core is used 6341c 6342 if (ifcore .ne. 0) then 6343 ac = zero 6344 bc = zero 6345 icore = 1 6346 if (cfac .le. zero .or. zratio .eq. zero) then 6347 write(6,280) r(icore),ac,bc 6348 else 6349 if (rcfac .le. zero) then 6350 do 220 i=nr,2,-1 6351 if (cdc(i) .gt. cfac*zratio*(cdd(i)+cdu(i))) goto 230 6352 220 continue 6353 else 6354 do 221 i=nr,2,-1 6355 if (r(i) .le. rcfac ) goto 230 6356 221 continue 6357 endif 6358 230 icore = i 6359 cdcp = (cdc(icore+1)-cdc(icore)) / (r(icore+1)-r(icore)) 6360 tanb = cdc(icore) / (r(icore)*cdcp-cdc(icore)) 6361 rbold = tpfive 6362 do 240 i=1,50 6363 rbnew = pi+atan(tanb*rbold) 6364 if (abs(rbnew-rbold) .lt. .00001) then 6365 bc = rbnew / r(icore) 6366 ac = cdc(icore) / (r(icore)*sin(rbnew)) 6367 do 260 j=1,icore 6368 cdc(j) = ac*r(j)*sin(bc*r(j)) 6369 260 continue 6370 write(6,280) r(icore),ac,bc 6371 goto 290 6372 else 6373 rbold=rbnew 6374 endif 6375 240 continue 6376 write(6,1030) 6377 call ext(830) 6378 endif 6379 endif 6380 280 format(//,' core correction used',/, 6381 1 ' pseudo core inside r =',f6.3,/,' ac =',f6.3,' bc =',f6.3,/) 6382 1030 format(//,' error in pseudo - noncovergence in finding ', 6383 1 /,'pseudo-core values') 6384c 6385c End the pseudo core charge. 6386c Compute the potential due to pseudo valence charge. 6387c 6388c njtj *** NOTE *** 6389c Spin-polarized potentails should be unscreend with 6390c spin-polarized valence charge. This was not 6391c done in pseudo and pseudok in earlier versions 6392c of this program. 6393c njtj *** NOTE *** 6394c 6395 290 if (ispp .eq. 's') then 6396 blank='s' 6397 else 6398 blank=' ' 6399 endif 6400 call velect(0,1,icorr,blank,ifcore,nr,r,rab,zval, 6401 1 cdd,cdu,cdc,vod,vou,etot,wk1,wk2,wk3,wk4,wk5,wkb) 6402c 6403c Construct the ionic pseudopotential and find the cutoff, 6404c ecut should be adjusted to give a reassonable ionic cutoff 6405c radius, but should not alter the pseudopotential, ie., 6406c the ionic cutoff radius should not be inside the pseudopotential 6407c cutoff radius 6408c 6409 ecut=ecuts 6410 do 315 i=ncp,norb 6411 lp = lo(i)+1 6412 if (so(i) .lt. 0.1) then 6413 do 300 j=2,nr 6414 viod(lp,j)=viod(lp,j) + (vid(j)-vod(j))*r(j) 6415 vp2z = viod(lp,j) + 2*zion 6416 if (abs(vp2z) .gt. ecut) jcut = j 6417 300 continue 6418 rcut(i-ncore) = r(jcut) 6419 do 310 j=jcut,nr 6420 fcut = exp(-5*(r(j)-r(jcut))) 6421 viod(lp,j) = - 2*zion + fcut * (viod(lp,j)+2*zion) 6422 310 continue 6423 do 311 j=2,nr 6424 v(j) = viod(lp,j)/r(j) 6425 311 continue 6426c 6427c njtj *** plotting routines *** 6428c 6429 call potran(lo(i)+1,v,r,nr,zion,wk1,wk2,wk3) 6430 call potrv(v,r,nr-120,lo(i)) 6431c 6432c njtj *** user should adjust for their needs *** 6433c 6434 else 6435 do 312 j=2,nr 6436 viou(lp,j)=viou(lp,j)+ (viu(j)-vou(j))*r(j) 6437 vp2z = viou(lp,j) + 2*zion 6438 if (abs(vp2z) .gt. ecut) jcut = j 6439 312 continue 6440 rcut(i-ncore) = r(jcut) 6441 do 313 j=jcut,nr 6442 fcut = exp(-5*(r(j)-r(jcut))) 6443 viou(lp,j) = - 2*zion + fcut * (viou(lp,j)+2*zion) 6444 313 continue 6445 do 314 j=2,nr 6446 v(j) = viou(lp,j)/r(j) 6447 314 continue 6448c 6449c njtj *** plotting routines *** 6450c 6451 call potran(lo(i)+1,v,r,nr,zion,wk1,wk2,wk3) 6452 call potrv(v,r,nr-120,lo(i)) 6453c 6454c njtj *** user should adjust for their needs *** 6455c 6456 endif 6457 315 continue 6458c 6459c njtj *** plotting routines *** 6460c The calls to 1)potran take the fourier transform of 6461c the potential and saves it in the current plot.dat file, 6462c 2)potrv saves the potential in the current plot.dat file 6463c 3)zion is saved to the current plot.dat file wtih a 6464c marker 'zio' for latter plotting 6465c 6466 write(3,4559) 6467 write(3,4560) zion 6468 4559 format(1x,'marker zio') 6469 4560 format(2x,f5.2) 6470c 6471c njtj *** user should adjust for their needs *** 6472c 6473 6474c 6475c Convert spin-polarized potentials back to nonspin-polarized 6476c by occupation weight(zo). Assumes core polarization is 6477c zero, ie. polarization is only a valence effect. 6478c 6479 if (ispp .eq. 's' ) then 6480 do 500 i=ncp,norb,2 6481 lp = lo(i)+1 6482 zot=zo(i)+zo(i+1) 6483 if (zot .ne. zero) then 6484 do 505 j=2,nr 6485 viod(lp,j)=(viod(lp,j)*zo(i)+viou(lp,j) 6486 1 *zo(i+1))/zot 6487 viou(lp,j)=viod(lp,j) 6488 505 continue 6489 else 6490 do 506 j=2,nr 6491 viod(lp,j)=viod(lp,j)/2+viou(lp,j)/2 6492 viou(lp,j)=viod(lp,j) 6493 506 continue 6494 endif 6495 500 continue 6496 endif 6497c 6498 do 320 i=2,nr 6499 vid(i) = vod(i) 6500 viu(i) = vou(i) 6501 320 continue 6502c 6503c Test the pseudopotential self consistency. Spin-polarized 6504c is tested as spin-polarized(since up/down potentials are 6505c now the same) 6506c 6507 call dsolv2(0,1,blank,ifcore,lmax,nr,a,b,r,rab, 6508 1 norb-ncore,0,nops(ncp),lo(ncp),so(ncp),zo(ncp), 6509 2 znuc,cdd,cdu,cdc,viod,viou,vid,viu,ev(ncp),ek(ncp), 6510 3 ep(ncp),wk1,wk2,wk3,wk4,wk5,wk6,wk7,evi(ncp)) 6511c 6512c Printout the pseudo eigenvalues after cutoff. 6513c 6514 write(6,325) (il(lo(i)+1),rcut(i-ncore),i=ncp,norb) 6515 write(6,326) (ev(i),i=ncp,norb) 6516 325 format(//,' test of eigenvalues',//,' rcut =',8(2x,a1,f7.2)) 6517 326 format(' eval =',8(2x,f8.5)) 6518c 6519c Printout the data for potentials. 6520c 6521 write(6,330) 6522 330 format(///,' l vps(0) vpsmin at r',/) 6523 do 370 i=1,lmax 6524 if (indd(i)+indu(i) .eq. 0) goto 370 6525 if (indd(i) .ne. 0) then 6526 vpsdm = zero 6527 do 350 j=2,nr 6528 if (r(j) .lt. .00001) goto 350 6529 vps = viod(i,j)/r(j) 6530 if (vps .lt. vpsdm) then 6531 vpsdm = vps 6532 rmind = r(j) 6533 endif 6534 350 continue 6535 write(6,360) il(i),viod(i,2)/r(2),vpsdm,rmind 6536 endif 6537 if (indu(i) .ne. 0) then 6538 vpsum = zero 6539 do 351 j=2,nr 6540 if (r(j) .lt. .00001) goto 351 6541 vps = viou(i,j)/r(j) 6542 if (vps .lt. vpsum) then 6543 vpsum = vps 6544 rminu = r(j) 6545 endif 6546 351 continue 6547 write(6,360) il(i),viou(i,2)/r(2),vpsum,rminu 6548 endif 6549 360 format(1x,a1,3f10.3) 6550 370 continue 6551c 6552c Print out the energies from etotal. 6553c 6554 call etotal(itype,one,nameat,norb-ncore, 6555 1 nops(ncp),lo(ncp),so(ncp),zo(ncp), 6556 2 etot,ev(ncp),ek(ncp),ep(ncp)) 6557c 6558c Find the jobname and date, date is a machine 6559c dependent routine and must be chosen/written/ 6560c comment in/out in the zedate section. 6561c 6562 iray(1) = 'atom-lda ' 6563 call zedate(iray(2)) 6564 iray(3) = ' Hamann,' 6565 iray(4) = ' Schluter ' 6566 iray(5) = 'and Chiang' 6567 iray(6) = ' potential' 6568c 6569c Encode the title array. 6570c 6571 do 390 i=1,7 6572 ititle(i) = ' ' 6573 390 continue 6574 do 420 i=1,lmax 6575 if (indd(i) .eq. 0 .and. indu(i) .eq. 0) goto 420 6576 zelu = zero 6577 zeld = zero 6578 if (indd(i) .ne. 0) then 6579 noi = no(indd(i)) 6580 zeld = zo(indd(i)) 6581 endif 6582 if (indu(i) .ne. 0) then 6583 noi = no(indu(i)) 6584 zelu = zo(indu(i)) 6585 endif 6586 zelt = zeld + zelu 6587 if (ispp .ne. 's') then 6588 write(ititle(2*i-1),400) noi,il(i),zelt 6589 write(ititle(2*i),401)ispp,rc(i) 6590 400 format(i1,a1,'(',f6.2,')') 6591 401 format(a1,' rc=',f5.2) 6592 else 6593 write(ititle(2*i-1),410) noi,il(i),zeld 6594 write(ititle(2*i),411)zelu,ispp,rc(i) 6595 410 format(i1,a1,' (',f4.2,',') 6596 411 format(f4.2,')',a1,f4.2) 6597 endif 6598 420 continue 6599c 6600c Construct relativistic sum and difference potentials. 6601c 6602 if (ispp .eq. 'r') then 6603 if (indu(1) .eq. 0) goto 429 6604 indd(1)=indu(1) 6605 indu(1)=0 6606 do 428 j=2,nr 6607 viod(1,j) = viou(1,j) 6608 viou(1,j) = zero 6609 428 continue 6610 429 do 431 i=2,lmax 6611 if (indd(i) .eq. 0 .or. indu(i) .eq. 0) goto 431 6612 do 430 j=2,nr 6613 viodj = viod(i,j) 6614 viouj = viou(i,j) 6615 viod(i,j) = ((i-1)*viodj + i*viouj) / (2*i-1) 6616 viou(i,j) = 2 * (viouj - viodj) / (2*i-1) 6617 430 continue 6618 431 continue 6619 endif 6620c 6621c Determine the number of potentials. Coded them as 6622c two digits, where the first digit is the number 6623c of down or sum potentials and the second the number of 6624c up or difference potentials. 6625c 6626 npotd = 0 6627 npotu = 0 6628 do 450 i=1,lmax 6629 if (indd(i) .ne. 0) npotd=npotd+1 6630 if (indu(i) .ne. 0) npotu=npotu+1 6631 450 continue 6632c 6633c Write the heading to the current pseudo.dat 6634c file (unit=1). 6635c 6636 ifull = 0 6637 if (cfac .le. zero .or. zratio .eq. zero) ifull = 1 6638 if (ifcore .eq. 1) then 6639 if (ifull .eq. 0) then 6640 nicore = 'pcec' 6641 else 6642 nicore = 'fcec' 6643 endif 6644 elseif (ifcore .eq. 2) then 6645 if (ifull .eq. 0) then 6646 nicore = 'pche' 6647 else 6648 nicore = 'fche' 6649 endif 6650 else 6651 nicore = 'nc ' 6652 endif 6653 if (ispp .eq. 's') then 6654 irel='isp' 6655 elseif (ispp .eq. 'r') then 6656 irel='rel' 6657 else 6658 irel = 'nrl' 6659 endif 6660 rewind 1 6661 write(1) nameat,icorr,irel,nicore,(iray(i),i=1,6), 6662 1 (ititle(i),i=1,7),npotd,npotu,nr-1,a,b,zion 6663 write(1) (r(i),i=2,nr) 6664c 6665c Write the potentials to the current pseudo.dat 6666c file (unit=1). 6667c 6668 do 460 i=1,lmax 6669 if (indd(i) .eq. 0) goto 460 6670 write(1) i-1,(viod(i,j),j=2,nr) 6671 460 continue 6672 do 465 i=1,lmax 6673 if (indu(i) .eq. 0) goto 465 6674 write(1) i-1,(viou(i,j),j=2,nr) 6675 465 continue 6676c 6677c Write the charge densities to the current pseudo.dat 6678c file (unit=1). 6679c 6680 if (ifcore .eq. 0) then 6681 write(1) (zero,i=2,nr) 6682 else 6683 write(1) (cdc(i),i=2,nr) 6684 endif 6685 write(1) (zratio*(cdd(i)+cdu(i)),i=2,nr) 6686c 6687 return 6688 end 6689C 6690C 6691C 6692 subroutine pseudt(itype,icorr,ispp,lmax,nr,a,b,r,rab, 6693 1 nameat,norb,ncore,no,lo,so,zo,znuc,zel,cdd,cdu,cdc, 6694 2 viod,viou,vid,viu,vod,vou,etot,ev,ek,ep,wk1,wk2, 6695 3 wk3,wk4,wk5,wk6,wk7,nops,v,ar,br,wkb,evi) 6696c 6697c ************************************************************* 6698c * * 6699c * This routine was written by Norman J. Troullier Jr. * 6700c * Sept. 1989, while at the U. of Minnesota, all * 6701c * comments concerning this routine should be directed * 6702c * to him. * 6703c * * 6704c * troullie@128.101.224.101 * 6705c * troullie@csfsa.cs.umn.edu * 6706c * 612 625-0392 * 6707c * * 6708c * pseudt generates a pseudopotential using the * 6709c * scheme of N. Troullier and J. L. Martins. * 6710c * The general format of this routine is the same as the * 6711c * pseudo and pseudk routines. Output/input is * 6712c * compatible. * 6713c * * 6714c ************************************************************* 6715c 6716c njtj 6717c ### Cray conversions 6718c ### 1)Comment out implicit double precision. 6719c ### 2)Switch double precision parameter 6720c ### to single precision parameter statement. 6721c ### Cray conversions 6722c njtj 6723c 6724 implicit double precision (a-h,o-z) 6725c 6726 parameter (zero=0.D0,one=1.D0,tpfive=2.5D0,ecuts=1.0D-3) 6727 parameter (small=1.D-12,pnine=0.9D0,ai=2*137.0360411D0) 6728Cray parameter (zero=0.0,one=1.0,tpfive=2.5,ecuts=1.0E-3) 6729Cray parameter (small=1.E-12,pnine=0.9,ai=2*137.0360411) 6730c 6731 character*1 ispp,blank,il(5) 6732 character*2 icorr,nameat 6733 character*3 irel 6734 character*4 nicore 6735 character*10 iray(6),ititle(7) 6736c 6737 dimension r(nr),rab(nr),no(norb),lo(norb),so(norb),zo(norb), 6738 1 cdd(nr),cdu(nr),cdc(nr),viod(lmax,nr),viou(lmax,nr), 6739 2 vid(nr),viu(nr),vod(nr),vou(nr),ev(norb),ek(norb),ep(norb), 6740 3 wk1(nr),wk2(nr),wk3(nr),wk4(nr),wk5(nr),wk6(nr),wk7(nr), 6741 4 wkb(3*nr),nops(norb),v(nr),ar(nr),br(nr),evi(norb) 6742c 6743 dimension indd(5),indu(5),rc(5),rcut(10), 6744 1 etot(10),aa(7),rr(7),coe(7),aj(5,5),bj(5) 6745c 6746 data il/'s','p','d','f','g'/ 6747 if (ncore .eq. norb) return 6748 ifcore = itype-1 6749 pi = 4*atan(one) 6750 do 3 i=1,5 6751 indd(i)=0 6752 indu(i)=0 6753 3 continue 6754 do 4 i=1,40 6755 nops(i) = 0 6756 4 continue 6757c 6758c read rc(s),rc(p),rc(d),rc(f),rc(g),cfac,rcfac 6759c 6760c cfac is used for the pseudocore - the pseudocore stops where 6761c the core charge density equals cfac times the renormalized 6762c valence charge density (renormalized to make the atom neutral). 6763c If cfac is input as negative, the full core charge is used, 6764c if cfac is input as zero, it is set equal to one. 6765c rcfac is used for the pseudocore cut off radius. If set 6766c to less then or equal to zero cfac is used. cfac must be 6767c set to greater then zero. 6768c 6769 read(5,10) (rc(i),i=1,5),cfac,rcfac 6770 10 format(7f10.5) 6771 if (cfac .eq. 0.D0) cfac=one 6772c 6773c Reset vod and vou to zero, 6774c they are here used to store the pseudo valence charge density. 6775c 6776 do 15 i=1,nr 6777 vod(i) = zero 6778 15 continue 6779 do 16 i=1,nr 6780 vou(i) = zero 6781 16 continue 6782c 6783c print heading 6784c 6785 write(6,20) nameat 6786 20 format(//,1x,a2,' pseudopotential generation using the ', 6787 1 'Troullier and Martins method',/,1x,60('-'),//, 6788 2 ' nl s eigenvalue',6x,'rc',10x,'cdrc',7x,'delta',/) 6789c 6790c Start loop over valence orbitals, only one orbital for each 6791c angular momentum and spin can exist. 6792c 6793 ncp = ncore+1 6794 do 190 i=ncp,norb 6795 lp = lo(i) + 1 6796 llp = lo(i)*lp 6797 if (so(i) .lt. 0.1) then 6798 if (indd(lp) .ne. 0) then 6799 write(6,1000)lp-1 6800 call ext(800+lp) 6801 else 6802 indd(lp) = i 6803 endif 6804 else 6805 if (indu(lp) .ne. 0) then 6806 write(6,1010)lp-1 6807 call ext(810+lp) 6808 else 6809 indu(lp) = i 6810 endif 6811 endif 6812 1000 format(//,'error in pseudt - two down spin orbitals of the same ', 6813 1 /,'angular momentum (',i1,') exist') 6814 1010 format(//,'error in pseudt - two up spin orbitals of the same ', 6815 1 /,'angular momentum (',i1,') exist') 6816c 6817c Find the all electron wave function. 6818c 6819 do 29 j=1,nr 6820 ar(j) = zero 6821 29 continue 6822 if (so(i) .lt. 0.1) then 6823 do 30 j=2,nr 6824 v(j) = viod(lp,j)/r(j) + vid(j) 6825 30 continue 6826 else 6827 do 31 j=2,nr 6828 v(j) = viou(lp,j)/r(j) + viu(j) 6829 31 continue 6830 endif 6831 if (ispp .ne. 'r') then 6832 do 32 j=2,nr 6833 v(j) = v(j) + llp/r(j)**2 6834 32 continue 6835 endif 6836c 6837c The parameter iflag has been added as a nonconvegence 6838c indicator for auxillary routines. Its value does 6839c not change its operation. iflag is a returned value, 6840c set to 1 for none convergence. 6841c 6842 if (ispp .ne. 'r') then 6843 iflag=0 6844 call difnrl(0,i,v,ar,br,lmax,nr,a,b, 6845 1 r,rab,norb,no,lo,so,znuc,viod,viou, 6846 2 vid,viu,ev,iflag,wk1,wk2,wk3,evi) 6847 else 6848 call difrel(0,i,v,ar,br,lmax,nr,a,b,r, 6849 1 rab,norb,no,lo,so,znuc,viod,viou,vid,viu, 6850 2 ev,wk1,wk2,wk3,wk4,evi) 6851 endif 6852c 6853c njtj *** plotting routines *** 6854c potrw is called to save an usefull number of points 6855c of the wave function to make a plot. The info is 6856c written to the current plot.dat file. 6857c 6858 ist=1 6859 if (ar(nr-85) .lt. zero) ist=-1 6860 call potrw(ar,r,nr-85,lo(i),1,ist) 6861c 6862c njtj *** user should adjust for their needs *** 6863c 6864c 6865c Find last zero and extremum 6866c 6867 ka = lo(i)+1 6868 if (so(i) .lt. 0.1 .and. lo(i) .ne. 0) ka=-lo(i) 6869 nextr = no(i)-lo(i) 6870 rzero = zero 6871 arp = br(2) 6872c 6873 if (ispp .eq. 'r') then 6874 if (so(i) .lt. 0.1) then 6875 arp = ka*ar(2)/r(2) + (ev(i) - viod(lp,2)/r(2) 6876 1 - vid(2) + ai*ai) * br(2) / ai 6877 else 6878 arp = ka*ar(2)/r(2) + (ev(i) - viou(lp,2)/r(2) 6879 1 - viu(2) + ai*ai) * br(2) / ai 6880 endif 6881 endif 6882c 6883 do 40 j=3,nr-7 6884 if (nextr .eq. 0) goto 50 6885 if (ar(j-1)*ar(j) .le. zero) 6886 1 rzero = (ar(j)*r(j-1)-ar(j-1)*r(j)) / (ar(j)-ar(j-1)) 6887 arpm = arp 6888 arp = br(j) 6889c 6890 if (ispp .eq. 'r') then 6891 if(so(i) .lt. 0.1) then 6892 arp = ka*ar(j)/r(j) + (ev(i) - viod(lp,j)/r(j) 6893 1 - vid(j) + ai*ai) * br(j) / ai 6894 else 6895 arp = ka*ar(j)/r(j) + (ev(i) - viou(lp,j)/r(j) 6896 1 - viu(j) + ai*ai) * br(j) / ai 6897 endif 6898 endif 6899c 6900 if (arp*arpm .gt. zero) goto 40 6901 rextr = (arp*r(j-1)-arpm*r(j)) / (arp-arpm) 6902 nextr = nextr - 1 6903 40 continue 6904 50 if (rzero .lt. r(2)) rzero = r(2) 6905c 6906c Check rc if inside rzero, 6907c reset to .9 between rmax and rzero if inside 6908c if rc(lp) is negative, rc(lp) is percent of way 6909c betweeen rzero and rmax. 6910c 6911 if (rc(lp) .gt. rzero) then 6912 elseif(rc(lp) .ge. zero) then 6913 rc(lp) = rzero + pnine*(rextr-rzero) 6914 else 6915 rc(lp) = rzero - rc(lp)*(rextr-rzero) 6916 endif 6917c 6918c Find the index for odd grid point closest to rc. 6919c 6920 do 70 j=1,nr 6921 if (r(j) .gt. rc(lp)) goto 80 6922 70 continue 6923 80 jrc=j-1 6924 rc(lp)=r(jrc) 6925c 6926c Reset n quantum numbers. 6927c 6928 nops(i) = lp 6929c 6930c Find the integrated charge inside rc(1-charge outside). 6931c 6932 ll = 2 6933 if (ispp .eq. 'r') then 6934 cdrc = -(ar(jrc)*ar(jrc)+br(jrc)*br(jrc))*rab(jrc) 6935 if (jrc .ne. 2*(jrc/2)) then 6936 do 102 k=jrc,1,-1 6937 cdrc = cdrc+ll*(ar(k)*ar(k)+br(k)*br(k))*rab(k) 6938 ll = 6 - ll 6939 102 continue 6940 else 6941 do 103 k=jrc,4,-1 6942 cdrc = cdrc+ll*(ar(k)*ar(k)+br(k)*br(k))*rab(k) 6943 ll = 6 - ll 6944 103 continue 6945 cdrc = cdrc-(ar(4)*ar(4)+br(4)*br(4))*rab(4) 6946 cdrc = cdrc+9*((ar(1)*ar(1)+br(1)*br(1))*rab(1)+ 6947 1 3*(ar(2)*ar(2)+br(2)*br(2))*rab(2)+ 6948 2 3*(ar(3)*ar(3)+br(3)*br(3))*rab(3)+ 6949 3 (ar(4)*ar(4)+br(4)*br(4))*rab(4))/8 6950 endif 6951 cdrc = cdrc/3 6952 else 6953 cdrc = - ar(jrc) * ar(jrc) * rab(jrc) 6954 if (jrc .ne. 2*(jrc/2)) then 6955 do 100 k=jrc,1,-1 6956 cdrc = cdrc + ll * ar(k) * ar(k) * rab(k) 6957 ll = 6 - ll 6958 100 continue 6959 else 6960 do 101 k=jrc,4,-1 6961 cdrc = cdrc + ll * ar(k) * ar(k) * rab(k) 6962 ll = 6 - ll 6963 101 continue 6964 cdrc = cdrc - ar(4) * ar(4) * rab(4) 6965 cdrc = cdrc + 9 * ( ar(1) * ar(1) * rab(1) + 6966 1 3 * ar(2) *ar(2) * rab(2) + 6967 2 3 * ar(3) *ar(3) * rab(3) + 6968 3 ar(4) * ar(4) * rab(4))/8 6969 endif 6970 cdrc = cdrc/3 6971 endif 6972c 6973c Find the values for wave(arc), d(wave)/dr(arp), potential(vrc), 6974c d(potential)/dr(vrp), and d2(potential)/dr2(vrpp) 6975c 6976 rc1 = r(jrc) 6977 rc2 = rc1 * rc1 6978 rc3 = rc2 * rc1 6979 rc4 = rc2 * rc2 6980 rc5 = rc4 * rc1 6981 rc6 = rc4 * rc2 6982 rc7 = rc4 * rc3 6983 rc8 = rc4 * rc4 6984 iswtch = 1 6985 if (ar(jrc) .lt. zero) iswtch = -1 6986 arc = iswtch * ar(jrc) 6987 arp = br(jrc) 6988 if (ispp .eq. 'r') then 6989 if (so(i) .lt. 0.1) then 6990 arp=ka*ar(jrc)/r(jrc) + (ev(i) - viod(lp,jrc)/r(jrc) 6991 1 - vid(jrc) + ai*ai) * br(jrc)/ai 6992 else 6993 arp=ka*ar(jrc)/r(jrc) + (ev(i) - viou(lp,jrc)/r(jrc) 6994 1 - viu(jrc) + ai*ai) * br(jrc)/ai 6995 endif 6996 endif 6997 arp =arp *iswtch 6998 brc = arp / arc 6999c 7000 if (so(i) .lt. 0.1) then 7001 vrc = viod(lp,jrc)/r(jrc) + vid(jrc) 7002 aa(1)=viod(lp,jrc-3)/r(jrc-3) + vid(jrc-3) 7003 aa(2)=viod(lp,jrc-2)/r(jrc-2) + vid(jrc-2) 7004 aa(3)=viod(lp,jrc-1)/r(jrc-1) + vid(jrc-1) 7005 aa(4)=vrc 7006 aa(5)=viod(lp,jrc+1)/r(jrc+1) + vid(jrc+1) 7007 aa(6)=viod(lp,jrc+2)/r(jrc+2) + vid(jrc+2) 7008 aa(7)=viod(lp,jrc+3)/r(jrc+3) + vid(jrc+3) 7009 else 7010 vrc = viou(lp,jrc)/r(jrc) + viu(jrc) 7011 aa(1)=viou(lp,jrc-3)/r(jrc-3) + viu(jrc-3) 7012 aa(2)=viou(lp,jrc-2)/r(jrc-2) + viu(jrc-2) 7013 aa(3)=viou(lp,jrc-1)/r(jrc-1) + viu(jrc-1) 7014 aa(4)=vrc 7015 aa(5)=viou(lp,jrc+1)/r(jrc+1) + viu(jrc+1) 7016 aa(6)=viou(lp,jrc+2)/r(jrc+2) + viu(jrc+2) 7017 aa(7)=viou(lp,jrc+3)/r(jrc+3) + viu(jrc+3) 7018 endif 7019 rr(1)=r(jrc-3)-r(jrc) 7020 rr(2)=r(jrc-2)-r(jrc) 7021 rr(3)=r(jrc-1)-r(jrc) 7022 rr(4)=zero 7023 rr(5)=r(jrc+1)-r(jrc) 7024 rr(6)=r(jrc+2)-r(jrc) 7025 rr(7)=r(jrc+3)-r(jrc) 7026 call polcoe(rr,aa,7,coe) 7027 vap = coe(2) 7028 vapp= 2*coe(3) 7029c 7030c Set up matrix without the d2(potential(0)/dr2=0 condition 7031c to find an intial guess for gamma. 7032c 7033 delta=zero 7034 bj(1)=log(arc/rc1**lp) 7035 bj(2)=brc-lp/rc1 7036 bj(3)=vrc-ev(i)+(lp/rc1)**2-brc**2 7037 vt=vrc-ev(i)+lp*(lp-1)/rc2 7038 bj(4)=vap-2*(vt*brc+lp**2/rc3-brc**3) 7039 bj(5)=vapp-2*((vap-2*lp*(lp-1)/rc3)*brc+(vt-3*brc**2)* 7040 1 (vt-brc**2)-3*lp**2/rc4) 7041 aj(1,1)=rc2 7042 aj(1,2)=rc4 7043 aj(1,3)=rc5 7044 aj(1,4)=rc6 7045 aj(1,5)=rc7 7046 aj(2,1)=2*rc1 7047 aj(2,2)=4*rc3 7048 aj(2,3)=5*rc4 7049 aj(2,4)=6*rc5 7050 aj(2,5)=7*rc6 7051 aj(3,1)=2*one 7052 aj(3,2)=12*rc2 7053 aj(3,3)=20*rc3 7054 aj(3,4)=30*rc4 7055 aj(3,5)=42*rc5 7056 aj(4,1)=zero 7057 aj(4,2)=24*rc1 7058 aj(4,3)=60*rc2 7059 aj(4,4)=120*rc3 7060 aj(4,5)=210*rc4 7061 aj(5,1)=zero 7062 aj(5,2)=24*one 7063 aj(5,3)=120*rc1 7064 aj(5,4)=360*rc2 7065 aj(5,5)=840*rc3 7066 call gaussj(aj,5,5,bj,1,1) 7067 gamma=bj(1) 7068 alpha=bj(2) 7069 alpha1=bj(3) 7070 alpha2=bj(4) 7071 alpha3=bj(5) 7072c 7073c Start iteration loop to find delta, uses false postion. 7074c 7075 do 150 j=1,50 7076c 7077c Generate pseudo wavefunction-note missing factor exp(delta). 7078c 7079 do 110 k=1,jrc 7080 rp=r(k) 7081 r2=rp*rp 7082 polyr = r2*((((alpha3*rp+alpha2)*rp+ 7083 1 alpha1)*rp+ alpha)*r2+gamma) 7084 ar(k) = iswtch * rp**lp * exp(polyr) 7085 110 continue 7086c 7087c Integrate pseudo charge density from r = 0 to rc. 7088c 7089 ll = 2 7090 cdps = - ar(jrc) * ar(jrc) * rab(jrc) 7091 if (jrc .ne. 2*(jrc/2)) then 7092 do 120 k=jrc,1,-1 7093 cdps = cdps + ll * ar(k) * ar(k) * rab(k) 7094 ll = 6 - ll 7095 120 continue 7096 else 7097 do 121 k=jrc,4,-1 7098 cdps = cdps + ll * ar(k) * ar(k) * rab(k) 7099 ll = 6 - ll 7100 121 continue 7101 cdps = cdps - ar(4) * ar(4) * rab(4) 7102 cdps = cdps + 9 * ( ar(1) * ar(1) * rab(1) + 7103 1 3 * ar(2) *ar(2) * rab(2) + 7104 2 3 * ar(3) *ar(3) * rab(3) + 7105 3 ar(4) * ar(4) * rab(4))/8 7106 endif 7107 cdps = cdps/3 7108c 7109c Calculate new delta 7110c 7111 fdnew = log(cdrc/cdps) - 2*delta 7112 if (abs(fdnew) .lt. small) goto 160 7113 if (j .eq. 1) then 7114 ddelta=-one/2 7115 else 7116 ddelta = - fdnew * ddelta / (fdnew-fdold) 7117 endif 7118 delta = delta + ddelta 7119 bj(1)=log(arc/rc1**lp)-delta 7120 bj(2)=brc-lp/rc1 7121 bj(3)=vrc-ev(i)+(lp/rc1)**2-brc**2 7122 vt=vrc-ev(i)+lp*(lp-1)/rc2 7123 bj(4)=vap-2*(vt*brc+lp**2/rc3-brc**3) 7124 bj(5)=vapp-2*((vap-2*lp*(lp-1)/rc3)*brc+(vt-3*brc**2)* 7125 1 (vt-brc**2)-3*lp**2/rc4) 7126 aj(1,1)=rc2 7127 aj(1,2)=rc4 7128 aj(1,3)=rc5 7129 aj(1,4)=rc6 7130 aj(1,5)=rc7 7131 aj(2,1)=2*rc1 7132 aj(2,2)=4*rc3 7133 aj(2,3)=5*rc4 7134 aj(2,4)=6*rc5 7135 aj(2,5)=7*rc6 7136 aj(3,1)=2*one 7137 aj(3,2)=12*rc2 7138 aj(3,3)=20*rc3 7139 aj(3,4)=30*rc4 7140 aj(3,5)=42*rc5 7141 aj(4,1)=zero 7142 aj(4,2)=24*rc1 7143 aj(4,3)=60*rc2 7144 aj(4,4)=120*rc3 7145 aj(4,5)=210*rc4 7146 aj(5,1)=zero 7147 aj(5,2)=24*one 7148 aj(5,3)=120*rc1 7149 aj(5,4)=360*rc2 7150 aj(5,5)=840*rc3 7151 call gaussj(aj,5,5,bj,1,1) 7152 gamma=bj(1) 7153 alpha=bj(2) 7154 alpha1=bj(3) 7155 alpha2=bj(4) 7156 alpha3=bj(5) 7157 fdold = fdnew 7158 150 continue 7159c 7160c End iteration loop for delta. 7161c 7162 write(6,1020)lp-1 7163 call ext(820+lp) 7164 1020 format(//,'error in pseudt - nonconvergence in finding', 7165 1 /,' starting delta for angular momentum ',i1) 7166c 7167c Bracket the correct gamma, use gamma and -gamma 7168c from above as intial brackets, expands brackets 7169c until a root is found.. 7170c 7171 160 x1=gamma 7172 x2=-gamma 7173 alpha4=zero 7174c 7175 call zrbact(x1,x2,rc1,rc2,rc3,rc4,rc5,rc6,rc7, 7176 1 rc8,lp,arc,brc,vrc,vap,vapp,ev(i),cdrc,r,rab, 7177 2 jrc,delta,gamma,alpha,alpha1,alpha2,alpha3,alpha4,ar) 7178c 7179c Iteration loop to find correct gamma, uses 7180c bisection to find gamma. 7181c 7182 call rtbist(x1,x2,rc1,rc2,rc3,rc4,rc5,rc6,rc7, 7183 1 rc8,lp,arc,brc,vrc,vap,vapp,ev(i),cdrc,r,rab,jrc,delta, 7184 2 gamma,alpha,alpha1,alpha2,alpha3,alpha4,ar) 7185c 7186c Augment charge density and invert schroedinger equation 7187c to find new potential. 7188c 7189 expd = exp(delta) 7190 if (so(i) .lt. 0.1) then 7191 do 169 j=1,jrc 7192 poly = r(j)*r(j)*(((((alpha4*r(j)+alpha3) 7193 1 *r(j)+alpha2)*r(j)+alpha1)*r(j)+alpha)*r(j)**2+gamma) 7194 ar(j) = iswtch * r(j)**lp * expd * exp(poly) 7195 vod(j) = vod(j) + zo(i)*ar(j)*ar(j) 7196 xlamda=((((8*alpha4*r(j)+7*alpha3)*r(j) 7197 1 +6*alpha2)*r(j)+5*alpha1)*r(j)+4*alpha)*r(j)**2+ 7198 2 2*gamma 7199 vj = ev(i) + xlamda * (2 * lp + xlamda * r(j)**2) 7200 1 +((((56*alpha4*r(j)+42*alpha3)*r(j) 7201 2 +30*alpha2)*r(j)+20*alpha1)*r(j)+12*alpha)*r(j)**2 7202 3 +2*gamma 7203 viod(lp,j) = (vj-vid(j)) * r(j) 7204 169 continue 7205 do 168 j=jrc+1,nr 7206 vod(j) = vod(j) + zo(i)*ar(j)*ar(j) 7207 168 continue 7208 else 7209 do 170 j=1,jrc 7210 poly = r(j)*r(j)*(((((alpha4*r(j)+alpha3) 7211 1 *r(j)+alpha2)*r(j)+alpha1)*r(j)+alpha)*r(j)**2+gamma) 7212 ar(j) = iswtch * r(j)**lp * expd * exp(poly) 7213 vou(j) = vou(j) + zo(i)*ar(j)*ar(j) 7214 xlamda=((((8*alpha4*r(j)+7*alpha3)*r(j) 7215 1 +6*alpha2)*r(j)+5*alpha1)*r(j)+4*alpha)*r(j)**2+ 7216 2 2*gamma 7217 vj = ev(i) + xlamda * (2 * lp + xlamda * r(j)**2) 7218 1 +((((56*alpha4*r(j)+42*alpha3)*r(j) 7219 2 +30*alpha2)*r(j)+20*alpha1)*r(j)+12*alpha)*r(j)**2 7220 3 +2*gamma 7221 viou(lp,j) = (vj-viu(j)) * r(j) 7222 170 continue 7223 do 171 j=jrc+1,nr 7224 vou(j) = vou(j) + zo(i)*ar(j)*ar(j) 7225 171 continue 7226 endif 7227c 7228c njtj *** plotting routines *** 7229c potrw is called to save a usefull number of points 7230c of the pseudowave function to make a plot. The 7231c info is written to the current plot.dat file. 7232c wtrans is called to fourier transform the the pseudo 7233c wave function and save it to the current plot.dat file. 7234c 7235 ist=1 7236 if (ar(nr-85) .lt. zero) ist=-1 7237 call potrw(ar,r,nr-85,lo(i),0,ist) 7238 if (ev(i) .eq. zero .or. evi(i) .ne. zero) ist=2 7239 call wtrans(ar,r,nr,rab,lo(i),ist,wk1) 7240c 7241c njtj *** user should adjust for their needs *** 7242c 7243 write(6,180) nops(i),il(lp),so(i),ev(i),rc(lp),cdrc,delta 7244 180 format(1x,i1,a1,f6.1,5f12.6) 7245 190 continue 7246c 7247c End loop over valence orbitals. 7248c 7249c Reset the n quantum numbers to include all valence orbitals. 7250c Compute the ratio between the valence charge present and the 7251c valence charge of a neutral atom. 7252c Transfer pseudo valence charge to charge array 7253c 7254 zval = zero 7255 zratio = zero 7256 do 200 i=ncp,norb 7257 nops(i) = lo(i) + 1 7258 zval = zval + zo(i) 7259 200 continue 7260 zion = zval+znuc-zel 7261 if (zval .ne. zero) zratio=zion/zval 7262 do 210 i=1,nr 7263 cdd(i) = vod(i) 7264 210 continue 7265 do 211 i=1,nr 7266 cdu(i) = vou(i) 7267 211 continue 7268c 7269c If a core correction is indicated construct pseudo core charge 7270c cdc(r) = ac*r * sin(bc*r) inside r(icore) 7271c if cfac < 0 or the valence charge is zero the full core is used 7272c 7273 if (ifcore .ne. 0) then 7274 ac = zero 7275 bc = zero 7276 icore = 1 7277 if (cfac .le. zero .or. zratio .eq. zero) then 7278 write(6,280) r(icore),ac,bc 7279 else 7280 if (rcfac .le. zero) then 7281 do 220 i=nr,2,-1 7282 if (cdc(i) .gt. cfac*zratio*(cdd(i)+cdu(i))) goto 230 7283 220 continue 7284 else 7285 do 221 i=nr,2,-1 7286 if (r(i) .le. rcfac ) goto 230 7287 221 continue 7288 endif 7289 230 icore = i 7290 cdcp = (cdc(icore+1)-cdc(icore)) / (r(icore+1)-r(icore)) 7291 tanb = cdc(icore) / (r(icore)*cdcp-cdc(icore)) 7292 rbold = tpfive 7293 do 240 i=1,50 7294 rbnew = pi+atan(tanb*rbold) 7295 if (abs(rbnew-rbold) .lt. .00001) then 7296 bc = rbnew / r(icore) 7297 ac = cdc(icore) / (r(icore)*sin(rbnew)) 7298 do 260 j=1,icore 7299 cdc(j) = ac*r(j)*sin(bc*r(j)) 7300 260 continue 7301 write(6,280) r(icore),ac,bc 7302 goto 290 7303 else 7304 rbold=rbnew 7305 endif 7306 240 continue 7307 write(6,1030) 7308 call ext(830) 7309 endif 7310 endif 7311 280 format(//,' core correction used',/, 7312 1 ' pseudo core inside r =',f6.3,/,' ac =',f6.3,' bc =',f6.3,/) 7313 1030 format(//,' error in pseudt - noncovergence in finding ', 7314 1 /,'pseudo-core values') 7315c 7316c End the pseudo core charge. 7317c Compute the potential due to pseudo valence charge. 7318c 7319c njtj *** NOTE *** 7320c Spin-polarized potentails should be unscreend with 7321c spin-polarized valence charge. This was not 7322c done in pseudo and pseudok in earlier versions 7323c of this program. 7324c njtj *** NOTE *** 7325c 7326 290 if (ispp .eq. 's') then 7327 blank='s' 7328 else 7329 blank=' ' 7330 endif 7331 call velect(0,1,icorr,blank,ifcore,nr,r,rab,zval, 7332 1 cdd,cdu,cdc,vod,vou,etot,wk1,wk2,wk3,wk4,wk5,wkb) 7333c 7334c Construct the ionic pseudopotential and find the cutoff, 7335c ecut should be adjusted to give a reassonable ionic cutoff 7336c radius, but should not alter the pseudopotential, ie., 7337c the ionic cutoff radius should not be inside the pseudopotential 7338c cutoff radius 7339c 7340 ecut=ecuts 7341 do 315 i=ncp,norb 7342 lp = lo(i)+1 7343 if (so(i) .lt. 0.1) then 7344 do 300 j=2,nr 7345 viod(lp,j)=viod(lp,j) + (vid(j)-vod(j))*r(j) 7346 vp2z = viod(lp,j) + 2*zion 7347 if (abs(vp2z) .gt. ecut) jcut = j 7348 300 continue 7349 rcut(i-ncore) = r(jcut) 7350 do 310 j=jcut,nr 7351 fcut = exp(-5*(r(j)-r(jcut))) 7352 viod(lp,j) = - 2*zion + fcut * (viod(lp,j)+2*zion) 7353 310 continue 7354 do 311 j=2,nr 7355 v(j) = viod(lp,j)/r(j) 7356 311 continue 7357c 7358c njtj *** plotting routines *** 7359c 7360 call potran(lo(i)+1,v,r,nr,zion,wk1,wk2,wk3) 7361 call potrv(v,r,nr-120,lo(i)) 7362c 7363c njtj *** user should adjust for their needs *** 7364c 7365 else 7366 do 312 j=2,nr 7367 viou(lp,j)=viou(lp,j)+ (viu(j)-vou(j))*r(j) 7368 vp2z = viou(lp,j) + 2*zion 7369 if (abs(vp2z) .gt. ecut) jcut = j 7370 312 continue 7371 rcut(i-ncore) = r(jcut) 7372 do 313 j=jcut,nr 7373 fcut = exp(-5*(r(j)-r(jcut))) 7374 viou(lp,j) = - 2*zion + fcut * (viou(lp,j)+2*zion) 7375 313 continue 7376 do 314 j=2,nr 7377 v(j) = viou(lp,j)/r(j) 7378 314 continue 7379c 7380c njtj *** plotting routines *** 7381c 7382 call potran(lo(i)+1,v,r,nr,zion,wk1,wk2,wk3) 7383 call potrv(v,r,nr-120,lo(i)) 7384c 7385c njtj *** user should adjust for their needs *** 7386c 7387 endif 7388 315 continue 7389c 7390c njtj *** plotting routines *** 7391c The calls to 1)potran take the fourier transform of 7392c the potential and saves it in the current plot.dat file, 7393c 2)potrv saves the potential in the current plot.dat file 7394c 3)zion is saved to the current plot.dat file wtih a 7395c marker 'zio' for latter plotting 7396c 7397 write(3,4559) 7398 write(3,4560) zion 7399 4559 format(1x,'marker zio') 7400 4560 format(2x,f5.2) 7401c 7402c njtj *** user should adjust for their needs *** 7403c 7404 7405c 7406c Convert spin-polarized potentials back to nonspin-polarized 7407c by occupation weight(zo). Assumes core polarization is 7408c zero, ie. polarization is only a valence effect. 7409c 7410 if (ispp .eq. 's' ) then 7411 do 500 i=ncp,norb,2 7412 lp = lo(i)+1 7413 zot=zo(i)+zo(i+1) 7414 if (zot .ne. zero) then 7415 do 505 j=2,nr 7416 viod(lp,j)=(viod(lp,j)*zo(i)+viou(lp,j) 7417 1 *zo(i+1))/zot 7418 viou(lp,j)=viod(lp,j) 7419 505 continue 7420 else 7421 do 506 j=2,nr 7422 viod(lp,j)=viod(lp,j)/2+viou(lp,j)/2 7423 viou(lp,j)=viod(lp,j) 7424 506 continue 7425 endif 7426 500 continue 7427 endif 7428c 7429 do 320 i=2,nr 7430 vid(i) = vod(i) 7431 viu(i) = vou(i) 7432 320 continue 7433c 7434c Test the pseudopotential self consistency. Spin-polarized 7435c is tested as spin-polarized(since up/down potentials are 7436c now the same) 7437c 7438 call dsolv2(0,1,blank,ifcore,lmax,nr,a,b,r,rab, 7439 1 norb-ncore,0,nops(ncp),lo(ncp),so(ncp),zo(ncp), 7440 2 znuc,cdd,cdu,cdc,viod,viou,vid,viu,ev(ncp),ek(ncp), 7441 3 ep(ncp),wk1,wk2,wk3,wk4,wk5,wk6,wk7,evi(ncp)) 7442c 7443c Printout the pseudo eigenvalues after cutoff. 7444c 7445 write(6,325) (il(lo(i)+1),rcut(i-ncore),i=ncp,norb) 7446 write(6,326) (ev(i),i=ncp,norb) 7447 325 format(//,' test of eigenvalues',//,' rcut =',8(2x,a1,f7.2)) 7448 326 format(' eval =',8(2x,f8.5)) 7449c 7450c Printout the data for potentials. 7451c 7452 write(6,330) 7453 330 format(///,' l vps(0) vpsmin at r',/) 7454 do 370 i=1,lmax 7455 if (indd(i)+indu(i) .eq. 0) goto 370 7456 if (indd(i) .ne. 0) then 7457 vpsdm = zero 7458 do 350 j=2,nr 7459 if (r(j) .lt. .00001) goto 350 7460 vps = viod(i,j)/r(j) 7461 if (vps .lt. vpsdm) then 7462 vpsdm = vps 7463 rmind = r(j) 7464 endif 7465 350 continue 7466 write(6,360) il(i),viod(i,2)/r(2),vpsdm,rmind 7467 endif 7468 if (indu(i) .ne. 0) then 7469 vpsum = zero 7470 do 351 j=2,nr 7471 if (r(j) .lt. .00001) goto 351 7472 vps = viou(i,j)/r(j) 7473 if (vps .lt. vpsum) then 7474 vpsum = vps 7475 rminu = r(j) 7476 endif 7477 351 continue 7478 write(6,360) il(i),viou(i,2)/r(2),vpsum,rminu 7479 endif 7480 360 format(1x,a1,3f10.3) 7481 370 continue 7482c 7483c Print out the energies from etotal. 7484c 7485 call etotal(itype,one,nameat,norb-ncore, 7486 1 nops(ncp),lo(ncp),so(ncp),zo(ncp), 7487 2 etot,ev(ncp),ek(ncp),ep(ncp)) 7488c 7489c Find the jobname and date, date is a machine 7490c dependent routine and must be chosen/written/ 7491c comment in/out in the zedate section. 7492c 7493 iray(1) = 'atom-lda ' 7494 call zedate(iray(2)) 7495 iray(3) = ' Troullier' 7496 iray(4) = ' - Martins' 7497 iray(5) = ' potential' 7498 iray(6) = ' ' 7499c 7500c Encode the title array. 7501c 7502 do 390 i=1,7 7503 ititle(i) = ' ' 7504 390 continue 7505 do 420 i=1,lmax 7506 if (indd(i) .eq. 0 .and. indu(i) .eq. 0) goto 420 7507 zelu = zero 7508 zeld = zero 7509 if (indd(i) .ne. 0) then 7510 noi = no(indd(i)) 7511 zeld = zo(indd(i)) 7512 endif 7513 if (indu(i) .ne. 0) then 7514 noi = no(indu(i)) 7515 zelu = zo(indu(i)) 7516 endif 7517 zelt = zeld + zelu 7518 if (ispp .ne. 's') then 7519 write(ititle(2*i-1),400) noi,il(i),zelt 7520 write(ititle(2*i),401)ispp,rc(i) 7521 400 format(i1,a1,'(',f6.2,')') 7522 401 format(a1,' rc=',f5.2) 7523 else 7524 write(ititle(2*i-1),410) noi,il(i),zeld 7525 write(ititle(2*i),411)zelu,ispp,rc(i) 7526 410 format(i1,a1,' (',f4.2,',') 7527 411 format(f4.2,')',a1,f4.2) 7528 endif 7529 420 continue 7530c 7531c Construct relativistic sum and difference potentials. 7532c 7533 if (ispp .eq. 'r') then 7534 if (indu(1) .eq. 0) goto 429 7535 indd(1)=indu(1) 7536 indu(1)=0 7537 do 428 j=2,nr 7538 viod(1,j) = viou(1,j) 7539 viou(1,j) = zero 7540 428 continue 7541 429 do 431 i=2,lmax 7542 if (indd(i) .eq. 0 .or. indu(i) .eq. 0) goto 431 7543 do 430 j=2,nr 7544 viodj = viod(i,j) 7545 viouj = viou(i,j) 7546 viod(i,j) = ((i-1)*viodj + i*viouj) / (2*i-1) 7547 viou(i,j) = 2 * (viouj - viodj) / (2*i-1) 7548 430 continue 7549 431 continue 7550 endif 7551c 7552c Determine the number of potentials. Coded them as 7553c two digits, where the first digit is the number 7554c of down or sum potentials and the second the number of 7555c up or difference potentials. 7556c 7557 npotd = 0 7558 npotu = 0 7559 do 450 i=1,lmax 7560 if (indd(i) .ne. 0) npotd=npotd+1 7561 if (indu(i) .ne. 0) npotu=npotu+1 7562 450 continue 7563c 7564c Write the heading to the current pseudo.dat 7565c file (unit=1). 7566c 7567 ifull = 0 7568 if (cfac .le. zero .or. zratio .eq. zero) ifull = 1 7569 if (ifcore .eq. 1) then 7570 if (ifull .eq. 0) then 7571 nicore = 'pcec' 7572 else 7573 nicore = 'fcec' 7574 endif 7575 elseif (ifcore .eq. 2) then 7576 if (ifull .eq. 0) then 7577 nicore = 'pche' 7578 else 7579 nicore = 'fche' 7580 endif 7581 else 7582 nicore = 'nc ' 7583 endif 7584 if (ispp .eq. 's') then 7585 irel='isp' 7586 elseif (ispp .eq. 'r') then 7587 irel='rel' 7588 else 7589 irel = 'nrl' 7590 endif 7591 rewind 1 7592 write(1) nameat,icorr,irel,nicore,(iray(i),i=1,6), 7593 1 (ititle(i),i=1,7),npotd,npotu,nr-1,a,b,zion 7594 write(1) (r(i),i=2,nr) 7595c 7596c Write the potentials to the current pseudo.dat 7597c file (unit=1). 7598c 7599 do 460 i=1,lmax 7600 if (indd(i) .eq. 0) goto 460 7601 write(1) i-1,(viod(i,j),j=2,nr) 7602 460 continue 7603 do 465 i=1,lmax 7604 if (indu(i) .eq. 0) goto 465 7605 write(1) i-1,(viou(i,j),j=2,nr) 7606 465 continue 7607c 7608c Write the charge densities to the current pseudo.dat 7609c file (unit=1). 7610c 7611 if (ifcore .eq. 0) then 7612 write(1) (zero,i=2,nr) 7613 else 7614 write(1) (cdc(i),i=2,nr) 7615 endif 7616 write(1) (zratio*(cdd(i)+cdu(i)),i=2,nr) 7617c 7618 return 7619 end 7620C 7621C 7622C 7623 subroutine pseudv(itype,icorr,ispp,lmax,nr,a,b,r,rab, 7624 1 nameat,norb,ncore,no,lo,so,zo,znuc,zel,cdd,cdu,cdc, 7625 2 viod,viou,vid,viu,vod,vou,etot,ev,ek,ep,wk1,wk2,wk3, 7626 3 wk4,wk5,wk6,wk7,f,g,nops,v,ar,br,arps,wkb,evi) 7627c 7628c ************************************************************* 7629c * * 7630c * This routine was written by Norman J. Troullier Jr. * 7631c * Nov. 1989, while at the U. of Minnesota, all * 7632c * comments concerning this routine should be directed * 7633c * to him. * 7634c * * 7635c * troullie@128.101.224.101 * 7636c * troullie@csfsa.cs.umn.edu * 7637c * 612 625-0392 * 7638c * * 7639c * pseudv generates a pseudopotential using the * 7640c * scheme of D. Vanderbilt, ref. Physical Review B, * 7641c * vol. 32, num 12, page 8412. * 7642c * The general format of this routine is the same as the * 7643c * pseudo, pseudk and pseudt routines. Output/input is * 7644c * compatible. * 7645c * * 7646c ************************************************************* 7647c 7648c njtj 7649c ### Cray conversions 7650c ### 1)Comment out implicit double precision. 7651c ### 2)Switch double precision parameter 7652c ### to single precision parameter statement. 7653c ### Cray conversions 7654c njtj 7655c 7656 implicit double precision (a-h,o-z) 7657c 7658 parameter(zero=0.D0,deltas=1.D-3,tpfive=2.5D0,one=1.D0,two=2.D0) 7659 parameter(small=1.D-32,small2=1.D-8,small3=1.D-16,pzfive=0.05D0) 7660 parameter(pfive=0.5D0,small4=1.D-6,ai=2*137.0360411D0) 7661 parameter(onepf=1.5D0,oneh=100.D0) 7662Cray parameter(zero=0.0,deltas=1.E-3,tpfive=2.5,one=1.0,two=2.D0) 7663Cray parameter(small=1.E-32,small2=1.E-8,small3=1.E-16,pzfive=0.5) 7664Cray parameter(pfive=0.5,small4=1.E-6,ai=2*137.0360411) 7665Cray parameter(onepf=1.5,oneh=100.0) 7666c 7667 character*1 ispp,blank,il(5) 7668 character*2 icorr,nameat 7669 character*3 irel 7670 character*4 nicore 7671 character*10 ititle(7),iray(6) 7672c 7673 dimension r(nr),rab(nr),no(norb),lo(norb),so(norb),zo(norb), 7674 1 cdd(nr),cdu(nr),cdc(nr),viod(lmax,nr),viou(lmax,nr), 7675 2 vid(nr),viu(nr),vod(nr),vou(nr),ev(norb),ek(norb),ep(norb), 7676 3 wk1(nr),wk2(nr),wk3(nr),wk4(nr),wk5(nr),wk6(nr),wk7(nr), 7677 4 wkb(6*nr),f(nr),g(nr),nops(norb),v(nr),ar(nr),br(nr), 7678 5 arps(nr),evi(norb) 7679c 7680 dimension etot(10),indd(5),indu(5),rc(5),rcut(10),ab(5), 7681 1 rr(5),coe(5),bj(3),aj(3,3) 7682c 7683 data il/'s','p','d','f','g'/ 7684 do 3 i=1,5 7685 indd(i)=0 7686 indu(i)=0 7687 3 continue 7688 if (ncore .eq. norb) return 7689 ifcore = itype-1 7690 pi = 4*atan(one) 7691c 7692c Spin-polarized potentails should be unscreened with 7693c a spin-polarized valence charge. This was not 7694c done in pseudo and pseudk in earlier versions 7695c of this program. 7696c 7697 if (ispp .eq. 's' ) then 7698 blank = 's' 7699 else 7700 blank = ' ' 7701 endif 7702c 7703c read rc(s),rc(p),rc(d),rc(f),rc(g),cfac,rcfac 7704c 7705c cfac is used for the pseudocore - the pseudocore stops where 7706c the core charge density equals cfac times the renormalized 7707c valence charge density (renormalized to make the atom neutral). 7708c If cfac is input as negative, the full core charge is used, 7709c if cfac is input as zero, it is set equal to one. 7710c rcfac is used for the pseudocore cut off radius. If set 7711c to less then or equal to zero cfac is used. cfac must be 7712c set to greater then zero. 7713c 7714 read(5,10) (rc(i),i=1,5),cfac,rcfac 7715 10 format(7f10.5) 7716 if (cfac .eq. zero) cfac=one 7717c 7718c Reset vod and vou to zero. They are here used to store 7719c the pseudo valence charge density. 7720c 7721 do 15 i=1,nr 7722 vod(i) = zero 7723 vou(i) = zero 7724 15 continue 7725c 7726c Print the heading. 7727c 7728 write(6,20) nameat 7729 20 format(//,a2,' Pseudopotential Vanderbilt generation',/,1x, 7730 1 50('-'),//,' nl s eigenvalue',6x,'rc',4x,6x,'cl', 7731 2 9x,'gamma',7x,'delta',/) 7732c 7733c start loop over valence orbitals 7734c 7735 ncp = ncore+1 7736 do 190 i=ncp,norb 7737 lp = lo(i) + 1 7738 llp = lo(i)*lp 7739 if (so(i) .lt. 0.1) then 7740 if (indd(lp) .ne. 0) then 7741 write(6,1000)lp-1 7742 call ext(800+lp) 7743 else 7744 indd(lp) = i 7745 endif 7746 else 7747 if (indu(lp) .ne. 0) then 7748 write(6,1010)lp-1 7749 call ext(810+lp) 7750 else 7751 indu(lp) = i 7752 endif 7753 endif 7754 1000 format(//,'error in pseudv - two down spin orbitals of the same ', 7755 1 /,'angular momentum (',i1,') exist') 7756 1010 format(//,'error in pseudv - two up spin orbitals of the same ', 7757 1 /,'angular momentum (',i1,') exist') 7758c 7759c find all electron wave function 7760c 7761 do 25 j=1,nr 7762 ar(j)=zero 7763 25 continue 7764 if (so(i) .lt. 0.1) then 7765 do 27 j=2,nr 7766 v(j) = viod(lp,j)/r(j) + vid(j) 7767 27 continue 7768 else 7769 do 30 j=2,nr 7770 v(j) = viou(lp,j)/r(j) + viu(j) 7771 30 continue 7772 endif 7773 if (ispp .ne. 'r') then 7774 do 32 j=2,nr 7775 v(j) = v(j) + llp/r(j)**2 7776 32 continue 7777 endif 7778 if (ispp .ne. 'r') then 7779 call difnrl(0,i,v,ar,br,lmax,nr,a,b,r,rab,norb,no,lo,so, 7780 1 znuc,viod,viou,vid,viu,ev,iflag,wk1,wk2,wk3,evi) 7781 else 7782 call difrel(0,i,v,ar,br,lmax,nr,a,b,r,rab,norb,no,lo,so, 7783 1 znuc,viod,viou,vid,viu,ev,wk1,wk2,wk3,wk4,evi) 7784 endif 7785c 7786c njtj *** plotting routines *** 7787c potrw is called to save an usefull number of points 7788c of the wave function to make a plot. The info is 7789c written to the current plot.dat file. 7790c 7791 ist=1 7792 if (ar(nr-85) .lt. zero) ist=-1 7793 call potrw(ar,r,nr-85,lo(i),1,ist) 7794c 7795c njtj *** user should adjust for their needs *** 7796c 7797c Find the last zero and extremum. 7798c 7799 ka = lo(i)+1 7800 if (so(i) .lt. 0.1 .and. lo(i) .ne. 0) ka=-lo(i) 7801 nextr = no(i)-lo(i) 7802 rzero = zero 7803 arp = br(2) 7804c 7805 if (ispp .eq. 'r') then 7806 if (so(i) .lt. 0.1) then 7807 arp = ka*ar(2)/r(2) + (ev(i) - viod(lp,2)/r(2) 7808 1 - vid(2) + ai*ai) * br(2) / ai 7809 else 7810 arp = ka*ar(2)/r(2) + (ev(i) - viou(lp,2)/r(2) 7811 1 - viu(2) + ai*ai) * br(2) / ai 7812 endif 7813 endif 7814c 7815 do 40 j=3,nr-7 7816 if (nextr .eq. 0) goto 50 7817 if (ar(j-1)*ar(j) .le. zero) 7818 1 rzero = (ar(j)*r(j-1)-ar(j-1)*r(j)) / (ar(j)-ar(j-1)) 7819 arpm = arp 7820 arp = br(j) 7821c 7822 if (ispp .eq. 'r') then 7823 if (so(i) .lt. 0.1) then 7824 arp = ka*ar(j)/r(j) + (ev(i) - viod(lp,j)/r(j) 7825 1 - vid(j) + ai*ai) * br(j) / ai 7826 else 7827 arp = ka*ar(j)/r(j) + (ev(i) - viou(lp,j)/r(j) 7828 1 - viu(j) + ai*ai) * br(j) / ai 7829 endif 7830 endif 7831c 7832 if (arp*arpm .gt. zero) goto 40 7833 rextr = (arp*r(j-1)-arpm*r(j)) / (arp-arpm) 7834 nextr = nextr - 1 7835 40 continue 7836c 7837c Check rc, if outside bounds reset. 7838c 7839 50 if (rzero .lt. r(2)) rzero = r(2) 7840 if (rc(lp) .gt. rzero .and. rc(lp) .lt. rextr) goto 60 7841 if (rc(lp) .ge. rzero) write(6,2001)rc(lp),rextr 7842 2001 format(/,'Warning, the Core radius =',f5.2, 7843 1 /,' is larger then wave function', 7844 1 ' extrema position =',f5.2,/) 7845 if (rc(lp) .lt. zero) rc(lp) = rzero - rc(lp)*(rextr-rzero) 7846c 7847c Find the index for grid point closest to 1.5*rc. 7848c Find the index for 3*rc which is used for matching norms. 7849c 7850 60 rcopf= onepf*rc(lp) 7851 do 71 j=1,nr 7852 if (r(j) .le. rcopf) then 7853 jrc=j 7854 endif 7855 if (r(j) .lt. 3*rc(lp)) then 7856 j3rc = j 7857 endif 7858 71 continue 7859c 7860c Reset the n quantum numbers. 7861c 7862 do 70 j=1,norb 7863 nops(j) = 0 7864 70 continue 7865 nops(i) = lp 7866c 7867c Set up potential vl1, first find true potential, 7868c its first and second derivative at rc. Store new 7869c potential(unscreen it first, screening added back 7870c in dsolv2). 7871c 7872 if (so(i) .lt. 0.1) then 7873 vrc = viod(lp,jrc)/r(jrc) + vid(jrc) 7874 ab(1)=viod(lp,jrc-2)/r(jrc-2) + vid(jrc-2) 7875 ab(2)=viod(lp,jrc-1)/r(jrc-1) + vid(jrc-1) 7876 ab(3)=vrc 7877 ab(4)=viod(lp,jrc+1)/r(jrc+1) + vid(jrc+1) 7878 ab(5)=viod(lp,jrc+2)/r(jrc+2) + vid(jrc+2) 7879 else 7880 vrc = viou(lp,jrc)/r(jrc) + viu(jrc) 7881 ab(1)=viou(lp,jrc-2)/r(jrc-2) + viu(jrc-2) 7882 ab(2)=viou(lp,jrc-1)/r(jrc-1) + viu(jrc-1) 7883 ab(3)=vrc 7884 ab(4)=viou(lp,jrc+1)/r(jrc+1) + viu(jrc+1) 7885 ab(5)=viou(lp,jrc+2)/r(jrc+2) + viu(jrc+2) 7886 endif 7887 rr(1)=r(jrc-2)-r(jrc) 7888 rr(2)=r(jrc-1)-r(jrc) 7889 rr(3)=zero 7890 rr(4)=r(jrc+1)-r(jrc) 7891 rr(5)=r(jrc+2)-r(jrc) 7892 call polcoe(rr,ab,5,coe) 7893 vap = coe(2) 7894 vapp= 2*coe(3) 7895 bj(1)=vrc 7896 bj(2)=vap 7897 bj(3)=vapp 7898 aj(1,1)=one 7899 aj(2,1)=zero 7900 aj(3,1)=zero 7901 aj(1,2)=r(jrc)**2 7902 aj(2,2)=2*r(jrc) 7903 aj(3,2)=2*one 7904 aj(1,3)=r(jrc)**4 7905 aj(2,3)=4*r(jrc)**3 7906 aj(3,3)=12*r(jrc)**2 7907 call gaussj(aj,3,3,bj,1,1) 7908 b0=bj(1) 7909 b2=bj(2) 7910 b4=bj(3) 7911 if (so(i) .lt. 0.1) then 7912 do 82 j=1,jrc 7913 viod(lp,j)=((b0+b2*r(j)**2+b4*r(j)**4)-vid(j))*r(j) 7914 82 continue 7915 else 7916 do 83 j=1,jrc 7917 viou(lp,j)=((b0+b2*r(j)**2+b4*r(j)**4)-viu(j))*r(j) 7918 83 continue 7919 endif 7920c 7921c Set up the functions f(r/rc) and g(r/rc) and modify the ionic potential. 7922c 7923 if (lp .eq. 1) then 7924 dcl = sqrt(znuc) 7925 else 7926 dcl=-2*one*lp*llp 7927 endif 7928 cl=dcl 7929 sinhb2=(sinh(one))**2 7930c 7931 do 80 j=1,nr 7932 rrc = r(j)/rc(lp)/onepf 7933 f(j)=oneh**(-((sinh(rrc))**2)/sinhb2) 7934 if (f(j) .lt. small2) f(j)=zero 7935 g(j) = f(j) 7936 80 continue 7937 if (so(i) .lt. 0.1) then 7938 do 81 j=2,nr 7939 viod(lp,j)=viod(lp,j)+dcl*f(j)*r(j) 7940 81 continue 7941 else 7942 do 84 j=2,nr 7943 viou(lp,j)=viou(lp,j)+dcl*f(j)*r(j) 7944 84 continue 7945 endif 7946 dcl=dcl/2 7947c 7948c Start the iteration loop to find cl. 7949c 7950 eviae = ev(i) 7951 devold = zero 7952 do 130 j=1,100 7953 call dsolv2(j,2,blank,ifcore,lmax, 7954 1 nr,a,b,r,rab,norb,ncore,nops,lo,so,zo,znuc,cdd,cdu,cdc, 7955 2 viod,viou,vid,viu,ev,ek,ep,wk1,wk2,wk3,wk4,wk5,wk6, 7956 3 wk7,evi) 7957 dev = eviae-ev(i) 7958c 7959c The abs(dev-devold) condition was added to eliminate 7960c division by zero errors in the calculation of 7961c dcl = -dev*dcl / (dev-devold). 7962c 7963 if ((abs(dev) .lt. small2 .or. abs(dev-devold) .lt. small3) 7964 1 .and. j .ne. 1) then 7965 goto 140 7966 else 7967 if (j .gt. 15 .or. abs(dev) .lt. 0.001) then 7968c 7969c Use newton raphson iteration to change cl. 7970c 7971 dcl = -dev*dcl / (dev-devold) 7972 else 7973 if (dev*dcl .le. zero) then 7974 dcl=-dcl/4 7975 endif 7976 endif 7977 endif 7978c 7979c Find the new potential. 7980c 7981 if (so(i) .lt. 0.1) then 7982 do 110 k=2,nr 7983 viod(lp,k) = viod(lp,k) + dcl*r(k)*f(k) 7984 110 continue 7985 else 7986 do 111 k=2,nr 7987 viou(lp,k) = viou(lp,k) + dcl*r(k)*f(k) 7988 111 continue 7989 endif 7990 cl = cl + dcl 7991 devold = dev 7992 130 continue 7993c 7994c End the iteration loop for cl. 7995c 7996 call ext(820+lp) 7997c 7998c Find the new pseudo-wavefunction. 7999c 8000 140 if (so(i) .lt. 0.1) then 8001 do 150 j=2,nr 8002 v(j) = (viod(lp,j)+llp/r(j))/r(j) + vid(j) 8003 150 continue 8004 else 8005 do 151 j=2,nr 8006 v(j) = (viou(lp,j)+llp/r(j))/r(j) + viu(j) 8007 151 continue 8008 endif 8009 do 152 j=1,nr 8010 arps(j)=zero 8011 152 continue 8012 call difnrl(0,i,v,arps,br,lmax,nr,a,b,r,rab,norb, 8013 1 nops,lo,so,znuc,viod,viou,vid,viu,ev,iflag,wk1, 8014 2 wk2,wk3,evi) 8015c 8016c Compute yl store in g, store ln(arps) in br. 8017c 8018 do 155 j=2,nr 8019 g(j)=arps(j)*f(j) 8020 155 continue 8021 do 157 j=2,nr 8022 br(j)=log(arps(j)+small) 8023 157 continue 8024c 8025c Compute delta and gamma. 8026c 8027 gamma = abs(ar(j3rc)/arps(j3rc)+ar(j3rc+1)/arps(j3rc+1))/2 8028 ag = zero 8029 gg = zero 8030 ll = 4 8031 do 160 j=2,nr 8032 ag = ag + ll*arps(j)*g(j)*rab(j) 8033 gg = gg + ll*g(j)*g(j)*rab(j) 8034 ll = 6 - ll 8035 160 continue 8036 ag = ag/3 8037 gg = gg/3 8038 delta = sqrt((ag/gg)**2+(one/gamma**2-one)/gg) - ag/gg 8039c 8040c Modify the pseudo-wavefunction. 8041c 8042 do 171 j=2,nr 8043 arps(j) = gamma*arps(j)*(one+delta*f(j)) 8044 171 continue 8045c 8046c Find d(ln(wl)/dr and store in g(). Note the use of additional 8047c given information of the Vanderbilt method, i.e. the use of 8048c d(ln(wl)/dr to improve stability. 8049c 8050 do 172 j=4,nr-2 8051 ab(1) = br(j-2) 8052 ab(2) = br(j-1) 8053 ab(3) = br(j) 8054 ab(4) = br(j+1) 8055 ab(5) = br(j+2) 8056 rr(1)=r(j-2)-r(j) 8057 rr(2)=r(j-1)-r(j) 8058 rr(3)=zero 8059 rr(4)=r(j+1)-r(j) 8060 rr(5)=r(j+2)-r(j) 8061 call polcoe(rr,ab,5,coe) 8062 g(j)=coe(2) 8063 172 continue 8064 g(nr-1)=g(nr-2) 8065 g(nr)=g(nr-2) 8066 ab(1) = g(4) 8067 ab(2) = g(5) 8068 ab(3) = g(6) 8069 ab(4) = g(7) 8070 ab(5) = g(8) 8071 rr(1)=r(4)-r(3) 8072 rr(2)=r(5)-r(3) 8073 rr(3)=r(6)-r(3) 8074 rr(4)=r(7)-r(3) 8075 rr(5)=r(8)-r(3) 8076 call polcoe(rr,ab,5,coe) 8077 g(3)=coe(1) 8078 ab(1) = g(3) 8079 ab(2) = g(4) 8080 ab(3) = g(5) 8081 ab(4) = g(6) 8082 ab(5) = g(7) 8083 rr(1)=r(3)-r(2) 8084 rr(2)=r(4)-r(2) 8085 rr(3)=r(5)-r(2) 8086 rr(4)=r(6)-r(2) 8087 rr(5)=r(7)-r(2) 8088 call polcoe(rr,ab,5,coe) 8089 g(2)=coe(1) 8090c 8091c Find constants for inversion. 8092c 8093 c3=log(oneh)/onepf/rc(lp)/sinhb2 8094 c2=2/onepf/rc(lp)*c3 8095 c1=c3**2 8096c 8097c Modify potential and find total charge density. 8098c 8099 if (so(i) .lt. 0.1) then 8100 do 173 j=2,nr 8101 vod(j)=vod(j)+zo(i)*arps(j)*arps(j) 8102 173 continue 8103 else 8104 do 174 j=2,nr 8105 vou(j)=vou(j)+zo(i)*arps(j)*arps(j) 8106 174 continue 8107 endif 8108 if (so(i) .lt. 0.1) then 8109 do 175 j=2,nr 8110 xr=two*r(j)/rc(lp)/onepf 8111 sinhxr=sinh(xr) 8112 coshxr=cosh(xr) 8113 viod(lp,j)=viod(lp,j)+delta*f(j)/(one+delta*f(j))* 8114 1 (c1*(sinhxr)**2-c2*coshxr-2*c3*sinhxr*g(j))*r(j) 8115 175 continue 8116 else 8117 do 176 j=2,nr 8118 xr=two*r(j)/rc(lp)/onepf 8119 sinhxr=sinh(xr) 8120 coshxr=cosh(xr) 8121 viou(lp,j)=viou(lp,j)+delta*f(j)/(one+delta*f(j))* 8122 1 (c1*(sinhxr)**2-c2*coshxr-2*c3*sinhxr*g(j))*r(j) 8123 176 continue 8124 endif 8125c 8126c njtj *** plotting routines *** 8127c potrw is called to save a usefull number of points 8128c of the pseudowave function to make a plot. The 8129c info is written to the current plot.dat file. 8130c wtrans is called to fourier transform the the pseudo 8131c wave function and save it to the current plot.dat file. 8132c 8133 ist=1 8134 if (arps(nr-85) .lt. zero) ist=-1 8135 call potrw(arps,r,nr-85,lo(i),0,ist) 8136 if (ev(i) .eq. zero .or. evi(i) .ne. zero) ist=2 8137 call wtrans(arps,r,nr,rab,lo(i),ist,wk1) 8138c 8139c njtj *** user should adjust for their needs *** 8140c 8141 write(6,180) nops(i),il(lp),so(i),ev(i),rc(lp),cl,gamma,delta 8142 180 format(1x,i1,a1,f6.1,2f12.6,f12.3,2f12.4) 8143 190 continue 8144c 8145c End the loop over the valence orbitals. 8146c 8147c Reset the n quantum numbers to include all valence orbitals. 8148c Compute the ratio between the valence charge present and the 8149c valence charge of a neutral atom. 8150c Transfer pseudo valence charge to charge array 8151c 8152 zval = zero 8153 zratio = zero 8154 do 200 i=ncp,norb 8155 nops(i) = lo(i) + 1 8156 zval = zval + zo(i) 8157 200 continue 8158 zion = zval+znuc-zel 8159 if (zval .ne. zero) zratio=zion/zval 8160 vod(1)=zero 8161 vou(1)=zero 8162 do 210 i=1,nr 8163 cdd(i) = vod(i) 8164 210 continue 8165 do 211 i=1,nr 8166 cdu(i) = vou(i) 8167 211 continue 8168c 8169c If a core correction is indicated construct pseudo core charge 8170c cdc(r) = ac*r * sin(bc*r) inside r(icore) 8171c if cfac < 0 or the valence charge is zero the full core is used 8172c 8173 if (ifcore .ne. 0) then 8174 ac = zero 8175 bc = zero 8176 icore = 1 8177 if (cfac .le. zero .or. zratio .eq. zero) then 8178 write(6,280) r(icore),ac,bc 8179 else 8180 if (rcfac .le. zero) then 8181 do 220 i=nr,2,-1 8182 if (cdc(i) .gt. cfac*zratio*(cdd(i)+cdu(i))) goto 230 8183 220 continue 8184 else 8185 do 221 i=nr,2,-1 8186 if (r(i) .le. rcfac ) goto 230 8187 221 continue 8188 endif 8189 230 icore = i 8190 cdcp = (cdc(icore+1)-cdc(icore)) / (r(icore+1)-r(icore)) 8191 tanb = cdc(icore) / (r(icore)*cdcp-cdc(icore)) 8192 rbold = tpfive 8193 do 240 i=1,50 8194 rbnew = pi+atan(tanb*rbold) 8195 if (abs(rbnew-rbold) .lt. .00001) then 8196 bc = rbnew / r(icore) 8197 ac = cdc(icore) / (r(icore)*sin(rbnew)) 8198 do 260 j=1,icore 8199 cdc(j) = ac*r(j)*sin(bc*r(j)) 8200 260 continue 8201 write(6,280) r(icore),ac,bc 8202 goto 290 8203 else 8204 rbold=rbnew 8205 endif 8206 240 continue 8207 write(6,1030) 8208 call ext(830) 8209 endif 8210 endif 8211 280 format(//,' core correction used',/, 8212 1 ' pseudo core inside r =',f6.3,/,' ac =',f6.3,' bc =',f6.3,/) 8213 1030 format(//,' error in pseudv - noncovergence in finding ', 8214 1 /,'pseudo-core values') 8215c 8216c End the pseudo core charge. 8217c Compute the potential due to pseudo valence charge. 8218c 8219c njtj *** NOTE *** 8220c Spin-polarized potentails should be unscreend with 8221c spin-polarized valence charge. This was not 8222c done in pseudo and pseudok in earlier versions 8223c of this program. 8224c njtj *** NOTE *** 8225c 8226 290 if (ispp .eq. 's') then 8227 blank='s' 8228 else 8229 blank=' ' 8230 endif 8231 call velect(0,1,icorr,blank,ifcore,nr,r,rab,zval, 8232 1 cdd,cdu,cdc,vod,vou,etot,wk1,wk2,wk3,wk4,wk5,wkb) 8233c 8234c Construct the ionic pseudopotential and find the cutoff, 8235c ecut should be adjusted to give a reassonable ionic cutoff 8236c radius, but should not alter the pseudopotential, ie., 8237c the ionic cutoff radius should not be inside the pseudopotential 8238c cutoff radius 8239c 8240 ecut=deltas 8241 do 315 i=ncp,norb 8242 lp = lo(i)+1 8243 if (so(i) .lt. 0.1) then 8244 do 300 j=2,nr 8245 viod(lp,j)=viod(lp,j) + (vid(j)-vod(j))*r(j) 8246 vp2z = viod(lp,j) + 2*zion 8247 if (abs(vp2z) .gt. ecut) jcut = j 8248 300 continue 8249 rcut(i-ncore) = r(jcut) 8250 do 310 j=jcut,nr 8251 fcut = exp(-5*(r(j)-r(jcut))) 8252 viod(lp,j) = - 2*zion + fcut * (viod(lp,j)+2*zion) 8253 310 continue 8254 do 311 j=2,nr 8255 v(j) = viod(lp,j)/r(j) 8256 311 continue 8257 else 8258 do 312 j=2,nr 8259 viou(lp,j)=viou(lp,j)+ (viu(j)-vou(j))*r(j) 8260 vp2z = viou(lp,j) + 2*zion 8261 if (abs(vp2z) .gt. ecut) jcut = j 8262 312 continue 8263 rcut(i-ncore) = r(jcut) 8264 do 313 j=jcut,nr 8265 fcut = exp(-5*(r(j)-r(jcut))) 8266 viou(lp,j) = - 2*zion + fcut * (viou(lp,j)+2*zion) 8267 313 continue 8268 do 314 j=2,nr 8269 v(j) = viou(lp,j)/r(j) 8270 314 continue 8271 endif 8272c 8273c njtj *** plotting routines *** 8274c 8275 call potran(lo(i)+1,v,r,nr,zion,wk1,wk2,wk3) 8276 call potrv(v,r,nr-120,lo(i)) 8277c 8278c njtj *** user should adjust for their needs *** 8279c 8280 315 continue 8281c 8282c njtj *** plotting routines *** 8283c The calls to 1)potran take the fourier transform of 8284c the potential and saves it in the current plot.dat file, 8285c 2)potrv saves the potential in the current plot.dat file 8286c 3)zion is saved to the current plot.dat file wtih a 8287c marker 'zio' for latter plotting 8288c 8289 write(3,4559) 8290 write(3,4560) zion 8291 4559 format(1x,'marker zio') 8292 4560 format(2x,f5.2) 8293c 8294c njtj *** user should adjust for their needs *** 8295c 8296c Convert spin-polarized potentials back to nonspin-polarized 8297c by occupation weight(zo). Assumes core polarization is 8298c zero, ie. polarization is only a valence effect. 8299c 8300 if (ispp .eq. 's' ) then 8301 do 500 i=ncp,norb,2 8302 lp = lo(i)+1 8303 zot=zo(i)+zo(i+1) 8304 if (zot .ne. zero) then 8305 do 505 j=2,nr 8306 viod(lp,j)=(viod(lp,j)*zo(i)+viou(lp,j) 8307 1 *zo(i+1))/zot 8308 viou(lp,j)=viod(lp,j) 8309 505 continue 8310 else 8311 do 506 j=2,nr 8312 viod(lp,j)=viod(lp,j)/2+viou(lp,j)/2 8313 viou(lp,j)=viod(lp,j) 8314 506 continue 8315 endif 8316 500 continue 8317 endif 8318c 8319 do 320 i=1,nr 8320 vid(i) = vod(i) 8321 viu(i) = vou(i) 8322 320 continue 8323c 8324c Test the pseudopotential self consistency. Spin-polarized 8325c is tested as spin-polarized(since up/down potentials are 8326c now the same) 8327c 8328 call dsolv2(0,1,blank,ifcore,lmax, 8329 1 nr,a,b,r,rab,norb,ncore,nops,lo,so,zo,znuc,cdd,cdu,cdc, 8330 2 viod,viou,vid,viu,ev,ek,ep,wk1,wk2,wk3,wk4,wk5,wk6, 8331 3 wk7,evi) 8332c 8333c Printout the pseudo eigenvalues after cutoff. 8334c 8335 write(6,325) (il(lo(i)+1),rcut(i-ncore),i=ncp,norb) 8336 write(6,326) (ev(i),i=ncp,norb) 8337 325 format(//,' test of eigenvalues',//,' rcut =',8(2x,a1,f7.2)) 8338 326 format(' eval =',8(2x,f8.5)) 8339c 8340c Printout the data for potentials. 8341c 8342 write(6,330) 8343 330 format(///,' l vps(0) vpsmin at r',/) 8344 do 370 i=1,lmax 8345 if (indd(i)+indu(i) .eq. 0) goto 370 8346 if (indd(i) .ne. 0) then 8347 vpsdm = zero 8348 do 350 j=2,nr 8349 if (r(j) .lt. .00001) goto 350 8350 vps = viod(i,j)/r(j) 8351 if (vps .lt. vpsdm) then 8352 vpsdm = vps 8353 rmind = r(j) 8354 endif 8355 350 continue 8356 write(6,360) il(i),viod(i,2)/r(2),vpsdm,rmind 8357 endif 8358 if (indu(i) .ne. 0) then 8359 vpsum = zero 8360 do 351 j=2,nr 8361 if (r(j) .lt. .00001) goto 351 8362 vps = viou(i,j)/r(j) 8363 if (vps .lt. vpsum) then 8364 vpsum = vps 8365 rminu = r(j) 8366 endif 8367 351 continue 8368 write(6,360) il(i),viou(i,2)/r(2),vpsum,rminu 8369 endif 8370 360 format(1x,a1,3f10.3) 8371 370 continue 8372c 8373c Print out the energies from etotal. 8374c 8375 call etotal(itype,one,nameat,norb-ncore, 8376 1 nops(ncp),lo(ncp),so(ncp),zo(ncp), 8377 2 etot,ev(ncp),ek(ncp),ep(ncp)) 8378c 8379c Find the jobname and date, date is a machine 8380c dependent routine and must be chosen/written/ 8381c comment in/out in the zedate section. 8382c 8383 iray(1)='atom-lda ' 8384 call zedate(iray(2)) 8385 iray(3) = 'Vanderbilt' 8386 iray(4) = ' Pseudo - ' 8387 iray(5) = 'potential ' 8388 iray(6) = 'generation' 8389c 8390c Encode the title array. 8391c 8392 do 390 i=1,7 8393 ititle(i) = ' ' 8394 390 continue 8395 do 420 i=1,lmax 8396 if (indd(i) .eq. 0 .and. indu(i) .eq. 0) goto 420 8397 zelu = zero 8398 zeld = zero 8399 if (indd(i) .ne. 0) then 8400 noi = no(indd(i)) 8401 zeld = zo(indd(i)) 8402 endif 8403 if (indu(i) .ne. 0) then 8404 noi = no(indu(i)) 8405 zelu = zo(indu(i)) 8406 endif 8407 zelt = zeld + zelu 8408 if (ispp .ne. 's') then 8409 write(ititle(2*i-1),400) noi,il(i),zelt 8410 write(ititle(2*i),401)ispp,rc(i) 8411 400 format(' ',i1,a1,'(',f5.2,')') 8412 401 format(a1,' rc=',f5.2) 8413 else 8414 write(ititle(2*i-1),410) noi,il(i),zeld 8415 write(ititle(2*i),411)zelu,ispp,rc(i) 8416 410 format(i1,a1,' (',f4.2,',') 8417 411 format(f4.2,')',a1,f4.2) 8418 endif 8419 420 continue 8420c 8421c Construct relativistic sum and difference potentials. 8422c 8423 if (ispp .eq. 'r') then 8424 if (indu(1) .eq. 0) goto 429 8425 indd(1)=indu(1) 8426 indu(1)=0 8427 do 428 j=2,nr 8428 viod(1,j) = viou(1,j) 8429 viou(1,j) = zero 8430 428 continue 8431 429 do 431 i=2,lmax 8432 if (indd(i) .eq. 0 .or. indu(i) .eq. 0) goto 431 8433 do 430 j=2,nr 8434 viodj = viod(i,j) 8435 viouj = viou(i,j) 8436 viod(i,j) = ((i-1)*viodj + i*viouj) / (2*i-1) 8437 viou(i,j) = 2 * (viouj - viodj) / (2*i-1) 8438 430 continue 8439 431 continue 8440 endif 8441c 8442c Determine the number of potentials. Coded them as 8443c two digits, where the first digit is the number 8444c of down or sum potentials and the second the number of 8445c up or difference potentials. 8446c 8447 npotd = 0 8448 npotu = 0 8449 do 450 i=1,lmax 8450 if (indd(i) .ne. 0) npotd=npotd+1 8451 if (indu(i) .ne. 0) npotu=npotu+1 8452 450 continue 8453c 8454c Write the heading to the current pseudo.dat 8455c file (unit=1). 8456c 8457 ifull = 0 8458 if (cfac .le. zero .or. zratio .eq. zero) ifull = 1 8459 if (ifcore .eq. 1) then 8460 if (ifull .eq. 0) then 8461 nicore = 'pcec' 8462 else 8463 nicore = 'fcec' 8464 endif 8465 elseif (ifcore .eq. 2) then 8466 if (ifull .eq. 0) then 8467 nicore = 'pche' 8468 else 8469 nicore = 'fche' 8470 endif 8471 else 8472 nicore = 'nc ' 8473 endif 8474 if (ispp .eq. 's') then 8475 irel='isp' 8476 elseif (ispp .eq. 'r') then 8477 irel='rel' 8478 else 8479 irel = 'nrl' 8480 endif 8481 rewind 1 8482 write(1) nameat,icorr,irel,nicore,(iray(i),i=1,6), 8483 1 (ititle(i),i=1,7),npotd,npotu,nr-1,a,b,zion 8484 write(1) (r(i),i=2,nr) 8485c 8486c Write the potentials to the current pseudo.dat 8487c file (unit=1). 8488c 8489 do 460 i=1,lmax 8490 if (indd(i) .eq. 0) goto 460 8491 write(1) i-1,(viod(i,j),j=2,nr) 8492 460 continue 8493 do 465 i=1,lmax 8494 if (indu(i) .eq. 0) goto 465 8495 write(1) i-1,(viou(i,j),j=2,nr) 8496 465 continue 8497c 8498c Write the charge densities to the current pseudo.dat 8499c file (unit=1). 8500c 8501 if (ifcore .eq. 0) then 8502 write(1) (zero,i=2,nr) 8503 else 8504 write(1) (cdc(i),i=2,nr) 8505 endif 8506 write(1) (zratio*(cdd(i)+cdu(i)),i=2,nr) 8507c 8508 return 8509 end 8510C 8511C 8512C 8513 subroutine rtbis2(x1,x2,rc1,rc2,rc3,rc4,rc5,rc6,rc7, 8514 1 rc8,lp,arc,brc,vrc,vap,vapp,ev,cdrc,r,rab,jrc,delta, 8515 2 gamma,alpha,alpha1,alpha2,alpha3,alpha4,ar) 8516c 8517c ************************************************************* 8518c * njtj 8519c * Finds the value of gamma for the v"(0)=0 criteria. 8520c * The method used is bisection. This routine 8521c * was taken from Numerical Recipes, page 247. 8522c * njtj 8523c ************************************************************* 8524c 8525c njtj 8526c ### Cray conversions 8527c ### 1)Comment out the implicit double precision. 8528c ### 2)Switch double precision parameter 8529c ### to single precision parameter statement. 8530c ### Cray conversions 8531c njtj 8532c 8533 implicit double precision (a-h,o-z) 8534c 8535 parameter (jmax=80,pfive=0.5D0,zero=0.D0,xacc=1.D-10) 8536Cray parameter (jmax=80,pfive=0.5,zero=0.0,xacc=1.E-10) 8537c 8538 dimension r(jrc),rab(jrc),ar(jrc) 8539c 8540 call gamfn2(rc1,rc2,rc3,rc4,rc5,rc6,rc7,rc8,lp, 8541 1 arc,brc,vrc,vap,vapp,ev,cdrc,r,rab,jrc,delta,x1, 8542 2 alpha,alpha1,alpha2,alpha3,alpha4,f,ar) 8543 call gamfn2(rc1,rc2,rc3,rc4,rc5,rc6,rc7,rc8,lp, 8544 1 arc,brc,vrc,vap,vapp,ev,cdrc,r,rab,jrc,delta,x2, 8545 2 alpha,alpha1,alpha2,alpha3,alpha4,fmid,ar) 8546 if(f*fmid.ge.zero) then 8547 write(6,4000) 8548 call ext(840+lp) 8549 endif 8550 if(f.lt.zero)then 8551 gamma=x1 8552 dx=x2-x1 8553 else 8554 gamma=x2 8555 dx=x1-x2 8556 endif 8557 do 11 j=1,jmax 8558 dx=dx*pfive 8559 xmid=gamma+dx 8560 call gamfn2(rc1,rc2,rc3,rc4,rc5,rc6,rc7,rc8,lp, 8561 1 arc,brc,vrc,vap,vapp,ev,cdrc,r,rab,jrc,delta, 8562 2 xmid,alpha,alpha1,alpha2,alpha3,alpha4,fmid,ar) 8563 if(fmid.lt.zero)gamma=xmid 8564 if(abs(dx).lt.xacc .or. fmid.eq. zero) return 856511 continue 8566 write(6,4001) 8567 call ext(850+lp) 8568 4000 format(' error in bisection method(rtbistk)', 8569 1 ' - root must be bracketed.', 8570 2 /,'a b o r t i n g p r o g r a m') 8571 4001 format(' error in bisection method(rtbistk)', 8572 1 ' - too many bisections used', 8573 2 /,'a b o r t i n g p r o g r a m') 8574 end 8575C 8576C 8577C 8578 subroutine rtbist(x1,x2,rc1,rc2,rc3,rc4,rc5,rc6,rc7, 8579 1 rc8,lp,arc,brc,vrc,vap,vapp,ev,cdrc,r,rab,jrc,delta, 8580 2 gamma,alpha,alpha1,alpha2,alpha3,alpha4,ar) 8581c 8582c ************************************************************* 8583c * njtj 8584c * Finds the value of gamma for the v"(0)=0 criteria. 8585c * The method used is bisection. This routine 8586c * was taken from Numerical Recipes, page 247. 8587c * njtj 8588c ************************************************************* 8589c 8590c njtj 8591c ### Cray conversions 8592c ### 1)Comment out the implicit double precision. 8593c ### 2)Switch double precision parameter 8594c ### to single precision parameter statement. 8595c ### Cray conversions 8596c njtj 8597c 8598 implicit double precision (a-h,o-z) 8599c 8600 parameter (jmax=80,pfive=0.5D0,zero=0.D0,xacc=1.D-10) 8601Cray parameter (jmax=80,pfive=0.5,zero=0.0,xacc=1.E-10) 8602c 8603 dimension r(jrc),rab(jrc),ar(jrc) 8604c 8605 call gamfnd(rc1,rc2,rc3,rc4,rc5,rc6,rc7,rc8,lp, 8606 1 arc,brc,vrc,vap,vapp,ev,cdrc,r,rab,jrc,delta,x1, 8607 2 alpha,alpha1,alpha2,alpha3,alpha4,f,ar) 8608 call gamfnd(rc1,rc2,rc3,rc4,rc5,rc6,rc7,rc8,lp, 8609 1 arc,brc,vrc,vap,vapp,ev,cdrc,r,rab,jrc,delta,x2, 8610 2 alpha,alpha1,alpha2,alpha3,alpha4,fmid,ar) 8611 if(f*fmid.ge.zero) then 8612 write(6,4000) 8613 call ext(840+lp) 8614 endif 8615 if(f.lt.zero)then 8616 gamma=x1 8617 dx=x2-x1 8618 else 8619 gamma=x2 8620 dx=x1-x2 8621 endif 8622 do 11 j=1,jmax 8623 dx=dx*pfive 8624 xmid=gamma+dx 8625 call gamfnd(rc1,rc2,rc3,rc4,rc5,rc6,rc7,rc8,lp, 8626 1 arc,brc,vrc,vap,vapp,ev,cdrc,r,rab,jrc,delta, 8627 2 xmid,alpha,alpha1,alpha2,alpha3,alpha4,fmid,ar) 8628 if(fmid.lt.zero)gamma=xmid 8629 if(abs(dx).lt.xacc .or. fmid.eq. zero) return 863011 continue 8631 write(6,4001) 8632 call ext(850+lp) 8633 4000 format(' error in bisection method(rtbistk)', 8634 1 ' - root must be bracketed.', 8635 2 /,'a b o r t i n g p r o g r a m') 8636 4001 format(' error in bisection method(rtbistk)', 8637 1 ' - too many bisections used', 8638 2 /,'a b o r t i n g p r o g r a m') 8639 end 8640C 8641C 8642C 8643 DOUBLE PRECISION FUNCTION SBESSJ(N,X) 8644 implicit double precision(a-h, o-z) 8645 PARAMETER(ONE=1.D0,TWO=2.D0,THREE=3.D0,ZERO=0.D0) 8646 PARAMETER( FIVE = 5.0D0 , TEN = 10.0D0 , FOURTN = 14.0D0 ) 8647C SPHERICAL BESSEL FUNCTION OF THE FIRST KIND 8648C 8649 8650 IF(ABS(X) .GT. 0.001) THEN 8651 SB0 = SIN(X)/X 8652 ELSE 8653 X2 = X*X/TWO 8654 SB0 = ONE - (X2/THREE)*(ONE - X2/TEN) 8655 ENDIF 8656 IF(N .EQ. 0) THEN 8657 SBESSJ = SB0 8658 ELSE 8659 IF(ABS(X) .GT. 0.001) THEN 8660 SB1 = (SIN(X)/X - COS(X)) / X 8661 ELSE 8662 X2 = X*X/TWO 8663 SB1 = (X/THREE)*(ONE - (X2/FIVE)*(1.0 - X2/FOURTN)) 8664 ENDIF 8665 IF(N .EQ. 1) THEN 8666 SBESSJ = SB1 8667 ELSEIF(X .EQ. ZERO) THEN 8668 SBESSJ = ZERO 8669 ELSE 8670 BY = SB1 8671 BYM = SB0 8672 UX = ONE / X 8673 DO 10 J=1,N-1 8674 BYP = REAL(2*J+1)*UX*BY - BYM 8675 BYM = BY 8676 BY = BYP 8677 10 CONTINUE 8678 SBESSJ = BY 8679 ENDIF 8680 ENDIF 8681 RETURN 8682 END 8683 8684 SUBROUTINE SPLIFT (X,Y,YP,YPP,N,W,IERR,ISX,A1,B1,AN,BN) 8685C 8686 implicit double precision(a-h,o-z) 8687 8688 PARAMETER (FOUR=4.D0) 8689CRAY PARAMETER (FOUR=4.0) 8690C 8691C NJTJ 8692C ### CRAY CONVERSIONS 8693C ### 1)Comment out the implicit double precision. 8694C ### 2)Switch double precision parameter 8695C ### to single precision parameter 8696C ### CRAY CONVERSIONS 8697C NJTJ 8698C 8699C SANDIA MATHEMATICAL PROGRAM LIBRARY 8700C APPLIED MATHEMATICS DIVISION 2613 8701C SANDIA LABORATORIES 8702C ALBUQUERQUE, NEW MEXICO 87185 8703C CONTROL DATA 6600/7600 VERSION 7.2 MAY 1978 8704C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 8705C ISSUED BY SANDIA LABORATORIES 8706C * A PRIME CONTRACTOR TO THE 8707C * UNITED STATES DEPARTMENT OF ENERGY 8708C * * * * * * * * * * * * * * * NOTICE * * * * * * * * * * * * * * * 8709C * THIS REPORT WAS PREPARED AS AN ACCOUNT OF WORK SPONSORED BY THE 8710C * UNITED STATES GOVERNMENT. NEITHER THE UNITED STATES NOR THE 8711C * UNITED STATES DEPARTMENT OF ENERGY NOR ANY OF THEIR EMPLOYEES, 8712C * NOR ANY OF THEIR CONTRACTORS, SUBCONTRACTORS, OR THEIR EMPLOYEES 8713C * MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR ASSUMES ANY LEGAL 8714C * LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, COMPLETENESS OR 8715C * USEFULNESS OF ANY INFORMATION, APPARATUS, PRODUCT OR PROCESS 8716C * DISCLOSED, OR REPRESENTS THAT ITS USE WOULD NOT INFRINGE 8717C * OWNED RIGHTS. 8718C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 8719C * THE PRIMARY DOCUMENT FOR THE LIBRARY OF WHICH THIS ROUTINE IS 8720C * PART IS SAND77-1441. 8721C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 8722C 8723C WRITTEN BY RONDALL E. JONES 8724C 8725C ABSTRACT 8726C SPLIFT FITS AN INTERPOLATING CUBIC SPLINE TO THE N DATA POINT 8727C GIVEN IN X AND Y AND RETURNS THE FIRST AND SECOND DERIVATIVES 8728C IN YP AND YPP. THE RESULTING SPLINE (DEFINED BY X, Y, AND 8729C YPP) AND ITS FIRST AND SECOND DERIVATIVES MAY THEN BE 8730C EVALUATED USING SPLINT. THE SPLINE MAY BE INTEGRATED USING 8731C SPLIQ. FOR A SMOOTHING SPLINE FIT SEE SUBROUTINE SMOO. 8732C 8733C DESCRIPTION OF ARGUMENTS 8734C THE USER MUST DIMENSION ALL ARRAYS APPEARING IN THE CALL LIST 8735C E.G. X(N), Y(N), YP(N), YPP(N), W(3N) 8736C 8737C --INPUT-- 8738C 8739C X - ARRAY OF ABSCISSAS OF DATA (IN INCREASING ORDER) 8740C Y - ARRAY OF ORDINATES OF DATA 8741C N - THE NUMBER OF DATA POINTS. THE ARRAYS X, Y, YP, AND 8742C YPP MUST BE DIMENSIONED AT LEAST N. (N .GE. 4) 8743C ISX - MUST BE ZERO ON THE INITIAL CALL TO SPLIFT. 8744C IF A SPLINE IS TO BE FITTED TO A SECOND SET OF DATA 8745C THAT HAS THE SAME SET OF ABSCISSAS AS A PREVIOUS SET, 8746C AND IF THE CONTENTS OF W HAVE NOT BEEN CHANGED SINCE 8747C THAT PREVIOUS FIT WAS COMPUTED, THEN ISX MAY BE 8748C SET TO ONE FOR FASTER EXECUTION. 8749C A1,B1,AN,BN - SPECIFY THE END CONDITIONS FOR THE SPLINE WHICH 8750C ARE EXPRESSED AS CONSTRAINTS ON THE SECOND DERIVATIVE 8751C OF THE SPLINE AT THE END POINTS (SEE YPP). 8752C THE END CONDITION CONSTRAINTS ARE 8753C YPP(1) = A1*YPP(2) + B1 8754C AND 8755C YPP(N) = AN*YPP(N-1) + BN 8756C WHERE 8757C ABS(A1).LT. 1.0 AND ABS(AN).LT. 1.0. 8758C 8759C THE SMOOTHEST SPLINE (I.E., LEAST INTEGRAL OF SQUARE 8760C OF SECOND DERIVATIVE) IS OBTAINED BY A1=B1=AN=BN=0. 8761C IN THIS CASE THERE IS AN INFLECTION AT X(1) AND X(N). 8762C IF THE DATA IS TO BE EXTRAPOLATED (SAY, BY USING SPLIN 8763C TO EVALUATE THE SPLINE OUTSIDE THE RANGE X(1) TO X(N)) 8764C THEN TAKING A1=AN=0.5 AND B1=BN=0 MAY YIELD BETTER 8765C RESULTS. IN THIS CASE THERE IS AN INFLECTION 8766C AT X(1) - (X(2)-X(1)) AND AT X(N) + (X(N)-X(N-1)). 8767C IN THE MORE GENERAL CASE OF A1=AN=A AND B1=BN=0, 8768C THERE IS AN INFLECTION AT X(1) - (X(2)-X(1))*A/(1.0-A) 8769C AND AT X(N) + (X(N)-X(N-1))*A/(1.0-A). 8770C 8771C A SPLINE THAT HAS A GIVEN FIRST DERIVATIVE YP1 AT X(1) 8772C AND YPN AT Y(N) MAY BE DEFINED BY USING THE 8773C FOLLOWING CONDITIONS. 8774C 8775C A1=-0.5 8776C 8777C B1= 3.0*((Y(2)-Y(1))/(X(2)-X(1))-YP1)/(X(2)-X(1)) 8778C 8779C AN=-0.5 8780C 8781C BN=-3.0*((Y(N)-Y(N-1))/(X(N)-X(N-1))-YPN)/(X(N)-X(N-1) 8782C 8783C --OUTPUT-- 8784C 8785C YP - ARRAY OF FIRST DERIVATIVES OF SPLINE (AT THE X(I)) 8786C YPP - ARRAY OF SECOND DERIVATIVES OF SPLINE (AT THE X(I)) 8787C IERR - A STATUS CODE 8788C --NORMAL CODE 8789C 1 MEANS THAT THE REQUESTED SPLINE WAS COMPUTED. 8790C --ABNORMAL CODES 8791C 2 MEANS THAT N, THE NUMBER OF POINTS, WAS .LT. 4. 8792C 3 MEANS THE ABSCISSAS WERE NOT STRICTLY INCREASING. 8793C 8794C --WORK-- 8795C 8796C W - ARRAY OF WORKING STORAGE DIMENSIONED AT LEAST 3N. 8797 DIMENSION X(N),Y(N),YP(N),YPP(N),W(N,3) 8798C 8799 IF (N.LT.4) THEN 8800 IERR = 2 8801 RETURN 8802 ENDIF 8803 NM1 = N-1 8804 NM2 = N-2 8805 IF (ISX.GT.0) GO TO 40 8806 DO 5 I=2,N 8807 IF (X(I)-X(I-1) .LE. 0) THEN 8808 IERR = 3 8809 RETURN 8810 ENDIF 8811 5 CONTINUE 8812C 8813C DEFINE THE TRIDIAGONAL MATRIX 8814C 8815 W(1,3) = X(2)-X(1) 8816 DO 10 I=2,NM1 8817 W(I,2) = W(I-1,3) 8818 W(I,3) = X(I+1)-X(I) 8819 10 W(I,1) = 2*(W(I,2)+W(I,3)) 8820 W(1,1) = FOUR 8821 W(1,3) =-4*A1 8822 W(N,1) = FOUR 8823 W(N,2) =-4*AN 8824C 8825C L U DECOMPOSITION 8826C 8827 DO 30 I=2,N 8828 W(I-1,3) = W(I-1,3)/W(I-1,1) 8829 30 W(I,1) = W(I,1) - W(I,2)*W(I-1,3) 8830C 8831C DEFINE *CONSTANT* VECTOR 8832C 8833 40 YPP(1) = 4*B1 8834 DOLD = (Y(2)-Y(1))/W(2,2) 8835 DO 50 I=2,NM2 8836 DNEW = (Y(I+1) - Y(I))/W(I+1,2) 8837 YPP(I) = 6*(DNEW - DOLD) 8838 YP(I) = DOLD 8839 50 DOLD = DNEW 8840 DNEW = (Y(N)-Y(N-1))/(X(N)-X(N-1)) 8841 YPP(NM1) = 6*(DNEW - DOLD) 8842 YPP(N) = 4*BN 8843 YP(NM1)= DOLD 8844 YP(N) = DNEW 8845C 8846C FORWARD SUBSTITUTION 8847C 8848 YPP(1) = YPP(1)/W(1,1) 8849 DO 60 I=2,N 8850 60 YPP(I) = (YPP(I) - W(I,2)*YPP(I-1))/W(I,1) 8851C 8852C BACKWARD SUBSTITUTION 8853C 8854 DO 70 J=1,NM1 8855 I = N-J 8856 70 YPP(I) = YPP(I) - W(I,3)*YPP(I+1) 8857C 8858C COMPUTE FIRST DERIVATIVES 8859C 8860 YP(1) = (Y(2)-Y(1))/(X(2)-X(1)) - (X(2)-X(1))*(2*YPP(1) 8861 1 + YPP(2))/6 8862 DO 80 I=2,NM1 8863 80 YP(I) = YP(I) + W(I,2)*(YPP(I-1) + 2*YPP(I))/6 8864 YP(N) = YP(N) + (X(N)-X(NM1))*(YPP(NM1) + 2*YPP(N))/6 8865C 8866 IERR = 1 8867 RETURN 8868 END 8869C 8870C 8871C 8872 SUBROUTINE SPLINT (X,Y,YPP,N,XI,YI,YPI,YPPI,NI,KERR) 8873 implicit double precision (a-h,o-z) 8874C 8875C SANDIA MATHEMATICAL PROGRAM LIBRARY 8876C APPLIED MATHEMATICS DIVISION 2613 8877C SANDIA LABORATORIES 8878C ALBUQUERQUE, NEW MEXICO 87185 8879C CONTROL DATA 6600/7600 VERSION 7.2 MAY 1978 8880C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 8881C ISSUED BY SANDIA LABORATORIES 8882C * A PRIME CONTRACTOR TO THE 8883C * UNITED STATES DEPARTMENT OF ENERGY 8884C * * * * * * * * * * * * * * * NOTICE * * * * * * * * * * * * * * * 8885C * THIS REPORT WAS PREPARED AS AN ACCOUNT OF WORK SPONSORED BY THE 8886C * UNITED STATES GOVERNMENT. NEITHER THE UNITED STATES NOR THE 8887C * UNITED STATES DEPARTMENT OF ENERGY NOR ANY OF THEIR EMPLOYEES, 8888C * NOR ANY OF THEIR CONTRACTORS, SUBCONTRACTORS, OR THEIR EMPLOYEES 8889C * MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR ASSUMES ANY LEGAL 8890C * LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, COMPLETENESS OR 8891C * USEFULNESS OF ANY INFORMATION, APPARATUS, PRODUCT OR PROCESS 8892C * DISCLOSED, OR REPRESENTS THAT ITS USE WOULD NOT INFRINGE 8893C * OWNED RIGHTS. 8894C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 8895C * THE PRIMARY DOCUMENT FOR THE LIBRARY OF WHICH THIS ROUTINE IS 8896C * PART IS SAND77-1441. 8897C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 8898C 8899C WRITTEN BY RONDALL E. JONES 8900C 8901C ABSTRACT 8902C 8903C SPLINT EVALUATES A CUBIC SPLINE AND ITS FIRST AND SECOND 8904C DERIVATIVES AT THE ABSCISSAS IN XI. THE SPLINE (WHICH 8905C IS DEFINED BY X, Y, AND YPP) MAY HAVE BEEN DETERMINED BY 8906C SPLIFT OR SMOO OR ANY OTHER SPLINE FITTING ROUTINE THAT 8907C PROVIDES SECOND DERIVATIVES. 8908C 8909C DESCRIPTION OF ARGUMENTS 8910C THE USER MUST DIMENSION ALL ARRAYS APPEARING IN THE CALL LIST 8911C E.G. X(N), Y(N), YPP(N), XI(NI), YI(NI), YPI(NI), YPPI(NI) 8912C 8913C --INPUT-- 8914C 8915C X - ARRAY OF ABSCISSAS (IN INCREASING ORDER) THAT DEFINE TH 8916C SPLINE. USUALLY X IS THE SAME AS X IN SPLIFT OR SMOO. 8917C Y - ARRAY OF ORDINATES THAT DEFINE THE SPLINE. USUALLY Y I 8918C THE SAME AS Y IN SPLIFT OR AS R IN SMOO. 8919C YPP - ARRAY OF SECOND DERIVATIVES THAT DEFINE THE SPLINE. 8920C USUALLY YPP IS THE SAME AS YPP IN SPLIFT OR R2 IN SMOO. 8921C N - THE NUMBER OF DATA POINTS THAT DEFINE THE SPLINE. 8922C THE ARRAYS X, Y, AND YPP MUST BE DIMENSIONED AT LEAST N 8923C N MUST BE GREATER THAN OR EQUAL TO 2. 8924C XI - THE ABSCISSA OR ARRAY OF ABSCISSAS (IN ARBITRARY ORDER) 8925C AT WHICH THE SPLINE IS TO BE EVALUATED. 8926C EACH XI(K) THAT LIES BETWEEN X(1) AND X(N) IS A CASE OF 8927C INTERPOLATION. EACH XI(K) THAT DOES NOT LIE BETWEEN 8928C X(1) AND X(N) IS A CASE OF EXTRAPOLATION. BOTH CASES 8929C ARE ALLOWED. SEE DESCRIPTION OF KERR. 8930C NI - THE NUMBER OF ABSCISSAS AT WHICH THE SPLINE IS TO BE 8931C EVALUATED. IF NI IS GREATER THAN 1, THEN XI, YI, YPI, 8932C AND YPPI MUST BE ARRAYS DIMENSIONED AT LEAST NI. 8933C NI MUST BE GREATER THAN OR EQUAL TO 1. 8934C 8935C --OUTPUT-- 8936C 8937C YI - ARRAY OF VALUES OF THE SPLINE (ORDINATES) AT XI. 8938C YPI - ARRAY OF VALUES OF THE FIRST DERIVATIVE OF SPLINE AT XI 8939C YPPI- ARRAY OF VALUES OF SECOND DERIVATIVES OF SPLINE AT XI. 8940C KERR- A STATUS CODE 8941C --NORMAL CODES 8942C 1 MEANS THAT THE SPLINE WAS EVALUATED AT EACH ABSCISSA 8943C IN XI USING ONLY INTERPOLATION. 8944C 2 MEANS THAT THE SPLINE WAS EVALUATED AT EACH ABSCISSA 8945C IN XI, BUT AT LEAST ONE EXTRAPOLATION WAS PERFORMED. 8946C -- ABNORMAL CODE 8947C 3 MEANS THAT THE REQUESTED NUMBER OF EVALUATIONS, NI, 8948C WAS NOT POSITIVE. 8949C 8950 DIMENSION X(N),Y(N),YPP(N),XI(NI),YI(NI),YPI(NI),YPPI(NI) 8951C 8952C CHECK INPUT 8953C 8954 IF (NI) 1,1,2 8955 1 CONTINUE 8956C 1 CALL ERRCHK(67,67HIN SPLINT, THE REQUESTED NUMBER OF INTERPOLATI 8957C 1NS WAS NOT POSITIVE) 8958 KERR = 3 8959 RETURN 8960 2 KERR = 1 8961 NM1= N-1 8962C 8963C K IS INDEX ON VALUE OF XI BEING WORKED ON. XX IS THAT VALUE. 8964C I IS CURRENT INDEX INTO X ARRAY. 8965C 8966 K = 1 8967 XX = XI(1) 8968 IF (XX.LT.X(1)) GO TO 90 8969 IF (XX.GT.X(N)) GO TO 80 8970 IL = 1 8971 IR = N 8972C 8973C BISECTION SEARCH 8974C 8975 10 I = (IL+IR)/2 8976 IF (I.EQ.IL) GO TO 100 8977 IF (XX-X(I)) 20,100,30 8978 20 IR = I 8979 GO TO 10 8980 30 IL = I 8981 GO TO 10 8982C 8983C LINEAR FORWARD SEARCH 8984C 8985 50 IF (XX-X(I+1)) 100,100,60 8986 60 IF (I.GE.NM1) GO TO 80 8987 I = I+1 8988 GO TO 50 8989C 8990C EXTRAPOLATION 8991C 8992 80 KERR = 2 8993 I = NM1 8994 GO TO 100 8995 90 KERR = 2 8996 I = 1 8997C 8998C INTERPOLATION 8999C 9000 100 H = X(I+1) - X(I) 9001 H2 = H*H 9002 XR = (X(I+1)-XX)/H 9003 XR2= XR*XR 9004 XR3= XR*XR2 9005 XL = (XX-X(I))/H 9006 XL2= XL*XL 9007 XL3= XL*XL2 9008 YI(K) = Y(I)*XR + Y(I+1)*XL 9009 1 -H2*(YPP(I)*(XR-XR3) + YPP(I+1)*(XL-XL3))/6.0D0 9010 YPI(K) = (Y(I+1)-Y(I))/H 9011 1 +H*(YPP(I)*(1.0D0-3.0D0*XR2)-YPP(I+1)*(1.0D0-3.0D0*XL2))/6.0D0 9012 YPPI(K) = YPP(I)*XR + YPP(I+1)*XL 9013C 9014C NEXT POINT 9015C 9016 IF (K.GE.NI) RETURN 9017 K = K+1 9018 XX = XI(K) 9019 IF (XX.LT.X(1)) GO TO 90 9020 IF (XX.GT.X(N)) GO TO 80 9021 IF (XX-XI(K-1)) 110,100,50 9022 110 IL = 1 9023 IR = I+1 9024 GO TO 10 9025C 9026 END 9027 SUBROUTINE SPLIQ(X,Y,YP,YPP,N,XLO,XUP,NUP,ANS,IERR) 9028C 9029C 9030C NJTJ 9031C ### CRAY CONVERSIONS 9032C ### 1)Comment out implicit double precision. 9033C ### CRAY CONVERSIONS 9034C NJTJ 9035C 9036 implicit double precision (a-h,o-z) 9037 DIMENSION X(N),Y(N),YP(N),YPP(N),XUP(NUP),ANS(NUP) 9038C 9039C SANDIA MATHEMATICAL PROGRAM LIBRARY 9040C APPLIED MATHEMATICS DIVISION 2613 9041C SANDIA LABORATORIES 9042C ALBUQUERQUE, NEW MEXICO 87185 9043C CONTROL DATA 6600/7600 VERSION 7.2 MAY 1978 9044C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 9045C ISSUED BY SANDIA LABORATORIES 9046C * A PRIME CONTRACTOR TO THE 9047C * UNITED STATES DEPARTMENT OF ENERGY 9048C * * * * * * * * * * * * * * * NOTICE * * * * * * * * * * * * * * * 9049C * THIS REPORT WAS PREPARED AS AN ACCOUNT OF WORK SPONSORED BY THE 9050C * UNITED STATES GOVERNMENT. NEITHER THE UNITED STATES NOR THE 9051C * UNITED STATES DEPARTMENT OF ENERGY NOR ANY OF THEIR EMPLOYEES, 9052C * NOR ANY OF THEIR CONTRACTORS, SUBCONTRACTORS, OR THEIR EMPLOYEES 9053C * MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR ASSUMES ANY LEGAL 9054C * LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, COMPLETENESS OR 9055C * USEFULNESS OF ANY INFORMATION, APPARATUS, PRODUCT OR PROCESS 9056C * DISCLOSED, OR REPRESENTS THAT ITS USE WOULD NOT INFRINGE 9057C * OWNED RIGHTS. 9058C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 9059C * THE PRIMARY DOCUMENT FOR THE LIBRARY OF WHICH THIS ROUTINE IS 9060C * PART IS SAND77-1441. 9061C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 9062C 9063C THIS ROUTINE WAS WRITTEN BY M. K. GORDON 9064C 9065C ABSTRACT 9066C 9067C SUBROUTINE SPLIQ INTEGRATES A CUBIC SPLINE (GENERATED BY 9068C SPLIFT, SMOO, ETC.) ON THE INTERVALS (XLO,XUP(I)), WHERE XUP 9069C IS A SEQUENCE OF UPPER LIMITS ON THE INTERVALS OF INTEGRATION. 9070C THE ONLY RESTRICTIONS ON XLO AND XUP(*) ARE 9071C XLO .LT. XUP(1), 9072C XUP(I) .LE. XUP(I+1) FOR EACH I . 9073C ENDPOINTS BEYOND THE SPAN OF ABSCISSAS ARE ALLOWED. 9074C THE SPLINE OVER THE INTERVAL (X(I),X(I+1)) IS REGARDED 9075C AS A CUBIC POLYNOMIAL EXPANDED ABOUT X(I) AND IS INTEGRATED 9076C ANALYTICALLY. 9077C 9078C DESCRIPTION OF ARGUMENTS 9079C THE USER MUST DIMENSION ALL ARRAYS APPEARING IN THE CALL LIST 9080C E.G. X(N), Y(N), YP(N), YPP(N), XUP(NUP), ANS(NUP) 9081C 9082C --INPUT-- 9083C 9084C X - ARRAY OF ABSCISSAS (IN INCREASING ORDER) THAT DEFINE TH 9085C SPLINE. USUALLY X IS THE SAME AS X IN SPLIFT OR SMOO. 9086C Y - ARRAY OF ORDINATES THAT DEFINE THE SPLINE. USUALLY Y I 9087C THE SAME AS Y IN SPLIFT OR AS R IN SMOO. 9088C YP - ARRAY OF FIRST DERIVATIVES OF THE SPLINE AT ABSCISSAS. 9089C USUALLY YP IS THE SAME AS YP IN SPLIFT OR R1 IN SMOO. 9090C YPP - ARRAY OF SECOND DERIVATIVES THAT DEFINE THE SPLINE. 9091C USUALLY YPP IS THE SAME AS YPP IN SPLIFT OR R2 IN SMOO. 9092C N - THE NUMBER OF DATA POINTS THAT DEFINE THE SPLINE. 9093C XLO - LEFT ENDPOINT OF INTEGRATION INTERVALS. 9094C XUP - RIGHT ENDPOINT OR ARRAY OF RIGHT ENDPOINTS OF 9095C INTEGRATION INTERVALS IN ASCENDING ORDER. 9096C NUP - THE NUMBER OF RIGHT ENDPOINTS. IF NUP IS GREATER THAN 9097C 1, THEN XUP AND ANS MUST BE DIMENSIONED AT LEAST NUP. 9098C 9099C --OUTPUT-- 9100C 9101C ANS -- ARRAY OF INTEGRAL VALUES, THAT IS, 9102C ANS(I) = INTEGRAL FROM XLO TO XUP(I) 9103C IERR -- ERROR STATUS 9104C = 1 INTEGRATION SUCCESSFUL 9105C = 2 IMPROPER INPUT - N.LT.4 OR NUP.LT.1 9106C = 3 IMPROPER INPUT - ABSCISSAS NOT IN 9107C STRICTLY ASCENDING ORDER 9108C = 4 IMPROPER INPUT - RIGHT ENDPOINTS XUP NOT 9109C IN ASCENDING ORDER 9110C = 5 IMPROPER INPUT - XLO.GT.XUP(1) 9111C = 6 INTEGRATION SUCCESSFUL BUT AT LEAST ONE ENDPOINT 9112C NOT WITHIN SPAN OF ABSCISSAS 9113C ** NOTE. ERRCHK PROCESSES DIAGNOSTICS FOR CODES 2,3,4,5 9114C 9115C CHECK FOR IMPROPER INPUT 9116C 9117 IERR = 2 9118 IF(N .LT. 4 .OR. NUP .LT. 1) THEN 9119 RETURN 9120 ENDIF 9121 NM1 = N-1 9122 NM2 = N-2 9123 IERR = 3 9124 DO 2 I = 1,NM1 9125 IF(X(I) .GE. X(I+1)) THEN 9126 RETURN 9127 ENDIF 9128 2 CONTINUE 9129 IF(NUP .NE. 1) THEN 9130 IERR = 4 9131 DO 3 I = 2,NUP 9132 IF(XUP(I-1) .GT. XUP(I)) THEN 9133 RETURN 9134 ENDIF 9135 3 CONTINUE 9136 ENDIF 9137 IERR = 5 9138 IF(XLO .GT. XUP(1)) THEN 9139 RETURN 9140 ENDIF 9141 IERR = 1 9142 IF(XLO .LT. X(1) .OR. XUP(NUP) .GT. X(N)) IERR = 6 9143C 9144C LOCATE XLO IN INTERVAL (X(I),X(I+1)) 9145C 9146 DO 10 I = 1,NM2 9147 IF(XLO .LT. X(I+1)) GO TO 20 9148 10 CONTINUE 9149 I = NM1 9150 20 HLO = XLO-X(I) 9151 HLO2 = HLO*HLO 9152 HI = X(I+1)-X(I) 9153 HI2 = HI*HI 9154 DO 30 J = 1,NUP 9155 IF(XUP(J) .GT. X(I+1) .AND. XLO .LT. X(NM1)) GO TO 40 9156C 9157C COMPUTE SPECIAL CASES OF XUP IN INTERVAL WITH XLO 9158C 9159 HUP = XUP(J)-X(I) 9160 HSUM = HUP+HLO 9161 HDIFF = HUP-HLO 9162 HUP2 = HUP*HUP 9163 SUM = (YPP(I+1)-YPP(I))*HSUM*HDIFF*(HUP2+HLO2)/(24*HI) 9164 SUM = SUM + YPP(I)*HDIFF*(HUP2+HLO*HUP+HLO2)/6 9165 SUM = SUM + YP(I)*HDIFF*HSUM/2 9166 SUM = SUM + Y(I)*HDIFF 9167 30 ANS(J) = SUM 9168 RETURN 9169C 9170C COMPUTE INTEGRAL BETWEEN XLO AND X(I+1) AS FOUR TERMS IN TAYLOR 9171C POLYNOMIAL AND ADVANCE I TO I+1 9172C 9173 40 HDIFF = HI-HLO 9174 HSUM = HI+HLO 9175 SUM0 = Y(I)*HDIFF 9176 SUM1 = YP(I)*HDIFF*HSUM 9177 SUM2 = YPP(I)*HDIFF*(HI2+HI*HLO+HLO2) 9178 SUM3 = (YPP(I+1)-YPP(I))*HDIFF*HSUM*(HI2+HLO2)/HI 9179 I = I+1 9180C 9181C LOCATE EACH XUP(M) IN INTERVAL (X(I),X(I+1)) 9182C 9183 DO 80 M = J,NUP 9184 50 IF(XUP(M) .LT. X(I+1) .OR. I .EQ. NM1) GO TO 60 9185C 9186C AUGMENT INTEGRAL BETWEEN ABSCISSAS TO INCLUDE INTERVAL 9187C (X(I),X(I+1)) AND ADVANCE I TO I+1 9188C 9189 HI = X(I+1)-X(I) 9190 HI2 = HI*HI 9191 HI3 = HI2*HI 9192 SUM0 = SUM0 + Y(I)*HI 9193 SUM1 = SUM1 + YP(I)*HI2 9194 SUM2 = SUM2 + YPP(I)*HI3 9195 SUM3 = SUM3 + (YPP(I+1)-YPP(I))*HI3 9196 I = I+1 9197 GO TO 50 9198C 9199C INTEGRAL BETWEEN X(I) AND XUP(M) IS ZERO 9200C 9201 60 IF(XUP(M) .NE. X(I)) THEN 9202C 9203C COMPUTE INTEGRAL BETWEEN X(I) AND XUP(M) AND EVALUATE 9204C TAYLOR POLYNOMIAL IN REVERSE ORDER 9205C 9206 HUP = XUP(M)-X(I) 9207 HUP2 = HUP*HUP 9208 HUP3 = HUP2*HUP 9209 HUP4 = HUP3*HUP 9210 HI = X(I+1)-X(I) 9211 PSUM0 = Y(I)*HUP 9212 PSUM1 = YP(I)*HUP2 9213 PSUM2 = YPP(I)*HUP3 9214 PSUM3 = (YPP(I+1)-YPP(I))*HUP4/HI 9215 SUM = (SUM3+PSUM3)/24 + (SUM2+PSUM2)/6 9216 SUM = SUM + (SUM1+PSUM1)/2 9217 SUM = SUM + (SUM0+PSUM0) 9218 ELSE 9219 SUM = ((SUM3/24 + SUM2/6) + SUM1/2) + SUM0 9220 ENDIF 9221 80 ANS(M) = SUM 9222 RETURN 9223 END 9224C 9225C 9226C 9227c 9228c ******************************************************** 9229c * * 9230c * njtj * 9231c * These are machine dependent routines. * 9232c * Included are routine for Apollo, Sun, * 9233c * Vax, and Cray systems. The user must * 9234c * 1)compile with their systems lines uncommented * 9235c * or 2)supply their own * 9236c * or 3)remove-comment out all references to * 9237c * these calls in the program. * 9238c * * 9239c ******************************************************** 9240c 9241c ****************Apollo start*********************** 9242c 9243C 9244C **************Cray start*********************** 9245C 9246Cray SUBROUTINE ZESEC(T) 9247C 9248C GETS CPU TIME IN SECONDS 9249C CRAY-2 VERSION 9250C 9251Cray T = SECOND() 9252Cray RETURN 9253Cray END 9254C 9255Cray SUBROUTINE ZEDATE(BDATE) 9256C 9257C GETS THE DATE (DAY-MONTH-YEAR) 9258C CRAY-2 VERSION 9259C 9260Cray CHARACTER*10 BDATE 9261Cray CHARACTER*8 ADATE 9262Cray CHARACTER*3 MONTH(12) 9263Cray CHARACTER*1 DASH,DUM1,DUM2 9264Cray DATA DASH/'-'/ 9265Cray DATA MONTH/'JAN','FEB','MAR','APR','MAY','JUN','JUL','AUG','SEP', 9266Cray 2 'OCT','NOV','DEC'/ 9267Cray 9268Cray WRITE(ADATE,100) DATE() 9269Cray READ(ADATE,101) LMONTH,DUM1,LDAY,DUM2,LYEAR 9270Cray WRITE(BDATE,102) LDAY,DASH,MONTH(LMONTH),DASH,LYEAR 9271Cray 100 FORMAT(A8) 9272Cray 101 FORMAT(I2,A1,I2,A1,I2) 9273Cray 102 FORMAT(I2,A1,A3,A1,I2,' ') 9274Cray RETURN 9275Cray END 9276C 9277C *****************Cray end*********************** 9278C 9279C *****************Vax start********************** 9280C 9281cVax SUBROUTINE ZESEC(T) 9282C 9283C CALCULATES THE ELAPSED CPU TIME SINCE 9284C THE FIRST CALL IN A VAX/VMS SYSTEM 9285C 9286cVax REAL*8 T 9287cVax COMMON/ZESEC/IFLAG 9288cVax DATA IFLAG /0/ 9289cVax IF(IFLAG.EQ.0) THEN 9290cVax CALL LIB$INIT_TIMER 9291cVax IFLAG=1 9292cVax T=0.0 9293cVax ELSE 9294cVax CALL LIB$STAT_TIMER(2,ITS) 9295cVax T=0.01*FLOAT(ITS) 9296cVax ENDIF 9297cVax RETURN 9298cVax END 9299C 9300cVax SUBROUTINE ZEDATE(BDATE) 9301C 9302C Gets the data (DAY-MONTH-YEAR) 9303C VAX version 9304C 9305cVax CHARACTER*10 BDATE 9306cVax CHARACTER*9 ADATE 9307cVax CALL DATE(ADATE) 9308cVax WRITE(BDATE,100) ADATE 9309cVax 100 FORMAT(A9,' ') 9310cVax RETURN 9311cVax END 9312C 9313C ********************Vax end*********************** 9314C 9315C ********************Sun start ******************** 9316C 9317 SUBROUTINE ZESEC(TBACK) 9318C 9319C GETS CPU TIME IN SECONDS 9320C Sun version 9321C 9322 REAL TARRAY(2) 9323 DOUBLE PRECISION TBACK 9324 T=ETIME(TARRAY) 9325 T=TARRAY(1) 9326 TBACK=T 9327 RETURN 9328 END 9329C 9330 SUBROUTINE ZEDATE(BDATE) 9331C 9332C GETS THE DATE (DAY-MONTH-YEAR) 9333C Sun version 9334C 9335 CHARACTER*1 BDATE(10) 9336 CHARACTER*1 LOCTIM(24) 9337 CALL FDATE(LOCTIM) 9338 DO 101 I = 11, 20 9339 II = I - 10 9340 BDATE(II) = LOCTIM(I) 9341101 CONTINUE 9342 RETURN 9343 END 9344C 9345C *****************Sun end ********************* 9346C 9347C 9348C 9349 SUBROUTINE TINVIT(NM,N,D,E,E2,M,W,IND,Z, 9350 X IERR,RV1,RV2,RV3,RV4,RV6) 9351C 9352c njtj 9353c ### Cray conversions 9354c ### 1)Switch double precision to real. 9355c ### 2)Switch double precision parameter 9356c ### to single precision parameter statement. 9357c ### Cray conversions 9358c njtj 9359C 9360 INTEGER I,J,M,N,P,Q,R,S,II,IP,JJ,NM,ITS,TAG,IERR,GROUP 9361 INTEGER IND(M) 9362 DOUBLE PRECISION D(N),E(N),E2(N),W(M),Z(NM,M), 9363 X RV1(N),RV2(N),RV3(N),RV4(N),RV6(N) 9364Cray REAL D(N),E(N),E2(N),W(M),Z(NM,M), 9365Cray X RV1(N),RV2(N),RV3(N),RV4(N),RV6(N) 9366 DOUBLE PRECISION U,V,UK,XU,X0,X1,EPS2,EPS3,EPS4, 9367 X NORM,ORDER,MACHEP 9368Cray REAL U,V,UK,XU,X0,X1,EPS2,EPS3,EPS4,NORM,ORDER,MACHEP 9369C 9370 PARAMETER(ZERO=0.D0,ONE=1.D0,ONEM3=1.D-3,TWO=2.D0) 9371Cray PARAMETER(ZERO=0.0,ONE=1.0,ONEM3=1.E-3,TWO=2.0) 9372C 9373C THIS SUBROUTINE IS A TRANSLATION OF THE INVERSE ITERATION TECH- 9374C NIQUE IN THE ALGOL PROCEDURE TRISTURM BY PETERS AND WILKINSON. 9375C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 418-439(1971). 9376C 9377C THIS SUBROUTINE FINDS THOSE EIGENVECTORS OF A TRIDIAGONAL 9378C SYMMETRIC MATRIX CORRESPONDING TO SPECIFIED EIGENVALUES, 9379C USING INVERSE ITERATION. 9380C 9381C ON INPUT- 9382C 9383C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL 9384C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM 9385C DIMENSION STATEMENT, 9386C 9387C N IS THE ORDER OF THE MATRIX, 9388C 9389C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX, 9390C 9391C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX 9392C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY, 9393C 9394C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E, 9395C WITH ZEROS CORRESPONDING TO NEGLIGIBLE ELEMENTS OF E. 9396C E(I) IS CONSIDERED NEGLIGIBLE IF IT IS NOT LARGER THAN 9397C THE PRODUCT OF THE RELATIVE MACHINE PRECISION AND THE SUM 9398C OF THE MAGNITUDES OF D(I) AND D(I-1). E2(1) MUST CONTAIN 9399C 0.0 IF THE EIGENVALUES ARE IN ASCENDING ORDER, OR 2.0 9400C IF THE EIGENVALUES ARE IN DESCENDING ORDER. IF BISECT, 9401C TRIDIB, OR IMTQLV HAS BEEN USED TO FIND THE EIGENVALUES, 9402C THEIR OUTPUT E2 ARRAY IS EXACTLY WHAT IS EXPECTED HERE, 9403C 9404C M IS THE NUMBER OF SPECIFIED EIGENVALUES, 9405C 9406C W CONTAINS THE M EIGENVALUES IN ASCENDING OR DESCENDING ORDER, 9407C 9408C IND CONTAINS IN ITS FIRST M POSITIONS THE SUBMATRIX INDICES 9409C ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W -- 9410C 1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX FROM 9411C THE TOP, 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC. 9412C 9413C ON OUTPUT- 9414C 9415C ALL INPUT ARRAYS ARE UNALTERED, 9416C 9417C Z CONTAINS THE ASSOCIATED SET OF ORTHONORMAL EIGENVECTORS. 9418C ANY VECTOR WHICH FAILS TO CONVERGE IS SET TO ZERO, 9419C 9420C IERR IS SET TO 9421C ZERO FOR NORMAL RETURN, 9422C -R IF THE EIGENVECTOR CORRESPONDING TO THE R-TH 9423C EIGENVALUE FAILS TO CONVERGE IN 5 ITERATIONS, 9424C 9425C RV1, RV2, RV3, RV4, AND RV6 ARE TEMPORARY STORAGE ARRAYS. 9426C 9427C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW, 9428C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY 9429C 9430C ------------------------------------------------------------------ 9431C 9432C ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING 9433C THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC. 9434C 9435C ********** 9436 MACHEP = TWO**(-40) 9437C 9438 IERR = 0 9439 IF (M .EQ. 0) GO TO 1001 9440 TAG = 0 9441 ORDER = ONE - E2(1) 9442 Q = 0 9443C ********** ESTABLISH AND PROCESS NEXT SUBMATRIX ********** 9444 100 P = Q + 1 9445C 9446 DO 120 Q = P, N 9447 IF (Q .EQ. N) GO TO 140 9448 IF (E2(Q+1) .EQ. ZERO) GO TO 140 9449 120 CONTINUE 9450C ********** FIND VECTORS BY INVERSE ITERATION ********** 9451 140 TAG = TAG + 1 9452 S = 0 9453C 9454 DO 920 R = 1, M 9455 IF (IND(R) .NE. TAG) GO TO 920 9456 ITS = 1 9457 X1 = W(R) 9458 IF (S .NE. 0) GO TO 510 9459C ********** CHECK FOR ISOLATED ROOT ********** 9460 XU = ONE 9461 IF (P .NE. Q) GO TO 490 9462 RV6(P) = ONE 9463 GO TO 870 9464 490 NORM = ABS(D(P)) 9465 IP = P + 1 9466C 9467 DO 500 I = IP, Q 9468 500 NORM = NORM + ABS(D(I)) + ABS(E(I)) 9469C ********** EPS2 IS THE CRITERION FOR GROUPING, 9470C EPS3 REPLACES ZERO PIVOTS AND EQUAL 9471C ROOTS ARE MODIFIED BY EPS3, 9472C EPS4 IS TAKEN VERY SMALL TO AVOID OVERFLOW ********** 9473 EPS2 = ONEM3 * NORM 9474 EPS3 = MACHEP * NORM 9475 UK = REAL(Q-P+1) 9476 EPS4 = UK * EPS3 9477 UK = EPS4 / SQRT(UK) 9478 S = P 9479 505 GROUP = 0 9480 GO TO 520 9481C ********** LOOK FOR CLOSE OR COINCIDENT ROOTS ********** 9482 510 IF (ABS(X1-X0) .GE. EPS2) GO TO 505 9483 GROUP = GROUP + 1 9484 IF (ORDER * (X1 - X0) .LE. ZERO) X1 = X0 + ORDER * EPS3 9485C ********** ELIMINATION WITH INTERCHANGES AND 9486C INITIALIZATION OF VECTOR ********** 9487 520 V = ZERO 9488C 9489 DO 580 I = P, Q 9490 RV6(I) = UK 9491 IF (I .EQ. P) GO TO 560 9492 IF (ABS(E(I)) .LT. ABS(U)) GO TO 540 9493C ********** WARNING -- A DIVIDE CHECK MAY OCCUR HERE IF 9494C E2 ARRAY HAS NOT BEEN SPECIFIED CORRECTLY ********** 9495 XU = U / E(I) 9496 RV4(I) = XU 9497 RV1(I-1) = E(I) 9498 RV2(I-1) = D(I) - X1 9499 RV3(I-1) = ZERO 9500 IF (I .NE. Q) RV3(I-1) = E(I+1) 9501 U = V - XU * RV2(I-1) 9502 V = -XU * RV3(I-1) 9503 GO TO 580 9504 540 XU = E(I) / U 9505 RV4(I) = XU 9506 RV1(I-1) = U 9507 RV2(I-1) = V 9508 RV3(I-1) = ZERO 9509 560 U = D(I) - X1 - XU * V 9510 IF (I .NE. Q) V = E(I+1) 9511 580 CONTINUE 9512C 9513 IF (U .EQ. ZERO) U = EPS3 9514 RV1(Q) = U 9515 RV2(Q) = ZERO 9516 RV3(Q) = ZERO 9517C ********** BACK SUBSTITUTION 9518C FOR I=Q STEP -1 UNTIL P DO -- ********** 9519 600 DO 620 II = P, Q 9520 I = P + Q - II 9521 RV6(I) = (RV6(I) - U * RV2(I) - V * RV3(I)) / RV1(I) 9522 V = U 9523 U = RV6(I) 9524 620 CONTINUE 9525C ********** ORTHOGONALIZE WITH RESPECT TO PREVIOUS 9526C MEMBERS OF GROUP ********** 9527 IF (GROUP .EQ. 0) GO TO 700 9528 J = R 9529C 9530 DO 680 JJ = 1, GROUP 9531 630 J = J - 1 9532 IF (IND(J) .NE. TAG) GO TO 630 9533 XU = ZERO 9534C 9535 DO 640 I = P, Q 9536 640 XU = XU + RV6(I) * Z(I,J) 9537C 9538 DO 660 I = P, Q 9539 660 RV6(I) = RV6(I) - XU * Z(I,J) 9540C 9541 680 CONTINUE 9542C 9543 700 NORM = ZERO 9544C 9545 DO 720 I = P, Q 9546 720 NORM = NORM + ABS(RV6(I)) 9547C 9548 IF (NORM .GE. ONE) GO TO 840 9549C ********** FORWARD SUBSTITUTION ********** 9550 IF (ITS .EQ. 5) GO TO 830 9551 IF (NORM .NE. ZERO) GO TO 740 9552 RV6(S) = EPS4 9553 S = S + 1 9554 IF (S .GT. Q) S = P 9555 GO TO 780 9556 740 XU = EPS4 / NORM 9557C 9558 DO 760 I = P, Q 9559 760 RV6(I) = RV6(I) * XU 9560C ********** ELIMINATION OPERATIONS ON NEXT VECTOR 9561C ITERATE ********** 9562 780 DO 820 I = IP, Q 9563 U = RV6(I) 9564C ********** IF RV1(I-1) .EQ. E(I), A ROW INTERCHANGE 9565C WAS PERFORMED EARLIER IN THE 9566C TRIANGULARIZATION PROCESS ********** 9567 IF (RV1(I-1) .NE. E(I)) GO TO 800 9568 U = RV6(I-1) 9569 RV6(I-1) = RV6(I) 9570 800 RV6(I) = U - RV4(I) * RV6(I-1) 9571 820 CONTINUE 9572C 9573 ITS = ITS + 1 9574 GO TO 600 9575C ********** SET ERROR -- NON-CONVERGED EIGENVECTOR ********** 9576 830 IERR = -R 9577 XU = ZERO 9578 GO TO 870 9579C ********** NORMALIZE SO THAT SUM OF SQUARES IS 9580C 1 AND EXPAND TO FULL ORDER ********** 9581 840 U = ZERO 9582C 9583 DO 860 I = P, Q 9584 860 U = U + RV6(I)**2 9585C 9586 XU = ONE / SQRT(U) 9587C 9588 870 DO 880 I = 1, N 9589 880 Z(I,R) = ZERO 9590C 9591 DO 900 I = P, Q 9592 900 Z(I,R) = RV6(I) * XU 9593C 9594 X0 = X1 9595 920 CONTINUE 9596C 9597 IF (Q .LT. N) GO TO 100 9598 1001 RETURN 9599C ********** LAST CARD OF TINVIT ********** 9600 END 9601C 9602C 9603C 9604 SUBROUTINE TRIDIB(N,EPS1,D,E,E2,LB,UB,M11,M,W,IND,IERR,RV4,RV5) 9605c 9606c njtj 9607c ### Cray conversions 9608c ### 1)Switch double precision to real. 9609c ### 2)Switch double precision parameter 9610c ### to single precision parameter statement. 9611c ### Cray conversions 9612c njtj 9613C 9614 INTEGER I,J,K,L,M,N,P,Q,R,S,II,M1,M2,M11,M22,TAG,IERR,ISTURM 9615 INTEGER IND(M) 9616 DOUBLE PRECISION D(N),E(N),E2(N),W(M),RV4(N),RV5(N) 9617 DOUBLE PRECISION U,V,LB,T1,T2,UB,XU,X0,X1,EPS1,MACHEP 9618Cray REAL D(N),E(N),E2(N),W(M),RV4(N),RV5(N) 9619Cray REAL U,V,LB,T1,T2,UB,XU,X0,X1,EPS1,MACHEP 9620C 9621 PARAMETER(ZERO=0.D0,ONE=1.D0,TWO=2.D0,PFIVE=0.5D0) 9622Cray PARAMETER(ZERO=0.0,ONE=1.0,TWO=2.0,PFIVE=0.5) 9623C 9624C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BISECT, 9625C NUM. MATH. 9, 386-393(1967) BY BARTH, MARTIN, AND WILKINSON. 9626C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 249-256(1971). 9627C 9628C THIS SUBROUTINE FINDS THOSE EIGENVALUES OF A TRIDIAGONAL 9629C SYMMETRIC MATRIX BETWEEN SPECIFIED BOUNDARY INDICES, 9630C USING BISECTION. 9631C 9632C ON INPUT- 9633C 9634C N IS THE ORDER OF THE MATRIX, 9635C 9636C EPS1 IS AN ABSOLUTE ERROR TOLERANCE FOR THE COMPUTED 9637C EIGENVALUES. IF THE INPUT EPS1 IS NON-POSITIVE, 9638C IT IS RESET FOR EACH SUBMATRIX TO A DEFAULT VALUE, 9639C NAMELY, MINUS THE PRODUCT OF THE RELATIVE MACHINE 9640C PRECISION AND THE 1-NORM OF THE SUBMATRIX, 9641C 9642C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX, 9643C 9644C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX 9645C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY, 9646C 9647C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. 9648C E2(1) IS ARBITRARY, 9649C 9650C M11 SPECIFIES THE LOWER BOUNDARY INDEX FOR THE DESIRED 9651C EIGENVALUES, 9652C 9653C M SPECIFIES THE NUMBER OF EIGENVALUES DESIRED. THE UPPER 9654C BOUNDARY INDEX M22 IS THEN OBTAINED AS M22=M11+M-1. 9655C 9656C ON OUTPUT- 9657C 9658C EPS1 IS UNALTERED UNLESS IT HAS BEEN RESET TO ITS 9659C (LAST) DEFAULT VALUE, 9660C 9661C D AND E ARE UNALTERED, 9662C 9663C ELEMENTS OF E2, CORRESPONDING TO ELEMENTS OF E REGARDED 9664C AS NEGLIGIBLE, HAVE BEEN REPLACED BY ZERO CAUSING THE 9665C MATRIX TO SPLIT INTO A DIRECT SUM OF SUBMATRICES. 9666C E2(1) IS ALSO SET TO ZERO, 9667C 9668C LB AND UB DEFINE AN INTERVAL CONTAINING EXACTLY THE DESIRED 9669C EIGENVALUES, 9670C 9671C W CONTAINS, IN ITS FIRST M POSITIONS, THE EIGENVALUES 9672C BETWEEN INDICES M11 AND M22 IN ASCENDING ORDER, 9673C 9674C IND CONTAINS IN ITS FIRST M POSITIONS THE SUBMATRIX INDICES 9675C ASSOCIATED WITH THE CORRESPONDING EIGENVALUES IN W -- 9676C 1 FOR EIGENVALUES BELONGING TO THE FIRST SUBMATRIX FROM 9677C THE TOP, 2 FOR THOSE BELONGING TO THE SECOND SUBMATRIX, ETC., 9678C 9679C IERR IS SET TO 9680C ZERO FOR NORMAL RETURN, 9681C 3*N+1 IF MULTIPLE EIGENVALUES AT INDEX M11 MAKE 9682C UNIQUE SELECTION IMPOSSIBLE, 9683C 3*N+2 IF MULTIPLE EIGENVALUES AT INDEX M22 MAKE 9684C UNIQUE SELECTION IMPOSSIBLE, 9685C 9686C RV4 AND RV5 ARE TEMPORARY STORAGE ARRAYS. 9687C 9688C NOTE THAT SUBROUTINE TQL1, IMTQL1, OR TQLRAT IS GENERALLY FASTER 9689C THAN TRIDIB, IF MORE THAN N/4 EIGENVALUES ARE TO BE FOUND. 9690C 9691C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW, 9692C APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY 9693C 9694C ------------------------------------------------------------------ 9695C 9696C ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING 9697C THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC. 9698C 9699C ********** 9700 MACHEP = TWO**(-40) 9701C 9702 IERR = 0 9703 TAG = 0 9704 XU = D(1) 9705 X0 = D(1) 9706 U = ZERO 9707C ********** LOOK FOR SMALL SUB-DIAGONAL ENTRIES AND DETERMINE AN 9708C INTERVAL CONTAINING ALL THE EIGENVALUES ********** 9709 DO 40 I = 1, N 9710 X1 = U 9711 U = ZERO 9712 IF (I .NE. N) U = ABS(E(I+1)) 9713 XU = MIN(D(I)-(X1+U),XU) 9714 X0 = MAX(D(I)+(X1+U),X0) 9715 IF (I .EQ. 1) GO TO 20 9716 IF (ABS(E(I)) .GT. MACHEP * (ABS(D(I)) + ABS(D(I-1)))) 9717 X GO TO 40 9718 20 E2(I) = ZERO 9719 40 CONTINUE 9720C 9721 X1 = MAX(ABS(XU),ABS(X0)) * MACHEP * REAL(N) 9722 XU = XU - X1 9723 T1 = XU 9724 X0 = X0 + X1 9725 T2 = X0 9726C ********** DETERMINE AN INTERVAL CONTAINING EXACTLY 9727C THE DESIRED EIGENVALUES ********** 9728 P = 1 9729 Q = N 9730 M1 = M11 - 1 9731 IF (M1 .EQ. 0) GO TO 75 9732 ISTURM = 1 9733 50 V = X1 9734 X1 = XU + (X0 - XU) * 0.5 9735 IF (X1 .EQ. V) GO TO 980 9736 GO TO 320 9737 60 IF (S - M1) 65, 73, 70 9738 65 XU = X1 9739 GO TO 50 9740 70 X0 = X1 9741 GO TO 50 9742 73 XU = X1 9743 T1 = X1 9744 75 M22 = M1 + M 9745 IF (M22 .EQ. N) GO TO 90 9746 X0 = T2 9747 ISTURM = 2 9748 GO TO 50 9749 80 IF (S - M22) 65, 85, 70 9750 85 T2 = X1 9751 90 Q = 0 9752 R = 0 9753C ********** ESTABLISH AND PROCESS NEXT SUBMATRIX, REFINING 9754C INTERVAL BY THE GERSCHGORIN BOUNDS ********** 9755 100 IF (R .EQ. M) GO TO 1001 9756 TAG = TAG + 1 9757 P = Q + 1 9758 XU = D(P) 9759 X0 = D(P) 9760 U = ZERO 9761C 9762 DO 120 Q = P, N 9763 X1 = U 9764 U = ZERO 9765 V = ZERO 9766 IF (Q .EQ. N) GO TO 110 9767 U = ABS(E(Q+1)) 9768 V = E2(Q+1) 9769 110 XU = MIN(D(Q)-(X1+U),XU) 9770 X0 = MAX(D(Q)+(X1+U),X0) 9771 IF (V .EQ. 0.0) GO TO 140 9772 120 CONTINUE 9773C 9774 140 X1 = MAX(ABS(XU),ABS(X0)) * MACHEP 9775 IF (EPS1 .LE. 0.0) EPS1 = -X1 9776 IF (P .NE. Q) GO TO 180 9777C ********** CHECK FOR ISOLATED ROOT WITHIN INTERVAL ********** 9778 IF (T1 .GT. D(P) .OR. D(P) .GE. T2) GO TO 940 9779 M1 = P 9780 M2 = P 9781 RV5(P) = D(P) 9782 GO TO 900 9783 180 X1 = X1 * REAL(Q-P+1) 9784 LB = MAX(T1,XU-X1) 9785 UB = MIN(T2,X0+X1) 9786 X1 = LB 9787 ISTURM = 3 9788 GO TO 320 9789 200 M1 = S + 1 9790 X1 = UB 9791 ISTURM = 4 9792 GO TO 320 9793 220 M2 = S 9794 IF (M1 .GT. M2) GO TO 940 9795C ********** FIND ROOTS BY BISECTION ********** 9796 X0 = UB 9797 ISTURM = 5 9798C 9799 DO 240 I = M1, M2 9800 RV5(I) = UB 9801 RV4(I) = LB 9802 240 CONTINUE 9803C ********** LOOP FOR K-TH EIGENVALUE 9804C FOR K=M2 STEP -1 UNTIL M1 DO -- 9805C (-DO- NOT USED TO LEGALIZE -COMPUTED GO TO-) ********** 9806 K = M2 9807 250 XU = LB 9808C ********** FOR I=K STEP -1 UNTIL M1 DO -- ********** 9809 DO 260 II = M1, K 9810 I = M1 + K - II 9811 IF (XU .GE. RV4(I)) GO TO 260 9812 XU = RV4(I) 9813 GO TO 280 9814 260 CONTINUE 9815C 9816 280 IF (X0 .GT. RV5(K)) X0 = RV5(K) 9817C ********** NEXT BISECTION STEP ********** 9818 300 X1 = (XU + X0) * PFIVE 9819 IF ((X0 - XU) .LE. (TWO * MACHEP * 9820 X (ABS(XU) + ABS(X0)) + ABS(EPS1))) GO TO 420 9821C ********** IN-LINE PROCEDURE FOR STURM SEQUENCE ********** 9822 320 S = P - 1 9823 U = ONE 9824C 9825 DO 340 I = P, Q 9826 IF (U .NE. ZERO) GO TO 325 9827 V = ABS(E(I)) / MACHEP 9828 IF (E2(I) .EQ. ZERO) V = ZERO 9829 GO TO 330 9830 325 V = E2(I) / U 9831 330 U = D(I) - X1 - V 9832 IF (U .LT. ZERO) S = S + 1 9833 340 CONTINUE 9834C 9835 GO TO (60,80,200,220,360), ISTURM 9836C ********** REFINE INTERVALS ********** 9837 360 IF (S .GE. K) GO TO 400 9838 XU = X1 9839 IF (S .GE. M1) GO TO 380 9840 RV4(M1) = X1 9841 GO TO 300 9842 380 RV4(S+1) = X1 9843 IF (RV5(S) .GT. X1) RV5(S) = X1 9844 GO TO 300 9845 400 X0 = X1 9846 GO TO 300 9847C ********** K-TH EIGENVALUE FOUND ********** 9848 420 RV5(K) = X1 9849 K = K - 1 9850 IF (K .GE. M1) GO TO 250 9851C ********** ORDER EIGENVALUES TAGGED WITH THEIR 9852C SUBMATRIX ASSOCIATIONS ********** 9853 900 S = R 9854 R = R + M2 - M1 + 1 9855 J = 1 9856 K = M1 9857C 9858 DO 920 L = 1, R 9859 IF (J .GT. S) GO TO 910 9860 IF (K .GT. M2) GO TO 940 9861 IF (RV5(K) .GE. W(L)) GO TO 915 9862C 9863 DO 905 II = J, S 9864 I = L + S - II 9865 W(I+1) = W(I) 9866 IND(I+1) = IND(I) 9867 905 CONTINUE 9868C 9869 910 W(L) = RV5(K) 9870 IND(L) = TAG 9871 K = K + 1 9872 GO TO 920 9873 915 J = J + 1 9874 920 CONTINUE 9875C 9876 940 IF (Q .LT. N) GO TO 100 9877 GO TO 1001 9878C ********** SET ERROR -- INTERVAL CANNOT BE FOUND CONTAINING 9879C EXACTLY THE DESIRED EIGENVALUES ********** 9880 980 IERR = 3 * N + ISTURM 9881 1001 LB = T1 9882 UB = T2 9883 RETURN 9884C ********** LAST CARD OF TRIDIB ********** 9885 END 9886C 9887C 9888C 9889 subroutine trnsvv(a,b,c,n) 9890c 9891c njtj 9892c ### Cray conversions 9893c ### 1)Comment out implicit double precision. 9894c ### Cray conversions 9895c njtj 9896c 9897 implicit double precision (a-h,o-z) 9898c 9899 dimension a(n),b(n) 9900c 9901 do 10 i=1,n 9902 a(i)=a(i)+c*b(i) 9903 10 continue 9904 return 9905 end 9906 9907 subroutine velect(iter,iconv,icorr,ispp,ifcore, 9908 1 nr,r,rab,zel,cdd,cdu,cdc,vod,vou,etot,y,yp, 9909 2 ypp,s1,s2,w) 9910c 9911c velect generates the electronic output potential from 9912c the electron charge density. The ionic part is 9913c added in dsolv1/dsolv2. 9914c 9915c njtj *** modifications *** 9916c The only major modiication is that the constants for the 9917c ceperly-alder 'ca' method are placed in parameter 9918c statements, this was done so non-opt compiliers 9919c would minimize the number of calculations. 9920c njtj *** modifications *** 9921c 9922c njtj 9923c ### Cray conversions 9924c ### 1)Comment out implicit double precision. 9925c ### 2)Switch double precision parameter statements 9926c ### to single precision parameter statements. 9927c ### Cray conversions 9928c njtj 9929c 9930 implicit double precision (a-h,o-z) 9931c 9932 character*1 ispp 9933 character*2 icorr 9934c 9935c njtj *** modification start *** 9936c 9937 parameter (zero=0.D0,one=1.D0,pfive=.5D0,opf=1.5D0,pnn=.99D0) 9938 parameter (pthree=0.3D0,psevf=0.75D0,c0504=0.0504D0) 9939 parameter (c0254=0.0254D0,c014=0.014D0,c0406=0.0406D0) 9940 parameter (c15p9=15.9D0,c0666=0.0666D0,c11p4=11.4D0) 9941 parameter (c045=0.045D0,c7p8=7.8D0,c88=0.88D0,c20p592=20.592D0) 9942 parameter (c3p52=3.52D0,c0311=0.0311D0,c0014=0.0014D0) 9943 parameter (c0538=0.0538D0,c0096=0.0096D0,c096=0.096D0) 9944 parameter (c0622=0.0622D0,c004=0.004D0,c0232=0.0232D0) 9945 parameter (c1686=0.1686D0,c1p3981=1.3981D0,c2611=0.2611D0) 9946 parameter (c2846=0.2846D0,c1p0529=1.0529D0,c3334=0.3334D0) 9947Cray parameter (zero=0.0,one=1.0,pfive=0.5,opf=1.5,pnn=0.99) 9948Cray parameter (pthree=0.3,psevf=0.75,c0504=0.0504) 9949Cray parameter (c0254=0.0254,c014=0.014,c0406=0.0406) 9950Cray parameter (c15p9=15.9,c0666=0.0666,c11p4=11.4) 9951Cray parameter (c045=0.045,c7p8=7.8,c88=0.88,c20p592=20.592) 9952Cray parameter (c3p52=3.52,c0311=0.0311,c0014=0.0014) 9953Cray parameter (c0538=0.0538,c0096=0.0096,c096=0.096) 9954Cray parameter (c0622=0.0622,c004=0.004,c0232=0.0232) 9955Cray parameter (c1686=0.1686,c1p3981=1.3981,c2611=0.2611) 9956Cray parameter (c2846=0.2846,c1p0529=1.0529,c3334=0.3334) 9957c 9958c Ceperly-Alder 'ca' constants 9959c 9960 parameter (con1=1.D0/6, con2=0.008D0/3, con3=0.3502D0/3) 9961 parameter (con4=0.0504D0/3, con5=0.0028D0/3, con6=0.1925D0/3) 9962 parameter (con7=0.0206D0/3, con8=9.7867D0/6, con9=1.0444D0/3) 9963 parameter (con10=7.3703D0/6, con11=1.3336D0/3) 9964Cray parameter (con1=1.0/6, con2=0.008/3, con3=0.3502/3) 9965Cray parameter (con4=0.0504/3, con5=0.0028/3, con6=0.1925/3) 9966Cray parameter (con7=0.0206/3, con8=9.7867/6, con9=1.0444/3) 9967Cray parameter (con10=7.3703/6, con11=1.3336/3) 9968c 9969c njtj *** modification end *** 9970c 9971 dimension r(nr),rab(nr),cdd(nr),cdu(nr),cdc(nr), 9972 1 vod(nr),vou(nr),etot(10),y(nr),yp(nr),ypp(nr), 9973 2 s1(nr),s2(nr),w(3*nr) 9974c 9975 pi=4*atan(one) 9976c 9977c------Machine dependent parameter- 9978c------Require exp(-2*expzer) to be within the range of the machine 9979c 9980Csun expzer = 3.7D2 9981cApollo expzer = 3.7D2 9982 expzer = 3.7D2 9983cVax expzer = 44.D0 9984Cray expzer = 2.8E3 9985c 9986c fit cd/r by splines 9987c 9988 y(1) = zero 9989 do 10 i=2,nr 9990 y(i) = (cdd(i)+cdu(i))/r(i) 9991 10 continue 9992 if (ifcore .eq. 2) then 9993 do 11 i=2,nr 9994 y(i) = y(i) + cdc(i)/r(i) 9995 11 continue 9996 endif 9997 isx = 0 9998 a1 = zero 9999 an = zero 10000 b1 = zero 10001 bn = zero 10002 nrm=nr 10003 call splift(r,y,yp,ypp,nrm,w,ierr,isx,a1,b1,an,bn) 10004 if(ierr.ne.1) then 10005 write(6,20000)ierr 10006 call ext(420+ierr) 10007 endif 1000820000 format(1x,'****** Error in splift ierr =',i2) 10009c 10010c compute the integrals of cd/r and cd from 10011c r(1)=0 to r(i) 10012c 10013 xlo = zero 10014 call spliq(r,y,yp,ypp,nrm,xlo,r,nrm,s2,ierr) 10015 if(ierr.ne.1) then 10016 write(6,20001)ierr 10017 call ext(440+ierr) 10018 endif 1001920001 format(1x,'****** Error in spliq ierr =',i2) 10020 do 20 i=1,nr 10021 ypp(i) = r(i)*ypp(i) + 2*yp(i) 10022 yp(i) = r(i)*yp(i) + y(i) 10023 y(i) = r(i)*y(i) 10024 20 continue 10025 call spliq(r,y,yp,ypp,nrm,xlo,r,nrm,s1,ierr) 10026 if(ierr.ne.1) then 10027 write(6,20002)ierr 10028 call ext(460+ierr) 10029 endif 1003020002 format(1x,'****** Error in spliq ierr =',i2) 10031c 10032c check normalization 10033c 10034 xnorm = zero 10035 if (ifcore .eq. 2 .and. iter .eq. 0 ) zel=s1(nr) 10036 if (zel .ne. zero) xnorm = zel/s1(nr) 10037 if (iter .gt. 3 .and. abs(zel-s1(nr)) .gt. 0.01) then 10038 if (zel .lt. s1(nr)+1.0 ) then 10039 write(6,24) iter,xnorm 10040 24 format(/,' warning *** charge density rescaled in', 10041 1 ' velect',/,' iteration number',i4,3x, 10042 2 'scaling factor =',f6.3,/) 10043 else 10044 xnorm=pnn*xnorm 10045 write(6,25) iter,xnorm 10046 25 format(/,' warning *** charge density partially rescaled in', 10047 1 ' velect',/,' iteration number',i4,3x, 10048 2 'scaling factor =',f6.3,/) 10049 endif 10050 endif 10051c 10052c compute new hartree potential 10053c renormalize the charge density 10054c 10055 do 30 i=2,nr 10056 vod(i) = 2 * xnorm*(s1(i)/r(i) + s2(nr) - s2(i)) 10057 vou(i) = vod(i) 10058 cdd(i) = xnorm*cdd(i) 10059 cdu(i) = xnorm*cdu(i) 10060 30 continue 10061c 10062c compute hartree contribution to total energy 10063c 10064 if (iconv .eq. 1) then 10065 ehart = zero 10066 ll = 4 10067 do 40 i=2,nr 10068 ehart = ehart+ll*(cdd(i)+cdu(i))*vod(i)*rab(i) 10069 ll = 6 - ll 10070 40 continue 10071 ehart = ehart / 6 10072 endif 10073c 10074c add exchange and correlation 10075c 10076 trd = one/3 10077 ftrd = 4*trd 10078 tftm = 2**ftrd-2 10079 a0 = (4/(9*pi))**trd 10080c 10081c set x-alpha 10082c 10083 alp = one 10084 if (icorr .ne. 'xa') alp = 2 * trd 10085 vxc = zero 10086 vc = zero 10087 exc = zero 10088 ec = zero 10089c 10090c start loop 10091c 10092 ll = 4 10093 do 210 i=2,nr 10094 cdsum = cdd(i) + cdu(i) 10095 if (ifcore .ge. 1) cdsum=cdsum+cdc(i) 10096 if (cdsum .le. zero) goto 210 10097c 10098c Vax bug fix. Troy Barbee - 4/17/90 10099c 10100 if (log(3*r(i)**2/cdsum) .gt. 2*expzer) goto 210 10101 rs = (3*r(i)**2/cdsum)**trd 10102 z = zero 10103 fz = zero 10104 fzp = zero 10105 if (ispp .eq. 's') then 10106 z = (cdd(i)-cdu(i)) / cdsum 10107 fz = ((1+z)**ftrd+(1-z)**ftrd-2)/tftm 10108 fzp = ftrd*((1+z)**trd-(1-z)**trd)/tftm 10109 endif 10110c 10111c exchange (only use (xa)) 10112c 10113 vxp = -3*alp/(pi*a0*rs) 10114 exp = 3*vxp/4 10115 if (ispp .eq. 'r') then 10116 beta = c014/rs 10117 sb = sqrt(1+beta*beta) 10118 alb = log(beta+sb) 10119 vxp = vxp * (-pfive + opf * alb / (beta*sb)) 10120 exp = exp *(one-opf*((beta*sb-alb)/beta**2)**2) 10121 endif 10122 65 vxf = 2**trd*vxp 10123 exf = 2**trd*exp 10124 vcp = zero 10125 ecp = zero 10126 vcf = zero 10127 ecf = zero 10128 if (icorr .eq. 'ca') then 10129c ceperly-alder (ca) 10130c The Perdew-Zunger parameterization is used. 10131c See Phys. Rev. B 23 5075 (1981). 10132 if (rs .gt. one) then 10133 sqrs=sqrt(rs) 10134 te = one+con10*sqrs+con11*rs 10135 be = one+c1p0529*sqrs+c3334*rs 10136 ecp = -c2846/be 10137 vcp = ecp*te/be 10138 te = one+con8*sqrs+con9*rs 10139 be = one+c1p3981*sqrs+c2611*rs 10140 ecf = -c1686/be 10141 vcf = ecf*te/be 10142 else 10143 rslog=log(rs) 10144 ecp=(c0622+c004*rs)*rslog-c096-c0232*rs 10145 vcp=(c0622+con2*rs)*rslog-con3-con4*rs 10146 ecf=(c0311+c0014*rs)*rslog-c0538-c0096*rs 10147 vcf=(c0311+con5*rs)*rslog-con6-con7*rs 10148 endif 10149 elseif (icorr .eq. 'xa') then 10150c correlation 10151 elseif (icorr .eq. 'wi') then 10152c wigner (wi) 10153 vcp = -(c3p52*rs+c20p592)/(3*(rs+c7p8)**2) 10154 ecp = -c88/(rs+c7p8) 10155 elseif (icorr .eq. 'hl') then 10156c hedin-lundqvist (hl) 10157 x = rs/21 10158 aln = log(1+1/x) 10159 vcp = -c045*aln 10160 ecp = aln+(x**3*aln-x*x)+x/2-trd 10161 if (x .gt. 500*one) ecp=((con1/x-pthree)/x+psevf)/x 10162 ecp = -c045*ecp 10163 elseif (icorr .eq. 'gl') then 10164c gunnarson-lundqvist-wilkins (gl) 10165 x = rs/c11p4 10166 aln = log(1+1/x) 10167 vcp = -c0666*aln 10168 ecp = aln+(x**3*aln-x*x)+x/2-trd 10169 if (x .gt. 500*one) ecp=((con1/x-pthree)/x+psevf)/x 10170 ecp = -c0666*ecp 10171 x = rs/c15p9 10172 aln = log(1+1/x) 10173 vcf = -c0406*aln 10174 ecf = aln+(x**3*aln-x*x)+x/2-trd 10175 if (x .gt. 500*one) ecf=((con1/x-pthree)/x+psevf)/x 10176 ecf = -c0406*ecf 10177 elseif (icorr .eq. 'bh') then 10178c von barth - hedin (bh) 10179 x = rs/30 10180 aln = log(1+1/x) 10181 vcp = -c0504*aln 10182 ecp = aln+(x**3*aln-x*x)+x/2-trd 10183 if (x .gt. 500*one) ecp=((con1/x-pthree)/x+psevf)/x 10184 ecp = -c0504*ecp 10185 x = rs/75 10186 aln = log(1+1/x) 10187 vcf = -c0254*aln 10188 ecf = aln+(x**3*aln-x*x)+x/2-trd 10189 if (x .gt. 500*one) ecf=((con1/x-pthree)/x+psevf)/x 10190 ecf = -c0254*ecf 10191 else 10192 write(6,70) icorr 10193 call ext(400) 10194 endif 10195 70 format('error in velect - icorr =',a2,' not implemented') 10196 vxcp = vxp + vcp 10197 vxcf = vxf + vcf 10198 vxcd = vxcp 10199 vxcu = vxcp 10200 excp = exp + ecp 10201 excf = exf + ecf 10202 vcd = vcp 10203 vcu = vcp 10204 exct = excp 10205 ect = ecp 10206 if (z .ne. zero) then 10207 vxcd = vxcd + fz*(vxcf-vxcp) + (1-z)*fzp*(excf-excp) 10208 vxcu = vxcu + fz*(vxcf-vxcp) - (1+z)*fzp*(excf-excp) 10209 vcd = vcd + fz*(vcf-vcp) + (1-z)*fzp*(ecf-ecp) 10210 vcu = vcu + fz*(vcf-vcp) - (1+z)*fzp*(ecf-ecp) 10211 exct = exct + fz*(excf-excp) 10212 ect = ect + fz*(ecf-ecp) 10213 endif 10214 vod(i) = vod(i) + vxcd 10215 vou(i) = vou(i) + vxcu 10216 vxc = vxc + ll * (cdd(i)*vxcd + cdu(i)*vxcu) * rab(i) 10217 vc = vc + ll * (cdd(i)*vcd + cdu(i)*vcu ) * rab(i) 10218 exc = exc + ll * cdsum * exct * rab(i) 10219 ec = ec + ll * cdsum * ect * rab(i) 10220 ll = 6 - ll 10221 210 continue 10222 etot(4) = ehart 10223 etot(5) = vxc / 3 10224 etot(6) = (3*vc - 4*ec) / 3 10225 etot(7) = exc / 3 10226 vod(1) = vod(2) - (vod(3)-vod(2))*r(2)/(r(3)-r(2)) 10227 vou(1) = vou(2) - (vou(3)-vou(2))*r(2)/(r(3)-r(2)) 10228 return 10229 end 10230C 10231C 10232C 10233 subroutine vionic(ispp,itype,icorr,ifcore,zsh,rsh, 10234 1 lmax,nr,a,b,r,rab,nameat,ncore,znuc, 10235 2 cdd,cdu,cdc,viod,viou) 10236c 10237c Vionic sets up the ionic potential. 10238c Note that viod/viou is the ionic potential times r. 10239c 10240c njtj *** major modifications *** 10241c If a potential does not exist, it is approximated 10242c by an existing potential. 10243c A nonspin or spin-polarized pseudo test, uses the 10244c down(nonspin generation), weighted average(spin- 10245c polarized), or averaged(relativistic) potentials. 10246c A relativistic pseudo test, must use relativistic 10247c generated potentials. The Schroedinger equation is 10248c used to integrate a relativistic pseudo test, 10249c not the Dirac equation. 10250c njtj *** major modifications *** 10251c 10252c njtj 10253c ### Cray conversions 10254c ### 1)Comment out implicit double precision. 10255c ### 2)Switch double precision parameter 10256c ### to single precision parameter statement. 10257c ### Cray conversions 10258c njtj 10259c 10260 implicit double precision (a-h,o-z) 10261c 10262 parameter (zero=0.D0) 10263Cray parameter (zero=0.0) 10264c 10265 character*1 ispp 10266 character*2 icorr,icorrt,nameat,namet 10267 character*3 irel 10268 character*4 nicore 10269 character*10 iray(6),ititle(7) 10270 10271 dimension r(nr),rab(nr),cdd(nr),cdu(nr),cdc(nr), 10272 1 viod(lmax,nr),viou(lmax,nr),npd(5),npu(5) 10273c 10274c 2*znuc part 10275c 10276 ifcore = 0 10277 if (itype .lt. 4) then 10278 do 10 i=1,lmax 10279 do 12 j=1,nr 10280 viod(i,j) = -2*znuc 10281 viou(i,j) = -2*znuc 10282 12 continue 10283 10 continue 10284 else 10285c 10286c read pseudopotentials from tape1 10287c 10288 rewind 1 10289 read(1) namet,icorrt,irel,nicore,(iray(i),i=1,6), 10290 1 (ititle(i),i=1,7),npotd,npotu,nrm,a,b,zion 10291 if(nicore.eq.'fcec'.or.nicore.eq.'pcec') ifcore = 1 10292 if(nicore.eq.'fche'.or.nicore.eq.'pche') ifcore = 2 10293 nr = nrm+1 10294 read(1) (r(i),i=2,nr) 10295 r(1) = zero 10296c 10297c down potentials (or average relativistic potentials) 10298c 10299c njtj *** major start *** 10300c if a potential does not exist, it is replaced by the 10301c next existing lower angular momentum potential or 10302c the next existing higher if no lower exist. 10303c 10304 do 15 i=1,lmax 10305 npd(i)=0 10306 15 continue 10307 do 20 i=1,npotd 10308 read(1) loi,(viod(loi+1,j),j=2,nr) 10309 viod(loi+1,1) = zero 10310 npd(loi+1)=1 10311 20 continue 10312 if (npd(1) .eq. 0) then 10313 do 25 i=2,lmax 10314 if (npd(i) .gt. 0) then 10315 do 24 j=1,nr 10316 viod(1,j)=viod(i,j) 10317 24 continue 10318 goto 30 10319 endif 10320 25 continue 10321 endif 10322 30 do 33 i=2,lmax 10323 if (npd(i) .eq. 0) then 10324 do 32 j=1,nr 10325 viod(i,j)=viod(i-1,j) 10326 32 continue 10327 endif 10328 33 continue 10329c 10330c up potentials (or spin orbit potentials) 10331c 10332 if (npotu .le. 0) goto 49 10333 do 35 i=1,lmax 10334 npu(i)=0 10335 35 continue 10336 do 37 i=1,npotu 10337 read(1) loi,(viou(loi+1,j),j=2,nr) 10338 viou(loi+1,1) = zero 10339 npu(loi+1)=1 10340 37 continue 10341 if (npu(1) .eq. 0) then 10342 do 38 i=2,lmax 10343 if (npu(i) .gt. 0) then 10344 do 39 j=1,nr 10345 viou(1,j)=viou(i,j) 10346 39 continue 10347 goto 40 10348 endif 10349 38 continue 10350 endif 10351 40 do 45 i=2,lmax 10352 if (npu(i) .eq. 0) then 10353 do 43 j=1,nr 10354 viou(i,j)=viou(i-1,j) 10355 43 continue 10356 endif 10357 45 continue 10358c 10359c njtj *** major end *** 10360c 10361c 10362c core and valence charges 10363c 10364 49 read(1) (cdc(i),i=2,nr) 10365 cdc(1) = zero 10366c 10367c replace valence charge on tape(valence charge modify) 10368c 10369 if (itype .eq. 6) then 10370 write(1) (cdd(i)+cdu(i),i=2,nr) 10371 return 10372 endif 10373 read(1) (cdd(i),i=2,nr) 10374 cdd(1) = zero 10375c 10376c njtj *** major start *** 10377c distribute charge as up and down charge 10378c generate radial intergration grid 10379c set up potentials equal to down potentials for 10380c spin-polarized pseudo test of nonspin and relativistic 10381c generated potentails. Construct spin-orbit potentials 10382c from relativistic sum and difference potentials and 10383c change ispp='r' to ispp=' '. 10384c 10385 do 50 i=1,nr 10386 rab(i) = (r(i)+a)*b 10387 cdd(i) = cdd(i)/2 10388 cdu(i) = cdd(i) 10389 50 continue 10390 if (ispp .eq. 's' .and. irel .ne. 'isp') then 10391 do 51 i=1,lmax 10392 do 52 j=1,nr 10393 viou(i,j) = viod(i,j) 10394 52 continue 10395 51 continue 10396 endif 10397 if (ispp .eq. 'r') then 10398 ispp=' ' 10399 if (irel .ne. 'rel') then 10400 write(6,130)irel 10401 130 format(//,'Pseudopotentail is not relativistic!!!!',/ 10402 1 ' setting up potentials equal to down!!!',//) 10403 do 53 i=1,lmax 10404 do 54 j=1,nr 10405 viou(i,j) = viod(i,j) 10406 54 continue 10407 53 continue 10408 else 10409 do 57 j=1,nr 10410 viou(1,j)=viod(1,j) 10411 57 continue 10412 do 58 i=2,lmax 10413 do 56 j=1,nr 10414 vsum=viod(i,j) 10415 vdiff=viou(i,j) 10416 viod(i,j)=vsum-i*vdiff/2 10417 viou(i,j)=vsum+(i-1)*vdiff/2 10418 56 continue 10419 58 continue 10420 endif 10421 endif 10422c 10423c njtj *** major end *** 10424c 10425c 10426c printout 10427c 10428 write(6,60) namet,icorrt,irel,nicore,(iray(i),i=1,6), 10429 1 (ititle(i),i=1,7) 10430 60 format(//,1x,a2,2x,a2,2x,a3,2x,a4, 10431 1 ' pseudopotential read from tape', 10432 2 /,1x,2a10,5x,4a10,/,1x,7a10,//) 10433 if (nameat .ne. namet) write(6,70) nameat,namet 10434 70 format(' input element ',a2, 10435 1 ' not equal to element on tape ',a2,//) 10436 if (icorr .ne. icorrt) write(6,80) icorr,icorrt 10437 80 format(' input correlation ',a2, 10438 1 ' not equal to correlation from tape ',a2,//) 10439 write(6,90) r(2),nr,r(nr) 10440 90 format(' radial grid parameters',//, 10441 1 ' r(1) = .0 , r(2) =',e8.2,' , ... , r(',i3,') =', 10442 2 f6.2,//) 10443 endif 10444c 10445c add potential from shell charge 10446c 10447 if (abs(zsh) .gt. 0.e-5) then 10448 do 110 i=1,lmax 10449 do 120 j=1,nr 10450 if (r(j) .ge. rsh) then 10451 viod(i,j) = viod(i,j) - 2*zsh 10452 viou(i,j) = viou(i,j) - 2*zsh 10453 else 10454 viod(i,j) = viod(i,j) - 2*zsh*r(i)/rsh 10455 viou(i,j) = viou(i,j) - 2*zsh*r(i)/rsh 10456 endif 10457 120 continue 10458 110 continue 10459 endif 10460 return 10461 end 10462C 10463C 10464C 10465 subroutine wtrans(vd,r,nr,rab,l,ist,b) 10466c 10467c ********************************************************** 10468c * 10469c * This is a plotting routine; the user should adjust 10470c * for their own needs. The result 10471c * is then printed to the current plot.dat file (unit=3) 10472c * for later plotting of the data. A marker (marker fw#) 10473c * is placed at the end of each set of data. 10474c * 10475c ********************************************************** 10476c 10477c njtj 10478c ### Cray conversions 10479c ### 1)Comment out implicit double precision. 10480c ### 2)Switch double precision parameter 10481c ### to single precision parameter statement. 10482c ### Cray conversions 10483c njtj 10484c 10485 implicit double precision (a-h,o-z) 10486c 10487 parameter (zero=0.D0,one=1.D0,big=17280.0D0,p5=.05D0) 10488Cray parameter (zero=0.0,one=1.0,big=17280.0,p5=.05) 10489c 10490 dimension vd(nr),r(nr),rab(nr),b(nr),vql(48),vql2(48), 10491 1 a(2000),vdpp(2000),r2(2000),v(2000),w(4000) 10492c 10493 do 1 i=1,48 10494 vql(i)=zero 10495 1 continue 10496c 10497c The wavefuncion(rR) times r times rab. 10498c 10499 if (abs(ist) .eq. 2) goto 400 10500 pi4=16*atan(one) 10501 do 10 k=2,nr 10502 if (r(k)-r(k-1).gt. p5) then 10503 nr2=k 10504 goto 20 10505 endif 10506 10 continue 10507 20 nr2=7*(nr2/7)+1 10508 nr3=nr2-7 10509 do 130 k=2,nr2 10510 b(k)=vd(k)*r(k)*rab(k) 10511 130 continue 10512 do 150 k=nr2,nr 10513 a(k-nr2+1)=vd(k)*r(k) 10514 150 continue 10515 isx = 0 10516 a1 = -p5*10 10517 an = -p5*10 10518 b1 = zero 10519 bn = zero 10520 nrm=nr-nr2+1 10521 call splift(r(nr2),a,r2,vdpp,nrm,w,ierr,isx,a1,b1,an,bn) 10522 if(ierr.ne.1) then 10523 call exit 10524 endif 10525 nr4=0 10526 do 155 ak=r(nr2),100.0D0,0.05D0 10527 nr4=nr4+1 10528 r2(nr4)=ak 10529 155 continue 10530 call splint(r(nr2),a,vdpp,nrm,r2,v,w,w(2000),nr4,kerr) 10531c 10532c Find the fourier transform-vql. 10533c 10534 do 140 j=1,48 10535 q=one/4*j 10536 vql(j)=zero 10537 a(1)=zero 10538 do 135 k=2,nr2 10539 a(k)=b(k)*sbessj(l,q*r(k)) 10540 135 continue 10541c 10542c Due to the high number of occilations in the intagrand, 10543c an eight point Newton-Cotes intagration method is used. 10544c See Abramowitz and Stegun Eq. 25.4.17 10545c 10546 do 145 k=1,nr3,7 10547 vql(j)=vql(j)+751*(a(k)+a(k+7))+3577*(a(k+1)+a(k+6))+ 10548 1 1323*(a(k+2)+a(k+5))+2989*(a(k+3)+a(k+4)) 10549 145 continue 10550 vql(j)=pi4*7*vql(j)/big 10551 do 160 k=1,nr4 10552 a(k)=v(k)*sbessj(l,q*r2(k)) 10553 160 continue 10554 vql2(j)=zero 10555 do 165 kk=8,nr4,7 10556 k=kk-7 10557 vql2(j)=vql2(j)+751*(a(k)+a(k+7))+3577*(a(k+1)+ 10558 1 a(k+6))+1323*(a(k+2)+a(k+5))+2989*(a(k+3)+a(k+4)) 10559 165 continue 10560 vql2(j)=0.35D0*pi4*vql2(j)/big 10561 vql(j)=vql(j)+vql2(j) 10562 140 continue 10563c 10564c Print out the transform vql(q) to the current plot.dat 10565c file (unit=3) for latter plotting. 10566c 10567 400 do 170 j=1,48 10568 write(3,6000)one/4*j,ist*vql(j) 10569 170 continue 10570 write(3,6001)l 10571 return 10572c 10573c format statements 10574c 10575 6000 format(1x,f7.4,3x,f10.6) 10576 6001 format(1x,'marker fw',i1) 10577 end 10578C 10579C 10580C 10581 subroutine zrbac2(x1,x2,rc1,rc2,rc3,rc4,rc5,rc6,rc7, 10582 1 rc8,lp,arc,brc,vrc,vap,vapp,ev,cdrc,r,rab,jrc,delta, 10583 2 gamma,alpha,alpha1,alpha2,alpha3,alpha4,ar) 10584c 10585c ********************************************************** 10586c * njtj 10587c * Routine brackets the root of the given function. 10588c * Taken from Numerical Recipes page 245. 10589c * njtj 10590c ********************************************************** 10591c 10592c njtj 10593c ### Cray conversions 10594c ### 1)Comment out implicit double precision. 10595c ### 2)Switch double precision parameter 10596c ### to single precision parameter statement. 10597c ### Cray conversions 10598c njtj 10599c 10600 implicit double precision (a-h,o-z) 10601c 10602 parameter (factor=1.6D0,ntry=50) 10603Cray parameter (factor=1.6,ntry=50) 10604c 10605 dimension r(jrc),rab(jrc),ar(jrc) 10606c 10607 call gamfn2(rc1,rc2,rc3,rc4,rc5,rc6,rc7,rc8,lp, 10608 1 arc,brc,vrc,vap,vapp,ev,cdrc,r,rab,jrc,delta,x1, 10609 2 alpha,alpha1,alpha2,alpha3,alpha4,f1,ar) 10610 call gamfn2(rc1,rc2,rc3,rc4,rc5,rc6,rc7,rc8,lp, 10611 1 arc,brc,vrc,vap,vapp,ev,cdrc,r,rab,jrc,delta,x2, 10612 2 alpha,alpha1,alpha2,alpha3,alpha4,f2,ar) 10613c 10614 do 11 j=1,ntry 10615 if(f1*f2.lt.0.0)return 10616 if(abs(f1).lt.abs(f2))then 10617 x1=x1+factor*(x1-x2) 10618 call gamfn2(rc1,rc2,rc3,rc4,rc5,rc6,rc7,rc8,lp, 10619 1 arc,brc,vrc,vap,vapp,ev,cdrc,r,rab,jrc,delta,x1, 10620 2 alpha,alpha1,alpha2,alpha3,alpha4,f1,ar) 10621 else 10622 x2=x2+factor*(x2-x1) 10623 call gamfn2(rc1,rc2,rc3,rc4,rc5,rc6,rc7,rc8,lp, 10624 1 arc,brc,vrc,vap,vapp,ev,cdrc,r,rab,jrc,delta,x2, 10625 2 alpha,alpha1,alpha2,alpha3,alpha4,f2,ar) 10626 endif 1062711 continue 10628c 10629c failure, abort program 10630c 10631 write(6,1000)lp 10632 call ext(830+lp) 10633 1000 format(//,'error in zbractk - can not bracket orbital ',i2) 10634 return 10635 end 10636C 10637C 10638C 10639 subroutine zrbact(x1,x2,rc1,rc2,rc3,rc4,rc5,rc6,rc7, 10640 1 rc8,lp,arc,brc,vrc,vap,vapp,ev,cdrc,r,rab,jrc,delta, 10641 2 gamma,alpha,alpha1,alpha2,alpha3,alpha4,ar) 10642c 10643c ********************************************************** 10644c * njtj 10645c * Routine brackets the root of the given function. 10646c * Taken from Numerical Recipes page 245. 10647c * njtj 10648c ********************************************************** 10649c 10650c njtj 10651c ### Cray conversions 10652c ### 1)Comment out implicit double precision. 10653c ### 2)Switch double precision parameter 10654c ### to single precision parameter statement. 10655c ### Cray conversions 10656c njtj 10657c 10658 implicit double precision (a-h,o-z) 10659c 10660 parameter (factor=1.6D0,ntry=50) 10661Cray parameter (factor=1.6,ntry=50) 10662c 10663 dimension r(jrc),rab(jrc),ar(jrc) 10664c 10665 call gamfnd(rc1,rc2,rc3,rc4,rc5,rc6,rc7,rc8,lp, 10666 1 arc,brc,vrc,vap,vapp,ev,cdrc,r,rab,jrc,delta,x1, 10667 2 alpha,alpha1,alpha2,alpha3,alpha4,f1,ar) 10668 call gamfnd(rc1,rc2,rc3,rc4,rc5,rc6,rc7,rc8,lp, 10669 1 arc,brc,vrc,vap,vapp,ev,cdrc,r,rab,jrc,delta,x2, 10670 2 alpha,alpha1,alpha2,alpha3,alpha4,f2,ar) 10671c 10672 do 11 j=1,ntry 10673 if(f1*f2.lt.0.0)return 10674 if(abs(f1).lt.abs(f2))then 10675 x1=x1+factor*(x1-x2) 10676 call gamfnd(rc1,rc2,rc3,rc4,rc5,rc6,rc7,rc8,lp, 10677 1 arc,brc,vrc,vap,vapp,ev,cdrc,r,rab,jrc,delta,x1, 10678 2 alpha,alpha1,alpha2,alpha3,alpha4,f1,ar) 10679 else 10680 x2=x2+factor*(x2-x1) 10681 call gamfnd(rc1,rc2,rc3,rc4,rc5,rc6,rc7,rc8,lp, 10682 1 arc,brc,vrc,vap,vapp,ev,cdrc,r,rab,jrc,delta,x2, 10683 2 alpha,alpha1,alpha2,alpha3,alpha4,f2,ar) 10684 endif 1068511 continue 10686c 10687c failure, abort program 10688c 10689 write(6,1000)lp 10690 call ext(830+lp) 10691 1000 format(//,'error in zbractk - can not bracket orbital ',i2) 10692 return 10693 end 10694C 10695C 10696C 10697c $Id$ 10698