Skip to content

Commit

Permalink
Merge pull request #1046 from lachlanbelcher/nwc_sym
Browse files Browse the repository at this point in the history 
@lachlanbelcher thanks for the contribution
  • Loading branch information
@nwchemgit
nwchemgit authored Nov 20, 2024
2 parents 24e60be + b5d8d4e commit 6d839a7
Show file tree
Hide file tree
Showing 3 changed files with 75 additions and 63 deletions.
47 changes: 27 additions & 20 deletions src/nwc_columbus/aoints/int_1e_sifs.F
View file
Original file line number Diff line number Diff line change
Expand Up @@ -382,35 +382,40 @@ subroutine int_1e_sifs(ibas, aoints, energy, nenrgy, nbft,
& thresh, int_mb(k_ilab),int_mb(k_jlab), max1e,
& dbl_mb(k_buf), mem1, dbl_mb(k_scr), numints)
end if
WRITE(*,*)"LB, numints=",numints
c
do i=1,numints

if(ibuf.eq.n1max) then
if(ibuf.eq.n1max) then !dump full record to file
numtot = numtot + ibuf
C LB
WRITE(*,*)"C LB, calling sym_1int 1"
CALL sym_1int(ibuf,nsoints,
& dbl_mb(k_sifval), clab,
& dbl_mb(k_SOval), cSOlab)
WRITE(*,'(a,1i4)')"C LB, nsoints =",nsoints
WRITE(*,*)"C LB, cSOlab ="
WRITE(*,'(2i4)') cSOlab(1:2,1:nsoints)
! WRITE(*,*)"C LB, calling sym_1int 1"
! CALL sym_1int(ibuf,nsoints,
! & dbl_mb(k_sifval), clab,
! & dbl_mb(k_SOval), cSOlab)
! WRITE(*,'(a,1i4)')"C LB, nsoints =",nsoints
! WRITE(*,*)"C LB, cSOlab ="
! WRITE(*,'(2i4)') cSOlab(1:2,1:nsoints)
C LB
WRITE(*,*)"C LB, calling sifew1"
call sifew1(aoints, info, 2, nsoints, last,
! call sifew1(aoints, info, 2, nsoints, last,
call sifew1(aoints, info, 2, ibuf, last,
& itypea, itypeb, ibvtyp,
& dbl_mb(k_SOval), cSOlab, fcore, ibitv,
! & dbl_mb(k_SOval), cSOlab, fcore, ibitv,
& dbl_mb(k_sifval), clab, fcore, ibitv,
& dbl_mb(k_sifbuf), nrec, ierr)
c ibuf on return has the number of unwritten
c integrals. dbl_mb(k_sifval+0:(ibuf-1))
c contains the unwritten values, ditto for labels
numtot = numtot - ibuf
endif

ibuf=ibuf+1
clab(1,ibuf)=int_mb(k_ilab+i-1)
clab(2,ibuf)=int_mb(k_jlab+i-1)
dbl_mb(k_sifval+ibuf-1)=dbl_mb(k_buf+i-1)
IF ( ABS(dbl_mb(k_buf+i-1)) .gt. thresh) THEN
ibuf=ibuf+1
clab(1,ibuf)=int_mb(k_ilab+i-1)
clab(2,ibuf)=int_mb(k_jlab+i-1)
dbl_mb(k_sifval+ibuf-1)=dbl_mb(k_buf+i-1)
ENDIF

enddo ! i

Expand All @@ -420,14 +425,16 @@ subroutine int_1e_sifs(ibas, aoints, energy, nenrgy, nbft,
end do !j_shell
last=nmsame
numtot=numtot+ibuf
WRITE(*,*)"C LB, calling sym_1int 2"
CALL sym_1int(ibuf,nsoints,
& dbl_mb(k_sifval), clab,
& dbl_mb(k_SOval), cSOlab)
! WRITE(*,*)"C LB, calling sym_1int 2, ibuf=",ibuf
! CALL sym_1int(ibuf,nsoints,
! & dbl_mb(k_sifval), clab,
! & dbl_mb(k_SOval), cSOlab)
WRITE(*,*)"C LB, calling sifew1"
call sifew1(aoints, info, 2, nsoints, last,
! call sifew1(aoints, info, 2, nsoints, last,
call sifew1(aoints, info, 2, ibuf, last,
& itypea, itypeb, ibvtyp,
& dbl_mb(k_SOval), cSOlab, fcore, ibitv,
! & dbl_mb(k_SOval), cSOlab, fcore, ibitv,
& dbl_mb(k_sifval), clab, fcore, ibitv,
& dbl_mb(k_sifbuf), nrec, ierr)

write(6,'(a,i10,1x,a,a)') 'Wrote ',numtot, integ_type,
Expand Down
79 changes: 41 additions & 38 deletions src/nwc_columbus/aoints/int_mom_sifs.F
View file
Original file line number Diff line number Diff line change
Expand Up @@ -204,12 +204,12 @@ subroutine int_mom_sifs(ibas, oskel, aoints, nbft,
c int_type = 2, angular momentum
c int_type = 3, dipole moments
do int_type=1,3
WRITE(*,*)"LB, starting int_type loop",int_type
! WRITE(*,*)"LB, starting int_type loop",int_type

if(int_type.eq.1.or.int_type.eq.2) itypea=2 ! gonna do dipole
if(int_type.eq.3) itypea=1

WRITE(*,*)" LB, starting int_type loop, itypea=",itypea
! WRITE(*,*)" LB, starting int_type loop, itypea=",itypea

if (0 .eq. ga_nodeid()) then
cgk debug
Expand Down Expand Up @@ -257,23 +257,26 @@ subroutine int_mom_sifs(ibas, oskel, aoints, nbft,
C LB
C LB Dipoles
elseif(int_type.eq.3) then
!write(*,*)'LB: calling int_mpolel'
lval=1;! 1 for dipoles
! get geom
IF (.NOT. bas_geom(ibas,geom)) CALL errquit
$ ('int_mom_sifs: bas_geom failed for ibas', ibas,
& BASIS_ERR)
IF (.NOT. geom_center_of_mass(geom, centerl)) CALL
& errquit ('int_mom_sifs: geom_center_of_mass failed'
& ,geom,GEOM_ERR)
WRITE(*,*)"LB, calling int_mpolel"
! get centerl
! IF (.NOT. geom_center_of_mass(geom, centerl)) CALL
! & errquit ('int_mom_sifs: geom_center_of_mass failed'
! & ,geom,GEOM_ERR)
centerl=0
! WRITE(*,*)"LB, calling int_mpolel"
WRITE(*,*)"LB, centerl=",centerl
CALL int_mpolel (ibas, ishell, ibas, jshell,
$ lval, centerl,
$ mem1mom, dbl_mb(k_scr), max1mom, dbl_mb(k_buf),
$ Num_MPint)
WRITE(*,'(a,2i5)')"LB, ishell, jshell =", ishell, jshell
WRITE(*,'(a,1i5)')"LB, Num_MPint =", Num_MPint
WRITE(*,*)"poles="
WRITE(*,*)dbl_mb(k_buf:k_buf+Num_MPint-1)
! WRITE(*,'(a,2i5)')"LB, ishell, jshell =", ishell, jshell
! WRITE(*,'(a,1i5)')"LB, Num_MPint =", Num_MPint
! WRITE(*,*)"poles="
! WRITE(*,*)dbl_mb(k_buf:k_buf+Num_MPint-1)
C LB
endif

Expand All @@ -287,8 +290,8 @@ subroutine int_mom_sifs(ibas, oskel, aoints, nbft,
noffsetx = 2
ENDIF

WRITE(*,'(a,3i4)')"LB, noffsetz,noffsety,noffsetx=",noffsetz,
& noffsety,noffsetx
! WRITE(*,'(a,3i4)')"LB, noffsetz,noffsety,noffsetx=",noffsetz,
! & noffsety,noffsetx
do j=jlo,jhi
do i=ilo,ihi
cgk debug
Expand All @@ -298,14 +301,13 @@ subroutine int_mom_sifs(ibas, oskel, aoints, nbft,
cgk end
ijmap=(j-jlo)*(ihi-ilo+1)+(i-ilo)
IF (int_type .eq. 3) THEN! dipoles
!ijmap=ijmap*(ihi-ilo+1)
ijmap=(i-ilo)*(jhi-jlo+1)+(j-jlo)
ijmap=ijmap*3
ENDIF
if(i.ge.j) then
symmap=nbft*(j-1)-((j-1)*j)/2+i
WRITE(*,'(a,2i4)')"LB, ijmap, symmap=",ijmap,symmap
* write(*,*)'gk: symmap=',symmap
! WRITE(*,'(a,2i4)')"LB, ijmap, symmap=",ijmap,symmap
! write(*,*)'gk: symmap=',symmap
dbl_mb(k_momx+symmap-1)=
& dbl_mb(k_buf+noffsetx+ijmap)
dbl_mb(k_momy+symmap-1)=
Expand All @@ -315,15 +317,15 @@ subroutine int_mom_sifs(ibas, oskel, aoints, nbft,
int_mb(k_imom+symmap-1)=i
int_mb(k_jmom+symmap-1)=j
cgk debug
write(*,'(a,3i3,f18.12)')
& 'gk: i,j,ij,dbl_mb(mom_x):',
& i,j,numints+ijmap,dbl_mb(k_momx+symmap-1)
write(*,'(a,3i3,f18.12)')
& 'gk: i,j,ij,dbl_mb(mom_y):',
& i,j,numints+ijmap,dbl_mb(k_momy+symmap-1)
write(*,'(a,3i3,f18.12)')
& 'gk: i,j,ij,dbl_mb(mom_z):',
& i,j,numints+ijmap,dbl_mb(k_momz+symmap-1)
! write(*,'(a,3i3,f18.12)')
! & 'gk: i,j,ij,dbl_mb(mom_x):',
! & i,j,numints+ijmap,dbl_mb(k_momx+symmap-1)
! write(*,'(a,3i3,f18.12)')
! & 'gk: i,j,ij,dbl_mb(mom_y):',
! & i,j,numints+ijmap,dbl_mb(k_momy+symmap-1)
! write(*,'(a,3i3,f18.12)')
! & 'gk: i,j,ij,dbl_mb(mom_z):',
! & i,j,numints+ijmap,dbl_mb(k_momz+symmap-1)
cgk end
endif
enddo ! ilo
Expand Down Expand Up @@ -394,8 +396,8 @@ subroutine int_mom_sifs(ibas, oskel, aoints, nbft,
numtot = numtot + ibuf
C LB
!WRITE(*,*)"LB: in int_mom_sifs"
WRITE(*,*)"LB: in int_mom_sifs, ibuf=",ibuf
WRITE(*,*)"LB: itypea,itypeb=",itypea,itypeb
! WRITE(*,*)"LB: in int_mom_sifs, ibuf=",ibuf
! WRITE(*,*)"LB: itypea,itypeb=",itypea,itypeb
!WRITE(*,*)"LB: calling sifew1 1 last=",last,"ibvtyp=",ibvtyp
C LB
call sifew1(aoints, info, 2, ibuf, msame,
Expand All @@ -407,6 +409,7 @@ subroutine int_mom_sifs(ibas, oskel, aoints, nbft,

momval=dbl_mb(kcart+symmap)

! WRITE(*,*)"LB, momval =",momval
if(abs(momval).gt.thresh) then
ibuf=ibuf+1
clab(1,ibuf)=int_mb(k_imom+symmap)
Expand All @@ -416,7 +419,6 @@ subroutine int_mom_sifs(ibas, oskel, aoints, nbft,
symmap=symmap+1
enddo
enddo
!if (icart.eq.3.and.int_type.eq.2) then
if (icart.eq.3.and.int_type.eq.3) then
last=nomore
else
Expand All @@ -429,18 +431,19 @@ subroutine int_mom_sifs(ibas, oskel, aoints, nbft,
* write(*,*)'gk: numtot=', numtot
cgk end
C LB
!WRITE(*,*)"LB: in int_mom_sifs"
WRITE(*,*)"LB: in int_mom_sifs, ibuf=",ibuf
WRITE(*,*)"LB: itypea,itypeb=",itypea,itypeb
WRITE(*,*)"C LB, calling sym_1int 2"
CALL sym_1int(ibuf,nsoints,
& sifval, clab,
& SOval, cSOlab)
!WRITE(*,*)"LB: calling sifew1 2 last=",last,"ibvtyp=",ibvtyp
! WRITE(*,*)"LB: in int_mom_sifs, ibuf=",ibuf
! WRITE(*,*)"LB: itypea,itypeb=",itypea,itypeb
! WRITE(*,*)"C LB, calling sym_1int 2"
! CALL sym_1int(ibuf,nsoints,
! & sifval, clab,
! & SOval, cSOlab)
! WRITE(*,*)"LB: calling sifew1 2 last=",last,"ibvtyp=",ibvtyp
C LB
call sifew1(aoints, info, 2, nsoints, last,
! call sifew1(aoints, info, 2, nsoints, last,
call sifew1(aoints, info, 2, ibuf, last,
& itypea, itypeb, ibvtyp,
& SOval, cSOlab, fcore, ibitv,
! & SOval, cSOlab, fcore, ibitv,
& sifval, clab, fcore, ibitv,
& sifbuf, nrec, ierr)
write(6,'(a,i10,1x,a,a)') 'Wrote ',numtot, integ_type,
& ' integrals to aoints'
Expand Down
12 changes: 7 additions & 5 deletions src/nwc_columbus/aoints/int_so_sifs.F
View file
Original file line number Diff line number Diff line change
Expand Up @@ -318,18 +318,20 @@ subroutine int_so_sifs(ibas, oskel, aoints, nbft, max1e, mem1,
numtot=numtot+ibuf
cgk debug
WRITE(*,*)"C LB, calling sym_1int 2"
CALL sym_1int(ibuf,nsoints,
& sifval, clab,
& SymOrbval, cSOlab)
! CALL sym_1int(ibuf,nsoints,
! & sifval, clab,
! & SymOrbval, cSOlab)
* WRITE(*,*)"int_so_sifs calling sifew1 2"
* write(*,*)'gk: nrec=', nrec
* write(*,*)'gk: ibuf=', ibuf
* write(*,*)'gk: numtot=', numtot
* WRITE(*,*)"last=",last,"ibvtyp=",ibvtyp
cgk end
call sifew1(aoints, info, 2, nsoints, last,
! call sifew1(aoints, info, 2, nsoints, last,
call sifew1(aoints, info, 2, ibuf, last,
& itypea, itypeb, ibvtyp,
& SymOrbval, cSOlab, fcore, ibitv,
! & SymOrbval, cSOlab, fcore, ibitv,
& sifval, clab, fcore, ibitv,
& sifbuf, nrec, ierr)
write(6,'(a,i10,1x,a,a)') 'Wrote ',numtot, integ_type,
& ' integrals to aoints'
Expand Down

0 comments on commit 6d839a7

Please sign in to comment.