1c $Id$ 2 block data initial_bq_data 3 implicit none 4#include "bq_data.fh" 5c 6 data bq_active /max_bq*.false./ 7 data bq_mem /max_bq*.false./ 8 data bq_ncent /max_bq*-1/ 9 10 end 11C> 12C> \defgroup bq Point charges 13C> 14C> The Bq module plays a role that is similar to the role of the 15C> geometry. I.e. it deals with centers distributed in space where 16C> the centers may have some properties. 17C> 18C> Because Bq centers are often used to generate embedding potentials 19C> in QM/MM calculations Bq instances have to be able to contain 20C> thousands of centers. The geometry instance typically contain only 21C> atoms and hence are restricted in the number of centers they can 22C> contain. 23C 24C> \ingroup bq 25C> @{ 26C> 27C> \brief Create a Bq instance 28C> 29 function bq_create(namespace,handle) 30 implicit none 31#include "mafdecls.fh" 32#include "bq_data.fh" 33#include "errquit.fh" 34#include "rtdb.fh" 35 character*(*) namespace !< [Input] The Bq instance name 36 logical bq_create 37c local variables 38 integer i 39 integer handle !< [Output] The Bq instance handle 40 41 bq_create = .false. 42 do i=1,max_bq 43 if(bq_ncent(i).eq.-1) then 44 bq_create = .true. 45 bq_name(i) = namespace 46 bq_ncent(i) = 0 47 handle = i 48 return 49 end if 50 end do 51 52 return 53 end 54 55 function bq_get_handle(namespace,handle) 56 implicit none 57#include "mafdecls.fh" 58#include "bq_data.fh" 59#include "errquit.fh" 60#include "rtdb.fh" 61 character*(*) namespace 62 logical bq_get_handle 63c local variables 64 integer i 65 integer handle 66 67 logical bq_check_handle 68 external bq_check_handle 69 70 bq_get_handle = .false. 71 do i=1,max_bq 72 if(bq_name(i).eq.namespace.and.bq_check_handle(i)) then 73 bq_get_handle = .true. 74 handle = i 75 return 76 end if 77 end do 78 79 return 80 end 81 82 function bq_activate(handle) 83 implicit none 84#include "mafdecls.fh" 85#include "bq_data.fh" 86#include "errquit.fh" 87#include "rtdb.fh" 88 integer handle 89 logical bq_activate 90c local variables 91 integer i 92 93 logical bq_check_handle 94 external bq_check_handle 95 96 bq_activate = .true. 97 if(.not.bq_check_handle(handle)) then 98 bq_activate = .false. 99 write(*,*) "bq handle is out of bounds" 100 return 101 end if 102 if(bq_ncent(handle).eq.0) then 103 bq_activate = .false. 104 write(*,*) "bq ncent is zero" 105 return 106 end if 107 108 do i=1,max_bq 109 bq_active(i)=.false. 110 end do 111 112 bq_active(handle) = .true. 113 114 return 115 end 116 117 function bq_deactivate(handle) 118 implicit none 119#include "mafdecls.fh" 120#include "bq_data.fh" 121#include "errquit.fh" 122#include "rtdb.fh" 123 integer handle 124 logical bq_deactivate 125c local variables 126 127 logical bq_check_handle 128 external bq_check_handle 129 130 bq_deactivate = .true. 131 if(.not.bq_check_handle(handle)) then 132 bq_deactivate = .false. 133 return 134 end if 135 if(bq_ncent(handle).eq.0) then 136 bq_deactivate = .false. 137 return 138 end if 139 140 bq_active(handle) = .false. 141 142 return 143 end 144 145 function bq_get_active(handle) 146 implicit none 147#include "mafdecls.fh" 148#include "bq_data.fh" 149#include "errquit.fh" 150#include "rtdb.fh" 151 integer handle 152 logical bq_get_active 153c local variables 154 integer i 155 156 logical bq_check_handle 157 external bq_check_handle 158 159 do i=1,max_bq 160 if(bq_active(i)) then 161 bq_get_active = .true. 162 handle = i 163 return 164 end if 165 end do 166 167 bq_get_active = .false. 168 169 return 170 end 171C> 172C> \brief Set the coordinates and charges for a Bq instance 173C> 174C> Allocates memory and associates it with the Bq instance and 175C> initializes that memory with the charges and coordinates provided. 176C> The Bq instance assumes responsibility for the memory. I.e. 177C> the memory will be deallocated when the Bq instance is eventually 178C> destroyed. 179C> 180 function bq_set(handle,n,q,c) 181 implicit none 182#include "mafdecls.fh" 183#include "bq_data.fh" 184#include "errquit.fh" 185#include "rtdb.fh" 186 integer handle !< [Input] The Bq instance handle 187 integer n !< [Input] The number of centers 188 double precision q(n) !< [Input] The charges 189 double precision c(3*n) !< [Input] The coordinates 190 logical bq_set 191c local variables 192 integer i 193 integer h_c,i_c 194 integer h_q,i_q 195 character*(32) pname 196 197 logical bq_check_handle 198 external bq_check_handle 199 200 pname = "bq_set" 201 202 if(.not.bq_check_handle(handle)) then 203 bq_set = .false. 204 return 205 else 206 bq_set = .true. 207 end if 208c 209c If there is 210c - already memory associated with this Bq instance 211c - but it is not enough to hold the new data and 212c - the Bq instance is responsible for this memory 213c then 214c free the memory before allocating new memory to avoid 215c memory leaks 216c 217 if (bq_ncent(handle).ne.0.and.bq_ncent(handle).lt.n) then 218 h_c = bq_coord(handle) 219 h_q = bq_charge(handle) 220 if (bq_mem(handle)) then 221 if (.not.ma_free_heap(h_c)) 222 & call errquit(pname//' unable to free heap space', 223 & h_c,MA_ERR) 224 if (.not.ma_free_heap(h_q)) 225 & call errquit(pname//' unable to free heap space', 226 & h_q,MA_ERR) 227 endif 228 bq_ncent(handle) = 0 229 endif 230c 231c If this Bq instance has no memory then 232c allocate some 233c else 234c look up the offsets 235c 236 if (bq_ncent(handle).eq.0) then 237 if(.not.ma_alloc_get(MT_DBL, 3*n, 'bqdata c', 238 & h_c, i_c) ) call errquit( 239 & pname//' unable to allocate heap space', 240 & 3*n, MA_ERR) 241 242 if(.not.ma_alloc_get(MT_DBL, n, 'bqdata q', 243 & h_q, i_q) ) call errquit( 244 & pname//' unable to allocate heap space', 245 & n, MA_ERR) 246 else 247 h_c = bq_coord(handle) 248 h_q = bq_charge(handle) 249 if(.not.ma_get_index( h_c, i_c) ) call errquit( 250 & pname//' unable to locate coord handle', 251 & 0, MA_ERR) 252 253 if(.not.ma_get_index( h_q, i_q) ) call errquit( 254 & pname//' unable to locate charge handle', 255 & 0, MA_ERR) 256 endif 257 258 259 do i=1,n 260 dbl_mb(i_q+i-1) = q(i) 261 end do 262 263 do i=1,3*n 264 dbl_mb(i_c+i-1) = c(i) 265 end do 266 267 bq_ncent(handle) = n 268 bq_charge(handle) = h_q 269 bq_coord(handle) = h_c 270 bq_mem(handle) = .true. 271 272 return 273 end 274C> 275C> \brief Allocate and initialize space for a Bq instance 276C> 277C> This routine always allocates and initializes memory for this Bq 278C> instance. If this instance already has memory associated with it 279C> and if this memory is the responsibility of the Bq instance it will 280C> deallocated. 281C> 282C> \return Return .true. if successful and .false. otherwise. 283C> 284 function bq_alloc(handle,n) 285 implicit none 286#include "mafdecls.fh" 287#include "bq_data.fh" 288#include "errquit.fh" 289#include "rtdb.fh" 290 integer handle !< [Input] The Bq instance handle 291 integer n !< [Input] The number of centers 292 logical bq_alloc 293c local variables 294 integer i 295 integer h_c,i_c 296 integer h_q,i_q 297 character*(32) pname 298 299 logical bq_check_handle 300 external bq_check_handle 301 302 pname = "bq_alloc" 303 304 if(.not.bq_check_handle(handle)) then 305 bq_alloc = .false. 306 return 307 else 308 bq_alloc = .true. 309 end if 310 311 if(bq_ncent(handle).ne.0.and.bq_mem(handle)) then 312 h_c = bq_coord(handle) 313 h_q = bq_charge(handle) 314 if (.not.ma_free_heap(h_c)) 315 & call errquit(pname//' unable to free heap space', 316 & h_c,MA_ERR) 317 if (.not.ma_free_heap(h_q)) 318 & call errquit(pname//' unable to free heap space', 319 & h_q,MA_ERR) 320 bq_ncent(handle) = 0 321 endif 322 323 if(.not.ma_alloc_get(MT_DBL, 3*n, 'bqdata c', 324 & h_c, i_c) ) call errquit( 325 & pname//' unable to allocate heap space', 326 & 3*n, MA_ERR) 327 328 if(.not.ma_alloc_get(MT_DBL, n, 'bqdata q', 329 & h_q, i_q) ) call errquit( 330 & pname//' unable to allocate heap space', 331 & n, MA_ERR) 332 333 334 do i=1,n 335 dbl_mb(i_q+i-1) = 0.0d0 336 end do 337 338 do i=1,3*n 339 dbl_mb(i_c+i-1) = 0.0d0 340 end do 341 342 bq_ncent(handle) = n 343 bq_charge(handle) = h_q 344 bq_coord(handle) = h_c 345 bq_mem(handle) = .true. 346 347 return 348 end 349C> 350C> \brief Associate memory handles with a Bq instance 351C> 352C> This function associates chunks of memory containing the charges 353C> and the coordinates with a Bq instance. The memory is supposed to 354C> be allocated on the heap in the calling routine. The memory remains 355C> the responsibility of the application. I.e. if the Bq instance is 356C> destroyed the memory chunks will not be deallocated. 357C> To set the memory chunks and transfer the associated responsibility 358C> to the Bq instance use bq_pset_mem instead. 359C> 360C> Any memory that was associated with this Bq instance and was the 361C> responsibility of the Bq instance will be deallocated before the 362C> new memory gets associated. 363C> 364C> \return Returns .true. if successfull and .false. otherwise. 365C> 366 function bq_pset(handle,n,h_q,h_c) 367 implicit none 368#include "mafdecls.fh" 369#include "bq_data.fh" 370#include "errquit.fh" 371#include "rtdb.fh" 372 integer handle !< [Input] The Bq instance handle 373 integer n !< [Input] The number of centers 374 integer h_q !< [Input] The memory handle for the charges 375 integer h_c !< [Input] The memory handle for the coordinates 376 logical bq_pset 377c local variables 378 character*(32) pname 379 380 logical bq_check_handle 381 external bq_check_handle 382 383 pname = "bq_pset" 384 385 if(.not.bq_check_handle(handle)) then 386 bq_pset = .false. 387 return 388 else 389 bq_pset = .true. 390 end if 391 392 if(bq_ncent(handle).ne.0.and.bq_mem(handle)) then 393 h_c = bq_coord(handle) 394 h_q = bq_charge(handle) 395 if (.not.ma_free_heap(h_c)) 396 & call errquit(pname//' unable to free heap space', 397 & h_c,MA_ERR) 398 if (.not.ma_free_heap(h_q)) 399 & call errquit(pname//' unable to free heap space', 400 & h_q,MA_ERR) 401 bq_ncent(handle) = 0 402 endif 403 404 bq_ncent(handle) = n 405 bq_charge(handle) = h_q 406 bq_coord(handle) = h_c 407 bq_mem(handle) = .false. 408 409 return 410 end 411C> 412C> \brief Transfer memory handles and associated responsibility to a Bq 413C> instance 414C> 415C> This function associates chunks of memory containing the charges 416C> and the coordinates with a Bq instance, and transfers the 417C> responsibility for managing this memory as well. 418C> The memory is supposed to be allocated on the heap in the calling 419C> routine. 420C> To set the memory chunks and not transfer the associated 421C> responsibility to the Bq instance use bq_pset instead. 422C> 423C> Any memory that was associated with this Bq instance and was the 424C> responsibility of the Bq instance will be deallocated before the 425C> new memory gets associated. 426C> 427C> \return Returns .true. if successfull and .false. otherwise. 428C> 429 function bq_pset_mem(handle,n,h_q,h_c) 430 implicit none 431#include "mafdecls.fh" 432#include "bq_data.fh" 433#include "errquit.fh" 434#include "rtdb.fh" 435 integer handle !< [Input] The Bq instance handle 436 integer n !< [Input] The number of centers 437 integer h_q !< [Input] The memory handle for the charges 438 integer h_c !< [Input] The memory handle for the coordinates 439 logical bq_pset_mem 440c local variables 441 character*(32) pname 442 443 logical bq_check_handle 444 external bq_check_handle 445 446 pname = "bq_pset_mem" 447 448 if(.not.bq_check_handle(handle)) then 449 bq_pset_mem = .false. 450 return 451 else 452 bq_pset_mem = .true. 453 end if 454 455 if(bq_ncent(handle).ne.0.and.bq_mem(handle)) then 456 h_c = bq_coord(handle) 457 h_q = bq_charge(handle) 458 if (.not.ma_free_heap(h_c)) 459 & call errquit(pname//' unable to free heap space', 460 & h_c,MA_ERR) 461 if (.not.ma_free_heap(h_q)) 462 & call errquit(pname//' unable to free heap space', 463 & h_q,MA_ERR) 464 bq_ncent(handle) = 0 465 endif 466 467 bq_ncent(handle) = n 468 bq_charge(handle) = h_q 469 bq_coord(handle) = h_c 470 bq_mem(handle) = .true. 471 472 return 473 end 474 475 function bq_get(handle,n,q,c) 476 implicit none 477#include "mafdecls.fh" 478#include "bq_data.fh" 479#include "errquit.fh" 480#include "rtdb.fh" 481 integer handle 482 integer n 483 double precision q(n) 484 double precision c(3*n) 485 logical bq_get 486c local variables 487 integer i 488 integer h_c,i_c 489 integer h_q,i_q 490 character*(32) pname 491 492 logical bq_check_handle 493 external bq_check_handle 494 495 pname = "bq_get" 496 497 if(.not.bq_check_handle(handle)) then 498 bq_get = .false. 499 return 500 else 501 bq_get = .true. 502 end if 503 504 if(n.ne.bq_ncent(handle)) then 505 bq_get = .false. 506 return 507 end if 508 509 510 h_q = bq_charge(handle) 511 h_c = bq_coord(handle) 512 513 if(.not.ma_get_index( h_c, i_c) ) call errquit( 514 & pname//' unable to locate coord handle', 515 & 0, MA_ERR) 516 517 518 if(.not.ma_get_index( h_q, i_q) ) call errquit( 519 & pname//' unable to locate charge handle', 520 & 0, MA_ERR) 521 522 do i=1,n 523 q(i) = dbl_mb(i_q+i-1) 524 end do 525 526 do i=1,3*n 527 c(i) = dbl_mb(i_c+i-1) 528 end do 529 530 return 531 end 532C> 533C> \brief Get the number of centers of a Bq instance 534C> 535 function bq_ncenter(handle,n) 536 implicit none 537#include "mafdecls.fh" 538#include "bq_data.fh" 539#include "errquit.fh" 540#include "rtdb.fh" 541 integer handle 542 integer n 543 logical bq_ncenter 544c local variables 545 character*(32) pname 546 547 logical bq_check_handle 548 external bq_check_handle 549 550 pname = "bq_ncenter" 551 552 if(.not.bq_check_handle(handle)) then 553 bq_ncenter = .false. 554 return 555 else 556 bq_ncenter = .true. 557 end if 558 559 n = bq_ncent(handle) 560 561 return 562 end 563 564 function bq_namespace(handle,namespace) 565 implicit none 566#include "mafdecls.fh" 567#include "bq_data.fh" 568#include "errquit.fh" 569#include "rtdb.fh" 570 integer handle 571 character*(*) namespace 572 logical bq_namespace 573c local variables 574 character*(32) pname 575 576 logical bq_check_handle 577 external bq_check_handle 578 579 pname = "bq_namespace" 580 581 if(.not.bq_check_handle(handle)) then 582 bq_namespace = .false. 583 return 584 else 585 bq_namespace = .true. 586 end if 587 588 namespace = bq_name(handle) 589 590 return 591 end 592 593 function bq_check_handle(handle) 594 implicit none 595#include "mafdecls.fh" 596#include "bq_data.fh" 597#include "errquit.fh" 598#include "rtdb.fh" 599 integer handle 600 logical bq_check_handle 601c local variables 602 603 if(handle .lt.1 .or. handle .gt. max_bq) then 604 bq_check_handle = .false. 605 else if (bq_ncent(handle).eq.-1) then 606 bq_check_handle = .false. 607 else 608 bq_check_handle = .true. 609 end if 610 611 return 612 end 613 614 subroutine bq_print_info(handle) 615 implicit none 616#include "mafdecls.fh" 617#include "bq_data.fh" 618#include "errquit.fh" 619#include "rtdb.fh" 620#include "util.fh" 621#include "global.fh" 622 623 integer handle 624c local variables 625 integer i,printlevel 626 integer k 627 integer h_c,i_c 628 integer h_q,i_q 629 character*(32) pname 630 logical status,oprint 631 double precision bq_charge_total 632 633 logical bq_check_handle 634 external bq_check_handle 635 636 pname = "bq_print_info" 637 638 call util_print_get_level(printlevel) 639 oprint = (ga_nodeid().eq.0).and.(printlevel.le.print_medium) 640 641 if(.not.bq_check_handle(handle)) then 642 call errquit( 643 & pname//' unable to locate handle ', 644 & 0,0) 645 end if 646 647 if(bq_ncent(handle).eq.0) then 648 write(*,*) "No charges are found" 649 return 650 end if 651 652 h_q = bq_charge(handle) 653 h_c = bq_coord(handle) 654 655 if(.not.ma_get_index( h_c, i_c) ) call errquit( 656 & pname//' unable to locate coord handle', 657 & 0, MA_ERR) 658 659 660 if(.not.ma_get_index( h_q, i_q) ) call errquit( 661 & pname//' unable to locate charge handle', 662 & 0, MA_ERR) 663 664 if (oprint) then 665 call util_print_centered(6, 666 > "Bq Structure Information (Angstroms)", 667 > 36, .true.) 668 669 write(*,*) "Name: ", bq_name(handle) 670 write(*,*) "Number of centers: ",bq_ncent(handle) 671 672c == tally up bq charges == 673 bq_charge_total = 0.d0 674 do i=1,bq_ncent(handle) 675 write(6,FMT=9000) 676c > i,(dbl_mb(i_c+3*(i-1)+k-1),k=1,3), 677 > i,(dbl_mb(i_c+3*(i-1)+k-1)*0.529177249d00,k=1,3), 678 > dbl_mb(i_q+i-1) 679 bq_charge_total = bq_charge_total + dbl_mb(i_q+i-1) 680 end do 681 write(*,*) "Total Bq charge: ",bq_charge_total 682 write(*,*) 683 write(*,*) 684c 685 end if 6869000 format(i5,2x,"Bq",4x,3f15.8,3x,"charge",3x,f15.8) 687 688 return 689 end 690C> 691C> \brief Destroy a Bq instance 692C> 693C> Destroys a Bq instance. Whether the memory for the coordinates 694C> and the charges is deallocated depends on how this memory was 695C> associated with the Bq instance. 696C> 697 function bq_destroy(handle) 698 implicit none 699#include "mafdecls.fh" 700#include "bq_data.fh" 701#include "errquit.fh" 702#include "rtdb.fh" 703 integer handle 704 logical bq_destroy 705c local variables 706 integer h_c 707 integer h_q 708 character*(32) pname 709 710 logical bq_check_handle 711 external bq_check_handle 712 713 pname = "bq_destroy" 714 715 bq_destroy = .true. 716 717 if(.not.bq_check_handle(handle)) then 718 bq_destroy = .false. 719 return 720 else 721 bq_destroy = .true. 722 end if 723 724 bq_name(handle)=" " 725 bq_active(handle)=.false. 726 727 if(bq_ncent(handle).eq.0) then 728 bq_ncent(handle) = -1 729 return 730 else 731 bq_ncent(handle) = -1 732 endif 733 734 if(.not.bq_mem(handle)) return 735 bq_mem(handle) = .false. 736 737 h_q = bq_charge(handle) 738 h_c = bq_coord(handle) 739 740 if(.not.ma_free_heap(h_q)) 741 & call errquit( 742 & pname//' unable to deallocate heap space', 743 & 0, MA_ERR) 744 745 if(.not.ma_free_heap(h_c)) 746 & call errquit( 747 & pname//' unable to deallocate heap space', 748 & 0, MA_ERR) 749 750 751 return 752 end 753C> 754C> \brief Destroy all Bq instances 755C> 756 function bq_destroy_all() 757 implicit none 758#include "mafdecls.fh" 759#include "bq_data.fh" 760#include "errquit.fh" 761#include "rtdb.fh" 762 integer handle 763 logical bq_destroy_all 764c local variables 765 character*(32) pname 766 767 logical bq_destroy 768 external bq_destroy 769 770 logical bq_check_handle 771 external bq_check_handle 772 773 pname = "bq_destroy_all" 774 775 bq_destroy_all = .false. 776 777 do handle=1,max_bq 778 if(bq_check_handle(handle)) then 779 if(.not.bq_destroy(handle)) return 780 endif 781 end do 782 bq_destroy_all = .true. 783 784 return 785 end 786C> 787C> \brief Retrieve the memory index for the coordinates of a Bq instance 788C> 789 function bq_index_coord(handle,i_c) 790 implicit none 791#include "mafdecls.fh" 792#include "bq_data.fh" 793#include "errquit.fh" 794 integer handle !< [Input] The Bq instance handle 795 logical bq_index_coord 796c local variables 797 integer h_c 798 integer i_c !< [Output] The coordinates memory index 799 character*(32) pname 800 801 logical bq_check_handle 802 external bq_check_handle 803 804 pname = "bq_index_coord" 805 806 if(.not.bq_check_handle(handle)) then 807 bq_index_coord = .false. 808 return 809 else 810 bq_index_coord = .true. 811 end if 812 813 h_c = bq_coord(handle) 814 815 if(.not.ma_get_index( h_c, i_c) ) call errquit( 816 & pname//' uunable to locate coord handle', 817 & 0, MA_ERR) 818 819 return 820 end 821C> 822C> \brief Retrieve the memory index for the charges of a Bq instance 823C> 824 function bq_index_charge(handle,i_q) 825 implicit none 826#include "mafdecls.fh" 827#include "bq_data.fh" 828#include "errquit.fh" 829 integer handle !< [Input] The Bq instance handle 830 logical bq_index_charge 831c local variables 832 integer h_q 833 integer i_q !< [Output] The charges memory index 834 character*(32) pname 835 836 logical bq_check_handle 837 external bq_check_handle 838 839 pname = "bq_index_charge" 840 841 if(.not.bq_check_handle(handle)) then 842 bq_index_charge = .false. 843 return 844 else 845 bq_index_charge = .true. 846 end if 847 848 h_q = bq_charge(handle) 849 850 if(.not.ma_get_index( h_q, i_q) ) call errquit( 851 & pname//' unable to locate charge handle', 852 & 0, MA_ERR) 853 854 return 855 end 856 857 subroutine bq_force_status(rtdb,ostatus) 858 implicit none 859#include "mafdecls.fh" 860#include "bq_data.fh" 861#include "rtdb.fh" 862#include "errquit.fh" 863 integer rtdb 864 logical ostatus 865c 866 external bq_on 867 logical bq_on 868c local variables 869 integer i 870 871 logical bq_check_handle 872 external bq_check_handle 873 874 ostatus = .false. 875 876 if(.not.bq_on()) return 877 if(.not. rtdb_get(rtdb,"bq:force",mt_log,1,ostatus)) 878 > ostatus = .false. 879 880 return 881 end 882 883 884 function bq_on() 885 implicit none 886#include "bq_data.fh" 887#include "errquit.fh" 888 logical bq_on 889c local variables 890 integer i 891 892 logical bq_check_handle 893 external bq_check_handle 894 895 bq_on = .false. 896 897 do i=1,max_bq 898 if(bq_active(i).and.bq_ncent(i).gt.0) then 899 bq_on = .true. 900 return 901 end if 902 end do 903 904 return 905 end 906 907 subroutine bq_print_xyz(handle,un) 908 implicit none 909#include "mafdecls.fh" 910#include "bq_data.fh" 911#include "errquit.fh" 912#include "rtdb.fh" 913#include "util.fh" 914#include "global.fh" 915 916 integer handle 917 integer un 918c local variables 919 integer i,printlevel 920 integer k 921 integer h_c,i_c 922 integer h_q,i_q 923 character*(32) pname 924 logical status,oprint 925 926 logical bq_check_handle 927 external bq_check_handle 928 929 pname = "bq_print_info" 930 931 call util_print_get_level(printlevel) 932 oprint = (ga_nodeid().eq.0).and.(printlevel.le.print_medium) 933 934 if(.not.bq_check_handle(handle)) then 935 call errquit( 936 & pname//' unable to locate handle ', 937 & 0,0) 938 end if 939 940 if(bq_ncent(handle).eq.0) then 941 write(*,*) "No charges are found" 942 return 943 end if 944 945 h_q = bq_charge(handle) 946 h_c = bq_coord(handle) 947 948 if(.not.ma_get_index( h_c, i_c) ) call errquit( 949 & pname//' unable to locate coord handle', 950 & 0, MA_ERR) 951 952 953 if(.not.ma_get_index( h_q, i_q) ) call errquit( 954 & pname//' unable to locate charge handle', 955 & 0, MA_ERR) 956 957 write(un,*) bq_ncent(handle) 958 write(un,*) 959 do i=1,bq_ncent(handle) 960 write(un,FMT=9000) 961 > i,(dbl_mb(i_c+3*(i-1)+k-1)*0.529177249d00,k=1,3), 962 > dbl_mb(i_q+i-1) 963 964 end do 965 write(*,*) 966 write(*,*) 967 9689000 format(i5,2x,"Bq",4x,4f15.8) 969 970 return 971 end 972 973 subroutine bq_print_xyzq(handle,un) 974 implicit none 975#include "mafdecls.fh" 976#include "bq_data.fh" 977#include "errquit.fh" 978#include "rtdb.fh" 979#include "util.fh" 980#include "global.fh" 981 982 integer handle 983 integer un 984c local variables 985 integer i,printlevel 986 integer k 987 integer h_c,i_c 988 integer h_q,i_q 989 character*(32) pname 990 logical status,oprint 991 992 logical bq_check_handle 993 external bq_check_handle 994 995 pname = "bq_print_info" 996 997 call util_print_get_level(printlevel) 998 oprint = (ga_nodeid().eq.0).and.(printlevel.le.print_medium) 999 1000 if(.not.bq_check_handle(handle)) then 1001 call errquit( 1002 & pname//' unable to locate handle ', 1003 & 0,0) 1004 end if 1005 1006 if(bq_ncent(handle).eq.0) then 1007 write(*,*) "No charges are found" 1008 return 1009 end if 1010 1011 h_q = bq_charge(handle) 1012 h_c = bq_coord(handle) 1013 1014 if(.not.ma_get_index( h_c, i_c) ) call errquit( 1015 & pname//' unable to locate coord handle', 1016 & 0, MA_ERR) 1017 1018 1019 if(.not.ma_get_index( h_q, i_q) ) call errquit( 1020 & pname//' unable to locate charge handle', 1021 & 0, MA_ERR) 1022 1023 write(un,*) bq_ncent(handle) 1024 write(un,*) 1025 do i=1,bq_ncent(handle) 1026 write(un,FMT=9000) 1027 > i,(dbl_mb(i_c+3*(i-1)+k-1)*0.529177249d00,k=1,3), 1028 > dbl_mb(i_q+i-1) 1029 1030 end do 1031 write(*,*) 1032 write(*,*) 1033 10349000 format(i5,2x,"Bq",4x,4f15.8) 1035 1036 return 1037 end 1038C> @} 1039