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