1      subroutine tddft_grad_store_gradient(rtdb,nat,nroots,iroots,g_g)
2      implicit none
3c
4c     Write the final TDDFT gradient to the runtime database for use
5c     elsewhere in the code.
6c
7c     Written by Huub van Dam, June 2007.
8c
9#include "errquit.fh"
10#include "mafdecls.fh"
11#include "global.fh"
12#include "rtdb.fh"
13c
14c     Input:
15c
16      integer rtdb           ! the runtime database handle
17      integer nat            ! the number of atoms
18      integer nroots         ! the number of excited states
19      integer iroots(nroots) ! the excited state labels
20      integer g_g            ! the global array holding the gradient
21c
22c     Local:
23c
24      integer lforce           ! the length of a gradient array
25      integer l_force, k_force ! memory for the gradient array
26      integer ilo(3), ihi(3)   ! the dimensions of the global array
27      integer ld(3)            ! the leading dimensions of the array
28      integer ir               ! counter over roots
29      logical status           ! return value of RTDB calls
30      integer iproc            ! the rank of the current processor
31c
32      character*26 rtdb_string ! name for the data on the RTDB
33c
34c     Code:
35c
36      call ga_sync
37c
38      status = rtdb_parallel(.false.)
39c
40      lforce = nat * 3
41      iproc = ga_nodeid()
42      if (iproc.eq.0) then
43c
44        if (.not.ma_push_get(mt_dbl,lforce,'forces',l_force,k_force))
45     &    call errquit(
46     &    'tddft_grad_store_gradient:could not allocate l_force',lforce,
47     &    MA_ERR)
48c
49        do ir = 1, nroots
50c
51          ilo(1) = ir
52          ihi(1) = ir
53          ilo(2) = 1
54          ihi(2) = 3
55          ilo(3) = 1
56          ihi(3) = nat
57          ld(1)  = 1
58          ld(2)  = 3
59          call nga_get(g_g,ilo,ihi,dbl_mb(k_force),ld)
60c
61c         write(rtdb_string,'("tddft:gradient:",i2)')iroots(ir)
62          write(rtdb_string,'("tddft:gradient")')
63          if (.not. rtdb_put(rtdb, rtdb_string, mt_dbl, lforce,
64     &      dbl_mb(k_force)))call errquit
65     &      ('tddft_grad_store_gradients: could not store gradients',
66     &       1, RTDB_ERR)
67c
68        enddo
69c
70        if (.not.ma_pop_stack(l_force)) call errquit(
71     &    'tddft_grad_store_gradient:could not deallocate l_force',
72     &    0, MA_ERR)
73c
74      endif
75c
76      call ga_sync
77c
78      status = rtdb_parallel(.true.)
79c
80      end
81
82c $Id$
83