comp-chem/NWChem
1
0
Fork 0
mirror of https://github.com/nwchemgit/nwchem.git synced 2026-07-29 06:35:39 -04:00
Code Issues Projects Releases Packages Wiki Activity Actions 1

several nwxc_ functions can be called now as subroutines. This simplifies module dependencies

Browse source
This commit is contained in:
Edoardo Apra 2015-09-09 02:06:44 +00:00
parent 2616b9be18
commit 43a58e70b4
16 changed files with 142 additions and 99 deletions
Download patch file Download diff file Expand all files Collapse all files

4
src/config/make_nwchem_config
View file

@ -269,7 +269,7 @@ STUBROUTINES := $(patsubst ccsd,ccsd ccsd_input,$(STUBROUTINES) )
STUBROUTINES := $(patsubst mcscf,mcscf mcscf_input,$(STUBROUTINES) )
STUBROUTINES := $(patsubst moints,atwtest direct_mp2 moints_full,$(STUBROUTINES) )
STUBROUTINES := $(patsubst nwdft,nwdft occup_input xc_chktau dft_fitcd grid_cleanup dft_fitvc grid_quadv0_gen dft_input xc_quadv0_gen dft_energy dft_energy_gradient sodft_energy tddft_input tddft_energy sodft_energy sodft_energy_gradient rt_dft_input xc_vdw_to_hessian,$(STUBROUTINES) )
STUBROUTINES := $(patsubst nwxc,nwxc_eval_df nwxc_eval_df2 nwxc_eval_df3 nwxc_get_cam nwxc_get_disp nwxc_has_cam nwxc_has_2nd nwxc_has_xc nwxc_has_disp nwxc_has_hfx nwxc_has_mp2c nwxc_init nwxc_input nwxc_is_gga nwxc_is_lda nwxc_is_mgga nwxc_is_on nwxc_print nwxc_print_nwpw nwxc_reset_rho_tolerance nwxc_rtdb_delete nwxc_rtdb_load nwxc_rtdb_store nwxc_vdw3_dftd3 nwxc_wght_hfx nwxc_wght_mp2c,$(STUBROUTINES) )
STUBROUTINES := $(patsubst nwxc,nwxc_getwght nwxc_getvals nwxc_eval_df nwxc_eval_df2 nwxc_eval_df3 nwxc_get_cam nwxc_get_disp nwxc_has_cam nwxc_has_2nd nwxc_has_xc nwxc_has_disp nwxc_has_hfx nwxc_has_mp2c nwxc_init nwxc_input nwxc_is_gga nwxc_is_lda nwxc_is_mgga nwxc_is_on nwxc_print nwxc_print_nwpw nwxc_reset_rho_tolerance nwxc_rtdb_delete nwxc_rtdb_load nwxc_rtdb_store nwxc_vdw3_dftd3 nwxc_wght_hfx nwxc_wght_mp2c,$(STUBROUTINES) )
STUBROUTINES := $(patsubst rimp2,rimp2,$(STUBROUTINES) )
STUBROUTINES := $(patsubst rimp2_grad,rimp2g,$(STUBROUTINES) )
#STUBROUTINES := $(patsubst oimp2,oimp2,$(STUBROUTINES) )
@ -277,7 +277,7 @@ STUBROUTINES := $(patsubst stepper,stpr_walk stpr_walk_task stpr_walk_reset step
STUBROUTINES := $(patsubst symmetry,,$(STUBROUTINES) )
STUBROUTINES := $(patsubst cphf,cphf cphf_poliz mjdtest cphf2,$(STUBROUTINES) )
STUBROUTINES := $(patsubst scfaux,,$(STUBROUTINES) )
STUBROUTINES := $(patsubst vib,vib_vib freq_vib_input vib_dsquar,$(STUBROUTINES) )
STUBROUTINES := $(patsubst vib,vib_cross vib_vib freq_vib_input vib_dsquar,$(STUBROUTINES) )
STUBROUTINES := $(patsubst driver,driver oniom_energy oniom_gradient oniom_input drv_lst drv_opt driver_input lbfgsb_driver deloc_driver,$(STUBROUTINES) )
#STUBROUTINES := $(patsubst plane_wave,plnwv plnwv_input,$(STUBROUTINES) )
STUBROUTINES := $(patsubst prepar,prepar pre_input,$(STUBROUTINES) )

21
src/nwdft/input_dft/dft_inpana.F
View file

@ -21,7 +21,6 @@ c
#include "bas.fh"
#include "cdft.fh"
#include "util.fh"
#include "nwxc.fh"
c
double precision AUTOANG, ANGTOAU
Parameter (AUTOANG = 0.529177249d0, ANGTOAU = 1.d0/AUTOANG)
@ -59,7 +58,7 @@ c
c
logical status ! FA
logical use_nwxc
logical dftmp2
logical dftmp2,out1
double precision mp2fac
c
me=ga_nodeid()
@ -685,23 +684,23 @@ c & r1
cHvD
use_nwxc = util_module_avail("nwxc")
if (use_nwxc) then
use_nwxc = nwxc_rtdb_load(rtdb,"dft")
call nwxc_rtdb_load(rtdb,"dft")
endif
if (use_nwxc) then
if (nwxc_has_hfx()) then
xfac(1) = nwxc_wght_hfx()
call nwxc_getvals("nwxc_has_hfx",out1)
if (out1) then
call nwxc_getwght("nwxc_wght_hfx",xfac(1))
endif
dftmp2 = nwxc_has_mp2c()
mp2fac = nwxc_wght_mp2c()
call nwxc_getvals("nwxc_has_mp2c",dftmp2)
if (dftmp2) then
call nwxc_getwght("nwxc_wght_mp2c",mp2fac)
if (.not.rtdb_put(rtdb,'dft:mp2fac', mt_dbl, 1, mp2fac))
& call errquit('dft_inpana: rtdb_put failed', 2902, RTDB_ERR)
endif
if (nwxc_has_cam()) then
cam_exch = .true.
call nwxc_getvals("nwxc_has_cam",cam_exch)
if (cam_exch) then
call nwxc_get_cam(cam_alpha,cam_beta,cam_omega,cam_srhf)
else
cam_exch = .false.
else
cam_alpha = 0.0d0
cam_beta = 0.0d0
cam_omega = 0.0d0

14
src/nwdft/input_dft/dft_input.F
View file

@ -18,7 +18,6 @@ c
#include "stdio.fh"
#include "cdft.fh"
#include "case.fh"
#include "nwxc.fh"
#include "util.fh"
c
c read input for DFT calculation. All input is of the form:
@ -71,12 +70,13 @@ c
c xdm variables
double precision xdm_a1, xdm_a2
logical xdm_onlyc, xdm_varc
logical out1
c
c xps variables
logical lxps
integer lenstr
character*255 inp_vecs
c
data dirs /'convergence','decomp','dft','direct','semidirect',
$ 'ecp','grid','vectors','incore','iterations',
$ 'max_ovl','mulliken','mult','noio','noprint','odft',
@ -330,13 +330,13 @@ c
if (test(1:3).eq."old") then
call xc_input(rtdb, 'dft')
else if (test(1:3).eq."new") then
if (.not.nwxc_input()) then
call nwxc_input(out1)
if (.not.out1) then
call errquit("dft_input: nwxc_input failed",0,UERR)
endif
if (.not.nwxc_rtdb_store(rtdb,"dft")) then
call errquit("dft_input: nwxc_rtdb_store failed",0,UERR)
endif
if (nwxc_has_cam()) then
call nwxc_rtdb_store(rtdb,"dft")
call nwxc_getvals("nwxc_has_cam",out1)
if (out1) then
cam_exch = .true.
call nwxc_get_cam(cam_alpha,cam_beta,cam_omega,cam_srhf)
else

22
src/nwdft/lr_tddft/tddft_init.F
View file

@ -28,7 +28,6 @@ c
#include "msgids.fh"
#include "stdio.fh"
#include "case.fh"
#include "nwxc.fh"
c
integer rtdb ! Runtime database handle
integer geom ! Geometry handle
@ -570,30 +569,27 @@ c -------------
c
use_nwxc = util_module_avail("nwxc")
if (use_nwxc) then
use_nwxc = nwxc_rtdb_load(rtdb,"dft")
call nwxc_rtdb_load(rtdb,"dft")
endif
if (use_nwxc) then
if (nwxc_has_hfx()) then
xfac(1) = nwxc_wght_hfx()
lhashf = .true.
else
lhashf = .false.
call nwxc_getvals("nwxc_has_hf",lhashf)
if (lhashf) then
call nwxc_getwght("nwxc_wght_hfx",xfac(1))
endif
lhasdft = nwxc_has_xc()
call nwxc_getvals("nwxc_has_xc",lhasdft)
ldft = lhasdft.and.(.not.lhashf)
lhf = (.not.lhasdft).and.lhashf
lhybrid = lhasdft.and.lhashf
dftmp2 = nwxc_has_mp2c()
mp2fac = nwxc_wght_mp2c()
call nwxc_getvals("nwxc_has_mp2c",dftmp2)
if (dftmp2) then
call nwxc_getwght("nwxc_wght_mp2c",mp2fac)
if (.not.rtdb_put(rtdb,'dft:mp2fac', mt_dbl, 1, mp2fac))
& call errquit('dft_inpana: rtdb_put failed', 2902, RTDB_ERR)
endif
if (nwxc_has_cam()) then
cam_exch = .true.
call nwxc_getvals("nwxc_has_cam",cam_exch)
if (cam_exch) then
call nwxc_get_cam(cam_alpha,cam_beta,cam_omega,cam_srhf)
else
cam_exch = .false.
cam_alpha = 0.0d0
cam_beta = 0.0d0
cam_omega = 0.0d0

5
src/nwdft/scf_dft/dft_canorg.F
View file

@ -256,7 +256,6 @@ c
#include "stdio.fh"
#include "global.fh"
#include "dft_conv.fh"
#include "nwxc.fh"
#include "util.fh"
c
logical oprint
@ -279,7 +278,9 @@ c
iAOacc = iAOacc_max
tol_rho = tol_rho_max
use_nwxc = util_module_avail("nwxc")
if (use_nwxc) use_nwxc = nwxc_is_on()
if (use_nwxc) then
call nwxc_getvals("nwxc_is_on",use_nwxc)
endif
if (use_nwxc) call nwxc_reset_rho_tolerance(tol_rho)
if(iter.ge.nfock/2) iswitc = iswitc+1
if(abs(delta).lt.1d-6) iswitc = iswitc+2

2
src/nwdft/scf_dft/dft_scf.F
View file

@ -431,7 +431,7 @@ c Jorge Garza/Begin
c Jorge Garza/End
use_nwxc = util_module_avail("nwxc")
if (use_nwxc) then
use_nwxc = nwxc_is_on()
call nwxc_getvals("nwxc_is_on",use_nwxc)
endif
c
c Set aside some memory for reduced density matrix

6
src/nwdft/xc/xc_chkdispauto.F
View file

@ -5,18 +5,18 @@ c
c see if any functional has automatic dispersion included
c
#include "cdft.fh"
#include "nwxc.fh"
#include "util.fh"
c note in cdft.fh, they define cfac(numfunc) and xfac(numfunc)
c
logical lhasautodisp
logical lhasautodisp,out1
lhasautodisp = .false.
c
c beck97-d, ssb-d
lhasautodisp = xccomb(37).or.xccomb(46).or.xccomb(60).or.
& xccomb(61).or.xccomb(62).or.xccomb(63)
if (util_module_avail("nwxc")) then
lhasautodisp = lhasautodisp.or.nwxc_has_disp()
call nwxc_getvals("nwxc_has_disp",out1)
lhasautodisp = lhasautodisp.or.out1
endif
c
if (lhasautodisp) then

4
src/nwdft/xc/xc_eval_fnl.F
View file

@ -41,7 +41,6 @@ c xc-third derivative header file
cHvD
#include "errquit.fh"
#include "mafdecls.fh"
#include "nwxc.fh"
#include "util.fh"
integer l_f, k_f
integer l_g, k_g
@ -89,6 +88,7 @@ c
logical do_2nd, do_3rd
logical ldew, ldew2, ldew3
logical out1
c
double precision eps,dumd
integer nx,nc,dumi
@ -126,7 +126,7 @@ c
c
use_nwxc = util_module_avail("nwxc")
if (use_nwxc) then
use_nwxc = nwxc_is_on()
call nwxc_getvals("nwxc_is_on",out1)
endif
if (use_nwxc) then
c

1
src/nwdft/xc/xc_tabcd.F
View file

@ -72,7 +72,6 @@ c
#include "dft2drv.fh"
#include "dist.fh"
#include "dft_fdist.fh"
#include "nwxc.fh"
#include "util.fh"
c
Logical GRAD !< [Input] .True. if functional depends on density

26
src/nwdft/xc/xc_util.F
View file

@ -9,11 +9,11 @@ c
c
#include "cdft.fh"
#include "steric.fh"
#include "nwxc.fh"
#include "util.fh"
c
c see if any Gradient Corrected Functional is not null
c
logical out1,out2
double precision tot,eps
parameter(eps=1.d-10)
c
@ -46,7 +46,9 @@ c
xc_chkgrad = .false.
end if
if (util_module_avail("nwxc")) then
xc_chkgrad = xc_chkgrad .or. nwxc_is_gga().or.nwxc_is_mgga()
call nwxc_getvals("nwxc_is_gga",out1)
call nwxc_getvals("nwxc_is_mgga",out2)
xc_chkgrad = xc_chkgrad .or. out1.or.out2
endif
c
return
@ -55,10 +57,10 @@ c
logical function xc_gotxc()
implicit none
#include "cdft.fh"
#include "nwxc.fh"
#include "util.fh"
double precision tot
integer i
logical out1
c
c return true if there is any XC functional to compute
c (other than HF Exch)
@ -69,7 +71,8 @@ c
enddo
xc_gotxc = tot.gt.1d-8.or.lb94.or.cs00
if (util_module_avail("nwxc")) then
xc_gotxc = xc_gotxc.or.nwxc_has_xc()
call nwxc_getvals("nwxc_has_xc",out1)
xc_gotxc = xc_gotxc.or.out1
endif
return
end
@ -94,8 +97,8 @@ c
implicit none
c
#include "cdft.fh"
#include "nwxc.fh"
#include "util.fh"
logical out1
c
xc_got2nd=.not.(
c
@ -164,7 +167,8 @@ chp414 . cfac(21).ne.0d0.or.
. cfac(54).ne.0d0.or.
. cfac(36).ne.0d0)
if (util_module_avail("nwxc")) then
xc_got2nd = xc_got2nd .or. nwxc_has_2nd()
call nwxc_getvals("nwxc_has_2nd",out1)
xc_got2nd = xc_got2nd .or. out1
endif
c
return
@ -180,10 +184,10 @@ c
c see if any metaGGA Functional using TAU is not null
c
#include "cdft.fh"
#include "nwxc.fh"
#include "util.fh"
C note in cdft.fh,they define cfac(numfunc) and xfac(numfunc)
c
logical out1
double precision tot,eps
parameter(eps=1.d-10)
tot = xfac(18) + cfac(25) + xfac(21) + cfac(27) +
@ -201,7 +205,8 @@ c
xc_chktau = .false.
endif
if (util_module_avail("nwxc")) then
xc_chktau = xc_chktau .or. nwxc_is_mgga()
call nwxc_getvals("nwxc_is_mgga",out1)
xc_chktau = xc_chktau .or. out1
endif
return
end
@ -229,7 +234,7 @@ c
#include "cdft.fh"
#include "case.fh"
#include "util.fh"
#include "nwxc.fh"
logical out1
c
xc_hascam=(
. xfac(38).ne.0d0.or.
@ -242,7 +247,8 @@ c
c
xc_hascam = xc_hascam.or.cam_exch
if (util_module_avail("nwxc")) then
xc_hascam = xc_hascam.or.nwxc_has_cam()
call nwxc_getvals("nwxc_has_cam",out1)
xc_hascam = xc_hascam.or.out1
endif
c
return

23
src/nwdft/xc/xc_vdw_main.F
View file

@ -556,8 +556,6 @@ c
#include "stdio.fh"
#include "global.fh"
#include "rtdb.fh"
#include "nwxc.fh"
#include "xc_vdw.fh"
c
integer n
integer itags,ltags,i_xyz,l_xyz,icharge,lcharge,
@ -569,12 +567,14 @@ c
external xc_vdw_init
logical oprint,oprinth
logical stat
logical use_nwxc_disp
logical use_nwxc_disp,out1
c
logical geom_cart_get2
external geom_cart_get2
c
double precision delta,delta_default
double precision alpha
integer ivdw
c
oprint = util_print('vdw', print_high)
oprinth = util_print('vdw high', print_high)
@ -603,13 +603,15 @@ c Which Grimme dispersion version
c
if (.not.rtdb_get(rtdb,'dft:ivdw',MT_INT,1,ivdw))
& ivdw = 2
use_nwxc_disp = util_module_avail("nwxc")
if (use_nwxc_disp) then
use_nwxc_disp = use_nwxc_disp .and. nwxc_has_disp()
endif
if (use_nwxc_disp) then
use_nwxc_disp = .false.
if(util_module_avail("nwxc")) then
call nwxc_getvals("nwxc_has_disp",out1)
use_nwxc_disp = out1
if (use_nwxc_disp) then
c get ivdw here as this data is needed for xc_vdw_init
call nwxc_get_disp(ivdw,s6,s8,sr6,sr8,a1,a2,alpha)
call nwxc_get_disp(ivdw,s6,s8,sr6,sr8,a1,a2,alpha)
endif
endif
c
c conversion factor angs 2 au
@ -650,9 +652,6 @@ c
write(luout,*) ' sr8 =',sr8
write(luout,*) ' alpha =',alpha
write(luout,*) ' ivdw =',ivdw
write(luout,*) ' k1 = ',k1
write(luout,*) ' k2 = ',k2
write(luout,*) ' k3 = ',k3
endif
c
evdw=xc_vdw_e(s6,s8,sr6,sr8,a1,a2,n,dbl_mb(i_xyz),int_mb(iz))

25
src/nwpw/nwpw_input.F
View file

@ -11,7 +11,6 @@ c
#include "rtdb.fh"
#include "nwc_const.fh"
#include "errquit.fh"
#include "nwxc.fh"
#include "util.fh"
c
integer ind ! Index of matched directive
@ -154,6 +153,8 @@ chvd
double precision a,b,c
logical hfsr
integer flag
logical lstat,out1
double precision xfac
chvd
* **** external functions ****
@ -631,33 +632,35 @@ c
ind = index(exchange_correlation,' ') - 1
if (exchange_correlation(1:ind).eq.'new') then
c call inp_prev_field()
if (.not.nwxc_input()) then
cold if (.not.nwxc_input()) then
call nwxc_input(lstat)
if(.not.lstat) then
call errquit("nwpw_input: not a functional",
+ 0,UERR)
endif
if (.not.nwxc_rtdb_store(rtdb,"dft")) then
call errquit("nwpw_input: store functional failed",
+ 0,UERR)
endif
call nwxc_rtdb_store(rtdb,"dft")
value = .true.
if (nwxc_has_hfx()) then
call nwxc_getvals("nwxc_has_hfx",out1)
if (out1) then
value = value .and.
+ rtdb_put(rtdb,'pspw:HFX',mt_log,1,.true.)
value = value .and.
+ rtdb_put(rtdb,'band:HFX',mt_log,1,.true.)
value = value .and.
+ rtdb_put(rtdb,'pspw:HFX_parameter',mt_dbl,1,
+ nwxc_wght_hfx())
+ out1)
call nwxc_getwght("nwxc_wght_hfx",xfac)
value = value .and.
+ rtdb_put(rtdb,'band:HFX_parameter',mt_dbl,1,
+ nwxc_wght_hfx())
+ xfac)
else
value = value .and.
+ rtdb_put(rtdb,'pspw:HFX',mt_log,1,.false.)
value = value .and.
+ rtdb_put(rtdb,'band:HFX',mt_log,1,.false.)
endif
if (nwxc_has_cam()) then
call nwxc_getvals("nwxc_has_cam",out1)
if (out1) then
call nwxc_get_cam(a,b,c,hfsr)
if (hfsr) then
flag = 4
@ -679,7 +682,7 @@ c call inp_prev_field()
endif
if (util_module_avail("nwxc")) then
value = nwxc_rtdb_delete(rtdb,"dft") !*** don't need to check return value ****
call nwxc_rtdb_delete(rtdb,"dft") !*** don't need to check return value ****
endif
value = rtdb_cput(rtdb,'cgsd:exchange_correlation',

18
src/nwpw/nwpwlib/control/control.F
View file

@ -210,10 +210,9 @@
if (util_module_avail("nwxc")) then
!$OMP single
if (nwxc_rtdb_load(rtdb,"dft")) then
call nwxc_rtdb_load(rtdb,"dft")
c call nwxc_print()
has_disp = nwxc_has_disp()
endif
!$OMP end single
endif
@ -318,10 +317,9 @@ c call nwxc_print()
if (util_module_avail("nwxc")) then
!$OMP single
if (nwxc_rtdb_load(rtdb,"dft")) then
call nwxc_rtdb_load(rtdb,"dft")
c call nwxc_print()
has_disp = nwxc_has_disp()
endif
!$OMP end single
endif
@ -467,10 +465,9 @@ c
if (util_module_avail("nwxc")) then
!$OMP single
if (nwxc_rtdb_load(rtdb,"dft")) then
call nwxc_rtdb_load(rtdb,"dft")
c call nwxc_print()
has_disp = nwxc_has_disp()
endif
!$OMP end single
endif
@ -673,10 +670,9 @@ c
if (util_module_avail("nwxc")) then
!$OMP single
if (nwxc_rtdb_load(rtdb,"dft")) then
call nwxc_rtdb_load(rtdb,"dft")
c call nwxc_print()
has_disp = nwxc_has_disp()
endif
!$OMP end single
endif
@ -782,10 +778,9 @@ c call nwxc_print()
if (util_module_avail("nwxc")) then
!$OMP single
if (nwxc_rtdb_load(rtdb,"dft")) then
call nwxc_rtdb_load(rtdb,"dft")
c call nwxc_print()
has_disp = nwxc_has_disp()
endif
!$OMP end single
endif
@ -871,10 +866,9 @@ c call nwxc_print()
if (util_module_avail("nwxc")) then
!$OMP single
if (nwxc_rtdb_load(rtdb,"dft")) then
call nwxc_rtdb_load(rtdb,"dft")
c call nwxc_print()
has_disp = nwxc_has_disp()
endif
!$OMP end single
endif

2
src/nwxc/nwxc.fh
View file

@ -28,8 +28,6 @@ C>
logical nwxc_has_2nd !< Does this functional support 2nd order
!< partial derivatives?
C>
logical nwxc_rtdb_load !< Load the functional from the RTDB
logical nwxc_rtdb_store !< Store the functional on the RTDB
logical nwxc_rtdb_delete !< Delete the functional from the RTDB
C>
logical nwxc_set_rho_tolerance !< Set the density tolerance

24
src/nwxc/nwxc_nwchem.F
View file

@ -33,7 +33,7 @@ C>
C> \return Return .true. if the functional was successfully parsed,
C> and .false. otherwise.
C>
logical function nwxc_input()
subroutine nwxc_input(stat)
implicit none
#include "stdio.fh"
#include "errquit.fh"
@ -106,7 +106,6 @@ c ! cursor if failed
end select
enddo
call nwxc_detect_dependencies()
nwxc_input = stat
return
end
C>
@ -235,12 +234,13 @@ C>
C> \return Return .true. if the data was successfully stored, and
C> .false. otherwise.
C>
logical function nwxc_rtdb_store(rtdb,name)
subroutine nwxc_rtdb_store(rtdb,name)
implicit none
#include "mafdecls.fh"
#include "rtdb.fh"
#include "nwxcP.fh"
#include "inp.fh"
#include "errquit.fh"
integer rtdb !< [Input] The RTDB handle
character*(*) name !< [Input] The name under which the current
!< functional will be stored
@ -336,7 +336,9 @@ c This stuff is to be removed when the integration is finalized
endif
endif
cHACK
nwxc_rtdb_store = status
if (.not.status) then
call errquit("nwxc_rtdb_store failed",0,UERR)
endif
c
return
end
@ -357,7 +359,7 @@ C> \return Return .true. if the data was successfully loaded, and
C> .false. if no functional with the specified name was found, abort
C> if only partial information on a particular functional is found.
C>
logical function nwxc_rtdb_load(rtdb,name)
subroutine nwxc_rtdb_load(rtdb,name)
implicit none
#include "mafdecls.fh"
#include "errquit.fh"
@ -380,7 +382,6 @@ c
rtdb_key="dft:xc:"//name(1:lenname)//":nwxc_usr_num"
status=status.and.rtdb_get(rtdb,rtdb_key,MT_INT,1,nwxc_usr_num)
c
nwxc_rtdb_load = status
nwxc_on = status
if (.not. status) then
c
@ -456,7 +457,6 @@ c
status=status.and.rtdb_get(rtdb,rtdb_key,MT_INT,1,
+ nwxc_eval_method)
c
nwxc_rtdb_load = status
if (.not.status) then
c
c We found nwxc_num_f and nwxc_usr_num so the functional must have
@ -484,10 +484,11 @@ C>
C> \return Return .true. if the functional was successfully
C> deleted, and .false. otherwise.
C>
logical function nwxc_rtdb_delete(rtdb,name)
subroutine nwxc_rtdb_delete(rtdb,name)
implicit none
#include "inp.fh"
#include "rtdb.fh"
#include "errquit.fh"
integer rtdb !< [Input] The RTDB handle
character*(*) name !< [Input] The name under which the functional
!< is stored
@ -503,8 +504,11 @@ c
status=status.and.rtdb_delete(rtdb,rtdb_key)
rtdb_key="dft:xc:"//name(1:lenname)//":nwxc_usr_num"
status=status.and.rtdb_delete(rtdb,rtdb_key)
nwxc_rtdb_delete = status
#if 0
if (.not.status) then
call errquit("nwxc_rtdb_delete failed",0,UERR)
endif
#endif
return
end
C> @}

44
src/nwxc/nwxc_query.F
View file

@ -1121,3 +1121,47 @@ c
C>
C> @}
c $Id$
subroutine nwxc_getvals(argin,argout)
implicit none
#include "nwxc.fh"
character*(*) argin
logical argout
if(argin.eq.'nwxc_has_cam') then
argout=nwxc_has_cam()
elseif(argin.eq.'nwxc_has_hfx') then
argout=nwxc_has_hfx()
elseif(argin.eq.'nwxc_has_xc') then
argout=nwxc_has_xc()
elseif(argin.eq.'nwxc_has_2nd') then
argout=nwxc_has_2nd()
elseif(argin.eq.'nwxc_is_on') then
argout=nwxc_is_on()
elseif(argin.eq.'nwxc_is_gga') then
argout=nwxc_is_gga()
elseif(argin.eq.'nwxc_is_mgga') then
argout=nwxc_is_mgga()
elseif(argin.eq.'nwxc_has_disp') then
argout=nwxc_has_disp()
elseif(argin.eq.'nwxc_has_mp2c') then
argout=nwxc_has_mp2c()
else
call errquit('nwxcgetvls: wrong argin ',0,0)
endif
return
end
subroutine nwxc_getwght(argin,argout)
implicit none
#include "nwxc.fh"
character*(*) argin
double precision argout
if(argin.eq.'nwxc_wght_hfx') then
argout=nwxc_wght_hfx()
elseif(argin.eq.'nwxc_wght_mp2c') then
argout=nwxc_wght_mp2c()
else
call errquit('nwxcgetwght: wrong argin ',0,0)
endif
return
end