1* $Id$
2c-----------------------------------------------------------------------
3C This files contains a set of routines used to convert pair
4c quantities into quartet quantities. These routines used to
5c be included in different files, usually where they are called
6c from. They are called with ...BL(IADDRESS).. double precision
7c parameters which then are of the INTEGER type in the routines.
8c It causes problems of incompatibile types for some compilers.
9c-----------------------------------------------------------------------
10c List of subroutines with previous location :
11c
12c amshift.f:      subroutine convr3(bl,m,nbls,npij,npkl,idx1,idx2,
13c
14c derivat.f:      subroutine conv24x(nbls,npij,npkl,idx1,idx2 ,
15c derivat.f:      subroutine conv24r(nbls,npij,idx1,xab,xabq)
16c
17c spec_calcint.f: subroutine conv1x_1(nbls1,mmax1,npij,lcij, idx1,indx,
18c spec_calcint.f: subroutine conv1der_1(nbls1,npij,lci,idx1,indx, aa,
19c spec_calcint.f: subroutine conv1der_2(nbls1,npij,lci,idx1,indx, aa,
20c spec_calcint.f: subroutine conv1x_2(nbls1,mmax1,npij,lcij, idx1,indx,
21c spec_calcint.f: subroutine conv2x(nbls1,nfumax1,npkl,lckl, idx2,indx,
22c-----------------------------------------------------------------------
23c=======================================================================
24      subroutine convr3(bl,m,nbls,npij,npkl,idx1,idx2,
25     *                   xab,xcd, ixabn,ixcdn)
26      implicit real*8 (a-h,o-z)
27      dimension bl(*)
28      dimension idx1(*),idx2(*)
29      dimension xab(npij,3),xcd(npkl,3)
30c
31      nbls1=nbls
32      nbls2=nbls*2
33      nbls3=nbls*3
34      nbls1=nbls1*m
35      nbls2=nbls2*m
36      nbls3=nbls3*m
37      call getmem(nbls3,ixabn)
38      call getmem(nbls3,ixcdn)
39c
40       ixab1=ixabn-1
41       ixcd1=ixcdn-1
42c
43      ijklnmr=0
44      do 100 ijkl=1,nbls
45      ijpar=idx1(ijkl)
46      klpar=idx2(ijkl)
47c
48      xab1=xab(ijpar,1)
49      xab2=xab(ijpar,2)
50      xab3=xab(ijpar,3)
51      xcd1=xcd(klpar,1)
52      xcd2=xcd(klpar,2)
53      xcd3=xcd(klpar,3)
54c
55        do 100 nmr=1,m
56        ijklnmr=ijklnmr+1
57        bl(ixab1+ijklnmr)      =xab1
58        bl(ixab1+ijklnmr+nbls1)=xab2
59        bl(ixab1+ijklnmr+nbls2)=xab3
60c
61        bl(ixcd1+ijklnmr)      =xcd1
62        bl(ixcd1+ijklnmr+nbls1)=xcd2
63        bl(ixcd1+ijklnmr+nbls2)=xcd3
64c
65  100 continue
66      return
67      end
68c=======================================================================
69      subroutine conv24x(nbls,npij,npkl,idx1,idx2 ,
70     *                  xab ,xcd, xyab, xycd ,
71     *                  xabq,xcdq,xyabq,xycdq )
72      implicit real*8 (a-h,o-z)
73c
74      dimension idx1(nbls),idx2(nbls)
75      dimension xab(npij,3) ,xcd(npkl,3) ,xyab(npij,3) ,xycd(npkl,3)
76      dimension xabq(nbls,3),xcdq(nbls,3),xyabq(nbls,3),xycdq(nbls,3)
77c
78      do 100 ijkl=1,nbls
79      ijpar=idx1(ijkl)
80      klpar=idx2(ijkl)
81        do 150 i=1,3
82        xabq(ijkl,i)=xab(ijpar,i)
83        xcdq(ijkl,i)=xcd(klpar,i)
84        xyabq(ijkl,i)=xyab(ijpar,i)
85        xycdq(ijkl,i)=xycd(klpar,i)
86  150   continue
87  100 continue
88c
89      end
90c=======================================================================
91      subroutine conv24r(nbls,npij,idx1,xab,xabq)
92      implicit real*8 (a-h,o-z)
93c
94      dimension idx1(nbls)
95      dimension xab(npij,3),xabq(nbls,3)
96c
97      do 100 ijkl=1,nbls
98      ijpar=idx1(ijkl)
99c     klpar=idx2(ijkl)
100        do 150 i=1,3
101        xabq(ijkl,i)=xab(ijpar,i)
102c       xcdq(ijkl,i)=xcd(klpar,i)
103  150   continue
104  100 continue
105      end
106c=======================================================================
107      subroutine conv1x_1(nbls1,mmax1,npij,lcij, idx1,indx,
108     *                    abnia,xpn,abnix,xpnx )
109c-------------------------------------------------------------------
110c npij = number of uniqe pairs now
111c-------------------------------------------------------------------
112c
113      implicit real*8 (a-h,o-z)
114      dimension idx1(*),indx(*)
115      dimension xpn(npij,3,*)
116      dimension abnia(npij,mmax1,*)
117c
118      dimension xpnx(nbls1,3)
119      dimension abnix(nbls1,mmax1)
120c
121      do 10 i=1,nbls1
122      ijkl=indx(i)
123      ijpar=idx1(ijkl)
124        xpnx(i,1)=xpn(ijpar,1,lcij)
125        xpnx(i,2)=xpn(ijpar,2,lcij)
126        xpnx(i,3)=xpn(ijpar,3,lcij)
127   10 continue
128c
129      do 20 m=1,mmax1
130      do 20 i=1,nbls1
131      ijkl=indx(i)
132      ijpar=idx1(ijkl)
133        abnix(i,m)=abnia(ijpar,m,lcij)
134   20 continue
135      end
136c=======================================================================
137      subroutine conv1x_2(nbls1,mmax1,npij,lcij, idx1,indx,xpn,xpnx )
138c
139c npij = number of uniqe pairs now
140c
141c
142      implicit real*8 (a-h,o-z)
143      dimension idx1(*),indx(*)
144      dimension xpn(npij,3,*)
145      dimension xpnx(nbls1,3)
146c
147      do 10 i=1,nbls1
148      ijkl=indx(i)
149      ijpar=idx1(ijkl)
150        xpnx(i,1)=xpn(ijpar,1,lcij)
151        xpnx(i,2)=xpn(ijpar,2,lcij)
152        xpnx(i,3)=xpn(ijpar,3,lcij)
153   10 continue
154c
155      end
156c=======================================================================
157      subroutine conv1der_1(nbls1,npij,lci,idx1,indx, aa, aax)
158c
159c npij = number of uniqe pairs now
160c exponents are already rescaled by 2 in precal2a_1
161c
162      implicit real*8 (a-h,o-z)
163      dimension idx1(*),indx(*)
164      dimension aa(npij,*)
165c output :
166      dimension aax(nbls1)
167c
168      do 10 i=1,nbls1
169      ijkl=indx(i)
170      ijpar=idx1(ijkl)
171cccc    aax(i)=aa(ijpar,lci)*2.0d0   ! already rescaled
172        aax(i)=aa(ijpar,lci)
173   10 continue
174c
175      end
176c=======================================================================
177      subroutine conv1der_2(nbls1,npij,lci,idx1,indx, aa, aax)
178c
179c npij = number of uniqe pairs now
180c
181      implicit real*8 (a-h,o-z)
182      dimension idx1(*),indx(*)
183      dimension aa(npij,*)
184c output :
185      dimension aax(nbls1)
186c-------------------------------------------------------------------
187c this is for iroute=2 only: all exponents in a block are the same:
188c exponents are already rescaled by 2 in precal2a_2
189c-------------------------------------------------------------------
190      aax(1)=aa(1,lci)
191c
192c     ijkl1 =indx(1)
193c     ijpar1=idx1(ijkl1)
194c     aax(1)=aa(ijpar1,lci)*2.d0
195c----------------------------------------------
196c     do 10 i=1,nbls1
197c     ijkl=indx(i)
198c     ijpar=idx1(ijkl)
199c       aax(i)=aa(ijpar,lci)*2.0d0
200c  10 continue
201c----------------------------------------------
202c
203      end
204c=======================================================================
205      subroutine conv2x(nbls1,nfumax1,npkl,lckl, idx2,indx,
206     *                  habcd,nfumax, habcdx  )
207c
208c npkl = number of uniqe pairs now
209c
210      implicit real*8 (a-h,o-z)
211      dimension idx2(*),indx(*)
212      dimension habcd(npkl,3,nfumax,*)
213      dimension habcdx(nbls1,3,nfumax)
214c
215         do 32 ifu=1,nfumax1
216         do 32 i=1,nbls1
217         ijkl=indx(i)
218         klpar=idx2(ijkl)
219           habcdx(i,1,ifu)=habcd(klpar,1,ifu,lckl)
220           habcdx(i,2,ifu)=habcd(klpar,2,ifu,lckl)
221           habcdx(i,3,ifu)=habcd(klpar,3,ifu,lckl)
222   32    continue
223      end
224c=======================================================================
225