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