Line data Source code
1 : !!****m* ABINIT/m_frskerker1
2 : !! NAME
3 : !! m_frskerker1
4 : !!
5 : !! FUNCTION
6 : !! provide the ability to compute the
7 : !! penalty function and its first derivative associated
8 : !! with some residuals and a real space dielectric function
9 : !!
10 : !! COPYRIGHT
11 : !! Copyright (C) 1998-2026 ABINIT group (DCA, XG, MT)
12 : !! This file is distributed under the terms of the
13 : !! GNU General Public License, see ~ABINIT/COPYING
14 : !! or http://www.gnu.org/copyleft/gpl.txt .
15 : !! For the initials of contributors, see ~ABINIT/Infos/contributors .
16 : !!
17 : !! NOTES
18 : !! this is neither a function nor a subroutine. This is a module
19 : !! It is made of two functions and one init subroutine
20 : !!
21 : !! SOURCE
22 :
23 : #if defined HAVE_CONFIG_H
24 : #include "config.h"
25 : #endif
26 :
27 : #include "abi_common.h"
28 :
29 : module m_frskerker1
30 :
31 : use defs_basis
32 : use m_abicore
33 : use m_dtset
34 :
35 : use defs_abitypes, only : MPI_type
36 : use m_spacepar, only : laplacian
37 : use m_numeric_tools, only : dotproduct
38 :
39 : implicit none
40 : !! common variables copied from input
41 : integer,save,private :: nfft,nspden,ngfft(18)
42 : real(dp),save,allocatable,private :: deltaW(:,:),mat(:,:),g2cart(:)
43 : real(dp),save,private :: gprimd(3,3),dielng
44 : type(dataset_type),pointer,save,private :: dtset_ptr
45 : type(MPI_type),save,private,pointer :: mpi_enreg_ptr
46 : !! common variables computed
47 : logical,save,private :: ok=.false.
48 :
49 : contains
50 : !!***
51 :
52 : !!****f* m_frskerker1/frskerker1__init
53 : !! NAME
54 : !! frskerker1__init
55 : !!
56 : !! FUNCTION
57 : !! initialisation subroutine
58 : !! Copy every variables required for the energy calculation
59 : !! Allocate the required memory
60 : !!
61 : !! INPUTS
62 : !!
63 : !! OUTPUT
64 : !!
65 : !! SOURCE
66 :
67 7 : subroutine frskerker1__init(dtset_in,mpi_enreg_in,nfft_in,ngfft_in,nspden_in,dielng_in,deltaW_in,gprimd_in,mat_in,g2cart_in )
68 :
69 : !Arguments ------------------------------------
70 : integer,intent(in) :: nfft_in,ngfft_in(18),nspden_in
71 : real(dp),intent(in) :: deltaW_in(nfft_in,nspden_in),mat_in(nfft_in,nspden_in),g2cart_in(nfft_in)
72 : real(dp),dimension(3,3),intent(in) :: gprimd_in
73 : real(dp),intent(in) :: dielng_in
74 : type(dataset_type),target,intent(in) :: dtset_in
75 : type(MPI_type),target,intent(in) :: mpi_enreg_in
76 :
77 : ! *************************************************************************
78 :
79 : ! !allocation and data transfer
80 : ! !Thought it would have been more logical to use the privates intrinsic of the module as
81 : ! !input variables it seems that it is not possible...
82 7 : if(.not.ok) then
83 7 : dtset_ptr => dtset_in
84 7 : mpi_enreg_ptr => mpi_enreg_in
85 7 : nspden=nspden_in
86 7 : ngfft=ngfft_in
87 7 : nfft=nfft_in
88 28 : ABI_MALLOC(deltaW,(size(deltaW_in,1),size(deltaW_in,2)))
89 21 : ABI_MALLOC(mat,(size(mat_in,1),size(mat_in,2)))
90 21 : ABI_MALLOC(g2cart,(size(g2cart_in,1)))
91 70021 : deltaW=deltaW_in
92 7 : dielng=dielng_in
93 70021 : mat=mat_in
94 7 : gprimd=gprimd_in
95 70014 : g2cart=g2cart_in
96 7 : ok = .true.
97 : end if
98 7 : end subroutine frskerker1__init
99 : !!***
100 :
101 : !!****f* m_frskerker1/frskerker1__end
102 : !! NAME
103 : !! frskerker1__end
104 : !!
105 : !! FUNCTION
106 : !! ending subroutine
107 : !! deallocate memory areas
108 : !!
109 : !! INPUTS
110 : !!
111 : !! OUTPUT
112 : !!
113 : !! SOURCE
114 :
115 7 : subroutine frskerker1__end()
116 :
117 : ! *************************************************************************
118 7 : if(ok) then
119 : ! ! set ok to false which prevent using the pf and dpf
120 7 : ok = .false.
121 : ! ! free memory
122 7 : ABI_FREE(deltaW)
123 7 : ABI_FREE(mat)
124 7 : ABI_FREE(g2cart)
125 : end if
126 :
127 7 : end subroutine frskerker1__end
128 : !!***
129 :
130 : !!****f* m_frskerker1/frskerker1__newvres
131 : !! NAME
132 : !! frskerker1__newvres
133 : !!
134 : !! FUNCTION
135 : !! affectation subroutine
136 : !! do the required renormalisation when providing a new value for
137 : !! the density after application of the gradient
138 : !!
139 : !! INPUTS
140 : !!
141 : !! OUTPUT
142 : !!
143 : !! SOURCE
144 :
145 334 : subroutine frskerker1__newvres(nv1,nv2,x, grad, vrespc)
146 :
147 : !Arguments ------------------------------------
148 : integer,intent(in) :: nv1,nv2
149 : real(dp),intent(in):: x
150 : real(dp),intent(inout)::grad(nv1,nv2)
151 : real(dp),intent(inout)::vrespc(nv1,nv2)
152 :
153 : ! *************************************************************************
154 :
155 3340668 : grad(:,:)=x*grad(:,:)
156 3340668 : vrespc(:,:)=vrespc(:,:)+grad(:,:)
157 :
158 334 : end subroutine frskerker1__newvres
159 : !!***
160 :
161 : !!****f* m_frskerker1/frskerker1__pf
162 : !! NAME
163 : !! frskerker1__pf
164 : !!
165 : !! FUNCTION
166 : !! penalty function associated with the preconditionned residuals
167 : !!
168 : !! INPUTS
169 : !!
170 : !! OUTPUT
171 : !!
172 : !! SOURCE
173 :
174 3780 : function frskerker1__pf(nv1,nv2,vrespc)
175 :
176 : !Arguments ------------------------------------
177 : integer,intent(in) :: nv1,nv2
178 : real(dp),intent(in)::vrespc(nv1,nv2)
179 : real(dp) ::frskerker1__pf
180 :
181 : !Local variables-------------------------------
182 7560 : real(dp):: buffer1(nv1,nv2),buffer2(nv1,nv2)
183 : ! *************************************************************************
184 :
185 3780 : if(ok) then
186 37807560 : buffer1=vrespc
187 : call laplacian(gprimd,mpi_enreg_ptr,nfft,nspden,ngfft,&
188 3780 : & rdfuncr=buffer1,laplacerdfuncr=buffer2,g2cart_in=g2cart)
189 37807560 : buffer2(:,:)=(vrespc(:,:)-((dielng)**2)*buffer2(:,:)) * half -deltaW
190 3780 : frskerker1__pf=dotproduct(nv1,nv2,vrespc,buffer2) !*half-dotproduct(nv1,nv2,vrespc,deltaW)
191 : else
192 : frskerker1__pf=zero
193 : end if
194 :
195 3780 : end function frskerker1__pf
196 : !!***
197 :
198 : !!****f* m_frskerker1/frskerker1__dpf
199 : !! NAME
200 : !! frskerker1__dpf
201 : !!
202 : !! FUNCTION
203 : !! derivative of the penalty function
204 : !! actually not the derivative but something allowing minimization
205 : !! at constant density
206 : !! formula from the work of rackowski,canning and wang
207 : !! H*phi - int(phi**2H d3r)phi
208 : !!
209 : !! INPUTS
210 : !!
211 : !! OUTPUT
212 : !!
213 : !! SOURCE
214 :
215 6387 : function frskerker1__dpf(nv1,nv2,vrespc)
216 :
217 : !Arguments ------------------------------------
218 : integer,intent(in) :: nv1,nv2
219 : real(dp),intent(in):: vrespc(nv1,nv2)
220 : real(dp) ::frskerker1__dpf(nv1,nv2)
221 :
222 : !Local variables-------------------------------
223 2129 : real(dp) :: buffer1(nv1,nv2),buffer2(nv1,nv2)
224 : ! *************************************************************************
225 :
226 2129 : if(ok) then
227 21294258 : buffer1=vrespc
228 : call laplacian(gprimd,mpi_enreg_ptr,nfft,nspden,ngfft,&
229 2129 : & rdfuncr=buffer1,laplacerdfuncr=buffer2,g2cart_in=g2cart)
230 21294258 : frskerker1__dpf(:,:)= vrespc(:,:)-deltaW-((dielng)**2)*buffer2(:,:)
231 : else
232 0 : frskerker1__dpf = zero
233 : end if
234 :
235 : end function frskerker1__dpf
236 : !!***
237 :
238 : end module m_frskerker1
239 : !!***
|
