1*
2* $Id$
3*
4
5*     ***********************************
6*     *             			*
7*     *           psi_write_filename	*
8*     *             			*
9*     ***********************************
10
11      subroutine psi_write_filename(filename,ispin,ne,psi2)
12      implicit none
13      character*(*) filename
14      integer ispin,ne(2)
15      double complex psi2(*)
16      integer occupation
17
18#include "bafdecls.fh"
19#include "errquit.fh"
20
21*    *** local variables ***
22      integer version,l
23      integer nfft3d,npack1
24      integer nfft(3)
25      real*8  unita(3,3)
26      character*255 full_filename
27
28      integer MASTER,taskid,taskid_i,taskid_j,taskid_p,com_p
29      parameter(MASTER=0)
30      integer n,q,pj
31
32c     complex*16 tmp(*)
33      integer tmp(2),tmp2(2)
34      logical value,pio,doflush
35
36*     ***** local functions ****
37      double precision control_unita
38      external         control_unita
39      integer  control_ngrid,control_version
40      external control_ngrid,control_version
41      logical  control_parallel_io
42      external control_parallel_io
43
44      call nwpw_timing_start(50)
45      call Parallel_taskid(taskid)
46      call Parallel2d_taskid_i(taskid_i)
47      call Parallel2d_taskid_j(taskid_j)
48      call D3dB_nfft3d(1,nfft3d)
49      call Pack_npack(1,npack1)
50
51      doflush = .false.
52      pio = control_parallel_io()
53      if (pio) then
54         taskid_p = taskid_i
55         com_p = 1
56      else
57         taskid_p = taskid
58         com_p = 0
59      end if
60
61      value = BA_push_get(mt_dcpl,nfft3d,'tmp',tmp(2),tmp(1))
62      value = value.and.
63     >        BA_push_get(mt_dcpl,nfft3d,'tmp2',tmp2(2),tmp2(1))
64      if (.not. value)
65     > call errquit('psi_write_filename:out of stack',0,MA_ERR)
66
67      version = control_version()
68      nfft(1) = control_ngrid(1)
69      nfft(2) = control_ngrid(2)
70      nfft(3) = control_ngrid(3)
71
72      unita(1,1) = control_unita(1,1)
73      unita(2,1) = control_unita(2,1)
74      unita(3,1) = control_unita(3,1)
75      unita(1,2) = control_unita(1,2)
76      unita(2,2) = control_unita(2,2)
77      unita(3,2) = control_unita(3,2)
78      unita(1,3) = control_unita(1,3)
79      unita(2,3) = control_unita(2,3)
80      unita(3,3) = control_unita(3,3)
81
82*     **** open ELCIN binary file ****
83      if (taskid_p.eq.MASTER) then
84         call util_file_name_noprefix(filename,.false.,
85     >                                .false.,
86     >                       full_filename)
87         l = index(full_filename,' ') -1
88         doflush = .true.
89         call openfile(6,full_filename,l,'w',l)
90         if (taskid.eq.MASTER) then
91            call iwrite(6,version,1)
92            call iwrite(6,nfft,3)
93            call dwrite(6,unita,9)
94            call iwrite(6,ispin,1)
95            call iwrite(6,ne,2)
96            occupation = -1
97            call iwrite(6,occupation,1)
98         else
99            if (pio) then
100               call ishift_fileptr(6,4)
101               call dshift_fileptr(6,9)
102               call ishift_fileptr(6,4)
103            end if
104         end if
105      end if
106
107*     *** read in 3d blocks ***
108      do n=1,(ne(1)+ne(2))
109         call Dneall_ntoqp(n,q,pj)
110         if (pj.eq.taskid_j) then
111           call Pack_c_Copy(1,psi2(1+(q-1)*npack1),dcpl_mb(tmp2(1)))
112           call Pack_c_unpack(1,dcpl_mb(tmp2(1)))
113         end if
114         if (pio) then
115            call D3dB_c_write_pio(1,6,dcpl_mb(tmp2(1)),
116     >                                dcpl_mb(tmp(1)),pj)
117         else
118            call D3dB_c_write(1,6,dcpl_mb(tmp2(1)),
119     >                            dcpl_mb(tmp(1)),pj)
120         end if
121      end do
122
123*     **** flush the filepointers ****
124      if (pio.and.doflush) call flush_fileptr(6)
125
126*     *** close ELCIN binary file ***
127      call ga_sync()
128      if (taskid_p.eq.MASTER) then
129        call closefile(6)
130      end if
131      call ga_sync()
132
133      value =           BA_pop_stack(tmp2(2))
134      value = value.and.BA_pop_stack(tmp(2))
135      if (.not. value)
136     > call errquit('psi_write_filename:error popping stack',0,MA_ERR)
137
138      call nwpw_timing_end(50)
139      return
140      end
141
142
143
144
145*     **************************************
146*     *             			   *
147*     *        psi_write_full_filename     *
148*     *             			   *
149*     **************************************
150
151      subroutine psi_write_full_filename(full_filename,
152     >                                   ispin,ne,psi2,occupation,occ)
153      implicit none
154      character*(*) full_filename
155      integer ispin,ne(2)
156      double complex psi2(*)
157      integer occupation
158      double precision occ(*)
159
160#include "bafdecls.fh"
161#include "util.fh"
162#include "stdio.fh"
163#include "errquit.fh"
164
165*    *** local variables ***
166      integer version,l
167      integer nfft3d,npack1
168      integer nfft(3)
169      real*8  unita(3,3)
170
171      integer MASTER,taskid,taskid_i,taskid_j,taskid_p,com_p
172      parameter(MASTER=0)
173      integer n,q,pj
174
175c     complex*16 tmp(*)
176      integer tmp(2),tmp2(2)
177      logical value,lprint,pio,doflush
178
179*     ***** local functions ****
180      double precision control_unita
181      external         control_unita
182      integer  control_ngrid,control_version
183      external control_ngrid,control_version
184      logical  control_print,control_parallel_io
185      external control_print,control_parallel_io
186
187      call nwpw_timing_start(50)
188      call ga_sync()
189      call Parallel_taskid(taskid)
190      call Parallel2d_taskid_i(taskid_i)
191      call Parallel2d_taskid_j(taskid_j)
192      call D3dB_nfft3d(1,nfft3d)
193      call Pack_npack(1,npack1)
194
195
196      doflush = .false.
197      pio = control_parallel_io()
198      if (pio) then
199         taskid_p = taskid_i
200         com_p = 1
201      else
202         taskid_p = taskid
203         com_p = 0
204      end if
205
206      lprint= ((taskid.eq.MASTER).and.control_print(print_medium))
207
208      value = BA_push_get(mt_dcpl,nfft3d,'tmp',tmp(2),tmp(1))
209      value = value.and.
210     >        BA_push_get(mt_dcpl,nfft3d,'tmp2',tmp2(2),tmp2(1))
211      if (.not. value)
212     > call errquit('psi_write_full_filename:out of stack',0,MA_ERR)
213
214      version = control_version()
215      nfft(1) = control_ngrid(1)
216      nfft(2) = control_ngrid(2)
217      nfft(3) = control_ngrid(3)
218
219      unita(1,1) = control_unita(1,1)
220      unita(2,1) = control_unita(2,1)
221      unita(3,1) = control_unita(3,1)
222      unita(1,2) = control_unita(1,2)
223      unita(2,2) = control_unita(2,2)
224      unita(3,2) = control_unita(3,2)
225      unita(1,3) = control_unita(1,3)
226      unita(2,3) = control_unita(2,3)
227      unita(3,3) = control_unita(3,3)
228
229
230*     **** open ELCIN binary file ****
231      if (taskid_p.eq.MASTER) then
232
233
234         l = index(full_filename,' ') -1
235         if (lprint) write(LuOut,1210) full_filename(1:l)
236 1210    FORMAT(/' output psi filename:',A)
237
238         doflush = .true.
239         call openfile(6,full_filename,l,'w',l)
240
241         if (taskid.eq.MASTER) then
242            call iwrite(6,version,1)
243            call iwrite(6,nfft,3)
244            call dwrite(6,unita,9)
245            call iwrite(6,ispin,1)
246            call iwrite(6,ne,2)
247            call iwrite(6,occupation,1)
248         else
249            if (pio) then
250               call ishift_fileptr(6,4)
251               call dshift_fileptr(6,9)
252               call ishift_fileptr(6,4)
253            end if
254         end if
255      end if
256
257*     *** write out 3d blocks ***
258      do n=1,(ne(1)+ne(2))
259         call Dneall_ntoqp(n,q,pj)
260         if (pj.eq.taskid_j) then
261           call Pack_c_Copy(1,psi2(1+(q-1)*npack1),dcpl_mb(tmp2(1)))
262           call Pack_c_unpack(1,dcpl_mb(tmp2(1)))
263         end if
264         if (pio) then
265            call D3dB_c_write_pio(1,6,dcpl_mb(tmp2(1)),
266     >                                dcpl_mb(tmp(1)),pj)
267         else
268            call D3dB_c_write(1,6,dcpl_mb(tmp2(1)),
269     >                            dcpl_mb(tmp(1)),pj)
270         end if
271      end do
272
273*     **** flush the filepointers ****
274      if (pio.and.doflush) call flush_fileptr(6)
275
276*     **** write the occupations - ****
277      if (occupation.gt.0) then
278         if (taskid.eq.MASTER) then
279           call dwrite(6,occ,(ne(1)+ne(2)))
280         end if
281      end if
282
283
284*     *** close ELCIN binary file ***
285      call ga_sync()
286      if (taskid_p.eq.MASTER) then
287        call closefile(6)
288      end if
289      call ga_sync()
290
291      value =           BA_pop_stack(tmp2(2))
292      value = value.and.BA_pop_stack(tmp(2))
293      if (.not. value)
294     > call errquit('psi_write_full_filename:popping stack',0,MA_ERR)
295
296      call nwpw_timing_end(50)
297      return
298      end
299
300
301