Line data Source code
1 : !!****m* ABINIT/libxc_functionals
2 : !! NAME
3 : !! libxc_functionals
4 : !!
5 : !! FUNCTION
6 : !! Module containing interfaces to the LibXC library, for exchange
7 : !! correlation potentials and energies. The interfacing between
8 : !! the ABINIT and LibXC formats and datastructures happens here.
9 : !! Also contains basic container datatype for LibXC interfacing.
10 : !!
11 : !! COPYRIGHT
12 : !! Copyright (C) 2008-2026 ABINIT group (MOliveira,LHH,FL,GMR,MT)
13 : !! This file is distributed under the terms of the
14 : !! GNU Gener_al Public License, see ~abinit/COPYING
15 : !! or http://www.gnu.org/copyleft/gpl.txt .
16 : !!
17 : !! NOTES
18 : !! libxc_functionals.F90 defines a structured datatype (libxc_functional_type)
19 : !! and associated methods to initialize/finalize it and get properties from it.
20 : !! Abinit used a global variable (xc_global, libxc_functional_type) which is
21 : !! initialized in the driving routine (driver) with the value of ixc specified
22 : !! by the user in the input file.
23 : !! * It is possible to change the value of ixc at run-time; for that we have
24 : !! to reinitialize the global structure with the new value of ixc before
25 : !! computing XC quantities. Moreover one has to reinstate the old functional
26 : !! before returning so that the other routines will continue to used the
27 : !! previous ixc. This task can be accomplished with the following pseudocode:
28 : !! !!!!! if (old_ixc<0) call libxc_functionals_end()
29 : !! !!!!! if (new_ixc<0) call libxc_functionals_init(new_ixc,nspden)
30 : !! !!!!! >>>> Compute XC stuff here.
31 : !! !!!!! if (new_ixc<0) call libxc_functionals_end()
32 : !! !!!!! if (old_ixc<0) call libxc_functionals_init(old_ixc,nspden)
33 : !! * It is also possible to define a local (private) variable of type libxc_functional_type.
34 : !! For that, the different methods have to be called with an extra optional
35 : !! argument (called xc_funcs in this example):
36 : !! !!!!! call libxc_functionals_init(ixc,nspden,xc_funcs)
37 : !! !!!!! call libxc_functionals_end(xc_funcs)
38 : !!
39 : !! SOURCE
40 :
41 : #if defined HAVE_CONFIG_H
42 : #include "config.h"
43 : #endif
44 :
45 : #include "abi_common.h"
46 :
47 : module libxc_functionals
48 :
49 : use defs_basis
50 : use m_abicore
51 : use m_errors
52 :
53 : !ISO C bindings are mandatory
54 : #ifdef HAVE_FC_ISO_C_BINDING
55 : use, intrinsic :: iso_c_binding
56 : #endif
57 :
58 : implicit none
59 : private
60 :
61 : !Public functions
62 : public :: libxc_functionals_check ! Check if the code has been compiled with libXC
63 : public :: libxc_functionals_init ! Initialize a set of XC functional(s), from libXC
64 : public :: libxc_functionals_end ! End usage of a set of libXC functional(s)
65 : public :: libxc_functionals_fullname ! Return full name of a set of XC functional(s)
66 : public :: libxc_functionals_getid ! Return identifer of a XC functional, from its name
67 : public :: libxc_functionals_family_from_id ! Retrieve family of a XC functional, from its id
68 : public :: libxc_functionals_ixc ! The value of ixc used to initialize the XC functional(s)
69 : public :: libxc_functionals_islda ! Return TRUE if the set of XC functional(s) is LDA
70 : public :: libxc_functionals_isgga ! Return TRUE if the set of XC functional(s) is GGA or meta-GGA
71 : public :: libxc_functionals_ismgga ! Return TRUE if the set of XC functional(s) set is meta-GGA
72 : public :: libxc_functionals_is_tb09 ! Return TRUE if the XC functional is Tran-Blaha 2009.
73 : public :: libxc_functionals_is_potential_only ! Return TRUE if one of the XC functionals in the set is potential-only
74 : public :: libxc_functionals_set_c_tb09 ! Set c parameter for Tran-Blaha 2009 functional
75 : public :: libxc_functionals_needs_tau ! Return TRUE if the set of XC functional(s) uses KINETIC EN. DENSITY
76 : public :: libxc_functionals_needs_laplacian ! Return TRUE if the set of XC functional(s) uses LAPLACIAN
77 : public :: libxc_functionals_needs_temperature ! Return TRUE if the set of XC functional(s) uses the elec. temperature
78 : public :: libxc_functionals_set_temperature ! Set electronic temperature in a set of XC functional(s)
79 : public :: libxc_functionals_has_kxc ! Return TRUE if Kxc (3rd der) is available for a set of XC functional(s) set
80 : public :: libxc_functionals_has_k3xc ! Return TRUE if K3xc (4th der) is available for a set of XC functional(s) set
81 : public :: libxc_functionals_nspin ! The number of spin components for the set of XC functional(s)
82 : public :: libxc_functionals_is_hybrid ! Return TRUE if a set of XC functional(s) is hybrid
83 : public :: libxc_functionals_is_hybrid_from_id ! Return TRUE if a XC functional is hybrid, from its id
84 : public :: libxc_functionals_get_hybridparams ! Retrieve parameter(s) of hybrid functional(s)
85 : public :: libxc_functionals_set_hybridparams ! Change parameter(s) of hybrid functional(s)
86 : public :: libxc_functionals_gga_from_hybrid ! Return the id of the XC-GGA used for the hybrid
87 : public :: libxc_functionals_getvxc ! Return XC potential and energy, from input density
88 :
89 : !Private functions
90 : private :: libxc_functionals_compute_tb09 ! Compute c parameter for Tran-Blaha 2009 functional
91 : private :: libxc_functionals_getrefs ! Get references of a single XC functional
92 : private :: libxc_functionals_depends_on_temp ! TRUE if a single functional depends on elec. temperature
93 : private :: libxc_functionals_set_temp ! Set electronic temperature in a single XC functional
94 : private :: libxc_functionals_constants_load ! Load libXC constants from C headers
95 : #ifdef HAVE_FC_ISO_C_BINDING
96 : private :: xc_char_to_c ! Convert a string from Fortran to C
97 : private :: xc_char_to_f ! Convert a string from C to Fortran
98 : #endif
99 :
100 : !Public constants (use libxc_functionals_constants_load to init them)
101 : integer,public,save :: XC_FAMILY_UNKNOWN = -1
102 : integer,public,save :: XC_FAMILY_LDA = 1
103 : integer,public,save :: XC_FAMILY_GGA = 2
104 : integer,public,save :: XC_FAMILY_MGGA = 4
105 : integer,public,save :: XC_FAMILY_LCA = 8
106 : integer,public,save :: XC_FAMILY_OEP = 16
107 : integer,public,save :: XC_FAMILY_HYB_GGA = 32
108 : integer,public,save :: XC_FAMILY_HYB_MGGA = 64
109 : integer,public,save :: XC_FAMILY_HYB_LDA =128
110 : integer,public,save :: XC_FLAGS_HAVE_EXC = 1
111 : integer,public,save :: XC_FLAGS_HAVE_VXC = 2
112 : integer,public,save :: XC_FLAGS_HAVE_FXC = 4
113 : integer,public,save :: XC_FLAGS_HAVE_KXC = 8
114 : integer,public,save :: XC_FLAGS_HAVE_LXC = 16
115 : integer,public,save :: XC_FLAGS_NEEDS_LAPLACIAN= 32768
116 : integer,public,save :: XC_FLAGS_NEEDS_TAU = 65536
117 : integer,public,save :: XC_FLAGS_ENFORCE_FHC = 131072
118 : integer,public,save :: XC_EXCHANGE = 0
119 : integer,public,save :: XC_CORRELATION = 1
120 : integer,public,save :: XC_EXCHANGE_CORRELATION = 2
121 : integer,public,save :: XC_KINETIC = 3
122 : integer,public,save :: XC_SINGLE_PRECISION = 0
123 : logical,private,save :: libxc_constants_initialized=.false.
124 :
125 : !XC functional public type
126 : type,public :: libxc_functional_type
127 : integer :: id ! identifier
128 : integer :: family ! LDA, GGA, etc.
129 : integer :: kind ! EXCHANGE, CORRELATION, etc.
130 : integer :: nspin ! # of spin components
131 : integer :: abi_ixc ! Abinit IXC id for this functional
132 : logical :: has_exc ! TRUE is exc is available for the functional
133 : logical :: has_vxc ! TRUE is vxc is available for the functional
134 : logical :: has_fxc ! TRUE is fxc is available for the functional
135 : logical :: has_kxc ! TRUE is kxc is available for the functional
136 : logical :: needs_tau ! TRUE is functional needs kinetic energy density
137 : logical :: needs_laplacian ! TRUE is functional needs laplacian of density
138 : logical :: is_hybrid ! TRUE is functional is a hybrid functional
139 : real(dp) :: hyb_mixing ! Hybrid functional: mixing factor of Fock contribution (default=0)
140 : real(dp) :: hyb_mixing_sr ! Hybrid functional: mixing factor of SR Fock contribution (default=0)
141 : real(dp) :: hyb_range ! Range (for separation) for a hybrid functional (default=0)
142 : real(dp) :: temperature ! Electronic temperature; if <=0, the functional doesnt depend on it
143 : real(dp) :: xc_tb09_c ! Special TB09 functional parameter
144 : real(dp) :: sigma_threshold ! Value of a threshold to be applied on density gradient (sigma)
145 : ! (temporary dur to a libxc bug) - If <0, apply no filter
146 : #ifdef HAVE_FC_ISO_C_BINDING
147 : type(C_PTR),pointer :: conf => null() ! C pointer to the functional itself
148 : #endif
149 : end type libxc_functional_type
150 :
151 : !List of functionals on which a filter has to be applied on sigma (density gradient)
152 : ! This should be done by libXC via _set_sigma_threshold but this is not (libXC 6)
153 : ! This threshold has been evaluated from pbeh functional...
154 : real(dp),parameter :: sigma_threshold_def = 1.0e-25_dp
155 : integer,parameter :: n_sigma_filtered = 17
156 : character(len=28) :: sigma_filtered(n_sigma_filtered) = &
157 : & ['XC_HYB_GGA_XC_HSE03 ','XC_HYB_GGA_XC_HSE06 ','XC_HYB_GGA_XC_HJS_PBE ',&
158 : & 'XC_HYB_GGA_XC_HJS_PBE_SOL ','XC_HYB_GGA_XC_HJS_B88 ','XC_HYB_GGA_XC_HJS_B97X ',&
159 : & 'XC_HYB_GGA_XC_LRC_WPBEH ','XC_HYB_GGA_XC_LRC_WPBE ','XC_HYB_GGA_XC_LC_WPBE ',&
160 : & 'XC_HYB_GGA_XC_HSE12 ','XC_HYB_GGA_XC_HSE12S ','XC_HYB_GGA_XC_HSE_SOL ',&
161 : & 'XC_HYB_GGA_XC_LC_WPBE_WHS ','XC_HYB_GGA_XC_LC_WPBEH_WHS ','XC_HYB_GGA_XC_LC_WPBE08_WHS ',&
162 : & 'XC_HYB_GGA_XC_LC_WPBESOL_WHS','XC_HYB_GGA_XC_WHPBE0 ']
163 :
164 : !----------------------------------------------------------------------
165 :
166 : !Private global XC functional
167 : type(libxc_functional_type),target,save :: xc_global(2)
168 :
169 : !----------------------------------------------------------------------
170 :
171 : !Interfaces for C bindings
172 : #ifdef HAVE_FC_ISO_C_BINDING
173 : interface
174 : integer(C_INT) function xc_func_init(xc_func,functional,nspin) bind(C)
175 : use, intrinsic :: iso_c_binding, only : C_INT,C_PTR
176 : integer(C_INT),value :: functional,nspin
177 : type(C_PTR) :: xc_func
178 : end function xc_func_init
179 : end interface
180 : !
181 : interface
182 : subroutine xc_func_end(xc_func) bind(C)
183 : use, intrinsic :: iso_c_binding, only : C_PTR
184 : type(C_PTR) :: xc_func
185 : end subroutine xc_func_end
186 : end interface
187 : !
188 : interface
189 : integer(C_INT) function xc_functional_get_number(name) bind(C)
190 : use, intrinsic :: iso_c_binding, only : C_INT,C_PTR
191 : type(C_PTR),value :: name
192 : end function xc_functional_get_number
193 : end interface
194 : !
195 : interface
196 : type(C_PTR) function xc_functional_get_name(number) bind(C)
197 : use, intrinsic :: iso_c_binding, only : C_INT,C_PTR
198 : integer(C_INT),value :: number
199 : end function xc_functional_get_name
200 : end interface
201 : !
202 : interface
203 : integer(C_INT) function xc_family_from_id(id,family,number) bind(C)
204 : use, intrinsic :: iso_c_binding, only : C_INT,C_PTR
205 : integer(C_INT),value :: id
206 : type(C_PTR),value :: family,number
207 : end function xc_family_from_id
208 : end interface
209 : !
210 : interface
211 : subroutine xc_hyb_cam_coef(xc_func,omega,alpha,beta) bind(C)
212 : use, intrinsic :: iso_c_binding, only : C_DOUBLE,C_PTR
213 : real(C_DOUBLE) :: omega,alpha,beta
214 : type(C_PTR) :: xc_func
215 : end subroutine xc_hyb_cam_coef
216 : end interface
217 : !
218 : interface
219 : subroutine xc_get_lda(xc_func,np,rho,zk,vrho,v2rho2,v3rho3) bind(C)
220 : use, intrinsic :: iso_c_binding, only : C_INT,C_PTR
221 : integer(C_INT),value :: np
222 : type(C_PTR),value :: rho,zk,vrho,v2rho2,v3rho3
223 : type(C_PTR) :: xc_func
224 : end subroutine xc_get_lda
225 : end interface
226 : !
227 : interface
228 : subroutine xc_get_gga(xc_func,np,rho,sigma,zk,vrho,vsigma,v2rho2,v2rhosigma,v2sigma2, &
229 : & v3rho3,v3rho2sigma,v3rhosigma2,v3sigma3) bind(C)
230 : use, intrinsic :: iso_c_binding, only : C_INT,C_PTR
231 : integer(C_INT),value :: np
232 : type(C_PTR),value :: rho,sigma,zk,vrho,vsigma,v2rho2,v2rhosigma,v2sigma2, &
233 : & v3rho3,v3rho2sigma,v3rhosigma2,v3sigma3
234 : type(C_PTR) :: xc_func
235 : end subroutine xc_get_gga
236 : end interface
237 : !
238 : interface
239 : subroutine xc_get_mgga(xc_func,np,rho,sigma,lapl,tau,zk,vrho,vsigma,vlapl,vtau, &
240 : & v2rho2,v2rhosigma,v2rholapl,v2rhotau,v2sigma2,v2sigmalapl, &
241 : & v2sigmatau,v2lapl2,v2lapltau,v2tau2) bind(C)
242 : use, intrinsic :: iso_c_binding, only : C_INT,C_PTR
243 : integer(C_INT),value :: np
244 : type(C_PTR),value :: rho,sigma,lapl,tau,zk,vrho,vsigma,vlapl,vtau, &
245 : & v2rho2,v2sigma2,v2lapl2,v2tau2,v2rhosigma,v2rholapl,v2rhotau, &
246 : & v2sigmalapl,v2sigmatau,v2lapltau
247 : type(C_PTR) :: xc_func
248 : end subroutine xc_get_mgga
249 : end interface
250 : !
251 : interface
252 : subroutine xc_func_set_params(xc_func,params,n_params) bind(C)
253 : use, intrinsic :: iso_c_binding, only : C_INT,C_DOUBLE,C_PTR
254 : integer(C_INT),value :: n_params
255 : real(C_DOUBLE) :: params(*)
256 : type(C_PTR) :: xc_func
257 : end subroutine xc_func_set_params
258 : end interface
259 : !
260 : interface
261 : integer(C_INT) function xc_func_set_params_name(xc_func,name,param) bind(C)
262 : use, intrinsic :: iso_c_binding, only : C_INT,C_DOUBLE,C_PTR
263 : real(C_DOUBLE) :: param
264 : type(C_PTR) :: xc_func
265 : type(C_PTR),value :: name
266 : end function xc_func_set_params_name
267 : end interface
268 : !
269 : interface
270 : type(C_PTR) function xc_func_get_params_name(xc_func,ipar) bind(C)
271 : use, intrinsic :: iso_c_binding, only : C_INT,C_PTR
272 : type(C_PTR) :: xc_func
273 : integer(C_INT) :: ipar
274 : end function xc_func_get_params_name
275 : end interface
276 : !
277 : interface
278 : type(C_PTR) function xc_func_get_params_description(xc_func,ipar) bind(C)
279 : use, intrinsic :: iso_c_binding, only : C_INT,C_PTR
280 : type(C_PTR) :: xc_func
281 : integer(C_INT) :: ipar
282 : end function xc_func_get_params_description
283 : end interface
284 : !
285 : interface
286 : subroutine xc_func_set_density_threshold(xc_func,dens_threshold) bind(C)
287 : use, intrinsic :: iso_c_binding, only : C_DOUBLE,C_PTR
288 : real(C_DOUBLE) :: dens_threshold
289 : type(C_PTR) :: xc_func
290 : end subroutine xc_func_set_density_threshold
291 : end interface
292 : !
293 : interface
294 : subroutine xc_func_set_sig_threshold(xc_func,sigma_threshold) bind(C)
295 : use, intrinsic :: iso_c_binding, only : C_DOUBLE,C_PTR
296 : real(C_DOUBLE) :: sigma_threshold
297 : type(C_PTR) :: xc_func
298 : end subroutine xc_func_set_sig_threshold
299 : end interface
300 : !
301 : interface
302 : subroutine xc_func_set_enforce_fhc(xc_func,on_off) bind(C)
303 : use, intrinsic :: iso_c_binding, only : C_INT,C_PTR
304 : type(C_PTR) :: xc_func
305 : integer(C_INT) :: on_off
306 : end subroutine xc_func_set_enforce_fhc
307 : end interface
308 : !
309 : interface
310 : integer(C_INT) function xc_func_is_hybrid_from_id(func_id) bind(C)
311 : use, intrinsic :: iso_c_binding, only : C_INT
312 : integer(C_INT),value :: func_id
313 : end function xc_func_is_hybrid_from_id
314 : end interface
315 : !
316 : interface
317 : subroutine xc_get_singleprecision_constant(xc_cst_singleprecision) bind(C)
318 : use, intrinsic :: iso_c_binding, only : C_INT
319 : integer(C_INT) :: xc_cst_singleprecision
320 : end subroutine xc_get_singleprecision_constant
321 : end interface
322 : !
323 : interface
324 : subroutine xc_get_family_constants(xc_cst_unknown,xc_cst_lda,xc_cst_gga,xc_cst_mgga, &
325 : & xc_cst_lca,xc_cst_oep,xc_cst_hyb_gga, &
326 : & xc_cst_hyb_mgga,xc_cst_hyb_lda) bind(C)
327 : use, intrinsic :: iso_c_binding, only : C_INT
328 : integer(C_INT) :: xc_cst_unknown,xc_cst_lda,xc_cst_gga,xc_cst_mgga, &
329 : & xc_cst_lca,xc_cst_oep,xc_cst_hyb_gga,xc_cst_hyb_mgga, &
330 : & xc_cst_hyb_lda
331 : end subroutine xc_get_family_constants
332 : end interface
333 : !
334 : interface
335 : subroutine xc_get_flags_constants(xc_cst_flags_have_exc,xc_cst_flags_have_vxc, &
336 : xc_cst_flags_have_fxc,xc_cst_flags_have_kxc,xc_cst_flags_have_lxc,&
337 : & xc_cxt_flags_needs_tau,xc_cxt_flags_needs_lapl,xc_cxt_flags_enforce_fhc) bind(C)
338 : use, intrinsic :: iso_c_binding, only : C_INT
339 : integer(C_INT) :: xc_cst_flags_have_exc,xc_cst_flags_have_vxc,xc_cst_flags_have_fxc, &
340 : & xc_cst_flags_have_kxc,xc_cst_flags_have_lxc, &
341 : & xc_cxt_flags_needs_tau,xc_cxt_flags_needs_lapl,xc_cxt_flags_enforce_fhc
342 : end subroutine xc_get_flags_constants
343 : end interface
344 : !
345 : interface
346 : subroutine xc_get_kind_constants(xc_cst_exchange,xc_cst_correlation, &
347 : & xc_cst_exchange_correlation,xc_cst_kinetic) bind(C)
348 : use, intrinsic :: iso_c_binding, only : C_INT
349 : integer(C_INT) :: xc_cst_exchange,xc_cst_correlation, &
350 : & xc_cst_exchange_correlation,xc_cst_kinetic
351 : end subroutine xc_get_kind_constants
352 : end interface
353 : !
354 : interface
355 : type(C_PTR) function xc_func_type_malloc() bind(C)
356 : use, intrinsic :: iso_c_binding, only : C_PTR
357 : end function xc_func_type_malloc
358 : end interface
359 : !
360 : interface
361 : subroutine xc_func_type_free(xc_func) bind(C)
362 : use, intrinsic :: iso_c_binding, only : C_PTR
363 : type(C_PTR) :: xc_func
364 : end subroutine xc_func_type_free
365 : end interface
366 : !
367 : interface
368 : type(C_PTR) function xc_get_info_name(xc_func) bind(C)
369 : use, intrinsic :: iso_c_binding, only : C_PTR
370 : type(C_PTR) :: xc_func
371 : end function xc_get_info_name
372 : end interface
373 : !
374 : interface
375 : type(C_PTR) function xc_get_info_refs(xc_func,iref) bind(C)
376 : use, intrinsic :: iso_c_binding, only : C_INT,C_PTR
377 : type(C_PTR) :: xc_func
378 : integer(C_INT) :: iref
379 : end function xc_get_info_refs
380 : end interface
381 : !
382 : interface
383 : integer(C_INT) function xc_get_info_flags(xc_func) bind(C)
384 : use, intrinsic :: iso_c_binding, only : C_INT,C_PTR
385 : type(C_PTR) :: xc_func
386 : end function xc_get_info_flags
387 : end interface
388 : !
389 : interface
390 : integer(C_INT) function xc_get_info_kind(xc_func) bind(C)
391 : use, intrinsic :: iso_c_binding, only : C_INT,C_PTR
392 : type(C_PTR) :: xc_func
393 : end function xc_get_info_kind
394 : end interface
395 : #endif
396 :
397 : contains
398 : !!***
399 :
400 : !----------------------------------------------------------------------
401 :
402 : !!****f* libxc_functionals/libxc_functionals_check
403 : !! NAME
404 : !! libxc_functionals_check
405 : !!
406 : !! FUNCTION
407 : !! Check if the code has been compiled with libXC
408 : !!
409 : !! INPUTS
410 : !! [stop_if_error]=optional flag; if TRUE the code stops if libXC is not correctly used
411 : !!
412 : !! SOURCE
413 :
414 368762 : function libxc_functionals_check(stop_if_error)
415 :
416 : !Arguments ------------------------------------
417 : logical :: libxc_functionals_check
418 : logical,intent(in),optional :: stop_if_error
419 : !Local variables-------------------------------
420 : character(len=100) :: msg
421 :
422 : ! *************************************************************************
423 :
424 368762 : libxc_functionals_check=.true. ; msg=""
425 :
426 : #if defined HAVE_LIBXC
427 : #if defined HAVE_FC_ISO_C_BINDING
428 368762 : if (.not.libxc_constants_initialized) call libxc_functionals_constants_load()
429 368762 : if (XC_SINGLE_PRECISION==1) then
430 0 : libxc_functionals_check=.false.
431 0 : msg='LibXC should be compiled with double precision!'
432 : end if
433 : #else
434 : libxc_functionals_check=.false.
435 : msg='LibXC cannot be used without ISO_C_BINDING support by the Fortran compiler!'
436 : #endif
437 : #else
438 : libxc_functionals_check=.false.
439 : msg='ABINIT was not compiled with LibXC support.'
440 : #endif
441 :
442 368762 : if (present(stop_if_error)) then
443 368744 : if (stop_if_error.and.trim(msg)/="") then
444 0 : ABI_ERROR(msg)
445 : end if
446 : end if
447 :
448 368762 : end function libxc_functionals_check
449 : !!***
450 :
451 : !----------------------------------------------------------------------
452 :
453 : !!****f* libxc_functionals/libxc_functionals_init
454 : !! NAME
455 : !! libxc_functionals_init
456 : !!
457 : !! FUNCTION
458 : !! Initialize the desired (set of) XC functional(s), from LibXC.
459 : !! * Call the LibXC initializer
460 : !! * Fill preliminary fields in module structures.
461 : !!
462 : !! INPUTS
463 : !! ixc=XC code for Abinit
464 : !! nspden=number of spin-density components
465 : !! [enforce_fhc]=flags controlling the enforcement of Fermi Hole Curvature (mGGA only)
466 : !! [el_temp]=electronic temperature (optional, only for specific functionals)
467 : !! [xc_tb09_c]=special argument for the Tran-Blaha 2009 functional
468 : !!
469 : !! OUTPUT
470 : !!
471 : !! SIDE EFFECTS
472 : !! [xc_functionals(2)]=<type(libxc_functional_type)>, optional argument
473 : !! Handle for XC functionals
474 : !!
475 : !! SOURCE
476 :
477 3826 : subroutine libxc_functionals_init(ixc,nspden,xc_functionals,&
478 : & enforce_fhc,el_temp,xc_tb09_c) ! optional arguments
479 :
480 : !Arguments ------------------------------------
481 : integer, intent(in) :: nspden
482 : integer, intent(in) :: ixc
483 : logical,intent(in),optional :: enforce_fhc
484 : real(dp),intent(in),optional :: el_temp,xc_tb09_c
485 : type(libxc_functional_type),intent(inout),optional,target :: xc_functionals(2)
486 : !Local variables-------------------------------
487 : integer :: ii,jj,nspden_eff
488 : character(len=500) :: msg
489 : type(libxc_functional_type),pointer :: xc_func
490 : #if defined HAVE_LIBXC && defined HAVE_FC_ISO_C_BINDING
491 : integer :: flags
492 : integer(C_INT) :: fhc_c,func_id_c,iref_c,npar_c,nspin_c,success_c
493 : real(C_DOUBLE) :: alpha_c,beta_c,omega_c,param_c(1)
494 : character(kind=C_CHAR,len=1),pointer :: strg_c
495 : type(C_PTR) :: func_ptr_c
496 : #endif
497 :
498 : ! *************************************************************************
499 :
500 : !Check libXC
501 3826 : if (.not.libxc_functionals_check(stop_if_error=.true.)) return
502 3826 : if (.not.libxc_constants_initialized)then
503 0 : call libxc_functionals_constants_load()
504 : endif
505 :
506 3826 : nspden_eff=min(nspden,2)
507 :
508 : !Select XC functional(s) identifiers
509 3826 : if (present(xc_functionals)) then
510 2671 : xc_functionals(1)%id = -ixc/1000
511 2671 : xc_functionals(2)%id = -ixc + (ixc/1000)*1000
512 : else
513 1155 : xc_global(1)%id = -ixc/1000
514 1155 : xc_global(2)%id = -ixc + (ixc/1000)*1000
515 : end if
516 :
517 11478 : do ii = 1,2
518 :
519 : ! Select XC functional
520 7652 : if (present(xc_functionals)) then
521 5342 : xc_func => xc_functionals(ii)
522 : else
523 2310 : xc_func => xc_global(ii)
524 : end if
525 :
526 7652 : xc_func%abi_ixc=ixc !Save abinit value for reference
527 :
528 7652 : xc_func%family=XC_FAMILY_UNKNOWN
529 7652 : xc_func%kind=-1
530 7652 : xc_func%nspin=nspden_eff
531 7652 : xc_func%has_exc=.false.
532 7652 : xc_func%has_vxc=.false.
533 7652 : xc_func%has_fxc=.false.
534 7652 : xc_func%has_kxc=.false.
535 7652 : xc_func%needs_tau=.false.
536 7652 : xc_func%needs_laplacian=.false.
537 7652 : xc_func%is_hybrid=.false.
538 7652 : xc_func%hyb_mixing=zero
539 7652 : xc_func%hyb_mixing_sr=zero
540 7652 : xc_func%hyb_range=zero
541 7652 : xc_func%temperature=-one
542 7652 : xc_func%xc_tb09_c=99.99_dp
543 7652 : xc_func%sigma_threshold=-one
544 :
545 7652 : if (xc_func%id<=0) cycle
546 :
547 : ! Get XC functional family
548 14584 : xc_func%family=libxc_functionals_family_from_id(xc_func%id)
549 : if (xc_func%family/=XC_FAMILY_LDA .and. &
550 : & xc_func%family/=XC_FAMILY_GGA .and. &
551 4294 : & xc_func%family/=XC_FAMILY_MGGA.and. &
552 : & xc_func%family/=XC_FAMILY_HYB_GGA) then
553 : write(msg, '(a,i8,2a,i8,a,i8,3a,i8,6a)' )&
554 0 : & 'Invalid IXC = ',ixc,ch10,&
555 0 : & 'Current xc_func%id=',xc_func%id,', (ii=',ii,')',ch10,&
556 0 : & 'The associated LibXC functional family ',xc_func%family,&
557 0 : & ' is currently unsupported by ABINIT',ch10,&
558 0 : & '(-1 means the family is unknown to the LibXC itself)',ch10,&
559 0 : & 'Please consult the LibXC documentation',ch10
560 0 : ABI_ERROR(msg)
561 : end if
562 :
563 : #if defined HAVE_LIBXC && defined HAVE_FC_ISO_C_BINDING
564 :
565 : ! Allocate functional
566 7292 : func_ptr_c=xc_func_type_malloc()
567 7292 : call c_f_pointer(func_ptr_c,xc_func%conf)
568 :
569 : ! Initialize functional
570 7292 : func_id_c=int(xc_func%id,kind=C_INT)
571 7292 : nspin_c=int(nspden_eff,kind=C_INT)
572 7292 : success_c=xc_func_init(xc_func%conf,func_id_c,nspin_c)
573 7292 : if (success_c/=0) then
574 0 : msg='Error in libXC functional initialization!'
575 0 : ABI_ERROR(msg)
576 : end if
577 :
578 : ! Special treatment for LDA_C_XALPHA functional
579 7292 : if (xc_func%id==libxc_functionals_getid('XC_LDA_C_XALPHA')) then
580 6 : param_c(1)=real(zero,kind=C_DOUBLE);npar_c=int(1,kind=C_INT)
581 6 : call xc_func_set_params(xc_func%conf,param_c,npar_c)
582 : end if
583 :
584 : ! Special treatment for XC_MGGA_X_TB09 functional
585 7292 : if (xc_func%id==libxc_functionals_getid('XC_MGGA_X_TB09')) then
586 30 : if (.not.present(xc_tb09_c)) then
587 0 : msg='xc_tb09_c argument is mandatory for TB09 functional!'
588 0 : ABI_BUG(msg)
589 : end if
590 30 : xc_func%xc_tb09_c=xc_tb09_c
591 : end if
592 :
593 : ! Get functional kind
594 7292 : xc_func%kind=int(xc_get_info_kind(xc_func%conf))
595 :
596 : ! Get functional flags
597 7292 : flags=int(xc_get_info_flags(xc_func%conf))
598 7292 : xc_func%has_exc=(iand(flags,XC_FLAGS_HAVE_EXC)>0)
599 7292 : xc_func%has_vxc=(iand(flags,XC_FLAGS_HAVE_VXC)>0)
600 7292 : xc_func%has_fxc=(iand(flags,XC_FLAGS_HAVE_FXC)>0)
601 7292 : xc_func%has_kxc=(iand(flags,XC_FLAGS_HAVE_KXC)>0)
602 :
603 : ! Retrieve/set parameters for metaGGA functionals
604 7292 : if (xc_func%family==XC_FAMILY_MGGA.or. &
605 : & xc_func%family==XC_FAMILY_HYB_MGGA) then
606 255 : xc_func%needs_tau=.true.;xc_func%needs_laplacian=.false.
607 255 : if (XC_FLAGS_NEEDS_TAU>0) xc_func%needs_tau=(iand(flags,XC_FLAGS_NEEDS_TAU)>0)
608 255 : if (XC_FLAGS_NEEDS_LAPLACIAN>0) xc_func%needs_laplacian=(iand(flags,XC_FLAGS_NEEDS_LAPLACIAN)>0)
609 255 : fhc_c=int(0,kind=C_INT) ; if (present(enforce_fhc)) fhc_c=merge(int(1,kind=C_INT),int(0,kind=C_INT),enforce_fhc)
610 255 : call xc_func_set_enforce_fhc(xc_func%conf,fhc_c)
611 : end if
612 :
613 : ! Retrieve parameters for hybrid functionals
614 7292 : xc_func%is_hybrid=(xc_func_is_hybrid_from_id(xc_func%id)==1)
615 7292 : if (xc_func%is_hybrid) then
616 174 : call xc_hyb_cam_coef(xc_func%conf,omega_c,alpha_c,beta_c)
617 174 : xc_func%hyb_mixing=real(alpha_c,kind=dp)
618 174 : xc_func%hyb_mixing_sr=real(beta_c,kind=dp)
619 174 : xc_func%hyb_range=real(omega_c,kind=dp)
620 : end if
621 :
622 : ! Possible temperature dependence
623 7292 : if (present(el_temp)) then
624 2218 : if (el_temp>tol10) then
625 2214 : if (libxc_functionals_depends_on_temp(xc_func)) then
626 7 : xc_func%temperature=el_temp
627 7 : call libxc_functionals_set_temp(xc_func,el_temp)
628 : end if
629 : end if
630 : end if
631 :
632 : ! Some functionals need a filter to be applied on sigma (density gradient)
633 : ! because libXC v6 doesn't implement sigma_threshold
634 7292 : if (xc_func%is_hybrid) then
635 3132 : do jj=1,n_sigma_filtered
636 3132 : if (xc_func%id==libxc_functionals_getid(trim(sigma_filtered(jj)))) then
637 131 : xc_func%sigma_threshold=sigma_threshold_def
638 : end if
639 : end do
640 : end if
641 :
642 : ! Dump functional information
643 7292 : call c_f_pointer(xc_get_info_name(xc_func%conf),strg_c)
644 7292 : call xc_char_to_f(strg_c,msg);msg=' '//trim(msg)
645 7292 : call wrtout(std_out,msg,'COLL')
646 7292 : iref_c=0
647 31018 : do while (iref_c>=0)
648 19900 : call c_f_pointer(xc_get_info_refs(xc_func%conf,iref_c),strg_c)
649 27552 : if (associated(strg_c)) then
650 12608 : call xc_char_to_f(strg_c,msg);msg=' '//trim(msg)
651 12608 : call wrtout(std_out,msg,'COLL')
652 12608 : iref_c=iref_c+1
653 : else
654 7292 : iref_c=-1
655 : end if
656 : end do
657 :
658 : #else
659 : ABI_UNUSED(xc_tb09_c)
660 : #endif
661 :
662 : end do
663 :
664 3826 : msg='';call wrtout(std_out,msg,'COLL')
665 :
666 : end subroutine libxc_functionals_init
667 : !!***
668 :
669 : !----------------------------------------------------------------------
670 :
671 : !!****f* libxc_functionals/libxc_functionals_end
672 : !! NAME
673 : !! libxc_functionals_end
674 : !!
675 : !! FUNCTION
676 : !! End usage of a (set of) XC functional(s).
677 : !! Call LibXC end function and deallocate module contents.
678 : !!
679 : !! INPUTS
680 : !!
681 : !! OUTPUT
682 : !!
683 : !! SIDE EFFECTS
684 : !! [xc_functionals(2)]=<type(libxc_functional_type)>, optional argument
685 : !! Handle for XC functionals
686 : !!
687 : !! SOURCE
688 :
689 3823 : subroutine libxc_functionals_end(xc_functionals)
690 :
691 : !Arguments ------------------------------------
692 : type(libxc_functional_type),intent(inout),optional,target :: xc_functionals(2)
693 : !Local variables-------------------------------
694 : integer :: ii
695 : type(libxc_functional_type),pointer :: xc_func
696 :
697 : ! *************************************************************************
698 :
699 11469 : do ii = 1,2
700 :
701 : ! Select XC functional
702 7646 : if (present(xc_functionals)) then
703 5338 : xc_func => xc_functionals(ii)
704 : else
705 2308 : xc_func => xc_global(ii)
706 : end if
707 :
708 7646 : if (xc_func%id <= 0) cycle
709 7286 : xc_func%id=-1
710 7286 : xc_func%family=-1
711 7286 : xc_func%kind=-1
712 7286 : xc_func%nspin=1
713 7286 : xc_func%abi_ixc=huge(0)
714 7286 : xc_func%has_exc=.false.
715 7286 : xc_func%has_vxc=.false.
716 7286 : xc_func%has_fxc=.false.
717 7286 : xc_func%has_kxc=.false.
718 7286 : xc_func%needs_tau=.false.
719 7286 : xc_func%needs_laplacian=.false.
720 7286 : xc_func%is_hybrid=.false.
721 7286 : xc_func%hyb_mixing=zero
722 7286 : xc_func%hyb_mixing_sr=zero
723 7286 : xc_func%hyb_range=zero
724 7286 : xc_func%temperature=-one
725 7286 : xc_func%xc_tb09_c=99.99_dp
726 7286 : xc_func%sigma_threshold=-one
727 : #if defined HAVE_LIBXC && defined HAVE_FC_ISO_C_BINDING
728 11109 : if (associated(xc_func%conf)) then
729 7286 : call xc_func_end(xc_func%conf)
730 7286 : call xc_func_type_free(c_loc(xc_func%conf))
731 : end if
732 : #endif
733 :
734 : end do
735 :
736 3823 : end subroutine libxc_functionals_end
737 : !!***
738 :
739 : !----------------------------------------------------------------------
740 :
741 : !!****f* libxc_functionals/libxc_functionals_fullname
742 : !! NAME
743 : !! libxc_functionals_fullname
744 : !!
745 : !! FUNCTION
746 : !! Return full name of a (set of) XC functional(s)
747 : !!
748 : !! INPUTS
749 : !! [xc_functionals(2)]=<type(libxc_functional_type)>, optional argument
750 : !! Handle for XC functionals
751 : !!
752 : !! OUTPUT
753 : !!
754 : !! SOURCE
755 :
756 0 : function libxc_functionals_fullname(xc_functionals)
757 :
758 : !Arguments ------------------------------------
759 : character(len=100) :: libxc_functionals_fullname
760 : type(libxc_functional_type),intent(in),optional,target :: xc_functionals(2)
761 : !Local variables-------------------------------
762 : integer :: nxc
763 0 : type(libxc_functional_type),pointer :: xc_funcs(:)
764 : #if defined HAVE_LIBXC && defined HAVE_FC_ISO_C_BINDING
765 : character(len=100) :: xcname
766 : character(kind=C_CHAR,len=1),pointer :: strg_c
767 : #endif
768 :
769 : ! *************************************************************************
770 :
771 0 : libxc_functionals_fullname='No XC functional'
772 :
773 0 : if (present(xc_functionals)) then
774 0 : xc_funcs => xc_functionals
775 : else
776 0 : xc_funcs => xc_global
777 : end if
778 :
779 0 : nxc=size(xc_funcs)
780 : if (nxc<1) return
781 :
782 : #if defined HAVE_LIBXC && defined HAVE_FC_ISO_C_BINDING
783 : if (nxc<2) then
784 : if (xc_funcs(1)%id /= 0) then
785 : call c_f_pointer(xc_functional_get_name(xc_funcs(1)%id),strg_c)
786 : call xc_char_to_f(strg_c,libxc_functionals_fullname)
787 : end if
788 0 : else if (xc_funcs(1)%id <= 0) then
789 0 : if (xc_funcs(2)%id /= 0) then
790 0 : call c_f_pointer(xc_functional_get_name(xc_funcs(2)%id),strg_c)
791 0 : call xc_char_to_f(strg_c,libxc_functionals_fullname)
792 : end if
793 0 : else if (xc_funcs(2)%id <= 0) then
794 : if (xc_funcs(1)%id /= 0) then
795 0 : call c_f_pointer(xc_functional_get_name(xc_funcs(1)%id),strg_c)
796 0 : call xc_char_to_f(strg_c,libxc_functionals_fullname)
797 : end if
798 : else
799 0 : call c_f_pointer(xc_functional_get_name(xc_funcs(1)%id),strg_c)
800 0 : call xc_char_to_f(strg_c,libxc_functionals_fullname)
801 0 : call c_f_pointer(xc_functional_get_name(xc_funcs(2)%id),strg_c)
802 0 : call xc_char_to_f(strg_c,xcname)
803 0 : libxc_functionals_fullname=trim(libxc_functionals_fullname)//'+'//trim(xcname)
804 : end if
805 : libxc_functionals_fullname=trim(libxc_functionals_fullname)
806 : #endif
807 :
808 0 : end function libxc_functionals_fullname
809 : !!***
810 :
811 : !----------------------------------------------------------------------
812 :
813 : !!****f* libxc_functionals/libxc_functionals_getid
814 : !! NAME
815 : !! libxc_functionals_getid
816 : !!
817 : !! FUNCTION
818 : !! Return identifer of a XC functional from its name
819 : !! Return -1 if undefined
820 : !!
821 : !! INPUTS
822 : !! xcname= string containing the name of a XC functional
823 : !!
824 : !! SOURCE
825 :
826 324001 : function libxc_functionals_getid(xcname)
827 :
828 : !Arguments ------------------------------------
829 : integer :: libxc_functionals_getid
830 : character(len=*),intent(in) :: xcname
831 : !Local variables-------------------------------
832 : #if defined HAVE_LIBXC && defined HAVE_FC_ISO_C_BINDING
833 : character(len=256) :: str
834 648002 : character(kind=C_CHAR,len=1),target :: name_c(len_trim(xcname)+1)
835 648002 : character(kind=C_CHAR,len=1),target :: name_c_xc(len_trim(xcname)-2)
836 : type(C_PTR) :: name_c_ptr
837 : #endif
838 :
839 : ! *************************************************************************
840 :
841 : #if defined HAVE_LIBXC && defined HAVE_FC_ISO_C_BINDING
842 324001 : str=trim(xcname)
843 324001 : if (xcname(1:3)=="XC_".or.xcname(1:3)=="xc_") then
844 323286 : str=xcname(4:);name_c_xc=xc_char_to_c(str)
845 323286 : name_c_ptr=c_loc(name_c_xc)
846 : else
847 715 : name_c=xc_char_to_c(str)
848 715 : name_c_ptr=c_loc(name_c)
849 : end if
850 324001 : libxc_functionals_getid=int(xc_functional_get_number(name_c_ptr))
851 : #else
852 : libxc_functionals_getid=-1
853 : if (.false.) write(std_out,*) xcname
854 : #endif
855 :
856 324001 : end function libxc_functionals_getid
857 : !!***
858 :
859 : !----------------------------------------------------------------------
860 :
861 : !!****f* libxc_functionals/libxc_functionals_family_from_id
862 : !! NAME
863 : !! libxc_functionals_family_from_id
864 : !!
865 : !! FUNCTION
866 : !! Return family of a XC functional from its id
867 : !!
868 : !! INPUTS
869 : !! xcid= id of a LibXC functional
870 : !!
871 : !! SOURCE
872 :
873 34472 : function libxc_functionals_family_from_id(xcid)
874 :
875 : !Arguments ------------------------------------
876 : integer :: libxc_functionals_family_from_id
877 : integer,intent(in) :: xcid
878 : !Local variables-------------------------------
879 : #if defined HAVE_LIBXC && defined HAVE_FC_ISO_C_BINDING
880 : integer(C_INT) :: xcid_c
881 : #endif
882 :
883 : ! *************************************************************************
884 :
885 : #if defined HAVE_LIBXC && defined HAVE_FC_ISO_C_BINDING
886 34472 : xcid_c=int(xcid,kind=C_INT)
887 34472 : libxc_functionals_family_from_id=int(xc_family_from_id(xcid_c,C_NULL_PTR,C_NULL_PTR))
888 : #else
889 : libxc_functionals_family_from_id=-1
890 : if (.false.) write(std_out,*) xcid
891 : #endif
892 :
893 27180 : end function libxc_functionals_family_from_id
894 : !!***
895 :
896 : !----------------------------------------------------------------------
897 :
898 : !!****f* libxc_functionals/libxc_functionals_ixc
899 : !! NAME
900 : !! libxc_functionals_ixc
901 : !!
902 : !! FUNCTION
903 : !! Return the value of ixc used to initialize the XC structure
904 : !!
905 : !! INPUTS
906 : !! [xc_functionals(2)]=<type(libxc_functional_type)>, optional argument
907 : !! Handle for XC functionals
908 : !!
909 : !! SOURCE
910 :
911 377872 : function libxc_functionals_ixc(xc_functionals)
912 :
913 : !Arguments ------------------------------------
914 : integer :: libxc_functionals_ixc
915 : type(libxc_functional_type),intent(in),optional :: xc_functionals(2)
916 :
917 : ! *************************************************************************
918 :
919 377872 : if (present(xc_functionals)) then
920 1545 : libxc_functionals_ixc=xc_functionals(1)%abi_ixc
921 : else
922 376327 : libxc_functionals_ixc=xc_global(1)%abi_ixc
923 : end if
924 :
925 377872 : end function libxc_functionals_ixc
926 : !!***
927 :
928 : !----------------------------------------------------------------------
929 :
930 : !!****f* libxc_functionals/libxc_functionals_islda
931 : !! NAME
932 : !! libxc_functionals_islda
933 : !!
934 : !! FUNCTION
935 : !! Test function to identify whether the presently used (set of) functional(s)
936 : !! is a LDA or not
937 : !!
938 : !! INPUTS
939 : !! [xc_functionals(2)]=<type(libxc_functional_type)>, optional argument
940 : !! Handle for XC functionals
941 : !!
942 : !! SOURCE
943 :
944 1303 : function libxc_functionals_islda(xc_functionals)
945 :
946 : !Arguments ------------------------------------
947 : logical :: libxc_functionals_islda
948 : type(libxc_functional_type),intent(in),optional :: xc_functionals(2)
949 :
950 : ! *************************************************************************
951 :
952 1303 : libxc_functionals_islda = .false.
953 1303 : if (.not.libxc_constants_initialized) call libxc_functionals_constants_load()
954 :
955 1303 : if (present(xc_functionals)) then
956 : libxc_functionals_islda=(any(xc_functionals%family==XC_FAMILY_LDA) .or. &
957 5221 : & any(xc_functionals%family==XC_FAMILY_HYB_LDA))
958 : else
959 : libxc_functionals_islda=(any(xc_global%family==XC_FAMILY_LDA) .or. &
960 0 : & any(xc_global%family==XC_FAMILY_HYB_LDA))
961 : end if
962 :
963 1303 : end function libxc_functionals_islda
964 : !!***
965 :
966 : !----------------------------------------------------------------------
967 :
968 : !!****f* libxc_functionals/libxc_functionals_isgga
969 : !! NAME
970 : !! libxc_functionals_isgga
971 : !!
972 : !! FUNCTION
973 : !! Test function to identify whether the presently used (set of) functional(s)
974 : !! is a GGA or not
975 : !!
976 : !! INPUTS
977 : !! [xc_functionals(2)]=<type(libxc_functional_type)>, optional argument
978 : !! Handle for XC functionals
979 : !!
980 : !! SOURCE
981 :
982 856260 : function libxc_functionals_isgga(xc_functionals)
983 :
984 : !Arguments ------------------------------------
985 : logical :: libxc_functionals_isgga
986 : type(libxc_functional_type),intent(in),optional :: xc_functionals(2)
987 :
988 : ! *************************************************************************
989 :
990 856260 : libxc_functionals_isgga = .false.
991 856260 : if (.not.libxc_constants_initialized) call libxc_functionals_constants_load()
992 :
993 856260 : if (present(xc_functionals)) then
994 : libxc_functionals_isgga=(any(xc_functionals%family==XC_FAMILY_GGA) .or. &
995 1600652 : & any(xc_functionals%family==XC_FAMILY_HYB_GGA))
996 : else
997 : libxc_functionals_isgga=(any(xc_global%family==XC_FAMILY_GGA) .or. &
998 2090976 : & any(xc_global%family==XC_FAMILY_HYB_GGA))
999 : end if
1000 :
1001 856260 : end function libxc_functionals_isgga
1002 : !!***
1003 :
1004 : !----------------------------------------------------------------------
1005 :
1006 : !!****f* libxc_functionals/libxc_functionals_ismgga
1007 : !! NAME
1008 : !! libxc_functionals_ismgga
1009 : !!
1010 : !! FUNCTION
1011 : !! Test function to identify whether the presently used (set of) functional(s)
1012 : !! is a Meta-GGA or not
1013 : !!
1014 : !! INPUTS
1015 : !! [xc_functionals(2)]=<type(libxc_functional_type)>, optional argument
1016 : !! Handle for XC functionals
1017 : !!
1018 : !! SOURCE
1019 :
1020 867610 : function libxc_functionals_ismgga(xc_functionals)
1021 :
1022 : !Arguments ------------------------------------
1023 : logical :: libxc_functionals_ismgga
1024 : type(libxc_functional_type),intent(in),optional :: xc_functionals(2)
1025 :
1026 : ! *************************************************************************
1027 :
1028 867610 : libxc_functionals_ismgga = .false.
1029 867610 : if (.not.libxc_constants_initialized) call libxc_functionals_constants_load()
1030 :
1031 867610 : if (present(xc_functionals)) then
1032 : libxc_functionals_ismgga=(any(xc_functionals%family==XC_FAMILY_MGGA) .or. &
1033 1541599 : & any(xc_functionals%family==XC_FAMILY_HYB_MGGA))
1034 : else
1035 : libxc_functionals_ismgga=(any(xc_global%family==XC_FAMILY_MGGA) .or. &
1036 2184283 : & any(xc_global%family==XC_FAMILY_HYB_MGGA))
1037 : end if
1038 :
1039 867610 : end function libxc_functionals_ismgga
1040 : !!***
1041 :
1042 : !----------------------------------------------------------------------
1043 :
1044 : !!****f* libxc_functionals/libxc_functionals_is_tb09
1045 : !! NAME
1046 : !! libxc_functionals_is_tb09
1047 : !!
1048 : !! FUNCTION
1049 : !! Test function to identify whether the presently used functional
1050 : !! is Tran-Blaha 2009 or not
1051 : !!
1052 : !! INPUTS
1053 : !! [xc_functionals(2)]=<type(libxc_functional_type)>, optional argument
1054 : !! Handle for XC functionals
1055 : !!
1056 : !! SOURCE
1057 :
1058 71703 : logical function libxc_functionals_is_tb09(xc_functionals) result(ans)
1059 :
1060 : !Arguments ------------------------------------
1061 : type(libxc_functional_type),intent(in),optional :: xc_functionals(2)
1062 : !Local variables-------------------------------
1063 : integer :: id_tb09
1064 :
1065 : ! *************************************************************************
1066 :
1067 71703 : ans = .false.
1068 71703 : id_tb09 = libxc_functionals_getid('XC_MGGA_X_TB09')
1069 :
1070 71703 : if (present(xc_functionals)) then
1071 0 : ans = any(xc_functionals%id == id_tb09)
1072 : else
1073 214988 : ans = any(xc_global%id == id_tb09)
1074 : end if
1075 :
1076 71703 : end function libxc_functionals_is_tb09
1077 : !!***
1078 :
1079 : !----------------------------------------------------------------------
1080 :
1081 : !!****f* libxc_functionals/libxc_functionals_is_potential_only
1082 : !! NAME
1083 : !! libxc_functionals_is_potential_only
1084 : !!
1085 : !! FUNCTION
1086 : !! Test function to identify whether the presently used (set of) functional(s)
1087 : !! provides a potential-only functional
1088 : !!
1089 : !! INPUTS
1090 : !! [xc_functionals(2)]=<type(libxc_functional_type)>, optional argument
1091 : !! Handle for XC functionals
1092 : !!
1093 : !! SOURCE
1094 :
1095 2331 : logical function libxc_functionals_is_potential_only(xc_functionals) result(ans)
1096 :
1097 : !Arguments ------------------------------------
1098 : type(libxc_functional_type),intent(in),optional,target :: xc_functionals(2)
1099 : !Local variables-------------------------------
1100 : integer :: id_tb09,id_bj06
1101 :
1102 : ! *************************************************************************
1103 :
1104 2331 : ans = .false.
1105 2331 : id_tb09 = libxc_functionals_getid('XC_MGGA_X_TB09')
1106 2331 : id_bj06 = libxc_functionals_getid('XC_MGGA_X_BJ06')
1107 :
1108 2331 : if (present(xc_functionals)) then
1109 : ans = (any(xc_functionals%id == id_tb09) .or. &
1110 13952 : & any(xc_functionals%id == id_bj06))
1111 : else
1112 : ans = (any(xc_global%id == id_tb09) .or. &
1113 0 : & any(xc_global%id == id_bj06))
1114 : end if
1115 :
1116 2331 : end function libxc_functionals_is_potential_only
1117 : !!***
1118 :
1119 : !----------------------------------------------------------------------
1120 :
1121 : !!****f* libxc_functionals/libxc_functionals_set_c_tb09
1122 : !! NAME
1123 : !! libxc_functionals_set_c_tb09
1124 : !!
1125 : !! FUNCTION
1126 : !! Set c parameter for the Tran-Blaha 2009 functional
1127 : !!
1128 : !! INPUTS
1129 : !! xc_c_tb09= value of the c parameter to set for the TB09 functional
1130 : !! [xc_functionals(2)]=<type(libxc_functional_type)>, optional argument
1131 : !! Handle for XC functionals
1132 : !!
1133 : !! SOURCE
1134 :
1135 71 : subroutine libxc_functionals_set_c_tb09(xc_tb09_c,xc_functionals)
1136 :
1137 : !Arguments ------------------------------------
1138 : real(dp),intent(in) :: xc_tb09_c
1139 : type(libxc_functional_type),intent(inout),optional :: xc_functionals(2)
1140 : !Local variables -------------------------------
1141 : integer :: id_tb09,ii
1142 :
1143 : ! *************************************************************************
1144 :
1145 71 : id_tb09 = libxc_functionals_getid('XC_MGGA_X_TB09')
1146 :
1147 71 : if (present(xc_functionals)) then
1148 0 : do ii=1,2
1149 0 : if (xc_functionals(ii)%id == id_tb09) then
1150 0 : xc_functionals(ii)%xc_tb09_c = xc_tb09_c
1151 : end if
1152 : end do
1153 : else
1154 213 : do ii=1,2
1155 213 : if (xc_global(ii)%id == id_tb09) then
1156 71 : xc_global(ii)%xc_tb09_c = xc_tb09_c
1157 : end if
1158 : end do
1159 : end if
1160 :
1161 71 : end subroutine libxc_functionals_set_c_tb09
1162 : !!***
1163 :
1164 : !----------------------------------------------------------------------
1165 :
1166 : !!****f* libxc_functionals/libxc_functionals_needs_tau
1167 : !! NAME
1168 : !! libxc_functionals_needs_tau
1169 : !!
1170 : !! FUNCTION
1171 : !! Test function to identify whether the presently used (set of) functional(s)
1172 : !! needs the kinetic energy density or not
1173 : !!
1174 : !! INPUTS
1175 : !! [xc_functionals(2)]=<type(libxc_functional_type)>, optional argument
1176 : !! Handle for XC functionals
1177 : !!
1178 : !! SOURCE
1179 :
1180 858659 : function libxc_functionals_needs_tau(xc_functionals)
1181 :
1182 : !Arguments ------------------------------------
1183 : logical :: libxc_functionals_needs_tau
1184 : type(libxc_functional_type),intent(in),optional :: xc_functionals(2)
1185 :
1186 : ! *************************************************************************
1187 :
1188 858659 : libxc_functionals_needs_tau = .false.
1189 :
1190 858659 : if (present(xc_functionals)) then
1191 803609 : libxc_functionals_needs_tau=(any(xc_functionals%needs_tau))
1192 : else
1193 1161438 : libxc_functionals_needs_tau=(any(xc_global%needs_tau))
1194 : end if
1195 :
1196 858659 : end function libxc_functionals_needs_tau
1197 : !!***
1198 :
1199 : !----------------------------------------------------------------------
1200 :
1201 : !!****f* libxc_functionals/libxc_functionals_needs_laplacian
1202 : !! NAME
1203 : !! libxc_functionals_needs_laplacian
1204 : !!
1205 : !! FUNCTION
1206 : !! Test function to identify whether the presently used (set of) functional(s)
1207 : !! needs the laplacian of the density or not
1208 : !!
1209 : !! INPUTS
1210 : !! [xc_functionals(2)]=<type(libxc_functional_type)>, optional argument
1211 : !! Handle for XC functionals
1212 : !!
1213 : !! SOURCE
1214 :
1215 855102 : function libxc_functionals_needs_laplacian(xc_functionals)
1216 :
1217 : !Arguments ------------------------------------
1218 : logical :: libxc_functionals_needs_laplacian
1219 : type(libxc_functional_type),intent(in),optional :: xc_functionals(2)
1220 :
1221 : ! *************************************************************************
1222 :
1223 855102 : libxc_functionals_needs_laplacian = .false.
1224 :
1225 855102 : if (present(xc_functionals)) then
1226 1029948 : libxc_functionals_needs_laplacian=(any(xc_functionals%needs_laplacian))
1227 : else
1228 1394510 : libxc_functionals_needs_laplacian=(any(xc_global%needs_laplacian))
1229 : end if
1230 :
1231 855102 : end function libxc_functionals_needs_laplacian
1232 : !!***
1233 :
1234 : !----------------------------------------------------------------------
1235 :
1236 : !!****f* libxc_functionals/libxc_functionals_needs_temperature
1237 : !! NAME
1238 : !! libxc_functionals_needs_temperature
1239 : !!
1240 : !! FUNCTION
1241 : !! Test function to identify whether the presently used (set of) functional(s)
1242 : !! needs the electronic temperature or not
1243 : !!
1244 : !! INPUTS
1245 : !! [xc_functionals(2)]=<type(libxc_functional_type)>, optional argument
1246 : !! Handle for XC functionals
1247 : !!
1248 : !! SOURCE
1249 :
1250 0 : function libxc_functionals_needs_temperature(xc_functionals)
1251 :
1252 : !Arguments ------------------------------------
1253 : logical :: libxc_functionals_needs_temperature
1254 : type(libxc_functional_type),intent(in),optional :: xc_functionals(2)
1255 :
1256 : ! *************************************************************************
1257 :
1258 0 : libxc_functionals_needs_temperature = .false.
1259 :
1260 0 : if (present(xc_functionals)) then
1261 0 : libxc_functionals_needs_temperature=(any(xc_functionals%temperature>tol8))
1262 : else
1263 0 : libxc_functionals_needs_temperature=(any(xc_global%temperature>tol8))
1264 : end if
1265 :
1266 0 : end function libxc_functionals_needs_temperature
1267 : !!***
1268 :
1269 : !----------------------------------------------------------------------
1270 :
1271 : !!****f* libxc_functionals/libxc_functionals_set_temperature
1272 : !! NAME
1273 : !! libxc_functionals_set_temperature
1274 : !!
1275 : !! FUNCTION
1276 : !! Set the electronic temperature in a (set of) of XC functional(s)
1277 : !! No action when no temperature dependence
1278 : !!
1279 : !! INPUTS
1280 : !! temperature=electronic temperature (in Kelvin units)
1281 : !! [xc_functionals(2)]=<type(libxc_functional_type)>, optional argument
1282 : !! Handle for XC functionals
1283 : !!
1284 : !! OUTPUT
1285 : !!
1286 : !! SOURCE
1287 :
1288 0 : subroutine libxc_functionals_set_temperature(temperature,xc_functionals)
1289 :
1290 : !Arguments ------------------------------------
1291 : real(dp),intent(in) :: temperature
1292 : type(libxc_functional_type),intent(in),optional,target :: xc_functionals(2)
1293 : !Local variables -------------------------------
1294 : integer :: ii
1295 : type(libxc_functional_type),pointer :: xc_func
1296 :
1297 : ! *************************************************************************
1298 :
1299 0 : do ii = 1, 2
1300 :
1301 : ! Select XC functional
1302 0 : if (present(xc_functionals)) then
1303 0 : xc_func => xc_functionals(ii)
1304 : else
1305 0 : xc_func => xc_global(ii)
1306 : end if
1307 :
1308 0 : if (xc_func%id>0) then
1309 0 : call libxc_functionals_set_temp(xc_func,temperature)
1310 : end if
1311 :
1312 : end do
1313 :
1314 0 : end subroutine libxc_functionals_set_temperature
1315 : !!***
1316 :
1317 : !----------------------------------------------------------------------
1318 :
1319 : !!****f* libxc_functionals/libxc_functionals_has_kxc
1320 : !! NAME
1321 : !! libxc_functionals_has_kxc
1322 : !!
1323 : !! FUNCTION
1324 : !! Test function to identify whether the presently used (set of) functional(s)
1325 : !! provides Kxc or not (fxc in the libXC convention)
1326 : !!
1327 : !! INPUTS
1328 : !! [xc_functionals(2)]=<type(libxc_functional_type)>, optional argument
1329 : !! Handle for XC functionals
1330 : !!
1331 : !! SOURCE
1332 :
1333 491435 : function libxc_functionals_has_kxc(xc_functionals)
1334 :
1335 : !Arguments ------------------------------------
1336 : logical :: libxc_functionals_has_kxc
1337 : type(libxc_functional_type),intent(in),optional,target :: xc_functionals(2)
1338 : !Local variables-------------------------------
1339 : integer :: ii
1340 :
1341 : ! *************************************************************************
1342 :
1343 491435 : libxc_functionals_has_kxc=.true.
1344 :
1345 1474305 : do ii=1,2
1346 1474305 : if (present(xc_functionals)) then
1347 5318 : if (.not.xc_functionals(ii)%has_fxc) libxc_functionals_has_kxc=.false.
1348 : else
1349 1950381 : if (.not.xc_global(ii)%has_fxc) libxc_functionals_has_kxc=.false.
1350 : end if
1351 : end do
1352 :
1353 491435 : end function libxc_functionals_has_kxc
1354 : !!***
1355 :
1356 : !----------------------------------------------------------------------
1357 :
1358 : !!****f* libxc_functionals/libxc_functionals_has_k3xc
1359 : !! NAME
1360 : !! libxc_functionals_has_k3xc
1361 : !!
1362 : !! FUNCTION
1363 : !! Test function to identify whether the presently used (set of) functional(s)
1364 : !! provides K3xc or not (kxc in the libXC convention)
1365 : !!
1366 : !! INPUTS
1367 : !! [xc_functionals(2)]=<type(libxc_functional_type)>, optional argument
1368 : !! Handle for XC functionals
1369 : !!
1370 : !! SOURCE
1371 :
1372 490321 : function libxc_functionals_has_k3xc(xc_functionals)
1373 :
1374 : !Arguments ------------------------------------
1375 : logical :: libxc_functionals_has_k3xc
1376 : type(libxc_functional_type),intent(in),optional,target :: xc_functionals(2)
1377 : !Local variables-------------------------------
1378 : integer :: ii
1379 :
1380 : ! *************************************************************************
1381 :
1382 490321 : libxc_functionals_has_k3xc=.true.
1383 :
1384 1470963 : do ii=1,2
1385 1470963 : if (present(xc_functionals)) then
1386 3090 : if (.not.xc_functionals(ii)%has_kxc) libxc_functionals_has_k3xc=.false.
1387 : else
1388 1948153 : if (.not.xc_global(ii)%has_kxc) libxc_functionals_has_k3xc=.false.
1389 : end if
1390 : end do
1391 :
1392 490321 : end function libxc_functionals_has_k3xc
1393 : !!***
1394 :
1395 : !----------------------------------------------------------------------
1396 :
1397 : !!****f* libxc_functionals/libxc_functionals_nspin
1398 : !! NAME
1399 : !! libxc_functionals_nspin
1400 : !!
1401 : !! FUNCTION
1402 : !! Returns the number of spin components for the (set of) XC functional(s)
1403 : !!
1404 : !! INPUTS
1405 : !! [xc_functionals(2)]=<type(libxc_functional_type)>, optional argument
1406 : !! Handle for XC functionals
1407 : !!
1408 : !! SOURCE
1409 :
1410 240 : function libxc_functionals_nspin(xc_functionals)
1411 :
1412 : !Arguments ------------------------------------
1413 : integer :: libxc_functionals_nspin
1414 : type(libxc_functional_type),intent(in),optional :: xc_functionals(2)
1415 :
1416 : ! *************************************************************************
1417 :
1418 240 : libxc_functionals_nspin = 1
1419 :
1420 240 : if (present(xc_functionals)) then
1421 0 : if (any(xc_functionals%nspin==2)) libxc_functionals_nspin=2
1422 : else
1423 630 : if (any(xc_global%nspin==2)) libxc_functionals_nspin=2
1424 : end if
1425 :
1426 240 : end function libxc_functionals_nspin
1427 : !!***
1428 :
1429 : !----------------------------------------------------------------------
1430 :
1431 : !!****f* libxc_functionals/libxc_functionals_is_hybrid
1432 : !! NAME
1433 : !! libxc_functionals_is_hybrid
1434 : !!
1435 : !! FUNCTION
1436 : !! Test function to identify whether the presently used (set of) functional(s)
1437 : !! is hybrid or not
1438 : !!
1439 : !! INPUTS
1440 : !! [xc_functionals(2)]=<type(libxc_functional_type)>, optional argument
1441 : !! Handle for XC functionals
1442 : !!
1443 : !! SOURCE
1444 :
1445 521760 : function libxc_functionals_is_hybrid(xc_functionals)
1446 :
1447 : !Arguments ------------------------------------
1448 : logical :: libxc_functionals_is_hybrid
1449 : type(libxc_functional_type),intent(in),optional :: xc_functionals(2)
1450 :
1451 : ! *************************************************************************
1452 :
1453 521760 : libxc_functionals_is_hybrid = .false.
1454 :
1455 521760 : if (present(xc_functionals)) then
1456 5179 : libxc_functionals_is_hybrid=(any(xc_functionals%is_hybrid))
1457 : else
1458 1552452 : libxc_functionals_is_hybrid=(any(xc_global%is_hybrid))
1459 : end if
1460 :
1461 521760 : end function libxc_functionals_is_hybrid
1462 : !!***
1463 :
1464 : !----------------------------------------------------------------------
1465 :
1466 : !!****f* libxc_functionals/libxc_functionals_is_hybrid_from_id
1467 : !! NAME
1468 : !! libxc_functionals_is_hybrid_from_id
1469 : !!
1470 : !! FUNCTION
1471 : !! Test function to identify whether a functional is hybrid or not, from its id
1472 : !!
1473 : !! INPUTS
1474 : !! xcid= id of a LibXC functional
1475 : !!
1476 : !! SOURCE
1477 :
1478 28111 : function libxc_functionals_is_hybrid_from_id(xcid)
1479 :
1480 : !Arguments ------------------------------------
1481 : logical :: libxc_functionals_is_hybrid_from_id
1482 : integer,intent(in) :: xcid
1483 : !Local variables-------------------------------
1484 : #if defined HAVE_LIBXC && defined HAVE_FC_ISO_C_BINDING
1485 : integer(C_INT) :: xcid_c
1486 : #endif
1487 :
1488 : ! *************************************************************************
1489 :
1490 : #if defined HAVE_LIBXC && defined HAVE_FC_ISO_C_BINDING
1491 28111 : xcid_c=int(xcid,kind=C_INT)
1492 27180 : libxc_functionals_is_hybrid_from_id =(xc_func_is_hybrid_from_id(xcid_c)==1)
1493 : #else
1494 : libxc_functionals_is_hybrid_from_id = .false.
1495 : if (.false.) write(std_out,*) xcid
1496 : #endif
1497 :
1498 27180 : end function libxc_functionals_is_hybrid_from_id
1499 : !!***
1500 :
1501 : !----------------------------------------------------------------------
1502 :
1503 : !!****f* libxc_functionals/libxc_functionals_get_hybridparams
1504 : !! NAME
1505 : !! libxc_functionals_get_hybridparams
1506 : !!
1507 : !! FUNCTION
1508 : !! Returns the parameters of an hybrid functional (mixing coefficient(s) and range separation)
1509 : !! Applies on a (set of) functional(s)
1510 : !!
1511 : !! INPUTS
1512 : !! [xc_functionals(2)]=<type(libxc_functional_type)>, optional argument
1513 : !! Handle for XC functionals
1514 : !!
1515 : !! OUTPUT
1516 : !! [hyb_mixing] = mixing factor of Fock contribution
1517 : !! [hyb_mixing_sr]= mixing factor of short-range Fock contribution
1518 : !! [hyb_range] = Range (for separation)
1519 : !!
1520 : !! SOURCE
1521 :
1522 341127 : subroutine libxc_functionals_get_hybridparams(hyb_mixing,hyb_mixing_sr,hyb_range,xc_functionals)
1523 :
1524 : !Arguments ------------------------------------
1525 : real(dp),intent(out),optional :: hyb_mixing,hyb_mixing_sr,hyb_range
1526 : type(libxc_functional_type),intent(in),optional,target :: xc_functionals(2)
1527 : !Local variables -------------------------------
1528 : integer :: ii
1529 : character(len=500) :: msg
1530 : type(libxc_functional_type),pointer :: xc_func
1531 :
1532 : ! *************************************************************************
1533 :
1534 341127 : if (present(hyb_mixing )) hyb_mixing =zero
1535 341127 : if (present(hyb_mixing_sr)) hyb_mixing_sr=zero
1536 341127 : if (present(hyb_range )) hyb_range =zero
1537 :
1538 1023381 : do ii = 1, 2
1539 :
1540 : ! Select XC functional
1541 682254 : if (present(xc_functionals)) then
1542 2160 : xc_func => xc_functionals(ii)
1543 : else
1544 680094 : xc_func => xc_global(ii)
1545 : end if
1546 :
1547 : ! Mixing coefficient for the Fock contribution
1548 682254 : if (present(hyb_mixing)) then
1549 681830 : if (abs(xc_func%hyb_mixing) > tol8) then
1550 190 : if (abs(hyb_mixing) <= tol8) then
1551 190 : hyb_mixing=xc_func%hyb_mixing
1552 : else
1553 0 : msg='Invalid XC functional: contains 2 hybrid exchange functionals!'
1554 0 : ABI_ERROR(msg)
1555 : end if
1556 : end if
1557 : end if
1558 :
1559 : ! Mixing coefficient for the short-range Fock contribution
1560 682254 : if (present(hyb_mixing_sr)) then
1561 681830 : if (abs(xc_func%hyb_mixing_sr) > tol8) then
1562 2670 : if (abs(hyb_mixing_sr) <= tol8) then
1563 2670 : hyb_mixing_sr=xc_func%hyb_mixing_sr
1564 : else
1565 0 : msg='Invalid XC functional: contains 2 hybrid exchange functionals!'
1566 0 : ABI_ERROR(msg)
1567 : end if
1568 : end if
1569 : end if
1570 :
1571 : ! Range separation
1572 1023381 : if (present(hyb_range)) then
1573 682254 : if (abs(xc_func%hyb_range) > tol8) then
1574 2673 : if (abs(hyb_range) <= tol8) then
1575 2673 : hyb_range=xc_func%hyb_range
1576 : else
1577 0 : msg='Invalid XC functional: contains 2 hybrid exchange functionals!'
1578 0 : ABI_ERROR(msg)
1579 : end if
1580 : end if
1581 : end if
1582 :
1583 : end do
1584 :
1585 341127 : end subroutine libxc_functionals_get_hybridparams
1586 : !!***
1587 :
1588 : !----------------------------------------------------------------------
1589 :
1590 : !!****f* libxc_functionals/libxc_functionals_set_hybridparams
1591 : !! NAME
1592 : !! libxc_functionals_set_hybridparams
1593 : !!
1594 : !! FUNCTION
1595 : !! Set the parameters of an hybrid functional (mixing coefficient(s) and range separation)
1596 : !! Applies on a (set of) functional(s)
1597 : !!
1598 : !! INPUTS
1599 : !! [hyb_mixing] = mixing factor of Fock contribution
1600 : !! [hyb_mixing_sr] = mixing factor of short-range Fock contribution
1601 : !! [hyb_range] = Range (for separation)
1602 : !! [xc_functionals(2)]=<type(libxc_functional_type)>, optional argument
1603 : !! Handle for XC functionals
1604 : !!
1605 : !! OUTPUT
1606 : !!
1607 : !! SOURCE
1608 :
1609 49 : subroutine libxc_functionals_set_hybridparams(hyb_mixing,hyb_mixing_sr,hyb_range,xc_functionals)
1610 :
1611 : !Arguments ------------------------------------
1612 : real(dp),intent(in),optional :: hyb_mixing,hyb_mixing_sr,hyb_range
1613 : type(libxc_functional_type),intent(in),optional,target :: xc_functionals(2)
1614 : !Local variables -------------------------------
1615 : integer :: ii,id_pbe0,id_hse03,id_hse06
1616 : logical :: is_pbe0,is_hse
1617 : integer :: func_id(2)
1618 : character(len=500) :: msg
1619 : type(libxc_functional_type),pointer :: xc_func
1620 : #if defined HAVE_LIBXC && defined HAVE_FC_ISO_C_BINDING
1621 : integer(C_INT) :: npar_c
1622 : real(C_DOUBLE) :: alpha_c,beta_c,omega_c,param_c(3)
1623 : #endif
1624 :
1625 : ! *************************************************************************
1626 :
1627 49 : is_pbe0=.false.
1628 49 : is_hse =.false.
1629 49 : id_pbe0=libxc_functionals_getid('HYB_GGA_XC_PBEH')
1630 49 : id_hse03=libxc_functionals_getid('HYB_GGA_XC_HSE03')
1631 49 : id_hse06=libxc_functionals_getid('HYB_GGA_XC_HSE06')
1632 :
1633 147 : do ii = 1, 2
1634 :
1635 : ! Select XC functional
1636 98 : if (present(xc_functionals)) then
1637 2 : xc_func => xc_functionals(ii)
1638 : else
1639 96 : xc_func => xc_global(ii)
1640 : end if
1641 98 : func_id(ii)=xc_func%id
1642 :
1643 : ! Doesnt work with all hybrid functionals
1644 98 : if (is_pbe0.or.is_hse) then
1645 0 : msg='Invalid XC functional: contains 2 hybrid exchange functionals!'
1646 0 : ABI_ERROR(msg)
1647 : end if
1648 98 : is_pbe0=(xc_func%id==id_pbe0)
1649 98 : is_hse=((xc_func%id==id_hse03).or.(xc_func%id==id_hse06))
1650 98 : if ((.not.is_pbe0).and.(.not.is_hse)) cycle
1651 :
1652 : #if defined HAVE_LIBXC && defined HAVE_FC_ISO_C_BINDING
1653 : ! New values for parameters
1654 :
1655 : ! PBE0 type functionals
1656 49 : if (present(hyb_mixing))then
1657 49 : xc_func%hyb_mixing=hyb_mixing
1658 49 : alpha_c=real(xc_func%hyb_mixing,kind=C_DOUBLE)
1659 49 : if (is_pbe0) then
1660 9 : npar_c=int(1,kind=C_INT) ; param_c(1)=alpha_c
1661 9 : call xc_func_set_params(xc_func%conf,param_c,npar_c)
1662 : endif
1663 : endif
1664 :
1665 : ! HSE type functionals
1666 98 : if(present(hyb_mixing_sr).or.present(hyb_range)) then
1667 49 : if (present(hyb_mixing_sr)) xc_func%hyb_mixing_sr=hyb_mixing_sr
1668 49 : if (present(hyb_range)) xc_func%hyb_range=hyb_range
1669 49 : beta_c =real(xc_func%hyb_mixing_sr,kind=C_DOUBLE)
1670 49 : omega_c=real(xc_func%hyb_range,kind=C_DOUBLE)
1671 49 : if (is_hse) then
1672 40 : npar_c=int(3,kind=C_INT)
1673 120 : param_c(1)=beta_c;param_c(2:3)=omega_c
1674 40 : call xc_func_set_params(xc_func%conf,param_c,npar_c)
1675 : endif
1676 : end if
1677 :
1678 : #else
1679 : ABI_UNUSED(hyb_mixing)
1680 : ABI_UNUSED(hyb_mixing_sr)
1681 : ABI_UNUSED(hyb_range)
1682 : #endif
1683 :
1684 : end do
1685 :
1686 49 : if ((.not.is_pbe0).and.(.not.is_hse)) then
1687 0 : write(msg,'(3a,2i6,a,a,i6,a,i6,a,i6,a)')'Invalid XC functional: not able to change parameters for this functional !',ch10,&
1688 0 : & 'The IDs are ',func_id(:),ch10,&
1689 0 : & 'Allowed HYB_GGA_XC_PBEH, HYB_GGA_XC_HSE03, and HYB_GGA_XC_HSE06 with IDs =',id_pbe0,',',id_hse03,',',id_hse06,'.'
1690 0 : ABI_ERROR(msg)
1691 : end if
1692 :
1693 49 : end subroutine libxc_functionals_set_hybridparams
1694 : !!***
1695 :
1696 : !----------------------------------------------------------------------
1697 :
1698 : !!****f* libxc_functionals/libxc_functionals_gga_from_hybrid
1699 : !! NAME
1700 : !! libxc_functionals_gga_from_hybrid
1701 : !!
1702 : !! FUNCTION
1703 : !! Returns a logical flag: TRUE if one can deduce, from the id of a hybrid functional set,
1704 : !! the id(s) of the GGA functional on which it is based.
1705 : !! Optionally returns the id of the GGA functional on which the hybrid functional is based
1706 : !! (2 integers defining the GGA X and C functionals).
1707 : !! - If an id is provided as input argument, it is used as input id;
1708 : !! - If not, the input id is taken from the optional xc_functionals datastructure;
1709 : !! - If no input argument is given, the input id is taken from the global xc_global datastructure.
1710 : !!
1711 : !! INPUTS
1712 : !! [hybrid_id]=<type(libxc_functional_type)>, optional : id of an input hybrid functional
1713 : !! [xc_functionals(2)]=<type(libxc_functional_type)>, optional : XC functionals from which
1714 : !! the id(s) can be used
1715 : !!
1716 : !! OUTPUT
1717 : !! [gga_id(2)]=array that contains the GGA libXC id(s)
1718 : !! libxc_functionals_gga_from_hybrid=.true. if the GGA has been found from the input id
1719 : !!
1720 : !! SOURCE
1721 :
1722 1225 : function libxc_functionals_gga_from_hybrid(gga_id,hybrid_id,xc_functionals)
1723 :
1724 : !Arguments ------------------------------------
1725 : !scalars
1726 : integer,intent(in),optional :: hybrid_id
1727 : logical :: libxc_functionals_gga_from_hybrid
1728 : !arrays
1729 : integer,intent(out),optional :: gga_id(2)
1730 : type(libxc_functional_type),intent(inout),optional,target :: xc_functionals(2)
1731 : !Local variables -------------------------------
1732 : !scalars
1733 : integer :: ii
1734 : logical :: is_hybrid
1735 : character(len=100) :: c_name,x_name,msg
1736 : #if defined HAVE_LIBXC && defined HAVE_FC_ISO_C_BINDING
1737 : character(len=100) :: xc_name
1738 : character(kind=C_CHAR,len=1),pointer :: strg_c
1739 : #endif
1740 : !arrays
1741 : integer :: trial_id(2)
1742 :
1743 : ! *************************************************************************
1744 :
1745 1225 : libxc_functionals_gga_from_hybrid=.false.
1746 :
1747 1225 : is_hybrid=.false.
1748 1225 : if (present(hybrid_id)) then
1749 931 : trial_id(1)=hybrid_id
1750 931 : trial_id(2)=0
1751 931 : is_hybrid=libxc_functionals_is_hybrid_from_id(trial_id(1))
1752 294 : else if (present(xc_functionals)) then
1753 0 : trial_id(1)=xc_functionals(1)%id
1754 0 : trial_id(2)=xc_functionals(2)%id
1755 0 : is_hybrid=libxc_functionals_is_hybrid(xc_functionals)
1756 : else
1757 294 : trial_id(1)=xc_global(1)%id
1758 294 : trial_id(2)=xc_global(2)%id
1759 294 : is_hybrid=libxc_functionals_is_hybrid(xc_global)
1760 : end if
1761 :
1762 1225 : c_name="unknown" ; x_name="unknown"
1763 :
1764 : !Specific treatment of the B3LYP functional, whose GGA counterpart does not exist in LibXC
1765 1225 : if (trial_id(1)==402 .or. trial_id(2)==402) then
1766 42 : libxc_functionals_gga_from_hybrid=.true.
1767 42 : if (present(gga_id)) then
1768 10 : gga_id(1)=0
1769 10 : gga_id(2)=-1402 ! This corresponds to a native ABINIT functional,
1770 : ! actually a composite from different LibXC functionals!
1771 10 : write(std_out,*)' libxc_functionals_gga_from_hybrid, return with gga_id=',gga_id
1772 : endif
1773 42 : return
1774 : endif
1775 :
1776 3549 : do ii = 1, 2
1777 :
1778 2366 : if ((trial_id(ii)<=0).or.(.not.is_hybrid)) cycle
1779 :
1780 1183 : if (libxc_functionals_gga_from_hybrid) then
1781 0 : msg='Invalid XC functional setup: contains 2 hybrid functionals!'
1782 0 : ABI_ERROR(msg)
1783 : end if
1784 :
1785 : #if defined HAVE_LIBXC && defined HAVE_FC_ISO_C_BINDING
1786 :
1787 1183 : call c_f_pointer(xc_functional_get_name(trial_id(ii)),strg_c)
1788 1183 : call xc_char_to_f(strg_c,xc_name)
1789 :
1790 : ! AVAILABLE FUNCTIONALS
1791 :
1792 : ! ===== PBE0 =====
1793 1183 : if (xc_name=="hyb_gga_xc_pbeh" .or. &
1794 1183 : & xc_name=="hyb_gga_xc_pbe0_13") then
1795 301 : c_name="GGA_C_PBE"
1796 301 : x_name="GGA_X_PBE"
1797 301 : libxc_functionals_gga_from_hybrid=.true.
1798 :
1799 : ! ===== HSE =====
1800 882 : else if (xc_name=="hyb_gga_xc_hse03" .or. &
1801 : & xc_name=="hyb_gga_xc_hse06" ) then
1802 882 : c_name="GGA_C_PBE"
1803 882 : x_name="GGA_X_PBE"
1804 882 : libxc_functionals_gga_from_hybrid=.true.
1805 : end if
1806 :
1807 :
1808 : #endif
1809 :
1810 : enddo ! ii
1811 :
1812 1183 : if (present(gga_id)) then
1813 284 : if (libxc_functionals_gga_from_hybrid) then
1814 284 : gga_id(1)=libxc_functionals_getid(c_name)
1815 284 : gga_id(2)=libxc_functionals_getid(x_name)
1816 : else
1817 0 : gga_id(:)=-1
1818 : end if
1819 : end if
1820 :
1821 : !Note that in the case of B3LYP functional, the return happened immediately after the setup of B3LYP parameters.
1822 :
1823 : end function libxc_functionals_gga_from_hybrid
1824 : !!***
1825 :
1826 : !----------------------------------------------------------------------
1827 :
1828 : !!****f* libxc_functionals/libxc_functionals_getvxc
1829 : !! NAME
1830 : !! libxc_functionals_getvxc
1831 : !!
1832 : !! FUNCTION
1833 : !! Return XC potential and energy, from input density (gradient etc...)
1834 : !!
1835 : !! INPUTS
1836 : !! ndvxc=size of dvxc
1837 : !! nd2vxc=size of d2vxc
1838 : !! npts=number of of points for the density
1839 : !! nspden=number of spin-density components
1840 : !! order=requested order of derivation
1841 : !! rho(npts,nspden)=electronic density
1842 : !! [grho2(npts,nspden)]=squared gradient of the density
1843 : !! [lrho(npts,nspden)]=laplacian of the density
1844 : !! [tau(npts,nspden)]= kinetic energy density
1845 : !!
1846 : !! OUTPUT
1847 : !! exc(npts)=XC energy density
1848 : !! vxc(npts,nspden)=derivative of the energy density wrt to the density
1849 : !! [vxclrho(npts,nspden)]=derivative of the energy density wrt to the density laplacian
1850 : !! [vxctau(npts,nspden)]=derivative of the energy density wrt to the kinetic energy density
1851 : !! [dvxc(npts,ndvxc)]=2nd derivative of the energy density wrt to the density
1852 : !! [vxcgr(npts,3)]=2nd derivative of the energy density wrt to the gradient
1853 : !! 2nd derivative of the energy density wrt to the density and the gradient
1854 : !! [d2vxc(npts,nd2vxc)]=3rd derivative of the energy density wrt to the density
1855 : !!
1856 : !! SIDE EFFECTS
1857 : !! [xc_functionals(2)]=<type(libxc_functional_type)>, optional argument
1858 : !! Handle for XC functionals
1859 : !!
1860 : !! SOURCE
1861 :
1862 1095357 : subroutine libxc_functionals_getvxc(ndvxc,nd2vxc,npts,nspden,order,rho,exc,vxc,&
1863 957098 : & grho2,vxcgr,lrho,vxclrho,tau,vxctau,dvxc,d2vxc,xc_functionals) ! Optional arguments
1864 :
1865 : !Arguments ------------------------------------
1866 : integer, intent(in) :: ndvxc,nd2vxc,npts,nspden,order
1867 : real(dp),intent(in) :: rho(npts,nspden)
1868 : real(dp),intent(out) :: vxc(npts,nspden),exc(npts)
1869 : real(dp),intent(in),optional :: grho2(npts,2*min(nspden,2)-1)
1870 : real(dp),intent(out),optional :: vxcgr(npts,3)
1871 : real(dp),intent(in),optional :: lrho(npts,nspden)
1872 : real(dp),intent(out),optional :: vxclrho(npts,nspden)
1873 : real(dp),intent(in),optional :: tau(npts,nspden)
1874 : real(dp),intent(out),optional :: vxctau(npts,nspden)
1875 : real(dp),intent(out),optional :: dvxc(npts,ndvxc)
1876 : real(dp),intent(out),optional :: d2vxc(npts,nd2vxc)
1877 : type(libxc_functional_type),intent(inout),optional,target :: xc_functionals(2)
1878 : !Local variables -------------------------------
1879 : !scalars
1880 : integer :: ii,ipts
1881 : logical :: is_gga,is_mgga,needs_tau,needs_laplacian,has_sigma_threshold
1882 : real(dp),target :: exctmp
1883 : character(len=500) :: msg
1884 : real(dp) :: sigma_threshold_max
1885 : #if defined HAVE_LIBXC && defined HAVE_FC_ISO_C_BINDING
1886 : type(C_PTR) :: rho_c,sigma_c,lrho_c,tau_c
1887 : #endif
1888 : !arrays
1889 730238 : real(dp),target :: rhotmp(nspden),sigma(3),vxctmp(nspden),vsigma(3)
1890 : real(dp),target :: v2rho2(3),v2rhosigma(6),v2sigma2(6)
1891 : real(dp),target :: v2rholapl(3),v2sigmalapl(6),v2lapl2(3)
1892 : real(dp),target :: v2rhotau(3),v2sigmatau(6),v2lapltau(3),v2tau2(3)
1893 : real(dp),target :: v3rho3(4),v3rho2sigma(9),v3rhosigma2(12),v3sigma3(10)
1894 730238 : real(dp),target :: lrhotmp(nspden),tautmp(nspden),vlrho(nspden),vtau(nspden)
1895 365119 : type(libxc_functional_type),pointer :: xc_funcs(:)
1896 : #if defined HAVE_LIBXC && defined HAVE_FC_ISO_C_BINDING
1897 : type(C_PTR) :: exc_c(2),vxc_c(2),vsigma_c(2),vlrho_c(2),vtau_c(2)
1898 : type(C_PTR) :: v2rho2_c(2),v2rhosigma_c(2),v2sigma2_c(2)
1899 : type(C_PTR) :: v2rholapl_c(2),v2sigmalapl_c(2),v2lapl2_c(2)
1900 : type(C_PTR) :: v2rhotau_c(2),v2sigmatau_c(2),v2lapltau_c(2),v2tau2_c(2)
1901 : type(C_PTR) :: v3rho3_c(2),v3rho2sigma_c(2),v3rhosigma2_c(2),v3sigma3_c(2)
1902 : #endif
1903 :
1904 : ! *************************************************************************
1905 :
1906 365119 : if (.not.libxc_constants_initialized) call libxc_functionals_constants_load()
1907 :
1908 : !Select XC functional(s)
1909 365119 : if (present(xc_functionals)) then
1910 1207 : xc_funcs => xc_functionals
1911 : else
1912 363912 : xc_funcs => xc_global
1913 : end if
1914 :
1915 365119 : is_gga =libxc_functionals_isgga (xc_funcs)
1916 365119 : is_mgga=libxc_functionals_ismgga(xc_funcs)
1917 578599 : needs_tau=(libxc_functionals_needs_tau(xc_funcs).and.present(tau))
1918 695175 : needs_laplacian=(libxc_functionals_needs_laplacian(xc_funcs).and.present(lrho))
1919 :
1920 1460476 : sigma_threshold_max=maxval(xc_funcs(:)%sigma_threshold,mask=(xc_funcs(:)%id>0))
1921 365119 : has_sigma_threshold=(sigma_threshold_max>zero)
1922 :
1923 365119 : if (is_gga.and.(.not.present(grho2))) then
1924 0 : msg='GGA needs gradient of density!'
1925 0 : ABI_BUG(msg)
1926 : end if
1927 365119 : if (is_mgga) then
1928 151639 : if (needs_tau) then
1929 151639 : if (present(vxctau).and.(.not.present(tau))) then
1930 0 : msg='meta-GGA needs tau!'
1931 0 : ABI_BUG(msg)
1932 : end if
1933 : end if
1934 151639 : if (needs_laplacian) then
1935 35063 : if (present(vxclrho).and.(.not.present(lrho))) then
1936 0 : msg='meta-GGA needs lrho!'
1937 0 : ABI_BUG(msg)
1938 : end if
1939 : end if
1940 : endif
1941 :
1942 : !Inititalize all output arrays to zero
1943 1619255565 : exc=zero ; vxc=zero
1944 1944156229 : if (present(dvxc)) dvxc=zero
1945 368577 : if (present(d2vxc)) d2vxc=zero
1946 1600945267 : if ((is_gga.or.is_mgga).and.present(vxcgr)) vxcgr=zero
1947 54379264 : if (is_mgga.and.present(vxclrho)) vxclrho=zero
1948 250809656 : if (is_mgga.and.present(vxctau)) vxctau=zero
1949 :
1950 : !Determine which XC outputs can be computed
1951 : #if defined HAVE_LIBXC && defined HAVE_FC_ISO_C_BINDING
1952 1095357 : do ii = 1,2
1953 730238 : if (xc_funcs(ii)%has_exc) then
1954 688715 : exc_c(ii)=c_loc(exctmp)
1955 : else
1956 41523 : exc_c(ii)=C_NULL_PTR
1957 : end if
1958 730238 : if (xc_funcs(ii)%has_vxc) then
1959 723778 : vxc_c(ii)=c_loc(vxctmp)
1960 723778 : vsigma_c(ii)=c_loc(vsigma)
1961 723778 : vtau_c(ii)=c_loc(vtau)
1962 723778 : vlrho_c(ii)=c_loc(vlrho)
1963 : else
1964 6460 : vxc_c(ii)=C_NULL_PTR
1965 6460 : vsigma_c(ii)=c_NULL_PTR
1966 6460 : vtau_c(ii)=C_NULL_PTR
1967 6460 : vlrho_c(ii)=C_NULL_PTR
1968 : end if
1969 730238 : if ((xc_funcs(ii)%has_fxc).and.(abs(order)>1)) then
1970 77065 : v2rho2_c(ii)=c_loc(v2rho2)
1971 77065 : v2sigma2_c(ii)=c_loc(v2sigma2)
1972 77065 : v2rhosigma_c(ii)=c_loc(v2rhosigma)
1973 77065 : if (is_mgga) then
1974 952 : v2rholapl_c(ii)=c_loc(v2rholapl)
1975 952 : v2sigmalapl_c(ii)=c_loc(v2sigmalapl)
1976 952 : v2lapl2_c(ii)=c_loc(v2lapl2)
1977 952 : v2rhotau_c(ii)=c_loc(v2rhotau)
1978 952 : v2sigmatau_c(ii)=c_loc(v2sigmatau)
1979 952 : v2lapltau_c(ii)=c_loc(v2lapltau)
1980 952 : v2tau2_c(ii)=c_loc(v2tau2)
1981 : end if
1982 : else
1983 653173 : v2rho2_c(ii)=C_NULL_PTR
1984 653173 : v2sigma2_c(ii)=C_NULL_PTR
1985 653173 : v2rhosigma_c(ii)=C_NULL_PTR
1986 653173 : if (is_mgga) then
1987 302326 : v2rholapl_c(ii)=C_NULL_PTR
1988 302326 : v2sigmalapl_c(ii)=C_NULL_PTR
1989 302326 : v2lapl2_c(ii)=C_NULL_PTR
1990 302326 : v2rhotau_c(ii)=C_NULL_PTR
1991 302326 : v2sigmatau_c(ii)=C_NULL_PTR
1992 302326 : v2lapltau_c(ii)=C_NULL_PTR
1993 302326 : v2tau2_c(ii)=C_NULL_PTR
1994 : end if
1995 : end if
1996 1095357 : if ((xc_funcs(ii)%has_kxc).and.(abs(order)>2)) then
1997 4 : v3rho3_c(ii)=c_loc(v3rho3)
1998 4 : v3sigma3_c(ii)=c_loc(v3sigma3)
1999 4 : v3rho2sigma_c(ii)=c_loc(v3rho2sigma)
2000 4 : v3rhosigma2_c(ii)=c_loc(v3rhosigma2)
2001 : else
2002 730234 : v3rho3_c(ii)=C_NULL_PTR
2003 730234 : v3sigma3_c(ii)=C_NULL_PTR
2004 730234 : v3rho2sigma_c(ii)=C_NULL_PTR
2005 730234 : v3rhosigma2_c(ii)=C_NULL_PTR
2006 : end if
2007 : end do
2008 : #endif
2009 :
2010 : !Initialize temporary arrays
2011 : #if defined HAVE_LIBXC && defined HAVE_FC_ISO_C_BINDING
2012 774634 : rhotmp=zero ; rho_c=c_loc(rhotmp)
2013 365119 : if (is_gga.or.is_mgga) then
2014 271613 : sigma=zero ; sigma_c=c_loc(sigma)
2015 : end if
2016 271613 : if (is_mgga) then
2017 303278 : tautmp=zero ; tau_c=c_loc(tautmp)
2018 303278 : lrhotmp=zero ;lrho_c=c_loc(lrhotmp)
2019 : end if
2020 : #endif
2021 :
2022 : !Some mGGA functionals require a special treatment
2023 245145 : if (is_mgga) then
2024 : !TB09 functional requires the c parameter to be set
2025 151639 : call libxc_functionals_compute_tb09(npts,nspden,rho,grho2,xc_funcs)
2026 : end if
2027 :
2028 : !Loop over points
2029 766155859 : do ipts=1,npts
2030 :
2031 : ! Convert the quantities provided by ABINIT to the ones needed by libxc
2032 765790740 : if (nspden == 1) then
2033 : ! ABINIT passes rho_up in the spin-unpolarized case, while the libxc
2034 : ! expects the total density
2035 1357782578 : rhotmp(1:nspden) = two*rho(ipts,1:nspden)
2036 : else
2037 260698353 : rhotmp(1:nspden) = rho(ipts,1:nspden)
2038 : end if
2039 765790740 : if (is_gga.or.is_mgga) then
2040 533255103 : if (nspden==1) then
2041 : ! ABINIT passes |grho_up|^2 while Libxc needs |grho_tot|^2
2042 458358329 : sigma(1) = four*grho2(ipts,1)
2043 : else
2044 : ! ABINIT passes |grho_up|^2, |grho_dn|^2, and |grho_tot|^2
2045 : ! while Libxc needs |grho_up|^2, grho_up.grho_dn, and |grho_dn|^2
2046 74896774 : sigma(1) = grho2(ipts,1)
2047 74896774 : sigma(2) = (grho2(ipts,3) - grho2(ipts,1) - grho2(ipts,2))/two
2048 74896774 : sigma(3) = grho2(ipts,2)
2049 : end if
2050 : ! Apply a threshold on sigma (cannot be done in libxc6, at present)
2051 533255103 : if (has_sigma_threshold) then
2052 34856586 : do ii=1,2*nspden-1
2053 34856586 : if (abs(sigma(ii))<=sigma_threshold_max) sigma(ii)=sigma_threshold_max
2054 : end do
2055 : end if
2056 : end if
2057 533255103 : if (is_mgga) then
2058 250292898 : if (nspden==1) then
2059 500585796 : if (needs_tau) tautmp(1:nspden) = two*tau(ipts,1:nspden)
2060 304271980 : if (needs_laplacian) lrhotmp(1:nspden) = two*lrho(ipts,1:nspden)
2061 : else
2062 0 : if (needs_tau) tautmp(1:nspden) = tau(ipts,1:nspden)
2063 0 : if (needs_laplacian) lrhotmp(1:nspden) = lrho(ipts,1:nspden)
2064 : end if
2065 : end if
2066 :
2067 : ! Loop over functionals
2068 2297737339 : do ii = 1,2
2069 1531581480 : if (xc_funcs(ii)%id<=0) cycle
2070 :
2071 : ! Get the energy and the potential (and possibly the other derivatives)
2072 : #if defined HAVE_LIBXC && defined HAVE_FC_ISO_C_BINDING
2073 3190415129 : exctmp=zero ; vxctmp=zero
2074 : ! ===== LDA =====
2075 1512512651 : if (xc_funcs(ii)%family==XC_FAMILY_LDA) then
2076 1058164524 : exctmp=zero ; vxctmp=zero ; v2rho2=zero ; v3rho3=zero
2077 : call xc_get_lda(xc_funcs(ii)%conf,1,rho_c, &
2078 517202585 : & exc_c(ii),vxc_c(ii),v2rho2_c(ii),v3rho3_c(ii))
2079 : ! ===== GGA =====
2080 995310066 : else if (xc_funcs(ii)%family==XC_FAMILY_GGA.or. &
2081 : & xc_funcs(ii)%family==XC_FAMILY_HYB_GGA) then
2082 1239037177 : exctmp=zero ; vxctmp=zero ; vsigma=zero
2083 548703352 : v2rho2=zero ; v2sigma2=zero ; v2rhosigma=zero
2084 548703352 : v3rho3=zero ; v3rho2sigma=zero ; v3rhosigma2=zero ; v3sigma3=zero
2085 : call xc_get_gga(xc_funcs(ii)%conf,1,rho_c,sigma_c, &
2086 : & exc_c(ii),vxc_c(ii),vsigma_c(ii), &
2087 : & v2rho2_c(ii),v2rhosigma_c(ii),v2sigma2_c(ii), &
2088 548703352 : & v3rho3_c(ii),v3rho2sigma_c(ii),v3rhosigma2_c(ii),v3sigma3_c(ii))
2089 : ! ===== mGGA =====
2090 446606714 : else if (xc_funcs(ii)%family==XC_FAMILY_MGGA.or. &
2091 : & xc_funcs(ii)%family==XC_FAMILY_HYB_MGGA) then
2092 1786426856 : exctmp=zero ; vxctmp=zero ; vsigma=zero ; vlrho=zero ; vtau=zero
2093 446606714 : v2rho2=zero ; v2sigma2=zero ; v2rhosigma=zero
2094 : ! At present, we don't use 2nd derivatives involving Tau or Laplacian
2095 : call xc_get_mgga(xc_funcs(ii)%conf,1,rho_c,sigma_c,lrho_c,tau_c, &
2096 : & exc_c(ii),vxc_c(ii),vsigma_c(ii),vlrho_c(ii),vtau_c(ii), &
2097 : & v2rho2_c(ii),v2rhosigma_c(ii),v2rholapl_c(ii),v2rhotau_c(ii),v2sigma2_c(ii), &
2098 446606714 : & v2sigmalapl_c(ii),v2sigmatau_c(ii),v2lapl2_c(ii),v2lapltau_c(ii),v2tau2_c(ii))
2099 : end if
2100 : #endif
2101 :
2102 1512512651 : exc(ipts) = exc(ipts) + exctmp
2103 3190415129 : vxc(ipts,1:nspden) = vxc(ipts,1:nspden) + vxctmp(1:nspden)
2104 :
2105 : ! Deal with fxc and kxc
2106 1512512651 : if (abs(order)>1) then
2107 : ! ----- LDA -----
2108 338069890 : if (xc_funcs(ii)%family==XC_FAMILY_LDA) then
2109 108958588 : if (nspden==1) then
2110 108916604 : if(order>=2) then
2111 108916604 : dvxc(ipts,1)=dvxc(ipts,1)+v2rho2(1)
2112 108916604 : if(order>2) then
2113 6912 : d2vxc(ipts,1)=d2vxc(ipts,1)+v3rho3(1)
2114 : endif
2115 0 : else if (order==-2) then
2116 0 : dvxc(ipts,1)=dvxc(ipts,1)+v2rho2(1)
2117 0 : dvxc(ipts,2)=dvxc(ipts,2)+v2rho2(1)
2118 : endif
2119 : else
2120 41984 : dvxc(ipts,1)=dvxc(ipts,1)+v2rho2(1)
2121 41984 : dvxc(ipts,2)=dvxc(ipts,2)+v2rho2(2)
2122 41984 : dvxc(ipts,3)=dvxc(ipts,3)+v2rho2(3)
2123 41984 : if(abs(order)>2) then
2124 0 : d2vxc(ipts,1)=d2vxc(ipts,1)+v3rho3(1)
2125 0 : d2vxc(ipts,2)=d2vxc(ipts,2)+v3rho3(2)
2126 0 : d2vxc(ipts,3)=d2vxc(ipts,3)+v3rho3(3)
2127 0 : d2vxc(ipts,4)=d2vxc(ipts,4)+v3rho3(4)
2128 : endif
2129 : endif
2130 : ! ----- GGA or mGGA -----
2131 : else if (xc_funcs(ii)%family==XC_FAMILY_GGA.or. &
2132 : & xc_funcs(ii)%family==XC_FAMILY_HYB_GGA.or. &
2133 229111302 : & xc_funcs(ii)%family==XC_FAMILY_MGGA.or. &
2134 : & xc_funcs(ii)%family==XC_FAMILY_HYB_MGGA) then
2135 229111302 : if (xc_funcs(ii)%kind==XC_EXCHANGE) then
2136 110452114 : if (nspden==1) then
2137 84061212 : dvxc(ipts,1)=v2rho2(1)*two
2138 84061212 : dvxc(ipts,2)=dvxc(ipts,1)
2139 84061212 : dvxc(ipts,3)=two*two*vsigma(1)
2140 84061212 : dvxc(ipts,4)=dvxc(ipts,3)
2141 84061212 : dvxc(ipts,5)=four*two*v2rhosigma(1)
2142 84061212 : dvxc(ipts,6)=dvxc(ipts,5)
2143 84061212 : dvxc(ipts,7)=two*four*four*v2sigma2(1)
2144 84061212 : dvxc(ipts,8)=dvxc(ipts,7)
2145 : else
2146 26390902 : dvxc(ipts,1)=v2rho2(1)
2147 26390902 : dvxc(ipts,2)=v2rho2(3)
2148 26390902 : dvxc(ipts,3)=two*vsigma(1)
2149 26390902 : dvxc(ipts,4)=two*vsigma(3)
2150 26390902 : dvxc(ipts,5)=two*v2rhosigma(1)
2151 26390902 : dvxc(ipts,6)=two*v2rhosigma(6)
2152 26390902 : dvxc(ipts,7)=four*v2sigma2(1)
2153 26390902 : dvxc(ipts,8)=four*v2sigma2(6)
2154 : end if
2155 118659188 : else if (xc_funcs(ii)%kind==XC_CORRELATION) then
2156 110452114 : if (nspden==1) then
2157 84061212 : dvxc(ipts,9)=v2rho2(1)
2158 84061212 : dvxc(ipts,10)=dvxc(ipts,9)
2159 84061212 : dvxc(ipts,11)=dvxc(ipts,9)
2160 84061212 : dvxc(ipts,12)=two*vsigma(1)
2161 84061212 : dvxc(ipts,13)=two*v2rhosigma(1)
2162 84061212 : dvxc(ipts,14)=dvxc(ipts,13)
2163 84061212 : dvxc(ipts,15)=four*v2sigma2(1)
2164 : else
2165 26390902 : dvxc(ipts,9)=v2rho2(1)
2166 26390902 : dvxc(ipts,10)=v2rho2(2)
2167 26390902 : dvxc(ipts,11)=v2rho2(3)
2168 26390902 : dvxc(ipts,12)=two*vsigma(1)
2169 26390902 : dvxc(ipts,13)=two*v2rhosigma(1)
2170 26390902 : dvxc(ipts,14)=two*v2rhosigma(6)
2171 26390902 : dvxc(ipts,15)=four*v2sigma2(1)
2172 : end if
2173 : end if
2174 : end if
2175 : end if
2176 :
2177 : ! Convert the quantities returned by Libxc to the ones needed by ABINIT
2178 1512512651 : if ((is_gga.or.is_mgga).and.present(vxcgr)) then
2179 1049289148 : if (nspden==1) then
2180 907658675 : vxcgr(ipts,3) = vxcgr(ipts,3) + vsigma(1)*two
2181 : else
2182 141630473 : vxcgr(ipts,1) = vxcgr(ipts,1) + two*vsigma(1) - vsigma(2)
2183 141630473 : vxcgr(ipts,2) = vxcgr(ipts,2) + two*vsigma(3) - vsigma(2)
2184 141630473 : vxcgr(ipts,3) = vxcgr(ipts,3) + vsigma(2)
2185 : end if
2186 : end if
2187 1049289148 : if (is_mgga.and.needs_tau.and.present(vxctau)) then
2188 1001171592 : vxctau(ipts,1:nspden) = vxctau(ipts,1:nspden) + vtau(1:nspden)
2189 : end if
2190 2278303391 : if (is_mgga.and.needs_laplacian.and.present(vxclrho)) then
2191 215916328 : vxclrho(ipts,1:nspden) = vxclrho(ipts,1:nspden) + vlrho(1:nspden)
2192 : end if
2193 :
2194 : end do ! ii
2195 : end do ! ipts
2196 :
2197 1050457 : end subroutine libxc_functionals_getvxc
2198 : !!***
2199 :
2200 : !======================================================================
2201 : ! HEREAFTER ARE PRIVATE FUNCTIONS
2202 : !======================================================================
2203 :
2204 : !----------------------------------------------------------------------
2205 :
2206 : !!****f* libxc_functionals/libxc_functionals_compute_tb09
2207 : !! NAME
2208 : !! libxc_functionals_compute_tb09
2209 : !!
2210 : !! FUNCTION
2211 : !! Compute c parameter for Tran-Blaha 2009 functional and set it
2212 : !! Applies on a (set of) functional(s)
2213 : !!
2214 : !! INPUTS
2215 : !! npts=number of of points for the density
2216 : !! nspden=number of spin-density components
2217 : !! rho(npts,nspden)=electronic density
2218 : !! grho2(npts,nspden)=squared gradient of the density
2219 : !!
2220 : !! OUTPUT
2221 : !!
2222 : !! SIDE EFFECTS
2223 : !! [xc_functionals(2)]=<type(libxc_functional_type)>, optional argument
2224 : !! Handle for XC functionals
2225 : !!
2226 : !! SOURCE
2227 :
2228 151639 : subroutine libxc_functionals_compute_tb09(npts,nspden,rho,grho2,xc_functionals)
2229 :
2230 : !Arguments ------------------------------------
2231 : integer, intent(in) :: npts,nspden
2232 : real(dp),intent(in) :: rho(npts,nspden),grho2(npts,2*min(nspden,2)-1)
2233 : type(libxc_functional_type),intent(inout),optional,target :: xc_functionals(2)
2234 : !Local variables -------------------------------
2235 : !scalars
2236 : integer :: ii,ipts
2237 : logical :: fixed_c_tb09,is_mgga_tb09
2238 : real(dp) :: cc
2239 : !arrays
2240 151639 : type(libxc_functional_type),pointer :: xc_funcs(:)
2241 151639 : real(dp),allocatable :: gnon(:)
2242 : #if defined HAVE_LIBXC && defined HAVE_FC_ISO_C_BINDING
2243 : integer(C_INT) :: npar_c=int(2,kind=C_INT)
2244 : real(C_DOUBLE) :: param_c(2)
2245 : #endif
2246 :
2247 : ! *************************************************************************
2248 :
2249 0 : if (.not.libxc_constants_initialized) call libxc_functionals_constants_load()
2250 :
2251 : !Select XC functional(s)
2252 151639 : if (present(xc_functionals)) then
2253 151639 : xc_funcs => xc_functionals
2254 : else
2255 151639 : xc_funcs => xc_global
2256 : end if
2257 :
2258 384908 : is_mgga_tb09=(any(xc_funcs%id==libxc_functionals_getid('XC_MGGA_X_TB09')))
2259 384912 : fixed_c_tb09=(any(abs(xc_funcs%xc_tb09_c-99.99_dp)>tol12))
2260 :
2261 151639 : if (is_mgga_tb09) then
2262 :
2263 : ! C is fixed by the user
2264 35028 : if (fixed_c_tb09) then
2265 : cc=zero
2266 105078 : do ii=1,2
2267 105078 : if (abs(xc_funcs(ii)%xc_tb09_c-99.99_dp)>tol12) cc=xc_funcs(ii)%xc_tb09_c
2268 : end do
2269 : ! write(msg,'(2a,f9.6)' ) ch10,&
2270 : !& 'In the mGGA functional TB09, c is fixed by the user and is equal to ',cc
2271 : !call wrtout(std_out,msg,'COLL')
2272 : ! C is computed
2273 : else
2274 6 : ABI_MALLOC(gnon,(npts))
2275 4004 : do ipts=1,npts
2276 8006 : if (sum(rho(ipts,:))<=1e-7_dp) then
2277 1056 : gnon(ipts)=zero
2278 : else
2279 2946 : if (nspden==1) then
2280 2946 : gnon(ipts)=sqrt(grho2(ipts,1))/rho(ipts,1)
2281 : else
2282 0 : gnon(ipts)=sqrt(grho2(ipts,3))/sum(rho(ipts,:))
2283 : end if
2284 : end if
2285 : end do
2286 4004 : cc= -0.012_dp + 1.023_dp*sqrt(sum(gnon)/npts)
2287 2 : ABI_FREE(gnon)
2288 : ! write(msg,'(2a,f9.6)' ) ch10,'In the mGGA functional TB09, c = ',cc
2289 : ! call wrtout(std_out,msg,'COLL')
2290 : end if
2291 :
2292 : ! Set c in XC data structure
2293 105084 : do ii=1,2
2294 105084 : if (xc_funcs(ii)%id==libxc_functionals_getid('XC_MGGA_X_TB09')) then
2295 : #if defined HAVE_LIBXC && defined HAVE_FC_ISO_C_BINDING
2296 35028 : param_c(1)=real(cc,kind=C_DOUBLE) ; param_c(2)=real(0._dp,kind=C_DOUBLE)
2297 35028 : call xc_func_set_params(xc_funcs(ii)%conf,param_c,npar_c)
2298 : #endif
2299 : end if
2300 : end do
2301 : end if
2302 :
2303 151639 : end subroutine libxc_functionals_compute_tb09
2304 : !!***
2305 :
2306 : !----------------------------------------------------------------------
2307 :
2308 : !!****f* libxc_functionals/libxc_functionals_getrefs
2309 : !! NAME
2310 : !! libxc_functionals_getrefs
2311 : !!
2312 : !! FUNCTION
2313 : !! Return the reference(s) of a single XC functional
2314 : !!
2315 : !! INPUTS
2316 : !! xc_functional=<type(libxc_functional_type)>, handle for XC functional
2317 : !!
2318 : !! OUTPUT
2319 : !! xcrefs(:)= references(s) of the functional
2320 : !!
2321 : !! SOURCE
2322 :
2323 : subroutine libxc_functionals_getrefs(xcrefs,xc_functional)
2324 :
2325 : !Arguments ------------------------------------
2326 : character(len=*),intent(out) :: xcrefs(:)
2327 : type(libxc_functional_type),intent(in) :: xc_functional
2328 : !Local variables-------------------------------
2329 : #if defined HAVE_LIBXC && defined HAVE_FC_ISO_C_BINDING
2330 : integer(C_INT) :: iref_c
2331 : character(kind=C_CHAR,len=1),pointer :: strg_c
2332 : #endif
2333 :
2334 : ! *************************************************************************
2335 :
2336 : xcrefs(:)=''
2337 :
2338 : #if defined HAVE_LIBXC && defined HAVE_FC_ISO_C_BINDING
2339 : iref_c=0
2340 : do while (iref_c>=0.and.iref_c<size(xcrefs))
2341 : call c_f_pointer(xc_get_info_refs(xc_functional%conf,iref_c),strg_c)
2342 : if (associated(strg_c)) then
2343 : call xc_char_to_f(strg_c,xcrefs(iref_c+1))
2344 : iref_c=iref_c+1
2345 : else
2346 : iref_c=-1
2347 : end if
2348 : end do
2349 : #else
2350 : if (.False.) write(std_out,*) xc_functional%id
2351 : #endif
2352 :
2353 : end subroutine libxc_functionals_getrefs
2354 : !!***
2355 :
2356 : !----------------------------------------------------------------------
2357 :
2358 : !!****f* libxc_functionals/libxc_functionals_depends_on_temp
2359 : !! NAME
2360 : !! libxc_functionals_depends_on_temp
2361 : !!
2362 : !! FUNCTION
2363 : !! Test function to identify whether a single XC functional
2364 : !! depends on the electronic temperature or not
2365 : !!
2366 : !! INPUTS
2367 : !! xc_functional=<type(libxc_functional_type)>, handle for XC functional
2368 : !!
2369 : !! SOURCE
2370 :
2371 2214 : function libxc_functionals_depends_on_temp(xc_functional)
2372 :
2373 : !Arguments ------------------------------------
2374 : logical :: libxc_functionals_depends_on_temp
2375 : type(libxc_functional_type),intent(in) :: xc_functional
2376 : !Local variables-------------------------------
2377 : #if defined HAVE_LIBXC && defined HAVE_FC_ISO_C_BINDING
2378 : integer(C_INT) :: ipar_c
2379 : character(len=50) :: par_name
2380 : character(kind=C_CHAR,len=1),pointer :: strg_c
2381 : #endif
2382 :
2383 : ! *************************************************************************
2384 :
2385 2214 : libxc_functionals_depends_on_temp = .false.
2386 :
2387 : #if defined HAVE_LIBXC && defined HAVE_FC_ISO_C_BINDING
2388 2214 : ipar_c=0
2389 18209 : do while (ipar_c>=0)
2390 16002 : call c_f_pointer(xc_func_get_params_name(xc_functional%conf,ipar_c),strg_c)
2391 18209 : if (associated(strg_c)) then
2392 13795 : call xc_char_to_f(strg_c,par_name)
2393 13795 : if (trim(par_name)=="T") then
2394 : libxc_functionals_depends_on_temp=.true. ; exit
2395 : end if
2396 13788 : ipar_c=ipar_c+1
2397 : else
2398 2207 : ipar_c=-1
2399 : end if
2400 : end do
2401 :
2402 2214 : if (.not.libxc_functionals_depends_on_temp) then
2403 : ! For libXC_version<5, these three functional were T-dependent
2404 : libxc_functionals_depends_on_temp = &
2405 : & (xc_functional%id==libxc_functionals_getid('XC_LDA_XC_KSDT') .or. &
2406 : & xc_functional%id==libxc_functionals_getid('XC_LDA_XC_GDSMFB') .or. &
2407 2207 : & xc_functional%id==libxc_functionals_getid('XC_LDA_XC_CORRKSDT'))
2408 : end if
2409 :
2410 : #else
2411 : if (.False.) write(std_out,*) xc_functional%id
2412 : #endif
2413 :
2414 2214 : end function libxc_functionals_depends_on_temp
2415 : !!***
2416 :
2417 : !----------------------------------------------------------------------
2418 :
2419 : !!****f* libxc_functionals/libxc_functionals_set_temp
2420 : !! NAME
2421 : !! libxc_functionals_set_temp
2422 : !!
2423 : !! FUNCTION
2424 : !! Set the electronic temperature in a single XC functional
2425 : !! No action if functional doesnt depend on temperature
2426 : !!
2427 : !! INPUTS
2428 : !! xc_functional=<type(libxc_functional_type)>, handle for XC functional
2429 : !! temperature=electronic temperature (in Ha units, i.e. T_kelvin * k_B_in_Ha/K )
2430 : !!
2431 : !! SOURCE
2432 :
2433 7 : subroutine libxc_functionals_set_temp(xc_functional,temperature)
2434 :
2435 : !Arguments ------------------------------------
2436 : real(dp),intent(in) :: temperature
2437 : type(libxc_functional_type),intent(in) :: xc_functional
2438 : !Local variables-------------------------------
2439 : #if defined HAVE_LIBXC && defined HAVE_FC_ISO_C_BINDING
2440 : integer(C_INT) :: iset_c,npar_c
2441 : real(C_DOUBLE) :: temp_c,param_c(1)
2442 : character(len=50) :: par_name
2443 : character(kind=C_CHAR,len=1),target :: name_c(2)
2444 : #endif
2445 :
2446 : ! *************************************************************************
2447 :
2448 : #if defined HAVE_LIBXC && defined HAVE_FC_ISO_C_BINDING
2449 7 : if (xc_functional%temperature>zero) then
2450 :
2451 7 : par_name="T" ; name_c=xc_char_to_c(trim(par_name))
2452 7 : temp_c=real(temperature,kind=C_DOUBLE)
2453 7 : iset_c = xc_func_set_params_name(xc_functional%conf,c_loc(name_c),temp_c)
2454 7 : if (iset_c /= 0) then
2455 : !Try this when set_params_name method is not available (libXC<5)
2456 : if (xc_functional%id==libxc_functionals_getid('XC_LDA_XC_KSDT') .or. &
2457 0 : & xc_functional%id==libxc_functionals_getid('XC_LDA_XC_GDSMFB') .or. &
2458 : & xc_functional%id==libxc_functionals_getid('XC_LDA_XC_CORRKSDT')) then
2459 0 : param_c(1)=real(zero,kind=C_DOUBLE);npar_c=int(1,kind=C_INT)
2460 0 : call xc_func_set_params(xc_functional%conf,param_c,npar_c)
2461 : end if
2462 : end if
2463 :
2464 : end if
2465 :
2466 : #else
2467 : if (.False.) write(std_out,*) xc_functional%id
2468 : #endif
2469 :
2470 7 : end subroutine libxc_functionals_set_temp
2471 : !!***
2472 :
2473 : !----------------------------------------------------------------------
2474 :
2475 : !!****f* libxc_functionals/libxc_functionals_constants_load
2476 : !! NAME
2477 : !! libxc_functionals_constants_load
2478 : !!
2479 : !! FUNCTION
2480 : !! Load libXC constants from C headers
2481 : !!
2482 : !! SOURCE
2483 :
2484 289 : subroutine libxc_functionals_constants_load()
2485 :
2486 : !Local variables-------------------------------
2487 : #if defined HAVE_LIBXC && defined HAVE_FC_ISO_C_BINDING
2488 : integer(C_INT) :: i1,i2,i3,i4,i5,i6,i7,i8,i9
2489 : #endif
2490 :
2491 : ! *************************************************************************
2492 :
2493 : #if defined HAVE_LIBXC && defined HAVE_FC_ISO_C_BINDING
2494 289 : call xc_get_singleprecision_constant(i1)
2495 289 : XC_SINGLE_PRECISION = int(i1)
2496 289 : call xc_get_family_constants(i1,i2,i3,i4,i5,i6,i7,i8,i9)
2497 289 : XC_FAMILY_UNKNOWN = int(i1)
2498 289 : XC_FAMILY_LDA = int(i2)
2499 289 : XC_FAMILY_GGA = int(i3)
2500 289 : XC_FAMILY_MGGA = int(i4)
2501 289 : XC_FAMILY_LCA = int(i5)
2502 289 : XC_FAMILY_OEP = int(i6)
2503 289 : XC_FAMILY_HYB_GGA = int(i7)
2504 289 : XC_FAMILY_HYB_MGGA = int(i8)
2505 289 : XC_FAMILY_HYB_LDA = int(i9)
2506 289 : call xc_get_flags_constants(i1,i2,i3,i4,i5,i6,i7,i8)
2507 289 : XC_FLAGS_HAVE_EXC = int(i1)
2508 289 : XC_FLAGS_HAVE_VXC = int(i2)
2509 289 : XC_FLAGS_HAVE_FXC = int(i3)
2510 289 : XC_FLAGS_HAVE_KXC = int(i4)
2511 289 : XC_FLAGS_HAVE_LXC = int(i5)
2512 289 : XC_FLAGS_NEEDS_TAU = int(i6)
2513 289 : XC_FLAGS_NEEDS_LAPLACIAN= int(i7)
2514 289 : XC_FLAGS_ENFORCE_FHC = int(i8)
2515 289 : call xc_get_kind_constants(i1,i2,i3,i4)
2516 289 : XC_EXCHANGE = int(i1)
2517 289 : XC_CORRELATION = int(i2)
2518 289 : XC_EXCHANGE_CORRELATION = int(i3)
2519 289 : XC_KINETIC = int(i4)
2520 289 : libxc_constants_initialized=.true.
2521 : #endif
2522 :
2523 289 : end subroutine libxc_functionals_constants_load
2524 : !!***
2525 :
2526 : !----------------------------------------------------------------------
2527 :
2528 : !!****f* libxc_functionals/xc_char_to_c
2529 : !! NAME
2530 : !! xc_char_to_c
2531 : !!
2532 : !! FUNCTION
2533 : !! Helper function to convert a Fortran string to a C string
2534 : !! Based on a routine by Joseph M. Krahn
2535 : !!
2536 : !! INPUTS
2537 : !! f_string=Fortran string
2538 : !!
2539 : !! OUTPUT
2540 : !! c_string=C string
2541 : !!
2542 : !! SOURCE
2543 :
2544 : #if defined HAVE_FC_ISO_C_BINDING
2545 324008 : function xc_char_to_c(f_string) result(c_string)
2546 :
2547 : !Arguments ------------------------------------
2548 : character(len=*),intent(in) :: f_string
2549 : character(kind=C_CHAR,len=1) :: c_string(len_trim(f_string)+1)
2550 : !Local variables -------------------------------
2551 : integer :: ii,strlen
2552 :
2553 : !! *************************************************************************
2554 :
2555 324008 : strlen=len_trim(f_string)
2556 3929990 : forall(ii=1:strlen)
2557 : c_string(ii)=f_string(ii:ii)
2558 : end forall
2559 324008 : c_string(strlen+1)=C_NULL_CHAR
2560 324008 : end function xc_char_to_c
2561 : #endif
2562 : !!***
2563 :
2564 : !----------------------------------------------------------------------
2565 :
2566 : !!****f* libxc_functionals/xc_char_to_f
2567 : !! NAME
2568 : !! xc_char_to_f
2569 : !!
2570 : !! FUNCTION
2571 : !! Helper function to convert a C string to a Fortran string
2572 : !! Based on a routine by Joseph M. Krahn
2573 : !!
2574 : !! NOTES
2575 : !! non-ascii chars are replaced by "?" as outputting strings containing non-ascii entries
2576 : !! can lead to IO error with ifort when running in parallel (don't know why sequential execution is OK, though)
2577 : !!
2578 : !! forrtl: severe (38): error during write, unit 6, file /proc/3478/fd/1
2579 : !! Image PC Routine Line Source
2580 : !! libifcoremt.so.5 00007FEA9BA95F46 for__io_return Unknown Unknown
2581 : !! libifcoremt.so.5 00007FEA9BB03A99 for_write_seq_fmt Unknown Unknown
2582 : !! libifcoremt.so.5 00007FEA9BB0193A for_write_seq_fmt Unknown Unknown
2583 : !! abinit 000000000285EB7A m_io_tools_mp_wri 1218 m_io_tools.F90
2584 : !!
2585 : !! INPUTS
2586 : !! c_string=C string
2587 : !!
2588 : !! OUTPUT
2589 : !! f_string=Fortran string
2590 : !!
2591 : !! SOURCE
2592 :
2593 : #if defined HAVE_FC_ISO_C_BINDING
2594 34878 : subroutine xc_char_to_f(c_string,f_string)
2595 :
2596 : !Arguments ------------------------------------
2597 : character(kind=C_CHAR,len=1),intent(in) :: c_string(*)
2598 : character(len=*),intent(out) :: f_string
2599 : !Local variables -------------------------------
2600 : integer :: ii
2601 :
2602 : !! *************************************************************************
2603 :
2604 34878 : ii=1
2605 1170834 : do while(c_string(ii)/=C_NULL_CHAR.and.ii<=len(f_string))
2606 1135956 : if (iachar(c_string(ii)) <= 127) then
2607 1135812 : f_string(ii:ii)=c_string(ii)
2608 : else
2609 144 : f_string(ii:ii)="?"
2610 : end if
2611 1135956 : ii=ii+1
2612 : end do
2613 34878 : if (ii<len(f_string)) f_string(ii:)=' '
2614 34878 : end subroutine xc_char_to_f
2615 : #endif
2616 : !!***
2617 :
2618 : !----------------------------------------------------------------------
2619 :
2620 0 : end module libxc_functionals
2621 : !!***
|
