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