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