Line data Source code
1 : !!****m* ABINIT/m_frskerker2
2 : !! NAME
3 : !! m_frskerker2
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_frskerker2
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 :
41 : !! common variables copied from input
42 : integer,save,private :: nfft,nspden,ngfft(18)
43 : real(dp),save,allocatable,private :: deltaW(:,:),mat(:,:),rdielng(:)
44 : real(dp),save,private :: gprimd(3,3)
45 : type(dataset_type),pointer,save,private :: dtset_ptr
46 : type(MPI_type),pointer,save,private :: mpi_enreg_ptr
47 : !! common variables computed
48 : logical,save,private :: ok=.false.
49 : ! *************************************************************************
50 :
51 : contains
52 : !!***
53 :
54 : !!****f* m_frskerker2/frskerker2__init
55 : !! NAME
56 : !! frskerker2__init
57 : !!
58 : !! FUNCTION
59 : !! initialisation subroutine
60 : !! Copy every variables required for the energy calculation
61 : !! Allocate the required memory
62 : !!
63 : !! INPUTS
64 : !!
65 : !! OUTPUT
66 : !!
67 : !! SOURCE
68 :
69 8 : subroutine frskerker2__init(dtset_in,mpi_enreg_in,nfft_in,ngfft_in,nspden_in,rdielng_in,deltaW_in,gprimd_in,mat_in )
70 :
71 : !Arguments ------------------------------------
72 : type(dataset_type),target,intent(in) :: dtset_in
73 : integer,intent(in) :: nfft_in,ngfft_in(18),nspden_in
74 : real(dp),intent(in) :: deltaW_in(nfft_in,nspden_in),mat_in(nfft_in,nspden_in)
75 : real(dp),intent(in) :: rdielng_in(nfft_in)
76 : real(dp),intent(in) :: gprimd_in(3,3)
77 : type(MPI_type),target,intent(in) :: mpi_enreg_in
78 :
79 : ! *************************************************************************
80 : ! !allocation and data transfer
81 : ! !Thought it would have been more logical to use the privates intrinsic of the module as
82 : ! !input variables it seems that it is not possible...
83 8 : if(.not.ok) then
84 8 : dtset_ptr => dtset_in
85 8 : mpi_enreg_ptr => mpi_enreg_in
86 8 : nspden=nspden_in
87 8 : ngfft=ngfft_in
88 8 : nfft=nfft_in
89 32 : ABI_MALLOC(deltaW,(size(deltaW_in,1),size(deltaW_in,2)))
90 24 : ABI_MALLOC(mat,(size(mat_in,1),size(mat_in,2)))
91 24 : ABI_MALLOC(rdielng,(size(rdielng_in)))
92 80024 : deltaW=deltaW_in
93 80016 : rdielng=rdielng_in
94 80024 : mat=mat_in
95 8 : gprimd=gprimd_in
96 8 : ok = .true.
97 : end if
98 :
99 8 : end subroutine frskerker2__init
100 : !!***
101 :
102 : !!****f* m_frskerker2/frskerker2__end
103 : !! NAME
104 : !! frskerker2__end
105 : !!
106 : !! FUNCTION
107 : !! ending subroutine
108 : !! deallocate memory areas
109 : !!
110 : !! INPUTS
111 : !!
112 : !! OUTPUT
113 : !!
114 : !! SOURCE
115 :
116 8 : subroutine frskerker2__end()
117 :
118 : ! *************************************************************************
119 8 : if(ok) then
120 : ! ! set ok to false which prevent using the pf and dpf
121 8 : ok = .false.
122 : ! ! free memory
123 8 : ABI_FREE(deltaW)
124 8 : ABI_FREE(mat)
125 8 : ABI_FREE(rdielng)
126 : end if
127 :
128 8 : end subroutine frskerker2__end
129 : !!***
130 :
131 : !!****f* m_frskerker2/frskerker2__newvres2
132 : !! NAME
133 : !! frskerker2__newvres2
134 : !!
135 : !! FUNCTION
136 : !! affectation subroutine
137 : !! do the required renormalisation when providing a new value for
138 : !! the density after application of the gradient
139 : !!
140 : !! INPUTS
141 : !!
142 : !! OUTPUT
143 : !!
144 : !! SOURCE
145 :
146 114 : subroutine frskerker2__newvres2(nv1,nv2,x, grad, vrespc)
147 :
148 : !Arguments ------------------------------------
149 : integer,intent(in) :: nv1,nv2
150 : real(dp),intent(in) :: x
151 : real(dp),intent(inout)::grad(nv1,nv2)
152 : real(dp),intent(inout)::vrespc(nv1,nv2)
153 :
154 : ! *************************************************************************
155 1140228 : grad(:,:)=x*grad(:,:)
156 1140228 : vrespc(:,:)=vrespc(:,:)+grad(:,:)
157 :
158 114 : end subroutine frskerker2__newvres2
159 : !!***
160 :
161 : !!****f* m_frskerker2/frskerker2__pf
162 : !! NAME
163 : !! frskerker2__pf
164 : !!
165 : !! FUNCTION
166 : !! penalty function associated with the preconditionned residuals
167 : !!
168 : !! INPUTS
169 : !!
170 : !! OUTPUT
171 : !!
172 : !! SOURCE
173 :
174 1347 : function frskerker2__pf(nv1,nv2,vrespc)
175 :
176 : !Arguments ------------------------------------
177 : integer,intent(in) :: nv1,nv2
178 : real(dp),intent(in) ::vrespc(nv1,nv2)
179 : real(dp) ::frskerker2__pf
180 :
181 : !Local variables-------------------------------
182 2694 : real(dp) :: buffer1(nv1,nv2),buffer2(nv1,nv2)
183 : integer :: ispden
184 : ! *************************************************************************
185 :
186 1347 : if(ok) then
187 13472694 : buffer1=vrespc
188 1347 : call laplacian(gprimd,mpi_enreg_ptr,nfft,nspden,ngfft,rdfuncr=buffer1,laplacerdfuncr=buffer2)
189 2694 : do ispden=1,nspden
190 : buffer2(:,ispden)=(vrespc(:,ispden)-((rdielng(:))**2)*buffer2(:,ispden)) &
191 13472694 : & *half - deltaW(:,ispden)
192 : end do
193 : ! pf_rscgres=dotproduct(vrespc,buffer2)*half-dotproduct(vrespc,deltaW)
194 1347 : frskerker2__pf=dotproduct(nv1,nv2,vrespc,buffer2)
195 : else
196 : frskerker2__pf=zero
197 : end if
198 1347 : end function frskerker2__pf
199 : !!***
200 :
201 : !!****f* m_frskerker2/frskerker2__dpf
202 : !! NAME
203 : !! frskerker2__dpf
204 : !!
205 : !! FUNCTION
206 : !! derivative of the penalty function
207 : !! actually not the derivative but something allowing minimization
208 : !! at constant density
209 : !! formula from the work of rackowski,canning and wang
210 : !! H*phi - int(phi**2H d3r)phi
211 : !! that is the simple projection of the change on a direction
212 : !! normal to the density changes
213 : !!
214 : !! INPUTS
215 : !!
216 : !! OUTPUT
217 : !!
218 : !! SOURCE
219 :
220 2643 : function frskerker2__dpf(nv1,nv2,vrespc)
221 :
222 : !Arguments ------------------------------------
223 : integer,intent(in) :: nv1,nv2
224 : real(dp),intent(in)::vrespc(nv1,nv2)
225 : real(dp) :: frskerker2__dpf(nv1,nv2)
226 :
227 : !Local variables-------------------------------
228 881 : real(dp):: buffer1(nv1,nv2),buffer2(nv1,nv2)
229 : integer :: ispden
230 :
231 : ! *************************************************************************
232 :
233 881 : if(ok) then
234 8811762 : buffer1=vrespc
235 881 : call laplacian(gprimd,mpi_enreg_ptr,nfft,nspden,ngfft,rdfuncr=buffer1,laplacerdfuncr=buffer2)
236 1762 : do ispden=1,nspden
237 8811762 : frskerker2__dpf(:,ispden)= vrespc(:,ispden)-deltaW(:,ispden)-((rdielng(:))**2)*buffer2(:,ispden)
238 : end do
239 : else
240 0 : frskerker2__dpf = zero
241 : end if
242 :
243 : end function frskerker2__dpf
244 : !!***
245 :
246 : end module m_frskerker2
247 : !!***
|
