1 Subroutine sca_lab_mat(basis_hand,isha,ishb, 2 & nshbfa,nshbfb,g_a,vec,vec2,what) 3 4C$Id$ 5 implicit none 6#include "errquit.fh" 7 8 integer basis_hand 9 integer isha,ishb 10 integer nshbfa,nshbfb 11 integer g_a 12 character*3 what 13 double precision vec(nshbfb,*),vec2(nshbfa,*) 14c**** 15 16#include "bas.fh" 17c 18 integer ifirsta, ilasta, ifirstb, ilastb,jj,ii 19c 20c Given a handle to a Gaussian basis set and two shell indices, return the 21c composite index for the pair of basis functions. 22c 23c****************************************************************************** 24 25 if (.not. bas_cn2bfr( basis_hand, isha, ifirsta, ilasta)) then 26 call errquit('Exiting in sca_lab_mat',1, BASIS_ERR) 27 endif 28 if (.not. bas_cn2bfr( basis_hand, ishb, ifirstb, ilastb)) then 29 call errquit('Exiting in sca_lab_mat',2, BASIS_ERR) 30 endif 31 if(what.eq.'acc') then 32 call ga_acc(g_a, 33 * ifirstb,ilastb, 34 * ifirsta,ilasta, 35 * vec,nshbfb,1.d0) 36 else 37 call ga_put(g_a, 38 * ifirstb,ilastb, 39 * ifirsta,ilasta, 40 * vec,nshbfb) 41 endif 42 if(isha.ne.ishb) then 43 do jj=1,nshbfb 44 do ii=1,nshbfa 45 vec2(ii,jj)=vec(jj,ii) 46 enddo 47 enddo 48 if(what.eq.'acc') then 49 call ga_acc(g_a, 50 * ifirsta,ilasta, 51 * ifirstb,ilastb, 52 * vec2,nshbfa,1.d0) 53 else 54 call ga_put(g_a, 55 * ifirsta,ilasta, 56 * ifirstb,ilastb, 57 * vec2,nshbfa) 58 endif 59 endif 60 61 return 62 end 63 Subroutine sca_lab_mat3d(basis_hand,isha,ishb, 64 & nshbfa,nshbfb,g_a,nmat, 65 . vec,vec2,what) 66 67C$Id$ 68 implicit none 69#include "errquit.fh" 70#include "bas.fh" 71 integer nmat 72 integer basis_hand 73 integer isha,ishb 74 integer nshbfa,nshbfb 75 integer g_a 76 character*3 what 77 double precision vec(nmat,nshbfb,*),vec2(nmat,nshbfa,*) 78c 79 integer ifirsta, ilasta, ifirstb, ilastb,jj,ii,kk 80 integer hi(3),lo(3),ld(2) 81 82 if (.not. bas_cn2bfr( basis_hand, isha, ifirsta, ilasta)) then 83 call errquit('Exiting in sca_lab_mat',1, BASIS_ERR) 84 endif 85 if (.not. bas_cn2bfr( basis_hand, ishb, ifirstb, ilastb)) then 86 call errquit('Exiting in sca_lab_mat',2, BASIS_ERR) 87 endif 88 lo(1)=1 89 hi(1)=nmat 90 lo(2)=ifirsta 91 hi(2)=ilasta 92 lo(3)=ifirstb 93 hi(3)=ilastb 94 ld(1)=nmat 95 ld(2)=ilastb-ifirstb+1 96 if(what.eq.'acc') then 97 call errquit(' acc not coded ',0, UNKNOWN_ERR) 98 else 99 call nga_put(g_a, 100 * lo,hi, 101 * vec,ld) 102 endif 103 if(isha.ne.ishb) then 104 do kk=1,nmat 105 do jj=1,nshbfb 106 do ii=1,nshbfa 107 vec2(nmat,ii,jj)=vec(nmat,jj,ii) 108 enddo 109 enddo 110 enddo 111 if(what.eq.'acc') then 112 call errquit(' acc not coded ',0, UNKNOWN_ERR) 113 else 114 ld(2)=ilasta-ifirsta+1 115 call nga_put(g_a, 116 * lo,hi,vec2,ld) 117 endif 118 endif 119 120 return 121 end 122 123 Subroutine gat_mat(T,TT,Ni,Nj,mi,mj,ifirst,jfirst,ibf,jbf) 124 125C$Id$ 126 implicit none 127 integer mi,mj,Ni,Nj 128 integer ifirst,jfirst 129 integer ibf(mi),jbf(mj) 130 double precision T(mi,mj),TT(Ni,Nj) 131c 132 integer i,j,jj 133c 134c gather into matrix 135c 136 do j = 1,mj 137 jj=jbf(j)-jfirst+1 138 do i =1,mi 139 T(i,j)=TT((ibf(i)-ifirst+1),jj) 140 enddo 141 enddo 142 143 return 144 end 145