1#define TCGMSG
2
3
4*     ***************************
5*     *                         *
6*     *    semicore_xc_F        *
7*     *                         *
8*     ***************************
9
10      subroutine semicore_xc_F(ispin,xcp,fion)
11      implicit none
12#include "errquit.fh"
13      integer ispin
14      real*8  xcp(*)
15
16      real*8 fion(3,*)
17
18#include "bafdecls.fh"
19
20*     **** semicore common block ****
21c     real*8  ncore(nfft3d,nkatmx),rcore(nkatmx)
22c     logocal semicore(0:nkatmx)
23      integer ncore(2),rcore(2)
24      integer semicore(2)
25      common / ccore / ncore,rcore,semicore
26
27*     **** local variables ****
28      logical value
29      integer npack0,nfft3d,n2ft3d
30      integer ii,ia,nx,ny,nz
31      real*8  sumx,sumy,sumz
32      real*8  scal1,scal2
33      integer exi(2),vxcG(2)
34      integer tmpx(2),tmpy(2),tmpz(2)
35
36      common /semicore_sumxyz/ sumx,sumy,sumz
37
38*     **** external functions ****
39      integer  ion_nion,ion_katm
40      real*8   lattice_omega
41      external ion_nion,ion_katm
42      external lattice_omega
43
44
45      call D3dB_nx(1,nx)
46      call D3dB_ny(1,ny)
47      call D3dB_nz(1,nz)
48      scal1 = 1.0d0/dble(nx*ny*nz)
49      scal2 = 1.0d0/lattice_omega()
50
51      call D3dB_nfft3d(1,nfft3d)
52      call D3dB_n2ft3d(1,n2ft3d)
53      call Pack_npack(0,npack0)
54
55      value = BA_push_get(mt_dcpl,nfft3d,'exi', exi(2), exi(1))
56      value = value.and.
57     >        BA_push_get(mt_dcpl,nfft3d,'vxcG',vxcG(2),vxcG(1))
58      value = value.and.
59     >        BA_push_get(mt_dcpl, npack0,'tmpx',tmpx(2),tmpx(1))
60      value = value.and.
61     >        BA_push_get(mt_dcpl, npack0,'tmpy',tmpy(2),tmpy(1))
62      value = value.and.
63     >        BA_push_get(mt_dcpl, npack0,'tmpz',tmpz(2),tmpz(1))
64      if (.not. value) call errquit('out of stack memory',0, MA_ERR)
65
66      !write(*,*) "HERB"
67
68      !call dcopy(n2ft3d,0.0d0,0,dcpl_mb(vxcG(1)),1)
69      call Parallel_shared_vector_zero(.true.,n2ft3d,dcpl_mb(vxcG(1)))
70      call D3dB_rr_Sum(1,xcp(1),
71     >                   xcp(1+(ispin-1)*n2ft3d),
72     >                   dcpl_mb(vxcG(1)))
73      write(*,*) "INTO FFT"
74      call D3dB_rc_fft3f(1,dcpl_mb(vxcG(1)))
75      write(*,*) "OUT FFT"
76      call Pack_c_pack(0,dcpl_mb(vxcG(1)))
77
78
79      do ii=1,ion_nion()
80         ia = ion_katm(ii)
81
82         if (log_mb(semicore(1)+ia)) then
83
84*          **** structure factor and local pseudopotential ****
85           call strfac(ii,dcpl_mb(exi(1)))
86           call Pack_c_pack(0,dcpl_mb(exi(1)))
87
88*          **** put (core-density) at atom position ****
89           call Pack_tc_iMul(0,
90     >               dbl_mb(ncore(1)+(ia-1)*5*npack0+2*npack0),
91     >              dcpl_mb(exi(1)),
92     >              dcpl_mb(tmpx(1)))
93           call Pack_tc_iMul(0,
94     >               dbl_mb(ncore(1)+(ia-1)*5*npack0+3*npack0),
95     >              dcpl_mb(exi(1)),
96     >              dcpl_mb(tmpy(1)))
97           call Pack_tc_iMul(0,
98     >               dbl_mb(ncore(1)+(ia-1)*5*npack0+4*npack0),
99     >              dcpl_mb(exi(1)),
100     >              dcpl_mb(tmpz(1)))
101
102           call Pack_cc_dot(0,dcpl_mb(tmpx(1)),dcpl_mb(vxcG(1)),sumx)
103           call Pack_cc_dot(0,dcpl_mb(tmpy(1)),dcpl_mb(vxcG(1)),sumy)
104           call Pack_cc_dot(0,dcpl_mb(tmpz(1)),dcpl_mb(vxcG(1)),sumz)
105
106!$OMP MASTER
107           write(*,*) "ii,ia,SUMXYZ=",ii,ia,sumx,sumy,sumz
108           fion(1,ii) = fion(1,ii) + sumx*dsqrt(scal1*scal2)
109           fion(2,ii) = fion(2,ii) + sumy*dsqrt(scal1*scal2)
110           fion(3,ii) = fion(3,ii) + sumz*dsqrt(scal1*scal2)
111!$OMP END MASTER
112         end if
113
114      end do
115!$OMP BARRIER
116
117      value = BA_pop_stack(tmpz(2))
118      value = BA_pop_stack(tmpy(2))
119      value = BA_pop_stack(tmpx(2))
120      value = BA_pop_stack(vxcG(2))
121      value = BA_pop_stack(exi(2))
122
123
124      return
125      end
126
127
128c $Id$
129