1*
2* $Id$
3*
4
5*     ***********************************
6*     *             			*
7*     *           chi_read		*
8*     *             			*
9*     ***********************************
10
11      subroutine chi_read(ispin,ne,chi2)
12      implicit none
13      integer ispin,ne(2)
14      double complex chi2(*)
15
16#include "bafdecls.fh"
17#include "btdb.fh"
18#include "errquit.fh"
19
20
21*    *** local variables ***
22      integer version,l,rtdb
23      integer nfft3d,npack1,occupation
24      integer nfft(3)
25      real*8  unita(3,3)
26      character*50 filename
27      character*255 full_filename
28
29      integer MASTER,taskid
30      parameter(MASTER=0)
31      integer n,q,pj
32      integer msglen
33
34c     complex*16 tmp(*)
35      integer tmp(2),tmp2(2)
36      logical value,psi_nolattice
37
38*     ***** local functions ****
39      character*50 control_input_psi
40      external     control_input_psi
41      double precision control_unita
42      external         control_unita
43      integer  control_ngrid,control_rtdb
44      external control_ngrid,control_rtdb
45
46      call Parallel_taskid(taskid)
47      call D3dB_nfft3d(1,nfft3d)
48      call Pack_npack(1,npack1)
49
50      value = BA_push_get(mt_dcpl,nfft3d,'tmp',tmp(2),tmp(1))
51      if (.not. value)
52     >  call errquit('chi_read:out of stack memory',0, MA_ERR)
53
54      value = BA_push_get(mt_dcpl,nfft3d,'tmp2',tmp2(2),tmp2(1))
55       if (.not. value)
56     > call errquit('chi_read:out of stack memory',1, MA_ERR)
57
58*     **** open ELCIN binary file ****
59      if (taskid.eq.MASTER) then
60         filename = control_input_psi()
61         full_filename = filename
62         call util_file_name_resolve(full_filename, .false.)
63c        call util_file_name_noprefix(filename,.false.,
64c    >                                .false.,
65c    >                        full_filename)
66
67         l = index(full_filename,' ') -1
68         write(*,1210) full_filename(1:l)
69 1210    FORMAT(/' input psi filename:',A)
70
71         call openfile(5,full_filename,l,'r',l)
72         call iread(5,version,1)
73         call iread(5,nfft,3)
74         call dread(5,unita,9)
75         call iread(5,ispin,1)
76         call iread(5,ne,2)
77         call iread(5,occupation,1)
78      end if
79
80c     **** send header to all nodes ****
81      msglen = 1
82      call Parallel_Brdcst_ivalues(MASTER,msglen,version)
83      msglen = 3
84      call Parallel_Brdcst_ivalues(MASTER,msglen,nfft)
85      msglen = 9
86      call Parallel_Brdcst_values(MASTER,msglen,unita)
87      msglen = 1
88      call Parallel_Brdcst_ivalues(MASTER,msglen,ispin)
89      msglen = 2
90      call Parallel_Brdcst_ivalues(MASTER,msglen,ne)
91
92
93
94*     ***** Error checking ****
95      if (version.ne.9) then
96       call errquit(
97     >       'Error cannot read pspw or band structure wavefunctions',1,
98     &       INPUT_ERR)
99      end if
100
101      if ( (nfft(1).ne.control_ngrid(1)) .or.
102     >     (nfft(2).ne.control_ngrid(2)) .or.
103     >     (nfft(3).ne.control_ngrid(3)) ) then
104        if (taskid.eq.MASTER) then
105        write(*,*) "nfft :",nfft
106        write(*,*) "ngrid:",control_ngrid(1),
107     >                      control_ngrid(2),
108     >                      control_ngrid(3)
109        end if
110        call errquit('Error reading wavefunctions - bad grid', 2,
111     &       INPUT_ERR)
112      end if
113
114      rtdb = control_rtdb()
115      if (.not.btdb_get(rtdb,'nwpw:psi_nolattice',
116     >                  mt_log,1,psi_nolattice))
117     >   psi_nolattice = .true.
118
119      if (.not.psi_nolattice) then
120      if ( (unita(1,1).ne.control_unita(1,1)) .or.
121     >     (unita(2,1).ne.control_unita(2,1)) .or.
122     >     (unita(3,1).ne.control_unita(3,1)) .or.
123     >     (unita(1,2).ne.control_unita(1,2)) .or.
124     >     (unita(2,2).ne.control_unita(2,2)) .or.
125     >     (unita(3,2).ne.control_unita(3,2)) .or.
126     >     (unita(1,3).ne.control_unita(1,3)) .or.
127     >     (unita(2,3).ne.control_unita(2,3)) .or.
128     >     (unita(3,3).ne.control_unita(3,3)) ) then
129        call errquit('Error reading wavefunctions - bad lattice', 3,
130     &       INPUT_ERR)
131      end if
132      end if
133
134
135*     *** read in 3d blocks ***
136      do n=1,ispin
137         call D3dB_c_read(1,5,dcpl_mb(tmp2(1)),
138     >                        dcpl_mb(tmp(1)),-1)
139         call Pack_c_pack(1,dcpl_mb(tmp2(1)))
140         call Pack_c_Copy(1,dcpl_mb(tmp2(1)),chi2(1+(n-1)*npack1))
141      end do
142
143
144*     *** close ELCIN binary file ***
145      if (taskid.eq.MASTER) then
146        call closefile(5)
147      end if
148
149      value =           BA_pop_stack(tmp2(2))
150      value = value.and.BA_pop_stack(tmp(2))
151      if (.not. value) call errquit('chi_read:popping stack',4, MA_ERR)
152
153*     end if
154
155      return
156      end
157
158