1c 2c qmd_tddft_enmo 3c 4 subroutine qmd_tddft_enmo(rtdb,geom,state,nstates,nroots,ipol, 5 $ nmo,nocc,en,g_v) 6c 7 implicit none 8c 9#include "rtdb.fh" 10#include "errquit.fh" 11#include "mafdecls.fh" 12#include "stdio.fh" 13#include "global.fh" 14c 15 integer rtdb ! rtdb 16 integer geom 17 integer state 18 integer nstates 19 integer nroots 20 integer ipol 21 integer nmo(2) 22 integer nocc(2) 23 integer g_v(2) 24 double precision en(nstates) 25c 26 character*30 pname 27c 28c preliminaries 29 pname = "qmd_tddft_enmo: " 30c 31 call qmd_tddft_energy(rtdb,state,nstates,nroots,en) 32 call qmd_tddft_movecs(rtdb,geom,ipol,nmo,nocc,g_v) 33c 34 call ga_sync() 35c 36 return 37 end 38c 39c qmd_tddft_energy: 40c 41 subroutine qmd_tddft_energy(rtdb,state,nstates,nroots,en) 42c 43 implicit none 44c 45#include "rtdb.fh" 46#include "errquit.fh" 47#include "mafdecls.fh" 48#include "stdio.fh" 49#include "global.fh" 50c 51 integer rtdb ! rtdb 52 integer state 53 integer nstates 54 integer nroots 55 double precision en(nstates) 56c 57 integer ien 58 integer l_enall, k_enall 59c 60 character*30 pname 61c 62c preliminaries 63 pname = "qmd_tddft_energy: " 64c 65 if (state.eq.1) call qmd_energy(rtdb,'tddft') 66c 67 if (.not.ma_push_get(mt_dbl,nroots,'enall',l_enall,k_enall)) 68 $ call errquit(pname//'ma_push_get enall',nroots,MA_ERR) 69c 70 if(.not.rtdb_get(rtdb,'dft:energy',mt_dbl,1,en(1))) 71 $ call errquit(pname//'dft energy',1,RTDB_ERR) 72 if(.not.rtdb_get(rtdb,'tddft:energy-all',mt_dbl,nroots, 73 $ dbl_mb(k_enall))) 74 $ call errquit(pname//'tddft energy',1,RTDB_ERR) 75 do ien=2,nstates 76 en(ien)=dbl_mb(k_enall+ien-2)+en(1) 77 end do 78c 79 if(.not.ma_pop_stack(l_enall)) 80 + call errquit(pname//'ma_chop_stack enall',0,MA_ERR) 81c 82 return 83 end 84c 85c qmd_tddft_movecs 86c 87 subroutine qmd_tddft_movecs(rtdb,geom,ipol,nmo,nocc,g_v) 88c 89 implicit none 90c 91#include "errquit.fh" 92#include "mafdecls.fh" 93#include "global.fh" 94#include "rtdb.fh" 95#include "bas.fh" 96c 97#include "qmd_common.fh" 98c 99 integer rtdb ! RTDB handle 100 integer geom ! geometry handle 101 integer g_v(2) ! movecs handle 102 integer ipol 103 integer nmo(2) 104 integer nocc(2) 105c 106c local variables 107 integer nbf ! number of basis functions 108 integer ipol_verify 109 integer nmo_verify(2) 110 integer nocc_verify(2) 111 integer basis 112 integer ispin 113 integer l_vals, k_vals 114 integer l_occ, k_occ 115 character*255 movecs ! MO vector file name 116 character*32 theory 117 character*255 title ! Title 118 character*255 basisname ! Basis set name 119 character*255 scftype ! Type of SCF 120c 121 integer ga_create_atom_blocked 122 external ga_create_atom_blocked 123 logical movecs_read_header 124 external movecs_read_header 125 logical movecs_read 126 external movecs_read 127c 128 character*30 pname 129c 130c preliminaries 131 pname='qmd_tddft_movecs: ' 132c 133 if (.not.bas_create(basis,'ao basis')) 134 & call errquit(pname//'failed to create',0,BASIS_ERR) 135c 136 if (.not.bas_rtdb_load(rtdb,geom,basis,'ao basis')) 137 & call errquit(pname//'failed to load',0,BASIS_ERR) 138c 139 if (.not. rtdb_cget(rtdb,'dft:output vectors',1,movecs)) 140 $ call errquit(pname//'DFT MO vectors not defined',0, 141 & RTDB_ERR) 142c 143 if (.not.movecs_read_header(movecs,title,basisname, 144 $ scftype,nbf,ipol_verify,nmo_verify,2)) call errquit 145 $ (pname//'failed to read MO file header',0, DISK_ERR) 146c 147 if (.not.rtdb_get(rtdb,'dft:noc',mt_int,2,nocc_verify)) 148 & call errquit(pname//'failed to get noc',0,RTDB_ERR) 149c 150 if (nmo(1).gt.0) then 151 do ispin=1,ipol 152 if (nmo(ispin).ne.nmo_verify(ispin)) 153 & call errquit(pname//'#MOs changed',0,RTDB_ERR) 154 if (nocc(ispin).ne.nocc_verify(ispin)) 155 & call errquit(pname//'#electrons changed',0,RTDB_ERR) 156 end do 157 end if 158 nmo=nmo_verify 159 nocc=nocc_verify 160c 161c Allocate MO energies array 162 if(.not.ma_push_get(mt_dbl,nbf,'vals',l_vals,k_vals)) 163 $ call errquit(pname//'could not allocate evals',nbf,MA_ERR) 164c 165c Allocate MO occup array 166 if(.not.ma_push_get(mt_dbl,nbf,'occ',l_occ,k_occ)) 167 $ call errquit(pname//'could not allocate occup',nbf,MA_ERR) 168c 169 do ispin=1,ipol 170 if(.not.movecs_read(movecs,ispin,dbl_mb(k_occ),dbl_mb(k_vals), 171 $ g_v(ispin))) 172 $ call errquit(pname//'failed to read MO vectors',0,DISK_ERR) 173 end do 174c 175 if (.not.ma_chop_stack(l_vals)) 176 $ call errquit(pname//'failed chopping MA stack',0, MA_ERR) 177 if (.not. ma_verify_allocator_stuff()) 178 $ call errquit(pname//'ma_verify_allocator_stuff',0,MA_ERR) 179 if (.not.bas_destroy(basis)) 180 $ call errquit(pname//'failed to destroy basis',basis,BASIS_ERR) 181c 182 return 183 end 184