1! $Id$ 2 3!************************************************** 4! 5! Name: alloc_paw_basis_data 6! 7! Purpose 8! 9! Created: 7/9/2002 10!************************************************** 11 SUBROUTINE alloc_paw_basis_data(nt,nb,ng) 12 implicit none 13#include "errquit.fh" 14 integer nt 15 integer nb(nt) 16 integer ng(nt) 17 18#include "paw_basis_data.fh" 19#include "bafdecls.fh" 20#include "paw_ma.fh" 21 22 23 logical ok 24 integer it 25 integer offset_nb 26 integer offset_ngb 27 integer offset_ng 28 29 tot_ntype = nt 30 31* !*** find total size for the arrays *** 32 do it = 1, tot_ntype 33 tot_nbasis = tot_nbasis + nb(it) 34 tot_ngridbasis = tot_ngridbasis + nb(it)*ng(it) 35 tot_ngrid = tot_ngrid + ng(it) 36 end do 37 38c ok = BA_set_auto_verify(.TRUE.) 39 40 ok = .TRUE. 41 42 ok = ok .AND. my_alloc(MT_INT,tot_ntype,"nbasis",nbasis) 43 ok = ok .AND. my_alloc(MT_INT,tot_ntype,"i_cut",i_cut) 44 ok = ok .AND. my_alloc(MT_INT,tot_ntype,"ngrid",ngrid) 45 ok = ok .AND. my_alloc(MT_INT,tot_ntype,"mult_l",mult_l) 46 ok = ok .AND. my_alloc(MT_DBL,tot_ntype,"r1",r1) 47 ok = ok .AND. my_alloc(MT_DBL,tot_ntype,"rmax",rmax) 48 ok = ok .AND. my_alloc(MT_DBL,tot_ntype,"log_amesh",log_amesh) 49 ok = ok .AND. my_alloc(MT_DBL,tot_ntype,"sigma",sigma) 50 ok = ok .AND. my_alloc(MT_DBL,tot_ntype,"ion_charge",ion_charge) 51 ok = ok .AND. my_alloc(MT_DBL,tot_ntype,"core_charge",core_charge) 52 ok = ok .AND. 53 > my_alloc(MT_DBL,tot_ntype,"core_kin_energy",core_kin_energy) 54 55 ok = ok .AND. my_alloc(MT_INT,tot_nbasis,"pr_n_ps",pr_n_ps) 56 ok = ok .AND. my_alloc(MT_INT,tot_nbasis,"pr_n",pr_n) 57 ok = ok .AND. my_alloc(MT_INT,tot_nbasis,"orb_l",orb_l) 58 ok = ok .AND. my_alloc(MT_DBL,tot_nbasis,"eig",eig) 59 60 ok = ok .AND. my_alloc(MT_DBL,tot_ngridbasis,"phi_ae",phi_ae) 61 ok = ok .AND. 62 > my_alloc(MT_DBL,tot_ngridbasis,"phi_ae_prime",phi_ae_prime) 63 ok = ok .AND. my_alloc(MT_DBL,tot_ngridbasis,"phi_ps",phi_ps) 64 ok = ok .AND. 65 > my_alloc(MT_DBL,tot_ngridbasis,"phi_ps_prime",phi_ps_prime) 66 ok = ok .AND. my_alloc(MT_DBL,tot_ngridbasis,"prj_ps",prj_ps) 67 ok = ok .AND. 68 > my_alloc(MT_DBL,tot_ngrid,"core_density",core_density) 69 ok = ok .AND. 70 > my_alloc(MT_DBL,tot_ngrid,"ps_core_density",ps_core_density) 71 72 ok = ok .AND. 73 > my_alloc(MT_DBL,tot_ngrid,"core_density_prime", 74 > core_density_prime) 75 ok = ok .AND. 76 > my_alloc(MT_DBL,tot_ngrid,"ps_core_density_prime", 77 > ps_core_density_prime) 78 79 ok = ok .AND. my_alloc(MT_DBL,tot_ngrid,"v_ps",v_ps) 80 ok = ok .AND. my_alloc(MT_DBL,tot_ngridbasis,"prj_ps0",prj_ps0) 81 ok = ok .AND. my_alloc(MT_DBL,tot_ngrid,"rgrid",rgrid) 82 83 ok = ok .AND. my_alloc(MT_INT,tot_ntype,"i_nb",i_nb) 84 ok = ok .AND. my_alloc(MT_INT,tot_ntype,"i_ng",i_ng) 85 ok = ok .AND. my_alloc(MT_INT,tot_ntype,"i_ngb",i_ngb) 86 87 ok = ok .AND. my_alloc(MT_INT,tot_ntype,"i_start",i_start) 88 ok = ok .AND. my_alloc(MT_INT,tot_ntype,"i_end",i_end) 89 ok = ok .AND. my_alloc(MT_INT,tot_ntype,"npoints",npoints) 90 91 if(.not. ok) then 92 call errquit("failed to allocate paw_basis data ",0, MA_ERR) 93 end if 94 95 do it=1,tot_ntype 96 int_mb(nbasis(1)-1 + it) = nb(it) 97 int_mb(ngrid(1)-1 + it) = ng(it) 98 end do 99 100 int_mb(i_nb(1) ) = 0 101 int_mb(i_ng(1) ) = 0 102 int_mb(i_ngb(1)) = 0 103 104 do it=1,tot_ntype-1 105 int_mb(i_nb(1) +it) = int_mb(i_nb(1) + it - 1) 106 > + int_mb(nbasis(1)-1 + it) 107 int_mb(i_ng(1) +it) = int_mb(i_ng(1) + it - 1) 108 > + int_mb(ngrid(1)-1 + it) 109 int_mb(i_ngb(1)+it) = int_mb(i_ngb(1) + it - 1) 110 > + int_mb(nbasis(1)-1 + it) 111 > *int_mb(ngrid(1)-1 + it) 112 end do 113 114 END !SUBROUTINE alloc_paw_basis_data 115 116 117 SUBROUTINE dealloc_paw_basis_data() 118 119 IMPLICIT NONE 120#include "errquit.fh" 121#include "paw_ma.fh" 122#include "paw_basis_data.fh" 123 124 logical ok 125 126 ok = .true. 127 ok = ok .and. my_dealloc(i_start) 128 ok = ok .and. my_dealloc(i_end) 129 ok = ok .and. my_dealloc(npoints) 130 131 ok = ok .and. my_dealloc(i_ngb) 132 ok = ok .and. my_dealloc(i_ng) 133 ok = ok .and. my_dealloc(i_nb) 134 ok = ok .and. my_dealloc(rgrid) 135 ok = ok .and. my_dealloc(prj_ps0) 136 ok = ok .and. my_dealloc(v_ps) 137 ok = ok .and. my_dealloc(ps_core_density) 138 ok = ok .and. my_dealloc(core_density) 139 ok = ok .and. my_dealloc(ps_core_density_prime) 140 ok = ok .and. my_dealloc(core_density_prime) 141 ok = ok .and. my_dealloc(prj_ps) 142 ok = ok .and. my_dealloc(phi_ps_prime) 143 ok = ok .and. my_dealloc(phi_ps) 144 ok = ok .and. my_dealloc(phi_ae_prime) 145 ok = ok .and. my_dealloc(phi_ae) 146 ok = ok .and. my_dealloc(eig) 147 ok = ok .and. my_dealloc(orb_l) 148 ok = ok .and. my_dealloc(pr_n) 149 ok = ok .and. my_dealloc(pr_n_ps) 150 ok = ok .and. my_dealloc(core_kin_energy) 151 ok = ok .and. my_dealloc(ion_charge) 152 ok = ok .and. my_dealloc(core_charge) 153 ok = ok .and. my_dealloc(sigma) 154 ok = ok .and. my_dealloc(log_amesh) 155 ok = ok .and. my_dealloc(rmax) 156 ok = ok .and. my_dealloc(r1) 157 ok = ok .and. my_dealloc(mult_l) 158 ok = ok .and. my_dealloc(ngrid) 159 ok = ok .and. my_dealloc(i_cut) 160 ok = ok .and. my_dealloc(nbasis) 161 162 if(.not. ok) then 163 call errquit("failed to deallocate paw_basis data ",0, MA_ERR) 164 end if 165 166 167 168 END !SUBROUTINE 169 170 171c ********************************* 172c * * 173c * paw_radgrid_map * 174c * * 175c ********************************* 176 177 subroutine paw_radgrid_map(tot_nr,i_start,i_end) 178 implicit none 179 integer tot_nr 180 integer i_start 181 integer i_end 182 183c *** local variables *** 184 integer nr,np,taskid 185 real*8 tmp 186 187 call Parallel_np(np) 188 call Parallel_taskid(taskid) 189 tmp = dble(tot_nr)/dble(np) 190 nr = dint(tmp) 191 192 i_start = 1 + taskid*nr 193 194 if (taskid .eq. (np-1)) THEN 195 i_end = tot_nr 196 else 197 i_end = i_start + nr 198 end if 199 200 return 201 end 202 203 204 205 206!************************************************** 207! 208! Name: paw_basis_tot_ntype 209! 210! Purpose 211! 212! Created: 7/9/2002 213!************************************************** 214 INTEGER FUNCTION paw_basis_tot_ntype() 215 implicit none 216 217#include "paw_basis_data.fh" 218 219 paw_basis_tot_ntype = tot_ntype 220 return 221 END 222 223!************************************************** 224! 225! Name: paw_basis_tot_nbasis 226! 227! Purpose 228! 229! Created: 7/9/2002 230!************************************************** 231 INTEGER FUNCTION paw_basis_tot_nbasis() 232 implicit none 233 234#include "paw_basis_data.fh" 235 236 paw_basis_tot_nbasis = tot_nbasis 237 return 238 END 239 240!************************************************** 241! 242! Name: paw_basis_tot_ngrid 243! 244! Purpose 245! 246! Created: 7/9/2002 247!************************************************** 248 INTEGER FUNCTION paw_basis_tot_ngrid() 249 implicit none 250 251#include "paw_basis_data.fh" 252 253 paw_basis_tot_ngrid = tot_ngrid 254 return 255 END 256 257!************************************************** 258! 259! Name: paw_basis_tot_ngridbasis 260! 261! Purpose 262! 263! Created: 7/9/2002 264!************************************************** 265 INTEGER FUNCTION paw_basis_tot_ngridbasis() 266 implicit none 267 268#include "paw_basis_data.fh" 269 270 paw_basis_tot_ngridbasis = tot_ngridbasis 271 return 272 END 273 274!************************************************** 275! 276! Name: paw_basis_i_nbasis 277! 278! Purpose 279! 280! Created: 7/9/2002 281!************************************************** 282 INTEGER FUNCTION paw_basis_i_nbasis(it) 283 implicit none 284 integer it 285 286#include "paw_basis_data.fh" 287 288 289 paw_basis_i_nbasis = nbasis(1) + it-1 290 return 291 END 292 293!************************************************** 294! 295! Name: paw_basis_i_nbasis 296! 297! Purpose 298! 299! Created: 7/9/2002 300!************************************************** 301 INTEGER FUNCTION paw_basis_nbasis(it) 302 implicit none 303 integer it 304 305#include "paw_basis_data.fh" 306#include "bafdecls.fh" 307 308 paw_basis_nbasis = int_mb(nbasis(1) + it-1) 309 return 310 END 311 312!************************************************** 313! 314! Name: paw_basis_i_ngrid 315! 316! Purpose 317! 318! Created: 7/9/2002 319!************************************************** 320 INTEGER FUNCTION paw_basis_i_ngrid(it) 321 implicit none 322 integer it 323 324#include "paw_basis_data.fh" 325 326 paw_basis_i_ngrid = ngrid(1) + it-1 327 return 328 END 329 330!************************************************** 331! 332! Name: paw_basis_ngrid 333! 334! Purpose 335! 336! Created: 7/9/2002 337!************************************************** 338 integer function paw_basis_ngrid(it) 339 implicit none 340 integer it 341 342#include "paw_basis_data.fh" 343#include "bafdecls.fh" 344 345 paw_basis_ngrid = int_mb(ngrid(1) + it-1) 346 return 347 END 348 349!************************************************** 350! 351! Name: 352! 353! Purpose 354! 355! Created: 7/9/2002 356!************************************************** 357 INTEGER FUNCTION paw_basis_i_mult_l(it) 358 implicit none 359 integer it 360 361#include "paw_basis_data.fh" 362 363 364 paw_basis_i_mult_l = mult_l(1) + it-1 365 return 366 END 367 368!************************************************** 369! 370! Name: 371! 372! Purpose 373! 374! Created: 7/9/2002 375!************************************************** 376 INTEGER FUNCTION paw_basis_mult_l(it) 377 implicit none 378 integer it 379 380#include "bafdecls.fh" 381#include "paw_basis_data.fh" 382 383 384 paw_basis_mult_l = int_mb(mult_l(1) + it-1) 385 return 386 END 387 388!************************************************** 389! 390! Name: paw_basis_i_r1 391! 392! Purpose 393! 394! Created: 7/9/2002 395!************************************************** 396 INTEGER FUNCTION paw_basis_i_r1(it) 397 implicit none 398 integer it 399 400#include "paw_basis_data.fh" 401 402 paw_basis_i_r1 = r1(1) + it-1 403 return 404 END 405 406!************************************************** 407! 408! Name: paw_basis_i_rmax 409! 410! Purpose 411! 412! Created: 7/9/2002 413!************************************************** 414 INTEGER FUNCTION paw_basis_i_rmax(it) 415 implicit none 416 integer it 417 418#include "paw_basis_data.fh" 419 420 421 paw_basis_i_rmax = rmax(1) + it-1 422 return 423 END 424!************************************************** 425! 426! Name: paw_basis_i_cut 427! 428! Purpose 429! 430! Created: 7/9/2002 431!************************************************** 432 INTEGER FUNCTION paw_basis_i_cut(it) 433 implicit none 434 integer it 435 436#include "paw_basis_data.fh" 437#include "bafdecls.fh" 438 439 paw_basis_i_cut = int_mb(i_cut(1) + it-1) 440 return 441 END 442 443 444!************************************************** 445! 446! Name: paw_basis_i_i_cut 447! 448! Purpose 449! 450! Created: 7/9/2002 451!************************************************** 452 INTEGER FUNCTION paw_basis_i_i_cut(it) 453 implicit none 454 integer it 455 456#include "paw_basis_data.fh" 457 458 paw_basis_i_i_cut = i_cut(1) + it-1 459 return 460 END 461 462 463!************************************************** 464! 465! Name: paw_basis_i_i_start 466! 467! Purpose 468! 469! Created: 7/9/2002 470!************************************************** 471 INTEGER FUNCTION paw_basis_i_i_start(it) 472 implicit none 473 integer it 474 475#include "paw_basis_data.fh" 476 477 paw_basis_i_i_start = i_start(1) + it-1 478 return 479 END 480 481!************************************************** 482! 483! Name: paw_basis_i_start 484! 485! Purpose 486! 487! Created: 7/9/2002 488!************************************************** 489 INTEGER FUNCTION paw_basis_i_start(it) 490 implicit none 491 integer it 492 493#include "paw_basis_data.fh" 494#include "bafdecls.fh" 495 496 paw_basis_i_start = int_mb(i_start(1) + it-1) 497 return 498 END 499 500 501!************************************************** 502! 503! Name: paw_basis_i_i_end 504! 505! Purpose 506! 507! Created: 7/9/2002 508!************************************************** 509 INTEGER FUNCTION paw_basis_i_i_end(it) 510 implicit none 511 integer it 512 513#include "paw_basis_data.fh" 514 515 paw_basis_i_i_end = i_end(1) + it-1 516 return 517 END 518 519 520!************************************************** 521! 522! Name: paw_basis_i_end 523! 524! Purpose 525! 526! Created: 7/9/2002 527!************************************************** 528 INTEGER FUNCTION paw_basis_i_end(it) 529 implicit none 530 integer it 531 532#include "paw_basis_data.fh" 533#include "bafdecls.fh" 534 535 paw_basis_i_end = int_mb(i_end(1) + it-1) 536 return 537 END 538 539 540!************************************************** 541! 542! Name: paw_basis_i_npoints 543! 544! Purpose 545! 546! Created: 7/9/2002 547!************************************************** 548 INTEGER FUNCTION paw_basis_i_npoints(it) 549 implicit none 550 integer it 551 552#include "paw_basis_data.fh" 553 554 paw_basis_i_npoints = npoints(1) + it-1 555 return 556 END 557 558 559!************************************************** 560! 561! Name: paw_basis_npoints 562! 563! Purpose 564! 565! Created: 7/9/2002 566!************************************************** 567 INTEGER FUNCTION paw_basis_npoints(it) 568 implicit none 569 integer it 570 571#include "paw_basis_data.fh" 572#include "bafdecls.fh" 573 574 paw_basis_npoints = int_mb(npoints(1) + it-1) 575 return 576 END 577 578 579 580!************************************************** 581! 582! Name: paw_basis_i_sigma 583! 584! Purpose 585! 586! Created: 7/9/2002 587!************************************************** 588 INTEGER FUNCTION paw_basis_i_sigma(it) 589 implicit none 590 integer it 591 592#include "paw_basis_data.fh" 593 594 paw_basis_i_sigma = sigma(1) + it-1 595 return 596 END 597 598!************************************************** 599! 600! Name: paw_basis_log_amesh 601! 602! Purpose 603! 604! Created: 7/9/2002 605!************************************************** 606 double precision FUNCTION paw_basis_log_amesh(it) 607 implicit none 608 integer it 609 610#include "paw_basis_data.fh" 611#include "bafdecls.fh" 612 613 paw_basis_log_amesh = dbl_mb(log_amesh(1)+it-1) 614 return 615 END 616 617!************************************************** 618! 619! Name: paw_basis_i_log_amesh 620! 621! Purpose 622! 623! Created: 7/9/2002 624!************************************************** 625 INTEGER FUNCTION paw_basis_i_log_amesh(it) 626 implicit none 627 integer it 628 629#include "paw_basis_data.fh" 630 631 paw_basis_i_log_amesh = log_amesh(1) + it-1 632 return 633 END 634 635!************************************************** 636! 637! Name: paw_basis_core_charge 638! 639! Purpose 640! 641! Created: 8/06/2002 642!************************************************** 643 subroutine calc_paw_basis_core_charge(ia,q) 644 implicit none 645 integer ia 646 double precision q 647 648#include "paw_basis_data.fh" 649#include "integrate.fh" 650#include "paw_basis.fh" 651#include "bafdecls.fh" 652 653 !*** local variables *** 654 real*8 core,fourpi 655 656c !*** external functions *** 657c integer paw_basis_i_core_density,paw_basis_i_rgrid 658c integer paw_basis_i_log_amesh,paw_basis_i_ngrid 659c external paw_basis_i_core_density,paw_basis_i_rgrid 660c external paw_basis_i_log_amesh,paw_basis_i_ngrid 661 662 fourpi = 16.0d0*datan(1.0d0) 663 q = fourpi*def_integr(0, 664 > dbl_mb(paw_basis_i_core_density(ia)), 665 > 2, 666 > dbl_mb(paw_basis_i_rgrid(ia)), 667 > dbl_mb(paw_basis_i_log_amesh(ia)), 668 > int_mb(paw_basis_i_ngrid(ia))) 669 670 return 671 end 672 673!************************************************** 674! 675! Name: paw_basis_i_core_charge 676! 677! Purpose 678! 679! Created: 7/9/2002 680!************************************************** 681 INTEGER FUNCTION paw_basis_i_core_charge(it) 682 implicit none 683 integer it 684 685#include "paw_basis_data.fh" 686 687 paw_basis_i_core_charge = core_charge(1) + it-1 688 return 689 END 690 691!************************************************** 692! 693! Name: paw_basis_core_charge 694! 695! Purpose 696! 697! Created: 7/9/2002 698!************************************************** 699 DOUBLE PRECISION FUNCTION paw_basis_core_charge(it) 700 implicit none 701 integer it 702 703#include "paw_basis_data.fh" 704#include "bafdecls.fh" 705 706 paw_basis_core_charge = dbl_mb(core_charge(1) + it-1) 707 return 708 END 709 710 711!************************************************** 712! 713! Name: paw_basis_i_ion_charge 714! 715! Purpose 716! 717! Created: 7/9/2002 718!************************************************** 719 INTEGER FUNCTION paw_basis_i_ion_charge(it) 720 implicit none 721 integer it 722 723#include "paw_basis_data.fh" 724 725 paw_basis_i_ion_charge = ion_charge(1) + it-1 726 return 727 END 728 729 730!************************************************** 731! 732! Name: paw_basis_ion_charge 733! 734! Purpose 735! 736! Created: 7/9/2002 737!************************************************** 738 DOUBLE PRECISION FUNCTION paw_basis_ion_charge(it) 739 implicit none 740 integer it 741 742#include "paw_basis_data.fh" 743#include "bafdecls.fh" 744 745 paw_basis_ion_charge = dbl_mb(ion_charge(1) + it-1) 746 return 747 END 748 749 750************************************************** 751! 752! Name: paw_basis_sphere_radius 753! 754! Purpose 755! 756! Created: 8/06/2002 757!************************************************** 758 real*8 function paw_basis_sphere_radius(ia) 759 implicit none 760 integer ia 761 762#include "paw_basis_data.fh" 763#include "bafdecls.fh" 764 765 766 !*** external functions *** 767 integer paw_basis_i_rgrid,paw_basis_i_i_cut 768 external paw_basis_i_rgrid,paw_basis_i_i_cut 769 770 paw_basis_sphere_radius = dbl_mb(paw_basis_i_rgrid(ia) 771 > +int_mb(paw_basis_i_i_cut(ia))-1) 772 return 773 end 774 775 776************************************************** 777! 778! Name: paw_basis_sigma 779! 780! Purpose 781! 782! Created: 8/06/2002 783!************************************************** 784 real*8 function paw_basis_sigma(ia) 785 implicit none 786 integer ia 787 788#include "paw_basis_data.fh" 789#include "bafdecls.fh" 790 791 !*** external functions *** 792 integer paw_basis_i_sigma 793 external paw_basis_i_sigma 794 795 paw_basis_sigma = dbl_mb(paw_basis_i_sigma(ia)) 796 return 797 end 798 799************************************************** 800! 801! Name: paw_tot_nlm_nbasis 802! 803! Purpose 804! 805! Created: 8/06/2002 806!************************************************** 807 integer function paw_tot_nlm_nbasis() 808 809 implicit none 810 811 integer ia 812 integer ii 813 integer l 814 815#include "paw_geom.fh" 816 817 !*** external functions *** 818 integer paw_nlm_nbasis 819 external paw_nlm_nbasis 820 821 paw_tot_nlm_nbasis = 0 822 do ia=1,ion_nion() 823 paw_tot_nlm_nbasis = paw_tot_nlm_nbasis + paw_nlm_nbasis(ia) 824 end do 825 826 return 827 end 828 829 830************************************************** 831! 832! Name: paw_nlm_nbasis 833! 834! Purpose 835! 836! Created: 8/06/2002 837!************************************************** 838 integer function paw_nlm_nbasis(ia) 839 840 implicit none 841 842 integer ia 843 integer ii 844 integer l 845 846#include "paw_geom.fh" 847#include "bafdecls.fh" 848 849 !*** external functions *** 850 integer paw_basis_i_orb_l,paw_basis_nbasis 851 external paw_basis_i_orb_l,paw_basis_nbasis 852 853 paw_nlm_nbasis = 0 854 do ii=1,paw_basis_nbasis(ia) 855 l = int_mb(paw_basis_i_orb_l(ia)+ii-1) 856 paw_nlm_nbasis = paw_nlm_nbasis + 2*l+1 857 end do 858 859 return 860 end 861 862 863************************************************** 864! 865! Name: paw_basis_n 866! 867! Purpose 868! 869! Created: 8/06/2002 870!************************************************** 871 integer function paw_basis_n(ii,ia) 872 implicit none 873 integer ii,ia 874 875#include "paw_basis_data.fh" 876#include "bafdecls.fh" 877 878 !*** external functions *** 879 integer paw_basis_i_pr_n 880 external paw_basis_i_pr_n 881 882 paw_basis_n = int_mb(paw_basis_i_pr_n(ia)+ii-1) 883 return 884 end 885 886************************************************** 887! 888! Name: paw_basis_n_ps 889! 890! Purpose 891! 892! Created: 8/06/2002 893!************************************************** 894 integer function paw_basis_n_ps(ii,ia) 895 implicit none 896 integer ii,ia 897 898#include "paw_basis_data.fh" 899#include "bafdecls.fh" 900 901 !*** external functions *** 902 integer paw_basis_i_pr_n_ps 903 external paw_basis_i_pr_n_ps 904 905 paw_basis_n_ps = int_mb(paw_basis_i_pr_n_ps(ia)+ii-1) 906 return 907 end 908 909************************************************** 910! 911! Name: paw_basis_orb_l 912! 913! Purpose 914! 915! Created: 8/06/2002 916!************************************************** 917 integer function paw_basis_orb_l(ii,ia) 918 implicit none 919 integer ii,ia 920 921#include "paw_basis_data.fh" 922#include "bafdecls.fh" 923 924 !*** external functions *** 925 integer paw_basis_i_orb_l 926 external paw_basis_i_orb_l 927 928 paw_basis_orb_l = int_mb(paw_basis_i_orb_l(ia)+ii-1) 929 return 930 end 931 932 933************************************************** 934! 935! Name: paw_basis_eig 936! 937! Purpose 938! 939! Created: 8/06/2002 940!************************************************** 941 real*8 function paw_basis_eig(ii,ia) 942 implicit none 943 integer ii,ia 944 945#include "paw_basis_data.fh" 946#include "bafdecls.fh" 947 948 !*** external functions *** 949 integer paw_basis_i_eig 950 external paw_basis_i_eig 951 952 paw_basis_eig = dbl_mb(paw_basis_i_eig(ia)+ii-1) 953 return 954 end 955 956 957 958!************************************************** 959! 960! Name: paw_basis_i_core_kin_energy 961! 962! Purpose 963! 964! Created: 7/9/2002 965!************************************************** 966 INTEGER FUNCTION paw_basis_i_core_kin_energy(it) 967 implicit none 968 integer it 969 970#include "paw_basis_data.fh" 971 972 paw_basis_i_core_kin_energy = core_kin_energy(1) + it-1 973 return 974 END 975 976 977!************************************************** 978! 979! Name: paw_basis_core_kin_energy 980! 981! Purpose 982! 983! Created: 7/9/2002 984!************************************************** 985 double precision FUNCTION paw_basis_core_kin_energy(it) 986 implicit none 987 integer it 988 989#include "paw_basis_data.fh" 990#include "bafdecls.fh" 991 992 paw_basis_core_kin_energy = dbl_mb(core_kin_energy(1) + it-1) 993 return 994 END 995 996!************************************************** 997! 998! Name: paw_basis_i_pr_n 999! 1000! Purpose 1001! 1002! Created: 7/9/2002 1003!************************************************** 1004 INTEGER FUNCTION paw_basis_i_pr_n(it) 1005 implicit none 1006 integer it 1007 1008#include "paw_basis_data.fh" 1009#include "bafdecls.fh" 1010 1011 paw_basis_i_pr_n = pr_n(1) + int_mb(i_nb(1) + it-1) 1012 return 1013 END 1014 1015!************************************************** 1016! 1017! Name: paw_basis_i_pr_n_ps 1018! 1019! Purpose 1020! 1021! Created: 7/9/200 1022!************************************************** 1023 INTEGER FUNCTION paw_basis_i_pr_n_ps(it) 1024 implicit none 1025 integer it 1026 1027#include "paw_basis_data.fh" 1028#include "bafdecls.fh" 1029 1030 paw_basis_i_pr_n_ps = pr_n_ps(1) + int_mb(i_nb(1) + it-1) 1031 return 1032 END 1033 1034!************************************************** 1035! 1036! Name: paw_basis_i_orb_l 1037! 1038! Purpose 1039! 1040! Created: 7/9/2002 1041!************************************************** 1042 INTEGER FUNCTION paw_basis_i_orb_l(it) 1043 implicit none 1044 integer it 1045 1046#include "paw_basis_data.fh" 1047#include "bafdecls.fh" 1048 1049 paw_basis_i_orb_l = orb_l(1) + int_mb(i_nb(1) + it-1) 1050 return 1051 END 1052 1053!************************************************** 1054! 1055! Name: paw_basis_i_eig 1056! 1057! Purpose 1058! 1059! Created: 7/9/2002 1060!************************************************** 1061 INTEGER FUNCTION paw_basis_i_eig(it) 1062 implicit none 1063 integer it 1064 1065#include "paw_basis_data.fh" 1066#include "bafdecls.fh" 1067 1068 paw_basis_i_eig = eig(1) + int_mb(i_nb(1) + it-1) 1069 return 1070 END 1071 1072!************************************************** 1073! 1074! Name: paw_basis_i_core_density 1075! 1076! Purpose 1077! 1078! Created: 7/9/2002 1079!************************************************** 1080 INTEGER FUNCTION paw_basis_i_core_density(it) 1081 implicit none 1082 integer it 1083 1084#include "paw_basis_data.fh" 1085#include "bafdecls.fh" 1086 1087 paw_basis_i_core_density = core_density(1) + 1088 + int_mb(i_ng(1) + it-1) 1089 return 1090 END 1091 1092!************************************************** 1093! 1094! Name: paw_basis_i_ps_core_density 1095! 1096! Purpose 1097! 1098! Created: 7/9/2002 1099!************************************************** 1100 INTEGER FUNCTION paw_basis_i_ps_core_density(it) 1101 implicit none 1102 integer it 1103 1104#include "paw_basis_data.fh" 1105#include "bafdecls.fh" 1106 1107 paw_basis_i_ps_core_density = ps_core_density(1) 1108 > + int_mb(i_ng(1) + it-1) 1109 return 1110 END 1111 1112 1113 1114!************************************************** 1115! 1116! Name: paw_basis_i_core_density_prime 1117! 1118! Purpose - needed for gga's 1119! 1120! Created: 1/28/2006 1121!************************************************** 1122 INTEGER FUNCTION paw_basis_i_core_density_prime(it) 1123 implicit none 1124 integer it 1125 1126#include "paw_basis_data.fh" 1127#include "bafdecls.fh" 1128 1129 paw_basis_i_core_density_prime = core_density_prime(1) 1130 > + int_mb(i_ng(1)+it-1) 1131 return 1132 END 1133 1134!************************************************** 1135! 1136! Name: paw_basis_i_ps_core_density_prime 1137! 1138! Purpose - needed for gga's 1139! 1140! Created: 1/28/2006 1141!************************************************** 1142 INTEGER FUNCTION paw_basis_i_ps_core_density_prime(it) 1143 implicit none 1144 integer it 1145 1146#include "paw_basis_data.fh" 1147#include "bafdecls.fh" 1148 1149 paw_basis_i_ps_core_density_prime = ps_core_density_prime(1) 1150 > + int_mb(i_ng(1)+ it-1) 1151 return 1152 END 1153 1154 1155!************************************************** 1156! 1157! Name: paw_basis_i_v_ps 1158! 1159! Purpose 1160! 1161! Created: 7/9/2002 1162!************************************************** 1163 INTEGER FUNCTION paw_basis_i_v_ps(it) 1164 implicit none 1165 integer it 1166 1167#include "paw_basis_data.fh" 1168#include "bafdecls.fh" 1169 1170 paw_basis_i_v_ps = v_ps(1) + int_mb(i_ng(1) + it-1) 1171 return 1172 END 1173 1174!************************************************** 1175! 1176! Name: paw_basis_i_rgrid 1177! 1178! Purpose 1179! 1180! Created: 7/9/2002 1181!************************************************** 1182 INTEGER FUNCTION paw_basis_i_rgrid(it) 1183 implicit none 1184 integer it 1185 1186#include "paw_basis_data.fh" 1187#include "bafdecls.fh" 1188 1189 paw_basis_i_rgrid = rgrid(1) + int_mb(i_ng(1) + it-1) 1190 return 1191 END 1192 1193!************************************************** 1194! 1195! Name: paw_basis_i_phi_ae 1196! 1197! Purpose 1198! 1199! Created: 7/9/2002 1200!************************************************** 1201 INTEGER FUNCTION paw_basis_i_phi_ae(it) 1202 implicit none 1203 integer it 1204 1205#include "paw_basis_data.fh" 1206#include "bafdecls.fh" 1207 1208 paw_basis_i_phi_ae = phi_ae(1) + int_mb(i_ngb(1) + it-1) 1209 return 1210 END 1211 1212 1213!************************************************** 1214! 1215! Name: paw_basis_i_phi_ps 1216! 1217! Purpose 1218! 1219! Created: 7/9/2002 1220!************************************************** 1221 INTEGER FUNCTION paw_basis_i_phi_ps(it) 1222 implicit none 1223 integer it 1224 1225#include "paw_basis_data.fh" 1226#include "bafdecls.fh" 1227 1228 paw_basis_i_phi_ps = phi_ps(1) + int_mb(i_ngb(1) + it-1) 1229 return 1230 END 1231 1232 1233!************************************************** 1234! 1235! Name: paw_basis_i_phi_ae_prime 1236! 1237! Purpose 1238! 1239! Created: 7/9/2002 1240!************************************************** 1241 INTEGER FUNCTION paw_basis_i_phi_ae_prime(it) 1242 implicit none 1243 integer it 1244 1245#include "paw_basis_data.fh" 1246#include "bafdecls.fh" 1247 1248 paw_basis_i_phi_ae_prime = phi_ae_prime(1) + 1249 + int_mb(i_ngb(1) + it-1) 1250 return 1251 END 1252 1253!************************************************** 1254! 1255! Name: paw_basis_i_phi_ps_prime 1256! 1257! Purpose 1258! 1259! Created: 7/9/2002 1260!************************************************** 1261 INTEGER FUNCTION paw_basis_i_phi_ps_prime(it) 1262 implicit none 1263 integer it 1264 1265#include "paw_basis_data.fh" 1266#include "bafdecls.fh" 1267 1268 paw_basis_i_phi_ps_prime = phi_ps_prime(1) + 1269 + int_mb(i_ngb(1) + it-1) 1270 return 1271 END 1272 1273!************************************************** 1274! 1275! Name: paw_basis_i_prj_ps 1276! 1277! Purpose 1278! 1279! Created: 7/9/2002 1280!************************************************** 1281 INTEGER FUNCTION paw_basis_i_prj_ps(it) 1282 implicit none 1283 integer it 1284 1285#include "paw_basis_data.fh" 1286#include "bafdecls.fh" 1287 1288 paw_basis_i_prj_ps = prj_ps(1) + int_mb(i_ngb(1) + it-1) 1289 return 1290 END 1291 1292!************************************************** 1293! 1294! Name: paw_basis_i_prj_ps0 1295! 1296! Purpose 1297! 1298! Created: 7/9/2002 1299!************************************************** 1300 INTEGER FUNCTION paw_basis_i_prj_ps0(it) 1301 implicit none 1302 integer it 1303 1304#include "bafdecls.fh" 1305#include "paw_basis_data.fh" 1306 1307 paw_basis_i_prj_ps0 = prj_ps0(1) + int_mb(i_ngb(1) + it-1) 1308 return 1309 END 1310 1311 subroutine set_max_i_cut(ic) 1312 implicit none 1313 integer ic 1314#include "paw_basis_data.fh" 1315 1316 max_i_cut = ic 1317 1318 end 1319 1320 1321 1322 subroutine set_max_mult_l(l) 1323 implicit none 1324 integer l 1325#include "paw_basis_data.fh" 1326 1327 max_mult_l = l 1328 1329 end 1330 1331 integer function paw_basis_max_i_cut() 1332 implicit none 1333 1334#include "paw_basis_data.fh" 1335 1336 paw_basis_max_i_cut= max_i_cut 1337 1338 end 1339 1340 integer function paw_basis_max_mult_l() 1341 implicit none 1342 1343#include "paw_basis_data.fh" 1344 1345 paw_basis_max_mult_l= max_mult_l 1346 1347 end 1348 1349 1350 1351 1352c ************************************************* 1353c * * 1354c * paw_basis_derivative_ngrid * 1355c * * 1356c ************************************************* 1357c 1358c This routine computes the seven point derivative of f. 1359c where f and df are stored on a logarithmic grid. The 1360c dimensions of f and df are, f(1:ng), and df(1:ng) 1361 1362 subroutine paw_basis_derivative_ngrid(ng,log_amesh,r,f,df) 1363 implicit none 1364 integer ng 1365 double precision log_amesh 1366 double precision r(ng) 1367 double precision f(ng) 1368 double precision df(ng) 1369 1370 double precision one_over_60 1371 parameter (one_over_60 = 1.0d0/60.0d0) 1372 1373 integer i,n1,n2,m1,m2 1374 double precision aa 1375 1376 aa = one_over_60/log_amesh 1377 n1 = 1 1378 n2 = ng 1379 m1 = n1 1380 m2 = n2 1381 1382 1383 if (n1.le.3) then 1384 if ((n1.eq.1).and.(n1.ge.m1).and.(n1.le.m2)) then 1385 df(1) = aa*(-147.0d0*f(1) 1386 > + 360.0d0*f(2) 1387 > - 450.0d0*f(3) 1388 > + 400.0d0*f(4) 1389 > - 225.0d0*f(5) 1390 > + 72.0d0*f(6) 1391 > - 10.0d0*f(7))/r(1) 1392 n1 = n1+1 1393 end if 1394 if ((n1.eq.2).and.(n1.ge.m1).and.(n1.le.m2)) then 1395 df(2) = aa*( -10.0d0*f(1) 1396 > - 77.0d0*f(2) 1397 > + 150.0d0*f(3) 1398 > - 100.0d0*f(4) 1399 > + 50.0d0*f(5) 1400 > - 15.0d0*f(6) 1401 > + 2.0d0*f(7))/r(2) 1402 n1 = n1+1 1403 end if 1404 if ((n1.eq.3.and.(n1.ge.m1).and.(n1.le.m2))) then 1405 df(3) = aa*( +2.0d0*f(1) 1406 > - 24.0d0*f(2) 1407 > - 35.0d0*f(3) 1408 > + 80.0d0*f(4) 1409 > - 30.0d0*f(5) 1410 > + 8.0d0*f(6) 1411 > - 1.0d0*f(7))/r(3) 1412 n1 = n1+1 1413 end if 1414 end if 1415 1416 if (n2.ge.(ng-2)) then 1417 if ((n2.eq.ng).and.(n2.ge.m1).and.(n2.le.m2)) then 1418 df(ng) = aa*( +147.0d0*f(ng) 1419 > - 360.0d0*f(ng-1) 1420 > + 450.0d0*f(ng-2) 1421 > - 400.0d0*f(ng-3) 1422 > + 225.0d0*f(ng-4) 1423 > - 72.0d0*f(ng-5) 1424 > + 10.0d0*f(ng-6))/r(ng) 1425 n2 = n2-1 1426 end if 1427 if ((n2.eq.(ng-1).and.(n2.ge.m1).and.(n2.le.m2))) then 1428 df(ng-1) = aa*( +10.0d0*f(ng) 1429 > + 77.0d0*f(ng-1) 1430 > - 150.0d0*f(ng-2) 1431 > + 100.0d0*f(ng-3) 1432 > - 50.0d0*f(ng-4) 1433 > + 15.0d0*f(ng-5) 1434 > - 2.0d0*f(ng-6))/r(ng-1) 1435 n2 = n2-1 1436 end if 1437 if ((n2.eq.(ng-2).and.(n2.ge.m1).and.(n2.le.m2))) then 1438 df(ng-2) = aa*( -2.0d0*f(ng) 1439 > + 24.0d0*f(ng-1) 1440 > + 35.0d0*f(ng-2) 1441 > - 80.0d0*f(ng-3) 1442 > + 30.0d0*f(ng-4) 1443 > - 8.0d0*f(ng-5) 1444 > + 1.0d0*f(ng-6))/r(ng-2) 1445 n2 = n2-1 1446 end if 1447 end if 1448 1449 do i=n1,n2 1450 df(i) = aa*( -1.0d0*f(i-3) 1451 > + 9.0d0*f(i-2) 1452 > - 45.0d0*f(i-1) 1453 > + 45.0d0*f(i+1) 1454 > - 9.0d0*f(i+2) 1455 > + 1.0d0*f(i+3))/r(i) 1456 end do 1457 1458 return 1459 end 1460 1461 1462 1463