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