1 subroutine dimqm_EqmN(rtdb, geom, xyz, eqmn) 2c use constants 3 implicit none 4#include "errquit.fh" 5#include "inp.fh" 6#include "rtdb.fh" 7#include "stdio.fh" 8#include "nwc_const.fh" 9#include "mafdecls.fh" 10#include "global.fh" 11#include "testutil.fh" 12#include "geom.fh" 13#include "dimqm_constants.fh" 14#include "dimqm.fh" 15#include "msgids.fh" 16c 17c Input Variables 18 integer rtdb 19 integer geom 20 double precision xyz(3, nDIM) 21 double precision eqmn(3, nDIM) 22c 23c Local Variables 24 integer mLo, mUp, mOnNode, id 25 integer nNuc 26 integer l_qmxyz, k_qmxyz 27 integer l_qmchrg, k_qmchrg 28 integer m, n 29c 30 id = ga_nodeid() 31 if(id.eq.0 .and. ldebug) write(luout,*) "Start EqmN" 32c 33c Pull in QM geometry data 34 if(.not. geom_ncent(geom, nNuc)) 35 $ call errquit("dimqm_EqmN: geom_ncent", 1, GEOM_ERR) 36c 37c Allocate memory for coords and charges 38 if(.not.ma_push_get(mt_dbl,3*nNuc,'QM xyz',l_qmxyz,k_qmxyz)) 39 $ call errquit("dimqm_EqmN malloc k_qmxyz failed", 1, MA_ERR) 40 if(.not.ma_push_get(mt_dbl,nNuc,'QM chrg',l_qmchrg,k_qmchrg)) 41 $ call errquit("dimqm_EqmN malloc k_qmchrg failed", 1, MA_ERR) 42c 43c Populate the arrays 44 if(.not.geom_cart_coords_get(geom, dbl_mb(k_qmxyz))) 45 $ call errquit("dimqm_EqmN coords get failed", 1, GEOM_ERR) 46 if(.not.geom_cart_get_charges(geom,nNuc,dbl_mb(k_qmchrg))) 47 $ call errquit("dimqm_EqmN charges get failed", 1, GEOM_ERR) 48c 49c Determine load balance 50 call pphilo(id, nDIM, mLo, mUp, mOnNode) 51c 52 do m = mLo, mUp ! Loop over DIM atoms on this node 53 do n = 1, nNuc ! Loop over all QM atoms 54c 55c Calculate potential 56 call dimqm_fldpot(xyz(:,m), dbl_mb(k_qmxyz+3*(n-1)), 57 $ dbl_mb(k_qmchrg+n-1), eqmn(:,m)) 58 end do 59 end do 60c write(luout,*) "EqmN:" 61c write(luout,*) eqmn 62 call ga_dgop(msg_dimqm, eqmn, 3*nDIM, '+') 63 call ga_sync() 64c 65c Deallocate memory 66 if(.not.ma_chop_stack(l_qmxyz)) 67 $ call errquit('dimqm_EqmN chop failed', 1, MA_ERR) 68c 69 if(id.eq.0 .and. ldebug) write(luout,*) "End EqmN" 70 end subroutine dimqm_EqmN 71