1* 2* $Id$ 3* 4 5* *********************************** 6* * * 7* * OrthoCheck * 8* * * 9* *********************************** 10 11 subroutine OrthoCheck(ispin,ne,psi1) 12 implicit none 13 integer ispin,ne(2) 14 double complex psi1(*) 15 16 17* *** local variables *** 18 19 integer MASTER,taskid 20 parameter(MASTER=0) 21 integer ms,npack1,i,j,ii,jj 22 integer n1(2),n2(2) 23 real*8 w,error 24 character*255 full_filename 25 26 call Parallel_taskid(taskid) 27 call Pack_npack(1,npack1) 28 29 n1(1) = 1 30 n2(1) = ne(1) 31 n1(2) = ne(1)+1 32 n2(2) = ne(1)+ne(2) 33 34* **** produce CHECK FILE **** 35 call util_file_name('ORTHOCHECK', 36 > .true., 37 > .false., 38 > full_filename) 39 if (taskid.eq.MASTER) then 40 open(unit=17,file=full_filename,form='formatted') 41 end if 42 43 44* **** check orthonormality **** 45 if (taskid.eq.MASTER) then 46 write(17,1350) 47 write(17,*) ne,n1,n2 48 end if 49 50 error = 0.0d0 51 do ms=1,ispin 52 do i=n1(ms),n2(ms) 53 ii = i-n1(ms)+1 54 do j=i,n2(ms) 55 jj = j-n1(ms)+1 56 call Pack_cc_dot(1,psi1(1+(i-1)*npack1), 57 > psi1(1+(j-1)*npack1), 58 > w) 59 60 if (i.eq.j) then 61 error = dabs(1.0d0-w) 62 else 63 error = dabs(w) 64 end if 65 66 if (taskid.eq.MASTER) then 67 write(17,1360) ms,ii,jj,w 68 end if 69 end do 70 end do 71 end do 72 if (taskid.eq.MASTER) write(17,1370) error 73 if (taskid.eq.MASTER) write(17,1380) 74 75* **** produce CHECK FILE **** 76 if (taskid.eq.MASTER) then 77 close(17) 78 end if 79 80 81 return 82 1350 FORMAT(/'******** orthonormality **********') 83 1360 FORMAT(I3,2I3,E18.7) 84 1370 FORMAT('ERROR = ',E18.7) 85 1380 FORMAT(/'**********************************') 86 end 87 88 89 90c* *********************************** 91c* * * 92c* * Grsm_MakeOrtho * 93c* * * 94c* *********************************** 95c 96c subroutine Grsm_g_MakeOrtho(npack,ne,psi) 97c implicit none 98c integer npack,ne 99c double complex psi(npack,ne) 100c 101c* **** local variables **** 102c integer j,k 103c real*8 w 104c 105c 106c write(*,*) 107c > "WARNING - not finished for 2d processor grid implementation!" 108c 109c !**** orthogonalize from the top -> down **** 110c do k=1,ne 111c call Pack_cc_dot(1,psi(1,k),psi(1,k),w) 112c w = 1.0d0/dsqrt(w) 113c call Pack_c_SMul(1,w,psi(1,k),psi(1,k)) 114c 115c do j=k+1,ne 116c call Pack_cc_dot(1,psi(1,k),psi(1,j),w) 117c w = -w 118c call Pack_cc_daxpy(1,w,psi(1,k),psi(1,j)) 119c end do 120c end do 121c 122cc !**** orthogonalize from the bottom -> up **** 123cc do k=ne,1,-1 124cc call Pack_cc_dot(1,psi(1,k),psi(1,k),w) 125cc w = 1.0d0/dsqrt(w) 126cc call Pack_c_SMul(1,w,psi(1,k),psi(1,k)) 127cc 128cc do j=k-1,1,-1 129cc call Pack_cc_dot(1,psi(1,k),psi(1,j),w) 130cc w = -w 131cc call Pack_cc_daxpy(1,w,psi(1,k),psi(1,j)) 132cc end do 133cc end do 134c 135c 136c return 137c end 138 139 140 141* *********************************** 142* * * 143* * OrthoCheck_geo * 144* * * 145* *********************************** 146 147 subroutine OrthoCheck_geo(ispin,ne,psi1) 148 implicit none 149 integer ispin,ne(2) 150 double complex psi1(*) 151 152 153* *** local variables *** 154 155 integer MASTER,taskid 156 parameter(MASTER=0) 157 integer ms,npack1,i,j,ii,jj 158 integer n1(2),n2(2) 159 real*8 w,error 160 character*255 full_filename 161 162 call Parallel_taskid(taskid) 163 call Pack_npack(1,npack1) 164 165 n1(1) = 1 166 n2(1) = ne(1) 167 n1(2) = ne(1)+1 168 n2(2) = ne(1)+ne(2) 169 170 171 172 173* **** check orthonormality **** 174 if (taskid.eq.MASTER) then 175 write(*,1350) 176 write(*,*) ne,n1,n2 177 end if 178 179 error = 0.0d0 180 do ms=1,ispin 181 do i=n1(ms),n2(ms) 182 ii = i-n1(ms)+1 183 do j=i,n2(ms) 184 jj = j-n1(ms)+1 185 call Pack_cc_dot(1,psi1(1+(i-1)*npack1), 186 > psi1(1+(j-1)*npack1), 187 > w) 188 189 if (i.eq.j) then 190 error = dabs(1.0d0-w) 191 else 192 error = dabs(w) 193 end if 194 195 if (taskid.eq.MASTER) then 196 write(*,1360) ms,ii,jj,w 197 end if 198 end do 199 end do 200 end do 201 if (taskid.eq.MASTER) write(*,1370) error 202 if (taskid.eq.MASTER) write(*,1380) 203 204 205 return 206 1350 FORMAT(/'******** geo orthonormality **********') 207 1360 FORMAT(I3,2I3,E18.7) 208 1370 FORMAT('ERROR = ',E18.7) 209 1380 FORMAT(/'**********************************') 210 end 211 212