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