1*
2* $Id$
3*
4      subroutine hnd_propty(rtdb,basis,geom)
5c
6      implicit none
7c
8#include "nwc_const.fh"
9#include "errquit.fh"
10#include "mafdecls.fh"
11#include "global.fh"
12#include "rtdb.fh"
13#include "stdio.fh"
14#include "int_nbf.fh"
15#include "zora.fh"
16c
17      integer     rtdb   ! runtime database handle
18      integer     basis  ! basis set "object" handle
19      integer     geom   ! geometry "object" handle
20      logical     status
21      logical     some
22      logical     out
23      integer     iopt
24      integer     i,ipol
25      character*20 scftype
26c
27      integer
28     &     nodip,noqdp,nootp,nopop,nospin,nodpl,nodhp,nod2hp,
29     1     nofpl,nofhp,nof2hp,nosos,noelp,noelf,noelfg,noelfgZ4,noden,
30     2     nogiao,nogshift,noston,nospinspin,noaoresponse,noboysloc,
31     3     nopmloc,noelpiso
32      data nodip,noqdp,nootp,nopop,nospin,nodpl,nodhp,nod2hp,
33     1     nofpl,nofhp,nof2hp,nosos,noelp,noelf,noelfg,noelfgZ4,noden,
34     2     nogiao,nogshift,noston,nospinspin,noaoresponse,noboysloc,
35     3     nopmloc,noelpiso
36     4    /  1,    1,    1,    1,    1,    1,    1,    1,    1,
37     5       1,    1,    1,    1,    1,    1,    1,    1,
38     6       1,    1,    1,    1,    1,    1,    1,    1 /
39c
40      out   =.false.
41      some  =.true.
42      some  =some.or.out
43      some  =some.and.ga_nodeid().eq.0
44
45c     Determine scftype
46      if (.not. rtdb_cget(rtdb, 'scf:scftype', 1, scftype))
47     &     scftype = "RHF"
48      if (scftype.eq."RHF") then
49           ipol = 1
50      else
51           ipol = 2
52      endif
53c
54      status=rtdb_get(rtdb,'prop:dipole',MT_INT,1,nodip)            !done
55      status=rtdb_get(rtdb,'prop:quadrupole',MT_INT,1,noqdp)        !done
56      status=rtdb_get(rtdb,'prop:octupole',MT_INT,1,nootp)          !done
57      status=rtdb_get(rtdb,'prop:mulliken',MT_INT,1,nopop)          !done
58      status=rtdb_get(rtdb,'prop:hyperfine',MT_INT,1,nospin)        !done
59      status=rtdb_get(rtdb,'prop:boyslocalization',MT_INT,1,noboysloc)
60      status=rtdb_get(rtdb,'prop:pmlocalization',MT_INT,1,nopmloc)
61      status=rtdb_get(rtdb,'prop:esp',MT_INT,1,noelp)               !done
62      status=rtdb_get(rtdb,'prop:espiso',MT_INT,1,noelpiso)         !done
63      status=rtdb_get(rtdb,'prop:efield',MT_INT,1,noelf)            !done
64      status=rtdb_get(rtdb,'prop:efieldgrad',MT_INT,1,noelfg)       !done
65      status=rtdb_get(rtdb,'prop:efieldgradZ4',MT_INT,1,noelfgZ4)   !done
66      status=rtdb_get(rtdb,'prop:electrondensity',MT_INT,1,noden)   !done
67      status=rtdb_get(rtdb,'prop:stoneanalysis',MT_INT,1,noston)
68      status=rtdb_get(rtdb,'prop:giao',MT_INT,1,nogiao)             !done
69      status=rtdb_get(rtdb,'prop:gshift',MT_INT,1,nogshift)         !done
70      status=rtdb_get(rtdb,'prop:spinspin',MT_INT,1,nospinspin)     !done
71      status=rtdb_get(rtdb,'prop:aoresponse',MT_INT,1,noaoresponse) !done
72c
73      if(nodhp.eq.0.or.nod2hp.eq.0) nodpl=0
74      if(nofhp.eq.0.or.nof2hp.eq.0) nofpl=0
75      if(nospinspin.eq.0) call hnd_spinspin(rtdb,basis,geom)
76
77c     ----- orbital localization ----
78
79c     Pipek-Mezey localization
80      if (nopmloc.eq.0) then
81        call localization_driver(rtdb, basis, geom, 1)
82      end if
83c
84c     Boys localization
85      if (noboysloc.eq.0) then
86        call localization_driver(rtdb, basis, geom, 2)
87      end if
88c
89c     ----- aoresponse: frequency dependent response -----
90c
91      iopt = 1 ! default
92      if (.not. rtdb_get(rtdb,'prop:newaoresp',MT_INT,1,iopt))
93     &   iopt = 1 ! toggle for old driver for closed shells
94      if (ipol.gt.1.or.scftype.eq."UHF") iopt = 1  ! always set new driver for open shells
95c
96      if (noaoresponse.eq.0) then
97        if (iopt.eq.0) then
98          if (ga_nodeid().eq.0) then
99               write (luout,*)
100     &   '*** CALLING OLD AORESP DRIVER FOR CLOSED SHELLS ***'
101          endif
102          call aoresponse_driver(rtdb, basis, geom)     ! old driver for closed shells only
103        else ! iopt .ne. 0
104          if (ga_nodeid().eq.0) then
105               write (luout,*)
106     &   '*** CALLING NEW AORESP DRIVER FOR CLOSED AND OPEN SHELLS ***'
107          endif
108          call aoresponse_driver_new(rtdb, basis, geom) ! new driver for closed and open shells
109        end if
110      end if
111c
112c     ----- dipole moment -----
113c
114      if(nodip.eq.0.or.nopmloc.eq.0.or.noboysloc.eq.0.or.nodpl.eq.0)
115     &  call hnd_mtpole(rtdb,basis,geom,1)
116c
117c     ----- quadrupole moment -----
118c
119      if(noqdp.eq.0)
120     &  call hnd_mtpole(rtdb,basis,geom,2)
121c
122c     ----- octupole moment -----
123c
124      if(nootp.eq.0)
125     &  call hnd_mtpole(rtdb,basis,geom,3)
126c
127c     ----- (hyper)polarizabilities by -sos- -----
128c
129*     if(nosos.eq.0) call hnd_sosx
130c
131c     ----- dipole polarizability -----
132c     ----- symmetry turned off   -----
133c
134*     if(nosym.ne.0) call hnd_symoff
135c
136*     if(nodpl.eq.0.and.nofpl.ne.0) call hnd_dpl
137c
138c     ----- dipole hyperpolarizability -----
139c
140*     if(nodhp.eq.0.and.nofhp.ne.0) call hnd_dhp
141c
142c     ----- dipole second hyperpolarizability -----
143c
144*     if(nod2hp.eq.0.and.nof2hp.ne.0) call hnd_d2hp
145c
146c     ----- frequency dependent dipole polarizability -----
147c
148*     if(nofpl.eq.0) call hnd_fpl
149c
150c     ----- freqency dependent dipole hyperpolarizability -----
151c
152*     if(nofhp.eq.0) call hnd_fhp
153c
154c     ----- frequency dependent dipole second hyperpolarizability -----
155c
156*     if(nof2hp.eq.0) call hnd_f2hp
157c
158c     ----- symmetry turned on again -----
159c
160*      if(nosym.ne.0) call hnd_symon
161c
162c     ----- mulliken population analysis -----
163c
164      if(nopop.eq.0) call hnd_mulken(rtdb,basis,geom)
165c
166c     ----- atomic spin density -----
167c
168      if(nospin.eq.0.and. (scftype.eq.'UHF')) then  ! only perform for open-shell
169       if (.not.do_zora) then
170          call hnd_spind(rtdb,basis,geom) ! non-relativistic
171       else
172        if (ga_nodeid().eq.0) then
173        write(LuOut,*)
174        call util_print_centered(LuOut,'ZORA NMR Hyperfine', 23, .true.)
175        write(LuOut,*)
176        endif
177        call hnd_hyperfine_ZORA(rtdb,basis,geom)
178       end if
179      end if
180c
181c     ----- electrostatic potential -----
182c
183      if(noelp.eq.0) call hnd_elpmap(rtdb,basis,geom)
184c
185c     ----- electrostatic potential on a specific electron density surface ---
186c
187      if(noelpiso.eq.0) call hnd_elpiso(rtdb,basis,geom)
188
189c     ----- electric field -----
190c
191      if(noelf.eq.0) call hnd_elfmap(rtdb,basis,geom)
192c
193c     ----- electric field gradient -----
194c
195      if(noelfg.eq.0) call hnd_efgmap(rtdb,basis,geom)
196c
197c     ----- electric field gradient with ZORA picture change effects -----
198c
199      if (do_zora. and. (noelfgZ4.eq.0)) then
200        if (ga_nodeid().eq.0) then
201         write(LuOut,*)
202         call util_print_centered(LuOut,'ZORA EFG-Z4', 23, .true.)
203         write(LuOut,*)
204        endif
205        call hnd_efgmap(rtdb,basis,geom)  ! normal EFG
206        call hnd_efgmap_Z4(rtdb,basis,geom)  ! with picture change (Z4) effects
207      end if
208c
209c     ----- electron, spin, alpha and beta densities -----
210c
211      if(noden.eq.0) then
212        call hnd_eldmap(rtdb,basis,geom)
213        call hnd_eldmap_grid(rtdb,basis,geom)
214      end if
215c
216c     ----- giao -nmr- chemical shifts -----
217c
218      if((nogiao.eq.0)) then
219        if (ga_nodeid().eq.0 .and. (do_zora)) then
220         write(LuOut,*)
221           call util_print_centered(LuOut,'Scalar ZORA NMR Shielding',
222     &                   23, .true.)
223         write(LuOut,*)
224        endif
225        call hnd_giaox_ZORA(rtdb,basis,geom) ! handles both w/wo zora
226      end if
227c
228c     ------- gshifts are a relativistic property -----
229c
230      if(nogshift.eq.0 .and. do_zora) then
231        if (ga_nodeid().eq.0) then
232         write(LuOut,*)
233         call util_print_centered(LuOut,'ZORA g-Shift', 23, .true.)
234         write(LuOut,*)
235        endif
236        call hnd_gshift_ZORA(rtdb,basis,geom) ! zora g-shift
237      end if
238c
239c     === deallocate used ga's ===
240      if (.not. rtdb_get(rtdb, 'dft:ipol', mt_int, 1, ipol))
241     &   ipol=1
242
243      if (nogshift.eq.0 .or. nogiao  .eq.0 .or.
244     &    nospin  .eq.0 .or. noelfgZ4.eq.0) then
245       if (do_zora) then
246        do i=1,ipol
247           if (.not. ga_destroy(g_zora_Kinetic(i))) call errquit(
248     &          'prp: ga_destroy failed g_zora_K',0, GA_ERR)
249           if (.not. ga_destroy(g_Cifull(i))) call errquit(
250     &         'prp: ga_destroy failed ',0, GA_ERR)
251        enddo ! ipol
252c Do not destroy g_AtNr if doing g-shift because it was not created!!
253        status=rtdb_get(rtdb,'prop:gshift'      ,MT_INT,1,nogshift)
254        if (nogshift.ne.0) then
255         if (.not. ga_destroy(g_AtNr)) call errquit( ! defined in dft_zora_NMR.F
256     &    'prp: ga_destroy failed g_AtNr',0, GA_ERR)
257        endif
258       if (.not. ga_destroy(g_Ci)) call errquit( ! defined in dft_zora_utils.F
259     &    'prp: ga_destroy failed g_Ci',0, GA_ERR)
260       end if
261      end if ! check-nogshift-nogiao-nospin-noelfgZ4
262c
263c     ----- stone's distributed multipole analysis -----
264c
265      noston=1
266!     if(noston.eq.0) call hnd_stonex
267c
268c     ----- boys orbital localization -----
269c
270      noboysloc=1
271!     if(noboysloc.eq.0) call hnd_boyloc
272!     if(noboysloc.eq.0) call hnd_mulken(rtdb,basis,geom)
273c
274      return
275      end
276