Branch data 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 : : !!***
|
