1* $Id$
2c===================================================================
3      subroutine transfor(bl,nbls,ixint,
4     *                    ityps,jtyps,ktyps,ltyps,
5     *                    ilenx,jlenx,klenx,llenx,
6     *                    ilens,jlens,klens,llens)
7c--------------------------------------------------------------------
8c This routine is called only if PNL basis set was specified as
9c                       SPHERICAL
10c
11c Note: Despite the comment above it is still necessary to check
12c       whether lens.ne.lenx. The reason is that in resolution-of-the-
13c       density calculations (e.g. RI-SCF, RI-MP2 and other similar
14c       methods) we have 2 basis sets, the AO basis and the fitting
15c       basis. These may have different specifications for the
16c       angular momenta, e.g. spherical harmonic AO basis combined
17c       with a cartesian fitting basis. In these cases we must transform
18c       only the bra or the ket of the integrals but not both. Failing
19c       to appreciate this causes rogue data to be pulled in leading to
20c       invalid results.
21c
22c ityps-ltyps PNL type of spherical harmonic shells
23c ilenx-llenx are cartesian sizes (see below)
24c ilens-llens are spher.harmon. sizes (see below)
25c--------------------------------------------------------------------
26c Shell  s  p  l   d5  d6  f7  f10  g9 g15  h11 h21  i13 i28
27c--------------------------------------------------------------------
28c size = 1  3  4   5   6   7   10   9  15   11  21   13  28
29
30c--------------------------------------------------------------------
31c itype= 1  2  3   4   5   6   7        8        9       10 ! texas
32c size = 1  3  4   5   6   7   10   9  15   11  21   13  28
33c--------------------------------------------------------------------
34c ityp1= 1  2  3   4   4   5   5    6   6    7   7    8   8 ! texas
35c size1= 1  3  4   6   6   10  10   15 15   21  21   28  28
36
37c--------------------------------------------------------------------
38c PNL    0  1  -1  2   2   3   3    4   4    5   5    6   6 ! pnl
39c--------------------------------------------------------------------
40c siz_c  1  3  4   6   6   10  10   15  15  21   21  28  28
41c siz_s  1  3  4   5   5    7   7    9   9  11   11  13  13
42c--------------------------------------------------------------------
43      implicit real*8 (a-h,o-z)
44#include "errquit.fh"
45      dimension bl(*)
46c--------------------------------------------------------------------
47c bl(ixint) is :
48c xint(nbls,ilenx*jlenx*klenx*llenx) - input (cart) integrals
49c xint(nbls,           *           ) - output(sphe) integrals
50c
51c--------------------------------------------------------------------
52c check if transformation is nedded for this block of integrals:
53c
54      if( max(ityps,jtyps,ktyps,ltyps).le.1 ) RETURN
55c
56c     write(6,*)'PNL types:',ityps,jtyps,ktyps,ltyps
57c     write(6,*)'PNL sizeS:',ilens,jlens,klens,llens
58c     write(6,*)'PNL sizeC:',ilenx,jlenx,klenx,llenx
59c
60c--------------------------------------------------------------------
61      ndim_bra=ilenx*jlenx
62      ndim_ket=klenx*llenx
63      n_braket=ndim_bra*ndim_ket
64c--------------------------------------------------------------------
65c allocate memory for scratch :
66c
67      call getmem(n_braket, iscrt)
68c--------------------------------------------------------------------
69c
70c transpose integral array :  X(nbls,n_braket) --> Y(n_braket,nbls)
71c
72      call getmem(nbls*n_braket, iyint)
73c
74      lda=nbls
75      ldb=n_braket
76      call trspmo(bl(ixint),lda,  bl(iyint),ldb)
77c--------------------------------------------------------------------
78c do transformation for BRA <ij| :
79c
80      max_bra=max(ityps,jtyps)
81      if( max_bra.gt.1.and.(jlenx+ilenx).ne.(jlens+ilens) ) then
82         iaddress=iyint
83         do 100 nn=1,nbls
84            call spcart_bra2etran(bl(iaddress),bl(iscrt),
85     *                            jlenx,ilenx,
86     *                            jlens,ilens,
87     *                            jtyps,ityps,
88     *                            1    ,1    ,
89     *                            ndim_ket,
90     *                            .false.)
91ccc  *                            .true. )  ! print
92            iaddress=iaddress+n_braket
93  100    continue
94         ndim_bra=ilens*jlens
95      endif
96c--------------------------------------------------------------------
97c do transformation for KET |kl> :
98c
99      max_ket=max(ktyps,ltyps)
100      if( max_ket.gt.1.and.(llenx+klenx).ne.(llens+klens) ) then
101         iaddress=iyint
102         do 200 nn=1,nbls
103            call spcart_ket2etran(bl(iaddress),bl(iscrt),
104     *                            llenx,klenx,
105     *                            llens,klens,
106     *                            ltyps,ktyps,
107     *                            1    ,1    ,
108     *                            ndim_bra,
109     *                            .false.)
110ccc  *                            .true. )  ! print
111            iaddress=iaddress+n_braket
112  200    continue
113      endif
114c--------------------------------------------------------------------
115c transpose back : Y(n_braket,nbls) --> X(nbls,n_braket)
116c
117c     lda=nbls
118c     ldb=n_braket
119c
120      call trspmo(bl(iyint),ldb,  bl(ixint),lda)
121c--------------------------------------------------------------------
122c release allocated memory :
123c
124      call retmem(2)
125c--------------------------------------------------------------------
126      end
127c===================================================================
128      subroutine get_spher_pnl_type(itypx,ityps)
129c--------------------------------------------------------------------
130c This routine returns PNL-type of SPHERICAL HARMONIC shell's (ityps)
131c using TXS CARTESIAN types itypx
132c
133c--------------------------------------------------------------------
134c Shell  s  p  l   d    f    g    h    i
135c--------------------------------------------------------------------
136c PNL_S  0  1  -1  2    3    4    5    6  ! bas_spherical=.true.
137c PNL_C  0  1  -1  2    3    4    5    6  ! bas_spherical=.false.
138c--------------------------------------------------------------------
139c
140c Shell  s  p  l   d5  d6  f7   f10  g15  h21  i28
141c--------------------------------------------------------------------
142c TXS-   1  2  3   4   5   6    7    8    9    10   ! type
143c TXS-1  1  2  3   4   4   5    5    6    7     8   ! type1
144c--------------------------------------------------------------------
145c siz_c  1  3  4   6   6   10   10   15   21   28
146c siz_s  1  3  4   5   5    7   7    9    11   13
147c--------------------------------------------------------------------
148      dimension ish_type(8)
149c
150c TXS shells         s  p  l   d    f    g    h    i
151c TXS_types          1  2  3   4    5    6    7    8
152c
153      data ish_type/ 0, 1, -1, 2,   3,   4,   5,    6  /
154c--------------------------------------------------------------------
155      if(itypx.gt.8) then
156         call errquit('texas tried to transform orbitals higher than I',
157     $        0, INT_ERR)
158      endif
159c
160      ityps=ish_type(itypx)
161c--------------------------------------------------------------------
162      end
163c===================================================================
164