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