1C> \ingroup util_ga
2C> @{
3C>
4C> \brief Anti-symmetrizes the matrix \f$A\f$
5C>
6C> Anti-symmetrizes the matrix \f$A\f$ by computing
7C> \f{eqnarray*}{
8C>    A = \left(A-A^T\right)/2
9C> \f}
10C>
11      subroutine ga_antisymmetrize(g_a)
12c
13c     Antisymmetrizes matrix A:  A := .5 * (A-A`)
14c     copied from ga_symmetrize, A+A' replaced by A-A'
15c     J. Nieplocha 08.22.93
16c
17      implicit none
18#include "mafdecls.fh"
19#include "global.fh"
20      integer g_a               ! Matrix to symmetrize
21c
22      Double Precision alpha
23      Integer myproc, proc
24      Integer ilo, ihi, jlo, jhi, myelem, nrow,ncol, lda
25      Integer dim1, dim2, type
26      Logical have_data
27
28      Integer     adrA,handa          !A
29      Integer hB, adrB          !B
30c
31c***  check environment
32c
33      myproc = ga_nodeid()
34      proc   = ga_nnodes()
35      alpha = 0.5d0
36c
37      call ga_inquire(g_a,  type, dim1, dim2)
38c
39      if (dim1 .ne. dim2) then
40         call ga_error('ga_sym: can only sym square matrix', 0)
41      endif
42c
43c***  Find the local distribution
44      call ga_distribution(g_a, myproc, ilo, ihi, jlo, jhi)
45#ifdef  BAD_GACCESS
46      if(.not.ma_push_get(MT_DBL,(ihi-ilo+1)*(jhi-jlo+1),
47     $  'scratch buff', handa, adra)) call
48     $  errquit('gaantisymm: pushget failed',0)
49#endif
50c
51      have_data = ihi.gt.0 .and. jhi.gt.0
52c
53c     if(myproc.eq.0)call ga_print(g_a)
54      call ga_sync()
55      if (have_data) then
56#ifdef  BAD_GACCESS
57         lda=ihi-ilo+1
58         call ga_get(g_a, ilo, ihi, jlo, jhi, dbl_mb(adrA), lda)
59#else
60         call ga_access(g_a, ilo, ihi, jlo, jhi, adrA, lda)
61#endif
62         nrow = ihi-ilo+1
63         ncol = jhi-jlo+1
64         myelem = nrow * ncol
65         if (.not. ma_push_get(MT_DBL,myelem,'ga_symtr:B',hB,adrB))
66     $      call ga_error('ga_symmetrize: insufficient memory', myelem)
67c
68         call GA_GET(g_a, jlo, jhi, ilo, ihi, dbl_mb(adrB),ncol)
69c        print *, myproc,'a, aT', dbl_mb(adrA), dbl_mb(adrB),
70c    $            ilo, ihi, jlo, jhi
71      endif
72
73      call ga_sync()
74
75      if(have_data) then
76         call gai_subtr(nrow, ncol, dbl_mb(adrA), lda, dbl_mb(adrB),
77     &                ncol, alpha)
78#ifdef  BAD_GACCESS
79         call ga_put(g_a, ilo, ihi, jlo, jhi, dbl_mb(adrA), lda)
80#else
81         call ga_release_update(g_a, ilo, ihi, jlo, jhi)
82#endif
83         if (.not. ma_pop_stack(hB))
84     $        call ga_error('ga_symmetrize: ma_pop?', 0)
85      endif
86#ifdef  BAD_GACCESS
87      if(.not.ma_pop_stack(handa)) call
88     $  errquit('gaantisymm: popstack failed',0)
89#endif
90c
91      call ga_sync()
92c
93      end
94
95
96      subroutine nga_antisymmetrize(g_a)
97c
98c     Antisymmetrizes matrix A:  A := .5 * (A-A`)
99c     This is silly hack at the moment that loops over each of the
100c     first indices, gets a matrix, symmetrizes, and puts it back.
101c     This is limited to 3 dimensions.  Eventually, we should be able
102c     to grab much larger chunks at a time.
103c
104      implicit none
105#include "mafdecls.fh"
106#include "global.fh"
107      integer g_a               ! Matrix to symmetrize
108c
109      Double Precision alpha
110      Integer myproc, proc
111      Integer flo, fhi,ilo, ihi, jlo, jhi, myelem, nrow,ncol, lda(2)
112      Integer lo(3), hi(3), lob(3), hib(3), ldb(2)
113      Integer dim1, dim2, type, nmat
114      Integer ndim, dims(3)
115      Logical have_data
116
117      Integer     adrA          !A
118      Integer hB, adrB          !B
119c
120c***  check environment
121c
122      myproc = ga_nodeid()
123      proc   = ga_nnodes()
124      alpha = 0.5d0
125c
126      ndim = ga_ndim(g_a)
127      if (ndim.ne.3)
128     $   call ga_error('nga_sym: needs 3 dims',ndim)
129      call nga_inquire(g_a,  type, ndim, dims)
130      dim1 = dims(2)
131      dim2 = dims(3)
132c
133      if (dim1 .ne. dim2) then
134         call ga_error('nga_sym: can only sym square matrix', 0)
135      endif
136c
137c***  Find the local distribution
138      call nga_distribution(g_a, myproc, lo, hi)
139c
140c Take care of some indexing
141c
142      flo = lo(1)
143      ilo = lo(2)
144      jlo = lo(3)
145      fhi = hi(1)
146      ihi = hi(2)
147      jhi = hi(3)
148      lob(1) = flo
149      hib(1) = fhi
150      lob(2) = jlo  ! switch i and j
151      hib(2) = jhi
152      lob(3) = ilo
153      hib(3) = ihi
154      nmat = fhi-flo+1
155      nrow = ihi-ilo+1
156      ncol = jhi-jlo+1
157      myelem = nrow * ncol * nmat
158      ldb(1) = nmat
159      ldb(2) = ncol
160      have_data = fhi.gt.0 .and. ihi.gt.0 .and. jhi.gt.0
161c
162c Get memory (if we have data)
163c
164      if (have_data) then
165         if (.not. ma_push_get(MT_DBL,myelem,'ga_symtr:B',hB,adrB))
166     $      call ga_error('nga_symmetrize: insufficient memory',
167     $                     myelem)
168      endif
169c
170c Get the differenc pieces
171c
172      call ga_sync()
173      if (have_data) then
174         call nga_access(g_a, lo, hi, adrA, lda)
175c
176         call nga_get(g_a, lob, hib, dbl_mb(adrB),ldb)
177      endif
178
179      call ga_sync()
180
181      if(have_data) then
182         call ngai_subtr(nmat, nrow, ncol, dbl_mb(adrA), lda(1), lda(2),
183     &                 dbl_mb(adrB), ldb(1), ldb(2), alpha)
184         call nga_release_update(g_a, lo, hi)
185      endif
186c
187      call ga_sync()
188c
189      if (have_data) then
190         if (.not. ma_pop_stack(hB))
191     $        call ga_error('ga_symmetrize: ma_pop?', 0)
192      endif
193c
194      end
195
196
197      subroutine gai_subtr(nrow, ncol, A, lda, B, ldb, alpha)
198c
199c     A := alpha * (A - B^)
200c
201      implicit none
202      Integer nrow, ncol, lda, ldb
203      Double Precision A(lda,ncol), B(ldb,nrow), alpha
204      Integer i,j
205c
206      do j = 1, ncol
207         do i = 1, nrow
208            a(i,j) = alpha*(a(i,j)-b(j,i))
209         enddo
210      enddo
211      END
212
213
214      subroutine ngai_subtr(nmat, nrow, ncol, A, lda1, lda2,
215     $                    B, ldb1, ldb2, alpha)
216c
217c     A := alpha * (A - B^)
218c     Again, assumes 3 dimensions
219c
220      implicit none
221      Integer nmat, nrow, ncol, lda1, lda2, ldb1, ldb2
222      Double Precision A(lda1,lda2,ncol), B(ldb1,ldb2,nrow), alpha
223      Integer i,j,f
224c
225      do j = 1, ncol
226         do i = 1, nrow
227            do f = 1, nmat
228               a(f,i,j) = alpha*(a(f,i,j)-b(f,j,i))
229            enddo
230         enddo
231      enddo
232      END
233C>
234C> @}
235c $Id$
236