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