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