1c $Id$
2*
3C> \ingroup nwint
4C> @{
5C>
6C> \brief Calculate the dipole velocity integrals
7C>
8C> Compute the dipole velocity integrals for a given shell pair.
9C> Apparently this routine is currently not used anywhere.
10C>
11c:tex-% this is part of the API Standard Integral routines.
12c:tex-\subsection{int\_dipvel}
13c:tex-This routine computes the dipole dipvelity integrals
14c:tex-{\it Syntax:}
15c:tex-\begin{verbatim}
16      subroutine int_dipvel(i_basis,ish,j_basis,jsh,lscr,scr,lh11,h11)
17c:tex-\end{verbatim}
18      implicit none
19#include "nwc_const.fh"
20#include "errquit.fh"
21#include "basP.fh"
22#include "basdeclsP.fh"
23#include "geomP.fh"
24#include "geobasmapP.fh"
25#include "mafdecls.fh"
26#include "bas_exndcf_dec.fh"
27#include "bas_ibs_dec.fh"
28#include "int_nbf.fh"
29#include "stdio.fh"
30#include "apiP.fh"
31#include "util.fh"
32c::external subroutines used
33c... errquit
34c::functions
35      logical cando_hnd_1e_prp
36      logical int_chk_init
37      logical int_chk_sh
38      external int_chk_init
39      external int_chk_sh
40      external cando_hnd_1e_prp
41c::passed
42c:tex-\begin{verbatim}
43      integer i_basis !< [Input] basis set handle for ish
44      integer ish     !< [Input] i shell/contraction
45      integer j_basis !< [Input] basis set handle for jsh
46      integer jsh     !< [Input] j shell/contraction
47      integer lscr    !< [Input] length of scratch array
48      double precision scr(lscr) !< [Scratch] scratch array
49      integer lh11               !< [Input] length of h11 buffer
50      double precision h11(lh11) !< [Output] h11 integrals
51c:tex-\end{verbatim}
52c::local
53      integer igeom, jgeom, ibas, jbas, ucont
54      integer itype, inp, igen, iexp, icent, icf, iatom
55      integer jtype, jnp, jgen, jexp, jcent, jcf, jatom
56c
57      logical any_spherical, trani, tranj, shells_ok
58      integer i_nbf_x, j_nbf_x
59      integer i_nbf_s, j_nbf_s
60      integer ipts, ncartint ,i,j
61c
62#include "bas_exndcf_sfn.fh"
63#include "bas_ibs_sfn.fh"
64c
65c check initialization and shells
66c
67      if (.not.int_chk_init('int_dipvel'))
68     &       call errquit('int_dipvel: int_init was not called' ,0,
69     &       INT_ERR)
70c
71      shells_ok = int_chk_sh(i_basis,ish)
72      shells_ok = shells_ok .and. int_chk_sh(j_basis,jsh)
73      if (.not.shells_ok)
74     &       call errquit('int_dipvel: invalid contraction/shell',0,
75     &       INT_ERR)
76c
77c  check if gencont
78c
79      call int_nogencont_check(i_basis,'int_dipvel:i_basis')
80      call int_nogencont_check(j_basis,'int_dipvel:j_basis')
81c
82      ibas = i_basis + basis_handle_offset
83      jbas = j_basis + basis_handle_offset
84c
85      ucont = (sf_ibs_cn2ucn(ish,ibas))
86      itype = infbs_cont(CONT_TYPE ,ucont,ibas)
87      inp   = infbs_cont(CONT_NPRIM,ucont,ibas)
88      igen  = infbs_cont(CONT_NGEN ,ucont,ibas)
89      iexp  = infbs_cont(CONT_IEXP ,ucont,ibas)
90      icf   = infbs_cont(CONT_ICFP ,ucont,ibas)
91      iatom = (sf_ibs_cn2ce(ish,ibas))
92      igeom = ibs_geom(ibas)
93c
94      ucont = (sf_ibs_cn2ucn(jsh,jbas))
95      jtype = infbs_cont(CONT_TYPE ,ucont,jbas)
96      jnp   = infbs_cont(CONT_NPRIM,ucont,jbas)
97      jgen  = infbs_cont(CONT_NGEN ,ucont,jbas)
98      jexp  = infbs_cont(CONT_IEXP ,ucont,jbas)
99      jcf   = infbs_cont(CONT_ICFP ,ucont,jbas)
100      jatom = (sf_ibs_cn2ce(jsh,jbas))
101      jgeom = ibs_geom(jbas)
102c
103      if (igeom.ne.jgeom) then
104        write(luout,*)'int_dipvel: two different geometries for',
105     &         ' properties?'
106        call errquit('int_dipvel: geom error ',911, GEOM_ERR)
107      endif
108c
109c     Determine # of cartesian integrals in block
110c
111      ncartint = int_nbf_x(itype)*int_nbf_x(jtype)
112c
113      call hnd_dipvel(
114     &       coords(1,iatom,igeom),
115     &       dbl_mb(mb_exndcf(iexp,ibas)),
116     &       dbl_mb(mb_exndcf(icf,ibas)),
117     &       inp,igen,itype,
118c
119     &       coords(1,jatom,jgeom),
120     &       dbl_mb(mb_exndcf(jexp,jbas)),
121     &       dbl_mb(mb_exndcf(jcf,jbas)),
122     &       jnp,jgen,jtype,
123c
124     &       ncartint,h11,scr,lscr)
125c
126c     h11 now has three blocks
127c
128      any_spherical = bas_spherical(ibas).or.bas_spherical(jbas)
129      if (.not.any_spherical) return
130c
131      i_nbf_x = int_nbf_x(itype)
132      j_nbf_x = int_nbf_x(jtype)
133c
134c... assume we need to transform both i and j integrals
135c
136      trani = .true.
137      tranj = .true.
138*.. do not tranform i component
139      if (.not.bas_spherical(ibas)) trani = .false.
140*.. do not tranform j component
141      if (.not.bas_spherical(jbas)) tranj = .false.
142c
143c ... reset general contractions for sp shells to 1 since they are handled
144c     as a block of 4.
145c
146      if (itype.eq.-1) igen = 1
147      if (jtype.eq.-1) jgen = 1
148      call spcart_2cBtran(h11,scr,lscr,
149     &    j_nbf_x,int_nbf_s(jtype),jtype,jgen,tranj,
150     &    i_nbf_x,int_nbf_s(itype),itype,igen,trani,
151     &    3,.false.)
152c
153c     We now have the integrals in array (nsph_ints,3)
154c
155      return
156      end
157C> @}
158