1      logical function ao_1prdm_write(nbf,g_vecs)
2      implicit none
3#include "errquit.fh"
4#include "mafdecls.fh"
5#include "global.fh"
6#include "tcgmsg.fh"
7#include "msgtypesf.h"
8#include "inp.fh"
9#include "msgids.fh"
10#include "cscfps.fh"
11#include "util.fh"
12#include "bas.fh"
13#include "geom.fh"
14#include "rtdb.fh"
15#include "stdio.fh"
16c
17c     Temporary routine
18c
19      integer nbf               ! [input] No. of functions in basis
20      integer g_vecs     ! Global array with eigen-vectors
21c
22      integer unitno            ! Unit no. for writing
23      parameter (unitno = 66)   ! These need to be managed !!!
24      integer l_vecs, k_vecs
25      integer i
26      integer ok
27      integer inntsize
28c
29      inntsize = MA_sizeof(MT_INT,1,MT_BYTE)
30      call ga_sync()
31c
32      ok = 0
33c
34      if (ga_nodeid() .eq. 0) then
35         open(unitno, status='unknown', form='unformatted',
36     $        file='ao_1prdm', err=1000)
37         if (.not. ma_push_get(mt_dbl,nbf,'ao_1prdm_write',
38     1      l_vecs,k_vecs))
39     $        call errquit('ao_1prdm_write: ma failed', nbf, MA_ERR)
40         do i = 1, nbf
41            call ga_get(g_vecs, 1, nbf, i, i, dbl_mb(k_vecs),1)
42            call swrite(unitno, dbl_mb(k_vecs), nbf)
43         enddo
44         if (.not. ma_pop_stack(l_vecs))
45     $        call errquit('ao_1prdm_write: ma pop failed', l_vecs,
46     &       MA_ERR)
47         close(unitno,err=1002)
48         ok = 1
49      endif
50c
51   10 call ga_brdcst(Msg_Vec_Stat+MSGINT, ok, inntsize, 0)
52c
53      ao_1prdm_write = ok .eq. 1
54      if (ga_nodeid() .eq. 0 .and.
55     $     util_print('vectors i/o', print_high)) then
56         write(6,22) 'ao_1prdm'
57   22    format(/' Wrote one-particle reduced density matrix to ',a/)
58         call util_flush(luout)
59      endif
60      call ga_sync()
61      return
62c
63 1000 write(6,*) ' ao_1prdm_write: failed to open ',
64     $     'ao_1prdm'
65      call util_flush(luout)
66      ok = 0
67      goto 10
68c
69 1002 write(6,*) ' ao_1prdm_write: failed to close',
70     $     'ao_1prdm'
71      call util_flush(luout)
72      ok = 0
73      goto 10
74c
75      end
76
77c $Id$
78