Commit 2a023436 authored by Roland Lindh's avatar Roland Lindh

Eliminate ipCntr all together.

parent 64c68663
Pipeline #161780092 failed with stage
in 56 minutes and 39 seconds
......@@ -13,15 +13,15 @@
Module Basis_Info
Implicit None
Private
Public :: Basis_Info_Dmp, Basis_Info_Get, &
Public :: Basis_Info_Dmp, Basis_Info_Get, Basis_Info_Free, &
Distinct_Basis_set_Centers, dbsc
#include "stdalloc.fh"
#include "Molcas.fh"
Integer, Parameter :: Mxdbsc=MxAtom
! Work in progress
Type Distinct_Basis_set_centers
Integer:: ipCntr
Integer:: nCntr=-1
Real*8, Allocatable:: Coor(:,:)
Integer:: nCntr=0
End Type Distinct_Basis_set_centers
!
Type (Distinct_Basis_set_centers) :: dbsc(Mxdbsc)
......@@ -36,55 +36,114 @@
!***********************************************************************
!
Subroutine Basis_Info_Dmp()
Integer i, nCnttp
Integer, Allocatable:: iDmp(:,:)
Integer i, j, nCnttp, nAtoms
Integer, Allocatable:: iDmp(:)
Real*8, Allocatable:: rDmp(:,:)
!
! Temporary code until nCnttp has been move over to the Module
!
i = 0
Do
i=i+1
If (i.gt.Mxdbsc .or. dbsc(i)%nCntr.eq.-1) Exit
If (i.gt.Mxdbsc .or. dbsc(i)%nCntr.eq.0) Exit
End Do
nCnttp=i-1
#ifdef _DEBUG_
Write (6,*) 'Basis_Info_Dmp'
Do i = 1, nCnttp
Write (6,*) dbsc(i)%ipCntr, dbsc(i)%nCntr
Do j = 1, dbsc(i)%nCntr
Write (6,*) (dbsc(i)%Coor(k,j),k=1,3)
End Do
End Do
#endif
Call mma_Allocate(iDmp,2,nCnttp,Label='iDmp')
Call mma_Allocate(iDmp,nCnttp,Label='iDmp')
nAtoms=0
Do i = 1, nCnttp
iDmp(1,i) = dbsc(i)%ipCntr
iDmp(2,i) = dbsc(i)%nCntr
iDmp(i) = dbsc(i)%nCntr
nAtoms=nAtoms+dbsc(i)%nCntr
End Do
Call Put_iArray('iDmp',iDmp,2*nCnttp)
Call Put_iArray('iDmp',iDmp,nCnttp)
Call mma_deallocate(iDmp)
!
Call mma_allocate(rDmp,3,nAtoms,Label='rDmp')
nAtoms = 0
Do i = 1, nCnttp
Do j = 1, dbsc(i)%nCntr
nAtoms=nAtoms+1
rDmp(1:3,nAtoms)=dbsc(i)%Coor(1:3,j)
End Do
End Do
Call Put_dArray('rDmp',rDmp,3*nAtoms)
Call mma_deallocate(rDmp)
Return
End Subroutine Basis_Info_Dmp
!
!***********************************************************************
!
Subroutine Basis_Info_Get()
Integer, Allocatable:: iDmp(:,:)
Integer, Allocatable:: iDmp(:)
Real*8, Allocatable:: rDmp(:,:)
Logical Found
Integer Len, i, nCnttp
Integer Len, i, j, nCnttp, nAtoms
!
Call qpg_iArray('iDmp',Found,Len)
nCnttp=Len/2
Call mma_Allocate(iDmp,2,nCnttp,Label='iDmp')
If (Found) Call Get_iArray('iDmp',iDmp,2*nCnttp)
nCnttp=Len
Call mma_Allocate(iDmp,nCnttp,Label='iDmp')
If (Found) Call Get_iArray('iDmp',iDmp,nCnttp)
Do i = 1, nCnttp
dbsc(i)%ipCntr = iDmp(1,i)
dbsc(i)%nCntr = iDmp(2,i)
dbsc(i)%nCntr = iDmp(i)
End Do
Call mma_deallocate(iDmp)
!
Call qpg_dArray('rDmp',Found,Len)
If (.Not.Found) Then
Write (6,*) 'rDMP not found on the run file.'
Call Abend()
End If
nAtoms=Len/3
Call mma_allocate(rDmp,3,nAtoms,Label='rDmp')
Call Get_dArray('rDmp',rDmp,3*nAtoms)
nAtoms = 0
Do i = 1, nCnttp
If (.Not.Allocated(dbsc(i)%Coor)) Then
Call mma_Allocate(dbsc(i)%Coor,3,dbsc(i)%nCntr,Label='dbsc:C')
End If
Do j = 1, dbsc(i)%nCntr
nAtoms=nAtoms+1
dbsc(i)%Coor(1:3,j)=rDmp(1:3,nAtoms)
End Do
End Do
Call mma_deallocate(rDmp)
#ifdef _DEBUG_
Write (6,*) 'Basis_Info_Get'
Do i = 1, nCnttp
Write (6,*) dbsc(i)%ipCntr, dbsc(i)%nCntr
Do j = 1, dbsc(i)%nCntr
Write (6,*) (dbsc(i)%Coor(k,j),k=1,3)
End Do
End Do
#endif
Return
End Subroutine Basis_Info_Get
!
!***********************************************************************
!
Subroutine Basis_Info_Free()
Integer i
!
! Deallocate all allocatable parts of dbsc.
!
i = 0
Do
i=i+1
If (i.gt.Mxdbsc .or. dbsc(i)%nCntr.eq.0) Exit
!
Call mma_deallocate(dbsc(i)%Coor)
dbsc(i)%nCntr=-1
End Do
!
Return
End Subroutine Basis_Info_Free
!
!***********************************************************************
!
End Module Basis_Info
......@@ -11,7 +11,12 @@
* 1990, IBM *
************************************************************************
Module Real_Spherical
Private
#include "stdalloc.fh"
Public :: ipSph, RSph, Sphere, Sphere_Free,
& Condon_Shortley_phase_factor
Integer, Dimension(:), Allocatable :: ipSph
Integer :: lmax_internal=-1
Real*8, Dimension(:), Allocatable :: RSph
Logical :: Condon_Shortley_phase_factor=.False.
*
......@@ -20,6 +25,14 @@
Contains
*
***********************************************************************
*
SubRoutine Sphere_Free()
If (Allocated(RSph)) Call mma_deallocate(RSph)
If (Allocated(ipSph)) Call mma_deallocate(ipSph)
lmax_internal=-1
End SubRoutine Sphere_Free
*
***********************************************************************
*
SubRoutine Sphere(lMax)
************************************************************************
......@@ -60,7 +73,16 @@
Call Abend()
End If
*
If (Allocated(RSph)) Return
If (lmax.lt.0) Then
Write (6,*) 'Sphere: lmax<0'
Call Abend()
End If
If (lmax.gt.lmax_internal) Then
Call Sphere_Free()
lmax_internal=lMax
Else
Return
End If
*
* Make the labels
* Gives info on basis function angular momenta
......
......@@ -73,12 +73,9 @@
ZA = Charge(iCnttp)
End If
If (ZA.eq.Zero) Go To 101
ixyz = dbsc(iCnttp)%ipCntr
*--------Loop over all unique centers of this group
Do iCnt = 1, dbsc(iCnttp)%nCntr
A(1) = Work(ixyz+(iCnt-1)*3)
A(2) = Work(ixyz+(iCnt-1)*3+1)
A(3) = Work(ixyz+(iCnt-1)*3+2)
A(1:3)=dbsc(iCnttp)%Coor(1:3,iCnt)
*
ndc = 0
Do jCnttp = 1, iCnttp
......@@ -91,13 +88,10 @@
If (pChrg(iCnttp).and.pChrg(jCnttp)) Go To 201
If (FragCnttp(iCnttp).and.FragCnttp(jCnttp)) Go To 201
ZAZB = ZA * ZB
jxyz = dbsc(jCnttp)%ipCntr
jCntMx = dbsc(jCnttp)%nCntr
If (iCnttp.eq.jCnttp) jCntMx = iCnt
Do jCnt = 1, jCntMx
B(1) = Work(jxyz+(jCnt-1)*3 )
B(2) = Work(jxyz+(jCnt-1)*3+1)
B(3) = Work(jxyz+(jCnt-1)*3+2)
B(1:3)=dbsc(jCnttp)%Coor(1:3,jCnt)
*
Fact = One
* Factor due to resticted summation
......@@ -285,11 +279,8 @@
If (pChrg(jCnttp)) Go To 202
If (FragCnttp(jCnttp)) Go To 202
ZAZB = ZA * ZB
jxyz = dbsc(jCnttp)%ipCntr
Do jCnt = 1, dbsc(jCnttp)%nCntr
B(1) = Work(jxyz+(jCnt-1)*3 )
B(2) = Work(jxyz+(jCnt-1)*3+1)
B(3) = Work(jxyz+(jCnt-1)*3+2)
B(1:3)=dbsc(jCnttp)%Coor(1:3,jCnt)
*
* Find the DCR for the two centers
*
......@@ -418,17 +409,15 @@
If (Charge(iCnttp).eq.Zero) Go To 103
If (FragCnttp(iCnttp)) Go To 103
ZA = Charge(iCnttp)
ixyz = dbsc(iCnttp)%ipCntr
If (iPrint.ge.99) Then
Write (6,*) ' Charge=',ZA
Write (6,*) ' ixyz=',ixyz
Call RecPrt(' Centers',' ',Work(ixyz),3,
& dbsc(iCnttp)%nCntr)
Call RecPrt(' Centers',' ',
& dbsc(iCnttp)%Coor(1,1),3,
& dbsc(iCnttp)%nCntr)
End If
Do iCnt = 1, dbsc(iCnttp)%nCntr
A(1) = Work(ixyz+(iCnt-1)*3)
A(2) = Work(ixyz+(iCnt-1)*3+1)
A(3) = Work(ixyz+(iCnt-1)*3+2)
A(1:3)=dbsc(iCnttp)%Coor(1:3,iCnt)
If (ix.eq.0) Then
CCoMx =One
......@@ -536,11 +525,8 @@
If (pChrg(jCnttp)) Go To 212
If (FragCnttp(jCnttp)) Go To 212
ZAZB = ZA * ZB
jxyz = dbsc(jCnttp)%ipCntr
Do jCnt = 1, dbsc(jCnttp)%nCntr
B(1) = Work(jxyz+(jCnt-1)*3 )
B(2) = Work(jxyz+(jCnt-1)*3+1)
B(3) = Work(jxyz+(jCnt-1)*3+2)
B(1:3)=dbsc(jCnttp)%Coor(1:3,jCnt)
*
* Find the DCR for the two centers
*
......
......@@ -93,12 +93,9 @@
Call Abend()
EndIf
If (ZA.eq.Zero) Go To 101
ixyz = dbsc(iCnttp)%ipCntr
*--------Loop over all unique centers of this group (A-subsystem)
Do iCnt = 1, dbsc(iCnttp)%nCntr
A(1) = Work(ixyz+(iCnt-1)*3)
A(2) = Work(ixyz+(iCnt-1)*3+1)
A(3) = Work(ixyz+(iCnt-1)*3+2)
A(1:3)=dbsc(iCnttp)%Coor(1:3,iCnt)
*
ndc = 0
Do jCnttp = iCnttp_B, nCnttp_B ! (B-subsystem)
......@@ -107,12 +104,9 @@
If (ZB.eq.Zero) Go To 201
ZAZB = ZA * ZB
jxyz = dbsc(jCnttp)%ipCntr
jCntMx = dbsc(jCnttp)%nCntr
Do jCnt = 1, jCntMx
B(1) = Work(jxyz+(jCnt-1)*3 )
B(2) = Work(jxyz+(jCnt-1)*3+1)
B(3) = Work(jxyz+(jCnt-1)*3+2)
B(1:3)=dbsc(jCnttp)%Coor(1:3,jCnt)
*
Fact = One
* Factor due to resticted summation
......
......@@ -60,7 +60,6 @@
COMMON / OFembed_R2/ dFMD
Character*16 OFE_KSDFT
COMMON / OFembed_C / OFE_KSDFT
*
*
iRout = 99
iPrint = nPrint(iRout)
......@@ -688,15 +687,18 @@ c nprint(26)=99
mdc = 0
iIrrep = 0
Do 2100 iCnttp = 1, nCnttp_Valence
jxyz = dbsc(iCnttp)%ipCntr
Do 2200 iCnt = 1, dbsc(iCnttp)%nCntr
mdc = mdc + 1
* Call RecPrt(' Coordinates',' ',Work(jxyz),1,3)
* Call RecPrt(' Coordinates',' ',
* & dbsc(iCnttp)%Coor(1,iCnt),1,3)
Fact = Zero
iComp = 0
If (Work(jxyz ).ne.Zero) iComp = iOr(iComp,1)
If (Work(jxyz+1).ne.Zero) iComp = iOr(iComp,2)
If (Work(jxyz+2).ne.Zero) iComp = iOr(iComp,4)
If (dbsc(iCnttp)%Coor(1,iCnt).ne.Zero)
& iComp = iOr(iComp,1)
If (dbsc(iCnttp)%Coor(2,iCnt).ne.Zero)
& iComp = iOr(iComp,2)
If (dbsc(iCnttp)%Coor(3,iCnt).ne.Zero)
& iComp = iOr(iComp,4)
Do jIrrep = 0, nIrrep-1
If ( TstFnc(iOper,nIrrep,iCoSet(0,0,mdc),
& nIrrep/nStab(mdc),iChTbl,jIrrep,
......@@ -713,13 +715,13 @@ c nprint(26)=99
Direct(lDsp)=.True.
*--------------------Transfer the coordinates
ip = 4*(ldsp-1) + ipC
call dcopy_(3,Work(jxyz),1,Work(ip),1)
call dcopy_(3,dbsc(iCnttp)%Coor(1,iCnt),1,
& Work(ip),1)
*--------------------Transfer the multiplicity factor
Work(ip+3) = Fact
iWork(ipCar-1+ldsp) = iCar + 1
End If
End Do
jxyz = jxyz + 3
2200 Continue
2100 Continue
If (iPrint.ge.99) Then
......
......@@ -9,11 +9,11 @@
* LICENSE or in <http://www.gnu.org/licenses/>. *
************************************************************************
Subroutine Int_Prep_g(iSD4,nSD,Coor,Shijij,iAOV,iStabs)
Use Basis_Info
Implicit Real*8 (a-h,o-z)
*
#include "itmax.fh"
#include "info.fh"
#include "WrkSpc.fh"
*
Integer iSD4(0:nSD,4)
*
......@@ -22,21 +22,27 @@
Logical Shijij
*
iCnttp=iSD4(13,1)
iCnt =iSD4(14,1)
jCnttp=iSD4(13,2)
jCnt =iSD4(14,2)
kCnttp=iSD4(13,3)
kCnt =iSD4(14,3)
lCnttp=iSD4(13,4)
lCnt =iSD4(14,4)
*
If (AuxCnttp(iCnttp)) Then
call dcopy_(3,Work(iSD4(8,2)),1,Coor(1,1),1)
Coor(1:3,1)=dbsc(jCnttp)%Coor(1:3,jCnt)
Else
call dcopy_(3,Work(iSD4(8,1)),1,Coor(1,1),1)
Coor(1:3,1)=dbsc(iCnttp)%Coor(1:3,iCnt)
End If
call dcopy_(3,Work(iSD4(8,2)),1,Coor(1,2),1)
Coor(1:3,2)=dbsc(jCnttp)%Coor(1:3,jCnt)
*
If (AuxCnttp(kCnttp)) Then
call dcopy_(3,Work(iSD4(8,4)),1,Coor(1,3),1)
Coor(1:3,3)=dbsc(lCnttp)%Coor(1:3,lCnt)
Else
call dcopy_(3,Work(iSD4(8,3)),1,Coor(1,3),1)
Coor(1:3,3)=dbsc(kCnttp)%Coor(1:3,kCnt)
End If
call dcopy_(3,Work(iSD4(8,4)),1,Coor(1,4),1)
Coor(1:3,4)=dbsc(lCnttp)%Coor(1:3,lCnt)
*
Shijij= iSD4(11,1).eq.iSD4(11,3).and.
& iSD4(11,2).eq.iSD4(11,4)
......
......@@ -166,8 +166,7 @@
If (.Not.ECP(kCnttp)) Go To 111
If (nM1(kCnttp).eq.0) Go To 111
Do 101 kCnt = 1, dbsc(kCnttp)%nCntr
kxyz = dbsc(kCnttp)%ipCntr + (kCnt-1)*3
call dcopy_(3,Work(kxyz),1,C,1)
C(1:3)=dbsc(kCnttp)%Coor(1:3,kCnt)
*
Call DCR(LmbdT,iOper,nIrrep,iStabM,nStabM,
& jStab(0,kdc+kCnt),nStab(kdc+kCnt),iDCRT,nDCRT)
......
......@@ -161,8 +161,7 @@
If (nM2(kCnttp).eq.0) Go To 111
*
Do 101 kCnt = 1, dbsc(kCnttp)%nCntr
kxyz = dbsc(kCnttp)%ipCntr + (kCnt-1)*3
call dcopy_(3,Work(kxyz),1,C,1)
C(1:3)=dbsc(kCnttp)%Coor(1:3,kCnt)
*
Call DCR(LmbdT,iOper,nIrrep,iStabM,nStabM,
& jStab(0,kdc+kCnt), nStab(kdc+kCnt),iDCRT,nDCRT)
......
......@@ -40,8 +40,7 @@
Do kCnttp = 1, nCnttp
If (Charge(kCnttp).eq.0.d0) Go To 411
Do kCnt = 1, dbsc(kCnttp)%nCntr
kxyz = dbsc(kCnttp)%ipCntr + (kCnt-1)*3
call dcopy_(3,Work(kxyz),1,C,1)
C(1:3)=dbsc(kCnttp)%Coor(1:3,kCnt)
ndc=kdc+kCnt
Fact=-Charge(kCnttp)*ff
nDisp = IndDsp(ndc,iIrrep)
......
......@@ -139,8 +139,7 @@ C If (iPrint.ge.99) Call RecPrt('DAO',' ',DAO,nZeta,nDAO)
Do kCnttp = 1, nCnttp
If (Charge(kCnttp).eq.Zero) Go To 111
Do kCnt = 1, dbsc(kCnttp)%nCntr
kxyz = dbsc(kCnttp)%ipCntr + (kCnt-1)*3
call dcopy_(3,Work(kxyz),1,C,1)
C(1:3)=dbsc(kCnttp)%Coor(1:3,kCnt)
*
Call DCR(LmbdT,iOper,nIrrep,iStabM,nStabM,
& jStab(0,kdc+kCnt),nStab(kdc+kCnt),iDCRT,nDCRT)
......
......@@ -55,6 +55,7 @@
************************************************************************
use Real_Spherical
use iSD_data
use Basis_Info, only: dbsc
Implicit Real*8 (A-H,O-Z)
External Kernel, KrnlMm
#include "angtp.fh"
......@@ -132,10 +133,11 @@ C Do iS = 1, nSkal
iPrim = iSD( 5,iS)
iExp = iSD( 6,iS)
iAO = iSD( 7,iS)
ixyz = iSD( 8,iS)
mdci = iSD(10,iS)
iShell = iSD(11,iS)
call dcopy_(3,Work(ixyz),1,A,1)
iCnttp = iSD(13,iS)
iCnt = iSD(14,iS)
A(1:3) = dbsc(iCnttp)%Coor(1:3,iCnt)
C Do jS = 1, iS
jShll = iSD( 0,jS)
......@@ -146,10 +148,11 @@ C Do jS = 1, iS
jPrim = iSD( 5,jS)
jExp = iSD( 6,jS)
jAO = iSD( 7,jS)
jxyz = iSD( 8,jS)
mdcj = iSD(10,jS)
jShell = iSD(11,jS)
call dcopy_(3,Work(jxyz),1,B,1)
jCnttp = iSD(13,jS)
jCnt = iSD(14,jS)
B(1:3) = dbsc(jCnttp)%Coor(1:3,iCnt)
*
iSmLbl = 1
nSO = MemSO1(iSmLbl,iCmp,jCmp,iShell,jShell)
......
......@@ -118,8 +118,7 @@
Do 1960 kCnttp = 1, nCnttp
If (.Not.ECP(kCnttp)) Go To 1961
Do 1965 kCnt = 1,dbsc(kCnttp)%nCntr
ixyz = dbsc(kCnttp)%ipCntr + (kCnt-1)*3
call dcopy_(3,Work(ixyz),1,C,1)
C(1:3)=dbsc(kCnttp)%Coor(1:3,kCnt)
If (iPrint.ge.49) Call RecPrt(' In PrjGrd: C',' ',C,1,3)
*
Call DCR(LmbdT,iOper,nIrrep,iStabM,nStabM,
......
......@@ -117,8 +117,7 @@
If (.Not.ECP(kCnttp)) Go To 1961
If (nSRO_Shells(kCnttp).le.0) Go To 1961
Do 1965 kCnt = 1,dbsc(kCnttp)%nCntr
ixyz = dbsc(kCnttp)%ipCntr + (kCnt-1)*3
call dcopy_(3,Work(ixyz),1,C,1)
C(1:3)=dbsc(kCnttp)%Coor(1:3,kCnt)
*
Call DCR(LmbdT,iOper,nIrrep,iStabM,nStabM,
& jStab(0,kdc+kCnt),nStab(kdc+kCnt),iDCRT,nDCRT)
......
......@@ -95,13 +95,16 @@
Do iSkal=1,nSkal
If (iSD(10,iSkal).eq.iCenter) Then
iCnttp=iSD(13,iSkal)
call dcopy_(3,DInf(iSD(8,iSkal)),1,Coor,1)
iCnt =iSD(14,iSkal)
Coor(1:3)=dbsc(iCnttp)%Coor(1:3,iCnt)
End If
End Do
Do iSkal=1,nSkal
If (iSD(13,iSkal).ne.iCnttp .and.
& iSD(10,iSkal).ne.iCenter) Then
If (EQ(Coor,DInf( iSD(8,iSkal) ))) Then
jCnttp=iSD(13,iSkal)
jCnt =iSD(14,iSkal)
If ( EQ(Coor, dbsc(jCnttp)%Coor(1,iCnt)) ) Then
Write (6,*) 'Multiple instances of the same center!'
Write (6,*) 'This is not allowed with AMFI.'
Call Quit_OnUserError()
......
......@@ -43,6 +43,7 @@
************************************************************************
use Real_Spherical
use iSD_data
use Basis_Info, only: dbsc
Implicit Real*8 (A-H,O-Z)
#include "angtp.fh"
#include "info.fh"
......@@ -107,10 +108,11 @@
iPrim = iSD( 5,iS)
iExp = iSD( 6,iS)
iAO = iSD( 7,iS)
ixyz = iSD( 8,iS)
mdci = iSD(10,iS)
iShell = iSD(11,iS)
call dcopy_(3,Work(ixyz),1,A,1)
iCnttp = iSD(13,iS)
iCnt = iSD(14,iS)
A(1:3)=dbsc(iCnttp)%Coor(1:3,iCnt)
Do jS = 1, iS
jShll = iSD( 0,jS)
jAng = iSD( 1,jS)
......@@ -120,10 +122,11 @@
jPrim = iSD( 5,jS)
jExp = iSD( 6,jS)
jAO = iSD( 7,jS)
jxyz = iSD( 8,jS)
mdcj = iSD(10,jS)
jShell = iSD(11,jS)
call dcopy_(3,Work(jxyz),1,B,1)
jCnttp = iSD(13,jS)
jCnt = iSD(14,jS)
B(1:3)=dbsc(jCnttp)%Coor(1:3,jCnt)
*
iSmLbl = 1
nSO = MemSO1(iSmLbl,iCmp,jCmp,iShell,jShell)
......
......@@ -61,12 +61,11 @@ c
Do jCnttp = 1, nCnttp
mCnt = dbsc(jCnttp)%nCntr
If (AuxCnttp(jCnttp)) mCnt = 0
jxyz = dbsc(jCnttp)%ipCntr
Do jCnt = 1, mCnt
ndc = ndc + 1
x1 = Work(jxyz)
y1 = Work(jxyz+1)
z1 = Work(jxyz+2)
x1 = dbsc(jCnttp)%Coor(1,jCnt)
y1 = dbsc(jCnttp)%Coor(2,jCnt)
z1 = dbsc(jCnttp)%Coor(3,jCnt)
Do i = 0, nIrrep/nStab(ndc) - 1
iFacx=iPhase(1,iCoset(i,0,ndc))
iFacy=iPhase(2,iCoset(i,0,ndc))
......
......@@ -143,11 +143,8 @@ c Call Seward_Init()
If (ZB.eq.Zero) Go To 202
If (FragCnttp(jCnttp)) Go To 202
ZAZB = ZA * ZB
jxyz = dbsc(jCnttp)%ipCntr
Do jCnt = 1, dbsc(jCnttp)%nCntr
B(1) = Work(jxyz )
B(2) = Work(jxyz+1)
B(3) = Work(jxyz+2)
B(1:3)=dbsc(jCnttp)%Coor(1:3,jCnt)
*
* Find the DCR for the two centers
*
......@@ -206,7 +203,6 @@ c Call Seward_Init()
PNX = PNX + ( ( ZAZB*temp0 + ZB*(temp1+temp2))
& * DBLE(nIrrep) ) / DBLE(LmbdR)
*
jxyz = jxyz + 3
End Do
202 Continue
ndc = ndc + dbsc(jCnttp)%nCntr
......
......@@ -27,6 +27,7 @@
Implicit None
#include "itmax.fh"
#include "info.fh"
#include "stdalloc.fh"
#include "real.fh"
#include "print.fh"
integer nDInf, nInfo, storageSize, LineWords
......@@ -53,8 +54,7 @@
External NucExp, rMass, iMostAbundantIsotope, iCLast
Data DefNm/'basis_library'/
* Call qEnter('FragExpand')
* Call qEnter('FragExpand')
UnNorm