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