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