1*
2* $Id$
3*
4
5*     ***********************************
6*     *             			*
7*     *           psi_write		*
8*     *             			*
9*     ***********************************
10
11      subroutine psi_write(ispin,ne,psi2,occupation,occ)
12      implicit none
13      integer ispin,ne(2)
14      double complex psi2(*)
15      integer occupation
16      double precision occ(*)
17
18#include "bafdecls.fh"
19#include "util.fh"
20#include "stdio.fh"
21#include "errquit.fh"
22
23*    *** local variables ***
24      integer version,l
25      integer nfft3d,npack1
26      integer nfft(3)
27      real*8  unita(3,3)
28      character*50 filename
29      character*255 full_filename
30
31      integer MASTER,taskid,taskid_i,taskid_j,taskid_p,com_p
32      parameter(MASTER=0)
33      integer n,q,pj
34
35c     complex*16 tmp(*)
36      integer tmp(2),tmp2(2)
37      logical value,lprint,pio,doflush
38
39*     ***** local functions ****
40      character*50 control_output_psi
41      external     control_output_psi
42      double precision control_unita
43      external         control_unita
44      integer  control_ngrid,control_version
45      external control_ngrid,control_version
46      logical  control_print,control_parallel_io
47      external control_print,control_parallel_io
48
49      call nwpw_timing_start(50)
50      call ga_sync()
51      call Parallel_taskid(taskid)
52      call Parallel2d_taskid_i(taskid_i)
53      call Parallel2d_taskid_j(taskid_j)
54      call D3dB_nfft3d(1,nfft3d)
55      call Pack_npack(1,npack1)
56
57      doflush = .false.
58      pio = control_parallel_io()
59      if (pio) then
60         taskid_p = taskid_i
61         com_p = 1
62      else
63         taskid_p = taskid
64         com_p = 0
65      end if
66
67      lprint= ((taskid.eq.MASTER).and.control_print(print_medium))
68
69      value = BA_push_get(mt_dcpl,nfft3d,'tmp',tmp(2),tmp(1))
70      value = value.and.
71     >        BA_push_get(mt_dcpl,nfft3d,'tmp2',tmp2(2),tmp2(1))
72      if (.not. value)
73     > call errquit('psi_write:out of stack memory',0,MA_ERR)
74
75      version = control_version()
76      nfft(1) = control_ngrid(1)
77      nfft(2) = control_ngrid(2)
78      nfft(3) = control_ngrid(3)
79
80      unita(1,1) = control_unita(1,1)
81      unita(2,1) = control_unita(2,1)
82      unita(3,1) = control_unita(3,1)
83      unita(1,2) = control_unita(1,2)
84      unita(2,2) = control_unita(2,2)
85      unita(3,2) = control_unita(3,2)
86      unita(1,3) = control_unita(1,3)
87      unita(2,3) = control_unita(2,3)
88      unita(3,3) = control_unita(3,3)
89
90*     **** open ELCIN binary file ****
91      if (taskid_p.eq.MASTER) then
92         filename = control_output_psi()
93
94         full_filename = filename
95         call util_file_name_resolve(full_filename, .false.)
96         l = index(full_filename,' ') -1
97         if (lprint) write(LuOut,1210) full_filename(1:l)
98 1210    FORMAT(/' output psi filename:',A)
99
100         doflush = .true.
101         call openfile(6,full_filename,l,'w',l)
102
103         if (taskid.eq.MASTER) then
104            call iwrite(6,version,1)
105            call iwrite(6,nfft,3)
106            call dwrite(6,unita,9)
107            call iwrite(6,ispin,1)
108            call iwrite(6,ne,2)
109            call iwrite(6,occupation,1)
110         else
111            if (pio) then
112               call ishift_fileptr(6,4)
113               call dshift_fileptr(6,9)
114               call ishift_fileptr(6,4)
115            end if
116         end if
117      end if
118
119*     *** write out 3d blocks ***
120      do n=1,(ne(1)+ne(2))
121         call Dneall_ntoqp(n,q,pj)
122         if (pj.eq.taskid_j) then
123           call Pack_c_Copy(1,psi2(1+(q-1)*npack1),dcpl_mb(tmp2(1)))
124           call Pack_c_unpack(1,dcpl_mb(tmp2(1)))
125         end if
126         if (pio) then
127            call D3dB_c_write_pio(1,6,dcpl_mb(tmp2(1)),
128     >                                dcpl_mb(tmp(1)),pj)
129         else
130            call D3dB_c_write(1,6,dcpl_mb(tmp2(1)),
131     >                            dcpl_mb(tmp(1)),pj)
132         end if
133      end do
134
135*     **** flush the filepointers ****
136      if (pio.and.doflush) call flush_fileptr(6)
137
138*     **** write the occupations - ****
139      if (occupation.gt.0) then
140         if (taskid.eq.MASTER) then
141           call dwrite(6,occ,(ne(1)+ne(2)))
142         end if
143      end if
144
145
146*     *** close ELCIN binary file ***
147      call ga_sync()
148      if (taskid_p.eq.MASTER) then
149        call closefile(6)
150      end if
151      call ga_sync()
152
153      value =           BA_pop_stack(tmp2(2))
154      value = value.and.BA_pop_stack(tmp(2))
155      if (.not. value)
156     > call errquit('psi_write:error popping stack',0,MA_ERR)
157
158      call nwpw_timing_end(50)
159      return
160      end
161
162
163
164
165*     ***********************************
166*     *             			*
167*     *           epsi_write		*
168*     *             			*
169*     ***********************************
170
171      subroutine epsi_write(ispin,ne,psi2)
172      implicit none
173      integer ispin,ne(2)
174      double complex psi2(*)
175
176#include "bafdecls.fh"
177#include "util.fh"
178#include "stdio.fh"
179#include "errquit.fh"
180
181
182*    *** local variables ***
183      integer occupation
184      integer version,l
185      integer nfft3d,npack1
186      integer nfft(3)
187      real*8  unita(3,3)
188      character*50 filename
189      character*255 full_filename
190
191      integer MASTER,taskid,taskid_i,taskid_j,taskid_p,com_p
192      parameter(MASTER=0)
193      integer n,q,pj
194
195c     complex*16 tmp(*)
196      integer tmp(2),tmp2(2)
197      logical value,lprint,pio,doflush
198
199*     ***** local functions ****
200      character*50 control_output_epsi
201      external     control_output_epsi
202      double precision control_unita
203      external         control_unita
204      integer  control_ngrid,control_version
205      external control_ngrid,control_version
206      logical  control_print,control_parallel_io
207      external control_print,control_parallel_io
208
209      doflush = .false.
210      call nwpw_timing_start(50)
211      call Parallel_taskid(taskid)
212      call Parallel2d_taskid_i(taskid_i)
213      call Parallel2d_taskid_j(taskid_j)
214      call D3dB_nfft3d(1,nfft3d)
215      call Pack_npack(1,npack1)
216
217      pio = control_parallel_io()
218      if (pio) then
219         taskid_p = taskid_i
220         com_p = 1
221      else
222         taskid_p = taskid
223         com_p = 0
224      end if
225
226      lprint= ((taskid.eq.MASTER).and.control_print(print_low))
227
228
229      value = BA_push_get(mt_dcpl,nfft3d,'tmp',tmp(2),tmp(1))
230      value = value.and.
231     >        BA_push_get(mt_dcpl,nfft3d,'tmp2',tmp2(2),tmp2(1))
232      if (.not. value)
233     > call errquit('epsi_write:out of stack memory',0,MA_ERR)
234
235      version = control_version()
236      nfft(1) = control_ngrid(1)
237      nfft(2) = control_ngrid(2)
238      nfft(3) = control_ngrid(3)
239
240      unita(1,1) = control_unita(1,1)
241      unita(2,1) = control_unita(2,1)
242      unita(3,1) = control_unita(3,1)
243      unita(1,2) = control_unita(1,2)
244      unita(2,2) = control_unita(2,2)
245      unita(3,2) = control_unita(3,2)
246      unita(1,3) = control_unita(1,3)
247      unita(2,3) = control_unita(2,3)
248      unita(3,3) = control_unita(3,3)
249
250*     **** open ELCIN binary file ****
251      if (taskid_p.eq.MASTER) then
252         filename = control_output_epsi()
253
254         full_filename = filename
255         call util_file_name_resolve(full_filename, .false.)
256
257         l = index(full_filename,' ') -1
258         if (lprint) write(LuOut,1220) full_filename(1:l)
259 1220    FORMAT(/' output epsi filename:',A)
260         doflush = .true.
261         call openfile(6,full_filename,l,'w',l)
262         if (taskid.eq.MASTER) then
263            call iwrite(6,version,1)
264            call iwrite(6,nfft,3)
265            call dwrite(6,unita,9)
266            call iwrite(6,ispin,1)
267            call iwrite(6,ne,2)
268            occupation = -1
269            call iwrite(6,occupation,1)
270         else
271            if (pio) then
272               call ishift_fileptr(6,4)
273               call dshift_fileptr(6,9)
274               call ishift_fileptr(6,4)
275            end if
276         end if
277      end if
278
279*     *** read in 3d blocks ***
280c      do n=1,(ne(1)+ne(2))
281c         call Dnexall_ntoqp(n,q,pj)
282c         if (pj.eq.taskid_j) then
283c           call Pack_c_Copy(1,psi2(1+(q-1)*npack1),dcpl_mb(tmp2(1)))
284c           call Pack_c_unpack(1,dcpl_mb(tmp2(1)))
285c         end if
286c         call D3dB_c_write(1,6,dcpl_mb(tmp2(1)),
287c     >                         dcpl_mb(tmp(1)),pj)
288c      end do
289      if (taskid_j.eq.0) then
290      do n=1,(ne(1)+ne(2))
291         call Pack_c_Copy(1,psi2(1+(n-1)*npack1),dcpl_mb(tmp2(1)))
292         call Pack_c_unpack(1,dcpl_mb(tmp2(1)))
293         if (pio) then
294            call D3dB_c_write_pio(1,6,dcpl_mb(tmp2(1)),
295     >                                dcpl_mb(tmp(1)),taskid_j)
296         else
297            call D3dB_c_write(1,6,dcpl_mb(tmp2(1)),
298     >                            dcpl_mb(tmp(1)),taskid_j)
299         end if
300      end do
301      end if
302
303*     **** flush the filepointers ****
304      if (pio.and.doflush) call flush_fileptr(6)
305
306
307*     *** close ELCIN binary file ***
308      call ga_sync()
309      if (taskid_p.eq.MASTER) then
310        call closefile(6)
311      end if
312      call ga_sync()
313
314      value =           BA_pop_stack(tmp2(2))
315      value = value.and.BA_pop_stack(tmp(2))
316      if (.not. value)
317     > call errquit('epsi_write:error popping stack',0,MA_ERR)
318
319      call nwpw_timing_end(50)
320      return
321      end
322
323
324
325*     ***********************************
326*     *             			*
327*     *           psi_write_noocc	*
328*     *             			*
329*     ***********************************
330
331      subroutine psi_write_noocc(ispin,ne,psi2)
332      implicit none
333      integer ispin,ne(2)
334      double complex psi2(*)
335      integer occupation
336
337#include "bafdecls.fh"
338#include "util.fh"
339#include "stdio.fh"
340#include "errquit.fh"
341
342*    *** local variables ***
343      integer version,l
344      integer nfft3d,npack1
345      integer nfft(3)
346      real*8  unita(3,3)
347      character*50 filename
348      character*255 full_filename
349
350      integer MASTER,taskid,taskid_i,taskid_j,taskid_p,com_p
351      parameter(MASTER=0)
352      integer n,q,pj
353
354c     complex*16 tmp(*)
355      integer tmp(2),tmp2(2)
356      logical value,lprint,pio,doflush
357
358*     ***** local functions ****
359      character*50 control_output_psi
360      external     control_output_psi
361      double precision control_unita
362      external         control_unita
363      integer  control_ngrid,control_version
364      external control_ngrid,control_version
365      logical  control_print,control_parallel_io
366      external control_print,control_parallel_io
367
368      call nwpw_timing_start(50)
369      call Parallel_taskid(taskid)
370      call Parallel2d_taskid_i(taskid_i)
371      call Parallel2d_taskid_j(taskid_j)
372      call D3dB_nfft3d(1,nfft3d)
373      call Pack_npack(1,npack1)
374
375      doflush = .false.
376      pio = control_parallel_io()
377      if (pio) then
378         taskid_p = taskid_i
379         com_p = 1
380      else
381         taskid_p = taskid
382         com_p = 0
383      end if
384
385      lprint= ((taskid.eq.MASTER).and.control_print(print_low))
386
387      value = BA_push_get(mt_dcpl,nfft3d,'tmp',tmp(2),tmp(1))
388      value = value.and.
389     >        BA_push_get(mt_dcpl,nfft3d,'tmp2',tmp2(2),tmp2(1))
390      if (.not. value)
391     > call errquit('psi_write:out of stack memory',0,MA_ERR)
392
393      version = control_version()
394      nfft(1) = control_ngrid(1)
395      nfft(2) = control_ngrid(2)
396      nfft(3) = control_ngrid(3)
397
398      unita(1,1) = control_unita(1,1)
399      unita(2,1) = control_unita(2,1)
400      unita(3,1) = control_unita(3,1)
401      unita(1,2) = control_unita(1,2)
402      unita(2,2) = control_unita(2,2)
403      unita(3,2) = control_unita(3,2)
404      unita(1,3) = control_unita(1,3)
405      unita(2,3) = control_unita(2,3)
406      unita(3,3) = control_unita(3,3)
407
408*     **** open ELCIN binary file ****
409      if (taskid_p.eq.MASTER) then
410         filename = control_output_psi()
411
412         full_filename = filename
413         call util_file_name_resolve(full_filename, .false.)
414c        call util_file_name_noprefix(filename,.false.,
415c    >                                .false.,
416c    >                       full_filename)
417         l = index(full_filename,' ') -1
418         if (lprint) write(LuOut,1210) full_filename(1:l)
419 1210    FORMAT(/' output psi filename:',A)
420
421         doflush = .true.
422         call openfile(6,full_filename,l,'w',l)
423         if (taskid.eq.MASTER) then
424            call iwrite(6,version,1)
425            call iwrite(6,nfft,3)
426            call dwrite(6,unita,9)
427            call iwrite(6,ispin,1)
428            call iwrite(6,ne,2)
429            occupation = -1
430            call iwrite(6,occupation,1)
431         else
432            if (pio) then
433               call ishift_fileptr(6,4)
434               call dshift_fileptr(6,9)
435               call ishift_fileptr(6,4)
436            end if
437         end if
438      end if
439
440*     *** write out 3d blocks ***
441      do n=1,(ne(1)+ne(2))
442         call Dneall_ntoqp(n,q,pj)
443         if (pj.eq.taskid_j) then
444           call Pack_c_Copy(1,psi2(1+(q-1)*npack1),dcpl_mb(tmp2(1)))
445           call Pack_c_unpack(1,dcpl_mb(tmp2(1)))
446         end if
447         if (pio) then
448            call D3dB_c_write_pio(1,6,dcpl_mb(tmp2(1)),
449     >                                dcpl_mb(tmp(1)),pj)
450         else
451            call D3dB_c_write(1,6,dcpl_mb(tmp2(1)),
452     >                            dcpl_mb(tmp(1)),pj)
453         end if
454      end do
455
456c*     **** write the occupations - ****
457c      if (occupation.gt.0) then
458c         if (taskid.eq.MASTER) then
459c           call dwrite(6,occ,(ne(1)+ne(2)))
460c         end if
461c      end if
462
463
464*     **** flush the filepointers ****
465      if (pio.and.doflush) call flush_fileptr(6)
466
467
468*     *** close ELCIN binary file ***
469      call ga_sync()
470      if (taskid_p.eq.MASTER) then
471        call closefile(6)
472      end if
473      call ga_sync()
474
475      value =           BA_pop_stack(tmp2(2))
476      value = value.and.BA_pop_stack(tmp(2))
477      if (.not. value)
478     > call errquit('psi_write:error popping stack',0,MA_ERR)
479
480      call nwpw_timing_end(50)
481      return
482      end
483
484