From 347f7162943a5479ec297417b51d905ad62c0c2e Mon Sep 17 00:00:00 2001 From: v1j4y Date: Thu, 3 Nov 2022 15:29:57 +0100 Subject: [PATCH 01/21] Working on fixing n_int. --- src/csf/configuration_CI_sigma_helpers.irp.f | 398 ++++++++++++--- src/csf/configurations.irp.f | 5 + src/csf/obtain_I_foralpha.irp.f | 507 ++++++++++++++++--- src/csf/sigma_vector.irp.f | 115 +++-- src/determinants/slater_rules.irp.f | 94 +++- 5 files changed, 917 insertions(+), 202 deletions(-) diff --git a/src/csf/configuration_CI_sigma_helpers.irp.f b/src/csf/configuration_CI_sigma_helpers.irp.f index cea7640c..167b41fc 100644 --- a/src/csf/configuration_CI_sigma_helpers.irp.f +++ b/src/csf/configuration_CI_sigma_helpers.irp.f @@ -12,6 +12,7 @@ use bitmasks integer :: idxI ! The id of the Ith CFG integer(bit_kind) :: Icfg(N_int,2) + integer(bit_kind) :: Jcfg(N_int,2) integer :: NalphaIcfg logical,dimension(:,:),allocatable :: tableUniqueAlphas integer :: listholes(mo_num) @@ -20,10 +21,10 @@ use bitmasks integer :: nvmos integer :: listvmos(mo_num) integer :: vmotype(mo_num) ! 1 -> VMO 2 -> SOMO - integer*8 :: Idomo - integer*8 :: Isomo - integer*8 :: Jdomo - integer*8 :: Jsomo + integer*8 :: Idomo, Idomop, Idomoq + integer*8 :: Isomo, Isomop, Isomoq + integer*8 :: Jdomo, Jdomop, Jdomoq + integer*8 :: Jsomo, Jsomop, Jsomoq integer*8 :: diffSOMO integer*8 :: diffDOMO integer*8 :: xordiffSOMODOMO @@ -31,20 +32,21 @@ use bitmasks integer :: ndiffDOMO integer :: nxordiffSOMODOMO integer :: ndiffAll - integer :: i,ii - integer :: j,jj + integer :: i,ii,iii + integer :: j,jj, i_s, i_d integer :: k,kk integer :: kstart integer :: kend - integer :: Nsomo_I - integer :: hole - integer :: p - integer :: q + integer :: Nsomo_I, Nsomo_J + integer :: hole, n_core_orb_64 + integer :: p, pp, p_s + integer :: q, qq, q_s integer :: countalphas logical :: pqAlreadyGenQ logical :: pqExistsQ logical :: ppExistsQ integer*8 :: MS + integer :: listall(N_int*bit_kind_size), nelall double precision :: t0, t1 call wall_time(t0) @@ -57,6 +59,9 @@ use bitmasks do idxI = 1, N_configuration Icfg = psi_configuration(:,:,idxI) + Jcfg = psi_configuration(:,:,idxI) + !print *," Jcfg somo=",Jcfg(1,1), " ", Jcfg(2,1) + !print *," Jcfg domo=",Jcfg(1,2), " ", Jcfg(2,2) Isomo = iand(act_bitmask(1,1),Icfg(1,1)) Idomo = iand(act_bitmask(1,1),Icfg(1,2)) @@ -64,38 +69,89 @@ use bitmasks ! find out all pq holes possible nholes = 0 ! holes in SOMO - do ii = 1,n_act_orb - i = list_act(ii) - if(POPCNT(IAND(Isomo,IBSET(0_8,i-1))) .EQ. 1) then - nholes += 1 - listholes(nholes) = i - holetype(nholes) = 1 - endif - end do + !do ii = 1,n_act_orb + ! i = list_act(ii) + ! if(POPCNT(IAND(Isomo,IBSET(0_8,i-1))) .EQ. 1) then + ! nholes += 1 + ! listholes(nholes) = i + ! holetype(nholes) = 1 + ! endif + !end do + call bitstring_to_list(psi_configuration(1,1,idxI),listall,nelall,N_int) + + !print *,'list somo' + do iii=1,nelall + nholes += 1 + listholes(nholes) = listall(iii) + !print *,listall(iii) + holetype(nholes) = 1 + end do + + Nsomo_I = nelall + ! holes in DOMO - do ii = 1,n_act_orb - i = list_act(ii) - if(POPCNT(IAND(Idomo,IBSET(0_8,i-1))) .EQ. 1) then - nholes += 1 - listholes(nholes) = i - holetype(nholes) = 2 - endif - end do + !do ii = 1,n_act_orb + ! i = list_act(ii) + ! if(POPCNT(IAND(Idomo,IBSET(0_8,i-1))) .EQ. 1) then + ! nholes += 1 + ! listholes(nholes) = i + ! holetype(nholes) = 2 + ! endif + !end do + + !do iii=1,N_int + ! print *,' iii=',iii, psi_configuration(iii,2,idxI), ' idxI=',idxI + !end do + call bitstring_to_list(psi_configuration(1,2,idxI),listall,nelall,N_int) + + !print *,'list domo ncore=',n_core_orb, ' nelall=',nelall + do iii=1,nelall + if(listall(iii) .gt. n_core_orb)then + nholes += 1 + listholes(nholes) = listall(iii) + !print *,listall(iii) + holetype(nholes) = 2 + endif + end do ! find vmos listvmos = -1 vmotype = -1 nvmos = 0 - do ii = 1,n_act_orb - i = list_act(ii) + !do ii = 1,n_act_orb + ! i = list_act(ii) + ! if(IAND(Idomo,(IBSET(0_8,i-1))) .EQ. 0) then + ! if(IAND(Isomo,(IBSET(0_8,i-1))) .EQ. 0) then + ! nvmos += 1 + ! listvmos(nvmos) = i + ! print *,'1 i=',i + ! vmotype(nvmos) = 1 + ! else if(POPCNT(IAND(Isomo,(IBSET(0_8,i-1)))) .EQ. 1) then + ! nvmos += 1 + ! listvmos(nvmos) = i + ! print *,'2 i=',i + ! vmotype(nvmos) = 2 + ! end if + ! end if + !end do + !print *,'-----------' + + ! Take into account N_int + do ii = 1, n_act_orb + iii = list_act(ii) + i_s = (1+((iii-1)/63)) + i = iii - ( i_s -1 )*63 + Isomo = iand(act_bitmask(i_s,1),Icfg(i_s,1)) + Idomo = iand(act_bitmask(i_s,1),Icfg(i_s,2)) + if(IAND(Idomo,(IBSET(0_8,i-1))) .EQ. 0) then if(IAND(Isomo,(IBSET(0_8,i-1))) .EQ. 0) then nvmos += 1 - listvmos(nvmos) = i + listvmos(nvmos) = iii vmotype(nvmos) = 1 else if(POPCNT(IAND(Isomo,(IBSET(0_8,i-1)))) .EQ. 1) then nvmos += 1 - listvmos(nvmos) = i + listvmos(nvmos) = iii vmotype(nvmos) = 2 end if end if @@ -106,7 +162,7 @@ use bitmasks ! Now find the allowed (p,q) excitations Isomo = iand(act_bitmask(1,1),Icfg(1,1)) Idomo = iand(act_bitmask(1,1),Icfg(1,2)) - Nsomo_I = POPCNT(Isomo) + !Nsomo_I = POPCNT(Isomo) if(Nsomo_I .EQ. 0) then kstart = 1 else @@ -115,24 +171,54 @@ use bitmasks kend = idxI-1 do i = 1,nholes - p = listholes(i) + pp = listholes(i) + p_s = (1+((pp-1)/63)) + p = pp - (p_s - 1)*63 + !print *,' pp=',pp, ' p_s=',p_s, ' p=',p do j = 1,nvmos - q = listvmos(j) + qq = listvmos(j) + q_s = (1+((qq-1)/63)) + q = qq - (q_s - 1)*63 + !print *,' qq=',qq, ' q_s=',q_s, ' q=',q + Isomop = iand(act_bitmask(i_s,1),Icfg(p_s,1)) + Idomop = iand(act_bitmask(i_s,1),Icfg(p_s,2)) + Isomop = iand(act_bitmask(i_s,1),Icfg(q_s,1)) + Idomop = iand(act_bitmask(i_s,1),Icfg(q_s,2)) if(p .EQ. q) cycle if(holetype(i) .EQ. 1 .AND. vmotype(j) .EQ. 1) then ! SOMO -> VMO - Jsomo = IBCLR(Isomo,p-1) - Jsomo = IBSET(Jsomo,q-1) - Jdomo = Idomo + !print *,'SOMO -> VMO' + if (p_s .eq. q_s) then + Jsomop = IBCLR(Isomop,p-1) + Jsomop = IBSET(Jsomop,q-1) + Jsomoq = Jsomop + else + Jsomop = IBCLR(Isomop,p-1) + Jsomoq = IBSET(Isomoq,q-1) + endif + + ! Domo remains the same + Jdomop = Idomop + Jdomoq = Idomoq + kstart = max(1,cfg_seniority_index(max(NSOMOMin,Nsomo_I-2))) kend = idxI-1 else if(holetype(i) .EQ. 1 .AND. vmotype(j) .EQ. 2) then ! SOMO -> SOMO - Jsomo = IBCLR(Isomo,p-1) - Jsomo = IBCLR(Jsomo,q-1) - Jdomo = IBSET(Idomo,q-1) + !print *,'SOMO -> SOMO' + if(p_s .eq. q_s) then + Jsomop = IBCLR(Isomop,p-1) + Jsomop = IBCLR(Jsomop,q-1) + Jsomoq = Jsomop + else + Jsomop = IBCLR(Isomop,p-1) + Jsomoq = IBCLR(Isomoq,q-1) + endif + + Jdomoq = IBSET(Idomoq,q-1) + ! Check for Minimal alpha electrons (MS) - if(POPCNT(Jsomo).ge.MS)then + if(POPCNT(Jsomoq).ge.MS)then kstart = max(1,cfg_seniority_index(max(NSOMOMin,Nsomo_I-4))) kend = idxI-1 else @@ -140,24 +226,60 @@ use bitmasks endif else if(holetype(i) .EQ. 2 .AND. vmotype(j) .EQ. 1) then ! DOMO -> VMO - Jsomo = IBSET(Isomo,p-1) - Jsomo = IBSET(Jsomo,q-1) - Jdomo = IBCLR(Idomo,p-1) + !print *,'DOMO -> VMO', Isomop, p, q, Jsomop + if(p_s .eq. q_s) then + Jsomop = IBSET(Isomop,p-1) + Jsomop = IBSET(Jsomop,q-1) + Jsomoq = Jsomop + else + Jsomop = IBSET(Isomop,p-1) + Jsomoq = IBSET(Jsomoq,q-1) + endif + !print *, 'Jsomop=', Jsomop + + Jdomop = IBCLR(Idomop,p-1) + kstart = cfg_seniority_index(Nsomo_I) kend = idxI-1 else if(holetype(i) .EQ. 2 .AND. vmotype(j) .EQ. 2) then ! DOMO -> SOMO - Jsomo = IBSET(Isomo,p-1) - Jsomo = IBCLR(Jsomo,q-1) - Jdomo = IBCLR(Idomo,p-1) - Jdomo = IBSET(Jdomo,q-1) + !print *,'DOMO -> SOMO' + if(p_s .eq. q_s) then + Jsomop = IBSET(Isomop,p-1) + Jsomop = IBCLR(Jsomop,q-1) + Jsomoq = Jsomop + + Jdomop = IBCLR(Idomop,p-1) + Jdomop = IBSET(Jdomop,q-1) + Jdomoq = Jdomop + else + Jsomop = IBSET(Isomop,p-1) + Jsomoq = IBCLR(Jsomoq,q-1) + + Jdomop = IBCLR(Idomop,p-1) + Jdomoq = IBSET(Jdomoq,q-1) + endif + kstart = max(1,cfg_seniority_index(max(NSOMOMin,Nsomo_I-2))) kend = idxI-1 else print*,"Something went wrong in obtain_associated_alphaI" endif + + ! Save it to Jcfg + !print *,i,j,"0| nalpha=",NalphaIcfg, " somo=",Jcfg(1,1),Jcfg(2,1) + Jcfg(p_s,1) = Jsomop + Jcfg(q_s,1) = Jsomoq + Jcfg(p_s,2) = Jdomop + Jcfg(q_s,2) = Jdomoq + !print *,'p_s=',p_s,' q_s=', q_s + !print *,'Jsomop=',Jsomop, ' Jsomoq=', Jsomoq, ' Jdomop=', Jdomop, ' Jdomoq=', Jdomo + !print *,i,j,"1| nalpha=",NalphaIcfg, " somo=",Jcfg(1,1),Jcfg(2,1) + call bitstring_to_list(Jcfg(1,1),listall,nelall,N_int) + Nsomo_J = nelall + ! Check for Minimal alpha electrons (MS) - if(POPCNT(Jsomo).lt.MS)then + if(Nsomo_J.lt.MS)then cycle endif @@ -169,15 +291,32 @@ use bitmasks pqAlreadyGenQ = .FALSE. ! First check if it can be generated before do k = kstart, kend - diffSOMO = IEOR(Jsomo,iand(reunion_of_act_virt_bitmask(1,1),psi_configuration(1,1,k))) - ndiffSOMO = POPCNT(diffSOMO) - if((ndiffSOMO .NE. 0) .AND. (ndiffSOMO .NE. 2)) cycle - diffDOMO = IEOR(Jdomo,iand(reunion_of_act_virt_bitmask(1,1),psi_configuration(1,2,k))) - xordiffSOMODOMO = IEOR(diffSOMO,diffDOMO) - ndiffDOMO = POPCNT(diffDOMO) - nxordiffSOMODOMO = POPCNT(xordiffSOMODOMO) - nxordiffSOMODOMO += ndiffSOMO + ndiffDOMO - !if(POPCNT(IEOR(diffSOMO,diffDOMO)) .LE. 1 .AND. ndiffDOMO .LT. 3) then + !diffSOMO = IEOR(Jsomo,iand(reunion_of_act_virt_bitmask(1,1),psi_configuration(1,1,k))) + !ndiffSOMO = POPCNT(diffSOMO) + !if((ndiffSOMO .NE. 0) .AND. (ndiffSOMO .NE. 2)) cycle + !diffDOMO = IEOR(Jdomo,iand(reunion_of_act_virt_bitmask(1,1),psi_configuration(1,2,k))) + !xordiffSOMODOMO = IEOR(diffSOMO,diffDOMO) + !ndiffDOMO = POPCNT(diffDOMO) + !nxordiffSOMODOMO = POPCNT(xordiffSOMODOMO) + !nxordiffSOMODOMO += ndiffSOMO + ndiffDOMO + + ndiffSOMO = 0 + ndiffDOMO = 0 + nxordiffSOMODOMO = 0 + do ii = 1, N_int + Jsomo = Jcfg(ii,1) + Jdomo = Jcfg(ii,2) + diffSOMO = IEOR(Jsomo,iand(reunion_of_act_virt_bitmask(ii,1),psi_configuration(ii,1,k))) + ndiffSOMO += POPCNT(diffSOMO) + diffDOMO = IEOR(Jdomo,iand(reunion_of_act_virt_bitmask(ii,2),psi_configuration(ii,2,k))) + xordiffSOMODOMO = IEOR(diffSOMO,diffDOMO) + ndiffDOMO += POPCNT(diffDOMO) + nxordiffSOMODOMO += POPCNT(xordiffSOMODOMO) + nxordiffSOMODOMO += ndiffSOMO + ndiffDOMO + end do + + if((ndiffSOMO .ne. 0) .and. (ndiffSOMO .ne. 2)) cycle + if((ndiffSOMO+ndiffDOMO) .EQ. 0) then pqAlreadyGenQ = .TRUE. ppExistsQ = .TRUE. @@ -208,22 +347,57 @@ use bitmasks Jdomo = Icfg(1,2) NalphaIcfg = 0 do i = 1, nholes - p = listholes(i) + !p = listholes(i) + pp = listholes(i) + p_s = (1+((pp-1)/63)) + p = pp - (p_s - 1)*63 do j = 1, nvmos - q = listvmos(j) + !q = listvmos(j) + qq = listvmos(j) + q_s = (1+((qq-1)/63)) + q = qq - (q_s - 1)*63 + Isomop = iand(act_bitmask(i_s,1),Icfg(p_s,1)) + Idomop = iand(act_bitmask(i_s,1),Icfg(p_s,2)) + Isomoq = iand(act_bitmask(i_s,1),Icfg(q_s,1)) + Idomoq = iand(act_bitmask(i_s,1),Icfg(q_s,2)) if(p .EQ. q) cycle if(tableUniqueAlphas(p,q)) then if(holetype(i) .EQ. 1 .AND. vmotype(j) .EQ. 1) then ! SOMO -> VMO - Jsomo = IBCLR(Isomo,p-1) - Jsomo = IBSET(Jsomo,q-1) - Jdomo = Idomo + !Jsomo = IBCLR(Isomo,p-1) + !Jsomo = IBSET(Jsomo,q-1) + !Jdomo = Idomo + if (p_s .eq. q_s) then + Jsomop = IBCLR(Isomop,p-1) + Jsomop = IBSET(Jsomop,q-1) + Jsomoq = Jsomop + else + Jsomop = IBCLR(Isomop,p-1) + Jsomoq = IBSET(Isomoq,q-1) + endif + + ! Domo remains the same + Jdomop = Idomop + Jdomoq = Idomoq + else if(holetype(i) .EQ. 1 .AND. vmotype(j) .EQ. 2) then ! SOMO -> SOMO - Jsomo = IBCLR(Isomo,p-1) - Jsomo = IBCLR(Jsomo,q-1) - Jdomo = IBSET(Idomo,q-1) - if(POPCNT(Jsomo).ge.MS)then + !Jsomo = IBCLR(Isomo,p-1) + !Jsomo = IBCLR(Jsomo,q-1) + !Jdomo = IBSET(Idomo,q-1) + + if(p_s .eq. q_s) then + Jsomop = IBCLR(Isomop,p-1) + Jsomop = IBCLR(Jsomop,q-1) + Jsomoq = Jsomop + else + Jsomop = IBCLR(Isomop,p-1) + Jsomoq = IBCLR(Isomoq,q-1) + endif + + Jdomoq = IBSET(Idomoq,q-1) + + if(POPCNT(Jsomoq).ge.MS)then kstart = max(1,cfg_seniority_index(max(NSOMOMin,Nsomo_I-4))) kend = idxI-1 else @@ -231,26 +405,74 @@ use bitmasks endif else if(holetype(i) .EQ. 2 .AND. vmotype(j) .EQ. 1) then ! DOMO -> VMO - Jsomo = IBSET(Isomo,p-1) - Jsomo = IBSET(Jsomo,q-1) - Jdomo = IBCLR(Idomo,p-1) + !Jsomo = IBSET(Isomo,p-1) + !Jsomo = IBSET(Jsomo,q-1) + !Jdomo = IBCLR(Idomo,p-1) + + if(p_s .eq. q_s) then + Jsomop = IBSET(Isomop,p-1) + Jsomop = IBSET(Jsomop,q-1) + Jsomoq = Jsomop + else + Jsomop = IBSET(Isomop,p-1) + Jsomoq = IBSET(Jsomoq,q-1) + endif + + Jdomop = IBCLR(Idomop,p-1) + else if(holetype(i) .EQ. 2 .AND. vmotype(j) .EQ. 2) then ! DOMO -> SOMO - Jsomo = IBSET(Isomo,p-1) - Jsomo = IBCLR(Jsomo,q-1) - Jdomo = IBCLR(Idomo,p-1) - Jdomo = IBSET(Jdomo,q-1) + !Jsomo = IBSET(Isomo,p-1) + !Jsomo = IBCLR(Jsomo,q-1) + !Jdomo = IBCLR(Idomo,p-1) + !Jdomo = IBSET(Jdomo,q-1) + if(p_s .eq. q_s) then + Jsomop = IBSET(Isomop,p-1) + Jsomop = IBCLR(Jsomop,q-1) + Jsomoq = Jsomop + + Jdomop = IBCLR(Idomop,p-1) + Jdomop = IBSET(Jdomop,q-1) + Jdomoq = Jdomop + else + Jsomop = IBSET(Isomop,p-1) + Jsomoq = IBCLR(Jsomoq,q-1) + + Jdomop = IBCLR(Idomop,p-1) + Jdomoq = IBSET(Jdomoq,q-1) + endif + else print*,"Something went wrong in obtain_associated_alphaI" endif + ! Save it to Jcfg + Jcfg(p_s,1) = Jsomop + Jcfg(q_s,1) = Jsomoq + Jcfg(p_s,2) = Jdomop + Jcfg(q_s,2) = Jdomoq + ! SOMO !print *,i,j,"|",NalphaIcfg, Jsomo, IOR(Jdomo,ISHFT(1_8,n_core_orb)-1) if(POPCNT(Jsomo) .ge. NSOMOMin) then NalphaIcfg += 1 - alphasIcfg_list(1,1,idxI,NalphaIcfg) = Jsomo - alphasIcfg_list(1,2,idxI,NalphaIcfg) = IOR(Jdomo,ISHFT(1_8,n_core_orb)-1) + alphasIcfg_list(:,1,idxI,NalphaIcfg) = Jcfg(:,1) + !alphasIcfg_list(:,2,idxI,NalphaIcfg) = IOR(Jdomo,ISHFT(1_8,n_core_orb)-1) + if(n_core_orb .le. 63)then + alphasIcfg_list(1,2,idxI,NalphaIcfg) = IOR(Jcfg(1,2),ISHFT(1_8,n_core_orb)-1) + else + n_core_orb_64 = n_core_orb + do ii=1,N_int + if(n_core_orb_64 .gt. 0)then + alphasIcfg_list(ii,2,idxI,NalphaIcfg) = IOR(Jcfg(ii,2),ISHFT(1_8,n_core_orb_64)-1) + else + alphasIcfg_list(ii,2,idxI,NalphaIcfg) = Jcfg(ii,2) + endif + n_core_orb_64 = ISHFT(n_core_orb_64,-6) + end do + endif NalphaIcfg_list(idxI) = NalphaIcfg + !print *,i,j,"2| nalpha=",NalphaIcfg, " somo=",Jcfg(1,1),Jcfg(2,1) endif endif end do @@ -261,14 +483,24 @@ use bitmasks Isomo = iand(reunion_of_act_virt_bitmask(1,1),Icfg(1,1)) Idomo = iand(reunion_of_act_virt_bitmask(1,1),Icfg(1,2)) kstart = max(1,cfg_seniority_index(max(NSOMOMin,Nsomo_I-2))) + ndiffDOMO = 0 do k = kstart, idxI-1 - diffSOMO = IEOR(Isomo,iand(act_bitmask(1,1),psi_configuration(1,1,k))) - ndiffSOMO = POPCNT(diffSOMO) + do ii=1,N_int + diffSOMO = IEOR(Icfg(ii,1),iand(act_bitmask(ii,1),psi_configuration(ii,1,k))) + ndiffSOMO += POPCNT(diffSOMO) + end do + ! ndiffSOMO cannot be 0 (I /= k) + ! if ndiffSOMO /= 2 then it has to be greater than 2 and hense + ! this Icfg could not have been generated before. if (ndiffSOMO /= 2) cycle - diffDOMO = IEOR(Idomo,iand(act_bitmask(1,1),psi_configuration(1,2,k))) - xordiffSOMODOMO = IEOR(diffSOMO,diffDOMO) - ndiffDOMO = POPCNT(diffDOMO) - nxordiffSOMODOMO = POPCNT(xordiffSOMODOMO) + ndiffDOMO = 0 + nxordiffSOMODOMO = 0 + do ii=1,N_int + diffDOMO = IEOR(Icfg(ii,2),iand(act_bitmask(ii,1),psi_configuration(ii,2,k))) + xordiffSOMODOMO = IEOR(diffSOMO,diffDOMO) + ndiffDOMO += POPCNT(diffDOMO) + nxordiffSOMODOMO += POPCNT(xordiffSOMODOMO) + end do if((ndiffSOMO+ndiffDOMO+nxordiffSOMODOMO .EQ. 4)) then ppExistsQ = .TRUE. EXIT @@ -279,8 +511,8 @@ use bitmasks ! SOMO if(POPCNT(Jsomo) .ge. NSOMOMin) then NalphaIcfg += 1 - alphasIcfg_list(1,1,idxI,NalphaIcfg) = Icfg(1,1) - alphasIcfg_list(1,2,idxI,NalphaIcfg) = Icfg(1,2) + alphasIcfg_list(:,1,idxI,NalphaIcfg) = Icfg(:,1) + alphasIcfg_list(:,2,idxI,NalphaIcfg) = Icfg(:,2) NalphaIcfg_list(idxI) = NalphaIcfg endif endif diff --git a/src/csf/configurations.irp.f b/src/csf/configurations.irp.f index aebf53d9..a84cb4ab 100644 --- a/src/csf/configurations.irp.f +++ b/src/csf/configurations.irp.f @@ -352,6 +352,11 @@ end psi_configuration(k,1,i) = ieor(psi_det(k,1,i),psi_det(k,2,i)) psi_configuration(k,2,i) = iand(psi_det(k,1,i),psi_det(k,2,i)) enddo + if(i.eq.1)then + print *,'Preparing PSI_CONFIGURATION i=',i + print *," Icfg somo=",psi_configuration(1,1,1), " ", psi_configuration(2,1,1) + print *," Icfg domo=",psi_configuration(1,2,1), " ", psi_configuration(2,2,1) + endif enddo ! Sort diff --git a/src/csf/obtain_I_foralpha.irp.f b/src/csf/obtain_I_foralpha.irp.f index 7d7ae09b..5fd630fc 100644 --- a/src/csf/obtain_I_foralpha.irp.f +++ b/src/csf/obtain_I_foralpha.irp.f @@ -38,6 +38,7 @@ subroutine obtain_connected_J_givenI(idxI, givenI, connectedI, idxs_connectedI, integer :: holetype(mo_num) integer :: end_index integer :: Nsomo_I + integer :: listall(N_int*bit_kind_size), nelall ! ! 2 2 1 1 0 0 : 1 1 0 0 0 0 @@ -65,9 +66,12 @@ subroutine obtain_connected_J_givenI(idxI, givenI, connectedI, idxs_connectedI, ! Since CFGs are sorted wrt to seniority ! we don't have to search the full CFG list - Isomo = givenI(1,1) - Idomo = givenI(1,2) - Nsomo_I = POPCNT(Isomo) + Nsomo_I = 0 + do i=1,N_int + Isomo = givenI(i,1) + Idomo = givenI(i,2) + Nsomo_I += POPCNT(Isomo) + end do end_index = min(N_configuration,cfg_seniority_index(min(Nsomo_I+6,elec_num))-1) if(end_index .LT. 0) end_index= N_configuration !end_index = N_configuration @@ -83,17 +87,24 @@ subroutine obtain_connected_J_givenI(idxI, givenI, connectedI, idxs_connectedI, ! idxs_connectedI(nconnectedI)=i ! cycle !endif - Isomo = givenI(1,1) - Idomo = givenI(1,2) - Jsomo = psi_configuration(1,1,i) - Jdomo = psi_configuration(1,2,i) - diffSOMO = IEOR(Isomo,Jsomo) - ndiffSOMO = POPCNT(diffSOMO) - diffDOMO = IEOR(Idomo,Jdomo) - xordiffSOMODOMO = IEOR(diffSOMO,diffDOMO) - ndiffDOMO = POPCNT(diffDOMO) - nxordiffSOMODOMO = POPCNT(xordiffSOMODOMO) - nxordiffSOMODOMO += ndiffSOMO + ndiffDOMO + + ndiffSOMO = 0 + ndiffDOMO = 0 + nxordiffSOMODOMO = 0 + do ii=1,N_int + Isomo = givenI(ii,1) + Idomo = givenI(ii,2) + Jsomo = psi_configuration(ii,1,i) + Jdomo = psi_configuration(ii,2,i) + diffSOMO = IEOR(Isomo,Jsomo) + ndiffSOMO += POPCNT(diffSOMO) + diffDOMO = IEOR(Idomo,Jdomo) + xordiffSOMODOMO = IEOR(diffSOMO,diffDOMO) + ndiffDOMO += POPCNT(diffDOMO) + nxordiffSOMODOMO += POPCNT(xordiffSOMODOMO) + nxordiffSOMODOMO += ndiffSOMO + ndiffDOMO + end do + if((nxordiffSOMODOMO .EQ. 4) .AND. ndiffSOMO .EQ. 2) then !------- ! MONO | @@ -144,25 +155,45 @@ subroutine obtain_connected_J_givenI(idxI, givenI, connectedI, idxs_connectedI, ! find out all pq holes possible nholes = 0 ! holes in SOMO - Isomo = psi_configuration(1,1,i) - Idomo = psi_configuration(1,2,i) - do iii = 1,n_act_orb - ii = list_act(iii) - if(POPCNT(IAND(Isomo,IBSET(0_8,ii-1))) .EQ. 1) then - nholes += 1 - listholes(nholes) = ii - holetype(nholes) = 1 - endif + !Isomo = psi_configuration(1,1,i) + !Idomo = psi_configuration(1,2,i) + !do iii = 1,n_act_orb + ! ii = list_act(iii) + ! if(POPCNT(IAND(Isomo,IBSET(0_8,ii-1))) .EQ. 1) then + ! nholes += 1 + ! listholes(nholes) = ii + ! holetype(nholes) = 1 + ! endif + !end do + + call bitstring_to_list(psi_configuration(1,1,i),listall,nelall,N_int) + + do iii=1,nelall + nholes += 1 + listholes(nholes) = listall(iii) + holetype(nholes) = 1 end do + ! holes in DOMO - do iii = 1,n_act_orb - ii = list_act(iii) - if(POPCNT(IAND(Idomo,IBSET(0_8,ii-1))) .EQ. 1) then - nholes += 1 - listholes(nholes) = ii - holetype(nholes) = 2 - endif + !do iii = 1,n_act_orb + ! ii = list_act(iii) + ! if(POPCNT(IAND(Idomo,IBSET(0_8,ii-1))) .EQ. 1) then + ! nholes += 1 + ! listholes(nholes) = ii + ! holetype(nholes) = 2 + ! endif + !end do + + call bitstring_to_list(psi_configuration(1,2,i),listall,nelall,N_int) + + do iii=1,nelall + if(listall(iii) .gt. n_core_orb)then + nholes += 1 + listholes(nholes) = listall(iii) + holetype(nholes) = 2 + endif end do + ntotalconnectedI += max(1,(psi_config_data(i,2)-psi_config_data(i,1)+1)*nholes) endif end do @@ -199,6 +230,8 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI integer*8 :: Isomo integer*8 :: Jdomo integer*8 :: Jsomo + integer(bit_kind) :: Jcfg(N_int,2) + integer(bit_kind) :: Icfg(N_int,2) integer*8 :: IJsomo integer*8 :: diffSOMO integer*8 :: diffDOMO @@ -209,9 +242,12 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI integer :: iii,ii,i,j,k,l,p,q,nsomoJ,nsomoalpha,starti,endi,extyp,nholes integer :: listholes(mo_num) integer :: holetype(mo_num) - integer :: end_index - integer :: Nsomo_alpha + integer :: end_index, ishift + integer :: Nsomo_alpha, pp,qq, nperm integer*8 :: MS + integer :: exc(0:2,2,2), tz, m, n, high, low + integer :: listall(N_int*bit_kind_size), nelall + integer(bit_kind) :: hole, particle, tmp MS = elec_alpha_num-elec_beta_num nconnectedI = 0 @@ -219,42 +255,66 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI ! Since CFGs are sorted wrt to seniority ! we don't have to search the full CFG list - Isomo = Ialpha(1,1) - Idomo = Ialpha(1,2) - Nsomo_alpha = POPCNT(Isomo) + !Isomo = Ialpha(1,1) + !Idomo = Ialpha(1,2) + !Nsomo_alpha = POPCNT(Isomo) + Icfg = Ialpha + Nsomo_alpha = 0 + do i=1,N_int + Isomo = Ialpha(i,1) + Idomo = Ialpha(i,2) + Nsomo_alpha += POPCNT(Isomo) + end do end_index = min(N_configuration,cfg_seniority_index(min(Nsomo_alpha+4,elec_num))-1) if(end_index .LT. 0) end_index= N_configuration - end_index = N_configuration + !end_index = N_configuration p = 0 q = 0 - if (N_int > 1) stop 'obtain_connected_i_foralpha : N_int > 1' + !if (N_int > 1) stop 'obtain_connected_i_foralpha : N_int > 1' do i=idxI,end_index - Isomo = Ialpha(1,1) - Idomo = Ialpha(1,2) - Jsomo = psi_configuration(1,1,i) - Jdomo = psi_configuration(1,2,i) ! Check for Minimal alpha electrons (MS) - if(POPCNT(Isomo).lt.MS)then + if(Nsomo_alpha .lt. MS)then cycle endif - diffSOMO = IEOR(Isomo,Jsomo) - ndiffSOMO = POPCNT(diffSOMO) - !if(idxI.eq.1)then - ! print *," \t idxI=",i," diffS=",ndiffSOMO," popJs=", POPCNT(Jsomo)," popIs=",POPCNT(Isomo) - !endif - diffDOMO = IEOR(Idomo,Jdomo) - xordiffSOMODOMO = IEOR(diffSOMO,diffDOMO) - ndiffDOMO = POPCNT(diffDOMO) - nxordiffSOMODOMO = POPCNT(xordiffSOMODOMO) - nxordiffSOMODOMO += ndiffSOMO + ndiffDOMO + !Isomo = Ialpha(1,1) + !Idomo = Ialpha(1,2) + !Jsomo = psi_configuration(1,1,i) + !Jdomo = psi_configuration(1,2,i) + !diffSOMO = IEOR(Isomo,Jsomo) + !ndiffSOMO = POPCNT(diffSOMO) + !diffDOMO = IEOR(Idomo,Jdomo) + !xordiffSOMODOMO = IEOR(diffSOMO,diffDOMO) + !ndiffDOMO = POPCNT(diffDOMO) + !nxordiffSOMODOMO = POPCNT(xordiffSOMODOMO) + !nxordiffSOMODOMO += ndiffSOMO + ndiffDOMO + + ndiffSOMO = 0 + ndiffDOMO = 0 + nxordiffSOMODOMO = 0 + do ii=1,N_int + Isomo = Ialpha(ii,1) + Idomo = Ialpha(ii,2) + Jsomo = psi_configuration(ii,1,i) + Jdomo = psi_configuration(ii,2,i) + diffSOMO = IEOR(Isomo,Jsomo) + ndiffSOMO += POPCNT(diffSOMO) + diffDOMO = IEOR(Idomo,Jdomo) + xordiffSOMODOMO = IEOR(diffSOMO,diffDOMO) + ndiffDOMO += POPCNT(diffDOMO) + nxordiffSOMODOMO += POPCNT(xordiffSOMODOMO) + nxordiffSOMODOMO += ndiffSOMO + ndiffDOMO + end do + Jcfg = psi_configuration(:,:,i) + if((nxordiffSOMODOMO .EQ. 4) .AND. ndiffSOMO .EQ. 2) then select case(ndiffDOMO) case (0) ! SOMO -> VMO !print *,"obt SOMO -> VMO" extyp = 3 + if(N_int .eq. 1) then IJsomo = IEOR(Isomo, Jsomo) !IRP_IF WITHOUT_TRAILZ ! p = (popcnt(ieor( IAND(Isomo,IJsomo) , IAND(Isomo,IJsomo) -1))-1) + 1 @@ -267,6 +327,77 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI !IRP_ELSE q = TRAILZ(IJsomo) + 1 !IRP_ENDIF + !print *," p=",p," q=",q + !call get_single_excitation_cfg(Jcfg, Icfg, p, q, N_int) + else + exc = 0 + do ii = 1,2 + ishift = 1-bit_kind_size + do l=1,N_int + ishift = ishift + bit_kind_size + if (Jcfg(l,ii) == Icfg(l,ii)) then + cycle + endif + tmp = xor( Jcfg(l,ii), Icfg(l,ii) ) + particle = iand(tmp, Icfg(l,ii)) + hole = iand(tmp, Jcfg(l,ii)) + if (particle /= 0_bit_kind) then + tz = trailz(particle) + exc(0,2,ii) = 1 + exc(1,2,ii) = tz+ishift + !print *,"part ",tz+ishift, " ii=",ii, exc(1,2,2) + endif + if (hole /= 0_bit_kind) then + tz = trailz(hole) + exc(0,1,ii) = 1 + exc(1,1,ii) = tz+ishift + !print *,"hole ",tz+ishift, " ii=",ii, exc(1,1,2) + endif + + if ( iand(exc(0,1,ii),exc(0,2,ii)) /= 1) then ! exc(0,1,ii)/=1 and exc(0,2,ii) /= 1 + cycle + endif + + high = max(exc(1,1,ii), exc(1,2,ii))-1 + low = min(exc(1,1,ii), exc(1,2,ii)) + + ASSERT (low >= 0) + ASSERT (high > 0) + + k = shiftr(high,bit_kind_shift)+1 + j = shiftr(low,bit_kind_shift)+1 + m = iand(high,bit_kind_size-1) + n = iand(low,bit_kind_size-1) + + if (j==k) then + nperm = nperm + popcnt(iand(Jcfg(j,ii), & + iand( shiftl(1_bit_kind,m)-1_bit_kind, & + not(shiftl(1_bit_kind,n))+1_bit_kind)) ) + else + nperm = nperm + popcnt( & + iand(Jcfg(j,ii), & + iand(not(0_bit_kind), & + (not(shiftl(1_bit_kind,n)) + 1_bit_kind) ))) & + + popcnt(iand(Jcfg(k,ii), & + (shiftl(1_bit_kind,m) - 1_bit_kind ) )) + + do iii=j+1,k-1 + nperm = nperm + popcnt(Jcfg(iii,ii)) + end do + + endif + + ! Set p and q + q = max(exc(1,1,1),exc(1,1,2)) + p = max(exc(1,2,1),exc(1,2,2)) + exit + + enddo + enddo +endif + !assert ( p == pp) + !assert ( q == qq) + !print *," --- p=",p," q=",q case (1) ! DOMO -> VMO ! or @@ -277,6 +408,7 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI ! DOMO -> VMO !print *,"obt DOMO -> VMO" extyp = 2 + if(N_int.eq.1)then !IRP_IF WITHOUT_TRAILZ ! p = (popcnt(ieor( IEOR(Idomo,Jdomo),IEOR(Idomo,Jdomo) -1))-1) + 1 !IRP_ELSE @@ -289,10 +421,83 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI !IRP_ELSE q = TRAILZ(Isomo) + 1 !IRP_ENDIF + else + exc=0 + exc(0,1,1) = 0 + exc(0,2,1) = 0 + exc(0,1,2) = 0 + exc(0,2,2) = 0 + do ii = 1,2 + ishift = 1-bit_kind_size + do l=1,N_int + ishift = ishift + bit_kind_size + if (Jcfg(l,ii) == Icfg(l,ii)) then + cycle + endif + tmp = xor( Jcfg(l,ii), Icfg(l,ii) ) + particle = iand(tmp, Icfg(l,ii)) + hole = iand(tmp, Jcfg(l,ii)) + if (particle /= 0_bit_kind) then + tz = trailz(particle) + exc(0,2,ii) = 1 + exc(1,2,ii) = tz+ishift + !print *,"part ",tz+ishift, " ii=",ii + endif + if (hole /= 0_bit_kind) then + tz = trailz(hole) + exc(0,1,ii) = 1 + exc(1,1,ii) = tz+ishift + !print *,"hole ",tz+ishift, " ii=",ii + endif + + if ( iand(exc(0,1,ii),exc(0,2,ii)) /= 1) then ! exc(0,1,ii)/=1 and exc(0,2,ii) /= 1 + cycle + endif + + high = max(exc(1,1,ii), exc(1,2,ii))-1 + low = min(exc(1,1,ii), exc(1,2,ii)) + + ASSERT (low >= 0) + ASSERT (high > 0) + + k = shiftr(high,bit_kind_shift)+1 + j = shiftr(low,bit_kind_shift)+1 + m = iand(high,bit_kind_size-1) + n = iand(low,bit_kind_size-1) + + if (j==k) then + nperm = nperm + popcnt(iand(Jcfg(j,ii), & + iand( shiftl(1_bit_kind,m)-1_bit_kind, & + not(shiftl(1_bit_kind,n))+1_bit_kind)) ) + else + nperm = nperm + popcnt( & + iand(Jcfg(j,ii), & + iand(not(0_bit_kind), & + (not(shiftl(1_bit_kind,n)) + 1_bit_kind) ))) & + + popcnt(iand(Jcfg(k,ii), & + (shiftl(1_bit_kind,m) - 1_bit_kind ) )) + + do iii=j+1,k-1 + nperm = nperm + popcnt(Jcfg(iii,ii)) + end do + + endif + + ! Set p and q + q = max(exc(1,1,1),exc(1,1,2)) + p = max(exc(1,2,1),exc(1,2,2)) + exit + + enddo + enddo +endif + !assert ( p == pp) + !assert ( q == qq) else ! SOMO -> SOMO !print *,"obt SOMO -> SOMO" extyp = 1 + if(N_int.eq.1)then !IRP_IF WITHOUT_TRAILZ ! q = (popcnt(ieor( IEOR(Idomo,Jdomo), IEOR(Idomo,Jdomo)-1))-1) + 1 !IRP_ELSE @@ -309,11 +514,84 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI !if(POPCNT(Isomo).lt.MS)then ! cycle !endif + else + exc=0 + exc(0,1,1) = 0 + exc(0,2,1) = 0 + exc(0,1,2) = 0 + exc(0,2,2) = 0 + do ii = 1,2 + ishift = 1-bit_kind_size + do l=1,N_int + ishift = ishift + bit_kind_size + if (Jcfg(l,ii) == Icfg(l,ii)) then + cycle + endif + tmp = xor( Jcfg(l,ii), Icfg(l,ii) ) + particle = iand(tmp, Icfg(l,ii)) + hole = iand(tmp, Jcfg(l,ii)) + if (particle /= 0_bit_kind) then + tz = trailz(particle) + exc(0,2,ii) = 1 + exc(1,2,ii) = tz+ishift + !print *,"part ",tz+ishift, " ii=",ii + endif + if (hole /= 0_bit_kind) then + tz = trailz(hole) + exc(0,1,ii) = 1 + exc(1,1,ii) = tz+ishift + !print *,"hole ",tz+ishift, " ii=",ii + endif + + if ( iand(exc(0,1,ii),exc(0,2,ii)) /= 1) then ! exc(0,1,ii)/=1 and exc(0,2,ii) /= 1 + cycle + endif + + high = max(exc(1,1,ii), exc(1,2,ii))-1 + low = min(exc(1,1,ii), exc(1,2,ii)) + + ASSERT (low >= 0) + ASSERT (high > 0) + + k = shiftr(high,bit_kind_shift)+1 + j = shiftr(low,bit_kind_shift)+1 + m = iand(high,bit_kind_size-1) + n = iand(low,bit_kind_size-1) + + if (j==k) then + nperm = nperm + popcnt(iand(Jcfg(j,ii), & + iand( shiftl(1_bit_kind,m)-1_bit_kind, & + not(shiftl(1_bit_kind,n))+1_bit_kind)) ) + else + nperm = nperm + popcnt( & + iand(Jcfg(j,ii), & + iand(not(0_bit_kind), & + (not(shiftl(1_bit_kind,n)) + 1_bit_kind) ))) & + + popcnt(iand(Jcfg(k,ii), & + (shiftl(1_bit_kind,m) - 1_bit_kind ) )) + + do iii=j+1,k-1 + nperm = nperm + popcnt(Jcfg(iii,ii)) + end do + + endif + + ! Set p and q + q = max(exc(1,1,1),exc(1,1,2)) + p = max(exc(1,2,1),exc(1,2,2)) + exit + + enddo + enddo +endif + !assert ( p == pp) + !assert ( q == qq) end if case (2) ! DOMO -> SOMO !print *,"obt DOMO -> SOMO" extyp = 4 + if(N_int.eq.1)then IJsomo = IEOR(Isomo, Jsomo) !IRP_IF WITHOUT_TRAILZ ! p = (popcnt(ieor( IAND(Jsomo,IJsomo), IAND(Jsomo,IJsomo)-1))-1) + 1 @@ -326,6 +604,79 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI !IRP_ELSE q = TRAILZ(IJsomo) + 1 !IRP_ENDIF + + else + exc=0 + exc(0,1,1) = 0 + exc(0,2,1) = 0 + exc(0,1,2) = 0 + exc(0,2,2) = 0 + do ii = 1,2 + ishift = 1-bit_kind_size + do l=1,N_int + ishift = ishift + bit_kind_size + if (Jcfg(l,ii) == Icfg(l,ii)) then + cycle + endif + tmp = xor( Jcfg(l,ii), Icfg(l,ii) ) + particle = iand(tmp, Icfg(l,ii)) + hole = iand(tmp, Jcfg(l,ii)) + if (particle /= 0_bit_kind) then + tz = trailz(particle) + exc(0,2,ii) = 1 + exc(1,2,ii) = tz+ishift + !print *,"part ",tz+ishift, " ii=",ii + endif + if (hole /= 0_bit_kind) then + tz = trailz(hole) + exc(0,1,ii) = 1 + exc(1,1,ii) = tz+ishift + !print *,"hole ",tz+ishift, " ii=",ii + endif + + if ( iand(exc(0,1,ii),exc(0,2,ii)) /= 1) then ! exc(0,1,ii)/=1 and exc(0,2,ii) /= 1 + cycle + endif + + high = max(exc(1,1,ii), exc(1,2,ii))-1 + low = min(exc(1,1,ii), exc(1,2,ii)) + + ASSERT (low >= 0) + ASSERT (high > 0) + + k = shiftr(high,bit_kind_shift)+1 + j = shiftr(low,bit_kind_shift)+1 + m = iand(high,bit_kind_size-1) + n = iand(low,bit_kind_size-1) + + if (j==k) then + nperm = nperm + popcnt(iand(Jcfg(j,ii), & + iand( shiftl(1_bit_kind,m)-1_bit_kind, & + not(shiftl(1_bit_kind,n))+1_bit_kind)) ) + else + nperm = nperm + popcnt( & + iand(Jcfg(j,ii), & + iand(not(0_bit_kind), & + (not(shiftl(1_bit_kind,n)) + 1_bit_kind) ))) & + + popcnt(iand(Jcfg(k,ii), & + (shiftl(1_bit_kind,m) - 1_bit_kind ) )) + + do iii=j+1,k-1 + nperm = nperm + popcnt(Jcfg(iii,ii)) + end do + + endif + + ! Set p and q + q = max(exc(1,1,1),exc(1,1,2)) + p = max(exc(1,2,1),exc(1,2,2)) + exit + + enddo + enddo +endif + !assert ( p == pp) + !assert ( q == qq) case default print *,"something went wront in get connectedI" end select @@ -345,26 +696,46 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI ! find out all pq holes possible nholes = 0 ! holes in SOMO - Isomo = psi_configuration(1,1,i) - Idomo = psi_configuration(1,2,i) - do iii = 1,n_act_orb - ii = list_act(iii) - if(POPCNT(IAND(Isomo,IBSET(0_8,ii-1))) .EQ. 1) then - nholes += 1 - listholes(nholes) = ii - holetype(nholes) = 1 - endif + !Isomo = psi_configuration(1,1,i) + !Idomo = psi_configuration(1,2,i) + !do iii = 1,n_act_orb + ! ii = list_act(iii) + ! if(POPCNT(IAND(Isomo,IBSET(0_8,ii-1))) .EQ. 1) then + ! nholes += 1 + ! listholes(nholes) = ii + ! holetype(nholes) = 1 + ! endif + !end do + call bitstring_to_list(psi_configuration(1,1,i),listall,nelall,N_int) + + do iii=1,nelall + nholes += 1 + listholes(nholes) = listall(iii) + holetype(nholes) = 1 end do + ! holes in DOMO - do iii = 1,n_act_orb - ii = list_act(iii) - if(POPCNT(IAND(Idomo,IBSET(0_8,ii-1))) .EQ. 1) then - nholes += 1 - listholes(nholes) = ii - holetype(nholes) = 2 - endif + !do iii = 1,n_act_orb + ! ii = list_act(iii) + ! if(POPCNT(IAND(Idomo,IBSET(0_8,ii-1))) .EQ. 1) then + ! nholes += 1 + ! listholes(nholes) = ii + ! holetype(nholes) = 2 + ! endif + !end do + nelall=0 + listall=0 + call bitstring_to_list(psi_configuration(1,2,i),listall,nelall,N_int) + + do iii=1,nelall + if(listall(iii) .gt. n_core_orb)then + nholes += 1 + listholes(nholes) = listall(iii) + holetype(nholes) = 2 + endif end do + do k=1,nholes p = listholes(k) q = p diff --git a/src/csf/sigma_vector.irp.f b/src/csf/sigma_vector.irp.f index 21c19aaa..99def47e 100644 --- a/src/csf/sigma_vector.irp.f +++ b/src/csf/sigma_vector.irp.f @@ -835,7 +835,7 @@ subroutine calculate_preconditioner_cfg(diag_energies) ! the configurations in psi_configuration ! returns : diag_energies : END_DOC - integer :: i,j,k,kk,l,p,q,noccp,noccq, ii, jj + integer :: i,j,k,kk,l,p,q,noccp,noccq, ii, jj, iii real*8,intent(out) :: diag_energies(n_CSF) integer :: nholes integer :: nvmos @@ -863,6 +863,7 @@ subroutine calculate_preconditioner_cfg(diag_energies) real*8 :: meCC real*8 :: ecore real*8 :: core_act_contrib + integer :: listall(N_int*bit_kind_size), nelall !PROVIDE h_core_ri PROVIDE core_fock_operator @@ -894,47 +895,61 @@ subroutine calculate_preconditioner_cfg(diag_energies) ! find out all pq holes possible nholes = 0 ! holes in SOMO - !do k = 1,mo_num - do kk = 1,n_act_orb - k = list_act(kk) - if(POPCNT(IAND(Isomo,IBSET(0_8,k-1))) .EQ. 1) then - nholes += 1 - listholes(nholes) = k - holetype(nholes) = 1 - endif - enddo - ! holes in DOMO - !do k = n_core_orb+1,n_core_orb + n_act_orb - !do k = 1+n_core_inact_orb,n_core_orb+n_core_inact_act_orb - !do k = 1,mo_num - do kk = 1,n_act_orb - k = list_act(kk) - if(POPCNT(IAND(Idomo,IBSET(0_8,k-1))) .EQ. 1) then - nholes += 1 - listholes(nholes) = k - holetype(nholes) = 2 - endif - enddo + !do kk = 1,n_act_orb + ! k = list_act(kk) + ! if(POPCNT(IAND(Isomo,IBSET(0_8,k-1))) .EQ. 1) then + ! nholes += 1 + ! listholes(nholes) = k + ! holetype(nholes) = 1 + ! endif + !enddo + call bitstring_to_list(psi_configuration(1,1,i),listall,nelall,N_int) - ! find vmos - listvmos = -1 - vmotype = -1 - nvmos = 0 - !do k = n_core_orb+1,n_core_orb + n_act_orb - !do k = 1,mo_num - do kk = 1,n_act_orb - k = list_act(kk) - !print *,i,IBSET(0,i-1),POPCNT(IAND(Isomo,(IBSET(0_8,i-1)))), POPCNT(IAND(Idomo,(IBSET(0_8,i-1)))) - if(POPCNT(IAND(Isomo,(IBSET(0_8,k-1)))) .EQ. 0 .AND. POPCNT(IAND(Idomo,(IBSET(0_8,k-1)))) .EQ. 0) then - nvmos += 1 - listvmos(nvmos) = k - vmotype(nvmos) = 0 - else if(POPCNT(IAND(Isomo,(IBSET(0_8,k-1)))) .EQ. 1 .AND. POPCNT(IAND(Idomo,(IBSET(0_8,k-1)))) .EQ. 0 ) then - nvmos += 1 - listvmos(nvmos) = k - vmotype(nvmos) = 1 - end if - enddo + do iii=1,nelall + nholes += 1 + listholes(nholes) = listall(iii) + holetype(nholes) = 1 + end do + + ! holes in DOMO + !do kk = 1,n_act_orb + ! k = list_act(kk) + ! if(POPCNT(IAND(Idomo,IBSET(0_8,k-1))) .EQ. 1) then + ! nholes += 1 + ! listholes(nholes) = k + ! holetype(nholes) = 2 + ! endif + !enddo + call bitstring_to_list(psi_configuration(1,2,i),listall,nelall,N_int) + + do iii=1,nelall + if(listall(iii) .gt. n_core_orb)then + nholes += 1 + listholes(nholes) = listall(iii) + holetype(nholes) = 2 + endif + end do + + + !!! find vmos + !!listvmos = -1 + !!vmotype = -1 + !!nvmos = 0 + !!!do k = n_core_orb+1,n_core_orb + n_act_orb + !!!do k = 1,mo_num + !!do kk = 1,n_act_orb + !! k = list_act(kk) + !! !print *,i,IBSET(0,i-1),POPCNT(IAND(Isomo,(IBSET(0_8,i-1)))), POPCNT(IAND(Idomo,(IBSET(0_8,i-1)))) + !! if(POPCNT(IAND(Isomo,(IBSET(0_8,k-1)))) .EQ. 0 .AND. POPCNT(IAND(Idomo,(IBSET(0_8,k-1)))) .EQ. 0) then + !! nvmos += 1 + !! listvmos(nvmos) = k + !! vmotype(nvmos) = 0 + !! else if(POPCNT(IAND(Isomo,(IBSET(0_8,k-1)))) .EQ. 1 .AND. POPCNT(IAND(Idomo,(IBSET(0_8,k-1)))) .EQ. 0 ) then + !! nvmos += 1 + !! listvmos(nvmos) = k + !! vmotype(nvmos) = 1 + !! end if + !!enddo !print *,"I=",i !call debug_spindet(psi_configuration(1,1,i),N_int) !call debug_spindet(psi_configuration(1,2,i),N_int) @@ -1413,8 +1428,8 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze !nconnectedtotalmax = 1000 !nconnectedmaxJ = 1000 maxnalphas = elec_num*mo_num - Icfg(1,1) = psi_configuration(1,1,1) - Icfg(1,2) = psi_configuration(1,2,1) + Icfg(:,1) = psi_configuration(:,1,1) + Icfg(:,2) = psi_configuration(:,2,1) allocate(listconnectedJ(N_INT,2,max(sze,10000))) allocate(idslistconnectedJ(max(sze,10000))) call obtain_connected_J_givenI(1, Icfg, listconnectedJ, idslistconnectedJ, nconnectedmaxJ, nconnectedtotalmax) @@ -1632,9 +1647,9 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze Nalphas_Icfg = NalphaIcfg_list(i) alphas_Icfg(1:n_int,1:2,1:Nalphas_Icfg) = alphasIcfg_list(1:n_int,1:2,i,1:Nalphas_Icfg) - if(Nalphas_Icfg .GT. maxnalphas) then - print *,"Nalpha > maxnalpha" - endif + !if(Nalphas_Icfg .GT. maxnalphas) then + ! print *,"Nalpha > maxnalpha" + !endif call obtain_connected_J_givenI(i, Icfg, listconnectedJ, idslistconnectedJ, nconnectedJ, ntotJ) @@ -1650,15 +1665,15 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze call obtain_connected_I_foralpha(i, alphas_Icfg(1,1,k), connectedI_alpha, idxs_connectedI_alpha, & nconnectedI, excitationIds, excitationTypes, diagfactors) + !if(i .EQ. 1) then + ! print *,'k=',k,' kcfgSOMO=',alphas_Icfg(1,1,k),' ',POPCNT(alphas_Icfg(1,1,k)),' kcfgDOMO=',alphas_Icfg(1,2,k),' ',POPCNT(alphas_Icfg(1,2,k)) + !endif + if(nconnectedI .EQ. 0) then cycle endif - !if(i .EQ. 1) then - ! print *,'k=',k,' kcfgSOMO=',alphas_Icfg(1,1,k),' ',POPCNT(alphas_Icfg(1,1,k)),' kcfgDOMO=',alphas_Icfg(1,2,k),' ',POPCNT(alphas_Icfg(1,2,k)) - !endif - ! Here we do 2x the loop. One to count for the size of the matrix, then we compute. totcolsTKI = 0 rowsTKI = -1 diff --git a/src/determinants/slater_rules.irp.f b/src/determinants/slater_rules.irp.f index 897607a9..08718023 100644 --- a/src/determinants/slater_rules.irp.f +++ b/src/determinants/slater_rules.irp.f @@ -83,7 +83,7 @@ subroutine get_excitation(det1,det2,exc,degree,phase,Nint) ! exc(1,1,1) = q ! exc(1,2,1) = p - ! T^alpha_pq : exc(0,1,2) = 1 + ! T^beta_pq : exc(0,1,2) = 1 ! exc(0,2,2) = 1 ! exc(1,1,2) = q ! exc(1,2,2) = p @@ -434,6 +434,98 @@ subroutine get_single_excitation(det1,det2,exc,phase,Nint) end +subroutine get_single_excitation_cfg(cfg1,cfg2,p,q,Nint) + use bitmasks + implicit none + BEGIN_DOC + ! Returns the excitation operator between two singly excited configurations. + END_DOC + integer, intent(in) :: Nint + integer(bit_kind), intent(in) :: cfg1(Nint,2) + integer(bit_kind), intent(in) :: cfg2(Nint,2) + integer, intent(out) :: p, q + integer :: tz + integer :: l, ispin, idx_hole, idx_particle, ishift + integer :: nperm + integer :: i,j,k,m,n + integer :: high, low + integer :: a,b,c,d + integer(bit_kind) :: hole, particle, tmp + integer :: exc(0:2,2,2) + + ASSERT (Nint > 0) + nperm = 0 + p = 0 + q = 0 + exc(0,1,1) = 0 + exc(0,2,1) = 0 + exc(0,1,2) = 0 + exc(0,2,2) = 0 + do ispin = 1,2 + ishift = 1-bit_kind_size + do l=1,Nint + ishift = ishift + bit_kind_size + if (cfg1(l,ispin) == cfg2(l,ispin)) then + cycle + endif + tmp = xor( cfg1(l,ispin), cfg2(l,ispin) ) + particle = iand(tmp, cfg2(l,ispin)) + hole = iand(tmp, cfg1(l,ispin)) + if (particle /= 0_bit_kind) then + tz = trailz(particle) + exc(0,2,ispin) = 1 + exc(1,2,ispin) = tz+ishift + !print *,"part ",tz+ishift, " ispin=",ispin + endif + if (hole /= 0_bit_kind) then + tz = trailz(hole) + exc(0,1,ispin) = 1 + exc(1,1,ispin) = tz+ishift + !print *,"hole ",tz+ishift, " ispin=",ispin + endif + + if ( iand(exc(0,1,ispin),exc(0,2,ispin)) /= 1) then ! exc(0,1,ispin)/=1 and exc(0,2,ispin) /= 1 + cycle + endif + + high = max(exc(1,1,ispin), exc(1,2,ispin))-1 + low = min(exc(1,1,ispin), exc(1,2,ispin)) + + ASSERT (low >= 0) + ASSERT (high > 0) + + k = shiftr(high,bit_kind_shift)+1 + j = shiftr(low,bit_kind_shift)+1 + m = iand(high,bit_kind_size-1) + n = iand(low,bit_kind_size-1) + + if (j==k) then + nperm = nperm + popcnt(iand(cfg1(j,ispin), & + iand( shiftl(1_bit_kind,m)-1_bit_kind, & + not(shiftl(1_bit_kind,n))+1_bit_kind)) ) + else + nperm = nperm + popcnt( & + iand(cfg1(j,ispin), & + iand(not(0_bit_kind), & + (not(shiftl(1_bit_kind,n)) + 1_bit_kind) ))) & + + popcnt(iand(cfg1(k,ispin), & + (shiftl(1_bit_kind,m) - 1_bit_kind ) )) + + do i=j+1,k-1 + nperm = nperm + popcnt(cfg1(i,ispin)) + end do + + endif + + ! Set p and q + q = max(exc(1,1,1),exc(1,1,2)) + p = max(exc(1,2,1),exc(1,2,2)) + return + + enddo + enddo +end + subroutine bitstring_to_list_ab( string, list, n_elements, Nint) use bitmasks implicit none From 1fbbaf58a54e5486e0a7019cd6bb424a189efa6e Mon Sep 17 00:00:00 2001 From: v1j4y Date: Mon, 21 Nov 2022 17:04:03 +0100 Subject: [PATCH 02/21] Fix iand for csf. --- src/csf/sigma_vector.irp.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/csf/sigma_vector.irp.f b/src/csf/sigma_vector.irp.f index 99def47e..cfe6279f 100644 --- a/src/csf/sigma_vector.irp.f +++ b/src/csf/sigma_vector.irp.f @@ -240,7 +240,7 @@ end subroutine get_phase_qp_to_cfg ! initialization psi_coef_config = 0.d0 DetToCSFTransformationMatrix(0,:,:) = 1.d0 - do i = 2-iand(MS,1), NSOMOMax,2 + do i = 2-iand(MS,1_8), NSOMOMax,2 Isomo = IBSET(0_8, i) - 1_8 ! rows = Ncsfs ! cols = Ndets From f2f9b9ffd0246f46ba3e8181b4272b686562d971 Mon Sep 17 00:00:00 2001 From: v1j4y Date: Tue, 22 Nov 2022 17:56:29 +0100 Subject: [PATCH 03/21] Working on csf nint. --- src/csf/configuration_CI_sigma_helpers.irp.f | 908 +++++++++++++------ 1 file changed, 618 insertions(+), 290 deletions(-) diff --git a/src/csf/configuration_CI_sigma_helpers.irp.f b/src/csf/configuration_CI_sigma_helpers.irp.f index 167b41fc..581498c5 100644 --- a/src/csf/configuration_CI_sigma_helpers.irp.f +++ b/src/csf/configuration_CI_sigma_helpers.irp.f @@ -1,5 +1,529 @@ use bitmasks +!!! BEGIN_PROVIDER [ integer(bit_kind), alphasIcfg_list , (N_int,2,N_configuration,mo_num*(mo_num))] +!!!&BEGIN_PROVIDER [ integer, NalphaIcfg_list, (N_configuration) ] +!!! implicit none +!!! !use bitmasks +!!! BEGIN_DOC +!!! ! Documentation for alphasI +!!! ! Returns the associated alpha's for +!!! ! the input configuration Icfg. +!!! END_DOC +!!! +!!! integer :: idxI ! The id of the Ith CFG +!!! integer(bit_kind) :: Icfg(N_int,2) +!!! integer(bit_kind) :: Jcfg(N_int,2) +!!! integer :: NalphaIcfg +!!! logical,dimension(:,:),allocatable :: tableUniqueAlphas +!!! integer :: listholes(mo_num) +!!! integer :: holetype(mo_num) ! 1-> SOMO 2->DOMO +!!! integer :: nholes +!!! integer :: nvmos +!!! integer :: listvmos(mo_num) +!!! integer :: vmotype(mo_num) ! 1 -> VMO 2 -> SOMO +!!! integer*8 :: Idomo, Idomop, Idomoq +!!! integer*8 :: Isomo, Isomop, Isomoq +!!! integer*8 :: Jdomo, Jdomop, Jdomoq +!!! integer*8 :: Jsomo, Jsomop, Jsomoq +!!! integer*8 :: diffSOMO +!!! integer*8 :: diffDOMO +!!! integer*8 :: xordiffSOMODOMO +!!! integer :: ndiffSOMO +!!! integer :: ndiffDOMO +!!! integer :: nxordiffSOMODOMO +!!! integer :: ndiffAll +!!! integer :: i,ii,iii +!!! integer :: j,jj, i_s, i_d +!!! integer :: k,kk +!!! integer :: kstart +!!! integer :: kend +!!! integer :: Nsomo_I, Nsomo_J +!!! integer :: hole, n_core_orb_64 +!!! integer :: p, pp, p_s +!!! integer :: q, qq, q_s +!!! integer :: countalphas +!!! logical :: pqAlreadyGenQ +!!! logical :: pqExistsQ +!!! logical :: ppExistsQ +!!! integer*8 :: MS +!!! integer :: listall(N_int*bit_kind_size), nelall +!!! +!!! double precision :: t0, t1 +!!! call wall_time(t0) +!!! +!!! MS = elec_alpha_num-elec_beta_num +!!! +!!! allocate(tableUniqueAlphas(mo_num,mo_num)) +!!! NalphaIcfg_list = 0 +!!! +!!! do idxI = 1, N_configuration +!!! +!!! Icfg = psi_configuration(:,:,idxI) +!!! Jcfg = psi_configuration(:,:,idxI) +!!! !print *," Jcfg somo=",Jcfg(1,1), " ", Jcfg(2,1) +!!! !print *," Jcfg domo=",Jcfg(1,2), " ", Jcfg(2,2) +!!! +!!! Isomo = iand(act_bitmask(1,1),Icfg(1,1)) +!!! Idomo = iand(act_bitmask(1,1),Icfg(1,2)) +!!! +!!! ! find out all pq holes possible +!!! nholes = 0 +!!! ! holes in SOMO +!!! !do ii = 1,n_act_orb +!!! ! i = list_act(ii) +!!! ! if(POPCNT(IAND(Isomo,IBSET(0_8,i-1))) .EQ. 1) then +!!! ! nholes += 1 +!!! ! listholes(nholes) = i +!!! ! holetype(nholes) = 1 +!!! ! endif +!!! !end do +!!! call bitstring_to_list(psi_configuration(1,1,idxI),listall,nelall,N_int) +!!! +!!! !print *,'list somo' +!!! do iii=1,nelall +!!! nholes += 1 +!!! listholes(nholes) = listall(iii) +!!! !print *,listall(iii) +!!! holetype(nholes) = 1 +!!! end do +!!! +!!! Nsomo_I = nelall +!!! +!!! ! holes in DOMO +!!! !do ii = 1,n_act_orb +!!! ! i = list_act(ii) +!!! ! if(POPCNT(IAND(Idomo,IBSET(0_8,i-1))) .EQ. 1) then +!!! ! nholes += 1 +!!! ! listholes(nholes) = i +!!! ! holetype(nholes) = 2 +!!! ! endif +!!! !end do +!!! +!!! !do iii=1,N_int +!!! ! print *,' iii=',iii, psi_configuration(iii,2,idxI), ' idxI=',idxI +!!! !end do +!!! call bitstring_to_list(psi_configuration(1,2,idxI),listall,nelall,N_int) +!!! +!!! !print *,'list domo ncore=',n_core_orb, ' nelall=',nelall +!!! do iii=1,nelall +!!! if(listall(iii) .gt. n_core_orb)then +!!! nholes += 1 +!!! listholes(nholes) = listall(iii) +!!! !print *,listall(iii) +!!! holetype(nholes) = 2 +!!! endif +!!! end do +!!! +!!! ! find vmos +!!! listvmos = -1 +!!! vmotype = -1 +!!! nvmos = 0 +!!! !do ii = 1,n_act_orb +!!! ! i = list_act(ii) +!!! ! if(IAND(Idomo,(IBSET(0_8,i-1))) .EQ. 0) then +!!! ! if(IAND(Isomo,(IBSET(0_8,i-1))) .EQ. 0) then +!!! ! nvmos += 1 +!!! ! listvmos(nvmos) = i +!!! ! print *,'1 i=',i +!!! ! vmotype(nvmos) = 1 +!!! ! else if(POPCNT(IAND(Isomo,(IBSET(0_8,i-1)))) .EQ. 1) then +!!! ! nvmos += 1 +!!! ! listvmos(nvmos) = i +!!! ! print *,'2 i=',i +!!! ! vmotype(nvmos) = 2 +!!! ! end if +!!! ! end if +!!! !end do +!!! !print *,'-----------' +!!! +!!! ! Take into account N_int +!!! do ii = 1, n_act_orb +!!! iii = list_act(ii) +!!! i_s = (1+((iii-1)/63)) +!!! i = iii - ( i_s -1 )*63 +!!! Isomo = iand(act_bitmask(i_s,1),Icfg(i_s,1)) +!!! Idomo = iand(act_bitmask(i_s,1),Icfg(i_s,2)) +!!! +!!! if(IAND(Idomo,(IBSET(0_8,i-1))) .EQ. 0) then +!!! if(IAND(Isomo,(IBSET(0_8,i-1))) .EQ. 0) then +!!! nvmos += 1 +!!! listvmos(nvmos) = iii +!!! vmotype(nvmos) = 1 +!!! else if(POPCNT(IAND(Isomo,(IBSET(0_8,i-1)))) .EQ. 1) then +!!! nvmos += 1 +!!! listvmos(nvmos) = iii +!!! vmotype(nvmos) = 2 +!!! end if +!!! end if +!!! end do +!!! +!!! tableUniqueAlphas = .FALSE. +!!! +!!! ! Now find the allowed (p,q) excitations +!!! Isomo = iand(act_bitmask(1,1),Icfg(1,1)) +!!! Idomo = iand(act_bitmask(1,1),Icfg(1,2)) +!!! !Nsomo_I = POPCNT(Isomo) +!!! if(Nsomo_I .EQ. 0) then +!!! kstart = 1 +!!! else +!!! kstart = cfg_seniority_index(max(NSOMOMin,Nsomo_I-2)) +!!! endif +!!! kend = idxI-1 +!!! +!!! do i = 1,nholes +!!! pp = listholes(i) +!!! p_s = (1+((pp-1)/63)) +!!! p = pp - (p_s - 1)*63 +!!! !print *,' pp=',pp, ' p_s=',p_s, ' p=',p +!!! do j = 1,nvmos +!!! qq = listvmos(j) +!!! q_s = (1+((qq-1)/63)) +!!! q = qq - (q_s - 1)*63 +!!! !print *,' qq=',qq, ' q_s=',q_s, ' q=',q +!!! Isomop = iand(act_bitmask(i_s,1),Icfg(p_s,1)) +!!! Idomop = iand(act_bitmask(i_s,1),Icfg(p_s,2)) +!!! Isomop = iand(act_bitmask(i_s,1),Icfg(q_s,1)) +!!! Idomop = iand(act_bitmask(i_s,1),Icfg(q_s,2)) +!!! if(p .EQ. q) cycle +!!! if(holetype(i) .EQ. 1 .AND. vmotype(j) .EQ. 1) then +!!! ! SOMO -> VMO +!!! !print *,'SOMO -> VMO' +!!! if (p_s .eq. q_s) then +!!! Jsomop = IBCLR(Isomop,p-1) +!!! Jsomop = IBSET(Jsomop,q-1) +!!! Jsomoq = Jsomop +!!! else +!!! Jsomop = IBCLR(Isomop,p-1) +!!! Jsomoq = IBSET(Isomoq,q-1) +!!! endif +!!! +!!! ! Domo remains the same +!!! Jdomop = Idomop +!!! Jdomoq = Idomoq +!!! +!!! kstart = max(1,cfg_seniority_index(max(NSOMOMin,Nsomo_I-2))) +!!! kend = idxI-1 +!!! else if(holetype(i) .EQ. 1 .AND. vmotype(j) .EQ. 2) then +!!! ! SOMO -> SOMO +!!! !print *,'SOMO -> SOMO' +!!! if(p_s .eq. q_s) then +!!! Jsomop = IBCLR(Isomop,p-1) +!!! Jsomop = IBCLR(Jsomop,q-1) +!!! Jsomoq = Jsomop +!!! else +!!! Jsomop = IBCLR(Isomop,p-1) +!!! Jsomoq = IBCLR(Isomoq,q-1) +!!! endif +!!! +!!! Jdomoq = IBSET(Idomoq,q-1) +!!! +!!! ! Check for Minimal alpha electrons (MS) +!!! if(POPCNT(Jsomoq).ge.MS)then +!!! kstart = max(1,cfg_seniority_index(max(NSOMOMin,Nsomo_I-4))) +!!! kend = idxI-1 +!!! else +!!! cycle +!!! endif +!!! else if(holetype(i) .EQ. 2 .AND. vmotype(j) .EQ. 1) then +!!! ! DOMO -> VMO +!!! !print *,'DOMO -> VMO', Isomop, p, q, Jsomop +!!! if(p_s .eq. q_s) then +!!! Jsomop = IBSET(Isomop,p-1) +!!! Jsomop = IBSET(Jsomop,q-1) +!!! Jsomoq = Jsomop +!!! else +!!! Jsomop = IBSET(Isomop,p-1) +!!! Jsomoq = IBSET(Jsomoq,q-1) +!!! endif +!!! !print *, 'Jsomop=', Jsomop +!!! +!!! Jdomop = IBCLR(Idomop,p-1) +!!! +!!! kstart = cfg_seniority_index(Nsomo_I) +!!! kend = idxI-1 +!!! else if(holetype(i) .EQ. 2 .AND. vmotype(j) .EQ. 2) then +!!! ! DOMO -> SOMO +!!! !print *,'DOMO -> SOMO' +!!! if(p_s .eq. q_s) then +!!! Jsomop = IBSET(Isomop,p-1) +!!! Jsomop = IBCLR(Jsomop,q-1) +!!! Jsomoq = Jsomop +!!! +!!! Jdomop = IBCLR(Idomop,p-1) +!!! Jdomop = IBSET(Jdomop,q-1) +!!! Jdomoq = Jdomop +!!! else +!!! Jsomop = IBSET(Isomop,p-1) +!!! Jsomoq = IBCLR(Jsomoq,q-1) +!!! +!!! Jdomop = IBCLR(Idomop,p-1) +!!! Jdomoq = IBSET(Jdomoq,q-1) +!!! endif +!!! +!!! kstart = max(1,cfg_seniority_index(max(NSOMOMin,Nsomo_I-2))) +!!! kend = idxI-1 +!!! else +!!! print*,"Something went wrong in obtain_associated_alphaI" +!!! endif +!!! +!!! ! Save it to Jcfg +!!! !print *,i,j,"0| nalpha=",NalphaIcfg, " somo=",Jcfg(1,1),Jcfg(2,1) +!!! Jcfg(p_s,1) = Jsomop +!!! Jcfg(q_s,1) = Jsomoq +!!! Jcfg(p_s,2) = Jdomop +!!! Jcfg(q_s,2) = Jdomoq +!!! !print *,'p_s=',p_s,' q_s=', q_s +!!! !print *,'Jsomop=',Jsomop, ' Jsomoq=', Jsomoq, ' Jdomop=', Jdomop, ' Jdomoq=', Jdomo +!!! !print *,i,j,"1| nalpha=",NalphaIcfg, " somo=",Jcfg(1,1),Jcfg(2,1) +!!! call bitstring_to_list(Jcfg(1,1),listall,nelall,N_int) +!!! Nsomo_J = nelall +!!! +!!! ! Check for Minimal alpha electrons (MS) +!!! if(Nsomo_J.lt.MS)then +!!! cycle +!!! endif +!!! +!!! ! Again, we don't have to search from 1 +!!! ! we just use seniority to find the +!!! ! first index with NSOMO - 2 to NSOMO + 2 +!!! ! this is what is done in kstart, kend +!!! +!!! pqAlreadyGenQ = .FALSE. +!!! ! First check if it can be generated before +!!! do k = kstart, kend +!!! !diffSOMO = IEOR(Jsomo,iand(reunion_of_act_virt_bitmask(1,1),psi_configuration(1,1,k))) +!!! !ndiffSOMO = POPCNT(diffSOMO) +!!! !if((ndiffSOMO .NE. 0) .AND. (ndiffSOMO .NE. 2)) cycle +!!! !diffDOMO = IEOR(Jdomo,iand(reunion_of_act_virt_bitmask(1,1),psi_configuration(1,2,k))) +!!! !xordiffSOMODOMO = IEOR(diffSOMO,diffDOMO) +!!! !ndiffDOMO = POPCNT(diffDOMO) +!!! !nxordiffSOMODOMO = POPCNT(xordiffSOMODOMO) +!!! !nxordiffSOMODOMO += ndiffSOMO + ndiffDOMO +!!! +!!! ndiffSOMO = 0 +!!! ndiffDOMO = 0 +!!! nxordiffSOMODOMO = 0 +!!! do ii = 1, N_int +!!! Jsomo = Jcfg(ii,1) +!!! Jdomo = Jcfg(ii,2) +!!! diffSOMO = IEOR(Jsomo,iand(reunion_of_act_virt_bitmask(ii,1),psi_configuration(ii,1,k))) +!!! ndiffSOMO += POPCNT(diffSOMO) +!!! diffDOMO = IEOR(Jdomo,iand(reunion_of_act_virt_bitmask(ii,2),psi_configuration(ii,2,k))) +!!! xordiffSOMODOMO = IEOR(diffSOMO,diffDOMO) +!!! ndiffDOMO += POPCNT(diffDOMO) +!!! nxordiffSOMODOMO += POPCNT(xordiffSOMODOMO) +!!! nxordiffSOMODOMO += ndiffSOMO + ndiffDOMO +!!! end do +!!! +!!! if((ndiffSOMO .ne. 0) .and. (ndiffSOMO .ne. 2)) cycle +!!! +!!! if((ndiffSOMO+ndiffDOMO) .EQ. 0) then +!!! pqAlreadyGenQ = .TRUE. +!!! ppExistsQ = .TRUE. +!!! EXIT +!!! endif +!!! if((nxordiffSOMODOMO .EQ. 4) .AND. ndiffSOMO .EQ. 2) then +!!! pqAlreadyGenQ = .TRUE. +!!! EXIT +!!! endif +!!! end do +!!! +!!! if(pqAlreadyGenQ) cycle +!!! +!!! pqExistsQ = .FALSE. +!!! +!!! if(.NOT. pqExistsQ) then +!!! tableUniqueAlphas(p,q) = .TRUE. +!!! endif +!!! end do +!!! end do +!!! +!!! !print *,tableUniqueAlphas(:,:) +!!! +!!! ! prune list of alphas +!!! Isomo = Icfg(1,1) +!!! Idomo = Icfg(1,2) +!!! Jsomo = Icfg(1,1) +!!! Jdomo = Icfg(1,2) +!!! NalphaIcfg = 0 +!!! do i = 1, nholes +!!! !p = listholes(i) +!!! pp = listholes(i) +!!! p_s = (1+((pp-1)/63)) +!!! p = pp - (p_s - 1)*63 +!!! do j = 1, nvmos +!!! !q = listvmos(j) +!!! qq = listvmos(j) +!!! q_s = (1+((qq-1)/63)) +!!! q = qq - (q_s - 1)*63 +!!! Isomop = iand(act_bitmask(i_s,1),Icfg(p_s,1)) +!!! Idomop = iand(act_bitmask(i_s,1),Icfg(p_s,2)) +!!! Isomoq = iand(act_bitmask(i_s,1),Icfg(q_s,1)) +!!! Idomoq = iand(act_bitmask(i_s,1),Icfg(q_s,2)) +!!! if(p .EQ. q) cycle +!!! if(tableUniqueAlphas(p,q)) then +!!! if(holetype(i) .EQ. 1 .AND. vmotype(j) .EQ. 1) then +!!! ! SOMO -> VMO +!!! !Jsomo = IBCLR(Isomo,p-1) +!!! !Jsomo = IBSET(Jsomo,q-1) +!!! !Jdomo = Idomo +!!! if (p_s .eq. q_s) then +!!! Jsomop = IBCLR(Isomop,p-1) +!!! Jsomop = IBSET(Jsomop,q-1) +!!! Jsomoq = Jsomop +!!! else +!!! Jsomop = IBCLR(Isomop,p-1) +!!! Jsomoq = IBSET(Isomoq,q-1) +!!! endif +!!! +!!! ! Domo remains the same +!!! Jdomop = Idomop +!!! Jdomoq = Idomoq +!!! +!!! else if(holetype(i) .EQ. 1 .AND. vmotype(j) .EQ. 2) then +!!! ! SOMO -> SOMO +!!! !Jsomo = IBCLR(Isomo,p-1) +!!! !Jsomo = IBCLR(Jsomo,q-1) +!!! !Jdomo = IBSET(Idomo,q-1) +!!! +!!! if(p_s .eq. q_s) then +!!! Jsomop = IBCLR(Isomop,p-1) +!!! Jsomop = IBCLR(Jsomop,q-1) +!!! Jsomoq = Jsomop +!!! else +!!! Jsomop = IBCLR(Isomop,p-1) +!!! Jsomoq = IBCLR(Isomoq,q-1) +!!! endif +!!! +!!! Jdomoq = IBSET(Idomoq,q-1) +!!! +!!! if(POPCNT(Jsomoq).ge.MS)then +!!! kstart = max(1,cfg_seniority_index(max(NSOMOMin,Nsomo_I-4))) +!!! kend = idxI-1 +!!! else +!!! cycle +!!! endif +!!! else if(holetype(i) .EQ. 2 .AND. vmotype(j) .EQ. 1) then +!!! ! DOMO -> VMO +!!! !Jsomo = IBSET(Isomo,p-1) +!!! !Jsomo = IBSET(Jsomo,q-1) +!!! !Jdomo = IBCLR(Idomo,p-1) +!!! +!!! if(p_s .eq. q_s) then +!!! Jsomop = IBSET(Isomop,p-1) +!!! Jsomop = IBSET(Jsomop,q-1) +!!! Jsomoq = Jsomop +!!! else +!!! Jsomop = IBSET(Isomop,p-1) +!!! Jsomoq = IBSET(Jsomoq,q-1) +!!! endif +!!! +!!! Jdomop = IBCLR(Idomop,p-1) +!!! +!!! else if(holetype(i) .EQ. 2 .AND. vmotype(j) .EQ. 2) then +!!! ! DOMO -> SOMO +!!! !Jsomo = IBSET(Isomo,p-1) +!!! !Jsomo = IBCLR(Jsomo,q-1) +!!! !Jdomo = IBCLR(Idomo,p-1) +!!! !Jdomo = IBSET(Jdomo,q-1) +!!! if(p_s .eq. q_s) then +!!! Jsomop = IBSET(Isomop,p-1) +!!! Jsomop = IBCLR(Jsomop,q-1) +!!! Jsomoq = Jsomop +!!! +!!! Jdomop = IBCLR(Idomop,p-1) +!!! Jdomop = IBSET(Jdomop,q-1) +!!! Jdomoq = Jdomop +!!! else +!!! Jsomop = IBSET(Isomop,p-1) +!!! Jsomoq = IBCLR(Jsomoq,q-1) +!!! +!!! Jdomop = IBCLR(Idomop,p-1) +!!! Jdomoq = IBSET(Jdomoq,q-1) +!!! endif +!!! +!!! else +!!! print*,"Something went wrong in obtain_associated_alphaI" +!!! endif +!!! +!!! ! Save it to Jcfg +!!! Jcfg(p_s,1) = Jsomop +!!! Jcfg(q_s,1) = Jsomoq +!!! Jcfg(p_s,2) = Jdomop +!!! Jcfg(q_s,2) = Jdomoq +!!! +!!! ! SOMO +!!! !print *,i,j,"|",NalphaIcfg, Jsomo, IOR(Jdomo,ISHFT(1_8,n_core_orb)-1) +!!! if(POPCNT(Jsomo) .ge. NSOMOMin) then +!!! NalphaIcfg += 1 +!!! alphasIcfg_list(:,1,idxI,NalphaIcfg) = Jcfg(:,1) +!!! !alphasIcfg_list(:,2,idxI,NalphaIcfg) = IOR(Jdomo,ISHFT(1_8,n_core_orb)-1) +!!! if(n_core_orb .le. 63)then +!!! alphasIcfg_list(1,2,idxI,NalphaIcfg) = IOR(Jcfg(1,2),ISHFT(1_8,n_core_orb)-1) +!!! else +!!! n_core_orb_64 = n_core_orb +!!! do ii=1,N_int +!!! if(n_core_orb_64 .gt. 0)then +!!! alphasIcfg_list(ii,2,idxI,NalphaIcfg) = IOR(Jcfg(ii,2),ISHFT(1_8,n_core_orb_64)-1) +!!! else +!!! alphasIcfg_list(ii,2,idxI,NalphaIcfg) = Jcfg(ii,2) +!!! endif +!!! n_core_orb_64 = ISHFT(n_core_orb_64,-6) +!!! end do +!!! endif +!!! NalphaIcfg_list(idxI) = NalphaIcfg +!!! !print *,i,j,"2| nalpha=",NalphaIcfg, " somo=",Jcfg(1,1),Jcfg(2,1) +!!! endif +!!! endif +!!! end do +!!! end do +!!! +!!! ! Check if this Icfg has been previously generated as a mono +!!! ppExistsQ = .False. +!!! Isomo = iand(reunion_of_act_virt_bitmask(1,1),Icfg(1,1)) +!!! Idomo = iand(reunion_of_act_virt_bitmask(1,1),Icfg(1,2)) +!!! kstart = max(1,cfg_seniority_index(max(NSOMOMin,Nsomo_I-2))) +!!! ndiffDOMO = 0 +!!! do k = kstart, idxI-1 +!!! do ii=1,N_int +!!! diffSOMO = IEOR(Icfg(ii,1),iand(act_bitmask(ii,1),psi_configuration(ii,1,k))) +!!! ndiffSOMO += POPCNT(diffSOMO) +!!! end do +!!! ! ndiffSOMO cannot be 0 (I /= k) +!!! ! if ndiffSOMO /= 2 then it has to be greater than 2 and hense +!!! ! this Icfg could not have been generated before. +!!! if (ndiffSOMO /= 2) cycle +!!! ndiffDOMO = 0 +!!! nxordiffSOMODOMO = 0 +!!! do ii=1,N_int +!!! diffDOMO = IEOR(Icfg(ii,2),iand(act_bitmask(ii,1),psi_configuration(ii,2,k))) +!!! xordiffSOMODOMO = IEOR(diffSOMO,diffDOMO) +!!! ndiffDOMO += POPCNT(diffDOMO) +!!! nxordiffSOMODOMO += POPCNT(xordiffSOMODOMO) +!!! end do +!!! if((ndiffSOMO+ndiffDOMO+nxordiffSOMODOMO .EQ. 4)) then +!!! ppExistsQ = .TRUE. +!!! EXIT +!!! endif +!!! end do +!!! ! Diagonal part (pp,qq) +!!! if(nholes > 0 .AND. (.NOT. ppExistsQ))then +!!! ! SOMO +!!! if(POPCNT(Jsomo) .ge. NSOMOMin) then +!!! NalphaIcfg += 1 +!!! alphasIcfg_list(:,1,idxI,NalphaIcfg) = Icfg(:,1) +!!! alphasIcfg_list(:,2,idxI,NalphaIcfg) = Icfg(:,2) +!!! NalphaIcfg_list(idxI) = NalphaIcfg +!!! endif +!!! endif +!!! +!!! NalphaIcfg = 0 +!!! enddo ! end loop idxI +!!! call wall_time(t1) +!!! print *, 'Preparation : ', t1 - t0 +!!! +!!!END_PROVIDER + BEGIN_PROVIDER [ integer(bit_kind), alphasIcfg_list , (N_int,2,N_configuration,mo_num*(mo_num))] &BEGIN_PROVIDER [ integer, NalphaIcfg_list, (N_configuration) ] implicit none @@ -21,18 +545,16 @@ use bitmasks integer :: nvmos integer :: listvmos(mo_num) integer :: vmotype(mo_num) ! 1 -> VMO 2 -> SOMO - integer*8 :: Idomo, Idomop, Idomoq - integer*8 :: Isomo, Isomop, Isomoq - integer*8 :: Jdomo, Jdomop, Jdomoq - integer*8 :: Jsomo, Jsomop, Jsomoq - integer*8 :: diffSOMO - integer*8 :: diffDOMO - integer*8 :: xordiffSOMODOMO + integer(bit_kind) :: Idomo(N_int), Idomop(N_int), Idomoq(N_int) + integer(bit_kind) :: Isomo(N_int), Isomop(N_int), Isomoq(N_int) + integer(bit_kind) :: Jdomo(N_int), Jdomop(N_int), Jdomoq(N_int) + integer(bit_kind) :: Jsomo(N_int), Jsomop(N_int), Jsomoq(N_int) + integer(bit_kind) :: diffDOMO(N_int), xordiffSOMODOMO(N_int), diffSOMO(N_int) integer :: ndiffSOMO integer :: ndiffDOMO integer :: nxordiffSOMODOMO integer :: ndiffAll - integer :: i,ii,iii + integer :: i,ii,iii, iint, jint, ipos, jpos integer :: j,jj, i_s, i_d integer :: k,kk integer :: kstart @@ -60,56 +582,30 @@ use bitmasks Icfg = psi_configuration(:,:,idxI) Jcfg = psi_configuration(:,:,idxI) - !print *," Jcfg somo=",Jcfg(1,1), " ", Jcfg(2,1) - !print *," Jcfg domo=",Jcfg(1,2), " ", Jcfg(2,2) - Isomo = iand(act_bitmask(1,1),Icfg(1,1)) - Idomo = iand(act_bitmask(1,1),Icfg(1,2)) + do i=1, N_int + Isomo(i) = iand(act_bitmask(i,1),Icfg(i,1)) + Idomo(i) = iand(act_bitmask(i,1),Icfg(i,2)) + enddo ! find out all pq holes possible nholes = 0 - ! holes in SOMO - !do ii = 1,n_act_orb - ! i = list_act(ii) - ! if(POPCNT(IAND(Isomo,IBSET(0_8,i-1))) .EQ. 1) then - ! nholes += 1 - ! listholes(nholes) = i - ! holetype(nholes) = 1 - ! endif - !end do - call bitstring_to_list(psi_configuration(1,1,idxI),listall,nelall,N_int) + call bitstring_to_list(Isomo,listall,nelall,N_int) - !print *,'list somo' do iii=1,nelall nholes += 1 listholes(nholes) = listall(iii) - !print *,listall(iii) holetype(nholes) = 1 end do Nsomo_I = nelall - ! holes in DOMO - !do ii = 1,n_act_orb - ! i = list_act(ii) - ! if(POPCNT(IAND(Idomo,IBSET(0_8,i-1))) .EQ. 1) then - ! nholes += 1 - ! listholes(nholes) = i - ! holetype(nholes) = 2 - ! endif - !end do + call bitstring_to_list(Idomo,listall,nelall,N_int) - !do iii=1,N_int - ! print *,' iii=',iii, psi_configuration(iii,2,idxI), ' idxI=',idxI - !end do - call bitstring_to_list(psi_configuration(1,2,idxI),listall,nelall,N_int) - - !print *,'list domo ncore=',n_core_orb, ' nelall=',nelall do iii=1,nelall if(listall(iii) .gt. n_core_orb)then nholes += 1 listholes(nholes) = listall(iii) - !print *,listall(iii) holetype(nholes) = 2 endif end do @@ -118,38 +614,19 @@ use bitmasks listvmos = -1 vmotype = -1 nvmos = 0 - !do ii = 1,n_act_orb - ! i = list_act(ii) - ! if(IAND(Idomo,(IBSET(0_8,i-1))) .EQ. 0) then - ! if(IAND(Isomo,(IBSET(0_8,i-1))) .EQ. 0) then - ! nvmos += 1 - ! listvmos(nvmos) = i - ! print *,'1 i=',i - ! vmotype(nvmos) = 1 - ! else if(POPCNT(IAND(Isomo,(IBSET(0_8,i-1)))) .EQ. 1) then - ! nvmos += 1 - ! listvmos(nvmos) = i - ! print *,'2 i=',i - ! vmotype(nvmos) = 2 - ! end if - ! end if - !end do - !print *,'-----------' ! Take into account N_int do ii = 1, n_act_orb iii = list_act(ii) - i_s = (1+((iii-1)/63)) - i = iii - ( i_s -1 )*63 - Isomo = iand(act_bitmask(i_s,1),Icfg(i_s,1)) - Idomo = iand(act_bitmask(i_s,1),Icfg(i_s,2)) + iint = shiftr(iii-1,bit_kind_shift) + 1 + ipos = iii-shiftl((iint-1),bit_kind_shift)-1 - if(IAND(Idomo,(IBSET(0_8,i-1))) .EQ. 0) then - if(IAND(Isomo,(IBSET(0_8,i-1))) .EQ. 0) then + if(IAND(Idomo(iint),(IBSET(0_8,ipos))) .EQ. 0) then + if(IAND(Isomo(iint),(IBSET(0_8,ipos))) .EQ. 0) then nvmos += 1 listvmos(nvmos) = iii vmotype(nvmos) = 1 - else if(POPCNT(IAND(Isomo,(IBSET(0_8,i-1)))) .EQ. 1) then + else if(POPCNT(IAND(Isomo(iint),(IBSET(0_8,ipos)))) .EQ. 1) then nvmos += 1 listvmos(nvmos) = iii vmotype(nvmos) = 2 @@ -160,9 +637,13 @@ use bitmasks tableUniqueAlphas = .FALSE. ! Now find the allowed (p,q) excitations - Isomo = iand(act_bitmask(1,1),Icfg(1,1)) - Idomo = iand(act_bitmask(1,1),Icfg(1,2)) - !Nsomo_I = POPCNT(Isomo) + do i=1, N_int + Isomo(i) = iand(act_bitmask(i,1),Icfg(i,1)) + Idomo(i) = iand(act_bitmask(i,1),Icfg(i,2)) + Jsomo(i) = Isomo(i) + Jdomo(i) = Idomo(i) + enddo + if(Nsomo_I .EQ. 0) then kstart = 1 else @@ -172,110 +653,25 @@ use bitmasks do i = 1,nholes pp = listholes(i) - p_s = (1+((pp-1)/63)) - p = pp - (p_s - 1)*63 - !print *,' pp=',pp, ' p_s=',p_s, ' p=',p + iint = shiftr(pp-1,bit_kind_shift) + 1 + ipos = pp-shiftl((iint-1),bit_kind_shift)-1 + if(holetype(i) == 1)then + Jsomo(iint) = IBCLR(Jsomo(iint),ipos) + else if(holetype(i) == 2)then + Jdomo(iint) = IBCLR(Jdomo(iint),ipos) + endif + do j = 1,nvmos qq = listvmos(j) - q_s = (1+((qq-1)/63)) - q = qq - (q_s - 1)*63 - !print *,' qq=',qq, ' q_s=',q_s, ' q=',q - Isomop = iand(act_bitmask(i_s,1),Icfg(p_s,1)) - Idomop = iand(act_bitmask(i_s,1),Icfg(p_s,2)) - Isomop = iand(act_bitmask(i_s,1),Icfg(q_s,1)) - Idomop = iand(act_bitmask(i_s,1),Icfg(q_s,2)) - if(p .EQ. q) cycle - if(holetype(i) .EQ. 1 .AND. vmotype(j) .EQ. 1) then - ! SOMO -> VMO - !print *,'SOMO -> VMO' - if (p_s .eq. q_s) then - Jsomop = IBCLR(Isomop,p-1) - Jsomop = IBSET(Jsomop,q-1) - Jsomoq = Jsomop - else - Jsomop = IBCLR(Isomop,p-1) - Jsomoq = IBSET(Isomoq,q-1) - endif - - ! Domo remains the same - Jdomop = Idomop - Jdomoq = Idomoq - - kstart = max(1,cfg_seniority_index(max(NSOMOMin,Nsomo_I-2))) - kend = idxI-1 - else if(holetype(i) .EQ. 1 .AND. vmotype(j) .EQ. 2) then - ! SOMO -> SOMO - !print *,'SOMO -> SOMO' - if(p_s .eq. q_s) then - Jsomop = IBCLR(Isomop,p-1) - Jsomop = IBCLR(Jsomop,q-1) - Jsomoq = Jsomop - else - Jsomop = IBCLR(Isomop,p-1) - Jsomoq = IBCLR(Isomoq,q-1) - endif - - Jdomoq = IBSET(Idomoq,q-1) - - ! Check for Minimal alpha electrons (MS) - if(POPCNT(Jsomoq).ge.MS)then - kstart = max(1,cfg_seniority_index(max(NSOMOMin,Nsomo_I-4))) - kend = idxI-1 - else - cycle - endif - else if(holetype(i) .EQ. 2 .AND. vmotype(j) .EQ. 1) then - ! DOMO -> VMO - !print *,'DOMO -> VMO', Isomop, p, q, Jsomop - if(p_s .eq. q_s) then - Jsomop = IBSET(Isomop,p-1) - Jsomop = IBSET(Jsomop,q-1) - Jsomoq = Jsomop - else - Jsomop = IBSET(Isomop,p-1) - Jsomoq = IBSET(Jsomoq,q-1) - endif - !print *, 'Jsomop=', Jsomop - - Jdomop = IBCLR(Idomop,p-1) - - kstart = cfg_seniority_index(Nsomo_I) - kend = idxI-1 - else if(holetype(i) .EQ. 2 .AND. vmotype(j) .EQ. 2) then - ! DOMO -> SOMO - !print *,'DOMO -> SOMO' - if(p_s .eq. q_s) then - Jsomop = IBSET(Isomop,p-1) - Jsomop = IBCLR(Jsomop,q-1) - Jsomoq = Jsomop - - Jdomop = IBCLR(Idomop,p-1) - Jdomop = IBSET(Jdomop,q-1) - Jdomoq = Jdomop - else - Jsomop = IBSET(Isomop,p-1) - Jsomoq = IBCLR(Jsomoq,q-1) - - Jdomop = IBCLR(Idomop,p-1) - Jdomoq = IBSET(Jdomoq,q-1) - endif - - kstart = max(1,cfg_seniority_index(max(NSOMOMin,Nsomo_I-2))) - kend = idxI-1 - else - print*,"Something went wrong in obtain_associated_alphaI" + jint = shiftr(qq-1,bit_kind_shift) + 1 + jpos = qq-shiftl((iint-1),bit_kind_shift)-1 + if(vmotype(j) == 1)then + Jsomo(jint) = IBSET(Jsomo(jint),jpos) + else if(vmotype(j) == 2)then + Jdomo(jint) = IBSET(Jdomo(jint),jpos) endif - ! Save it to Jcfg - !print *,i,j,"0| nalpha=",NalphaIcfg, " somo=",Jcfg(1,1),Jcfg(2,1) - Jcfg(p_s,1) = Jsomop - Jcfg(q_s,1) = Jsomoq - Jcfg(p_s,2) = Jdomop - Jcfg(q_s,2) = Jdomoq - !print *,'p_s=',p_s,' q_s=', q_s - !print *,'Jsomop=',Jsomop, ' Jsomoq=', Jsomoq, ' Jdomop=', Jdomop, ' Jdomoq=', Jdomo - !print *,i,j,"1| nalpha=",NalphaIcfg, " somo=",Jcfg(1,1),Jcfg(2,1) - call bitstring_to_list(Jcfg(1,1),listall,nelall,N_int) + call bitstring_to_list(Jcfg,listall,nelall,N_int) Nsomo_J = nelall ! Check for Minimal alpha electrons (MS) @@ -291,15 +687,6 @@ use bitmasks pqAlreadyGenQ = .FALSE. ! First check if it can be generated before do k = kstart, kend - !diffSOMO = IEOR(Jsomo,iand(reunion_of_act_virt_bitmask(1,1),psi_configuration(1,1,k))) - !ndiffSOMO = POPCNT(diffSOMO) - !if((ndiffSOMO .NE. 0) .AND. (ndiffSOMO .NE. 2)) cycle - !diffDOMO = IEOR(Jdomo,iand(reunion_of_act_virt_bitmask(1,1),psi_configuration(1,2,k))) - !xordiffSOMODOMO = IEOR(diffSOMO,diffDOMO) - !ndiffDOMO = POPCNT(diffDOMO) - !nxordiffSOMODOMO = POPCNT(xordiffSOMODOMO) - !nxordiffSOMODOMO += ndiffSOMO + ndiffDOMO - ndiffSOMO = 0 ndiffDOMO = 0 nxordiffSOMODOMO = 0 @@ -307,11 +694,11 @@ use bitmasks Jsomo = Jcfg(ii,1) Jdomo = Jcfg(ii,2) diffSOMO = IEOR(Jsomo,iand(reunion_of_act_virt_bitmask(ii,1),psi_configuration(ii,1,k))) - ndiffSOMO += POPCNT(diffSOMO) + ndiffSOMO += POPCNT(diffSOMO(ii)) diffDOMO = IEOR(Jdomo,iand(reunion_of_act_virt_bitmask(ii,2),psi_configuration(ii,2,k))) xordiffSOMODOMO = IEOR(diffSOMO,diffDOMO) - ndiffDOMO += POPCNT(diffDOMO) - nxordiffSOMODOMO += POPCNT(xordiffSOMODOMO) + ndiffDOMO += POPCNT(diffDOMO(ii)) + nxordiffSOMODOMO += POPCNT(xordiffSOMODOMO(ii)) nxordiffSOMODOMO += ndiffSOMO + ndiffDOMO end do @@ -335,7 +722,19 @@ use bitmasks if(.NOT. pqExistsQ) then tableUniqueAlphas(p,q) = .TRUE. endif + + + if(vmotype(j) == 1)then + Jsomo(jint) = IBCLR(Jsomo(jint),jpos) + else if(vmotype(j) == 2)then + Jdomo(jint) = IBCLR(Jdomo(jint),jpos) + endif end do + if(holetype(i) == 1)then + Jsomo(iint) = IBSET(Jsomo(iint),ipos) + else if(holetype(i) == 2)then + Jdomo(iint) = IBSET(Jdomo(iint),ipos) + endif end do !print *,tableUniqueAlphas(:,:) @@ -347,117 +746,33 @@ use bitmasks Jdomo = Icfg(1,2) NalphaIcfg = 0 do i = 1, nholes - !p = listholes(i) pp = listholes(i) - p_s = (1+((pp-1)/63)) - p = pp - (p_s - 1)*63 + iint = shiftr(pp-1,bit_kind_shift) + 1 + ipos = pp-shiftl((iint-1),bit_kind_shift)-1 + if(holetype(i) == 1)then + Jsomo(iint) = IBCLR(Jsomo(iint),ipos) + else if(holetype(i) == 2)then + Jdomo(iint) = IBCLR(Jdomo(iint),ipos) + endif + do j = 1, nvmos - !q = listvmos(j) qq = listvmos(j) - q_s = (1+((qq-1)/63)) - q = qq - (q_s - 1)*63 - Isomop = iand(act_bitmask(i_s,1),Icfg(p_s,1)) - Idomop = iand(act_bitmask(i_s,1),Icfg(p_s,2)) - Isomoq = iand(act_bitmask(i_s,1),Icfg(q_s,1)) - Idomoq = iand(act_bitmask(i_s,1),Icfg(q_s,2)) - if(p .EQ. q) cycle - if(tableUniqueAlphas(p,q)) then - if(holetype(i) .EQ. 1 .AND. vmotype(j) .EQ. 1) then - ! SOMO -> VMO - !Jsomo = IBCLR(Isomo,p-1) - !Jsomo = IBSET(Jsomo,q-1) - !Jdomo = Idomo - if (p_s .eq. q_s) then - Jsomop = IBCLR(Isomop,p-1) - Jsomop = IBSET(Jsomop,q-1) - Jsomoq = Jsomop - else - Jsomop = IBCLR(Isomop,p-1) - Jsomoq = IBSET(Isomoq,q-1) - endif + jint = shiftr(qq-1,bit_kind_shift) + 1 + jpos = qq-shiftl((iint-1),bit_kind_shift)-1 + if(vmotype(j) == 1)then + Jsomo(jint) = IBSET(Jsomo(jint),jpos) + else if(vmotype(j) == 2)then + Jdomo(jint) = IBSET(Jdomo(jint),jpos) + endif + if(pp .EQ. qq) cycle + if(tableUniqueAlphas(pp,qq)) then - ! Domo remains the same - Jdomop = Idomop - Jdomoq = Idomoq + call bitstring_to_list(Jcfg,listall,nelall,N_int) + Nsomo_J = nelall - else if(holetype(i) .EQ. 1 .AND. vmotype(j) .EQ. 2) then - ! SOMO -> SOMO - !Jsomo = IBCLR(Isomo,p-1) - !Jsomo = IBCLR(Jsomo,q-1) - !Jdomo = IBSET(Idomo,q-1) - - if(p_s .eq. q_s) then - Jsomop = IBCLR(Isomop,p-1) - Jsomop = IBCLR(Jsomop,q-1) - Jsomoq = Jsomop - else - Jsomop = IBCLR(Isomop,p-1) - Jsomoq = IBCLR(Isomoq,q-1) - endif - - Jdomoq = IBSET(Idomoq,q-1) - - if(POPCNT(Jsomoq).ge.MS)then - kstart = max(1,cfg_seniority_index(max(NSOMOMin,Nsomo_I-4))) - kend = idxI-1 - else - cycle - endif - else if(holetype(i) .EQ. 2 .AND. vmotype(j) .EQ. 1) then - ! DOMO -> VMO - !Jsomo = IBSET(Isomo,p-1) - !Jsomo = IBSET(Jsomo,q-1) - !Jdomo = IBCLR(Idomo,p-1) - - if(p_s .eq. q_s) then - Jsomop = IBSET(Isomop,p-1) - Jsomop = IBSET(Jsomop,q-1) - Jsomoq = Jsomop - else - Jsomop = IBSET(Isomop,p-1) - Jsomoq = IBSET(Jsomoq,q-1) - endif - - Jdomop = IBCLR(Idomop,p-1) - - else if(holetype(i) .EQ. 2 .AND. vmotype(j) .EQ. 2) then - ! DOMO -> SOMO - !Jsomo = IBSET(Isomo,p-1) - !Jsomo = IBCLR(Jsomo,q-1) - !Jdomo = IBCLR(Idomo,p-1) - !Jdomo = IBSET(Jdomo,q-1) - if(p_s .eq. q_s) then - Jsomop = IBSET(Isomop,p-1) - Jsomop = IBCLR(Jsomop,q-1) - Jsomoq = Jsomop - - Jdomop = IBCLR(Idomop,p-1) - Jdomop = IBSET(Jdomop,q-1) - Jdomoq = Jdomop - else - Jsomop = IBSET(Isomop,p-1) - Jsomoq = IBCLR(Jsomoq,q-1) - - Jdomop = IBCLR(Idomop,p-1) - Jdomoq = IBSET(Jdomoq,q-1) - endif - - else - print*,"Something went wrong in obtain_associated_alphaI" - endif - - ! Save it to Jcfg - Jcfg(p_s,1) = Jsomop - Jcfg(q_s,1) = Jsomoq - Jcfg(p_s,2) = Jdomop - Jcfg(q_s,2) = Jdomoq - - ! SOMO - !print *,i,j,"|",NalphaIcfg, Jsomo, IOR(Jdomo,ISHFT(1_8,n_core_orb)-1) - if(POPCNT(Jsomo) .ge. NSOMOMin) then + if(Nsomo_J .ge. NSOMOMin) then NalphaIcfg += 1 alphasIcfg_list(:,1,idxI,NalphaIcfg) = Jcfg(:,1) - !alphasIcfg_list(:,2,idxI,NalphaIcfg) = IOR(Jdomo,ISHFT(1_8,n_core_orb)-1) if(n_core_orb .le. 63)then alphasIcfg_list(1,2,idxI,NalphaIcfg) = IOR(Jcfg(1,2),ISHFT(1_8,n_core_orb)-1) else @@ -472,22 +787,35 @@ use bitmasks end do endif NalphaIcfg_list(idxI) = NalphaIcfg - !print *,i,j,"2| nalpha=",NalphaIcfg, " somo=",Jcfg(1,1),Jcfg(2,1) endif endif + + if(vmotype(j) == 1)then + Jsomo(jint) = IBCLR(Jsomo(jint),jpos) + else if(vmotype(j) == 2)then + Jdomo(jint) = IBCLR(Jdomo(jint),jpos) + endif end do + if(holetype(i) == 1)then + Jsomo(iint) = IBSET(Jsomo(iint),ipos) + else if(holetype(i) == 2)then + Jdomo(iint) = IBSET(Jdomo(iint),ipos) + endif end do ! Check if this Icfg has been previously generated as a mono ppExistsQ = .False. - Isomo = iand(reunion_of_act_virt_bitmask(1,1),Icfg(1,1)) - Idomo = iand(reunion_of_act_virt_bitmask(1,1),Icfg(1,2)) + do i=1, N_int + Isomo(i) = iand(act_bitmask(i,1),Icfg(i,1)) + Idomo(i) = iand(act_bitmask(i,1),Icfg(i,2)) + enddo + kstart = max(1,cfg_seniority_index(max(NSOMOMin,Nsomo_I-2))) ndiffDOMO = 0 do k = kstart, idxI-1 do ii=1,N_int diffSOMO = IEOR(Icfg(ii,1),iand(act_bitmask(ii,1),psi_configuration(ii,1,k))) - ndiffSOMO += POPCNT(diffSOMO) + ndiffSOMO += POPCNT(diffSOMO(ii)) end do ! ndiffSOMO cannot be 0 (I /= k) ! if ndiffSOMO /= 2 then it has to be greater than 2 and hense @@ -498,8 +826,8 @@ use bitmasks do ii=1,N_int diffDOMO = IEOR(Icfg(ii,2),iand(act_bitmask(ii,1),psi_configuration(ii,2,k))) xordiffSOMODOMO = IEOR(diffSOMO,diffDOMO) - ndiffDOMO += POPCNT(diffDOMO) - nxordiffSOMODOMO += POPCNT(xordiffSOMODOMO) + ndiffDOMO += POPCNT(diffDOMO(ii)) + nxordiffSOMODOMO += POPCNT(xordiffSOMODOMO(ii)) end do if((ndiffSOMO+ndiffDOMO+nxordiffSOMODOMO .EQ. 4)) then ppExistsQ = .TRUE. @@ -509,7 +837,7 @@ use bitmasks ! Diagonal part (pp,qq) if(nholes > 0 .AND. (.NOT. ppExistsQ))then ! SOMO - if(POPCNT(Jsomo) .ge. NSOMOMin) then + if(Nsomo_I .ge. NSOMOMin) then NalphaIcfg += 1 alphasIcfg_list(:,1,idxI,NalphaIcfg) = Icfg(:,1) alphasIcfg_list(:,2,idxI,NalphaIcfg) = Icfg(:,2) From 57bb5ed4dd6812e030e02e6208d96711650fa63e Mon Sep 17 00:00:00 2001 From: v1j4y Date: Wed, 23 Nov 2022 12:10:22 +0100 Subject: [PATCH 04/21] Remove orthoqr csf. --- src/csf/cfgCI_utils.c | 36 ++--- src/utils/linear_algebra.irp.f | 256 ++++++++++++++++----------------- 2 files changed, 146 insertions(+), 146 deletions(-) diff --git a/src/csf/cfgCI_utils.c b/src/csf/cfgCI_utils.c index 76b64dd0..5807375a 100644 --- a/src/csf/cfgCI_utils.c +++ b/src/csf/cfgCI_utils.c @@ -253,25 +253,25 @@ void generateAllBFs(int64_t Isomo, int64_t MS, Tree *bftree, int *NBF, int *NSOM buildTreeDriver(bftree, *NSOMO, MS, NBF); } -void ortho_qr_csf(double *overlapMatrix, int lda, double *orthoMatrix, int rows, int cols); +//void ortho_qr_csf(double *overlapMatrix, int lda, double *orthoMatrix, int rows, int cols); -void gramSchmidt_qp(double *overlapMatrix, int rows, int cols, double *orthoMatrix){ - int i,j; - //for(j=0;j 2147483648 - LWORK=max(n,int(WORK(1))) - - deallocate(WORK) - allocate(WORK(LWORK)) - call dgeqp3(m, n, A, LDA, jpvt, TAU, WORK, LWORK, INFO ) - print *,A - print *,jpvt - deallocate(WORK,TAU) - !stop - - !LWORK=-1 - !call dgeqrf( m, n, A, LDA, TAU, WORK, LWORK, INFO ) - !! /!\ int(WORK(1)) becomes negative when WORK(1) > 2147483648 - !LWORK=max(n,int(WORK(1))) - - !deallocate(WORK) - !allocate(WORK(LWORK)) - !call dgeqrf(m, n, A, LDA, TAU, WORK, LWORK, INFO ) - - !LWORK=-1 - !call dorgqr(m, n, n, A, LDA, TAU, WORK, LWORK, INFO) - !! /!\ int(WORK(1)) becomes negative when WORK(1) > 2147483648 - !LWORK=max(n,int(WORK(1))) - - !deallocate(WORK) - !allocate(WORK(LWORK)) - !call dorgqr(m, n, n, A, LDA, TAU, WORK, LWORK, INFO) - ! - !allocate(C(LDA,n)) - !call dgemm('N','N',m,n,n,1.0d0,B,LDA,A,LDA,0.0d0,C,LDA) - !norm = 0.0d0 - !B = 0.0d0 - !!print *,C - !do i=1,m - ! norm = 0.0d0 - ! do j=1,n - ! norm = norm + C(j,i)*C(j,i) - ! end do - ! norm = 1.0d0/dsqrt(norm) - ! do j=1,n - ! B(j,i) = C(j,i) - ! end do - !end do - !print *,B - - - !deallocate(WORK,TAU) -end - -subroutine ortho_qr_csf(A, LDA, B, m, n) bind(C, name="ortho_qr_csf") - use iso_c_binding - integer(c_int32_t), value :: LDA - integer(c_int32_t), value :: m - integer(c_int32_t), value :: n - integer(c_int16_t) :: A(LDA,n) - integer(c_int16_t) :: B(LDA,n) - call ortho_qr_withB(A,LDA,B,m,n) -end subroutine ortho_qr_csf +!! +!!subroutine ortho_qr_withB(A,LDA,B,m,n) +!! implicit none +!! BEGIN_DOC +!! ! Orthogonalization using Q.R factorization +!! ! +!! ! A : Overlap Matrix +!! ! +!! ! LDA : leftmost dimension of A +!! ! +!! ! m : Number of rows of A +!! ! +!! ! n : Number of columns of A +!! ! +!! ! B : Output orthogonal basis +!! ! +!! END_DOC +!! integer, intent(in) :: m,n, LDA +!! double precision, intent(inout) :: A(LDA,n) +!! double precision, intent(inout) :: B(LDA,n) +!! +!! integer :: LWORK, INFO +!! integer, allocatable :: jpvt(:) +!! double precision, allocatable :: TAU(:), WORK(:) +!! double precision, allocatable :: C(:,:) +!! double precision :: norm +!! integer :: i,j +!! +!! allocate (TAU(min(m,n)), WORK(1)) +!! allocate (jpvt(n)) +!! !print *," In function ortho" +!! B = A +!! +!! jpvt(1:n)=1 +!! +!! LWORK=-1 +!! call dgeqp3( m, n, A, LDA, jpvt, TAU, WORK, LWORK, INFO ) +!! +!! ! /!\ int(WORK(1)) becomes negative when WORK(1) > 2147483648 +!! LWORK=max(n,int(WORK(1))) +!! +!! deallocate(WORK) +!! allocate(WORK(LWORK)) +!! call dgeqp3(m, n, A, LDA, jpvt, TAU, WORK, LWORK, INFO ) +!! print *,A +!! print *,jpvt +!! deallocate(WORK,TAU) +!! !stop +!! +!! !LWORK=-1 +!! !call dgeqrf( m, n, A, LDA, TAU, WORK, LWORK, INFO ) +!! !! /!\ int(WORK(1)) becomes negative when WORK(1) > 2147483648 +!! !LWORK=max(n,int(WORK(1))) +!! +!! !deallocate(WORK) +!! !allocate(WORK(LWORK)) +!! !call dgeqrf(m, n, A, LDA, TAU, WORK, LWORK, INFO ) +!! +!! !LWORK=-1 +!! !call dorgqr(m, n, n, A, LDA, TAU, WORK, LWORK, INFO) +!! !! /!\ int(WORK(1)) becomes negative when WORK(1) > 2147483648 +!! !LWORK=max(n,int(WORK(1))) +!! +!! !deallocate(WORK) +!! !allocate(WORK(LWORK)) +!! !call dorgqr(m, n, n, A, LDA, TAU, WORK, LWORK, INFO) +!! ! +!! !allocate(C(LDA,n)) +!! !call dgemm('N','N',m,n,n,1.0d0,B,LDA,A,LDA,0.0d0,C,LDA) +!! !norm = 0.0d0 +!! !B = 0.0d0 +!! !!print *,C +!! !do i=1,m +!! ! norm = 0.0d0 +!! ! do j=1,n +!! ! norm = norm + C(j,i)*C(j,i) +!! ! end do +!! ! norm = 1.0d0/dsqrt(norm) +!! ! do j=1,n +!! ! B(j,i) = C(j,i) +!! ! end do +!! !end do +!! !print *,B +!! +!! +!! !deallocate(WORK,TAU) +!!end +!! +!!subroutine ortho_qr_csf(A, LDA, B, m, n) bind(C, name="ortho_qr_csf") +!! use iso_c_binding +!! integer(c_int32_t), value :: LDA +!! integer(c_int32_t), value :: m +!! integer(c_int32_t), value :: n +!! integer(c_int16_t) :: A(LDA,n) +!! integer(c_int16_t) :: B(LDA,n) +!! call ortho_qr_withB(A,LDA,B,m,n) +!!end subroutine ortho_qr_csf subroutine ortho_qr(A,LDA,m,n) implicit none From 677c6a6324f5366bb621ed68c88dedff4a23f39b Mon Sep 17 00:00:00 2001 From: v1j4y Date: Wed, 23 Nov 2022 13:58:32 +0100 Subject: [PATCH 05/21] Remove double comment. --- src/utils/linear_algebra.irp.f | 256 ++++++++++++++++----------------- 1 file changed, 128 insertions(+), 128 deletions(-) diff --git a/src/utils/linear_algebra.irp.f b/src/utils/linear_algebra.irp.f index d1abf87b..aa1bde97 100644 --- a/src/utils/linear_algebra.irp.f +++ b/src/utils/linear_algebra.irp.f @@ -458,37 +458,37 @@ subroutine ortho_canonical_complex(overlap,LDA,N,C,LDC,m,cutoff) end -!!subroutine ortho_qr_complex(A,LDA,m,n) -!! implicit none -!! BEGIN_DOC -!! ! Orthogonalization using Q.R factorization -!! ! -!! ! A : matrix to orthogonalize -!! ! -!! ! LDA : leftmost dimension of A -!! ! -!! ! n : Number of rows of A -!! ! -!! ! m : Number of columns of A -!! ! -!! END_DOC -!! integer, intent(in) :: m,n, LDA -!! complex*16, intent(inout) :: A(LDA,n) -!! -!! integer :: lwork, info -!! integer, allocatable :: jpvt(:) -!! complex*16, allocatable :: tau(:), work(:) -!! -!! allocate (jpvt(n), tau(n), work(1)) -!! LWORK=-1 -!! call zgeqrf( m, n, A, LDA, TAU, WORK, LWORK, INFO ) -!! LWORK=2*int(WORK(1)) -!! deallocate(WORK) -!! allocate(WORK(LWORK)) -!! call zgeqrf(m, n, A, LDA, TAU, WORK, LWORK, INFO ) -!! call zungqr(m, n, n, A, LDA, tau, WORK, LWORK, INFO) -!! deallocate(WORK,jpvt,tau) -!!end +subroutine ortho_qr_complex(A,LDA,m,n) + implicit none + BEGIN_DOC + ! Orthogonalization using Q.R factorization + ! + ! A : matrix to orthogonalize + ! + ! LDA : leftmost dimension of A + ! + ! n : Number of rows of A + ! + ! m : Number of columns of A + ! + END_DOC + integer, intent(in) :: m,n, LDA + complex*16, intent(inout) :: A(LDA,n) + + integer :: lwork, info + integer, allocatable :: jpvt(:) + complex*16, allocatable :: tau(:), work(:) + + allocate (jpvt(n), tau(n), work(1)) + LWORK=-1 + call zgeqrf( m, n, A, LDA, TAU, WORK, LWORK, INFO ) + LWORK=2*int(WORK(1)) + deallocate(WORK) + allocate(WORK(LWORK)) + call zgeqrf(m, n, A, LDA, TAU, WORK, LWORK, INFO ) + call zungqr(m, n, n, A, LDA, tau, WORK, LWORK, INFO) + deallocate(WORK,jpvt,tau) +end subroutine ortho_qr_unblocked_complex(A,LDA,m,n) implicit none @@ -1132,103 +1132,103 @@ subroutine ortho_svd(A,LDA,m,n) deallocate(U,D, Vt) end -!! -!!subroutine ortho_qr_withB(A,LDA,B,m,n) -!! implicit none -!! BEGIN_DOC -!! ! Orthogonalization using Q.R factorization -!! ! -!! ! A : Overlap Matrix -!! ! -!! ! LDA : leftmost dimension of A -!! ! -!! ! m : Number of rows of A -!! ! -!! ! n : Number of columns of A -!! ! -!! ! B : Output orthogonal basis -!! ! -!! END_DOC -!! integer, intent(in) :: m,n, LDA -!! double precision, intent(inout) :: A(LDA,n) -!! double precision, intent(inout) :: B(LDA,n) -!! -!! integer :: LWORK, INFO -!! integer, allocatable :: jpvt(:) -!! double precision, allocatable :: TAU(:), WORK(:) -!! double precision, allocatable :: C(:,:) -!! double precision :: norm -!! integer :: i,j -!! -!! allocate (TAU(min(m,n)), WORK(1)) -!! allocate (jpvt(n)) -!! !print *," In function ortho" -!! B = A -!! -!! jpvt(1:n)=1 -!! -!! LWORK=-1 -!! call dgeqp3( m, n, A, LDA, jpvt, TAU, WORK, LWORK, INFO ) -!! -!! ! /!\ int(WORK(1)) becomes negative when WORK(1) > 2147483648 -!! LWORK=max(n,int(WORK(1))) -!! -!! deallocate(WORK) -!! allocate(WORK(LWORK)) -!! call dgeqp3(m, n, A, LDA, jpvt, TAU, WORK, LWORK, INFO ) -!! print *,A -!! print *,jpvt -!! deallocate(WORK,TAU) -!! !stop -!! -!! !LWORK=-1 -!! !call dgeqrf( m, n, A, LDA, TAU, WORK, LWORK, INFO ) -!! !! /!\ int(WORK(1)) becomes negative when WORK(1) > 2147483648 -!! !LWORK=max(n,int(WORK(1))) -!! -!! !deallocate(WORK) -!! !allocate(WORK(LWORK)) -!! !call dgeqrf(m, n, A, LDA, TAU, WORK, LWORK, INFO ) -!! -!! !LWORK=-1 -!! !call dorgqr(m, n, n, A, LDA, TAU, WORK, LWORK, INFO) -!! !! /!\ int(WORK(1)) becomes negative when WORK(1) > 2147483648 -!! !LWORK=max(n,int(WORK(1))) -!! -!! !deallocate(WORK) -!! !allocate(WORK(LWORK)) -!! !call dorgqr(m, n, n, A, LDA, TAU, WORK, LWORK, INFO) -!! ! -!! !allocate(C(LDA,n)) -!! !call dgemm('N','N',m,n,n,1.0d0,B,LDA,A,LDA,0.0d0,C,LDA) -!! !norm = 0.0d0 -!! !B = 0.0d0 -!! !!print *,C -!! !do i=1,m -!! ! norm = 0.0d0 -!! ! do j=1,n -!! ! norm = norm + C(j,i)*C(j,i) -!! ! end do -!! ! norm = 1.0d0/dsqrt(norm) -!! ! do j=1,n -!! ! B(j,i) = C(j,i) -!! ! end do -!! !end do -!! !print *,B -!! -!! -!! !deallocate(WORK,TAU) -!!end -!! -!!subroutine ortho_qr_csf(A, LDA, B, m, n) bind(C, name="ortho_qr_csf") -!! use iso_c_binding -!! integer(c_int32_t), value :: LDA -!! integer(c_int32_t), value :: m -!! integer(c_int32_t), value :: n -!! integer(c_int16_t) :: A(LDA,n) -!! integer(c_int16_t) :: B(LDA,n) -!! call ortho_qr_withB(A,LDA,B,m,n) -!!end subroutine ortho_qr_csf + +!subroutine ortho_qr_withB(A,LDA,B,m,n) +! implicit none +! BEGIN_DOC +! ! Orthogonalization using Q.R factorization +! ! +! ! A : Overlap Matrix +! ! +! ! LDA : leftmost dimension of A +! ! +! ! m : Number of rows of A +! ! +! ! n : Number of columns of A +! ! +! ! B : Output orthogonal basis +! ! +! END_DOC +! integer, intent(in) :: m,n, LDA +! double precision, intent(inout) :: A(LDA,n) +! double precision, intent(inout) :: B(LDA,n) +! +! integer :: LWORK, INFO +! integer, allocatable :: jpvt(:) +! double precision, allocatable :: TAU(:), WORK(:) +! double precision, allocatable :: C(:,:) +! double precision :: norm +! integer :: i,j +! +! allocate (TAU(min(m,n)), WORK(1)) +! allocate (jpvt(n)) +! !print *," In function ortho" +! B = A +! +! jpvt(1:n)=1 +! +! LWORK=-1 +! call dgeqp3( m, n, A, LDA, jpvt, TAU, WORK, LWORK, INFO ) +! +! ! /!\ int(WORK(1)) becomes negative when WORK(1) > 2147483648 +! LWORK=max(n,int(WORK(1))) +! +! deallocate(WORK) +! allocate(WORK(LWORK)) +! call dgeqp3(m, n, A, LDA, jpvt, TAU, WORK, LWORK, INFO ) +! print *,A +! print *,jpvt +! deallocate(WORK,TAU) +! !stop +! +! !LWORK=-1 +! !call dgeqrf( m, n, A, LDA, TAU, WORK, LWORK, INFO ) +! !! /!\ int(WORK(1)) becomes negative when WORK(1) > 2147483648 +! !LWORK=max(n,int(WORK(1))) +! +! !deallocate(WORK) +! !allocate(WORK(LWORK)) +! !call dgeqrf(m, n, A, LDA, TAU, WORK, LWORK, INFO ) +! +! !LWORK=-1 +! !call dorgqr(m, n, n, A, LDA, TAU, WORK, LWORK, INFO) +! !! /!\ int(WORK(1)) becomes negative when WORK(1) > 2147483648 +! !LWORK=max(n,int(WORK(1))) +! +! !deallocate(WORK) +! !allocate(WORK(LWORK)) +! !call dorgqr(m, n, n, A, LDA, TAU, WORK, LWORK, INFO) +! ! +! !allocate(C(LDA,n)) +! !call dgemm('N','N',m,n,n,1.0d0,B,LDA,A,LDA,0.0d0,C,LDA) +! !norm = 0.0d0 +! !B = 0.0d0 +! !!print *,C +! !do i=1,m +! ! norm = 0.0d0 +! ! do j=1,n +! ! norm = norm + C(j,i)*C(j,i) +! ! end do +! ! norm = 1.0d0/dsqrt(norm) +! ! do j=1,n +! ! B(j,i) = C(j,i) +! ! end do +! !end do +! !print *,B +! +! +! !deallocate(WORK,TAU) +!end +! +!subroutine ortho_qr_csf(A, LDA, B, m, n) bind(C, name="ortho_qr_csf") +! use iso_c_binding +! integer(c_int32_t), value :: LDA +! integer(c_int32_t), value :: m +! integer(c_int32_t), value :: n +! integer(c_int16_t) :: A(LDA,n) +! integer(c_int16_t) :: B(LDA,n) +! call ortho_qr_withB(A,LDA,B,m,n) +!end subroutine ortho_qr_csf subroutine ortho_qr(A,LDA,m,n) implicit none From f79ee5faa88ec27ec03236a4ce11fca84c259873 Mon Sep 17 00:00:00 2001 From: v1j4y Date: Fri, 2 Dec 2022 11:30:05 +0100 Subject: [PATCH 06/21] Fixed bugs in p q excitations. --- src/csf/configuration_CI_sigma_helpers.irp.f | 384 +++++++++++-------- 1 file changed, 234 insertions(+), 150 deletions(-) diff --git a/src/csf/configuration_CI_sigma_helpers.irp.f b/src/csf/configuration_CI_sigma_helpers.irp.f index 581498c5..3794e8bb 100644 --- a/src/csf/configuration_CI_sigma_helpers.irp.f +++ b/src/csf/configuration_CI_sigma_helpers.irp.f @@ -671,11 +671,21 @@ use bitmasks Jdomo(jint) = IBSET(Jdomo(jint),jpos) endif + do ii=1, N_int + Jcfg(i,1) = Jsomo(i) + Jcfg(i,2) = Jdomo(i) + enddo + call bitstring_to_list(Jcfg,listall,nelall,N_int) Nsomo_J = nelall ! Check for Minimal alpha electrons (MS) if(Nsomo_J.lt.MS)then + if(vmotype(j) == 1)then + Jsomo(jint) = IBCLR(Jsomo(jint),jpos) + else if(vmotype(j) == 2)then + Jdomo(jint) = IBCLR(Jdomo(jint),jpos) + endif cycle endif @@ -715,12 +725,19 @@ use bitmasks endif end do - if(pqAlreadyGenQ) cycle + if(pqAlreadyGenQ) then + if(vmotype(j) == 1)then + Jsomo(jint) = IBCLR(Jsomo(jint),jpos) + else if(vmotype(j) == 2)then + Jdomo(jint) = IBCLR(Jdomo(jint),jpos) + endif + cycle + endif pqExistsQ = .FALSE. if(.NOT. pqExistsQ) then - tableUniqueAlphas(p,q) = .TRUE. + tableUniqueAlphas(pp,qq) = .TRUE. endif @@ -740,10 +757,13 @@ use bitmasks !print *,tableUniqueAlphas(:,:) ! prune list of alphas - Isomo = Icfg(1,1) - Idomo = Icfg(1,2) - Jsomo = Icfg(1,1) - Jdomo = Icfg(1,2) + do i=1, N_int + Isomo(i) = iand(act_bitmask(i,1),psi_configuration(i,1,idxI)) + Idomo(i) = iand(act_bitmask(i,1),psi_configuration(i,2,idxI)) + Jsomo(i) = Isomo(i) + Jdomo(i) = Idomo(i) + enddo + NalphaIcfg = 0 do i = 1, nholes pp = listholes(i) @@ -753,6 +773,7 @@ use bitmasks Jsomo(iint) = IBCLR(Jsomo(iint),ipos) else if(holetype(i) == 2)then Jdomo(iint) = IBCLR(Jdomo(iint),ipos) + Jsomo(iint) = IBSET(Jsomo(iint),ipos) endif do j = 1, nvmos @@ -763,14 +784,28 @@ use bitmasks Jsomo(jint) = IBSET(Jsomo(jint),jpos) else if(vmotype(j) == 2)then Jdomo(jint) = IBSET(Jdomo(jint),jpos) + Jsomo(jint) = IBCLR(Jsomo(jint),jpos) + endif + if(pp .EQ. qq) then + if(vmotype(j) == 1)then + Jsomo(jint) = IBCLR(Jsomo(jint),jpos) + else if(vmotype(j) == 2)then + Jdomo(jint) = IBCLR(Jdomo(jint),jpos) + endif + cycle endif - if(pp .EQ. qq) cycle if(tableUniqueAlphas(pp,qq)) then + do ii=1, N_int + Jcfg(i,1) = Jsomo(i) + Jcfg(i,2) = Jdomo(i) + enddo + call bitstring_to_list(Jcfg,listall,nelall,N_int) Nsomo_J = nelall if(Nsomo_J .ge. NSOMOMin) then + !print *," Idx = ",idxI, "p = ",pp, " q = ",qq," Jsomo=",Jsomo(1), " Jdomo=",IOR(Jdomo(1),ISHFT(1_8,n_core_orb)-1) NalphaIcfg += 1 alphasIcfg_list(:,1,idxI,NalphaIcfg) = Jcfg(:,1) if(n_core_orb .le. 63)then @@ -794,12 +829,14 @@ use bitmasks Jsomo(jint) = IBCLR(Jsomo(jint),jpos) else if(vmotype(j) == 2)then Jdomo(jint) = IBCLR(Jdomo(jint),jpos) + Jsomo(jint) = IBSET(Jsomo(jint),jpos) endif end do if(holetype(i) == 1)then Jsomo(iint) = IBSET(Jsomo(iint),ipos) else if(holetype(i) == 2)then Jdomo(iint) = IBSET(Jdomo(iint),ipos) + Jsomo(iint) = IBCLR(Jsomo(iint),ipos) endif end do @@ -863,6 +900,7 @@ END_PROVIDER integer,intent(in) :: idxI ! The id of the Ith CFG integer(bit_kind),intent(in) :: Icfg(N_int,2) + integer(bit_kind) :: Jcfg(N_int,2) integer,intent(out) :: NalphaIcfg integer(bit_kind),intent(out) :: alphasIcfg(N_int,2,*) logical,dimension(:,:),allocatable :: tableUniqueAlphas @@ -872,74 +910,84 @@ END_PROVIDER integer :: nvmos integer :: listvmos(mo_num) integer :: vmotype(mo_num) ! 1 -> VMO 2 -> SOMO - integer*8 :: Idomo - integer*8 :: Isomo - integer*8 :: Jdomo - integer*8 :: Jsomo - integer*8 :: diffSOMO - integer*8 :: diffDOMO - integer*8 :: xordiffSOMODOMO + integer(bit_kind) :: Idomo(N_int), Idomop(N_int), Idomoq(N_int) + integer(bit_kind) :: Isomo(N_int), Isomop(N_int), Isomoq(N_int) + integer(bit_kind) :: Jdomo(N_int), Jdomop(N_int), Jdomoq(N_int) + integer(bit_kind) :: Jsomo(N_int), Jsomop(N_int), Jsomoq(N_int) + integer(bit_kind) :: diffDOMO(N_int), xordiffSOMODOMO(N_int), diffSOMO(N_int) integer :: ndiffSOMO integer :: ndiffDOMO integer :: nxordiffSOMODOMO integer :: ndiffAll integer :: i, ii integer :: j, jj + integer :: iii, iint, jint, ipos, jpos + integer :: i_s, i_d integer :: k, kk integer :: kstart integer :: kend - integer :: Nsomo_I - integer :: hole - integer :: p - integer :: q + integer :: Nsomo_I, Nsomo_J + integer :: hole, n_core_orb_64 + integer :: p, pp, p_s + integer :: q, qq, q_s integer :: countalphas logical :: pqAlreadyGenQ logical :: pqExistsQ logical :: ppExistsQ - Isomo = iand(act_bitmask(1,1),Icfg(1,1)) - Idomo = iand(act_bitmask(1,1),Icfg(1,2)) + integer :: listall(N_int*bit_kind_size), nelall + + do i=1, N_int + Isomo(i) = iand(act_bitmask(i,1),Icfg(i,1)) + Idomo(i) = iand(act_bitmask(i,1),Icfg(i,2)) + enddo + !print*,"Input cfg" !call debug_spindet(Isomo,1) !call debug_spindet(Idomo,1) ! find out all pq holes possible - nholes = 0 - ! holes in SOMO - do ii = 1,n_act_orb - i = list_act(ii) - if(POPCNT(IAND(Isomo,IBSET(0_8,i-1))) .EQ. 1) then - nholes += 1 - listholes(nholes) = i - holetype(nholes) = 1 - endif - end do - ! holes in DOMO - do ii = 1,n_act_orb - i = list_act(ii) - if(POPCNT(IAND(Idomo,IBSET(0_8,i-1))) .EQ. 1) then - nholes += 1 - listholes(nholes) = i - holetype(nholes) = 2 - endif - end do + nholes = 0 + call bitstring_to_list(Isomo,listall,nelall,N_int) + + do iii=1,nelall + nholes += 1 + listholes(nholes) = listall(iii) + holetype(nholes) = 1 + end do + + Nsomo_I = nelall + + call bitstring_to_list(Idomo,listall,nelall,N_int) + + do iii=1,nelall + if(listall(iii) .gt. n_core_orb)then + nholes += 1 + listholes(nholes) = listall(iii) + holetype(nholes) = 2 + endif + end do + ! find vmos - listvmos = -1 - vmotype = -1 - nvmos = 0 - do ii = 1,n_act_orb - i = list_act(ii) - !print *,i,IBSET(0,i-1),POPCNT(IAND(Isomo,(IBSET(0_8,i-1)))), POPCNT(IAND(Idomo,(IBSET(0_8,i-1)))) - if(POPCNT(IAND(Isomo,(IBSET(0_8,i-1)))) .EQ. 0 .AND. POPCNT(IAND(Idomo,(IBSET(0_8,i-1)))) .EQ. 0) then - nvmos += 1 - listvmos(nvmos) = i - vmotype(nvmos) = 1 - else if(POPCNT(IAND(Isomo,(IBSET(0_8,i-1)))) .EQ. 1 .AND. POPCNT(IAND(Idomo,(IBSET(0_8,i-1)))) .EQ. 0 ) then - nvmos += 1 - listvmos(nvmos) = i - vmotype(nvmos) = 2 - end if - end do + ! Take into account N_int + do ii = 1, n_act_orb + iii = list_act(ii) + iint = shiftr(iii-1,bit_kind_shift) + 1 + ipos = iii-shiftl((iint-1),bit_kind_shift)-1 + + if(IAND(Idomo(iint),(IBSET(0_8,ipos))) .EQ. 0) then + if(IAND(Isomo(iint),(IBSET(0_8,ipos))) .EQ. 0) then + nvmos += 1 + listvmos(nvmos) = iii + vmotype(nvmos) = 1 + else if(POPCNT(IAND(Isomo(iint),(IBSET(0_8,ipos)))) .EQ. 1) then + nvmos += 1 + listvmos(nvmos) = iii + vmotype(nvmos) = 2 + end if + end if + end do + !print *,"Nvmo=",nvmos !print *,listvmos @@ -948,10 +996,15 @@ END_PROVIDER allocate(tableUniqueAlphas(mo_num,mo_num)) tableUniqueAlphas = .FALSE. + ! Now find the allowed (p,q) excitations + do i=1, N_int + Isomo(i) = iand(act_bitmask(i,1),Icfg(i,1)) + Idomo(i) = iand(act_bitmask(i,1),Icfg(i,2)) + Jsomo(i) = Isomo(i) + Jdomo(i) = Idomo(i) + enddo + ! Now find the allowed (p,q) excitations - Isomo = iand(act_bitmask(1,1),Icfg(1,1)) - Idomo = iand(act_bitmask(1,1),Icfg(1,2)) - Nsomo_I = POPCNT(Isomo) if(Nsomo_I .EQ. 0) then kstart = 1 else @@ -971,41 +1024,40 @@ END_PROVIDER !enddo do i = 1,nholes - p = listholes(i) + pp = listholes(i) + iint = shiftr(pp-1,bit_kind_shift) + 1 + ipos = pp-shiftl((iint-1),bit_kind_shift)-1 + if(holetype(i) == 1)then + Jsomo(iint) = IBCLR(Jsomo(iint),ipos) + else if(holetype(i) == 2)then + Jdomo(iint) = IBCLR(Jdomo(iint),ipos) + endif + do j = 1,nvmos - q = listvmos(j) - if(p .EQ. q) cycle - if(holetype(i) .EQ. 1 .AND. vmotype(j) .EQ. 1) then - ! SOMO -> VMO - Jsomo = IBCLR(Isomo,p-1) - Jsomo = IBSET(Jsomo,q-1) - Jdomo = Idomo - kstart = max(1,cfg_seniority_index(max(NSOMOMin,Nsomo_I-2))) - kend = idxI-1 - else if(holetype(i) .EQ. 1 .AND. vmotype(j) .EQ. 2) then - ! SOMO -> SOMO - Jsomo = IBCLR(Isomo,p-1) - Jsomo = IBCLR(Jsomo,q-1) - Jdomo = IBSET(Idomo,q-1) - kstart = max(1,cfg_seniority_index(max(NSOMOMin,Nsomo_I-4))) - kend = idxI-1 - else if(holetype(i) .EQ. 2 .AND. vmotype(j) .EQ. 1) then - ! DOMO -> VMO - Jsomo = IBSET(Isomo,p-1) - Jsomo = IBSET(Jsomo,q-1) - Jdomo = IBCLR(Idomo,p-1) - kstart = cfg_seniority_index(Nsomo_I) - kend = idxI-1 - else if(holetype(i) .EQ. 2 .AND. vmotype(j) .EQ. 2) then - ! DOMO -> SOMO - Jsomo = IBSET(Isomo,p-1) - Jsomo = IBCLR(Jsomo,q-1) - Jdomo = IBCLR(Idomo,p-1) - Jdomo = IBSET(Jdomo,q-1) - kstart = max(1,cfg_seniority_index(max(NSOMOMin,Nsomo_I-2))) - kend = idxI-1 - else - print*,"Something went wrong in obtain_associated_alphaI" + qq = listvmos(j) + jint = shiftr(qq-1,bit_kind_shift) + 1 + jpos = qq-shiftl((iint-1),bit_kind_shift)-1 + if(vmotype(j) == 1)then + Jsomo(jint) = IBSET(Jsomo(jint),jpos) + else if(vmotype(j) == 2)then + Jdomo(jint) = IBSET(Jdomo(jint),jpos) + endif + + do ii=1, N_int + Jcfg(i,1) = Jsomo(i) + Jcfg(i,2) = Jdomo(i) + enddo + + call bitstring_to_list(Jcfg,listall,nelall,N_int) + Nsomo_J = nelall + + if(pp .EQ. qq) then + if(vmotype(j) == 1)then + Jsomo(jint) = IBCLR(Jsomo(jint),jpos) + else if(vmotype(j) == 2)then + Jdomo(jint) = IBCLR(Jdomo(jint),jpos) + endif + cycle endif ! Again, we don't have to search from 1 @@ -1016,14 +1068,21 @@ END_PROVIDER pqAlreadyGenQ = .FALSE. ! First check if it can be generated before do k = kstart, kend - diffSOMO = IEOR(Jsomo,iand(act_bitmask(1,1),psi_configuration(1,1,k))) - ndiffSOMO = POPCNT(diffSOMO) + ndiffSOMO = 0 + ndiffDOMO = 0 + nxordiffSOMODOMO = 0 + do ii = 1, N_int + Jsomo = Jcfg(ii,1) + Jdomo = Jcfg(ii,2) + diffSOMO = IEOR(Jsomo,iand(reunion_of_act_virt_bitmask(ii,1),psi_configuration(ii,1,k))) + ndiffSOMO += POPCNT(diffSOMO(ii)) + diffDOMO = IEOR(Jdomo,iand(reunion_of_act_virt_bitmask(ii,2),psi_configuration(ii,2,k))) + xordiffSOMODOMO = IEOR(diffSOMO,diffDOMO) + ndiffDOMO += POPCNT(diffDOMO(ii)) + nxordiffSOMODOMO += POPCNT(xordiffSOMODOMO(ii)) + nxordiffSOMODOMO += ndiffSOMO + ndiffDOMO + end do if((ndiffSOMO .NE. 0) .AND. (ndiffSOMO .NE. 2)) cycle - diffDOMO = IEOR(Jdomo,iand(act_bitmask(1,1),psi_configuration(1,2,k))) - xordiffSOMODOMO = IEOR(diffSOMO,diffDOMO) - ndiffDOMO = POPCNT(diffDOMO) - nxordiffSOMODOMO = POPCNT(xordiffSOMODOMO) - nxordiffSOMODOMO += ndiffSOMO + ndiffDOMO !if(POPCNT(IEOR(diffSOMO,diffDOMO)) .LE. 1 .AND. ndiffDOMO .LT. 3) then if((ndiffSOMO+ndiffDOMO) .EQ. 0) then pqAlreadyGenQ = .TRUE. @@ -1033,19 +1092,20 @@ END_PROVIDER if((nxordiffSOMODOMO .EQ. 4) .AND. ndiffSOMO .EQ. 2) then pqAlreadyGenQ = .TRUE. !EXIT - !ppExistsQ = .TRUE. - !print *,i,k,ndiffSOMO,ndiffDOMO - !call debug_spindet(Jsomo,1) - !call debug_spindet(Jdomo,1) - !call debug_spindet(iand(reunion_of_act_virt_bitmask(1,1),psi_configuration(1,1,k)),1) - !call debug_spindet(iand(reunion_of_act_virt_bitmask(1,1),psi_configuration(1,2,k)),1) EXIT endif end do !print *,"(,",p,",",q,")",pqAlreadyGenQ - if(pqAlreadyGenQ) cycle + if(pqAlreadyGenQ) then + if(vmotype(j) == 1)then + Jsomo(jint) = IBCLR(Jsomo(jint),jpos) + else if(vmotype(j) == 2)then + Jdomo(jint) = IBCLR(Jdomo(jint),jpos) + endif + cycle + endif pqExistsQ = .FALSE. ! now check if this exists in the selected list @@ -1066,53 +1126,67 @@ END_PROVIDER !call debug_spindet(Jsomo,1) !call debug_spindet(Jdomo,1) endif + if(vmotype(j) == 1)then + Jsomo(jint) = IBCLR(Jsomo(jint),jpos) + else if(vmotype(j) == 2)then + Jdomo(jint) = IBCLR(Jdomo(jint),jpos) + endif end do + if(holetype(i) == 1)then + Jsomo(iint) = IBSET(Jsomo(iint),ipos) + else if(holetype(i) == 2)then + Jdomo(iint) = IBSET(Jdomo(iint),ipos) + endif end do !print *,tableUniqueAlphas(:,:) ! prune list of alphas - Isomo = Icfg(1,1) - Idomo = Icfg(1,2) - Jsomo = Icfg(1,1) - Jdomo = Icfg(1,2) + do i=1, N_int + Isomo(i) = iand(act_bitmask(i,1),Icfg(i,1)) + Idomo(i) = iand(act_bitmask(i,1),Icfg(i,2)) + Jsomo(i) = Isomo(i) + Jdomo(i) = Idomo(i) + enddo + NalphaIcfg = 0 do i = 1, nholes - p = listholes(i) - do j = 1, nvmos - q = listvmos(j) - if(p .EQ. q) cycle - if(tableUniqueAlphas(p,q)) then - if(holetype(i) .EQ. 1 .AND. vmotype(j) .EQ. 1) then - ! SOMO -> VMO - Jsomo = IBCLR(Isomo,p-1) - Jsomo = IBSET(Jsomo,q-1) - Jdomo = Idomo - else if(holetype(i) .EQ. 1 .AND. vmotype(j) .EQ. 2) then - ! SOMO -> SOMO - Jsomo = IBCLR(Isomo,p-1) - Jsomo = IBCLR(Jsomo,q-1) - Jdomo = IBSET(Idomo,q-1) - else if(holetype(i) .EQ. 2 .AND. vmotype(j) .EQ. 1) then - ! DOMO -> VMO - Jsomo = IBSET(Isomo,p-1) - Jsomo = IBSET(Jsomo,q-1) - Jdomo = IBCLR(Idomo,p-1) - else if(holetype(i) .EQ. 2 .AND. vmotype(j) .EQ. 2) then - ! DOMO -> SOMO - Jsomo = IBSET(Isomo,p-1) - Jsomo = IBCLR(Jsomo,q-1) - Jdomo = IBCLR(Idomo,p-1) - Jdomo = IBSET(Jdomo,q-1) - else - print*,"Something went wrong in obtain_associated_alphaI" - endif + pp = listholes(i) + iint = shiftr(pp-1,bit_kind_shift) + 1 + ipos = pp-shiftl((iint-1),bit_kind_shift)-1 + if(holetype(i) == 1)then + Jsomo(iint) = IBCLR(Jsomo(iint),ipos) + else if(holetype(i) == 2)then + Jdomo(iint) = IBCLR(Jdomo(iint),ipos) + endif + do j = 1, nvmos + qq = listvmos(j) + jint = shiftr(qq-1,bit_kind_shift) + 1 + jpos = qq-shiftl((iint-1),bit_kind_shift)-1 + if(vmotype(j) == 1)then + Jsomo(jint) = IBSET(Jsomo(jint),jpos) + else if(vmotype(j) == 2)then + Jdomo(jint) = IBSET(Jdomo(jint),jpos) + endif + if(pp .EQ. qq) cycle + if(tableUniqueAlphas(pp,qq)) then ! SOMO NalphaIcfg += 1 - !print *,i,j,"|",NalphaIcfg - alphasIcfg(1,1,NalphaIcfg) = Jsomo - alphasIcfg(1,2,NalphaIcfg) = IOR(Jdomo,ISHFT(1_8,n_core_orb)-1) + alphasIcfg_list(:,1,idxI,NalphaIcfg) = Jcfg(:,1) + if(n_core_orb .le. 63)then + alphasIcfg_list(1,2,idxI,NalphaIcfg) = IOR(Jcfg(1,2),ISHFT(1_8,n_core_orb)-1) + else + n_core_orb_64 = n_core_orb + do ii=1,N_int + if(n_core_orb_64 .gt. 0)then + alphasIcfg_list(ii,2,idxI,NalphaIcfg) = IOR(Jcfg(ii,2),ISHFT(1_8,n_core_orb_64)-1) + else + alphasIcfg_list(ii,2,idxI,NalphaIcfg) = Jcfg(ii,2) + endif + n_core_orb_64 = ISHFT(n_core_orb_64,-6) + end do + endif !print *,"I = ",idxI, " Na=",NalphaIcfg," - ",Jsomo, IOR(Jdomo,ISHFT(1_8,n_core_orb)-1) endif end do @@ -1123,12 +1197,22 @@ END_PROVIDER Isomo = iand(act_bitmask(1,1),Icfg(1,1)) Idomo = iand(act_bitmask(1,1),Icfg(1,2)) do k = 1, idxI-1 - diffSOMO = IEOR(Isomo,iand(act_bitmask(1,1),psi_configuration(1,1,k))) - diffDOMO = IEOR(Idomo,iand(act_bitmask(1,1),psi_configuration(1,2,k))) - xordiffSOMODOMO = IEOR(diffSOMO,diffDOMO) - ndiffSOMO = POPCNT(diffSOMO) - ndiffDOMO = POPCNT(diffDOMO) - nxordiffSOMODOMO = POPCNT(xordiffSOMODOMO) + do ii=1,N_int + diffSOMO = IEOR(Icfg(ii,1),iand(act_bitmask(ii,1),psi_configuration(ii,1,k))) + ndiffSOMO += POPCNT(diffSOMO(ii)) + end do + ! ndiffSOMO cannot be 0 (I /= k) + ! if ndiffSOMO /= 2 then it has to be greater than 2 and hense + ! this Icfg could not have been generated before. + if (ndiffSOMO /= 2) cycle + ndiffDOMO = 0 + nxordiffSOMODOMO = 0 + do ii=1,N_int + diffDOMO = IEOR(Icfg(ii,2),iand(act_bitmask(ii,1),psi_configuration(ii,2,k))) + xordiffSOMODOMO = IEOR(diffSOMO,diffDOMO) + ndiffDOMO += POPCNT(diffDOMO(ii)) + nxordiffSOMODOMO += POPCNT(xordiffSOMODOMO(ii)) + end do if((ndiffSOMO+ndiffDOMO+nxordiffSOMODOMO .EQ. 4) .AND. ndiffSOMO .EQ. 2) then ppExistsQ = .TRUE. EXIT @@ -1141,8 +1225,8 @@ END_PROVIDER !print *,p,q,"|",holetype(i),vmotype(j),NalphaIcfg !call debug_spindet(Idomo,1) !call debug_spindet(Jdomo,1) - alphasIcfg(1,1,NalphaIcfg) = Icfg(1,1) - alphasIcfg(1,2,NalphaIcfg) = Icfg(1,2) + alphasIcfg_list(:,1,idxI,NalphaIcfg) = Icfg(:,1) + alphasIcfg_list(:,2,idxI,NalphaIcfg) = Icfg(:,2) endif end subroutine From 0234e46e1b5efb97e45b74f3dc80f79f0892d855 Mon Sep 17 00:00:00 2001 From: v1j4y Date: Sun, 4 Dec 2022 00:25:15 +0100 Subject: [PATCH 07/21] Fixed alphalist. --- src/csf/configuration_CI_sigma_helpers.irp.f | 39 +++++++++++++------- 1 file changed, 25 insertions(+), 14 deletions(-) diff --git a/src/csf/configuration_CI_sigma_helpers.irp.f b/src/csf/configuration_CI_sigma_helpers.irp.f index 3794e8bb..2bad88c0 100644 --- a/src/csf/configuration_CI_sigma_helpers.irp.f +++ b/src/csf/configuration_CI_sigma_helpers.irp.f @@ -584,8 +584,8 @@ use bitmasks Jcfg = psi_configuration(:,:,idxI) do i=1, N_int - Isomo(i) = iand(act_bitmask(i,1),Icfg(i,1)) - Idomo(i) = iand(act_bitmask(i,1),Icfg(i,2)) + Isomo(i) = iand(act_bitmask(i,1),psi_configuration(i,1,idxI)) + Idomo(i) = iand(act_bitmask(i,1),psi_configuration(i,2,idxI)) enddo ! find out all pq holes possible @@ -638,8 +638,8 @@ use bitmasks ! Now find the allowed (p,q) excitations do i=1, N_int - Isomo(i) = iand(act_bitmask(i,1),Icfg(i,1)) - Idomo(i) = iand(act_bitmask(i,1),Icfg(i,2)) + Isomo(i) = iand(reunion_of_act_virt_bitmask(i,1),psi_configuration(i,1,idxI)) + Idomo(i) = iand(reunion_of_act_virt_bitmask(i,2),psi_configuration(i,2,idxI)) Jsomo(i) = Isomo(i) Jdomo(i) = Idomo(i) enddo @@ -659,21 +659,24 @@ use bitmasks Jsomo(iint) = IBCLR(Jsomo(iint),ipos) else if(holetype(i) == 2)then Jdomo(iint) = IBCLR(Jdomo(iint),ipos) + Jsomo(iint) = IBSET(Jsomo(iint),ipos) endif do j = 1,nvmos qq = listvmos(j) + if(pp.eq.qq) cycle jint = shiftr(qq-1,bit_kind_shift) + 1 jpos = qq-shiftl((iint-1),bit_kind_shift)-1 if(vmotype(j) == 1)then Jsomo(jint) = IBSET(Jsomo(jint),jpos) else if(vmotype(j) == 2)then Jdomo(jint) = IBSET(Jdomo(jint),jpos) + Jsomo(jint) = IBCLR(Jsomo(jint),jpos) endif do ii=1, N_int - Jcfg(i,1) = Jsomo(i) - Jcfg(i,2) = Jdomo(i) + Jcfg(ii,1) = Jsomo(ii) + Jcfg(ii,2) = Jdomo(ii) enddo call bitstring_to_list(Jcfg,listall,nelall,N_int) @@ -685,6 +688,7 @@ use bitmasks Jsomo(jint) = IBCLR(Jsomo(jint),jpos) else if(vmotype(j) == 2)then Jdomo(jint) = IBCLR(Jdomo(jint),jpos) + Jsomo(jint) = IBSET(Jsomo(jint),jpos) endif cycle endif @@ -730,12 +734,15 @@ use bitmasks Jsomo(jint) = IBCLR(Jsomo(jint),jpos) else if(vmotype(j) == 2)then Jdomo(jint) = IBCLR(Jdomo(jint),jpos) + Jsomo(jint) = IBSET(Jsomo(jint),jpos) endif cycle endif pqExistsQ = .FALSE. + !print *, " ndiffSOMO=",ndiffSOMO, " ndiffDOMO=", ndiffDOMO, " nxordiffSOMODOMO=",nxordiffSOMODOMO, " p=",pp," q=",qq + if(.NOT. pqExistsQ) then tableUniqueAlphas(pp,qq) = .TRUE. endif @@ -745,16 +752,18 @@ use bitmasks Jsomo(jint) = IBCLR(Jsomo(jint),jpos) else if(vmotype(j) == 2)then Jdomo(jint) = IBCLR(Jdomo(jint),jpos) + Jsomo(jint) = IBSET(Jsomo(jint),jpos) endif end do if(holetype(i) == 1)then Jsomo(iint) = IBSET(Jsomo(iint),ipos) else if(holetype(i) == 2)then Jdomo(iint) = IBSET(Jdomo(iint),ipos) + Jsomo(iint) = IBCLR(Jsomo(iint),ipos) endif end do - !print *,tableUniqueAlphas(:,:) + print *,tableUniqueAlphas(:,:) ! prune list of alphas do i=1, N_int @@ -763,6 +772,7 @@ use bitmasks Jsomo(i) = Isomo(i) Jdomo(i) = Idomo(i) enddo + print *, " Isomo=",Isomo(1), " Idomo=", Idomo(1) NalphaIcfg = 0 do i = 1, nholes @@ -791,21 +801,22 @@ use bitmasks Jsomo(jint) = IBCLR(Jsomo(jint),jpos) else if(vmotype(j) == 2)then Jdomo(jint) = IBCLR(Jdomo(jint),jpos) + Jsomo(jint) = IBSET(Jsomo(jint),jpos) endif cycle endif if(tableUniqueAlphas(pp,qq)) then do ii=1, N_int - Jcfg(i,1) = Jsomo(i) - Jcfg(i,2) = Jdomo(i) + Jcfg(ii,1) = Jsomo(ii) + Jcfg(ii,2) = Jdomo(ii) enddo call bitstring_to_list(Jcfg,listall,nelall,N_int) Nsomo_J = nelall if(Nsomo_J .ge. NSOMOMin) then - !print *," Idx = ",idxI, "p = ",pp, " q = ",qq," Jsomo=",Jsomo(1), " Jdomo=",IOR(Jdomo(1),ISHFT(1_8,n_core_orb)-1) + print *," Idx = ",idxI, "p = ",pp, " q = ",qq," Jsomo=",Jsomo(1), " Jdomo=",IOR(Jdomo(1),ISHFT(1_8,n_core_orb)-1) NalphaIcfg += 1 alphasIcfg_list(:,1,idxI,NalphaIcfg) = Jcfg(:,1) if(n_core_orb .le. 63)then @@ -843,8 +854,8 @@ use bitmasks ! Check if this Icfg has been previously generated as a mono ppExistsQ = .False. do i=1, N_int - Isomo(i) = iand(act_bitmask(i,1),Icfg(i,1)) - Idomo(i) = iand(act_bitmask(i,1),Icfg(i,2)) + Isomo(i) = iand(act_bitmask(i,1),psi_configuration(i,1,idxI)) + Idomo(i) = iand(act_bitmask(i,1),psi_configuration(i,2,idxI)) enddo kstart = max(1,cfg_seniority_index(max(NSOMOMin,Nsomo_I-2))) @@ -1044,8 +1055,8 @@ END_PROVIDER endif do ii=1, N_int - Jcfg(i,1) = Jsomo(i) - Jcfg(i,2) = Jdomo(i) + Jcfg(ii,1) = Jsomo(ii) + Jcfg(ii,2) = Jdomo(ii) enddo call bitstring_to_list(Jcfg,listall,nelall,N_int) From 4b3b6300ef8f76e82c4ddb83669665aa945d1ea2 Mon Sep 17 00:00:00 2001 From: v1j4y Date: Sat, 10 Dec 2022 11:36:12 +0100 Subject: [PATCH 08/21] Working on obtain I for alpha. --- src/csf/obtain_I_foralpha.irp.f | 450 +++++++++----------------------- 1 file changed, 119 insertions(+), 331 deletions(-) diff --git a/src/csf/obtain_I_foralpha.irp.f b/src/csf/obtain_I_foralpha.irp.f index 5fd630fc..a5a4164d 100644 --- a/src/csf/obtain_I_foralpha.irp.f +++ b/src/csf/obtain_I_foralpha.irp.f @@ -315,86 +315,35 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI !print *,"obt SOMO -> VMO" extyp = 3 if(N_int .eq. 1) then - IJsomo = IEOR(Isomo, Jsomo) -!IRP_IF WITHOUT_TRAILZ -! p = (popcnt(ieor( IAND(Isomo,IJsomo) , IAND(Isomo,IJsomo) -1))-1) + 1 -!IRP_ELSE - p = TRAILZ(IAND(Isomo,IJsomo)) + 1 -!IRP_ENDIF - IJsomo = IBCLR(IJsomo,p-1) -!IRP_IF WITHOUT_TRAILZ -! q = (popcnt(ieor(IJsomo,IJsomo-1))-1) + 1 -!IRP_ELSE - q = TRAILZ(IJsomo) + 1 -!IRP_ENDIF - !print *," p=",p," q=",q - !call get_single_excitation_cfg(Jcfg, Icfg, p, q, N_int) - else - exc = 0 - do ii = 1,2 - ishift = 1-bit_kind_size - do l=1,N_int - ishift = ishift + bit_kind_size - if (Jcfg(l,ii) == Icfg(l,ii)) then - cycle - endif - tmp = xor( Jcfg(l,ii), Icfg(l,ii) ) - particle = iand(tmp, Icfg(l,ii)) - hole = iand(tmp, Jcfg(l,ii)) - if (particle /= 0_bit_kind) then - tz = trailz(particle) - exc(0,2,ii) = 1 - exc(1,2,ii) = tz+ishift - !print *,"part ",tz+ishift, " ii=",ii, exc(1,2,2) - endif - if (hole /= 0_bit_kind) then - tz = trailz(hole) - exc(0,1,ii) = 1 - exc(1,1,ii) = tz+ishift - !print *,"hole ",tz+ishift, " ii=",ii, exc(1,1,2) - endif - - if ( iand(exc(0,1,ii),exc(0,2,ii)) /= 1) then ! exc(0,1,ii)/=1 and exc(0,2,ii) /= 1 - cycle - endif - - high = max(exc(1,1,ii), exc(1,2,ii))-1 - low = min(exc(1,1,ii), exc(1,2,ii)) - - ASSERT (low >= 0) - ASSERT (high > 0) - - k = shiftr(high,bit_kind_shift)+1 - j = shiftr(low,bit_kind_shift)+1 - m = iand(high,bit_kind_size-1) - n = iand(low,bit_kind_size-1) - - if (j==k) then - nperm = nperm + popcnt(iand(Jcfg(j,ii), & - iand( shiftl(1_bit_kind,m)-1_bit_kind, & - not(shiftl(1_bit_kind,n))+1_bit_kind)) ) - else - nperm = nperm + popcnt( & - iand(Jcfg(j,ii), & - iand(not(0_bit_kind), & - (not(shiftl(1_bit_kind,n)) + 1_bit_kind) ))) & - + popcnt(iand(Jcfg(k,ii), & - (shiftl(1_bit_kind,m) - 1_bit_kind ) )) - - do iii=j+1,k-1 - nperm = nperm + popcnt(Jcfg(iii,ii)) - end do - - endif - - ! Set p and q - q = max(exc(1,1,1),exc(1,1,2)) - p = max(exc(1,2,1),exc(1,2,2)) - exit - - enddo - enddo -endif + IJsomo = IEOR(Isomo, Jsomo) + p = TRAILZ(IAND(Isomo,IJsomo)) + 1 + IJsomo = IBCLR(IJsomo,p-1) + q = TRAILZ(IJsomo) + 1 + !print *," p=",p," q=",q + !call get_single_excitation_cfg(Jcfg, Icfg, p, q, N_int) + else + ! Find p + do ii=1,N_int + Isomo = Ialpha(ii,1) + Jsomo = psi_configuration(ii,1,i) + IJsomo = IEOR(Isomo, Jsomo) + if(popcnt(IAND(Isomo,IJsomo)) > 0)then + p = TRAILZ(IAND(Isomo,IJsomo)) + 1 + ii * bit_kind_size + EXIT + endif + end do + ! Find q + do ii=1,N_int + Isomo = Ialpha(ii,1) + Jsomo = psi_configuration(ii,1,i) + IJsomo = IEOR(Isomo, Jsomo) + IJsomo = IBCLR(IJsomo,p-1) + if(popcnt(IJsomo) > 0)then + q = TRAILZ(IJsomo) + 1 + ii * bit_kind_size + EXIT + endif + enddo + endif !assert ( p == pp) !assert ( q == qq) !print *," --- p=",p," q=",q @@ -409,88 +358,35 @@ endif !print *,"obt DOMO -> VMO" extyp = 2 if(N_int.eq.1)then -!IRP_IF WITHOUT_TRAILZ -! p = (popcnt(ieor( IEOR(Idomo,Jdomo),IEOR(Idomo,Jdomo) -1))-1) + 1 -!IRP_ELSE - p = TRAILZ(IEOR(Idomo,Jdomo)) + 1 -!IRP_ENDIF - Isomo = IEOR(Isomo, Jsomo) - Isomo = IBCLR(Isomo,p-1) -!IRP_IF WITHOUT_TRAILZ -! q = (popcnt(ieor(Isomo,Isomo-1))-1) + 1 -!IRP_ELSE - q = TRAILZ(Isomo) + 1 -!IRP_ENDIF - else - exc=0 - exc(0,1,1) = 0 - exc(0,2,1) = 0 - exc(0,1,2) = 0 - exc(0,2,2) = 0 - do ii = 1,2 - ishift = 1-bit_kind_size - do l=1,N_int - ishift = ishift + bit_kind_size - if (Jcfg(l,ii) == Icfg(l,ii)) then - cycle - endif - tmp = xor( Jcfg(l,ii), Icfg(l,ii) ) - particle = iand(tmp, Icfg(l,ii)) - hole = iand(tmp, Jcfg(l,ii)) - if (particle /= 0_bit_kind) then - tz = trailz(particle) - exc(0,2,ii) = 1 - exc(1,2,ii) = tz+ishift - !print *,"part ",tz+ishift, " ii=",ii - endif - if (hole /= 0_bit_kind) then - tz = trailz(hole) - exc(0,1,ii) = 1 - exc(1,1,ii) = tz+ishift - !print *,"hole ",tz+ishift, " ii=",ii - endif + p = TRAILZ(IEOR(Idomo,Jdomo)) + 1 + Isomo = IEOR(Isomo, Jsomo) + Isomo = IBCLR(Isomo,p-1) + q = TRAILZ(Isomo) + 1 + else - if ( iand(exc(0,1,ii),exc(0,2,ii)) /= 1) then ! exc(0,1,ii)/=1 and exc(0,2,ii) /= 1 - cycle - endif - - high = max(exc(1,1,ii), exc(1,2,ii))-1 - low = min(exc(1,1,ii), exc(1,2,ii)) - - ASSERT (low >= 0) - ASSERT (high > 0) - - k = shiftr(high,bit_kind_shift)+1 - j = shiftr(low,bit_kind_shift)+1 - m = iand(high,bit_kind_size-1) - n = iand(low,bit_kind_size-1) - - if (j==k) then - nperm = nperm + popcnt(iand(Jcfg(j,ii), & - iand( shiftl(1_bit_kind,m)-1_bit_kind, & - not(shiftl(1_bit_kind,n))+1_bit_kind)) ) - else - nperm = nperm + popcnt( & - iand(Jcfg(j,ii), & - iand(not(0_bit_kind), & - (not(shiftl(1_bit_kind,n)) + 1_bit_kind) ))) & - + popcnt(iand(Jcfg(k,ii), & - (shiftl(1_bit_kind,m) - 1_bit_kind ) )) - - do iii=j+1,k-1 - nperm = nperm + popcnt(Jcfg(iii,ii)) - end do - - endif - - ! Set p and q - q = max(exc(1,1,1),exc(1,1,2)) - p = max(exc(1,2,1),exc(1,2,2)) - exit - - enddo - enddo -endif + ! Find p + do ii=1,N_int + Isomo = Ialpha(ii,1) + Jsomo = psi_configuration(ii,1,i) + Idomo = Ialpha(ii,2) + Jdomo = psi_configuration(ii,2,i) + if(popcnt(IEOR(Idomo,Jdomo)) > 0)then + p = TRAILZ(IEOR(Idomo,Jdomo)) + 1 + ii * bit_kind_size + EXIT + endif + end do + ! Find q + do ii=1,N_int + Isomo = Ialpha(ii,1) + Jsomo = psi_configuration(ii,1,i) + Isomo = IEOR(Isomo, Jsomo) + Isomo = IBCLR(Isomo,p-1) + if(popcnt(Isomo) > 0)then + q = TRAILZ(Isomo) + 1 + ii * bit_kind_size + EXIT + endif + end do + endif !assert ( p == pp) !assert ( q == qq) else @@ -498,183 +394,75 @@ endif !print *,"obt SOMO -> SOMO" extyp = 1 if(N_int.eq.1)then -!IRP_IF WITHOUT_TRAILZ -! q = (popcnt(ieor( IEOR(Idomo,Jdomo), IEOR(Idomo,Jdomo)-1))-1) + 1 -!IRP_ELSE - q = TRAILZ(IEOR(Idomo,Jdomo)) + 1 -!IRP_ENDIF - Isomo = IEOR(Isomo, Jsomo) - Isomo = IBCLR(Isomo,q-1) -!IRP_IF WITHOUT_TRAILZ -! p = (popcnt(ieor(Isomo,Isomo-1))-1) + 1 -!IRP_ELSE - p = TRAILZ(Isomo) + 1 -!IRP_ENDIF - ! Check for Minimal alpha electrons (MS) - !if(POPCNT(Isomo).lt.MS)then - ! cycle - !endif - else - exc=0 - exc(0,1,1) = 0 - exc(0,2,1) = 0 - exc(0,1,2) = 0 - exc(0,2,2) = 0 - do ii = 1,2 - ishift = 1-bit_kind_size - do l=1,N_int - ishift = ishift + bit_kind_size - if (Jcfg(l,ii) == Icfg(l,ii)) then - cycle - endif - tmp = xor( Jcfg(l,ii), Icfg(l,ii) ) - particle = iand(tmp, Icfg(l,ii)) - hole = iand(tmp, Jcfg(l,ii)) - if (particle /= 0_bit_kind) then - tz = trailz(particle) - exc(0,2,ii) = 1 - exc(1,2,ii) = tz+ishift - !print *,"part ",tz+ishift, " ii=",ii - endif - if (hole /= 0_bit_kind) then - tz = trailz(hole) - exc(0,1,ii) = 1 - exc(1,1,ii) = tz+ishift - !print *,"hole ",tz+ishift, " ii=",ii - endif - - if ( iand(exc(0,1,ii),exc(0,2,ii)) /= 1) then ! exc(0,1,ii)/=1 and exc(0,2,ii) /= 1 - cycle - endif - - high = max(exc(1,1,ii), exc(1,2,ii))-1 - low = min(exc(1,1,ii), exc(1,2,ii)) - - ASSERT (low >= 0) - ASSERT (high > 0) - - k = shiftr(high,bit_kind_shift)+1 - j = shiftr(low,bit_kind_shift)+1 - m = iand(high,bit_kind_size-1) - n = iand(low,bit_kind_size-1) - - if (j==k) then - nperm = nperm + popcnt(iand(Jcfg(j,ii), & - iand( shiftl(1_bit_kind,m)-1_bit_kind, & - not(shiftl(1_bit_kind,n))+1_bit_kind)) ) - else - nperm = nperm + popcnt( & - iand(Jcfg(j,ii), & - iand(not(0_bit_kind), & - (not(shiftl(1_bit_kind,n)) + 1_bit_kind) ))) & - + popcnt(iand(Jcfg(k,ii), & - (shiftl(1_bit_kind,m) - 1_bit_kind ) )) - - do iii=j+1,k-1 - nperm = nperm + popcnt(Jcfg(iii,ii)) - end do - - endif - - ! Set p and q - q = max(exc(1,1,1),exc(1,1,2)) - p = max(exc(1,2,1),exc(1,2,2)) - exit - - enddo - enddo -endif + q = TRAILZ(IEOR(Idomo,Jdomo)) + 1 + Isomo = IEOR(Isomo, Jsomo) + Isomo = IBCLR(Isomo,q-1) + p = TRAILZ(Isomo) + 1 + ! Check for Minimal alpha electrons (MS) + !if(POPCNT(Isomo).lt.MS)then + ! cycle + !endif + else + ! Find p + do ii=1,N_int + Isomo = Ialpha(ii,1) + Jsomo = psi_configuration(ii,1,i) + Idomo = Ialpha(ii,2) + Jdomo = psi_configuration(ii,2,i) + if(popcnt(IEOR(Idomo,Jdomo)) > 0)then + q = TRAILZ(IEOR(Idomo,Jdomo)) + 1 + ii * bit_kind_size + EXIT + endif + enddo + ! Find q + do ii=1,N_int + Isomo = Ialpha(ii,1) + Jsomo = psi_configuration(ii,1,i) + Isomo = IEOR(Isomo, Jsomo) + Isomo = IBCLR(Isomo,q-1) + if(popcnt(Isomo) > 0)then + p = TRAILZ(Isomo) + 1 + ii * bit_kind_size + EXIT + endif + enddo + endif !assert ( p == pp) !assert ( q == qq) - end if + endif case (2) ! DOMO -> SOMO !print *,"obt DOMO -> SOMO" extyp = 4 if(N_int.eq.1)then - IJsomo = IEOR(Isomo, Jsomo) -!IRP_IF WITHOUT_TRAILZ -! p = (popcnt(ieor( IAND(Jsomo,IJsomo), IAND(Jsomo,IJsomo)-1))-1) + 1 -!IRP_ELSE - p = TRAILZ(IAND(Jsomo,IJsomo)) + 1 -!IRP_ENDIF - IJsomo = IBCLR(IJsomo,p-1) -!IRP_IF WITHOUT_TRAILZ -! q = (popcnt(ieor( IJsomo , IJsomo -1))-1) + 1 -!IRP_ELSE - q = TRAILZ(IJsomo) + 1 -!IRP_ENDIF - - else - exc=0 - exc(0,1,1) = 0 - exc(0,2,1) = 0 - exc(0,1,2) = 0 - exc(0,2,2) = 0 - do ii = 1,2 - ishift = 1-bit_kind_size - do l=1,N_int - ishift = ishift + bit_kind_size - if (Jcfg(l,ii) == Icfg(l,ii)) then - cycle - endif - tmp = xor( Jcfg(l,ii), Icfg(l,ii) ) - particle = iand(tmp, Icfg(l,ii)) - hole = iand(tmp, Jcfg(l,ii)) - if (particle /= 0_bit_kind) then - tz = trailz(particle) - exc(0,2,ii) = 1 - exc(1,2,ii) = tz+ishift - !print *,"part ",tz+ishift, " ii=",ii - endif - if (hole /= 0_bit_kind) then - tz = trailz(hole) - exc(0,1,ii) = 1 - exc(1,1,ii) = tz+ishift - !print *,"hole ",tz+ishift, " ii=",ii - endif - - if ( iand(exc(0,1,ii),exc(0,2,ii)) /= 1) then ! exc(0,1,ii)/=1 and exc(0,2,ii) /= 1 - cycle - endif - - high = max(exc(1,1,ii), exc(1,2,ii))-1 - low = min(exc(1,1,ii), exc(1,2,ii)) - - ASSERT (low >= 0) - ASSERT (high > 0) - - k = shiftr(high,bit_kind_shift)+1 - j = shiftr(low,bit_kind_shift)+1 - m = iand(high,bit_kind_size-1) - n = iand(low,bit_kind_size-1) - - if (j==k) then - nperm = nperm + popcnt(iand(Jcfg(j,ii), & - iand( shiftl(1_bit_kind,m)-1_bit_kind, & - not(shiftl(1_bit_kind,n))+1_bit_kind)) ) - else - nperm = nperm + popcnt( & - iand(Jcfg(j,ii), & - iand(not(0_bit_kind), & - (not(shiftl(1_bit_kind,n)) + 1_bit_kind) ))) & - + popcnt(iand(Jcfg(k,ii), & - (shiftl(1_bit_kind,m) - 1_bit_kind ) )) - - do iii=j+1,k-1 - nperm = nperm + popcnt(Jcfg(iii,ii)) - end do - - endif - - ! Set p and q - q = max(exc(1,1,1),exc(1,1,2)) - p = max(exc(1,2,1),exc(1,2,2)) - exit - - enddo - enddo -endif + IJsomo = IEOR(Isomo, Jsomo) + p = TRAILZ(IAND(Jsomo,IJsomo)) + 1 + IJsomo = IBCLR(IJsomo,p-1) + q = TRAILZ(IJsomo) + 1 + else + ! Find p + do ii=1,N_int + Isomo = Ialpha(ii,1) + Jsomo = psi_configuration(ii,1,i) + Idomo = Ialpha(ii,2) + Jdomo = psi_configuration(ii,2,i) + IJsomo = IEOR(Isomo, Jsomo) + if(popcnt(IAND(Jsomo,IJsomo)) > 0)then + p = TRAILZ(IAND(Jsomo,IJsomo)) + 1 + ii * bit_kind_size + EXIT + endif + enddo + ! Find q + do ii=1,N_int + Isomo = Ialpha(ii,1) + Jsomo = psi_configuration(ii,1,i) + IJsomo = IEOR(Isomo, Jsomo) + IJsomo = IBCLR(IJsomo,p-1) + if(popcnt(IJsomo) > 0)then + q = TRAILZ(IJsomo) + 1 + ii * bit_kind_size + EXIT + endif + enddo + endif !assert ( p == pp) !assert ( q == qq) case default From f291078945a5c849f389fe6eea4bb0dae198dd9f Mon Sep 17 00:00:00 2001 From: v1j4y Date: Sat, 10 Dec 2022 17:11:19 +0100 Subject: [PATCH 09/21] Fixed bug in config CI. --- src/csf/configuration_CI_sigma_helpers.irp.f | 7 ++++--- src/csf/obtain_I_foralpha.irp.f | 4 ++++ src/csf/sigma_vector.irp.f | 6 +++++- 3 files changed, 13 insertions(+), 4 deletions(-) diff --git a/src/csf/configuration_CI_sigma_helpers.irp.f b/src/csf/configuration_CI_sigma_helpers.irp.f index 2bad88c0..8fb8383e 100644 --- a/src/csf/configuration_CI_sigma_helpers.irp.f +++ b/src/csf/configuration_CI_sigma_helpers.irp.f @@ -763,7 +763,7 @@ use bitmasks endif end do - print *,tableUniqueAlphas(:,:) + !print *,tableUniqueAlphas(:,:) ! prune list of alphas do i=1, N_int @@ -772,7 +772,7 @@ use bitmasks Jsomo(i) = Isomo(i) Jdomo(i) = Idomo(i) enddo - print *, " Isomo=",Isomo(1), " Idomo=", Idomo(1) + !print *, " Isomo=",Isomo(1), " Idomo=", Idomo(1) NalphaIcfg = 0 do i = 1, nholes @@ -816,7 +816,7 @@ use bitmasks Nsomo_J = nelall if(Nsomo_J .ge. NSOMOMin) then - print *," Idx = ",idxI, "p = ",pp, " q = ",qq," Jsomo=",Jsomo(1), " Jdomo=",IOR(Jdomo(1),ISHFT(1_8,n_core_orb)-1) + !print *," Idx = ",idxI, "p = ",pp, " q = ",qq," Jsomo=",Jsomo(1), " Jdomo=",IOR(Jdomo(1),ISHFT(1_8,n_core_orb)-1) NalphaIcfg += 1 alphasIcfg_list(:,1,idxI,NalphaIcfg) = Jcfg(:,1) if(n_core_orb .le. 63)then @@ -861,6 +861,7 @@ use bitmasks kstart = max(1,cfg_seniority_index(max(NSOMOMin,Nsomo_I-2))) ndiffDOMO = 0 do k = kstart, idxI-1 + ndiffSOMO = 0 do ii=1,N_int diffSOMO = IEOR(Icfg(ii,1),iand(act_bitmask(ii,1),psi_configuration(ii,1,k))) ndiffSOMO += POPCNT(diffSOMO(ii)) diff --git a/src/csf/obtain_I_foralpha.irp.f b/src/csf/obtain_I_foralpha.irp.f index a5a4164d..8606f556 100644 --- a/src/csf/obtain_I_foralpha.irp.f +++ b/src/csf/obtain_I_foralpha.irp.f @@ -482,6 +482,9 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI diagfactors(nconnectedI) = 1.0d0 else if((ndiffSOMO + ndiffDOMO) .EQ. 0) then ! find out all pq holes possible + !print *,"I = ",i + !print *,"I somo= ",psi_configuration(1,1,i), " domo=", psi_configuration(1,2,i) + !print *,"alp somo= ",Ialpha(1,1), " domo=", Ialpha(1,2) nholes = 0 ! holes in SOMO !Isomo = psi_configuration(1,1,i) @@ -549,6 +552,7 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI excitationTypes(nconnectedI) = extyp diagfactors(nconnectedI) = 2.0d0 endif + !print *,excitationIds(1,nconnectedI), excitationIds(2,nconnectedI) enddo endif end do diff --git a/src/csf/sigma_vector.irp.f b/src/csf/sigma_vector.irp.f index 207de336..76f9bfc3 100644 --- a/src/csf/sigma_vector.irp.f +++ b/src/csf/sigma_vector.irp.f @@ -1654,7 +1654,7 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze call obtain_connected_J_givenI(i, Icfg, listconnectedJ, idslistconnectedJ, nconnectedJ, ntotJ) ! TODO : remove doubly excited for return - !print *,"I=",i," isomo=",psi_configuration(1,1,i)," idomo=",psi_configuration(1,2,i), " psiout=",psi_out(1,5) + !print *,"I=",i," isomo=",psi_configuration(1,1,i)," idomo=",psi_configuration(1,2,i), " psiout=",psi_out(1,5), "Nalphas_Icfg=",Nalphas_Icfg do k = 1,Nalphas_Icfg ! Now generate all singly excited with respect to a given alpha CFG @@ -1807,6 +1807,10 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze !$OMP END DO !$OMP END PARALLEL + !print *," ----- " + !do i=1,sze + ! print *,"i=",i," psi_out(i)=",psi_out(1,i) + !end do call omp_set_max_active_levels(4) deallocate(diag_energies) From 5622b9790da599e15880d7aa0362db13b49e8ed3 Mon Sep 17 00:00:00 2001 From: v1j4y Date: Thu, 15 Dec 2022 17:15:30 +0100 Subject: [PATCH 10/21] Fixed some bugs. Diagonal energy is OK. Some bugs still present. --- src/csf/configuration_CI_sigma_helpers.irp.f | 55 ++-- src/csf/conversion.irp.f | 1 + src/csf/obtain_I_foralpha.irp.f | 72 +++-- src/csf/sigma_vector.irp.f | 282 +++++++++++++++---- src/davidson/diagonalization_hcfg.irp.f | 35 ++- 5 files changed, 329 insertions(+), 116 deletions(-) diff --git a/src/csf/configuration_CI_sigma_helpers.irp.f b/src/csf/configuration_CI_sigma_helpers.irp.f index 8fb8383e..19533bd5 100644 --- a/src/csf/configuration_CI_sigma_helpers.irp.f +++ b/src/csf/configuration_CI_sigma_helpers.irp.f @@ -524,7 +524,7 @@ use bitmasks !!! !!!END_PROVIDER - BEGIN_PROVIDER [ integer(bit_kind), alphasIcfg_list , (N_int,2,N_configuration,mo_num*(mo_num))] + BEGIN_PROVIDER [ integer(bit_kind), alphasIcfg_list , (N_int,2,N_configuration,mo_num*12)] &BEGIN_PROVIDER [ integer, NalphaIcfg_list, (N_configuration) ] implicit none !use bitmasks @@ -549,7 +549,8 @@ use bitmasks integer(bit_kind) :: Isomo(N_int), Isomop(N_int), Isomoq(N_int) integer(bit_kind) :: Jdomo(N_int), Jdomop(N_int), Jdomoq(N_int) integer(bit_kind) :: Jsomo(N_int), Jsomop(N_int), Jsomoq(N_int) - integer(bit_kind) :: diffDOMO(N_int), xordiffSOMODOMO(N_int), diffSOMO(N_int) + !integer(bit_kind) :: diffDOMO(N_int), xordiffSOMODOMO(N_int), diffSOMO(N_int) + integer(bit_kind) :: diffDOMO, xordiffSOMODOMO, diffSOMO integer :: ndiffSOMO integer :: ndiffDOMO integer :: nxordiffSOMODOMO @@ -674,13 +675,15 @@ use bitmasks Jsomo(jint) = IBCLR(Jsomo(jint),jpos) endif + Nsomo_J=0 do ii=1, N_int Jcfg(ii,1) = Jsomo(ii) Jcfg(ii,2) = Jdomo(ii) + Nsomo_J += POPCNT(Jsomo(ii)) enddo - call bitstring_to_list(Jcfg,listall,nelall,N_int) - Nsomo_J = nelall + !call bitstring_to_list(Jcfg(1,1),listall,nelall,N_int) + !Nsomo_J = nelall ! Check for Minimal alpha electrons (MS) if(Nsomo_J.lt.MS)then @@ -705,15 +708,13 @@ use bitmasks ndiffDOMO = 0 nxordiffSOMODOMO = 0 do ii = 1, N_int - Jsomo = Jcfg(ii,1) - Jdomo = Jcfg(ii,2) - diffSOMO = IEOR(Jsomo,iand(reunion_of_act_virt_bitmask(ii,1),psi_configuration(ii,1,k))) - ndiffSOMO += POPCNT(diffSOMO(ii)) - diffDOMO = IEOR(Jdomo,iand(reunion_of_act_virt_bitmask(ii,2),psi_configuration(ii,2,k))) + diffSOMO = IEOR(Jcfg(ii,1),iand(reunion_of_act_virt_bitmask(ii,1),psi_configuration(ii,1,k))) + ndiffSOMO += POPCNT(diffSOMO) + diffDOMO = IEOR(Jcfg(ii,2),iand(reunion_of_act_virt_bitmask(ii,2),psi_configuration(ii,2,k))) xordiffSOMODOMO = IEOR(diffSOMO,diffDOMO) - ndiffDOMO += POPCNT(diffDOMO(ii)) - nxordiffSOMODOMO += POPCNT(xordiffSOMODOMO(ii)) - nxordiffSOMODOMO += ndiffSOMO + ndiffDOMO + ndiffDOMO += POPCNT(diffDOMO) + nxordiffSOMODOMO += POPCNT(xordiffSOMODOMO) + nxordiffSOMODOMO += POPCNT(diffSOMO) + POPCNT(diffDOMO) end do if((ndiffSOMO .ne. 0) .and. (ndiffSOMO .ne. 2)) cycle @@ -818,6 +819,7 @@ use bitmasks if(Nsomo_J .ge. NSOMOMin) then !print *," Idx = ",idxI, "p = ",pp, " q = ",qq," Jsomo=",Jsomo(1), " Jdomo=",IOR(Jdomo(1),ISHFT(1_8,n_core_orb)-1) NalphaIcfg += 1 + !print *," Idx = ",idxI, " Nalpha=",NalphaIcfg alphasIcfg_list(:,1,idxI,NalphaIcfg) = Jcfg(:,1) if(n_core_orb .le. 63)then alphasIcfg_list(1,2,idxI,NalphaIcfg) = IOR(Jcfg(1,2),ISHFT(1_8,n_core_orb)-1) @@ -864,7 +866,7 @@ use bitmasks ndiffSOMO = 0 do ii=1,N_int diffSOMO = IEOR(Icfg(ii,1),iand(act_bitmask(ii,1),psi_configuration(ii,1,k))) - ndiffSOMO += POPCNT(diffSOMO(ii)) + ndiffSOMO += POPCNT(diffSOMO) end do ! ndiffSOMO cannot be 0 (I /= k) ! if ndiffSOMO /= 2 then it has to be greater than 2 and hense @@ -875,8 +877,8 @@ use bitmasks do ii=1,N_int diffDOMO = IEOR(Icfg(ii,2),iand(act_bitmask(ii,1),psi_configuration(ii,2,k))) xordiffSOMODOMO = IEOR(diffSOMO,diffDOMO) - ndiffDOMO += POPCNT(diffDOMO(ii)) - nxordiffSOMODOMO += POPCNT(xordiffSOMODOMO(ii)) + ndiffDOMO += POPCNT(diffDOMO) + nxordiffSOMODOMO += POPCNT(xordiffSOMODOMO) end do if((ndiffSOMO+ndiffDOMO+nxordiffSOMODOMO .EQ. 4)) then ppExistsQ = .TRUE. @@ -926,7 +928,8 @@ END_PROVIDER integer(bit_kind) :: Isomo(N_int), Isomop(N_int), Isomoq(N_int) integer(bit_kind) :: Jdomo(N_int), Jdomop(N_int), Jdomoq(N_int) integer(bit_kind) :: Jsomo(N_int), Jsomop(N_int), Jsomoq(N_int) - integer(bit_kind) :: diffDOMO(N_int), xordiffSOMODOMO(N_int), diffSOMO(N_int) + !integer(bit_kind) :: diffDOMO(N_int), xordiffSOMODOMO(N_int), diffSOMO(N_int) + integer(bit_kind) :: diffDOMO, xordiffSOMODOMO, diffSOMO integer :: ndiffSOMO integer :: ndiffDOMO integer :: nxordiffSOMODOMO @@ -1084,15 +1087,13 @@ END_PROVIDER ndiffDOMO = 0 nxordiffSOMODOMO = 0 do ii = 1, N_int - Jsomo = Jcfg(ii,1) - Jdomo = Jcfg(ii,2) - diffSOMO = IEOR(Jsomo,iand(reunion_of_act_virt_bitmask(ii,1),psi_configuration(ii,1,k))) - ndiffSOMO += POPCNT(diffSOMO(ii)) - diffDOMO = IEOR(Jdomo,iand(reunion_of_act_virt_bitmask(ii,2),psi_configuration(ii,2,k))) + diffSOMO = IEOR(Jcfg(ii,1),iand(reunion_of_act_virt_bitmask(ii,1),psi_configuration(ii,1,k))) + ndiffSOMO += POPCNT(diffSOMO) + diffDOMO = IEOR(Jcfg(ii,2),iand(reunion_of_act_virt_bitmask(ii,2),psi_configuration(ii,2,k))) xordiffSOMODOMO = IEOR(diffSOMO,diffDOMO) - ndiffDOMO += POPCNT(diffDOMO(ii)) - nxordiffSOMODOMO += POPCNT(xordiffSOMODOMO(ii)) - nxordiffSOMODOMO += ndiffSOMO + ndiffDOMO + ndiffDOMO += POPCNT(diffDOMO) + nxordiffSOMODOMO += POPCNT(xordiffSOMODOMO) + nxordiffSOMODOMO += POPCNT(diffSOMO) + POPCNT(diffDOMO) end do if((ndiffSOMO .NE. 0) .AND. (ndiffSOMO .NE. 2)) cycle !if(POPCNT(IEOR(diffSOMO,diffDOMO)) .LE. 1 .AND. ndiffDOMO .LT. 3) then @@ -1211,7 +1212,7 @@ END_PROVIDER do k = 1, idxI-1 do ii=1,N_int diffSOMO = IEOR(Icfg(ii,1),iand(act_bitmask(ii,1),psi_configuration(ii,1,k))) - ndiffSOMO += POPCNT(diffSOMO(ii)) + ndiffSOMO += POPCNT(diffSOMO) end do ! ndiffSOMO cannot be 0 (I /= k) ! if ndiffSOMO /= 2 then it has to be greater than 2 and hense @@ -1222,8 +1223,8 @@ END_PROVIDER do ii=1,N_int diffDOMO = IEOR(Icfg(ii,2),iand(act_bitmask(ii,1),psi_configuration(ii,2,k))) xordiffSOMODOMO = IEOR(diffSOMO,diffDOMO) - ndiffDOMO += POPCNT(diffDOMO(ii)) - nxordiffSOMODOMO += POPCNT(xordiffSOMODOMO(ii)) + ndiffDOMO += POPCNT(diffDOMO) + nxordiffSOMODOMO += POPCNT(xordiffSOMODOMO) end do if((ndiffSOMO+ndiffDOMO+nxordiffSOMODOMO .EQ. 4) .AND. ndiffSOMO .EQ. 2) then ppExistsQ = .TRUE. diff --git a/src/csf/conversion.irp.f b/src/csf/conversion.irp.f index 494c3bfa..7c6c8363 100644 --- a/src/csf/conversion.irp.f +++ b/src/csf/conversion.irp.f @@ -114,6 +114,7 @@ subroutine convertWFfromCSFtoDET(N_st,psi_coef_cfg_in, psi_coef_det) integer :: idx integer MS MS = elec_alpha_num-elec_beta_num + print *,"size=",size(tmp_psi_coef_det,1)," ",size(tmp_psi_coef_det,2) countcsf = 0 diff --git a/src/csf/obtain_I_foralpha.irp.f b/src/csf/obtain_I_foralpha.irp.f index 8606f556..1d4e81fc 100644 --- a/src/csf/obtain_I_foralpha.irp.f +++ b/src/csf/obtain_I_foralpha.irp.f @@ -102,7 +102,7 @@ subroutine obtain_connected_J_givenI(idxI, givenI, connectedI, idxs_connectedI, xordiffSOMODOMO = IEOR(diffSOMO,diffDOMO) ndiffDOMO += POPCNT(diffDOMO) nxordiffSOMODOMO += POPCNT(xordiffSOMODOMO) - nxordiffSOMODOMO += ndiffSOMO + ndiffDOMO + nxordiffSOMODOMO += POPCNT(diffSOMO) + POPCNT(diffDOMO) end do if((nxordiffSOMODOMO .EQ. 4) .AND. ndiffSOMO .EQ. 2) then @@ -243,13 +243,16 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI integer :: listholes(mo_num) integer :: holetype(mo_num) integer :: end_index, ishift - integer :: Nsomo_alpha, pp,qq, nperm + integer :: Nsomo_alpha, pp,qq, nperm, iint, ipos integer*8 :: MS integer :: exc(0:2,2,2), tz, m, n, high, low integer :: listall(N_int*bit_kind_size), nelall + integer :: nconnectedExtradiag, nconnectedDiag integer(bit_kind) :: hole, particle, tmp MS = elec_alpha_num-elec_beta_num + nconnectedExtradiag=0 + nconnectedDiag=0 nconnectedI = 0 end_index = N_configuration @@ -260,10 +263,12 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI !Nsomo_alpha = POPCNT(Isomo) Icfg = Ialpha Nsomo_alpha = 0 + !print *," Ialpha=" do i=1,N_int Isomo = Ialpha(i,1) Idomo = Ialpha(i,2) Nsomo_alpha += POPCNT(Isomo) + !print *,Isomo, Idomo, "Nsomo=",Nsomo_alpha end do end_index = min(N_configuration,cfg_seniority_index(min(Nsomo_alpha+4,elec_num))-1) if(end_index .LT. 0) end_index= N_configuration @@ -293,20 +298,25 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI ndiffSOMO = 0 ndiffDOMO = 0 nxordiffSOMODOMO = 0 + nsomoJ=0 + nsomoalpha=0 do ii=1,N_int Isomo = Ialpha(ii,1) Idomo = Ialpha(ii,2) Jsomo = psi_configuration(ii,1,i) Jdomo = psi_configuration(ii,2,i) + nsomoJ += POPCNT(Jsomo) + nsomoalpha += POPCNT(Isomo) diffSOMO = IEOR(Isomo,Jsomo) ndiffSOMO += POPCNT(diffSOMO) diffDOMO = IEOR(Idomo,Jdomo) xordiffSOMODOMO = IEOR(diffSOMO,diffDOMO) ndiffDOMO += POPCNT(diffDOMO) nxordiffSOMODOMO += POPCNT(xordiffSOMODOMO) - nxordiffSOMODOMO += ndiffSOMO + ndiffDOMO + nxordiffSOMODOMO += POPCNT(diffSOMO) + POPCNT(diffDOMO) end do - Jcfg = psi_configuration(:,:,i) + !Jcfg = psi_configuration(:,:,i) + !print *,"nxordiffSOMODOMO(4)=",nxordiffSOMODOMO, " ndiffSOMO(2)=",ndiffSOMO if((nxordiffSOMODOMO .EQ. 4) .AND. ndiffSOMO .EQ. 2) then select case(ndiffDOMO) @@ -328,7 +338,7 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI Jsomo = psi_configuration(ii,1,i) IJsomo = IEOR(Isomo, Jsomo) if(popcnt(IAND(Isomo,IJsomo)) > 0)then - p = TRAILZ(IAND(Isomo,IJsomo)) + 1 + ii * bit_kind_size + p = TRAILZ(IAND(Isomo,IJsomo)) + 1 + (ii-1) * bit_kind_size EXIT endif end do @@ -337,22 +347,24 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI Isomo = Ialpha(ii,1) Jsomo = psi_configuration(ii,1,i) IJsomo = IEOR(Isomo, Jsomo) - IJsomo = IBCLR(IJsomo,p-1) + iint = shiftr(p-1,bit_kind_shift) + 1 + ipos = p-shiftl((iint-1),bit_kind_shift) + if(iint .eq. ii)then + IJsomo = IBCLR(IJsomo,ipos-1) + endif if(popcnt(IJsomo) > 0)then - q = TRAILZ(IJsomo) + 1 + ii * bit_kind_size + q = TRAILZ(IJsomo) + 1 + (ii-1) * bit_kind_size EXIT endif enddo endif !assert ( p == pp) !assert ( q == qq) - !print *," --- p=",p," q=",q + !print *," 1--- p=",p," q=",q case (1) ! DOMO -> VMO ! or ! SOMO -> SOMO - nsomoJ = POPCNT(Jsomo) - nsomoalpha = POPCNT(Isomo) if(nsomoJ .GT. nsomoalpha) then ! DOMO -> VMO !print *,"obt DOMO -> VMO" @@ -371,7 +383,7 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI Idomo = Ialpha(ii,2) Jdomo = psi_configuration(ii,2,i) if(popcnt(IEOR(Idomo,Jdomo)) > 0)then - p = TRAILZ(IEOR(Idomo,Jdomo)) + 1 + ii * bit_kind_size + p = TRAILZ(IEOR(Idomo,Jdomo)) + 1 + (ii-1) * bit_kind_size EXIT endif end do @@ -380,9 +392,13 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI Isomo = Ialpha(ii,1) Jsomo = psi_configuration(ii,1,i) Isomo = IEOR(Isomo, Jsomo) - Isomo = IBCLR(Isomo,p-1) + iint = shiftr(p-1,bit_kind_shift) + 1 + ipos = p-shiftl((iint-1),bit_kind_shift) + if(iint .eq. ii)then + Isomo = IBCLR(Isomo,ipos-1) + endif if(popcnt(Isomo) > 0)then - q = TRAILZ(Isomo) + 1 + ii * bit_kind_size + q = TRAILZ(Isomo) + 1 + (ii-1) * bit_kind_size EXIT endif end do @@ -404,13 +420,16 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI !endif else ! Find p + !print *,"Ialpha somo=",Ialpha(1,1), Ialpha(2,1)," Ialpha domo=",Ialpha(1,2), Ialpha(2,2) + !print *,"J somo=",psi_configuration(1,1,i), psi_configuration(2,1,i)," J domo=",psi_configuration(1,2,i),& + !psi_configuration(2,2,i) do ii=1,N_int Isomo = Ialpha(ii,1) Jsomo = psi_configuration(ii,1,i) Idomo = Ialpha(ii,2) Jdomo = psi_configuration(ii,2,i) if(popcnt(IEOR(Idomo,Jdomo)) > 0)then - q = TRAILZ(IEOR(Idomo,Jdomo)) + 1 + ii * bit_kind_size + q = TRAILZ(IEOR(Idomo,Jdomo)) + 1 + (ii-1) * bit_kind_size EXIT endif enddo @@ -419,9 +438,14 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI Isomo = Ialpha(ii,1) Jsomo = psi_configuration(ii,1,i) Isomo = IEOR(Isomo, Jsomo) - Isomo = IBCLR(Isomo,q-1) + iint = shiftr(q-1,bit_kind_shift) + 1 + ipos = q-shiftl((iint-1),bit_kind_shift) + if(iint .eq. ii)then + Isomo = IBCLR(Isomo,ipos-1) + endif + !print *,"ii=",ii," Isomo=",Isomo if(popcnt(Isomo) > 0)then - p = TRAILZ(Isomo) + 1 + ii * bit_kind_size + p = TRAILZ(Isomo) + 1 + (ii-1) * bit_kind_size EXIT endif enddo @@ -429,6 +453,7 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI !assert ( p == pp) !assert ( q == qq) endif + !print *," 2--- p=",p," q=",q case (2) ! DOMO -> SOMO !print *,"obt DOMO -> SOMO" @@ -447,7 +472,7 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI Jdomo = psi_configuration(ii,2,i) IJsomo = IEOR(Isomo, Jsomo) if(popcnt(IAND(Jsomo,IJsomo)) > 0)then - p = TRAILZ(IAND(Jsomo,IJsomo)) + 1 + ii * bit_kind_size + p = TRAILZ(IAND(Jsomo,IJsomo)) + 1 + (ii-1) * bit_kind_size EXIT endif enddo @@ -456,20 +481,26 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI Isomo = Ialpha(ii,1) Jsomo = psi_configuration(ii,1,i) IJsomo = IEOR(Isomo, Jsomo) - IJsomo = IBCLR(IJsomo,p-1) + iint = shiftr(p-1,bit_kind_shift) + 1 + ipos = p-shiftl((iint-1),bit_kind_shift) + if(iint .eq. ii)then + IJsomo = IBCLR(IJsomo,ipos-1) + endif if(popcnt(IJsomo) > 0)then - q = TRAILZ(IJsomo) + 1 + ii * bit_kind_size + q = TRAILZ(IJsomo) + 1 + (ii-1) * bit_kind_size EXIT endif enddo endif !assert ( p == pp) !assert ( q == qq) + !print *," 3--- p=",p," q=",q case default print *,"something went wront in get connectedI" end select starti = psi_config_data(i,1) endi = psi_config_data(i,2) + nconnectedExtradiag+=1 nconnectedI += 1 do k=1,N_int connectedI(k,1,nconnectedI) = psi_configuration(k,1,i) @@ -534,6 +565,7 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI if(holetype(k) .EQ. 1) then starti = psi_config_data(i,1) endi = psi_config_data(i,2) + nconnectedDiag+=1 nconnectedI += 1 connectedI(:,:,nconnectedI) = psi_configuration(:,:,i) idxs_connectedI(nconnectedI)=starti @@ -544,6 +576,7 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI else starti = psi_config_data(i,1) endi = psi_config_data(i,2) + nconnectedDiag+=1 nconnectedI += 1 connectedI(:,:,nconnectedI) = psi_configuration(:,:,i) idxs_connectedI(nconnectedI)=starti @@ -556,5 +589,6 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI enddo endif end do + !print *,"nconnectedExtradiag=",nconnectedExtradiag," nconnectedDiad=",nconnectedDiag end subroutine obtain_connected_I_foralpha diff --git a/src/csf/sigma_vector.irp.f b/src/csf/sigma_vector.irp.f index 76f9bfc3..9fe81fe9 100644 --- a/src/csf/sigma_vector.irp.f +++ b/src/csf/sigma_vector.irp.f @@ -885,7 +885,7 @@ subroutine calculate_preconditioner_cfg(diag_energies) Idomo = psi_configuration(1,2,i) Icfg(1,1) = psi_configuration(1,1,i) Icfg(1,2) = psi_configuration(1,2,i) - NSOMOI = getNSOMO(psi_configuration(:,:,i)) + !NSOMOI = getNSOMO(psi_configuration(:,:,i)) starti = psi_config_data(i,1) endi = psi_config_data(i,2) @@ -1239,27 +1239,34 @@ subroutine convertOrbIdsToModelSpaceIds(Ialpha, Jcfg, p, q, extype, pmodel, qmod integer,intent(in) :: p,q integer,intent(in) :: extype integer,intent(out) :: pmodel,qmodel - !integer(bit_kind) :: Isomo(N_int) - !integer(bit_kind) :: Idomo(N_int) - !integer(bit_kind) :: Jsomo(N_int) - !integer(bit_kind) :: Jdomo(N_int) - integer*8 :: Isomo - integer*8 :: Idomo - integer*8 :: Jsomo - integer*8 :: Jdomo + integer(bit_kind) :: Isomo(N_int) + integer(bit_kind) :: Idomo(N_int) + integer(bit_kind) :: Jsomo(N_int) + integer(bit_kind) :: Jdomo(N_int) + !integer*8 :: Isomo + !integer*8 :: Idomo + !integer*8 :: Jsomo + !integer*8 :: Jdomo integer*8 :: mask - integer :: iint, ipos + integer :: iint, ipos, ii !integer(bit_kind) :: Isomotmp(N_int) !integer(bit_kind) :: Jsomotmp(N_int) integer*8 :: Isomotmp integer*8 :: Jsomotmp integer :: pos0,pos0prev + integer :: tmpp, tmpq ! TODO Flag (print) when model space indices is > 64 - Isomo = Ialpha(1,1) - Idomo = Ialpha(1,2) - Jsomo = Jcfg(1,1) - Jdomo = Jcfg(1,2) + do ii=1,N_int + !Isomo = Ialpha(ii,1) + !Idomo = Ialpha(ii,2) + !Jsomo = Jcfg(ii,1) + !Jdomo = Jcfg(ii,2) + Isomo(ii) = Ialpha(ii,1) + Idomo(ii) = Ialpha(ii,2) + Jsomo(ii) = Jcfg(ii,1) + Jdomo(ii) = Jcfg(ii,2) + end do pos0prev = 0 pmodel = p qmodel = q @@ -1273,40 +1280,139 @@ subroutine convertOrbIdsToModelSpaceIds(Ialpha, Jcfg, p, q, extype, pmodel, qmod ! SOMO -> SOMO ! remove all domos !print *,"type -> SOMO -> SOMO" - mask = ISHFT(1_8,p) - 1 - Isomotmp = IAND(Isomo,mask) - pmodel = POPCNT(mask) - POPCNT(XOR(Isomotmp,mask)) - mask = ISHFT(1_8,q) - 1 - Isomotmp = IAND(Isomo,mask) - qmodel = POPCNT(mask) - POPCNT(XOR(Isomotmp,mask)) + !mask = ISHFT(1_8,p) - 1 + !Isomotmp = IAND(Isomo,mask) + !pmodel = POPCNT(mask) - POPCNT(XOR(Isomotmp,mask)) + !mask = ISHFT(1_8,q) - 1 + !Isomotmp = IAND(Isomo,mask) + !qmodel = POPCNT(mask) - POPCNT(XOR(Isomotmp,mask)) + + iint = shiftr(p-1,bit_kind_shift) + 1 + ipos = p-shiftl((iint-1),bit_kind_shift)-1 + tmpp = 0 + !print *,"iint=",iint, " p=",p + do ii=1,iint-1 + mask = ISHFT(1_bit_kind,-1)-1_bit_kind + Isomotmp = IAND(Isomo(ii),mask) + tmpp += POPCNT(mask) - POPCNT(XOR(Isomotmp,mask)) + end do + mask = ISHFT(1_bit_kind,ipos+1) - 1 + Isomotmp = IAND(Isomo(iint),mask) + pmodel = tmpp + POPCNT(mask) - POPCNT(XOR(Isomotmp,mask)) + !print *,"iint=",iint, " ipos=",ipos,"pmodel=",pmodel, XOR(Isomotmp,mask),Isomo(iint) + + iint = shiftr(q-1,bit_kind_shift) + 1 + ipos = q-shiftl((iint-1),bit_kind_shift)-1 + tmpq = 0 + do ii=1,iint-1 + mask = ISHFT(1_bit_kind,-1)-1_bit_kind + Isomotmp = IAND(Isomo(ii),mask) + tmpq += POPCNT(mask) - POPCNT(XOR(Isomotmp,mask)) + end do + mask = ISHFT(1_bit_kind,ipos+1) - 1 + Isomotmp = IAND(Isomo(iint),mask) + qmodel = tmpq + POPCNT(mask) - POPCNT(XOR(Isomotmp,mask)) + !print *,"iint=",iint, " ipos=",ipos,"qmodel=",qmodel case (2) ! DOMO -> VMO ! remove all domos except one at p !print *,"type -> DOMO -> VMO" - mask = ISHFT(1_8,p) - 1 - Jsomotmp = IAND(Jsomo,mask) - pmodel = POPCNT(mask) - POPCNT(XOR(Jsomotmp,mask)) - mask = ISHFT(1_8,q) - 1 - Jsomotmp = IAND(Jsomo,mask) - qmodel = POPCNT(mask) - POPCNT(XOR(Jsomotmp,mask)) + !mask = ISHFT(1_8,p) - 1 + !Jsomotmp = IAND(Jsomo,mask) + !pmodel = POPCNT(mask) - POPCNT(XOR(Jsomotmp,mask)) + !mask = ISHFT(1_8,q) - 1 + !Jsomotmp = IAND(Jsomo,mask) + !qmodel = POPCNT(mask) - POPCNT(XOR(Jsomotmp,mask)) + + iint = shiftr(p-1,bit_kind_shift) + 1 + ipos = p-shiftl((iint-1),bit_kind_shift)-1 + tmpp = 0 + do ii=1,iint-1 + mask = ISHFT(1_bit_kind,-1)-1_bit_kind + Jsomotmp = IAND(Jsomo(ii),mask) + tmpp += POPCNT(mask) - POPCNT(XOR(Jsomotmp,mask)) + end do + mask = ISHFT(1_bit_kind,ipos+1) - 1 + Jsomotmp = IAND(Jsomo(iint),mask) + pmodel = tmpp + POPCNT(mask) - POPCNT(XOR(Jsomotmp,mask)) + + iint = shiftr(q-1,bit_kind_shift) + 1 + ipos = q-shiftl((iint-1),bit_kind_shift)-1 + tmpq = 0 + do ii=1,iint-1 + mask = ISHFT(1_bit_kind,-1)-1_bit_kind + Jsomotmp = IAND(Jsomo(ii),mask) + tmpq += POPCNT(mask) - POPCNT(XOR(Jsomotmp,mask)) + end do + mask = ISHFT(1_bit_kind,ipos+1) - 1 + Jsomotmp = IAND(Jsomo(iint),mask) + qmodel = tmpq + POPCNT(mask) - POPCNT(XOR(Jsomotmp,mask)) case (3) ! SOMO -> VMO !print *,"type -> SOMO -> VMO" !Isomo = IEOR(Isomo,Jsomo) if(p.LT.q) then - mask = ISHFT(1_8,p) - 1 - Isomo = IAND(Isomo,mask) - pmodel = POPCNT(mask) - POPCNT(XOR(Isomo,mask)) - mask = ISHFT(1_8,q) - 1 - Jsomo = IAND(Jsomo,mask) - qmodel = POPCNT(mask) - POPCNT(XOR(Jsomo,mask)) + 1 + !mask = ISHFT(1_8,p) - 1 + !Isomo = IAND(Isomo,mask) + !pmodel = POPCNT(mask) - POPCNT(XOR(Isomo,mask)) + !mask = ISHFT(1_8,q) - 1 + !Jsomo = IAND(Jsomo,mask) + !qmodel = POPCNT(mask) - POPCNT(XOR(Jsomo,mask)) + 1 + + iint = shiftr(p-1,bit_kind_shift) + 1 + ipos = p-shiftl((iint-1),bit_kind_shift)-1 + tmpp = 0 + do ii=1,iint-1 + mask = ISHFT(1_bit_kind,-1)-1_bit_kind + Isomotmp = IAND(Isomo(ii),mask) + tmpp += POPCNT(mask) - POPCNT(XOR(Isomotmp,mask)) + end do + mask = ISHFT(1_8,ipos+1) - 1 + Isomotmp = IAND(Isomo(iint),mask) + pmodel = tmpp + POPCNT(mask) - POPCNT(XOR(Isomotmp,mask)) + + iint = shiftr(q-1,bit_kind_shift) + 1 + ipos = q-shiftl((iint-1),bit_kind_shift)-1 + tmpq = 0 + do ii=1,iint-1 + mask = ISHFT(1_bit_kind,-1)-1_bit_kind + Jsomotmp = IAND(Jsomo(ii),mask) + tmpq += POPCNT(mask) - POPCNT(XOR(Jsomotmp,mask)) + end do + mask = ISHFT(1_bit_kind,ipos+1) - 1 + Jsomotmp = IAND(Jsomo(iint),mask) + qmodel = tmpq + POPCNT(mask) - POPCNT(XOR(Jsomotmp,mask)) + 1 else - mask = ISHFT(1_8,p) - 1 - Isomo = IAND(Isomo,mask) - pmodel = POPCNT(mask) - POPCNT(XOR(Isomo,mask)) + 1 - mask = ISHFT(1_8,q) - 1 - Jsomo = IAND(Jsomo,mask) - qmodel = POPCNT(mask) - POPCNT(XOR(Jsomo,mask)) + !mask = ISHFT(1_8,p) - 1 + !Isomo = IAND(Isomo,mask) + !pmodel = POPCNT(mask) - POPCNT(XOR(Isomo,mask)) + 1 + !mask = ISHFT(1_8,q) - 1 + !Jsomo = IAND(Jsomo,mask) + !qmodel = POPCNT(mask) - POPCNT(XOR(Jsomo,mask)) + + iint = shiftr(p-1,bit_kind_shift) + 1 + ipos = p-shiftl((iint-1),bit_kind_shift)-1 + tmpp = 0 + do ii=1,iint-1 + mask = ISHFT(1_bit_kind,-1)-1_bit_kind + Isomotmp = IAND(Isomo(ii),mask) + tmpp += POPCNT(mask) - POPCNT(XOR(Isomotmp,mask)) + end do + mask = ISHFT(1_bit_kind,ipos+1) - 1 + Isomotmp = IAND(Isomo(iint),mask) + pmodel = tmpp + POPCNT(mask) - POPCNT(XOR(Isomotmp,mask)) + 1 + + iint = shiftr(q-1,bit_kind_shift) + 1 + ipos = q-shiftl((iint-1),bit_kind_shift)-1 + tmpq = 0 + do ii=1,iint-1 + mask = ISHFT(1_bit_kind,-1)-1_bit_kind + Jsomotmp = IAND(Jsomo(ii),mask) + tmpq += POPCNT(mask) - POPCNT(XOR(Jsomotmp,mask)) + end do + mask = ISHFT(1_bit_kind,ipos+1) - 1 + Jsomotmp = IAND(Jsomo(iint),mask) + qmodel = tmpq + POPCNT(mask) - POPCNT(XOR(Jsomotmp,mask)) endif case (4) ! DOMO -> SOMO @@ -1314,19 +1420,67 @@ subroutine convertOrbIdsToModelSpaceIds(Ialpha, Jcfg, p, q, extype, pmodel, qmod !print *,"type -> DOMO -> SOMO" !Isomo = IEOR(Isomo,Jsomo) if(p.LT.q) then - mask = ISHFT(1_8,p) - 1 - Jsomo = IAND(Jsomo,mask) - pmodel = POPCNT(mask) - POPCNT(XOR(Jsomo,mask)) - mask = ISHFT(1_8,q) - 1 - Isomo = IAND(Isomo,mask) - qmodel = POPCNT(mask) - POPCNT(XOR(Isomo,mask)) + 1 + !mask = ISHFT(1_8,p) - 1 + !Jsomo = IAND(Jsomo,mask) + !pmodel = POPCNT(mask) - POPCNT(XOR(Jsomo,mask)) + !mask = ISHFT(1_8,q) - 1 + !Isomo = IAND(Isomo,mask) + !qmodel = POPCNT(mask) - POPCNT(XOR(Isomo,mask)) + 1 + + iint = shiftr(p-1,bit_kind_shift) + 1 + ipos = p-shiftl((iint-1),bit_kind_shift)-1 + tmpp = 0 + do ii=1,iint-1 + mask = ISHFT(1_bit_kind,-1)-1_bit_kind + Jsomotmp = IAND(Jsomo(ii),mask) + tmpp += POPCNT(mask) - POPCNT(XOR(Jsomotmp,mask)) + end do + mask = ISHFT(1_bit_kind,ipos+1) - 1 + Jsomotmp = IAND(Jsomo(iint),mask) + pmodel = tmpp + POPCNT(mask) - POPCNT(XOR(Jsomotmp,mask)) + + iint = shiftr(q-1,bit_kind_shift) + 1 + ipos = q-shiftl((iint-1),bit_kind_shift)-1 + tmpq = 0 + do ii=1,iint-1 + mask = ISHFT(1_bit_kind,-1)-1_bit_kind + Isomotmp = IAND(Isomo(ii),mask) + tmpq += POPCNT(mask) - POPCNT(XOR(Isomotmp,mask)) + end do + mask = ISHFT(1_bit_kind,ipos+1) - 1 + Isomotmp = IAND(Isomo(iint),mask) + qmodel = tmpq + POPCNT(mask) - POPCNT(XOR(Isomotmp,mask)) + 1 else - mask = ISHFT(1_8,p) - 1 - Jsomo = IAND(Jsomo,mask) - pmodel = POPCNT(mask) - POPCNT(XOR(Jsomo,mask)) + 1 - mask = ISHFT(1_8,q) - 1 - Isomo = IAND(Isomo,mask) - qmodel = POPCNT(mask) - POPCNT(XOR(Isomo,mask)) + !mask = ISHFT(1_8,p) - 1 + !Jsomo = IAND(Jsomo,mask) + !pmodel = POPCNT(mask) - POPCNT(XOR(Jsomo,mask)) + 1 + !mask = ISHFT(1_8,q) - 1 + !Isomo = IAND(Isomo,mask) + !qmodel = POPCNT(mask) - POPCNT(XOR(Isomo,mask)) + + iint = shiftr(p-1,bit_kind_shift) + 1 + ipos = p-shiftl((iint-1),bit_kind_shift)-1 + tmpp = 0 + do ii=1,iint-1 + mask = ISHFT(1_bit_kind,-1)-1_bit_kind + Jsomotmp = IAND(Jsomo(ii),mask) + tmpp += POPCNT(mask) - POPCNT(XOR(Jsomotmp,mask)) + end do + mask = ISHFT(1_bit_kind,ipos+1) - 1 + Jsomotmp = IAND(Jsomo(iint),mask) + pmodel = tmpp + POPCNT(mask) - POPCNT(XOR(Jsomotmp,mask)) + 1 + + iint = shiftr(q-1,bit_kind_shift) + 1 + ipos = q-shiftl((iint-1),bit_kind_shift)-1 + tmpq = 0 + do ii=1,iint-1 + mask = ISHFT(1_bit_kind,-1)-1_bit_kind + Isomotmp = IAND(Isomo(ii),mask) + tmpq += POPCNT(mask) - POPCNT(XOR(Isomotmp,mask)) + end do + mask = ISHFT(1_bit_kind,ipos+1) - 1 + Isomotmp = IAND(Isomo(iint),mask) + qmodel = tmpq + POPCNT(mask) - POPCNT(XOR(Isomotmp,mask)) endif case default print *,"something is wrong in convertOrbIdsToModelSpaceIds" @@ -1415,7 +1569,7 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze allocate(diag_energies(n_CSF)) call calculate_preconditioner_cfg(diag_energies) - !print *," diag energy =",diag_energies(1) + print *," diag energy =",diag_energies(1) MS = 0 norm_coef_cfg=0.d0 @@ -1590,6 +1744,7 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze call omp_set_lock(lock(jj)) do kk = 1,n_st psi_out(kk,jj) = psi_out(kk,jj) + meCC1 * psi_in(kk,ii) + print *,"jj=",jj,'psi_out(kk)=',psi_out(kk,jj) enddo call omp_unset_lock(lock(jj)) enddo @@ -1666,7 +1821,8 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze nconnectedI, excitationIds, excitationTypes, diagfactors) !if(i .EQ. 1) then - ! print *,'k=',k,' kcfgSOMO=',alphas_Icfg(1,1,k),' ',POPCNT(alphas_Icfg(1,1,k)),' kcfgDOMO=',alphas_Icfg(1,2,k),' ',POPCNT(alphas_Icfg(1,2,k)) + ! print *,'k=',k,' kcfgSOMO=',alphas_Icfg(1,1,k),alphas_Icfg(2,1,k),' ',POPCNT(alphas_Icfg(1,1,k)),' & + ! kcfgDOMO=',alphas_Icfg(1,2,k),alphas_Icfg(2,2,k),' ',POPCNT(alphas_Icfg(1,2,k)), " NconnectedI=",nconnectedI !endif @@ -1682,9 +1838,13 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze NSOMOI = getNSOMO(connectedI_alpha(:,:,j)) p = excitationIds(1,j) q = excitationIds(2,j) + !print *,"j=",j, " p=",p," q=",q extype = excitationTypes(j) call convertOrbIdsToModelSpaceIds(alphas_Icfg(1,1,k), connectedI_alpha(1,1,j), p, q, extype, pmodel, qmodel) ! for E_pp E_rs and E_ppE_rr case + !if(k.eq.722)then + ! print *,"j=",j," k=",k,"p=",p,"q=",q,"NSOMOalpha=",NSOMOalpha, "pmodel=",pmodel,"qmodel=",qmodel, "extype=",extype + !endif rowsikpq = AIJpqMatrixDimsList(NSOMOalpha,extype,pmodel,qmodel,1) colsikpq = AIJpqMatrixDimsList(NSOMOalpha,extype,pmodel,qmodel,2) !print *,"j=",j," Nsomo=",NSOMOalpha," rowsikpq=",rowsikpq," colsikpq=",colsikpq, " p=",pmodel," q=",qmodel, " extyp=",extype @@ -1692,6 +1852,10 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze rowsTKI = rowsikpq enddo + !if(i.eq.1)then + ! print *,"n_st=",n_st,"rowsTKI=",rowsTKI, " nconnectedI=",nconnectedI, & + ! "totcolsTKI=",totcolsTKI + !endif allocate(TKI(n_st,rowsTKI,totcolsTKI)) ! coefficients of CSF ! Initialize the integral container ! dims : (totcolsTKI, nconnectedI) @@ -1721,10 +1885,10 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze TKI(kk,l,totcolsTKI+m) = AIJpqContainer(l,m,pmodel,qmodel,extype,NSOMOalpha) & * psi_in(kk,idxs_connectedI_alpha(j)+m-1) enddo - !if(i.eq.1) then - ! print *,AIJpqContainer(l,m,pmodel,qmodel,extype,NSOMOalpha) - !endif enddo + !if(i.eq.1) then + ! print *,"j=",j,"psi_in=",psi_in(1,idxs_connectedI_alpha(j)+m-1) + !endif enddo diagfactors_0 = diagfactors(j)*0.5d0 @@ -1763,16 +1927,24 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze rowsTKI = rowsikpq CCmattmp = 0.d0 + !if(i.eq.1)then + ! print *,"\t n_st=",n_st," colsikpq=",colsikpq," rowsTKI=",rowsTKI,& + ! " | ",size(TKIGIJ,1),size(AIJpqContainer,1),size(CCmattmp,1) + !endif call dgemm('N','N', n_st, colsikpq, rowsTKI, 1.d0, & TKIGIJ(1,1,j), size(TKIGIJ,1), & AIJpqContainer(1,1,pmodel,qmodel,extype,NSOMOalpha), & size(AIJpqContainer,1), 0.d0, & CCmattmp, size(CCmattmp,1) ) + !print *,"j=",j,"colsikpq=",colsikpq, "sizeTIG=",size(TKIGIJ,1),"sizeaijpq=",size(AIJpqContainer,1) do m = 1,colsikpq call omp_set_lock(lock(idxs_connectedI_alpha(j)+m-1)) do kk = 1,n_st psi_out(kk,idxs_connectedI_alpha(j)+m-1) += CCmattmp(kk,m) + !if(dabs(CCmattmp(kk,m)).gt.1e-10)then + ! print *, CCmattmp(kk,m), " | ",idxs_connectedI_alpha(j)+m-1 + !end if enddo call omp_unset_lock(lock(idxs_connectedI_alpha(j)+m-1)) enddo diff --git a/src/davidson/diagonalization_hcfg.irp.f b/src/davidson/diagonalization_hcfg.irp.f index 659602a1..b88c188d 100644 --- a/src/davidson/diagonalization_hcfg.irp.f +++ b/src/davidson/diagonalization_hcfg.irp.f @@ -112,6 +112,8 @@ subroutine davidson_diag_cfg_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,sze_csf,N double precision, allocatable :: U(:,:), U_csf(:,:), overlap(:,:) double precision, allocatable :: tmpU(:,:), tmpW(:,:) double precision, pointer :: W(:,:), W_csf(:,:) + double precision, pointer :: W2(:,:), W_csf2(:,:) + double precision, allocatable :: U2(:,:), U_csf2(:,:) logical :: disk_based double precision :: energy_shift(N_st_diag_in*davidson_sze_max) @@ -234,12 +236,15 @@ subroutine davidson_diag_cfg_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,sze_csf,N call c_f_pointer(ptr_w, W_csf, (/sze_csf,N_st_diag*itermax/)) else allocate(W(sze,N_st_diag),W_csf(sze_csf,N_st_diag*itermax)) + allocate(W2(sze,N_st_diag),W_csf2(sze_csf,N_st_diag*itermax)) endif allocate( & ! Large U(sze,N_st_diag), & + U2(sze,N_st_diag), & U_csf(sze_csf,N_st_diag*itermax), & + U_csf2(sze_csf,N_st_diag*itermax), & ! Small h(N_st_diag*itermax,N_st_diag*itermax), & @@ -324,8 +329,8 @@ subroutine davidson_diag_cfg_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,sze_csf,N tmpU(kk,ii) = U_csf(ii,shift+kk) enddo enddo - !tmpU =0.0d0 - !tmpU(1,2)=1.0d0 + tmpU =0.0d0 + tmpU(1,1)=1.0d0 double precision :: irp_rdtsc double precision :: ticks_0, ticks_1 integer*8 :: irp_imax @@ -340,19 +345,19 @@ subroutine davidson_diag_cfg_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,sze_csf,N enddo enddo - !U_csf = 0.0d0 - !U_csf(1,1) = 1.0d0 - !u_in = 0.0d0 - !call convertWFfromCSFtoDET(N_st_diag,tmpU,U2) - !call H_u_0_nstates_openmp(u_in,U2,N_st_diag,sze) - !call convertWFfromDETtoCSF(N_st_diag,u_in(1,1),W_csf2(1,1)) - !do i=1,sze_csf - ! print *,"I=",i," qp=",W_csf2(i,1)," my=",W_csf(i,1)," diff=",dabs(W_csf2(i,1))-dabs(W_csf(i,1)) - ! if(dabs(dabs(W_csf2(i,1))-dabs(W_csf(i,1))) .gt. 1.0e-10)then - ! print *,"somo=",psi_configuration(1,1,i)," domo=",psi_configuration(1,2,i)," diff=",dabs(W_csf2(i,1))-dabs(W_csf(i,1)) - ! endif - !end do - !stop + U_csf = 0.0d0 + U_csf(1,1) = 1.0d0 + u_in = 0.0d0 + call convertWFfromCSFtoDET(N_st_diag,tmpU,U2) + call H_u_0_nstates_openmp(u_in,U2,N_st_diag,sze) + call convertWFfromDETtoCSF(N_st_diag,u_in(1,1),W_csf2(1,1)) + do i=1,sze_csf + print *,"I=",i," qp=",W_csf2(i,1)," my=",W_csf(i,1)," diff=",dabs(W_csf2(i,1))-dabs(W_csf(i,1)) + !if(dabs(dabs(W_csf2(i,1))-dabs(W_csf(i,1))) .gt. 1.0e-10)then + ! print *,"somo=",psi_configuration(1,1,i)," domo=",psi_configuration(1,2,i)," diff=",dabs(W_csf2(i,1))-dabs(W_csf(i,1)) + !endif + end do + stop deallocate(tmpW) deallocate(tmpU) endif From bb0c3e391ca041884e528c5c5c3b39cbb75c3909 Mon Sep 17 00:00:00 2001 From: v1j4y Date: Thu, 15 Dec 2022 18:54:47 +0100 Subject: [PATCH 11/21] Fixed act_bitmask. --- src/csf/configuration_CI_sigma_helpers.irp.f | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/csf/configuration_CI_sigma_helpers.irp.f b/src/csf/configuration_CI_sigma_helpers.irp.f index 19533bd5..578a9153 100644 --- a/src/csf/configuration_CI_sigma_helpers.irp.f +++ b/src/csf/configuration_CI_sigma_helpers.irp.f @@ -875,7 +875,7 @@ use bitmasks ndiffDOMO = 0 nxordiffSOMODOMO = 0 do ii=1,N_int - diffDOMO = IEOR(Icfg(ii,2),iand(act_bitmask(ii,1),psi_configuration(ii,2,k))) + diffDOMO = IEOR(Icfg(ii,2),iand(act_bitmask(ii,2),psi_configuration(ii,2,k))) xordiffSOMODOMO = IEOR(diffSOMO,diffDOMO) ndiffDOMO += POPCNT(diffDOMO) nxordiffSOMODOMO += POPCNT(xordiffSOMODOMO) @@ -1221,7 +1221,7 @@ END_PROVIDER ndiffDOMO = 0 nxordiffSOMODOMO = 0 do ii=1,N_int - diffDOMO = IEOR(Icfg(ii,2),iand(act_bitmask(ii,1),psi_configuration(ii,2,k))) + diffDOMO = IEOR(Icfg(ii,2),iand(act_bitmask(ii,2),psi_configuration(ii,2,k))) xordiffSOMODOMO = IEOR(diffSOMO,diffDOMO) ndiffDOMO += POPCNT(diffDOMO) nxordiffSOMODOMO += POPCNT(xordiffSOMODOMO) From a6e844ad615579334567a28bd0e3ab02c0b81b15 Mon Sep 17 00:00:00 2001 From: v1j4y Date: Fri, 16 Dec 2022 13:29:59 +0100 Subject: [PATCH 12/21] Looks like CIS is working. --- src/csf/configuration_CI_sigma_helpers.irp.f | 25 +-- src/csf/conversion.irp.f | 2 +- src/csf/obtain_I_foralpha.irp.f | 68 ++++---- src/csf/sigma_vector.irp.f | 167 +++++++++++++------ src/davidson/diagonalization_hcfg.irp.f | 30 ++-- 5 files changed, 182 insertions(+), 110 deletions(-) diff --git a/src/csf/configuration_CI_sigma_helpers.irp.f b/src/csf/configuration_CI_sigma_helpers.irp.f index 578a9153..4473b1fa 100644 --- a/src/csf/configuration_CI_sigma_helpers.irp.f +++ b/src/csf/configuration_CI_sigma_helpers.irp.f @@ -586,7 +586,7 @@ use bitmasks do i=1, N_int Isomo(i) = iand(act_bitmask(i,1),psi_configuration(i,1,idxI)) - Idomo(i) = iand(act_bitmask(i,1),psi_configuration(i,2,idxI)) + Idomo(i) = iand(act_bitmask(i,2),psi_configuration(i,2,idxI)) enddo ! find out all pq holes possible @@ -667,7 +667,7 @@ use bitmasks qq = listvmos(j) if(pp.eq.qq) cycle jint = shiftr(qq-1,bit_kind_shift) + 1 - jpos = qq-shiftl((iint-1),bit_kind_shift)-1 + jpos = qq-shiftl((jint-1),bit_kind_shift)-1 if(vmotype(j) == 1)then Jsomo(jint) = IBSET(Jsomo(jint),jpos) else if(vmotype(j) == 2)then @@ -769,7 +769,7 @@ use bitmasks ! prune list of alphas do i=1, N_int Isomo(i) = iand(act_bitmask(i,1),psi_configuration(i,1,idxI)) - Idomo(i) = iand(act_bitmask(i,1),psi_configuration(i,2,idxI)) + Idomo(i) = iand(act_bitmask(i,2),psi_configuration(i,2,idxI)) Jsomo(i) = Isomo(i) Jdomo(i) = Idomo(i) enddo @@ -790,7 +790,7 @@ use bitmasks do j = 1, nvmos qq = listvmos(j) jint = shiftr(qq-1,bit_kind_shift) + 1 - jpos = qq-shiftl((iint-1),bit_kind_shift)-1 + jpos = qq-shiftl((jint-1),bit_kind_shift)-1 if(vmotype(j) == 1)then Jsomo(jint) = IBSET(Jsomo(jint),jpos) else if(vmotype(j) == 2)then @@ -857,7 +857,7 @@ use bitmasks ppExistsQ = .False. do i=1, N_int Isomo(i) = iand(act_bitmask(i,1),psi_configuration(i,1,idxI)) - Idomo(i) = iand(act_bitmask(i,1),psi_configuration(i,2,idxI)) + Idomo(i) = iand(act_bitmask(i,2),psi_configuration(i,2,idxI)) enddo kstart = max(1,cfg_seniority_index(max(NSOMOMin,Nsomo_I-2))) @@ -953,7 +953,7 @@ END_PROVIDER do i=1, N_int Isomo(i) = iand(act_bitmask(i,1),Icfg(i,1)) - Idomo(i) = iand(act_bitmask(i,1),Icfg(i,2)) + Idomo(i) = iand(act_bitmask(i,2),Icfg(i,2)) enddo !print*,"Input cfg" @@ -985,6 +985,7 @@ END_PROVIDER ! find vmos ! Take into account N_int + nvmos=0 do ii = 1, n_act_orb iii = list_act(ii) iint = shiftr(iii-1,bit_kind_shift) + 1 @@ -1014,7 +1015,7 @@ END_PROVIDER ! Now find the allowed (p,q) excitations do i=1, N_int Isomo(i) = iand(act_bitmask(i,1),Icfg(i,1)) - Idomo(i) = iand(act_bitmask(i,1),Icfg(i,2)) + Idomo(i) = iand(act_bitmask(i,2),Icfg(i,2)) Jsomo(i) = Isomo(i) Jdomo(i) = Idomo(i) enddo @@ -1051,7 +1052,7 @@ END_PROVIDER do j = 1,nvmos qq = listvmos(j) jint = shiftr(qq-1,bit_kind_shift) + 1 - jpos = qq-shiftl((iint-1),bit_kind_shift)-1 + jpos = qq-shiftl((jint-1),bit_kind_shift)-1 if(vmotype(j) == 1)then Jsomo(jint) = IBSET(Jsomo(jint),jpos) else if(vmotype(j) == 2)then @@ -1157,7 +1158,7 @@ END_PROVIDER ! prune list of alphas do i=1, N_int Isomo(i) = iand(act_bitmask(i,1),Icfg(i,1)) - Idomo(i) = iand(act_bitmask(i,1),Icfg(i,2)) + Idomo(i) = iand(act_bitmask(i,2),Icfg(i,2)) Jsomo(i) = Isomo(i) Jdomo(i) = Idomo(i) enddo @@ -1176,7 +1177,7 @@ END_PROVIDER do j = 1, nvmos qq = listvmos(j) jint = shiftr(qq-1,bit_kind_shift) + 1 - jpos = qq-shiftl((iint-1),bit_kind_shift)-1 + jpos = qq-shiftl((jint-1),bit_kind_shift)-1 if(vmotype(j) == 1)then Jsomo(jint) = IBSET(Jsomo(jint),jpos) else if(vmotype(j) == 2)then @@ -1207,8 +1208,8 @@ END_PROVIDER ! Check if this Icfg has been previously generated as a mono ppExistsQ = .False. - Isomo = iand(act_bitmask(1,1),Icfg(1,1)) - Idomo = iand(act_bitmask(1,1),Icfg(1,2)) + !Isomo = iand(act_bitmask(1,1),Icfg(1,1)) + !Idomo = iand(act_bitmask(1,2),Icfg(1,2)) do k = 1, idxI-1 do ii=1,N_int diffSOMO = IEOR(Icfg(ii,1),iand(act_bitmask(ii,1),psi_configuration(ii,1,k))) diff --git a/src/csf/conversion.irp.f b/src/csf/conversion.irp.f index 7c6c8363..92c8e669 100644 --- a/src/csf/conversion.irp.f +++ b/src/csf/conversion.irp.f @@ -114,7 +114,7 @@ subroutine convertWFfromCSFtoDET(N_st,psi_coef_cfg_in, psi_coef_det) integer :: idx integer MS MS = elec_alpha_num-elec_beta_num - print *,"size=",size(tmp_psi_coef_det,1)," ",size(tmp_psi_coef_det,2) + !print *,"size=",size(tmp_psi_coef_det,1)," ",size(tmp_psi_coef_det,2) countcsf = 0 diff --git a/src/csf/obtain_I_foralpha.irp.f b/src/csf/obtain_I_foralpha.irp.f index 1d4e81fc..8b588f4e 100644 --- a/src/csf/obtain_I_foralpha.irp.f +++ b/src/csf/obtain_I_foralpha.irp.f @@ -324,14 +324,14 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI ! SOMO -> VMO !print *,"obt SOMO -> VMO" extyp = 3 - if(N_int .eq. 1) then - IJsomo = IEOR(Isomo, Jsomo) - p = TRAILZ(IAND(Isomo,IJsomo)) + 1 - IJsomo = IBCLR(IJsomo,p-1) - q = TRAILZ(IJsomo) + 1 - !print *," p=",p," q=",q - !call get_single_excitation_cfg(Jcfg, Icfg, p, q, N_int) - else + !if(N_int .eq. 1) then + ! IJsomo = IEOR(Isomo, Jsomo) + ! p = TRAILZ(IAND(Isomo,IJsomo)) + 1 + ! IJsomo = IBCLR(IJsomo,p-1) + ! q = TRAILZ(IJsomo) + 1 + ! !print *," p=",p," q=",q + ! !call get_single_excitation_cfg(Jcfg, Icfg, p, q, N_int) + !else ! Find p do ii=1,N_int Isomo = Ialpha(ii,1) @@ -357,7 +357,7 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI EXIT endif enddo - endif + !endif !assert ( p == pp) !assert ( q == qq) !print *," 1--- p=",p," q=",q @@ -369,12 +369,12 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI ! DOMO -> VMO !print *,"obt DOMO -> VMO" extyp = 2 - if(N_int.eq.1)then - p = TRAILZ(IEOR(Idomo,Jdomo)) + 1 - Isomo = IEOR(Isomo, Jsomo) - Isomo = IBCLR(Isomo,p-1) - q = TRAILZ(Isomo) + 1 - else + !if(N_int.eq.1)then + ! p = TRAILZ(IEOR(Idomo,Jdomo)) + 1 + ! Isomo = IEOR(Isomo, Jsomo) + ! Isomo = IBCLR(Isomo,p-1) + ! q = TRAILZ(Isomo) + 1 + !else ! Find p do ii=1,N_int @@ -402,23 +402,23 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI EXIT endif end do - endif + !endif !assert ( p == pp) !assert ( q == qq) else ! SOMO -> SOMO !print *,"obt SOMO -> SOMO" extyp = 1 - if(N_int.eq.1)then - q = TRAILZ(IEOR(Idomo,Jdomo)) + 1 - Isomo = IEOR(Isomo, Jsomo) - Isomo = IBCLR(Isomo,q-1) - p = TRAILZ(Isomo) + 1 - ! Check for Minimal alpha electrons (MS) - !if(POPCNT(Isomo).lt.MS)then - ! cycle - !endif - else + !if(N_int.eq.1)then + ! q = TRAILZ(IEOR(Idomo,Jdomo)) + 1 + ! Isomo = IEOR(Isomo, Jsomo) + ! Isomo = IBCLR(Isomo,q-1) + ! p = TRAILZ(Isomo) + 1 + ! ! Check for Minimal alpha electrons (MS) + ! !if(POPCNT(Isomo).lt.MS)then + ! ! cycle + ! !endif + !else ! Find p !print *,"Ialpha somo=",Ialpha(1,1), Ialpha(2,1)," Ialpha domo=",Ialpha(1,2), Ialpha(2,2) !print *,"J somo=",psi_configuration(1,1,i), psi_configuration(2,1,i)," J domo=",psi_configuration(1,2,i),& @@ -449,7 +449,7 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI EXIT endif enddo - endif + !endif !assert ( p == pp) !assert ( q == qq) endif @@ -458,12 +458,12 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI ! DOMO -> SOMO !print *,"obt DOMO -> SOMO" extyp = 4 - if(N_int.eq.1)then - IJsomo = IEOR(Isomo, Jsomo) - p = TRAILZ(IAND(Jsomo,IJsomo)) + 1 - IJsomo = IBCLR(IJsomo,p-1) - q = TRAILZ(IJsomo) + 1 - else + !if(N_int.eq.1)then + ! IJsomo = IEOR(Isomo, Jsomo) + ! p = TRAILZ(IAND(Jsomo,IJsomo)) + 1 + ! IJsomo = IBCLR(IJsomo,p-1) + ! q = TRAILZ(IJsomo) + 1 + !else ! Find p do ii=1,N_int Isomo = Ialpha(ii,1) @@ -491,7 +491,7 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI EXIT endif enddo - endif + !endif !assert ( p == pp) !assert ( q == qq) !print *," 3--- p=",p," q=",q diff --git a/src/csf/sigma_vector.irp.f b/src/csf/sigma_vector.irp.f index 9fe81fe9..193fcf0e 100644 --- a/src/csf/sigma_vector.irp.f +++ b/src/csf/sigma_vector.irp.f @@ -1538,8 +1538,13 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze integer :: rowsTKI integer :: noccpp integer :: istart_cfg, iend_cfg, num_threads_max + integer :: iint, jint, ipos, jpos, Nsomo_I, iii integer :: nconnectedJ,nconnectedtotalmax,nconnectedmaxJ,maxnalphas,ntotJ - integer*8 :: MS, Isomo, Idomo, Jsomo, Jdomo, Ialpha, Ibeta + integer*8 :: MS,Ialpha, Ibeta + integer(bit_kind) :: Isomo(N_INT) + integer(bit_kind) :: Idomo(N_INT) + integer(bit_kind) :: Jsomo(N_INT) + integer(bit_kind) :: Jdomo(N_INT) integer :: moi, moj, mok, mol, starti, endi, startj, endj, cnti, cntj, cntk real*8 :: norm_coef_cfg, fac2eints real*8 :: norm_coef_det @@ -1554,6 +1559,7 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze real*8,dimension(:),allocatable:: diag_energies real*8 :: tmpvar, tmptot real*8 :: core_act_contrib + integer :: listall(N_int*bit_kind_size), nelall integer(omp_lock_kind), allocatable :: lock(:) call omp_set_max_active_levels(1) @@ -1569,7 +1575,7 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze allocate(diag_energies(n_CSF)) call calculate_preconditioner_cfg(diag_energies) - print *," diag energy =",diag_energies(1) + !print *," diag energy =",diag_energies(1) MS = 0 norm_coef_cfg=0.d0 @@ -1615,6 +1621,7 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze !$OMP shared(istart_cfg, iend_cfg, psi_configuration, mo_num, psi_config_data,& !$OMP N_int, N_st, psi_out, psi_in, h_core_ri, core_energy, h_act_ri, AIJpqContainer,& !$OMP pp, sze, NalphaIcfg_list,alphasIcfg_list, bit_tmp, & + !$OMP qq, iint, jint, ipos, jpos, nelall, listall, Nsomo_I, & !$OMP AIJpqMatrixDimsList, diag_energies, n_CSF, lock, NBFmax,nconnectedtotalmax, nconnectedmaxJ,maxnalphas,& !$OMP n_core_orb, n_act_orb, list_act, n, list_core, list_core_is_built,core_act_contrib, num_threads_max,& !$OMP n_core_orb_is_built, mo_integrals_map, mo_integrals_map_is_built) @@ -1637,10 +1644,12 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze ! else ! cycle - Icfg(1,1) = psi_configuration(1,1,i) - Icfg(1,2) = psi_configuration(1,2,i) - Isomo = Icfg(1,1) - Idomo = Icfg(1,2) + do ii=1,N_INT + Icfg(ii,1) = psi_configuration(ii,1,i) + Icfg(ii,2) = psi_configuration(ii,2,i) + Isomo(ii) = Icfg(ii,1) + Idomo(ii) = Icfg(ii,2) + enddo NSOMOI = getNSOMO(Icfg) ! find out all pq holes possible @@ -1651,42 +1660,86 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze ! list_core_inact ! bitmasks !do k = 1,mo_num - do kk = 1,n_act_orb - k = list_act(kk) - if(POPCNT(IAND(Isomo,IBSET(0_8,k-1))) .EQ. 1) then - nholes += 1 - listholes(nholes) = k - holetype(nholes) = 1 - endif - enddo - ! holes in DOMO - !do k = 1,mo_num - do kk = 1,n_act_orb - k = list_act(kk) - if(POPCNT(IAND(Idomo,IBSET(0_8,k-1))) .EQ. 1) then - nholes += 1 - listholes(nholes) = k - holetype(nholes) = 2 - endif - enddo + ! do kk = 1,n_act_orb + ! k = list_act(kk) + ! if(POPCNT(IAND(Isomo,IBSET(0_8,k-1))) .EQ. 1) then + ! nholes += 1 + ! listholes(nholes) = k + ! holetype(nholes) = 1 + ! endif + ! enddo + ! ! holes in DOMO + ! !do k = 1,mo_num + ! do kk = 1,n_act_orb + ! k = list_act(kk) + ! if(POPCNT(IAND(Idomo,IBSET(0_8,k-1))) .EQ. 1) then + ! nholes += 1 + ! listholes(nholes) = k + ! holetype(nholes) = 2 + ! endif + ! enddo - ! find vmos + ! ! find vmos listvmos = -1 vmotype = -1 nvmos = 0 - do kk = 1,n_act_orb - k = list_act(kk) - !print *,i,IBSET(0,i-1),POPCNT(IAND(Isomo,(IBSET(0_8,i-1)))), POPCNT(IAND(Idomo,(IBSET(0_8,i-1)))) - if(POPCNT(IAND(Isomo,(IBSET(0_8,k-1)))) .EQ. 0 .AND. POPCNT(IAND(Idomo,(IBSET(0_8,k-1)))) .EQ. 0) then - nvmos += 1 - listvmos(nvmos) = k - vmotype(nvmos) = 0 - else if(POPCNT(IAND(Isomo,(IBSET(0_8,k-1)))) .EQ. 1 .AND. POPCNT(IAND(Idomo,(IBSET(0_8,k-1)))) .EQ. 0 ) then - nvmos += 1 - listvmos(nvmos) = k - vmotype(nvmos) = 1 - end if - enddo + ! do kk = 1,n_act_orb + ! k = list_act(kk) + ! !print *,i,IBSET(0,i-1),POPCNT(IAND(Isomo,(IBSET(0_8,i-1)))), POPCNT(IAND(Idomo,(IBSET(0_8,i-1)))) + ! if(POPCNT(IAND(Isomo,(IBSET(0_8,k-1)))) .EQ. 0 .AND. POPCNT(IAND(Idomo,(IBSET(0_8,k-1)))) .EQ. 0) then + ! nvmos += 1 + ! listvmos(nvmos) = k + ! vmotype(nvmos) = 0 + ! else if(POPCNT(IAND(Isomo,(IBSET(0_8,k-1)))) .EQ. 1 .AND. POPCNT(IAND(Idomo,(IBSET(0_8,k-1)))) .EQ. 0 ) then + ! nvmos += 1 + ! listvmos(nvmos) = k + ! vmotype(nvmos) = 1 + ! end if + ! enddo + + ! find out all pq holes possible + nholes = 0 + call bitstring_to_list(Isomo,listall,nelall,N_int) + + do iii=1,nelall + nholes += 1 + listholes(nholes) = listall(iii) + holetype(nholes) = 1 + end do + + Nsomo_I = nelall + + call bitstring_to_list(Idomo,listall,nelall,N_int) + + do iii=1,nelall + if(listall(iii) .gt. n_core_orb)then + nholes += 1 + listholes(nholes) = listall(iii) + holetype(nholes) = 2 + endif + end do + + + ! find vmos + ! Take into account N_int + do ii = 1, n_act_orb + iii = list_act(ii) + iint = shiftr(iii-1,bit_kind_shift) + 1 + ipos = iii-shiftl((iint-1),bit_kind_shift)-1 + + if(IAND(Idomo(iint),(IBSET(0_8,ipos))) .EQ. 0) then + if(IAND(Isomo(iint),(IBSET(0_8,ipos))) .EQ. 0) then + nvmos += 1 + listvmos(nvmos) = iii + vmotype(nvmos) = 1 + else if(POPCNT(IAND(Isomo(iint),(IBSET(0_8,ipos)))) .EQ. 1) then + nvmos += 1 + listvmos(nvmos) = iii + vmotype(nvmos) = 2 + end if + end if + end do + ! Icsf ids @@ -1705,16 +1758,31 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze extype = excitationTypes_single(j) ! Off diagonal terms call convertOrbIdsToModelSpaceIds(Icfg, singlesI(1,1,j), p, q, extype, pmodel, qmodel) - Jsomo = singlesI(1,1,j) - Jdomo = singlesI(1,2,j) + do ii=1,N_INT + Jsomo(ii) = singlesI(1,1,j) + Jdomo(ii) = singlesI(1,2,j) + enddo + + ! Get actual p pos + pp = p + iint = shiftr(pp-1,bit_kind_shift) + 1 + ipos = pp-shiftl((iint-1),bit_kind_shift)-1 + + ! Get actual q pos + qq = q + jint = shiftr(qq-1,bit_kind_shift) + 1 + jpos = qq-shiftl((jint-1),bit_kind_shift)-1 ! Add the hole on J - if(POPCNT(IAND(Jsomo,IBSET(0_8,q-1))) .EQ. 1 .AND. POPCNT(IAND(Isomo,IBSET(0_8,q-1))) .EQ. 0) then + !if(POPCNT(IAND(Jsomo,IBSET(0_8,q-1))) .EQ. 1 .AND. POPCNT(IAND(Isomo,IBSET(0_8,q-1))) .EQ. 0) then + if(POPCNT(IAND(Jsomo(jint),IBSET(0_8,jpos))) .EQ. 1 .AND. POPCNT(IAND(Isomo(jint),IBSET(0_8,jpos))) .EQ. 0) then nholes += 1 listholes(nholes) = q holetype(nholes) = 1 endif - if((POPCNT(IAND(Jdomo,IBSET(0_8,q-1))) .EQ. 1 .AND. POPCNT(IAND(Idomo,IBSET(0_8,q-1))) .EQ. 0) .AND. POPCNT(IAND(Isomo,IBSET(0_8,q-1))) .EQ. 0) then + !if((POPCNT(IAND(Jdomo,IBSET(0_8,q-1))) .EQ. 1 .AND. POPCNT(IAND(Idomo,IBSET(0_8,q-1))) .EQ. 0) .AND. POPCNT(IAND(Isomo,IBSET(0_8,q-1))) .EQ. 0) then + if((POPCNT(IAND(Jdomo(jint),IBSET(0_8,jpos))) .EQ. 1 .AND. POPCNT(IAND(Idomo(jint),IBSET(0_8,jpos))) .EQ. 0) .AND.& + POPCNT(IAND(Isomo(jint),IBSET(0_8,jpos))) .EQ. 0) then nholes += 1 listholes(nholes) = q holetype(nholes) = 2 @@ -1744,17 +1812,18 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze call omp_set_lock(lock(jj)) do kk = 1,n_st psi_out(kk,jj) = psi_out(kk,jj) + meCC1 * psi_in(kk,ii) - print *,"jj=",jj,'psi_out(kk)=',psi_out(kk,jj) enddo call omp_unset_lock(lock(jj)) enddo enddo ! Undo setting in listholes - if(POPCNT(IAND(Jsomo,IBSET(0_8,q-1))) .EQ. 1 .AND. POPCNT(IAND(Isomo,IBSET(0_8,q-1))) .EQ. 0) then + !if(POPCNT(IAND(Jsomo,IBSET(0_8,q-1))) .EQ. 1 .AND. POPCNT(IAND(Isomo,IBSET(0_8,q-1))) .EQ. 0) then + if(POPCNT(IAND(Jsomo(jint),IBSET(0_8,jpos))) .EQ. 1 .AND. POPCNT(IAND(Isomo(jint),IBSET(0_8,jpos))) .EQ. 0) then nholes -= 1 endif - if((POPCNT(IAND(Jdomo,IBSET(0_8,q-1))) .EQ. 1 .AND. POPCNT(IAND(Idomo,IBSET(0_8,q-1))) .EQ. 0) .AND. POPCNT(IAND(Isomo,IBSET(0_8,q-1))) .EQ. 0) then + if((POPCNT(IAND(Jdomo(jint),IBSET(0_8,jpos))) .EQ. 1 .AND. POPCNT(IAND(Idomo(jint),IBSET(0_8,jpos))) .EQ. 0) .AND.& + POPCNT(IAND(Isomo(jint),IBSET(0_8,jpos))) .EQ. 0) then nholes -= 1 endif enddo @@ -1790,8 +1859,10 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze ! else ! cycle - Icfg(1,1) = psi_configuration(1,1,i) - Icfg(1,2) = psi_configuration(1,2,i) + do ii=1,N_INT + Icfg(ii,1) = psi_configuration(ii,1,i) + Icfg(ii,2) = psi_configuration(ii,2,i) + enddo starti = psi_config_data(i,1) endi = psi_config_data(i,2) @@ -1806,7 +1877,7 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze ! print *,"Nalpha > maxnalpha" !endif - call obtain_connected_J_givenI(i, Icfg, listconnectedJ, idslistconnectedJ, nconnectedJ, ntotJ) + !call obtain_connected_J_givenI(i, Icfg, listconnectedJ, idslistconnectedJ, nconnectedJ, ntotJ) ! TODO : remove doubly excited for return !print *,"I=",i," isomo=",psi_configuration(1,1,i)," idomo=",psi_configuration(1,2,i), " psiout=",psi_out(1,5), "Nalphas_Icfg=",Nalphas_Icfg diff --git a/src/davidson/diagonalization_hcfg.irp.f b/src/davidson/diagonalization_hcfg.irp.f index b88c188d..00bbf543 100644 --- a/src/davidson/diagonalization_hcfg.irp.f +++ b/src/davidson/diagonalization_hcfg.irp.f @@ -329,8 +329,8 @@ subroutine davidson_diag_cfg_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,sze_csf,N tmpU(kk,ii) = U_csf(ii,shift+kk) enddo enddo - tmpU =0.0d0 - tmpU(1,1)=1.0d0 + !tmpU =0.0d0 + !tmpU(1,1)=1.0d0 double precision :: irp_rdtsc double precision :: ticks_0, ticks_1 integer*8 :: irp_imax @@ -345,19 +345,19 @@ subroutine davidson_diag_cfg_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,sze_csf,N enddo enddo - U_csf = 0.0d0 - U_csf(1,1) = 1.0d0 - u_in = 0.0d0 - call convertWFfromCSFtoDET(N_st_diag,tmpU,U2) - call H_u_0_nstates_openmp(u_in,U2,N_st_diag,sze) - call convertWFfromDETtoCSF(N_st_diag,u_in(1,1),W_csf2(1,1)) - do i=1,sze_csf - print *,"I=",i," qp=",W_csf2(i,1)," my=",W_csf(i,1)," diff=",dabs(W_csf2(i,1))-dabs(W_csf(i,1)) - !if(dabs(dabs(W_csf2(i,1))-dabs(W_csf(i,1))) .gt. 1.0e-10)then - ! print *,"somo=",psi_configuration(1,1,i)," domo=",psi_configuration(1,2,i)," diff=",dabs(W_csf2(i,1))-dabs(W_csf(i,1)) - !endif - end do - stop + !U_csf = 0.0d0 + !U_csf(1,1) = 1.0d0 + !u_in = 0.0d0 + !call convertWFfromCSFtoDET(N_st_diag,tmpU,U2) + !call H_u_0_nstates_openmp(u_in,U2,N_st_diag,sze) + !call convertWFfromDETtoCSF(N_st_diag,u_in(1,1),W_csf2(1,1)) + !do i=1,sze_csf + ! print *,"I=",i," qp=",W_csf2(i,1)," my=",W_csf(i,1)," diff=",dabs(W_csf2(i,1))-dabs(W_csf(i,1)) + ! !if(dabs(dabs(W_csf2(i,1))-dabs(W_csf(i,1))) .gt. 1.0e-10)then + ! ! print *,"somo=",psi_configuration(1,1,i)," domo=",psi_configuration(1,2,i)," diff=",dabs(W_csf2(i,1))-dabs(W_csf(i,1)) + ! !endif + !end do + !stop deallocate(tmpW) deallocate(tmpU) endif From bc69ac42b13816b3988142d78a216f97d4014e40 Mon Sep 17 00:00:00 2001 From: v1j4y Date: Fri, 16 Dec 2022 15:01:13 +0100 Subject: [PATCH 13/21] restore dimension of alphsIcfg. --- src/csf/configuration_CI_sigma_helpers.irp.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/csf/configuration_CI_sigma_helpers.irp.f b/src/csf/configuration_CI_sigma_helpers.irp.f index 4473b1fa..3440c48e 100644 --- a/src/csf/configuration_CI_sigma_helpers.irp.f +++ b/src/csf/configuration_CI_sigma_helpers.irp.f @@ -524,7 +524,7 @@ use bitmasks !!! !!!END_PROVIDER - BEGIN_PROVIDER [ integer(bit_kind), alphasIcfg_list , (N_int,2,N_configuration,mo_num*12)] + BEGIN_PROVIDER [ integer(bit_kind), alphasIcfg_list , (N_int,2,N_configuration,mo_num*mo_num)] &BEGIN_PROVIDER [ integer, NalphaIcfg_list, (N_configuration) ] implicit none !use bitmasks From 2e0c96fd6b320f75eb2cf03376eb5d4f233c9b23 Mon Sep 17 00:00:00 2001 From: v1j4y Date: Fri, 16 Dec 2022 16:02:00 +0100 Subject: [PATCH 14/21] Fixed bug in calculation of Nsomo_J. --- src/csf/configuration_CI_sigma_helpers.irp.f | 37 +++++++++++--------- src/csf/sigma_vector.irp.f | 12 ++++--- src/davidson/diagonalization_hcfg.irp.f | 30 ++++++++-------- 3 files changed, 42 insertions(+), 37 deletions(-) diff --git a/src/csf/configuration_CI_sigma_helpers.irp.f b/src/csf/configuration_CI_sigma_helpers.irp.f index 3440c48e..744ba205 100644 --- a/src/csf/configuration_CI_sigma_helpers.irp.f +++ b/src/csf/configuration_CI_sigma_helpers.irp.f @@ -591,6 +591,7 @@ use bitmasks ! find out all pq holes possible nholes = 0 + listholes=-1 call bitstring_to_list(Isomo,listall,nelall,N_int) do iii=1,nelall @@ -638,12 +639,19 @@ use bitmasks tableUniqueAlphas = .FALSE. ! Now find the allowed (p,q) excitations - do i=1, N_int - Isomo(i) = iand(reunion_of_act_virt_bitmask(i,1),psi_configuration(i,1,idxI)) - Idomo(i) = iand(reunion_of_act_virt_bitmask(i,2),psi_configuration(i,2,idxI)) - Jsomo(i) = Isomo(i) - Jdomo(i) = Idomo(i) + do ii=1, N_int + !Isomo(ii) = iand(reunion_of_act_virt_bitmask(i,1),psi_configuration(ii,1,idxI)) + !Idomo(ii) = iand(reunion_of_act_virt_bitmask(i,2),psi_configuration(ii,2,idxI)) + Isomo(ii) = psi_configuration(ii,1,idxI) + Idomo(ii) = psi_configuration(ii,2,idxI) + Jsomo(ii) = Isomo(ii) + Jdomo(ii) = Idomo(ii) enddo + !print *,"I=",idxI + !print *,"Isomo=",Isomo(1)!, Isomo(2) + !print *,"Idomo=",Idomo(1)!, Idomo(2) + !print *,listholes + !print *,listvmos if(Nsomo_I .EQ. 0) then kstart = 1 @@ -789,6 +797,7 @@ use bitmasks do j = 1, nvmos qq = listvmos(j) + if(pp.eq.qq) cycle jint = shiftr(qq-1,bit_kind_shift) + 1 jpos = qq-shiftl((jint-1),bit_kind_shift)-1 if(vmotype(j) == 1)then @@ -797,31 +806,25 @@ use bitmasks Jdomo(jint) = IBSET(Jdomo(jint),jpos) Jsomo(jint) = IBCLR(Jsomo(jint),jpos) endif - if(pp .EQ. qq) then - if(vmotype(j) == 1)then - Jsomo(jint) = IBCLR(Jsomo(jint),jpos) - else if(vmotype(j) == 2)then - Jdomo(jint) = IBCLR(Jdomo(jint),jpos) - Jsomo(jint) = IBSET(Jsomo(jint),jpos) - endif - cycle - endif + if(tableUniqueAlphas(pp,qq)) then + Nsomo_J = 0 do ii=1, N_int Jcfg(ii,1) = Jsomo(ii) Jcfg(ii,2) = Jdomo(ii) + Nsomo_J += POPCNT(Jsomo(ii)) enddo - call bitstring_to_list(Jcfg,listall,nelall,N_int) - Nsomo_J = nelall + !call bitstring_to_list(Jcfg,listall,nelall,N_int) + !Nsomo_J = nelall if(Nsomo_J .ge. NSOMOMin) then !print *," Idx = ",idxI, "p = ",pp, " q = ",qq," Jsomo=",Jsomo(1), " Jdomo=",IOR(Jdomo(1),ISHFT(1_8,n_core_orb)-1) NalphaIcfg += 1 !print *," Idx = ",idxI, " Nalpha=",NalphaIcfg alphasIcfg_list(:,1,idxI,NalphaIcfg) = Jcfg(:,1) - if(n_core_orb .le. 63)then + if(n_core_orb .le. 64)then alphasIcfg_list(1,2,idxI,NalphaIcfg) = IOR(Jcfg(1,2),ISHFT(1_8,n_core_orb)-1) else n_core_orb_64 = n_core_orb diff --git a/src/csf/sigma_vector.irp.f b/src/csf/sigma_vector.irp.f index 193fcf0e..2ff3912b 100644 --- a/src/csf/sigma_vector.irp.f +++ b/src/csf/sigma_vector.irp.f @@ -1892,8 +1892,10 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze nconnectedI, excitationIds, excitationTypes, diagfactors) !if(i .EQ. 1) then - ! print *,'k=',k,' kcfgSOMO=',alphas_Icfg(1,1,k),alphas_Icfg(2,1,k),' ',POPCNT(alphas_Icfg(1,1,k)),' & - ! kcfgDOMO=',alphas_Icfg(1,2,k),alphas_Icfg(2,2,k),' ',POPCNT(alphas_Icfg(1,2,k)), " NconnectedI=",nconnectedI + ! !print *,'k=',k,' kcfgSOMO=',alphas_Icfg(1,1,k),alphas_Icfg(2,1,k),' ',POPCNT(alphas_Icfg(1,1,k)),' & + ! !kcfgDOMO=',alphas_Icfg(1,2,k),alphas_Icfg(2,2,k),' ',POPCNT(alphas_Icfg(1,2,k)), " NconnectedI=",nconnectedI + ! print *,'k=',k,' kcfgSOMO=',alphas_Icfg(1,1,k),' ',POPCNT(alphas_Icfg(1,1,k)),' & + ! kcfgDOMO=',alphas_Icfg(1,2,k),' ',POPCNT(alphas_Icfg(1,2,k)), " NconnectedI=",nconnectedI !endif @@ -1913,9 +1915,9 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze extype = excitationTypes(j) call convertOrbIdsToModelSpaceIds(alphas_Icfg(1,1,k), connectedI_alpha(1,1,j), p, q, extype, pmodel, qmodel) ! for E_pp E_rs and E_ppE_rr case - !if(k.eq.722)then - ! print *,"j=",j," k=",k,"p=",p,"q=",q,"NSOMOalpha=",NSOMOalpha, "pmodel=",pmodel,"qmodel=",qmodel, "extype=",extype - !endif + if(i.eq.1)then + print *,"j=",j," k=",k,"p=",p,"q=",q,"NSOMOalpha=",NSOMOalpha, "pmodel=",pmodel,"qmodel=",qmodel, "extype=",extype + endif rowsikpq = AIJpqMatrixDimsList(NSOMOalpha,extype,pmodel,qmodel,1) colsikpq = AIJpqMatrixDimsList(NSOMOalpha,extype,pmodel,qmodel,2) !print *,"j=",j," Nsomo=",NSOMOalpha," rowsikpq=",rowsikpq," colsikpq=",colsikpq, " p=",pmodel," q=",qmodel, " extyp=",extype diff --git a/src/davidson/diagonalization_hcfg.irp.f b/src/davidson/diagonalization_hcfg.irp.f index 00bbf543..b88c188d 100644 --- a/src/davidson/diagonalization_hcfg.irp.f +++ b/src/davidson/diagonalization_hcfg.irp.f @@ -329,8 +329,8 @@ subroutine davidson_diag_cfg_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,sze_csf,N tmpU(kk,ii) = U_csf(ii,shift+kk) enddo enddo - !tmpU =0.0d0 - !tmpU(1,1)=1.0d0 + tmpU =0.0d0 + tmpU(1,1)=1.0d0 double precision :: irp_rdtsc double precision :: ticks_0, ticks_1 integer*8 :: irp_imax @@ -345,19 +345,19 @@ subroutine davidson_diag_cfg_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,sze_csf,N enddo enddo - !U_csf = 0.0d0 - !U_csf(1,1) = 1.0d0 - !u_in = 0.0d0 - !call convertWFfromCSFtoDET(N_st_diag,tmpU,U2) - !call H_u_0_nstates_openmp(u_in,U2,N_st_diag,sze) - !call convertWFfromDETtoCSF(N_st_diag,u_in(1,1),W_csf2(1,1)) - !do i=1,sze_csf - ! print *,"I=",i," qp=",W_csf2(i,1)," my=",W_csf(i,1)," diff=",dabs(W_csf2(i,1))-dabs(W_csf(i,1)) - ! !if(dabs(dabs(W_csf2(i,1))-dabs(W_csf(i,1))) .gt. 1.0e-10)then - ! ! print *,"somo=",psi_configuration(1,1,i)," domo=",psi_configuration(1,2,i)," diff=",dabs(W_csf2(i,1))-dabs(W_csf(i,1)) - ! !endif - !end do - !stop + U_csf = 0.0d0 + U_csf(1,1) = 1.0d0 + u_in = 0.0d0 + call convertWFfromCSFtoDET(N_st_diag,tmpU,U2) + call H_u_0_nstates_openmp(u_in,U2,N_st_diag,sze) + call convertWFfromDETtoCSF(N_st_diag,u_in(1,1),W_csf2(1,1)) + do i=1,sze_csf + print *,"I=",i," qp=",W_csf2(i,1)," my=",W_csf(i,1)," diff=",dabs(W_csf2(i,1))-dabs(W_csf(i,1)) + !if(dabs(dabs(W_csf2(i,1))-dabs(W_csf(i,1))) .gt. 1.0e-10)then + ! print *,"somo=",psi_configuration(1,1,i)," domo=",psi_configuration(1,2,i)," diff=",dabs(W_csf2(i,1))-dabs(W_csf(i,1)) + !endif + end do + stop deallocate(tmpW) deallocate(tmpU) endif From c3c61d4ba11dab538f0bf7cb106a4ade389d66b1 Mon Sep 17 00:00:00 2001 From: v1j4y Date: Mon, 19 Dec 2022 13:51:55 +0100 Subject: [PATCH 15/21] Removed debug print. --- src/csf/configurations.irp.f | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/csf/configurations.irp.f b/src/csf/configurations.irp.f index a84cb4ab..aebf53d9 100644 --- a/src/csf/configurations.irp.f +++ b/src/csf/configurations.irp.f @@ -352,11 +352,6 @@ end psi_configuration(k,1,i) = ieor(psi_det(k,1,i),psi_det(k,2,i)) psi_configuration(k,2,i) = iand(psi_det(k,1,i),psi_det(k,2,i)) enddo - if(i.eq.1)then - print *,'Preparing PSI_CONFIGURATION i=',i - print *," Icfg somo=",psi_configuration(1,1,1), " ", psi_configuration(2,1,1) - print *," Icfg domo=",psi_configuration(1,2,1), " ", psi_configuration(2,2,1) - endif enddo ! Sort From 6f86f05e7fa027cf2ade3d160d679a9755e45225 Mon Sep 17 00:00:00 2001 From: v1j4y Date: Mon, 19 Dec 2022 13:53:55 +0100 Subject: [PATCH 16/21] Removed test code. --- src/davidson/diagonalization_hcfg.irp.f | 40 ++++++++++++------------- 1 file changed, 20 insertions(+), 20 deletions(-) diff --git a/src/davidson/diagonalization_hcfg.irp.f b/src/davidson/diagonalization_hcfg.irp.f index b88c188d..8e12b9c8 100644 --- a/src/davidson/diagonalization_hcfg.irp.f +++ b/src/davidson/diagonalization_hcfg.irp.f @@ -112,8 +112,8 @@ subroutine davidson_diag_cfg_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,sze_csf,N double precision, allocatable :: U(:,:), U_csf(:,:), overlap(:,:) double precision, allocatable :: tmpU(:,:), tmpW(:,:) double precision, pointer :: W(:,:), W_csf(:,:) - double precision, pointer :: W2(:,:), W_csf2(:,:) - double precision, allocatable :: U2(:,:), U_csf2(:,:) + !double precision, pointer :: W2(:,:), W_csf2(:,:) + !double precision, allocatable :: U2(:,:), U_csf2(:,:) logical :: disk_based double precision :: energy_shift(N_st_diag_in*davidson_sze_max) @@ -236,15 +236,15 @@ subroutine davidson_diag_cfg_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,sze_csf,N call c_f_pointer(ptr_w, W_csf, (/sze_csf,N_st_diag*itermax/)) else allocate(W(sze,N_st_diag),W_csf(sze_csf,N_st_diag*itermax)) - allocate(W2(sze,N_st_diag),W_csf2(sze_csf,N_st_diag*itermax)) + !allocate(W2(sze,N_st_diag),W_csf2(sze_csf,N_st_diag*itermax)) endif allocate( & ! Large U(sze,N_st_diag), & - U2(sze,N_st_diag), & + !U2(sze,N_st_diag), & U_csf(sze_csf,N_st_diag*itermax), & - U_csf2(sze_csf,N_st_diag*itermax), & + !U_csf2(sze_csf,N_st_diag*itermax), & ! Small h(N_st_diag*itermax,N_st_diag*itermax), & @@ -329,8 +329,8 @@ subroutine davidson_diag_cfg_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,sze_csf,N tmpU(kk,ii) = U_csf(ii,shift+kk) enddo enddo - tmpU =0.0d0 - tmpU(1,1)=1.0d0 + !tmpU =0.0d0 + !tmpU(1,1)=1.0d0 double precision :: irp_rdtsc double precision :: ticks_0, ticks_1 integer*8 :: irp_imax @@ -345,19 +345,19 @@ subroutine davidson_diag_cfg_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,sze_csf,N enddo enddo - U_csf = 0.0d0 - U_csf(1,1) = 1.0d0 - u_in = 0.0d0 - call convertWFfromCSFtoDET(N_st_diag,tmpU,U2) - call H_u_0_nstates_openmp(u_in,U2,N_st_diag,sze) - call convertWFfromDETtoCSF(N_st_diag,u_in(1,1),W_csf2(1,1)) - do i=1,sze_csf - print *,"I=",i," qp=",W_csf2(i,1)," my=",W_csf(i,1)," diff=",dabs(W_csf2(i,1))-dabs(W_csf(i,1)) - !if(dabs(dabs(W_csf2(i,1))-dabs(W_csf(i,1))) .gt. 1.0e-10)then - ! print *,"somo=",psi_configuration(1,1,i)," domo=",psi_configuration(1,2,i)," diff=",dabs(W_csf2(i,1))-dabs(W_csf(i,1)) - !endif - end do - stop + !U_csf = 0.0d0 + !U_csf(1,1) = 1.0d0 + !u_in = 0.0d0 + !call convertWFfromCSFtoDET(N_st_diag,tmpU,U2) + !call H_u_0_nstates_openmp(u_in,U2,N_st_diag,sze) + !call convertWFfromDETtoCSF(N_st_diag,u_in(1,1),W_csf2(1,1)) + !do i=1,sze_csf + ! print *,"I=",i," qp=",W_csf2(i,1)," my=",W_csf(i,1)," diff=",dabs(W_csf2(i,1))-dabs(W_csf(i,1)) + ! !if(dabs(dabs(W_csf2(i,1))-dabs(W_csf(i,1))) .gt. 1.0e-10)then + ! ! print *,"somo=",psi_configuration(1,1,i)," domo=",psi_configuration(1,2,i)," diff=",dabs(W_csf2(i,1))-dabs(W_csf(i,1)) + ! !endif + !end do + !stop deallocate(tmpW) deallocate(tmpU) endif From 0f600519cbc02fa9ad22f7aa9df03295487c22d3 Mon Sep 17 00:00:00 2001 From: v1j4y Date: Mon, 19 Dec 2022 13:54:34 +0100 Subject: [PATCH 17/21] Fixed bugs in obtain I. --- src/csf/obtain_I_foralpha.irp.f | 46 ++++++++++++++------------------- 1 file changed, 19 insertions(+), 27 deletions(-) diff --git a/src/csf/obtain_I_foralpha.irp.f b/src/csf/obtain_I_foralpha.irp.f index 8b588f4e..211d5af6 100644 --- a/src/csf/obtain_I_foralpha.irp.f +++ b/src/csf/obtain_I_foralpha.irp.f @@ -264,15 +264,15 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI Icfg = Ialpha Nsomo_alpha = 0 !print *," Ialpha=" - do i=1,N_int - Isomo = Ialpha(i,1) - Idomo = Ialpha(i,2) + do ii=1,N_int + Isomo = Ialpha(ii,1) + Idomo = Ialpha(ii,2) Nsomo_alpha += POPCNT(Isomo) !print *,Isomo, Idomo, "Nsomo=",Nsomo_alpha end do end_index = min(N_configuration,cfg_seniority_index(min(Nsomo_alpha+4,elec_num))-1) - if(end_index .LT. 0) end_index= N_configuration - !end_index = N_configuration + if(end_index .LT. 0 .OR. end_index .lt. idxI) end_index= N_configuration + end_index = N_configuration p = 0 @@ -283,17 +283,6 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI if(Nsomo_alpha .lt. MS)then cycle endif - !Isomo = Ialpha(1,1) - !Idomo = Ialpha(1,2) - !Jsomo = psi_configuration(1,1,i) - !Jdomo = psi_configuration(1,2,i) - !diffSOMO = IEOR(Isomo,Jsomo) - !ndiffSOMO = POPCNT(diffSOMO) - !diffDOMO = IEOR(Idomo,Jdomo) - !xordiffSOMODOMO = IEOR(diffSOMO,diffDOMO) - !ndiffDOMO = POPCNT(diffDOMO) - !nxordiffSOMODOMO = POPCNT(xordiffSOMODOMO) - !nxordiffSOMODOMO += ndiffSOMO + ndiffDOMO ndiffSOMO = 0 ndiffDOMO = 0 @@ -315,6 +304,9 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI nxordiffSOMODOMO += POPCNT(xordiffSOMODOMO) nxordiffSOMODOMO += POPCNT(diffSOMO) + POPCNT(diffDOMO) end do + !if(idxI.eq.218)then + ! print *,"I=",idxI,"Nsomo_alpha=",Nsomo_alpha,"nxordiffSOMODOMO(4)=",nxordiffSOMODOMO, " ndiffSOMO(2)=",ndiffSOMO, " ndiffDOMO=",ndiffDOMO + !endif !Jcfg = psi_configuration(:,:,i) !print *,"nxordiffSOMODOMO(4)=",nxordiffSOMODOMO, " ndiffSOMO(2)=",ndiffSOMO @@ -391,14 +383,14 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI do ii=1,N_int Isomo = Ialpha(ii,1) Jsomo = psi_configuration(ii,1,i) - Isomo = IEOR(Isomo, Jsomo) + IJsomo = IEOR(Isomo, Jsomo) iint = shiftr(p-1,bit_kind_shift) + 1 ipos = p-shiftl((iint-1),bit_kind_shift) if(iint .eq. ii)then - Isomo = IBCLR(Isomo,ipos-1) + IJsomo = IBCLR(IJsomo,ipos-1) endif - if(popcnt(Isomo) > 0)then - q = TRAILZ(Isomo) + 1 + (ii-1) * bit_kind_size + if(popcnt(IJsomo) > 0)then + q = TRAILZ(IJsomo) + 1 + (ii-1) * bit_kind_size EXIT endif end do @@ -437,15 +429,15 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI do ii=1,N_int Isomo = Ialpha(ii,1) Jsomo = psi_configuration(ii,1,i) - Isomo = IEOR(Isomo, Jsomo) + IJsomo = IEOR(Isomo, Jsomo) iint = shiftr(q-1,bit_kind_shift) + 1 ipos = q-shiftl((iint-1),bit_kind_shift) if(iint .eq. ii)then - Isomo = IBCLR(Isomo,ipos-1) + IJsomo = IBCLR(IJsomo,ipos-1) endif !print *,"ii=",ii," Isomo=",Isomo - if(popcnt(Isomo) > 0)then - p = TRAILZ(Isomo) + 1 + (ii-1) * bit_kind_size + if(popcnt(IJsomo) > 0)then + p = TRAILZ(IJsomo) + 1 + (ii-1) * bit_kind_size EXIT endif enddo @@ -502,9 +494,9 @@ subroutine obtain_connected_I_foralpha(idxI, Ialpha, connectedI, idxs_connectedI endi = psi_config_data(i,2) nconnectedExtradiag+=1 nconnectedI += 1 - do k=1,N_int - connectedI(k,1,nconnectedI) = psi_configuration(k,1,i) - connectedI(k,2,nconnectedI) = psi_configuration(k,2,i) + do ii=1,N_int + connectedI(ii,1,nconnectedI) = psi_configuration(ii,1,i) + connectedI(ii,2,nconnectedI) = psi_configuration(ii,2,i) enddo idxs_connectedI(nconnectedI)=starti excitationIds(1,nconnectedI)=p From 82409885de49037d00ec7053520c8f3fbc959ca5 Mon Sep 17 00:00:00 2001 From: v1j4y Date: Mon, 19 Dec 2022 13:55:20 +0100 Subject: [PATCH 18/21] Fixed some bugs in generating alphs. --- src/csf/configuration_CI_sigma_helpers.irp.f | 120 +++++++++++-------- 1 file changed, 68 insertions(+), 52 deletions(-) diff --git a/src/csf/configuration_CI_sigma_helpers.irp.f b/src/csf/configuration_CI_sigma_helpers.irp.f index 744ba205..bebf08a3 100644 --- a/src/csf/configuration_CI_sigma_helpers.irp.f +++ b/src/csf/configuration_CI_sigma_helpers.irp.f @@ -565,6 +565,7 @@ use bitmasks integer :: p, pp, p_s integer :: q, qq, q_s integer :: countalphas + integer :: countelec logical :: pqAlreadyGenQ logical :: pqExistsQ logical :: ppExistsQ @@ -584,9 +585,11 @@ use bitmasks Icfg = psi_configuration(:,:,idxI) Jcfg = psi_configuration(:,:,idxI) - do i=1, N_int - Isomo(i) = iand(act_bitmask(i,1),psi_configuration(i,1,idxI)) - Idomo(i) = iand(act_bitmask(i,2),psi_configuration(i,2,idxI)) + !print *,"idxI=",idxI + do ii=1, N_int + Isomo(ii) = iand(act_bitmask(ii,1),psi_configuration(ii,1,idxI)) + Idomo(ii) = iand(act_bitmask(ii,2),psi_configuration(ii,2,idxI)) + !print *,Isomo(ii), Idomo(ii) enddo ! find out all pq holes possible @@ -640,24 +643,22 @@ use bitmasks ! Now find the allowed (p,q) excitations do ii=1, N_int - !Isomo(ii) = iand(reunion_of_act_virt_bitmask(i,1),psi_configuration(ii,1,idxI)) - !Idomo(ii) = iand(reunion_of_act_virt_bitmask(i,2),psi_configuration(ii,2,idxI)) - Isomo(ii) = psi_configuration(ii,1,idxI) - Idomo(ii) = psi_configuration(ii,2,idxI) + !Isomo(ii) = iand(reunion_of_act_virt_bitmask(ii,1),psi_configuration(ii,1,idxI)) + !Idomo(ii) = iand(reunion_of_act_virt_bitmask(ii,2),psi_configuration(ii,2,idxI)) + Isomo(ii) = iand(act_bitmask(ii,1),psi_configuration(ii,1,idxI)) + Idomo(ii) = iand(act_bitmask(ii,2),psi_configuration(ii,2,idxI)) + !Isomo(ii) = psi_configuration(ii,1,idxI) + !Idomo(ii) = psi_configuration(ii,2,idxI) Jsomo(ii) = Isomo(ii) Jdomo(ii) = Idomo(ii) enddo - !print *,"I=",idxI - !print *,"Isomo=",Isomo(1)!, Isomo(2) - !print *,"Idomo=",Idomo(1)!, Idomo(2) - !print *,listholes - !print *,listvmos if(Nsomo_I .EQ. 0) then kstart = 1 else kstart = cfg_seniority_index(max(NSOMOMin,Nsomo_I-2)) endif + kstart = 1 kend = idxI-1 do i = 1,nholes @@ -690,9 +691,6 @@ use bitmasks Nsomo_J += POPCNT(Jsomo(ii)) enddo - !call bitstring_to_list(Jcfg(1,1),listall,nelall,N_int) - !Nsomo_J = nelall - ! Check for Minimal alpha electrons (MS) if(Nsomo_J.lt.MS)then if(vmotype(j) == 1)then @@ -716,9 +714,9 @@ use bitmasks ndiffDOMO = 0 nxordiffSOMODOMO = 0 do ii = 1, N_int - diffSOMO = IEOR(Jcfg(ii,1),iand(reunion_of_act_virt_bitmask(ii,1),psi_configuration(ii,1,k))) + diffSOMO = IEOR(Jcfg(ii,1),iand(act_bitmask(ii,1),psi_configuration(ii,1,k))) ndiffSOMO += POPCNT(diffSOMO) - diffDOMO = IEOR(Jcfg(ii,2),iand(reunion_of_act_virt_bitmask(ii,2),psi_configuration(ii,2,k))) + diffDOMO = IEOR(Jcfg(ii,2),iand(act_bitmask(ii,2),psi_configuration(ii,2,k))) xordiffSOMODOMO = IEOR(diffSOMO,diffDOMO) ndiffDOMO += POPCNT(diffDOMO) nxordiffSOMODOMO += POPCNT(xordiffSOMODOMO) @@ -773,16 +771,26 @@ use bitmasks end do !print *,tableUniqueAlphas(:,:) - ! prune list of alphas - do i=1, N_int - Isomo(i) = iand(act_bitmask(i,1),psi_configuration(i,1,idxI)) - Idomo(i) = iand(act_bitmask(i,2),psi_configuration(i,2,idxI)) - Jsomo(i) = Isomo(i) - Jdomo(i) = Idomo(i) + do ii=1, N_int + Isomo(ii) = iand(act_bitmask(ii,1),psi_configuration(ii,1,idxI)) + Idomo(ii) = iand(act_bitmask(ii,2),psi_configuration(ii,2,idxI)) + !Isomo(ii) = psi_configuration(ii,1,idxI) + !Idomo(ii) = psi_configuration(ii,2,idxI) + Jsomo(ii) = Isomo(ii) + Jdomo(ii) = Idomo(ii) enddo !print *, " Isomo=",Isomo(1), " Idomo=", Idomo(1) + !countelec=0 + !do ii=1, N_int + ! countelec += POPCNT(Icfg(ii,1))*1 + POPCNT(Icfg(ii,2))*2 + !enddo + !if(countelec .ne. 14)then + ! print *," idxI=",idxI, "00countelec=",countelec, " bit_kind_size=",bit_kind_size, " nvmo=",nvmos," mo_num=",mo_num + ! stop + !endif + NalphaIcfg = 0 do i = 1, nholes pp = listholes(i) @@ -809,21 +817,23 @@ use bitmasks if(tableUniqueAlphas(pp,qq)) then - Nsomo_J = 0 - do ii=1, N_int - Jcfg(ii,1) = Jsomo(ii) - Jcfg(ii,2) = Jdomo(ii) - Nsomo_J += POPCNT(Jsomo(ii)) - enddo - - !call bitstring_to_list(Jcfg,listall,nelall,N_int) - !Nsomo_J = nelall + Nsomo_J = 0 + countelec = 0 + do ii=1, N_int + Jcfg(ii,1) = Jsomo(ii) + Jcfg(ii,2) = Jdomo(ii) + Nsomo_J += POPCNT(Jsomo(ii)) + countelec += POPCNT(Jsomo(ii))*1 + POPCNT(Jdomo(ii))*2 + enddo if(Nsomo_J .ge. NSOMOMin) then !print *," Idx = ",idxI, "p = ",pp, " q = ",qq," Jsomo=",Jsomo(1), " Jdomo=",IOR(Jdomo(1),ISHFT(1_8,n_core_orb)-1) NalphaIcfg += 1 - !print *," Idx = ",idxI, " Nalpha=",NalphaIcfg + !if(idxI.eq.8)then + ! print *," 1 Idx = ",idxI, " Nalpha=",NalphaIcfg, " n_core_orb=",n_core_orb + !endif alphasIcfg_list(:,1,idxI,NalphaIcfg) = Jcfg(:,1) + alphasIcfg_list(:,2,idxI,NalphaIcfg) = Jcfg(:,2) if(n_core_orb .le. 64)then alphasIcfg_list(1,2,idxI,NalphaIcfg) = IOR(Jcfg(1,2),ISHFT(1_8,n_core_orb)-1) else @@ -839,6 +849,7 @@ use bitmasks endif NalphaIcfg_list(idxI) = NalphaIcfg endif + !print *," ", NalphaIcfg, Jsomo(1), Jsomo(2), "|", Jdomo(1), Jdomo(2) endif if(vmotype(j) == 1)then @@ -858,12 +869,14 @@ use bitmasks ! Check if this Icfg has been previously generated as a mono ppExistsQ = .False. - do i=1, N_int - Isomo(i) = iand(act_bitmask(i,1),psi_configuration(i,1,idxI)) - Idomo(i) = iand(act_bitmask(i,2),psi_configuration(i,2,idxI)) + do ii=1, N_int + Isomo(ii) = iand(act_bitmask(ii,1),psi_configuration(ii,1,idxI)) + Idomo(ii) = iand(act_bitmask(ii,2),psi_configuration(ii,2,idxI)) enddo + !Icfg = psi_configuration(:,:,idxI) - kstart = max(1,cfg_seniority_index(max(NSOMOMin,Nsomo_I-2))) + !kstart = max(1,cfg_seniority_index(max(NSOMOMin,Nsomo_I-2))) + kstart = 1 ndiffDOMO = 0 do k = kstart, idxI-1 ndiffSOMO = 0 @@ -871,7 +884,7 @@ use bitmasks diffSOMO = IEOR(Icfg(ii,1),iand(act_bitmask(ii,1),psi_configuration(ii,1,k))) ndiffSOMO += POPCNT(diffSOMO) end do - ! ndiffSOMO cannot be 0 (I /= k) + ! ndiffSOMO cannot be 0 (I /= k) if idxI is a single ex ! if ndiffSOMO /= 2 then it has to be greater than 2 and hense ! this Icfg could not have been generated before. if (ndiffSOMO /= 2) cycle @@ -897,9 +910,11 @@ use bitmasks alphasIcfg_list(:,2,idxI,NalphaIcfg) = Icfg(:,2) NalphaIcfg_list(idxI) = NalphaIcfg endif + !print *," ---> ", NalphaIcfg, Icfg(1,1), Icfg(2,1), "|", Icfg(1,2), Icfg(2,2) endif NalphaIcfg = 0 + enddo ! end loop idxI call wall_time(t1) print *, 'Preparation : ', t1 - t0 @@ -954,9 +969,9 @@ END_PROVIDER logical :: ppExistsQ integer :: listall(N_int*bit_kind_size), nelall - do i=1, N_int - Isomo(i) = iand(act_bitmask(i,1),Icfg(i,1)) - Idomo(i) = iand(act_bitmask(i,2),Icfg(i,2)) + do ii=1, N_int + Isomo(ii) = iand(act_bitmask(ii,1),Icfg(ii,1)) + Idomo(ii) = iand(act_bitmask(ii,2),Icfg(ii,2)) enddo !print*,"Input cfg" @@ -1016,11 +1031,11 @@ END_PROVIDER tableUniqueAlphas = .FALSE. ! Now find the allowed (p,q) excitations - do i=1, N_int - Isomo(i) = iand(act_bitmask(i,1),Icfg(i,1)) - Idomo(i) = iand(act_bitmask(i,2),Icfg(i,2)) - Jsomo(i) = Isomo(i) - Jdomo(i) = Idomo(i) + do ii=1, N_int + Isomo(ii) = iand(act_bitmask(ii,1),Icfg(ii,1)) + Idomo(ii) = iand(act_bitmask(ii,2),Icfg(ii,2)) + Jsomo(ii) = Isomo(ii) + Jdomo(ii) = Idomo(ii) enddo ! Now find the allowed (p,q) excitations @@ -1159,11 +1174,11 @@ END_PROVIDER !print *,tableUniqueAlphas(:,:) ! prune list of alphas - do i=1, N_int - Isomo(i) = iand(act_bitmask(i,1),Icfg(i,1)) - Idomo(i) = iand(act_bitmask(i,2),Icfg(i,2)) - Jsomo(i) = Isomo(i) - Jdomo(i) = Idomo(i) + do ii=1, N_int + Isomo(ii) = iand(act_bitmask(ii,1),Icfg(ii,1)) + Idomo(ii) = iand(act_bitmask(ii,2),Icfg(ii,2)) + Jsomo(ii) = Isomo(ii) + Jdomo(ii) = Idomo(ii) enddo NalphaIcfg = 0 @@ -1191,7 +1206,8 @@ END_PROVIDER ! SOMO NalphaIcfg += 1 alphasIcfg_list(:,1,idxI,NalphaIcfg) = Jcfg(:,1) - if(n_core_orb .le. 63)then + alphasIcfg_list(:,2,idxI,NalphaIcfg) = Jcfg(:,2) + if(n_core_orb .le. 64)then alphasIcfg_list(1,2,idxI,NalphaIcfg) = IOR(Jcfg(1,2),ISHFT(1_8,n_core_orb)-1) else n_core_orb_64 = n_core_orb From 16913557ca9813f59e9d9ae3e83c0143bc8f8261 Mon Sep 17 00:00:00 2001 From: v1j4y Date: Mon, 19 Dec 2022 13:56:27 +0100 Subject: [PATCH 19/21] Fixed bugs. Looks like S=1 Nint>1 is also working. --- src/csf/sigma_vector.irp.f | 179 ++++++++++++++++++++++--------------- 1 file changed, 105 insertions(+), 74 deletions(-) diff --git a/src/csf/sigma_vector.irp.f b/src/csf/sigma_vector.irp.f index 2ff3912b..541c3774 100644 --- a/src/csf/sigma_vector.irp.f +++ b/src/csf/sigma_vector.irp.f @@ -149,7 +149,6 @@ ncfgprev = cfg_seniority_index(i+2) end do !print *," ^^^^^ N_CSF = ",n_CSF," N_CFG=",N_configuration - END_PROVIDER @@ -881,10 +880,10 @@ subroutine calculate_preconditioner_cfg(diag_energies) do i=1,N_configuration - Isomo = psi_configuration(1,1,i) - Idomo = psi_configuration(1,2,i) - Icfg(1,1) = psi_configuration(1,1,i) - Icfg(1,2) = psi_configuration(1,2,i) + !Isomo = psi_configuration(1,1,i) + !Idomo = psi_configuration(1,2,i) + !Icfg(1,1) = psi_configuration(1,1,i) + !Icfg(1,2) = psi_configuration(1,2,i) !NSOMOI = getNSOMO(psi_configuration(:,:,i)) starti = psi_config_data(i,1) @@ -894,6 +893,7 @@ subroutine calculate_preconditioner_cfg(diag_energies) ! find out all pq holes possible nholes = 0 + listholes = -1 ! holes in SOMO !do kk = 1,n_act_orb ! k = list_act(kk) @@ -1258,10 +1258,6 @@ subroutine convertOrbIdsToModelSpaceIds(Ialpha, Jcfg, p, q, extype, pmodel, qmod ! TODO Flag (print) when model space indices is > 64 do ii=1,N_int - !Isomo = Ialpha(ii,1) - !Idomo = Ialpha(ii,2) - !Jsomo = Jcfg(ii,1) - !Jdomo = Jcfg(ii,2) Isomo(ii) = Ialpha(ii,1) Idomo(ii) = Ialpha(ii,2) Jsomo(ii) = Jcfg(ii,1) @@ -1292,26 +1288,30 @@ subroutine convertOrbIdsToModelSpaceIds(Ialpha, Jcfg, p, q, extype, pmodel, qmod tmpp = 0 !print *,"iint=",iint, " p=",p do ii=1,iint-1 - mask = ISHFT(1_bit_kind,-1)-1_bit_kind - Isomotmp = IAND(Isomo(ii),mask) - tmpp += POPCNT(mask) - POPCNT(XOR(Isomotmp,mask)) + !mask = ISHFT(1_bit_kind,-1)-1_bit_kind + !Isomotmp = IAND(Isomo(ii),mask) + !tmpp += POPCNT(mask) - POPCNT(XOR(Isomotmp,mask)) + tmpp += POPCNT(Isomo(ii)) end do mask = ISHFT(1_bit_kind,ipos+1) - 1 Isomotmp = IAND(Isomo(iint),mask) - pmodel = tmpp + POPCNT(mask) - POPCNT(XOR(Isomotmp,mask)) + !pmodel = tmpp + POPCNT(mask) - POPCNT(XOR(Isomotmp,mask)) + pmodel = tmpp + POPCNT(Isomotmp) !print *,"iint=",iint, " ipos=",ipos,"pmodel=",pmodel, XOR(Isomotmp,mask),Isomo(iint) iint = shiftr(q-1,bit_kind_shift) + 1 ipos = q-shiftl((iint-1),bit_kind_shift)-1 tmpq = 0 do ii=1,iint-1 - mask = ISHFT(1_bit_kind,-1)-1_bit_kind - Isomotmp = IAND(Isomo(ii),mask) - tmpq += POPCNT(mask) - POPCNT(XOR(Isomotmp,mask)) + !mask = ISHFT(1_bit_kind,-1)-1_bit_kind + !Isomotmp = IAND(Isomo(ii),mask) + !tmpq += POPCNT(mask) - POPCNT(XOR(Isomotmp,mask)) + tmpq += POPCNT(Isomo(ii)) end do mask = ISHFT(1_bit_kind,ipos+1) - 1 Isomotmp = IAND(Isomo(iint),mask) - qmodel = tmpq + POPCNT(mask) - POPCNT(XOR(Isomotmp,mask)) + !qmodel = tmpq + POPCNT(mask) - POPCNT(XOR(Isomotmp,mask)) + qmodel = tmpq + POPCNT(Isomotmp) !print *,"iint=",iint, " ipos=",ipos,"qmodel=",qmodel case (2) ! DOMO -> VMO @@ -1328,25 +1328,29 @@ subroutine convertOrbIdsToModelSpaceIds(Ialpha, Jcfg, p, q, extype, pmodel, qmod ipos = p-shiftl((iint-1),bit_kind_shift)-1 tmpp = 0 do ii=1,iint-1 - mask = ISHFT(1_bit_kind,-1)-1_bit_kind - Jsomotmp = IAND(Jsomo(ii),mask) - tmpp += POPCNT(mask) - POPCNT(XOR(Jsomotmp,mask)) + !mask = ISHFT(1_bit_kind,-1)-1_bit_kind + !Jsomotmp = IAND(Jsomo(ii),mask) + !tmpp += POPCNT(mask) - POPCNT(XOR(Jsomotmp,mask)) + tmpp += POPCNT(Jsomo(ii)) end do mask = ISHFT(1_bit_kind,ipos+1) - 1 Jsomotmp = IAND(Jsomo(iint),mask) - pmodel = tmpp + POPCNT(mask) - POPCNT(XOR(Jsomotmp,mask)) + !pmodel = tmpp + POPCNT(mask) - POPCNT(XOR(Jsomotmp,mask)) + pmodel = tmpp + POPCNT(Jsomotmp) iint = shiftr(q-1,bit_kind_shift) + 1 ipos = q-shiftl((iint-1),bit_kind_shift)-1 tmpq = 0 do ii=1,iint-1 - mask = ISHFT(1_bit_kind,-1)-1_bit_kind - Jsomotmp = IAND(Jsomo(ii),mask) - tmpq += POPCNT(mask) - POPCNT(XOR(Jsomotmp,mask)) + !mask = ISHFT(1_bit_kind,-1)-1_bit_kind + !Jsomotmp = IAND(Jsomo(ii),mask) + !tmpq += POPCNT(mask) - POPCNT(XOR(Jsomotmp,mask)) + tmpq += POPCNT(Jsomo(ii)) end do mask = ISHFT(1_bit_kind,ipos+1) - 1 Jsomotmp = IAND(Jsomo(iint),mask) - qmodel = tmpq + POPCNT(mask) - POPCNT(XOR(Jsomotmp,mask)) + !qmodel = tmpq + POPCNT(mask) - POPCNT(XOR(Jsomotmp,mask)) + qmodel = tmpq + POPCNT(Jsomotmp) case (3) ! SOMO -> VMO !print *,"type -> SOMO -> VMO" @@ -1363,25 +1367,29 @@ subroutine convertOrbIdsToModelSpaceIds(Ialpha, Jcfg, p, q, extype, pmodel, qmod ipos = p-shiftl((iint-1),bit_kind_shift)-1 tmpp = 0 do ii=1,iint-1 - mask = ISHFT(1_bit_kind,-1)-1_bit_kind - Isomotmp = IAND(Isomo(ii),mask) - tmpp += POPCNT(mask) - POPCNT(XOR(Isomotmp,mask)) + !mask = ISHFT(1_bit_kind,-1)-1_bit_kind + !Isomotmp = IAND(Isomo(ii),mask) + !tmpp += POPCNT(mask) - POPCNT(XOR(Isomotmp,mask)) + tmpp += POPCNT(Isomo(ii)) end do - mask = ISHFT(1_8,ipos+1) - 1 + mask = ISHFT(1_bit_kind,ipos+1) - 1 Isomotmp = IAND(Isomo(iint),mask) - pmodel = tmpp + POPCNT(mask) - POPCNT(XOR(Isomotmp,mask)) + !pmodel = tmpp + POPCNT(mask) - POPCNT(XOR(Isomotmp,mask)) + pmodel = tmpp + POPCNT(Isomotmp) iint = shiftr(q-1,bit_kind_shift) + 1 ipos = q-shiftl((iint-1),bit_kind_shift)-1 tmpq = 0 do ii=1,iint-1 - mask = ISHFT(1_bit_kind,-1)-1_bit_kind - Jsomotmp = IAND(Jsomo(ii),mask) - tmpq += POPCNT(mask) - POPCNT(XOR(Jsomotmp,mask)) + !mask = ISHFT(1_bit_kind,-1)-1_bit_kind + !Jsomotmp = IAND(Jsomo(ii),mask) + !tmpq += POPCNT(mask) - POPCNT(XOR(Jsomotmp,mask)) + tmpq += POPCNT(Jsomo(ii)) end do mask = ISHFT(1_bit_kind,ipos+1) - 1 Jsomotmp = IAND(Jsomo(iint),mask) - qmodel = tmpq + POPCNT(mask) - POPCNT(XOR(Jsomotmp,mask)) + 1 + !qmodel = tmpq + POPCNT(mask) - POPCNT(XOR(Jsomotmp,mask)) + 1 + qmodel = tmpq + POPCNT(Jsomotmp) + 1 else !mask = ISHFT(1_8,p) - 1 !Isomo = IAND(Isomo,mask) @@ -1394,25 +1402,29 @@ subroutine convertOrbIdsToModelSpaceIds(Ialpha, Jcfg, p, q, extype, pmodel, qmod ipos = p-shiftl((iint-1),bit_kind_shift)-1 tmpp = 0 do ii=1,iint-1 - mask = ISHFT(1_bit_kind,-1)-1_bit_kind - Isomotmp = IAND(Isomo(ii),mask) - tmpp += POPCNT(mask) - POPCNT(XOR(Isomotmp,mask)) + !mask = ISHFT(1_bit_kind,-1)-1_bit_kind + !Isomotmp = IAND(Isomo(ii),mask) + !tmpp += POPCNT(mask) - POPCNT(XOR(Isomotmp,mask)) + tmpp += POPCNT(Isomo(ii)) end do mask = ISHFT(1_bit_kind,ipos+1) - 1 Isomotmp = IAND(Isomo(iint),mask) - pmodel = tmpp + POPCNT(mask) - POPCNT(XOR(Isomotmp,mask)) + 1 + !pmodel = tmpp + POPCNT(mask) - POPCNT(XOR(Isomotmp,mask)) + 1 + pmodel = tmpp + POPCNT(Isomotmp) + 1 iint = shiftr(q-1,bit_kind_shift) + 1 ipos = q-shiftl((iint-1),bit_kind_shift)-1 tmpq = 0 do ii=1,iint-1 - mask = ISHFT(1_bit_kind,-1)-1_bit_kind - Jsomotmp = IAND(Jsomo(ii),mask) - tmpq += POPCNT(mask) - POPCNT(XOR(Jsomotmp,mask)) + !mask = ISHFT(1_bit_kind,-1)-1_bit_kind + !Jsomotmp = IAND(Jsomo(ii),mask) + !tmpq += POPCNT(mask) - POPCNT(XOR(Jsomotmp,mask)) + tmpq += POPCNT(Jsomo(ii)) end do mask = ISHFT(1_bit_kind,ipos+1) - 1 Jsomotmp = IAND(Jsomo(iint),mask) - qmodel = tmpq + POPCNT(mask) - POPCNT(XOR(Jsomotmp,mask)) + !qmodel = tmpq + POPCNT(mask) - POPCNT(XOR(Jsomotmp,mask)) + qmodel = tmpq + POPCNT(Jsomotmp) endif case (4) ! DOMO -> SOMO @@ -1431,25 +1443,29 @@ subroutine convertOrbIdsToModelSpaceIds(Ialpha, Jcfg, p, q, extype, pmodel, qmod ipos = p-shiftl((iint-1),bit_kind_shift)-1 tmpp = 0 do ii=1,iint-1 - mask = ISHFT(1_bit_kind,-1)-1_bit_kind - Jsomotmp = IAND(Jsomo(ii),mask) - tmpp += POPCNT(mask) - POPCNT(XOR(Jsomotmp,mask)) + !mask = ISHFT(1_bit_kind,-1)-1_bit_kind + !Jsomotmp = IAND(Jsomo(ii),mask) + !tmpp += POPCNT(mask) - POPCNT(XOR(Jsomotmp,mask)) + tmpp += POPCNT(Jsomo(ii)) end do mask = ISHFT(1_bit_kind,ipos+1) - 1 Jsomotmp = IAND(Jsomo(iint),mask) - pmodel = tmpp + POPCNT(mask) - POPCNT(XOR(Jsomotmp,mask)) + !pmodel = tmpp + POPCNT(mask) - POPCNT(XOR(Jsomotmp,mask)) + pmodel = tmpp + POPCNT(Jsomotmp) iint = shiftr(q-1,bit_kind_shift) + 1 ipos = q-shiftl((iint-1),bit_kind_shift)-1 tmpq = 0 do ii=1,iint-1 - mask = ISHFT(1_bit_kind,-1)-1_bit_kind - Isomotmp = IAND(Isomo(ii),mask) - tmpq += POPCNT(mask) - POPCNT(XOR(Isomotmp,mask)) + !mask = ISHFT(1_bit_kind,-1)-1_bit_kind + !Isomotmp = IAND(Isomo(ii),mask) + !tmpq += POPCNT(mask) - POPCNT(XOR(Isomotmp,mask)) + tmpq += POPCNT(Isomo(ii)) end do mask = ISHFT(1_bit_kind,ipos+1) - 1 Isomotmp = IAND(Isomo(iint),mask) - qmodel = tmpq + POPCNT(mask) - POPCNT(XOR(Isomotmp,mask)) + 1 + !qmodel = tmpq + POPCNT(mask) - POPCNT(XOR(Isomotmp,mask)) + 1 + qmodel = tmpq + POPCNT(Isomotmp) + 1 else !mask = ISHFT(1_8,p) - 1 !Jsomo = IAND(Jsomo,mask) @@ -1462,25 +1478,29 @@ subroutine convertOrbIdsToModelSpaceIds(Ialpha, Jcfg, p, q, extype, pmodel, qmod ipos = p-shiftl((iint-1),bit_kind_shift)-1 tmpp = 0 do ii=1,iint-1 - mask = ISHFT(1_bit_kind,-1)-1_bit_kind - Jsomotmp = IAND(Jsomo(ii),mask) - tmpp += POPCNT(mask) - POPCNT(XOR(Jsomotmp,mask)) + !mask = ISHFT(1_bit_kind,-1)-1_bit_kind + !Jsomotmp = IAND(Jsomo(ii),mask) + !tmpp += POPCNT(mask) - POPCNT(XOR(Jsomotmp,mask)) + tmpp += POPCNT(Jsomo(ii)) end do mask = ISHFT(1_bit_kind,ipos+1) - 1 Jsomotmp = IAND(Jsomo(iint),mask) - pmodel = tmpp + POPCNT(mask) - POPCNT(XOR(Jsomotmp,mask)) + 1 + !pmodel = tmpp + POPCNT(mask) - POPCNT(XOR(Jsomotmp,mask)) + 1 + pmodel = tmpp + POPCNT(Jsomotmp) + 1 iint = shiftr(q-1,bit_kind_shift) + 1 ipos = q-shiftl((iint-1),bit_kind_shift)-1 tmpq = 0 do ii=1,iint-1 - mask = ISHFT(1_bit_kind,-1)-1_bit_kind - Isomotmp = IAND(Isomo(ii),mask) - tmpq += POPCNT(mask) - POPCNT(XOR(Isomotmp,mask)) + !mask = ISHFT(1_bit_kind,-1)-1_bit_kind + !Isomotmp = IAND(Isomo(ii),mask) + !tmpq += POPCNT(mask) - POPCNT(XOR(Isomotmp,mask)) + tmpq += POPCNT(Isomo(ii)) end do mask = ISHFT(1_bit_kind,ipos+1) - 1 Isomotmp = IAND(Isomo(iint),mask) - qmodel = tmpq + POPCNT(mask) - POPCNT(XOR(Isomotmp,mask)) + !qmodel = tmpq + POPCNT(mask) - POPCNT(XOR(Isomotmp,mask)) + qmodel = tmpq + POPCNT(Isomotmp) endif case default print *,"something is wrong in convertOrbIdsToModelSpaceIds" @@ -1560,6 +1580,7 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze real*8 :: tmpvar, tmptot real*8 :: core_act_contrib integer :: listall(N_int*bit_kind_size), nelall + integer :: countelec integer(omp_lock_kind), allocatable :: lock(:) call omp_set_max_active_levels(1) @@ -1621,7 +1642,7 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze !$OMP shared(istart_cfg, iend_cfg, psi_configuration, mo_num, psi_config_data,& !$OMP N_int, N_st, psi_out, psi_in, h_core_ri, core_energy, h_act_ri, AIJpqContainer,& !$OMP pp, sze, NalphaIcfg_list,alphasIcfg_list, bit_tmp, & - !$OMP qq, iint, jint, ipos, jpos, nelall, listall, Nsomo_I, & + !$OMP qq, iint, jint, ipos, jpos, nelall, listall, Nsomo_I, countelec,& !$OMP AIJpqMatrixDimsList, diag_energies, n_CSF, lock, NBFmax,nconnectedtotalmax, nconnectedmaxJ,maxnalphas,& !$OMP n_core_orb, n_act_orb, list_act, n, list_core, list_core_is_built,core_act_contrib, num_threads_max,& !$OMP n_core_orb_is_built, mo_integrals_map, mo_integrals_map_is_built) @@ -1650,7 +1671,7 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze Isomo(ii) = Icfg(ii,1) Idomo(ii) = Icfg(ii,2) enddo - NSOMOI = getNSOMO(Icfg) + NSOMOI = getNSOMO(Icfg) ! find out all pq holes possible nholes = 0 @@ -1680,9 +1701,6 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze ! enddo ! ! find vmos - listvmos = -1 - vmotype = -1 - nvmos = 0 ! do kk = 1,n_act_orb ! k = list_act(kk) ! !print *,i,IBSET(0,i-1),POPCNT(IAND(Isomo,(IBSET(0_8,i-1)))), POPCNT(IAND(Idomo,(IBSET(0_8,i-1)))) @@ -1720,6 +1738,9 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze end do + listvmos = -1 + vmotype = -1 + nvmos = 0 ! find vmos ! Take into account N_int do ii = 1, n_act_orb @@ -1835,6 +1856,9 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze deallocate(excitationTypes_single) !print *," singles part psi(1,1)=",psi_out(1,1) + !do i=1,n_CSF + ! print *,"i=",i," psi(i)=",psi_out(1,i) + !enddo allocate(listconnectedJ(N_INT,2,max(sze,10000))) allocate(alphas_Icfg(N_INT,2,max(sze,10000))) @@ -1849,7 +1873,6 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze !!!====================!!! !!! Double Excitations !!! !!!====================!!! - ! Loop over all selected configurations !$OMP DO SCHEDULE(static) do i = istart_cfg,iend_cfg @@ -1880,7 +1903,8 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze !call obtain_connected_J_givenI(i, Icfg, listconnectedJ, idslistconnectedJ, nconnectedJ, ntotJ) ! TODO : remove doubly excited for return - !print *,"I=",i," isomo=",psi_configuration(1,1,i)," idomo=",psi_configuration(1,2,i), " psiout=",psi_out(1,5), "Nalphas_Icfg=",Nalphas_Icfg + !print *,"I=",i,"isomo=",psi_configuration(1,1,i),psi_configuration(2,1,i),POPCNT(psi_configuration(1,1,i)),POPCNT(psi_configuration(2,1,i)),& + !"idomo=",psi_configuration(1,2,i),psi_configuration(2,2,i),POPCNT(psi_configuration(1,2,i)),POPCNT(psi_configuration(2,2,i)), "Nalphas_Icfg=",Nalphas_Icfg do k = 1,Nalphas_Icfg ! Now generate all singly excited with respect to a given alpha CFG @@ -1891,11 +1915,11 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze call obtain_connected_I_foralpha(i, alphas_Icfg(1,1,k), connectedI_alpha, idxs_connectedI_alpha, & nconnectedI, excitationIds, excitationTypes, diagfactors) - !if(i .EQ. 1) then - ! !print *,'k=',k,' kcfgSOMO=',alphas_Icfg(1,1,k),alphas_Icfg(2,1,k),' ',POPCNT(alphas_Icfg(1,1,k)),' & - ! !kcfgDOMO=',alphas_Icfg(1,2,k),alphas_Icfg(2,2,k),' ',POPCNT(alphas_Icfg(1,2,k)), " NconnectedI=",nconnectedI - ! print *,'k=',k,' kcfgSOMO=',alphas_Icfg(1,1,k),' ',POPCNT(alphas_Icfg(1,1,k)),' & - ! kcfgDOMO=',alphas_Icfg(1,2,k),' ',POPCNT(alphas_Icfg(1,2,k)), " NconnectedI=",nconnectedI + !if(i .EQ. 218) then + ! print *,'k=',k,' kcfgSOMO=',alphas_Icfg(1,1,k),alphas_Icfg(2,1,k),' ',POPCNT(alphas_Icfg(1,1,k)),' & + ! kcfgDOMO=',alphas_Icfg(1,2,k),alphas_Icfg(2,2,k),' ',POPCNT(alphas_Icfg(1,2,k)), " NconnectedI=",nconnectedI + ! !print *,'k=',k,' kcfgSOMO=',alphas_Icfg(1,1,k),' ',POPCNT(alphas_Icfg(1,1,k)),' & + ! !kcfgDOMO=',alphas_Icfg(1,2,k),' ',POPCNT(alphas_Icfg(1,2,k)), " NconnectedI=",nconnectedI !endif @@ -1911,15 +1935,22 @@ subroutine calculate_sigma_vector_cfg_nst_naive_store(psi_out, psi_in, n_st, sze NSOMOI = getNSOMO(connectedI_alpha(:,:,j)) p = excitationIds(1,j) q = excitationIds(2,j) - !print *,"j=",j, " p=",p," q=",q extype = excitationTypes(j) + !print *,"K=",k,"j=",j, "countelec=",countelec," p=",p," q=",q, " extype=",extype, "NSOMOalpha=",NSOMOalpha," NSOMOI=",NSOMOI, "alphas_Icfg(1,1,k)=",alphas_Icfg(1,1,k), & + !alphas_Icfg(2,1,k), " domo=",alphas_Icfg(1,2,k), alphas_Icfg(2,2,k), " connected somo=",connectedI_alpha(1,1,j), & + !connectedI_alpha(2,1,j), " domo=",connectedI_alpha(1,2,j), connectedI_alpha(2,2,j) call convertOrbIdsToModelSpaceIds(alphas_Icfg(1,1,k), connectedI_alpha(1,1,j), p, q, extype, pmodel, qmodel) ! for E_pp E_rs and E_ppE_rr case - if(i.eq.1)then - print *,"j=",j," k=",k,"p=",p,"q=",q,"NSOMOalpha=",NSOMOalpha, "pmodel=",pmodel,"qmodel=",qmodel, "extype=",extype - endif rowsikpq = AIJpqMatrixDimsList(NSOMOalpha,extype,pmodel,qmodel,1) colsikpq = AIJpqMatrixDimsList(NSOMOalpha,extype,pmodel,qmodel,2) + !if(i.eq.218)then + ! print *,"j=",j," k=",k,"p=",p,"q=",q,"NSOMOalpha=",NSOMOalpha, "pmodel=",pmodel,"qmodel=",qmodel, "extype=",extype,& + ! "conn somo=",connectedI_alpha(1,1,j),connectedI_alpha(2,1,j),& + ! "conn domo=",connectedI_alpha(1,2,j),connectedI_alpha(2,2,j) + ! do m=1,colsikpq + ! print *,idxs_connectedI_alpha(j)+m-1 + ! enddo + !endif !print *,"j=",j," Nsomo=",NSOMOalpha," rowsikpq=",rowsikpq," colsikpq=",colsikpq, " p=",pmodel," q=",qmodel, " extyp=",extype totcolsTKI += colsikpq rowsTKI = rowsikpq From 4b52bc4a512a67ab4056b69ecfe21cb6a9d42df9 Mon Sep 17 00:00:00 2001 From: v1j4y Date: Mon, 19 Dec 2022 14:05:45 +0100 Subject: [PATCH 20/21] Revert to default diagonalization method. --- src/davidson/diagonalize_ci.irp.f | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/davidson/diagonalize_ci.irp.f b/src/davidson/diagonalize_ci.irp.f index 8ec6cd7e..76d8b65f 100644 --- a/src/davidson/diagonalize_ci.irp.f +++ b/src/davidson/diagonalize_ci.irp.f @@ -5,8 +5,8 @@ BEGIN_PROVIDER [ character*(3), sigma_vector_algorithm ] ! ! If 'cfg', use in Davidson END_DOC - !sigma_vector_algorithm = 'det' - sigma_vector_algorithm = 'cfg' + sigma_vector_algorithm = 'det' + !sigma_vector_algorithm = 'cfg' END_PROVIDER BEGIN_PROVIDER [ double precision, CI_energy, (N_states_diag) ] From e7428c50b84e832c0ed8d98b5dc7e3989904b8bb Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 23 Dec 2022 18:31:27 +0100 Subject: [PATCH 21/21] Fixed Davidson --- config/bull.cfg | 4 ++-- .../{test_dav.irp.f => test_dav.irp.f.example} | 0 2 files changed, 2 insertions(+), 2 deletions(-) rename src/dav_general_mat/{test_dav.irp.f => test_dav.irp.f.example} (100%) diff --git a/config/bull.cfg b/config/bull.cfg index 6a93fdca..91471473 100644 --- a/config/bull.cfg +++ b/config/bull.cfg @@ -6,7 +6,7 @@ # --align=32 : Align all provided arrays on a 32-byte boundary # [COMMON] -FC : mpiifort -shared-libgcc -shared-intel -fpic +FC : mpiifort -fpic -xCORE-AVX2 LAPACK_LIB : -mkl=parallel IRPF90 : irpf90 IRPF90_FLAGS : --ninja --align=32 -DMPI @@ -31,7 +31,7 @@ OPENMP : 1 ; Append OpenMP flags # -ftz : Flushes denormal results to zero # [OPT] -FCFLAGS : -xCORE-AVX2 -O2 -ip -ftz -g -traceback -qopt-prefetch=5 -qopt-prefetch-issue-excl-hint -unroll-aggressive +FCFLAGS : -O2 -ip -ftz -g -traceback -qopt-prefetch=5 -qopt-prefetch-issue-excl-hint -unroll-aggressive # Profiling flags ################# # diff --git a/src/dav_general_mat/test_dav.irp.f b/src/dav_general_mat/test_dav.irp.f.example similarity index 100% rename from src/dav_general_mat/test_dav.irp.f rename to src/dav_general_mat/test_dav.irp.f.example