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