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