1c
2c     Read 1-particle reduced density matrix
3c
4      logical function ao_1prdm_read(nbf,g_dens,filename)
5c
6      implicit none
7c
8#include "errquit.fh"
9#include "global.fh"
10#include "tcgmsg.fh"
11#include "msgtypesf.h"
12#include "mafdecls.fh"
13#include "msgids.fh"
14#include "cscfps.fh"
15#include "inp.fh"
16#include "util.fh"
17#include "stdio.fh"
18c
19      integer nbf               ! No. of functions in basis
20      integer g_dens
21      character*255  filename
22c
23      integer ok
24      integer l_dens, k_dens
25      integer i
26c
27      integer unitno
28      parameter (unitno = 66)
29c
30      integer inntsize
31      character*32 pname
32c
33c     Preliminaries
34      pname = "ao_1prdm_read: "
35      l_dens = -1               ! An invalid MA handle
36c
37      inntsize = MA_sizeof(MT_INT,1,MT_BYTE)
38      call ga_sync()
39      ok = 0
40      if (ga_nodeid() .eq. 0) then
41         open(unitno, status='old', form='unformatted', file=filename,
42     $        err=1000)
43         if (.not. ma_push_get(mt_dbl,nbf,'movecs_read',l_dens,k_dens))
44     $        call errquit(pname//'ma failed', nbf, MA_ERR)
45         do i = 1, nbf
46            call sread(unitno, dbl_mb(k_dens), nbf)
47            call ga_put(g_dens, 1, nbf, i, i, dbl_mb(k_dens), 1)
48         enddo
49 9       close(unitno,err=1002)
50         ok = 1
51      endif
52c
53 10   continue
54      if (l_dens .ne. -1) then
55         if (.not. ma_pop_stack(l_dens)) call errquit
56     $      (pname//'pop failed', l_dens, MA_ERR)
57      endif
58      call ga_sync()
59      call ga_brdcst(Msg_Vec_Stat+MSGINT, ok, inntsize, 0)
60c
61      ao_1prdm_read = ok .eq. 1
62      if (ga_nodeid() .eq. 0 .and. ao_1prdm_read .and.
63     $     util_print('vectors i/o', print_high)) then
64         write(6,22) 'ao_1prdm'
65 22      format(/' Read one-particle reduced density matrix from ',a/)
66         call util_flush(luout)
67      endif
68      return
69c
70 1000 write(6,*) pname//'failed to open ', filename
71      call util_flush(luout)
72      ok = 0
73      goto 10
74c
75 1002 write(6,*) pname//'failed to close', filename
76      call util_flush(luout)
77      ok = 0
78      goto 10
79c
80      end
81
82c $Id: ao_1prdm_read.F 26036 2014-08-26 00:28:22Z niri $
83