1c
2c     Write out 1-particle reduced density matrix
3c
4      subroutine ao_1prdm_write(nbf,g_dens,filename)
5c
6      implicit none
7c
8#include "errquit.fh"
9#include "mafdecls.fh"
10#include "global.fh"
11#include "tcgmsg.fh"
12#include "msgtypesf.h"
13#include "inp.fh"
14#include "msgids.fh"
15#include "cscfps.fh"
16#include "util.fh"
17#include "bas.fh"
18#include "geom.fh"
19#include "rtdb.fh"
20#include "stdio.fh"
21c
22      integer nbf         ! [input] Number of basis functions
23      integer g_dens      ! [input] 1-particle reduced density matrix
24      character*255 filename
25c
26      integer l_dens, k_dens
27      integer ok
28      integer inntsize
29      integer i
30      character*32 pname
31c
32      integer unitno
33      parameter (unitno = 78)
34c
35c     Preliminaries
36      pname = "ao_1prdm_write: "
37      l_dens = -1               ! An invalid MA handle
38c
39c     Read the file
40      inntsize=MA_sizeof(MT_INT,1,MT_BYTE)
41      call ga_sync()
42      ok = 0
43      if (ga_nodeid() .eq. 0) then
44       open(unitno,status='unknown',form='unformatted',file=filename)
45       if (.not. ma_push_get(mt_dbl,nbf,'ao_1prdm_write',
46     &     l_dens,k_dens)) call errquit(pname//'ma failed', nbf, MA_ERR)
47       do i = 1,nbf
48            call ga_get(g_dens, 1, nbf, i, i, dbl_mb(k_dens),1)
49            call swrite(unitno, dbl_mb(k_dens), nbf)
50       enddo
51       close(unitno)
52c
53c      Clean up
54       if (.not. ma_pop_stack(l_dens))
55     $      call errquit(pname//'ma pop failed', l_dens, MA_ERR)
56      endif   ! ga_nodeid()
57c
58c     Broadcast status to other nodes
59      ok = 1
60 10   call ga_brdcst(Msg_Vec_Stat+MSGINT, ok, inntsize, 0)
61      call ga_sync()
62c
63      end
64c $Id: ao_1prdm_write.F 26036 2014-08-26 00:28:22Z niri $
65