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