1C
2C $Id$
3C
4      subroutine hess_restart(rtdb, restr)
5c
6c     Write information to the database for restart and also put the
7c     hessian and fock derivatives out to disk.  Before putting the
8c     hessian out to disk, we will do a global summation to make sure
9c     that we get all of the contributions out to disk.  Dividing by
10c     the number of processors will prepare the hessian for the next
11c     contribution.
12c
13      implicit none
14#include "errquit.fh"
15c
16#include "global.fh"
17#include "hess_info.fh"
18#include "mafdecls.fh"
19#include "msgids.fh"
20#include "rtdb.fh"
21#include "stdio.fh"
22#include "util.fh"
23c
24      integer rtdb              ! [input] Run-time database handle
25      integer restr             ! [input] level of calculation completed
26                                ! 1 = 1 e-; 2 = 2 e-
27c
28      integer ind, idens, irhs
29      integer ilo(3), ihi(3)
30      double precision dnrm
31c
32      logical oprint, olprint
33      logical ocphfprint, olcphfprint
34c
35      call ga_dgop(msg_hess_exy,dbl_mb(k_exy),n3xyz2,'+')
36c
37c     Print out if requested
38c
39      oprint = util_print('hess_follow',print_high)
40      olprint = (oprint.and.(ga_nodeid().eq.0))
41      ocphfprint = util_print('hess_cont',print_debug)
42      olcphfprint = (oprint.and.(ga_nodeid().eq.0))
43c
44      if (olprint) then
45        write(LuOut,*)
46        write(LuOut,*) 'The Hessian after contributions:',restr
47        call hess_hssout(dbl_mb(k_exy),n3xyz,n3xyz,n3xyz)
48      endif
49      if (ocphfprint) then
50        if (olcphfprint) then
51          write(LuOut,*)
52          write(LuOut,*) 'The Fock derivatives :'
53          call util_flush(LuOut)
54        endif
55        ind = 0
56        do idens = 1, ndens
57          do irhs = 1, n3xyz
58            ind = ind + 1
59            ilo(1) = ind
60            ilo(2) = 1
61            ilo(3) = 1
62            ihi(1) = ind
63            ihi(2) = nocc(idens)+nvirt(idens)
64            ihi(3) = nocc(idens)+nvirt(idens)
65            call nga_print_patch(g_rhs,ilo,ihi,1)
66          enddo
67        enddo
68      endif
69      if (oprint) then
70        if (olprint) then
71          write(LuOut,*)
72          write(LuOut,*) 'The Fock derivatives :'
73        endif
74        ind = 0
75        do idens = 1, ndens
76          do irhs = 1, n3xyz
77            ind = ind + 1
78            ilo(1) = ind
79            ilo(2) = 1
80            ilo(3) = 1
81            ihi(1) = ind
82            ihi(2) = nocc(idens)+nvirt(idens)
83            ihi(3) = nocc(idens)+nvirt(idens)
84            call nga_normf_patch(g_rhs,ilo,ihi,dnrm)
85            if (olprint) then
86              write(LuOut,'(a,": dFock =",i2,i4,f24.8)')
87     +        'hess_restart',
88     +        idens,irhs,dnrm
89            endif
90          enddo
91        enddo
92      endif
93c
94c  Write hessian out to disk
95c
96      if(ga_nodeid().eq.0) then
97         call hess_wrt()
98      endif
99c
100c  Scale for next step
101c
102      call dscal(n3xyz2,1.0d+00/ga_nnodes(),dbl_mb(k_exy),1)
103c
104c  Write out fock derivatives to disk
105c
106c      call sx_write(g_rhs,n3xyz*ndens,nbf,fx_dra_handle)
107c
108c  Write out restr to the database
109c
110c      if (.not. rtdb_put(rtdb, 'hess:restart',mt_int,1,restr))
111c     $  call errquit('hess_restart: could not save restr to rtdb',
112c     $  555, RTDB_ERR)
113c
114      return
115      end
116C
117      subroutine hess_getrestart(irestart)
118c
119c     Get hessian and fock derivatives from disk.  After getting the
120c     hessian from disk, we will divide the hessian by the number of
121c     processors to prepare for the next contribution.
122c
123      implicit none
124#include "errquit.fh"
125c
126#include "global.fh"
127#include "tcgmsg.fh"
128#include "hess_info.fh"
129#include "msgtypesf.h"
130#include "mafdecls.fh"
131#include "msgids.fh"
132#include "stdio.fh"
133#include "util.fh"
134c
135      integer irestart              ! [input] restart index
136c
137      integer i, ind, idens, irhs
138      integer ilo(3), ihi(3)
139      double precision dnrm
140      logical oprint, olprint, ocphfprint, olcphfprint
141c
142      oprint = util_print('hess_follow',print_high)
143      olprint = (oprint.and.(ga_nodeid().eq.0))
144      ocphfprint = util_print('hess_cont',print_debug)
145      olcphfprint = (oprint.and.(ga_nodeid().eq.0))
146c
147      if (ga_nodeid().eq.0) then
148        write(LuOut,*)
149        write(LuOut,*) 'Getting restart information'
150        write(LuOut,*)
151      endif
152c
153c  Read hessian and dipole derivative from disk and broadcast
154c
155      if(ga_nodeid().eq.0) then
156         call hess_read(ncent, dbl_mb(k_exy))
157         call ddip_read(ncent, dbl_mb(k_dder))
158      endif
159      call ga_brdcst(msg_hess_exy+MSGDBL, dbl_mb(k_exy),
160     &               mdtob(n3xyz2), 0)
161      call ga_brdcst(msg_hess_ddip+MSGDBL, dbl_mb(k_dder),
162     &               mdtob(3*n3xyz),0)
163c
164c  Read Fock derivatives from disk
165c
166      call sx_read(g_rhs,n3xyz*ndens,nbf,fx_dra_handle)
167c
168c  Print out if requested
169c
170      if (olprint) then
171        write(LuOut,*)
172        write(LuOut,*) 'The Hessian at restart:'
173        call hess_hssout(dbl_mb(k_exy),n3xyz,n3xyz,n3xyz)
174      endif
175      if (ocphfprint) then
176        if (olcphfprint) then
177          write(LuOut,*)
178          write(LuOut,*) 'The Fock derivatives :'
179          call util_flush(LuOut)
180        endif
181        ind = 0
182        do idens = 1, ndens
183          do irhs = 1, n3xyz
184            ind = ind + 1
185            ilo(1) = ind
186            ilo(2) = 1
187            ilo(3) = 1
188            ihi(1) = ind
189            ihi(2) = nocc(idens)+nvirt(idens)
190            ihi(3) = nocc(idens)+nvirt(idens)
191            call nga_print_patch(g_rhs,ilo,ihi,1)
192          enddo
193        enddo
194      endif
195      if (oprint) then
196        if (olprint) then
197          write(LuOut,*)
198          write(LuOut,*) 'The Fock derivatives :'
199        endif
200        ind = 0
201        do idens = 1, ndens
202          do irhs = 1, n3xyz
203            ind = ind + 1
204            ilo(1) = ind
205            ilo(2) = 1
206            ilo(3) = 1
207            ihi(1) = ind
208            ihi(2) = nocc(idens)+nvirt(idens)
209            ihi(3) = nocc(idens)+nvirt(idens)
210            call nga_normf_patch(g_rhs,ilo,ihi,dnrm)
211            if (olprint) then
212              write(LuOut,'(a,": dFock =",i2,i4,f24.8)')
213     +        'hess_restart',
214     +        idens,irhs,dnrm
215            endif
216          enddo
217        enddo
218      endif
219c
220c  Scale for next step
221c
222      call dscal(n3xyz2,1.0d+00/ga_nnodes(),dbl_mb(k_exy),1)
223      call dscal(n3xyz*3,1.0d+00/ga_nnodes(),dbl_mb(k_dder),1)
224c
225c  Get rid of density allocation if we are done with the 2e- contribution
226c
227cng      if (irestart.ge.2) then
228        do i = 1, ndens
229          if (.not.ga_destroy(g_dens(i)))
230     &     call errquit('hess_getrestart: failed to delete density',i,
231     &       GA_ERR)
232        enddo
233        if (.not.ga_destroy(g_rhs_xc))
234     &    call errquit('hess_getrestart: failed to delete g_rhs_xc',
235     &                  555, GA_ERR)
236         if (.not.ga_destroy(g_wdens))
237     &   call errquit('hess_getrestart: failed to delete wdensity',
238     &                 555, GA_ERR)
239        call schwarz_tidy()
240        call intdd_terminate()
241cng      endif
242c
243      return
244      end
245