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