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