1C:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
2C NAME
3C     RIMP2_NS2_2e2c -- 2c2e derivative integrals for non-sep 2-c
4C     contribution to gradient
5C
6C REVISION./rimp2_grad/ns2_2e2c.F
7C     $Id$
8C
9C SYNOPSIS
10      Subroutine RIMP2_NS2_2e2c(FitBas, Buf, LBuf, Scr, LScr, g_V,
11     $     Grad, NCent)
12      Implicit NONE
13#include "errquit.fh"
14      Integer FitBas            ![in]
15      Integer LBuf              ![in]
16      Double Precision Buf(LBuf) ![in]
17      Integer LScr              ![in]
18      Double precision Scr(LScr) ![in]
19      Integer g_V               ![in]
20      Integer NCent             ![in]
21      Double precision Grad(3, NCent) ![inout]
22C
23C DESCRIPTION
24C PRINT CONTROLS
25C EXTERNAL ROUTINES
26C INCLUDE FILES
27#include "stdio.fh"
28#include "bas.fh"
29#include "mafdecls.fh"
30#include "global.fh"
31#include "msgids.fh"
32C:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
33C CONSTANTS
34C LOCAL VARIABLES
35      Integer Me, First, Last
36      Integer ILo, IHi, JLo, JHi, NI, NJ
37      Integer ILoCn, IHiCn, JLoCn, JHiCn, ICn, JCn
38      Integer H_Patch, I_Patch
39      Integer Atoms(2), A
40      Double precision Grad_Contrib(3, 2) ! xyz for each atom
41C
42C STATEMENT FUNCTIONS
43C
44      Me = GA_NodeID()
45C
46C     Identify our patch of g_V
47C
48      Call GA_Distribution(g_V, Me, ILo, IHi, JLo, JHi)
49C
50C     Figure out which contractions the patch correponds to
51C
52      If ( .NOT. Bas_BF2Cn(FitBas, ILo, ILoCn) ) Call ErrQuit(
53     $     'RIMP2_NS2_2e2c: bas_bf2cn failed ', ILo, BASIS_ERR)
54      If ( .NOT. Bas_BF2Cn(FitBas, IHi, IHiCn) ) Call ErrQuit(
55     $     'RIMP2_NS2_2e2c: bas_bf2cn failed ', IHi, BASIS_ERR)
56      If ( .NOT. Bas_BF2Cn(FitBas, JLo, JLoCn) ) Call ErrQuit(
57     $     'RIMP2_NS2_2e2c: bas_bf2cn failed ', JLo, BASIS_ERR)
58      If ( .NOT. Bas_BF2Cn(FitBas, JHi, JHiCn) ) Call ErrQuit(
59     $     'RIMP2_NS2_2e2c: bas_bf2cn failed ', JHi, BASIS_ERR)
60C
61      Write (LuOut, *) 'RIMP2_NS2_2e2c: initial patch ',
62     $     Me, ILo, IHi, JLo, JHi, ILoCn, IHiCn, JLoCn, JHiCn
63C
64C     Adjust patch to match shell boundaries.
65C
66C     Left and top edges: If they don't start at the beginning of a
67C     shell already, shift to start of NEXT contraction.
68C
69      If ( .NOT. Bas_Cn2BFR(FitBas, ILoCn, First, Last) ) Call
70     $     ErrQuit( 'RIMP2_NS2_2e2c: bas_cn2bfr failed', ILoCn,
71     &       BASIS_ERR)
72      If ( ILo .ne. First) then
73         ILoCn = ILoCn + 1
74         ILo = First + 1
75      EndIf
76C
77      If ( .NOT. Bas_Cn2BFR(FitBas, JLoCn, First, Last) ) Call
78     $     ErrQuit( 'RIMP2_NS2_2e2c: bas_cn2bfr failed', JLoCn,
79     &       BASIS_ERR)
80      If ( JLo .ne. First) then
81         JLoCn = JLoCn + 1
82         JLo = First + 1
83      EndIf
84C
85C     Right and bottom edges: simply extend to end of current contraction
86C
87      If ( .NOT. Bas_Cn2BFR(FitBas, IHiCn, First, Last) ) Call
88     $     ErrQuit( 'RIMP2_NS2_2e2c: bas_cn2bfr failed', IHiCn,
89     &       BASIS_ERR)
90      If ( IHi .ne. Last) IHi = Last
91C
92      If ( .NOT. Bas_Cn2BFR(FitBas, JHiCn, First, Last) ) Call
93     $     ErrQuit( 'RIMP2_NS2_2e2c: bas_cn2bfr failed', JHiCn,
94     &       BASIS_ERR)
95      If ( JHi .ne. Last) JHi = Last
96C
97      Write (LuOut, *) 'RIMP2_NS2_2e2c: adjusted patch ',
98     $     Me, ILo, IHi, JLo, JHi, ILoCn, IHiCn, JLoCn, JHiCn
99C
100C     Allocate for, and get our patch.
101C     If Buf(LBuf) is sufficient for up to 6 derivatives of a shell
102C     block, it is certainly large enough to hold a patch of g_V
103C     to contract them with.
104C
105      If ( .NOT. MA_Push_Get(MT_Dbl, LBuf, 'local g_V patch',
106     $     H_Patch, I_Patch) ) Call ErrQuit(
107     $     'RIMP2_NS2_2e2c: failed to allocate for local patch', LBuf,
108     &       MA_ERR)
109C
110C     Loop over our shells
111C
112      Do ICn = ILoCn, IHiCn
113         Do JCn = JLoCn, JHiCn
114C
115C           Compute integrals
116C
117            Call IntD_2e2c(FitBas, JCn, FitBas, ICn, LScr, Scr,
118     $           LBuf, Buf, Atoms)
119C
120C           Check to see if we have integrals to deal with
121C           (same-center derivatives are zero by translational
122C           invariance.  The integral routine indicates this by
123C           setting Atoms to something negative)
124C
125            If (Atoms(1) .gt. 0 .AND. Atoms(2) .gt. 0) then
126C
127C              Figure out the basis function ranges.
128C
129               If ( .NOT. Bas_Cn2BFR(FitBas, ICn, ILo, IHi) ) Call
130     $              ErrQuit( 'RIMP2_NS2_2e2c: bas_cn2bfr failed', ICn,
131     &       BASIS_ERR)
132               If ( .NOT. Bas_Cn2BFR(FitBas, JCn, JLo, JHi) ) Call
133     $              ErrQuit( 'RIMP2_NS2_2e2c: bas_cn2bfr failed', JCn,
134     &       BASIS_ERR)
135C
136               NI = IHi - ILo + 1
137               NJ = JHi - JLo + 1
138C
139C              Get corresponding patch
140C
141               Call GA_Get(g_V, ILo, IHi, JLo, JHi, Dbl_MB(I_Patch), NI)
142c$$$               Write (LuOut, *) 'RIMP2_NS2_2e2c: ICn, JCn ', ICn, JCn,
143c$$$     $              ILo, IHi, JLo, JHi, NI, NJ
144c$$$               Write (LuOut, *) 'RIMP2_NS2_2e2c: Atoms 0', Atoms
145C
146C              Contract patch with integrals
147C
148               Call DGEMV('T', NI*NJ, 6, 1.0d0, Buf, NI*NJ,
149     $              Dbl_MB(I_Patch), 1, 0.0d0, Grad_Contrib, 1)
150c$$$               Write (LuOut, *) 'RIMP2_NS2_2e2c: Grad_Contrib ',
151c$$$     $              Grad_Contrib
152c$$$               Write (LuOut, *) 'RIMP2_NS2_2e2c: Atoms 1', Atoms
153C
154C              Put the gradient contributions where they belong
155C
156               Do A = 1, 2
157c$$$               Write (LuOut, *) 'RIMP2_NS2_2e2c: Atoms 2', Atoms
158c$$$                  Write (LuOut, *) 'Copying grad_contrib(1, ', A,')'
159c$$$                  Write (LuOut, *) 'to grad(1, ', Atoms(a), ')'
160                  Call DAXPY(3, 1.0d0, Grad_Contrib(1, A), 1,
161     $                 Grad(1, Atoms(A)), 1)
162               EndDo ! A
163c$$$               Write (LuOut, *) 'RIMP2_NS2_2e2c: Grad ', Grad
164C
165            EndIf               ! Integrals to process
166         EndDo                  ! JCn
167      EndDo                     ! ICn
168C
169      If ( .NOT. MA_Pop_Stack(H_Patch) ) Call ErrQuit(
170     $     'RIMP2_NS2_2e2c: failed to free patch', 0, MA_ERR)
171C
172C     Synchronize and combine gradient contributions on each node
173C
174      Call GA_Sync
175      Call GA_DGOp(9234, Grad, 3*NCent, '+')
176C
177      Return
178      End
179