From 0a4c14658c01041e50c521f2532a4210c83e6ba8 Mon Sep 17 00:00:00 2001 From: Matheus Moraes Date: Wed, 18 Jun 2025 14:43:48 -0400 Subject: [PATCH 01/37] NEW: Scalar*twoERIs procedure --- src/mqc_algebra.F03 | 263 ++++++++++++++- src/mqc_est.F03 | 785 +++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 1039 insertions(+), 9 deletions(-) diff --git a/src/mqc_algebra.F03 b/src/mqc_algebra.F03 index 7b22b5ce..4a049da5 100644 --- a/src/mqc_algebra.F03 +++ b/src/mqc_algebra.F03 @@ -33055,8 +33055,269 @@ Function MQC_R4Tensor_R4Tensor_Partial_Contraction(RA,RB,orderA,orderB) Result(M enddo !$OMP END PARALLEL DO + EndFunction MQC_R4Tensor_R4Tensor_Partial_Contraction +! +! +! PROCEDURE MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor +! +!> \brief MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor +!> +!> +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] RA +!> \verbatim +!> RA is Type(MQC_R4Tensor) +!> The MQC R4Tensor to be partially contracted. +!> \endverbatim +!> +!> \param[in] RB +!> \verbatim +!> RB is Type(MQC_R4Tensor) +!> The MQC R4Tensor to be partially contracted. +!> \endverbatim +!> +!> \param[in] orderA +!> \verbatim +!> inorder is Integer(kind=int64),dimension(4),optional +!> Contain the indexes of RA to be contracted. +!> The two first integers in the object are the ones to be contracted, +!> while the two last are the one to be multiplied. +!> Ex: If orderA=[3,2,4,1], the thrid and second indexes of RA are contacted. +!> The fourth and first form the first and second indexes +!> of the result R4Tensor, respectivelly. +!> \endverbatim +!> +!> \param[in] orderB +!> \verbatim +!> inorder is Integer(kind=int64),dimension(B),optional +!> Contain the indexes of RB to be contracted. +!> The two first integers in the object are the ones to be contracted, +!> while the two last are used as the two last indexes of the R4Tensor. +!> +!> Ex: orderA=[3,2,4,1] and orderB=[2,1,4,3] +!> sum_{i,j} RA_{ljik} RB_{jipq} = RC_{klqp} +!> +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2025 +! + Function MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(RA,RB,orderA,orderB) Result(RC) +! + Implicit None + Type(MQC_R4Tensor),Intent(In)::RA,RB + Integer(kind=int64),dimension(4),Intent(In),optional::orderA,orderB + Type(MQC_R4Tensor)::RAreal,RBreal,RC + Type(MQC_Matrix)::tmpRB,tmpRA + Integer(kind=int64)::ia,ja,ka,la,ib,jb,kb,lb,i,j,k,l,p,q + Integer(kind=int64)::dimAi,dimAj,dimAk,dimAl,dimBi,dimBj,dimBk,dimBl + Integer(kind=int64),dimension(2)::vi,vj - EndFunction MQC_R4Tensor_R4Tensor_Partial_Contraction + if(present(orderA)) then + ia=orderA(1) + ja=orderA(2) + ka=orderA(3) + la=orderA(4) + if (ia.eq.ja) Call MQC_Error_I('Duplicated index in MQC_R4Tensor_R4Tensor_Contraction_2R4Tensor',& + 6,'ia', ia,'ja',ja) + if (ia.eq.ka) Call MQC_Error_I('Duplicated index in MQC_R4Tensor_R4Tensor_Contraction_2R4Tensor',& + 6,'ia', ia,'ka',ka) + if (ia.eq.la) Call MQC_Error_I('Duplicated index in MQC_R4Tensor_R4Tensor_Contraction_2R4Tensor',& + 6,'ia', ia,'la',la) + if (ja.eq.ka) Call MQC_Error_I('Duplicated index in MQC_R4Tensor_R4Tensor_Contraction_2R4Tensor',& + 6,'ja', ja,'ka',ka) + if (ja.eq.la) Call MQC_Error_I('Duplicated index in MQC_R4Tensor_R4Tensor_Contraction_2R4Tensor',& + 6,'ja', ja,'la',la) + if (ka.eq.la) Call MQC_Error_I('Duplicated index in MQC_R4Tensor_R4Tensor_Contraction_2R4Tensor',& + 6,'ka', ka,'la',la) + else + ia=1 + ja=2 + ka=3 + la=4 + endif + if(present(orderB)) then + ib=orderB(1) + jb=orderB(2) + kb=orderB(3) + lb=orderB(4) + if (ib.eq.jb) Call MQC_Error_I('Duplicated index in MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor',& + 6,'ib', ib,'jb',jb) + if (ib.eq.kb) Call MQC_Error_I('Duplicated index in MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor',& + 6,'ib', ib,'kb',kb) + if (ib.eq.lb) Call MQC_Error_I('Duplicated index in MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor',& + 6,'ib', ib,'lb',lb) + if (jb.eq.kb) Call MQC_Error_I('Duplicated index in MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor',& + 6,'jb', jb,'kb',kb) + if (jb.eq.lb) Call MQC_Error_I('Duplicated index in MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor',& + 6,'jb', jb,'lb',lb) + if (kb.eq.lb) Call MQC_Error_I('Duplicated index in MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor',& + 6,'kb', kb,'lb',lb) + else + ib=1 + jb=2 + kb=3 + lb=4 + endif + if (ia.gt.4.or.ia.le.0.or.ib.gt.4.or.ib.le.0.or.& + ja.gt.4.or.ja.le.0.or.jb.gt.4.or.jb.le.0.or.& + ka.gt.4.or.ka.le.0.or.kb.gt.4.or.kb.le.0.or.& + la.gt.4.or.la.le.0.or.lb.gt.4.or.lb.le.0.) Call MQC_Error(& + 'Index out of range in MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor', 6) + dimAi = MQC_R4Tensor_Size(RA,ia) + dimAj = MQC_R4Tensor_Size(RA,ja) + dimAk = MQC_R4Tensor_Size(RA,ka) + dimAl = MQC_R4Tensor_Size(RA,la) + + dimBi = MQC_R4Tensor_Size(RB,ib) + dimBj = MQC_R4Tensor_Size(RB,jb) + dimBk = MQC_R4Tensor_Size(RB,kb) + dimBl = MQC_R4Tensor_Size(RB,lb) + + If (dimAi.ne.dimBi.or.dimAj.ne.dimBj) Call MQC_Error(& + 'R4Tensor are not conformable for partial contraction_2R4Tensor', 6) + + If (MQC_R4Tensor_HaveInteger(RA)) RAreal = MQC_Cast_Real(RA) + If (MQC_R4Tensor_HaveInteger(RB)) RBreal = MQC_Cast_Real(RB) + If (MQC_R4Tensor_HaveComplex(RA) .or. MQC_R4Tensor_HaveComplex(RB)) then + Call MQC_Allocate_R4Tensor(dimAk,dimAl,dimBk,dimBl,RC,'Complex','StorFull') + ElseIf (MQC_R4Tensor_HaveReal(RA) .or. MQC_R4Tensor_HaveReal(RB)) then + Call MQC_Allocate_R4Tensor(dimAk,dimAl,dimBk,dimBl,RC,'Real','StorFull') + !!TODO:Consider symm + Else + Call MQC_Allocate_R4Tensor(dimAk,dimAl,dimBk,dimBl,RC,'Integer','StorFull') + EndIf + + vi=[1,dimAi] + vj=[1,dimAj] +!$OMP PARALLEL DO DEFAULT(NONE), & +!$OMP SHARED(RA,RB,vi,vj,ia,ja,la,ka,& +!$OMP ib,jb,lb,kb,RC,dimAl,dimAk,dimBl,dimBk),& +!$OMP PRIVATE(tmpRA,tmpRB,k,l,p,q) + do k=1,dimAl + do l=1,dimAk + select case(ia) + case(1) + select case(ja) + case(2) + if(ka.eq.3) tmpRA = RA%mat(vi,vj,[k],[l]) + if(ka.eq.4) tmpRA = RA%mat(vi,vj,[l],[k]) + case(3) + if(ka.eq.2) tmpRA = RA%mat(vi,[k],vj,[l]) + if(ka.eq.4) tmpRA = RA%mat(vi,[l],vj,[k]) + case(4) + if(ka.eq.2) tmpRA = RA%mat(vi,[k],[l],vj) + if(ka.eq.3) tmpRA = RA%mat(vi,[l],[k],vj) + end select + case(2) + select case(ja) + case(1) + if(ka.eq.3) tmpRA = transpose(RA%mat(vj,vi,[k],[l])) + if(ka.eq.4) tmpRA = transpose(RA%mat(vj,vi,[l],[k])) + case(3) + if(ka.eq.1) tmpRA = RA%mat([k],vi,vj,[l]) + if(ka.eq.4) tmpRA = RA%mat([l],vi,vj,[k]) + case(4) + if(ka.eq.1) tmpRA = RA%mat([k],vi,[l],vj) + if(ka.eq.3) tmpRA = RA%mat([l],vi,[k],vj) + end select + case(3) + select case(ja) + case(1) + if(ka.eq.2) tmpRA = transpose(RA%mat(vj,[k],vi,[l])) + if(ka.eq.4) tmpRA = transpose(RA%mat(vj,[l],vi,[k])) + case(2) + if(ka.eq.1) tmpRA = transpose(RA%mat([k],vj,vi,[l])) + if(ka.eq.4) tmpRA = transpose(RA%mat([l],vj,vi,[k])) + case(4) + if(ka.eq.1) tmpRA = RA%mat([k],[l],vi,vj) + if(ka.eq.2) tmpRA = RA%mat([l],[k],vi,vj) + end select + case(4) + select case(ja) + case(1) + if(ka.eq.2) tmpRA = transpose(RA%mat(vj,[k],[l],vi)) + if(ka.eq.3) tmpRA = transpose(RA%mat(vj,[l],[k],vi)) + case(2) + if(ka.eq.1) tmpRA = transpose(RA%mat([k],vj,[l],vi)) + if(ka.eq.3) tmpRA = transpose(RA%mat([l],vj,[k],vi)) + case(3) + if(ka.eq.1) tmpRA = transpose(RA%mat([k],[l],vj,vi)) + if(ka.eq.2) tmpRA = transpose(RA%mat([l],[k],vj,vi)) + end select + end select + do p=1,dimBl + do q=1,dimBk + select case(ib) + case(1) + select case(jb) + case(2) + if(kb.eq.3) tmpRB = RB%mat(vi,vj,[p],[q]) + if(kb.eq.4) tmpRB = RB%mat(vi,vj,[q],[p]) + case(3) + if(kb.eq.2) tmpRB = RB%mat(vi,[p],vj,[q]) + if(kb.eq.4) tmpRB = RB%mat(vi,[q],vj,[p]) + case(4) + if(kb.eq.2) tmpRB = RB%mat(vi,[p],[q],vj) + if(kb.eq.3) tmpRB = RB%mat(vi,[q],[p],vj) + end select + case(2) + select case(jb) + case(1) + if(kb.eq.3) tmpRB = transpose(RB%mat(vj,vi,[p],[q])) + if(kb.eq.4) tmpRB = transpose(RB%mat(vj,vi,[q],[p])) + case(3) + if(kb.eq.1) tmpRB = RB%mat([p],vi,vj,[q]) + if(kb.eq.4) tmpRB = RB%mat([q],vi,vj,[p]) + case(4) + if(kb.eq.1) tmpRB = RB%mat([p],vi,[q],vj) + if(kb.eq.3) tmpRB = RB%mat([q],vi,[p],vj) + end select + case(3) + select case(jb) + case(1) + if(kb.eq.2) tmpRB = transpose(RB%mat(vj,[p],vi,[q])) + if(kb.eq.4) tmpRB = transpose(RB%mat(vj,[q],vi,[p])) + case(2) + if(kb.eq.1) tmpRB = transpose(RB%mat([p],vj,vi,[q])) + if(kb.eq.4) tmpRB = transpose(RB%mat([q],vj,vi,[p])) + case(4) + if(kb.eq.1) tmpRB = RB%mat([p],[q],vi,vj) + if(kb.eq.2) tmpRB = RB%mat([q],[p],vi,vj) + end select + case(4) + select case(jb) + case(1) + if(kb.eq.2) tmpRB = transpose(RB%mat(vj,[p],[q],vi)) + if(kb.eq.3) tmpRB = transpose(RB%mat(vj,[q],[p],vi)) + case(2) + if(kb.eq.1) tmpRB = transpose(RB%mat([p],vj,[q],vi)) + if(kb.eq.3) tmpRB = transpose(RB%mat([q],vj,[p],vi)) + case(3) + if(kb.eq.1) tmpRB = transpose(RB%mat([p],[q],vj,vi)) + if(kb.eq.2) tmpRB = transpose(RB%mat([q],[p],vj,vi)) + end select + end select + call RC%put(Contraction(tmpRA,tmpRB),k,l,p,q) + enddo + enddo + enddo + enddo +!$OMP END PARALLEL DO + + EndFunction MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor End Module MQC_Algebra diff --git a/src/mqc_est.F03 b/src/mqc_est.F03 index 16f970d6..3f5ca4fa 100644 --- a/src/mqc_est.F03 +++ b/src/mqc_est.F03 @@ -435,6 +435,8 @@ Module MQC_EST Interface Operator (*) Module Procedure MQC_Scalar_Integral_Multiply Module Procedure MQC_Integral_Scalar_Multiply + Module Procedure MQC_Scalar_twoERIs_Multiply + Module Procedure MQC_twoERIs_Scalar_Multiply End Interface ! !> \brief Computes the element-wise product of two objects @@ -2401,12 +2403,12 @@ end subroutine mqc_twoeriset_allocate !> only unique spin blocks are stored (first given in !> equality): !> -!> spin: [aa|aa]=[bb|bb]=[aa|bb]=[bb|aa] -!> space: [aa|aa], [bb|bb], [aa|bb]=[bb|aa] +!> space: [aa|aa]=[bb|bb]=[aa|bb]=[bb|aa] +!> spin: [aa|aa], [bb|bb], [aa|bb]=[bb|aa] !> general: [aa|aa], [bb|bb], [aa|bb]=[bb|aa], -!> [abab]=[ba|ba]*, [ab|ba]=[ba|ab], -!> [aa|ab]=[ab|aa]=[aa|ba]*=[ba|aa]*, -!> [ab|bb]=[bb|ab]=[bb|ba]*=[ba|bb]* +!> [ab|ab]=[ba|ba]*, [ab|ba]=[ba|ab], +!> [aa|ab]=[ab|aa]=[aa|ba]*=[ba|aa]*, +!> [ab|bb]=[bb|ab]=[bb|ba]*=[ba|bb]* !> !> \endverbatim !> @@ -8012,6 +8014,230 @@ function mqc_integral_scalar_multiply(integral,scalarIn) result(integralOut) end select ! end function mqc_integral_scalar_multiply +! +! +! PROCEDURE MQC_twoERIs_Scalar_Multiply +! +!> \brief MQC_twoERIs_Scalar_Multiply is used to multiply an MQC scalar with +!> an MQC twoERIs type variable and returns an MQC twoERIs +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_twoERIs_Scalar_Multiply is used to multiply an MQC scalar with an MQC +!> twoERIs type variable and returns an MQC twoERIs +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] eris +!> \verbatim +!> Integral is type(mqc_twoERIs) +!> The MQC twoERIs variable to multiply. +!> \endverbatim +!> +!> \param[in] ScalarIn +!> \verbatim +!> ScalarIn class(*) +!> The variable to multiply. +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2025 +! + function mqc_twoERIs_scalar_multiply(eris,scalarIn) result(erisOut) +! + implicit none + type(mqc_twoERIs),intent(in)::eris + class(*),intent(in)::scalarIn + type(mqc_twoERIs)::erisOut + type(mqc_R4Tensor)::aaaa,bbbb,aabb,bbaa,abab,abba,baab,baba,& + aaab,aaba,abaa,baaa,bbba,bbab,babb,abbb + type(mqc_scalar)::scalar + Character(Len=64)::myLabel + + myLabel = '' + + select type(scalarIn) + type is (integer) + scalar = scalarIn + type is (real) + scalar = scalarIn + type is (complex) + scalar = scalarIn + type is (mqc_scalar) + scalar = scalarIn + class default + call mqc_error_I('scalarIn type not defined in mqc_twoERIs_scalar_multiply',6) + end select + + select case (eris%integralType) + case('space','regular','raffenetti1','raffenetti2','raffenetti3') + if(eris%hasSpinBlock('aaaa')) & + aaaa = scalar*eris%getBlock('aaaa') + call mqc_twoeris_allocate(erisOut,myLabel,'space',aaaa) + case('spin') + if(eris%hasSpinBlock('aaaa')) & + aaaa = scalar*eris%getBlock('aaaa') + if(eris%hasSpinBlock('bbbb')) & + bbbb = scalar*eris%getBlock('bbbb') + if(eris%hasSpinBlock('bbaa')) & + bbaa = scalar*eris%getBlock('bbaa') + if(eris%hasSpinBlock('aabb')) & + aabb = scalar*eris%getBlock('aabb') + call mqc_twoeris_allocate(erisOut,myLabel,'space',aaaa,bbbb,bbaa,aabb) + case('general') + if(eris%hasSpinBlock('aaaa')) & + aaaa = scalar*eris%getBlock('aaaa') + if(eris%hasSpinBlock('bbbb')) & + bbbb = scalar*eris%getBlock('bbbb') + if(eris%hasSpinBlock('bbaa')) & + bbaa = scalar*eris%getBlock('bbaa') + if(eris%hasSpinBlock('aabb')) & + aabb = scalar*eris%getBlock('aabb') + if(eris%hasSpinBlock('aaab')) & + aaab = scalar*eris%getBlock('aaab') + if(eris%hasSpinBlock('aaba')) & + aaba = scalar*eris%getBlock('aaba') + if(eris%hasSpinBlock('abaa')) & + abaa = scalar*eris%getBlock('abaa') + if(eris%hasSpinBlock('baaa')) & + baaa = scalar*eris%getBlock('baaa') + if(eris%hasSpinBlock('bbba')) & + bbba = scalar*eris%getBlock('bbba') + if(eris%hasSpinBlock('bbab')) & + bbab = scalar*eris%getBlock('bbab') + if(eris%hasSpinBlock('babb')) & + babb = scalar*eris%getBlock('babb') + if(eris%hasSpinBlock('abbb')) & + abbb = scalar*eris%getBlock('abbb') + call mqc_twoeris_allocate(erisOut,myLabel,'general',aaaa,bbbb,bbaa,aabb,& + abab,abba,baab,baba,& + aaab,aaba,abaa,baaa,& + bbba,bbab,babb,abbb) + case default + call mqc_error_A('Unknown integral type in mqc_twoeris_scalar_multiply', 6, & + 'twoeris%integralType', eris%integralType ) + end select +! + end function mqc_twoERIs_scalar_multiply +! +! +! PROCEDURE MQC_Scalar_twoERIs_Multiply +! +!> \brief MQC_Scalar_twoERIs_Multiply is used to multiply an MQC scalar with +!> an MQC twoERIs type variable and returns an MQC twoERIs +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_Scalar_twoERIs_Multiply is used to multiply an MQC scalar with an MQC +!> twoERIs type variable and returns an MQC twoERIs +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] ScalarIn +!> \verbatim +!> ScalarIn class(*) +!> The variable to multiply. +!> \endverbatim +!> +!> \param[in] eris +!> \verbatim +!> Integral is type(mqc_twoERIs) +!> The MQC twoERIs variable to multiply. +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2025 +! + function mqc_scalar_twoERIs_multiply(scalarIn,eris) result(erisOut) +! + implicit none + type(mqc_twoERIs),intent(in)::eris + class(*),intent(in)::scalarIn + type(mqc_twoERIs)::erisOut + type(mqc_R4Tensor)::aaaa,bbbb,aabb,bbaa,abab,abba,baab,baba,& + aaab,aaba,abaa,baaa,bbba,bbab,babb,abbb + type(mqc_scalar)::scalar + Character(Len=64)::myLabel + + myLabel = '' + + select type(scalarIn) + type is (integer) + scalar = scalarIn + type is (real) + scalar = scalarIn + type is (complex) + scalar = scalarIn + type is (mqc_scalar) + scalar = scalarIn + class default + call mqc_error_I('scalarIn type not defined in mqc_scalar_twoERIs_multiply',6) + end select + + select case (eris%integralType) + case('space','regular','raffenetti1','raffenetti2','raffenetti3') + if(eris%hasSpinBlock('aaaa')) & + aaaa = scalar*eris%getBlock('aaaa') + call mqc_twoeris_allocate(erisOut,myLabel,'space',aaaa) + case('spin') + if(eris%hasSpinBlock('aaaa')) & + aaaa = scalar*eris%getBlock('aaaa') + if(eris%hasSpinBlock('bbbb')) & + bbbb = scalar*eris%getBlock('bbbb') + if(eris%hasSpinBlock('bbaa')) & + bbaa = scalar*eris%getBlock('bbaa') + if(eris%hasSpinBlock('aabb')) & + aabb = scalar*eris%getBlock('aabb') + call mqc_twoeris_allocate(erisOut,myLabel,'space',aaaa,bbbb,bbaa,aabb) + case('general') + if(eris%hasSpinBlock('aaaa')) & + aaaa = scalar*eris%getBlock('aaaa') + if(eris%hasSpinBlock('bbbb')) & + bbbb = scalar*eris%getBlock('bbbb') + if(eris%hasSpinBlock('bbaa')) & + bbaa = scalar*eris%getBlock('bbaa') + if(eris%hasSpinBlock('aabb')) & + aabb = scalar*eris%getBlock('aabb') + if(eris%hasSpinBlock('aaab')) & + aaab = scalar*eris%getBlock('aaab') + if(eris%hasSpinBlock('aaba')) & + aaba = scalar*eris%getBlock('aaba') + if(eris%hasSpinBlock('abaa')) & + abaa = scalar*eris%getBlock('abaa') + if(eris%hasSpinBlock('baaa')) & + baaa = scalar*eris%getBlock('baaa') + if(eris%hasSpinBlock('bbba')) & + bbba = scalar*eris%getBlock('bbba') + if(eris%hasSpinBlock('bbab')) & + bbab = scalar*eris%getBlock('bbab') + if(eris%hasSpinBlock('babb')) & + babb = scalar*eris%getBlock('babb') + if(eris%hasSpinBlock('abbb')) & + abbb = scalar*eris%getBlock('abbb') + call mqc_twoeris_allocate(erisOut,myLabel,'general',aaaa,bbbb,bbaa,aabb,& + abab,abba,baab,baba,& + aaab,aaba,abaa,baaa,& + bbba,bbab,babb,abbb) + case default + call mqc_error_A('Unknown integral type in mqc_scalar_twoeris_multiply', 6, & + 'twoeris%integralType', eris%integralType ) + end select +! + end function mqc_scalar_twoERIs_multiply ! ! PROCEDURE MQC_Element_Integral_Multiply @@ -10861,7 +11087,7 @@ end function mqc_eri_eri_contraction ! PROCEDURE MQC_ERI_ERI_Partial_Contraction ! !> \brief MQC_ERI_ERI_Contraction is used to return the contraction of -!> two-ERIs with an MQC rank-4 tensor +!> two-ERIs with an MQC two-ERIs ! !> \par Purpose: ! ============= @@ -11022,7 +11248,7 @@ function mqc_eri_eri_partial_contraction(eris1,eris2,index1,index2) result(IntOu str1=mqc_index_to_string([ia,ja,ka,la],active_conf) str2=mqc_index_to_string([ib,jb,kb,lb],active_conf) if(str1.eq.'aabb'.or.str1.eq.'bbaa') then - if(str2.eq.'aabb'.or.str1.eq.'bbaa') then + if(str2.eq.'aabb'.or.str2.eq.'bbaa') then if (active_conf(3:4).eq.'aa') then aa = aa + MQC_R4Tensor_R4Tensor_Partial_Contraction(& eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) @@ -11082,7 +11308,7 @@ function mqc_eri_eri_partial_contraction(eris1,eris2,index1,index2) result(IntOu str1=mqc_index_to_string([ia,ja,ka,la],active_conf) str2=mqc_index_to_string([ib,jb,kb,lb],active_conf) if(str1.eq.'aabb'.or.str1.eq.'bbaa') then - if(str2.eq.'aabb'.or.str1.eq.'bbaa') then + if(str2.eq.'aabb'.or.str2.eq.'bbaa') then if (active_conf(3:4).eq.'aa') then aa = aa + MQC_R4Tensor_R4Tensor_Partial_Contraction(& eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) @@ -11243,6 +11469,549 @@ function mqc_eri_eri_partial_contraction(eris1,eris2,index1,index2) result(IntOu end function mqc_eri_eri_partial_contraction ! ! +! PROCEDURE MQC_ERI_ERI_Partial_Contraction_2ERI +! +!> \brief MQC_ERI_ERI_Contraction_2ERI is used to return the contraction of +!> a two-ERIs with an MQC two-ERIs in a two-ERIs form +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_ERI_ERI_Contraction_2ERI is used to return the contraction of two-ERIs with +!> an MQC two-ERIs in a two-ERIs form. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] ERIs1 +!> \verbatim +!> ERIs1 is type(mqc_twoERIs) +!> The first 2ERIs to be contracted. +!> \endverbatim +!> +!> \param[in] ERIs2 +!> \verbatim +!> ERIs2 is type(mqc_twoERIs) +!> The second 2ERIs to be contracted. +!> \endverbatim +!> +!> \param[in] Index1 +!> \verbatim +!> Index1 is integer(kind=int64),dimension(4),optional +!> Contain the indexes of ERIs1 to be contracted. +!> The two first integers in the object are the ones to be contracted, +!> while the two last are the two first indexes of the final ERIs. +!> Ex: If Index1=[3,2,4,1], the third and second indexes of ERIs1 are contracted. +!> The fourth and first form the first and second indices +!> of the result ERIs, respectivelly. +!> \endverbatim +!> +!> \param[in] Index2 +!> \verbatim +!> Index2 is Integer(kind=int64),dimension(4),optional +!> Contain the indexes of ERIs2 to be contracted. +!> The two first integers in the object are the ones to be contracted, +!> while the two last are the final indexes of the final ERIs. +!> +!> Ex: index1=[3,2,4,1] and index2=[2,1,4,3] +!> sum_{i,j} ERIs1_{ljik} ERIs2_{jipq} = IntOut_{klqp} +!> +!> \endverbatim +!> +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2025 +! + function mqc_eri_eri_partial_contraction_2eri(eris1,eris2,index1,index2) result(eriOut) +! + implicit none + type(mqc_twoERIs),intent(in)::eris1,eris2 + integer(kind=int64),dimension(4),intent(in),optional::index1,index2 + type(mqc_twoERIs)::eriOut + + type(MQC_R4Tensor)::aaaa,aaab,aaba,abaa,baaa,aabb,abab,baab,abba,baba,bbaa,& + abbb,babb,bbab,bbba,bbbb + type(MQC_R4Tensor)::tmp_aaaa,tmp_bbbb + character(len=64)::mylabel,eriType + integer(kind=int64)::r4t1,r4t2,r4t3,r4t4,nB1,nB2,nB3,nB4 + type(mqc_twoERIs)::temp + Integer(kind=int64)::ia,ja,ka,la,ib,jb,kb,lb,i,j,k,l + Integer(kind=int64)::dimAi,dimAj,dimAk,dimAl,dimBi,dimBj,dimBk,dimBl + character(len=4)::str1,str2,active_conf_1,active_conf_2,active_conf + character(len=4),dimension(4)::allowed_spin,a_bbb_array,aaa_b_array + character(len=4),dimension(6)::aa_bb_array + character(len=4),dimension(16)::full_array + + full_array =['aaaa','bbbb','aabb','abab','abba','baab','baba','bbaa',& + 'abbb','babb','bbab','bbba','baaa','abaa','aaba','aaab'] + aa_bb_array=['aabb','abab','abba','baab','baba','bbaa'] + a_bbb_array=['abbb','babb','bbab','bbba'] + aaa_b_array=['baaa','abaa','aaba','aaab'] + +! + if(present(index1)) then + ia=index1(1) + ja=index1(2) + ka=index1(3) + la=index1(4) + if (ia.eq.ja) Call MQC_Error_I('Duplicated index in MQC_ERI_ERI_Contraction_2eri',& + 6,'ia', ia,'ja',ja) + if (ia.eq.ka) Call MQC_Error_I('Duplicated index in MQC_ERI_ERI_Contraction_2eri',& + 6,'ia', ia,'ka',ka) + if (ia.eq.la) Call MQC_Error_I('Duplicated index in MQC_ERI_ERI_Contraction_2eri',& + 6,'ia', ia,'la',la) + if (ja.eq.ka) Call MQC_Error_I('Duplicated index in MQC_ERI_ERI_Contraction_2eri',& + 6,'ja', ja,'ka',ka) + if (ja.eq.la) Call MQC_Error_I('Duplicated index in MQC_ERI_ERI_Contraction_2eri',& + 6,'ja', ja,'la',la) + if (ka.eq.la) Call MQC_Error_I('Duplicated index in MQC_ERI_ERI_Contraction_2eri',& + 6,'ka', ka,'la',la) + else + ia=1 + ja=2 + ka=3 + la=4 + endif + if(present(index2)) then + ib=index2(1) + jb=index2(2) + kb=index2(3) + lb=index2(4) + if (ib.eq.jb) Call MQC_Error_I('Duplicated index in MQC_ERI_ERI_Partial_Contraction_2eri',& + 6,'ib', ib,'jb',jb) + if (ib.eq.kb) Call MQC_Error_I('Duplicated index in MQC_ERI_ERI_Partial_Contraction_2eri',& + 6,'ib', ib,'kb',kb) + if (ib.eq.lb) Call MQC_Error_I('Duplicated index in MQC_ERI_ERI_Partial_Contraction_2eri',& + 6,'ib', ib,'lb',lb) + if (jb.eq.kb) Call MQC_Error_I('Duplicated index in MQC_ERI_ERI_Partial_Contraction_2eri',& + 6,'jb', jb,'kb',kb) + if (jb.eq.lb) Call MQC_Error_I('Duplicated index in MQC_ERI_ERI_Partial_Contraction_2eri',& + 6,'jb', jb,'lb',lb) + if (kb.eq.lb) Call MQC_Error_I('Duplicated index in MQC_ERI_ERI_Partial_Contraction_2eri',& + 6,'kb', kb,'lb',lb) + else + ib=1 + jb=2 + kb=3 + lb=4 + endif + if (ia.gt.4.or.ia.le.0.or.ib.gt.4.or.ib.le.0.or.& + ja.gt.4.or.ja.le.0.or.jb.gt.4.or.jb.le.0.or.& + ka.gt.4.or.ka.le.0.or.kb.gt.4.or.kb.le.0.or.& + la.gt.4.or.la.le.0.or.lb.gt.4.or.lb.le.0.) Call MQC_Error(& + 'Index out of range in MQC_ERI_ERI_Partial_Contraction_2eri', 6) + + if (eris1%blockSize('alpha',ia).ne.eris2%blockSize('alpha',ib).or.& + eris1%blockSize('alpha',ja).ne.eris2%blockSize('alpha',jb))& + call mqc_error_i('2ERIs not correctly dimensioned in mqc_eri_eri_contraction_2eri',6,& + 'dim1',eris1%blockSize('alpha',ia),'dim2',eris2%blockSize('alpha',ib),& + 'dim3',eris1%blockSize('alpha',ja),'dim4',eris2%blockSize('alpha',jb)) + + call aaaa%init(eris1%blockSize('alpha',ka),eris1%blockSize('alpha',la),& + eris2%blockSize('alpha',kb),eris2%blockSize('alpha',lb)) + call bbbb%init(eris1%blockSize('beta',ka),eris1%blockSize('beta',la),& + eris2%blockSize('beta',kb),eris2%blockSize('beta',lb)) + call aabb%init(eris1%blockSize('alpha',ka),eris1%blockSize('alpha',la),& + eris2%blockSize('beta',kb),eris2%blockSize('beta',lb)) + call bbaa%init(eris1%blockSize('beta',ka),eris1%blockSize('beta',la),& + eris2%blockSize('alpha',kb),eris2%blockSize('alpha',lb)) + call abab%init(eris1%blockSize('alpha',ka),eris1%blockSize('beta',la),& + eris2%blockSize('alpha',kb),eris2%blockSize('beta',lb)) + call abba%init(eris1%blockSize('alpha',ka),eris1%blockSize('beta',la),& + eris2%blockSize('beta',kb),eris2%blockSize('alpha',lb)) + call baab%init(eris1%blockSize('beta',ka),eris1%blockSize('alpha',la),& + eris2%blockSize('alpha',kb),eris2%blockSize('beta',lb)) + call baba%init(eris1%blockSize('beta',ka),eris1%blockSize('alpha',la),& + eris2%blockSize('beta',kb),eris2%blockSize('alpha',lb)) + call abbb%init(eris1%blockSize('alpha',ka),eris1%blockSize('beta',la),& + eris2%blockSize('beta',kb),eris2%blockSize('beta',lb)) + call babb%init(eris1%blockSize('beta',ka),eris1%blockSize('alpha',la),& + eris2%blockSize('beta',kb),eris2%blockSize('beta',lb)) + call bbab%init(eris1%blockSize('beta',ka),eris1%blockSize('beta',la),& + eris2%blockSize('alpha',kb),eris2%blockSize('beta',lb)) + call bbba%init(eris1%blockSize('beta',ka),eris1%blockSize('beta',la),& + eris2%blockSize('beta',kb),eris2%blockSize('alpha',lb)) + + eriType='spin' + do i=1,16 + active_conf_1=full_array(i) + str1=mqc_index_to_string([ia,ja,ka,la],active_conf_1) + do j=1,16 + active_conf_2=full_array(j) + active_conf=trim(active_conf_1(3:4))//trim(active_conf_2(3:4)) + str2=mqc_index_to_string([ib,jb,kb,lb],active_conf_2) + select case (active_conf) + case('aaaa') + aaaa = aaaa + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + case('bbbb') + bbbb = bbbb + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + case('aabb') + aabb = aabb + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + case('abab') + eriType='general' + abab = abab + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + case('abba') + eriType='general' + abba = abba + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + case('baab') + eriType='general' + baab = baab + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + case('baba') + eriType='general' + baba = baba + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + case('bbaa') + bbaa = bbaa + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + case('abbb') + eriType='general' + abbb = abbb + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + case('babb') + eriType='general' + babb = babb + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + case('bbab') + eriType='general' + bbab = bbab + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + case('bbba') + eriType='general' + bbba = bbba + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + end select + enddo + enddo + + !!!! TODO: Use the space symmetry + ! aaaa = MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + ! eris1%getBlock('aaaa'),eris2%getBlock('aaaa'),index1,index2) + ! select case (eris1%type()) + ! case ('space','regular') + ! select case (eris2%type()) + ! case ('space','regular') + ! eriType='space' + ! case ('spin') + ! eriType='spin' + ! bbbb = MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + ! eris1%getBlock('aaaa'),eris2%getBlock('bbbb'),index1,index2) + ! tmp_aaaa = aaaa + ! tmp_bbbb = bbbb + ! do i=1,6 + ! active_conf_1=aa_bb_array(i) + ! str1=mqc_index_to_string([ia,ja,ka,la],active_conf_1) + ! if(str1.eq.'aabb'.or.str1.eq.'bbaa') then + ! if (active_conf_1(3:4).eq.'aa') then + ! aabb = aabb + tmp_bbbb + ! else if (active_conf_1(3:4).eq.'bb') then + ! bbaa = bbaa + tmp_aaaa + ! end if + ! do j=1,6 + ! active_conf_2=aa_bb_array(j) + ! active_conf=trim(active_conf_1(3:4))//trim(active_conf_2(3:4)) + ! str2=mqc_index_to_string([ib,jb,kb,lb],active_conf_2) + ! if(str2.eq.'aabb'.or.str2.eq.'bbaa') then + ! if(i.eq.1.and.active_conf_2(3:4).eq.'aa') then + ! bbaa = bbaa + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + ! eris1%getBlock('aaaa'),eris2%getBlock(str2),index1,index2) + ! else if (i.eq.1.and.active_conf_2(3:4).eq.'bb') then + ! aabb = aabb + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + ! eris1%getBlock('aaaa'),eris2%getBlock(str2),index1,index2) + ! end if + + ! select case (active_conf) + ! case('aaaa') then + ! aaaa = aaaa + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + ! case('bbbb') then + ! bbbb = bbbb + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + ! case('aabb') then + ! aabb = aabb + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + ! case('abab') then + ! eriType='general' + ! abab = abab + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + ! case('abba') then + ! eriType='general' + ! abba = abba + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + ! case('baab') then + ! eriType='general' + ! baab = baab + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + ! case('baba') then + ! eriType='general' + ! baba = baba + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + ! case('bbaa') then + ! bbaa = bbaa + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + ! end select + ! end if + ! end do + ! end if + ! end do + ! case ('general') + ! eriType='spin' + ! bbbb = MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + ! eris1%getBlock('aaaa'),eris2%getBlock('bbbb'),index1,index2) + ! tmp_aaaa = aaaa + ! tmp_bbbb = bbbb + ! do i=1,6 + ! active_conf_1=aa_bb_array(i) + ! str1=mqc_index_to_string([ia,ja,ka,la],active_conf_1) + ! if(str1.eq.'aabb'.or.str1.eq.'bbaa') then + ! if (active_conf_1(3:4).eq.'aa') then + ! aabb = aabb + tmp_bbbb + ! else if (active_conf_1(3:4).eq.'bb') then + ! bbaa = bbaa + tmp_aaaa + ! end if + ! do j=1,6 + ! active_conf_2=aa_bb_array(j) + ! active_conf=trim(active_conf_1(3:4))//trim(active_conf_2(3:4)) + ! str2=mqc_index_to_string([ib,jb,kb,lb],active_conf_2) + ! if(str2.eq.'aabb'.or.str2.eq.'bbaa') then + ! if(i.eq.1.and.active_conf_2(3:4).eq.'aa') then + ! bbaa = bbaa + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + ! eris1%getBlock('aaaa'),eris2%getBlock(str2),index1,index2) + ! else if (i.eq.1.and.active_conf_2(3:4).eq.'bb') then + ! aabb = aabb + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + ! eris1%getBlock('aaaa'),eris2%getBlock(str2),index1,index2) + ! end if + + ! select case (active_conf) + ! case('aaaa') then + ! aaaa = aaaa + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + ! case('bbbb') then + ! bbbb = bbbb + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + ! case('aabb') then + ! aabb = aabb + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + ! case('abab') then + ! eriType='general' + ! abab = abab + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + ! case('abba') then + ! eriType='general' + ! abba = abba + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + ! case('baab') then + ! eriType='general' + ! baab = baab + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + ! case('baba') then + ! eriType='general' + ! baba = baba + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + ! case('bbaa') then + ! bbaa = bbaa + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + ! end select + ! end if + ! end do + ! do j=1,4 + ! active_conf_2=a_bbb_array(i) + ! active_conf=trim(active_conf_1(3:4))//trim(active_conf_2(3:4)) + ! str2=mqc_index_to_string([ib,jb,kb,lb],active_conf_2) + ! if(str2(1:2).eq.'aa'.or.str2(1:2).eq.'bb') then + ! + ! end if + ! end do + ! end if + ! end do + ! case default + ! call mqc_error_a('Unrecognized 2ERI integral type',6,& + ! 'eris2%type',eris2%type()) + ! end select + ! case ('spin') + ! select case (eris2%type()) + ! case ('space','regular','spin') + ! intType='spin' + ! bb = bb + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock('bbbb'),eris2%getBlock('bbbb'),index1,index2) + ! do i=1,6 + ! active_conf=aa_bb_array(i) + ! str1=mqc_index_to_string([ia,ja,ka,la],active_conf) + ! str2=mqc_index_to_string([ib,jb,kb,lb],active_conf) + ! if(str1.eq.'aabb'.or.str1.eq.'bbaa') then + ! if(str2.eq.'aabb'.or.str1.eq.'bbaa') then + ! if (active_conf(3:4).eq.'aa') then + ! aa = aa + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + ! else if (active_conf(3:4).eq.'bb') then + ! bb = bb + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + ! else if (active_conf(3:4).eq.'ab') then + ! intType='general' + ! ab = ab + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + ! else if (active_conf(3:4).eq.'ba') then + ! intType='general' + ! ba = ba + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + ! end if + ! end if + ! end if + ! end do + ! case ('general') + ! intType='spin' + ! bb = bb + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock('bbbb'),eris2%getBlock('bbbb'),index1,index2) + ! do i=1,6 + ! active_conf=aa_bb_array(i) + ! str1=mqc_index_to_string([ia,ja,ka,la],active_conf) + ! str2=mqc_index_to_string([ib,jb,kb,lb],active_conf) + ! if(str1.eq.'aabb'.or.str1.eq.'bbaa') then + ! if (active_conf(3:4).eq.'aa') then + ! aa = aa + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + ! else if (active_conf(3:4).eq.'bb') then + ! bb = bb + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + ! else if (active_conf(3:4).eq.'ab') then + ! intType='general' + ! ab = ab + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + ! else if (active_conf(3:4).eq.'ba') then + ! intType='general' + ! ba = ba + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + ! end if + ! end if + ! end do + ! case default + ! call mqc_error_a('Unrecognized 2ERI integral type',6,& + ! 'eris2%type',eris2%type()) + ! end select + ! case ('general') + ! select case (eris2%type()) + ! case ('space','regular','spin') + ! intType='spin' + ! bb = bb + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock('bbbb'),eris2%getBlock('bbbb'),index1,index2) + ! do i=1,6 + ! active_conf=aa_bb_array(i) + ! str1=mqc_index_to_string([ia,ja,ka,la],active_conf) + ! str2=mqc_index_to_string([ib,jb,kb,lb],active_conf) + ! if(str2.eq.'aabb'.or.str2.eq.'bbaa') then + ! if (active_conf(3:4).eq.'aa') then + ! aa = aa + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + ! else if (active_conf(3:4).eq.'bb') then + ! bb = bb + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + ! else if (active_conf(3:4).eq.'ab') then + ! intType='general' + ! ab = ab + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + ! else if (active_conf(3:4).eq.'ba') then + ! intType='general' + ! ba = ba + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + ! end if + ! end if + ! end do + ! case ('general') + ! intType='spin' + ! bb = bb + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock('bbbb'),eris2%getBlock('bbbb'),index1,index2) + ! do i=1,6 + ! active_conf=aa_bb_array(i) + ! str1=mqc_index_to_string([ia,ja,ka,la],active_conf) + ! str2=mqc_index_to_string([ib,jb,kb,lb],active_conf) + ! if (active_conf(3:4).eq.'aa') then + ! aa = aa + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + ! else if (active_conf(3:4).eq.'bb') then + ! bb = bb + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + ! else if (active_conf(3:4).eq.'ab') then + ! intType='general' + ! ab = ab + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + ! else if (active_conf(3:4).eq.'ba') then + ! intType='general' + ! ba = ba + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + ! end if + ! end do + ! do i=1,4 + ! active_conf=a_bbb_array(i) + ! str1=mqc_index_to_string([ia,ja,ka,la],active_conf) + ! str2=mqc_index_to_string([ib,jb,kb,lb],active_conf) + ! if (active_conf(3:4) == 'aa') then + ! aa = aa + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + ! else if (active_conf(3:4) == 'bb') then + ! bb = bb + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + ! else if (active_conf(3:4) == 'ab') then + ! intType='general' + ! ab = ab + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + ! else if (active_conf(3:4) == 'ba') then + ! intType='general' + ! ba = ba + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + ! end if + ! end do + ! do i=1,4 + ! active_conf=aaa_b_array(i) + ! str1=mqc_index_to_string([ia,ja,ka,la],active_conf) + ! str2=mqc_index_to_string([ib,jb,kb,lb],active_conf) + ! if (active_conf(3:4) == 'aa') then + ! aa = aa + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + ! else if (active_conf(3:4) == 'bb') then + ! bb = bb + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + ! else if (active_conf(3:4) == 'ab') then + ! intType='general' + ! ab = ab + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + ! else |if (active_conf(3:4) == 'ba') then + ! intType='general' + ! ba = ba + MQC_R4Tensor_R4Tensor_Partial_Contraction(& + ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + ! end if + ! end do + ! case default + ! call mqc_error_a('Unrecognized 2ERI integral type',6,& + ! 'eris2%type',eris2%type()) + ! end select + ! case default + ! call mqc_error_a('Unrecognized 2ERI integral type',6,& + ! 'eris1%type',eris1%type()) + ! end select + if (eriType.eq.'space') then + call mqc_twoeris_allocate(eriOut,'full','space',aaaa) + elseif (eriType.eq.'spin') then + call mqc_twoeris_allocate(eriOut,'full','spin',aaaa,bbbb,aabb,bbaa) + elseif (eriType.eq.'general') then + call mqc_twoeris_allocate(eriOut,'full','general',aaaa,bbbb,aabb,bbaa,& + abab,abba,baab,baba,aaab,aaba,abaa,baaa,bbba,& + bbab,babb,abbb) + endif + +! + end function mqc_eri_eri_partial_contraction_2eri +! +! ! PROCEDURE MQC_Index_to_String ! !> \brief MQC_Index_to_String is a support function to From fbeedc40195bba4622638d3281a5ba4581ea7cdb Mon Sep 17 00:00:00 2001 From: Matheus Moraes Date: Wed, 18 Jun 2025 15:48:46 -0400 Subject: [PATCH 02/37] MQC_TwoERIs_print avoids non allocated R4Tensors --- src/mqc_est.F03 | 63 ++++++++++++++++++++++++++++++------------------- 1 file changed, 39 insertions(+), 24 deletions(-) diff --git a/src/mqc_est.F03 b/src/mqc_est.F03 index 3f5ca4fa..bf6a3242 100644 --- a/src/mqc_est.F03 +++ b/src/mqc_est.F03 @@ -967,39 +967,54 @@ subroutine mqc_print_twoERIs(twoERIs,iOut,header, & call string_change_case(twoERIs%integraltype,'L') if(twoERIs%integralType.eq.'regular') then - call twoERIs%alpha%print(iout,'Regular 2ERIs') + if(twoERIs%hasSpinBlock('aaaa')) & + call twoERIs%alpha%print(iout,'Regular 2ERIs') elseIf(twoERIs%integralType.eq.'raffenetti1') then - call twoERIs%alpha%print(iout,'Raffenetti 1 2ERIs') + if(twoERIs%hasSpinBlock('aaaa')) & + call twoERIs%alpha%print(iout,'Raffenetti 1 2ERIs') elseIf(twoERIs%integralType.eq.'raffenetti2') then - call twoERIs%alpha%print(iout,'Raffenetti 2 2ERIs') + if(twoERIs%hasSpinBlock('aaaa')) & + call twoERIs%alpha%print(iout,'Raffenetti 2 2ERIs') elseIf(twoERIs%integralType.eq.'raffenetti3') then - call twoERIs%alpha%print(iout,'Raffenetti 3 2ERIs') + if(twoERIs%hasSpinBlock('aaaa')) & + call twoERIs%alpha%print(iout,'Raffenetti 3 2ERIs') elseIf(twoERIs%integralType.eq.'space') then - call twoERIs%alpha%print(iout,'Restricted MO 2ERIs') + if(twoERIs%hasSpinBlock('aaaa')) & + call twoERIs%alpha%print(iout,'Restricted MO 2ERIs') elseIf(twoERIs%integralType.eq.'spin') then write(iout,'(A)') 'Unrestricted MO 2ERIs' - call twoERIs%alpha%print(iout,'(aa|aa)') - call twoERIs%beta%print(iout,'(bb|bb)') - call twoERIs%alphaBeta%print(iout,'(aa|bb)') - if(twoERIs%storageType.eq.'full') call twoERIs%betaAlpha%print(iout,'(bb|aa)') + if(twoERIs%hasSpinBlock('aaaa')) & + call twoERIs%alpha%print(iout,'(aa|aa)') + if(twoERIs%hasSpinBlock('bbbb')) & + call twoERIs%beta%print(iout,'(bb|bb)') + if(twoERIs%hasSpinBlock('aabb')) & + call twoERIs%alphaBeta%print(iout,'(aa|bb)') + if(twoERIs%storageType.eq.'full'.and.twoERIs%hasSpinBlock('bbaa')) call twoERIs%betaAlpha%print(iout,'(bb|aa)') elseIf(twoERIs%integralType.eq.'general') then write(iout,'(A)') 'General MO 2ERIs' - call twoERIs%alpha%print(iout,'(aa|aa)') - call twoERIs%beta%print(iout,'(bb|bb)') - call twoERIs%alphaBeta%print(iout,'(aa|bb)') - if(twoERIs%storageType.eq.'full') call twoERIs%betaAlpha%print(iout,'(bb|aa)') - call twoERIs%abab%print(iout,'(ab|ab)') - call twoERIs%abba%print(iout,'(ab|ba)') - if(twoERIs%storageType.eq.'full') call twoERIs%baab%print(iout,'(ba|ab)') - if(twoERIs%storageType.eq.'full') call twoERIs%baba%print(iout,'(ba|ba)') - call twoERIs%aaab%print(iout,'(aa|ab)') - if(twoERIs%storageType.eq.'full') call twoERIs%aaba%print(iout,'(aa|ba)') - if(twoERIs%storageType.eq.'full') call twoERIs%abaa%print(iout,'(ab|aa)') - if(twoERIs%storageType.eq.'full') call twoERIs%baaa%print(iout,'(ba|aa)') - if(twoERIs%storageType.eq.'full') call twoERIs%bbba%print(iout,'(bb|ba)') - if(twoERIs%storageType.eq.'full') call twoERIs%bbab%print(iout,'(bb|ab)') + if(twoERIs%hasSpinBlock('aaaa')) & + call twoERIs%alpha%print(iout,'(aa|aa)') + if(twoERIs%hasSpinBlock('bbbb')) & + call twoERIs%beta%print(iout,'(bb|bb)') + if(twoERIs%hasSpinBlock('aabb')) & + call twoERIs%alphaBeta%print(iout,'(aa|bb)') + if(twoERIs%storageType.eq.'full'.and.twoERIs%hasSpinBlock('bbaa')) call twoERIs%betaAlpha%print(iout,'(bb|aa)') + if(twoERIs%hasSpinBlock('abab')) & + call twoERIs%abab%print(iout,'(ab|ab)') + if(twoERIs%hasSpinBlock('abba')) & + call twoERIs%abba%print(iout,'(ab|ba)') + if(twoERIs%storageType.eq.'full'.and.twoERIs%hasSpinBlock('baab')) call twoERIs%baab%print(iout,'(ba|ab)') + if(twoERIs%storageType.eq.'full'.and.twoERIs%hasSpinBlock('abba')) call twoERIs%baba%print(iout,'(ba|ba)') + if(twoERIs%hasSpinBlock('aaab')) & + call twoERIs%aaab%print(iout,'(aa|ab)') + if(twoERIs%storageType.eq.'full'.and.twoERIs%hasSpinBlock('aaba')) call twoERIs%aaba%print(iout,'(aa|ba)') + if(twoERIs%storageType.eq.'full'.and.twoERIs%hasSpinBlock('abaa')) call twoERIs%abaa%print(iout,'(ab|aa)') + if(twoERIs%storageType.eq.'full'.and.twoERIs%hasSpinBlock('bbba')) call twoERIs%baaa%print(iout,'(ba|aa)') + if(twoERIs%storageType.eq.'full'.and.twoERIs%hasSpinBlock('bbab')) call twoERIs%bbba%print(iout,'(bb|ba)') + if(twoERIs%storageType.eq.'full'.and.twoERIs%hasSpinBlock('babb')) call twoERIs%bbab%print(iout,'(bb|ab)') if(twoERIs%storageType.eq.'full') call twoERIs%babb%print(iout,'(ba|bb)') - call twoERIs%abbb%print(iout,'(ab|bb)') + if(twoERIs%hasSpinBlock('abbb')) & + call twoERIs%abbb%print(iout,'(ab|bb)') else call mqc_error_A('Integral type unrecogised in mqc_print_twoERIs', 6, & 'twoERIs%integralType', twoERIs%integralType ) From 6fa09d0691032735a9e90a56252d9e2b7d306f51 Mon Sep 17 00:00:00 2001 From: Matheus Moraes Date: Wed, 18 Jun 2025 16:58:20 -0400 Subject: [PATCH 03/37] Small bugfix twoERIs*scalar --- src/mqc_est.F03 | 25 +++++++++++++++++++++++-- 1 file changed, 23 insertions(+), 2 deletions(-) diff --git a/src/mqc_est.F03 b/src/mqc_est.F03 index bf6a3242..66b4d114 100644 --- a/src/mqc_est.F03 +++ b/src/mqc_est.F03 @@ -8076,7 +8076,7 @@ function mqc_twoERIs_scalar_multiply(eris,scalarIn) result(erisOut) type(mqc_scalar)::scalar Character(Len=64)::myLabel - myLabel = '' + myLabel = 'full' select type(scalarIn) type is (integer) @@ -8115,6 +8115,18 @@ function mqc_twoERIs_scalar_multiply(eris,scalarIn) result(erisOut) bbaa = scalar*eris%getBlock('bbaa') if(eris%hasSpinBlock('aabb')) & aabb = scalar*eris%getBlock('aabb') + if(eris%hasSpinBlock('baba')) & + baba = scalar*eris%getBlock('baba') + if(eris%hasSpinBlock('baab')) & + baab = scalar*eris%getBlock('baab') + if(eris%hasSpinBlock('abba')) & + abba = scalar*eris%getBlock('abba') + if(eris%hasSpinBlock('abab')) & + abab = scalar*eris%getBlock('abab') + if(eris%hasSpinBlock('aabb')) & + aabb = scalar*eris%getBlock('aabb') + if(eris%hasSpinBlock('aabb')) & + aabb = scalar*eris%getBlock('aabb') if(eris%hasSpinBlock('aaab')) & aaab = scalar*eris%getBlock('aaab') if(eris%hasSpinBlock('aaba')) & @@ -8188,7 +8200,7 @@ function mqc_scalar_twoERIs_multiply(scalarIn,eris) result(erisOut) type(mqc_scalar)::scalar Character(Len=64)::myLabel - myLabel = '' + myLabel = 'full' select type(scalarIn) type is (integer) @@ -8227,6 +8239,15 @@ function mqc_scalar_twoERIs_multiply(scalarIn,eris) result(erisOut) bbaa = scalar*eris%getBlock('bbaa') if(eris%hasSpinBlock('aabb')) & aabb = scalar*eris%getBlock('aabb') + aabb = scalar*eris%getBlock('aabb') + if(eris%hasSpinBlock('baba')) & + baba = scalar*eris%getBlock('baba') + if(eris%hasSpinBlock('baab')) & + baab = scalar*eris%getBlock('baab') + if(eris%hasSpinBlock('abba')) & + abba = scalar*eris%getBlock('abba') + if(eris%hasSpinBlock('abab')) & + abab = scalar*eris%getBlock('abab') if(eris%hasSpinBlock('aaab')) & aaab = scalar*eris%getBlock('aaab') if(eris%hasSpinBlock('aaba')) & From fe46740e2a24a8a2ea97afcecb3506720d5688ca Mon Sep 17 00:00:00 2001 From: Matheus Moraes Date: Thu, 26 Jun 2025 10:23:18 -0400 Subject: [PATCH 04/37] Updates from day Matheus was out the office --- src/mqc_algebra.F03 | 79 ++++++++++++++++++++++++++-------- src/mqc_est.F03 | 101 +++++++++++++++++++++++++++----------------- 2 files changed, 125 insertions(+), 55 deletions(-) diff --git a/src/mqc_algebra.F03 b/src/mqc_algebra.F03 index 4a049da5..f4e3d741 100644 --- a/src/mqc_algebra.F03 +++ b/src/mqc_algebra.F03 @@ -29063,20 +29063,29 @@ End Subroutine MQC_R4Tensor_Put_Int !> = .True.: print blank line below output !> = .False.: do not print blank line below output. !> \endverbatim +!> +!> \param[in] Short_Print_Threshold +!> \verbatim +!> Short_Print_Threshold is Real,Optional +!> if present: print only elements with absolute value larger than Short_Print_Threshold +!> \endverbatim ! ! Authors: ! ======== -!> \author L. M. Thompson -!> \date 2016 +!> \author L. M. Thompson, M. M. F. Moraes +!> \date 2016, 2025 ! - Subroutine MQC_Print_R4Tensor_Algebra1(Tensor,IOut,Header,blank_at_top,blank_at_bottom) + Subroutine MQC_Print_R4Tensor_Algebra1(Tensor,IOut,Header,blank_at_top,blank_at_bottom,short_print_threshold) ! Implicit None Integer(kind=int64),Intent(In)::IOut Class(MQC_R4Tensor),Intent(In)::Tensor Integer(kind=int64)::I,J,K,L Character(Len=*),intent(in),optional::Header + Real(kind=real64),intent(in),optional::short_print_threshold Logical,Optional::blank_at_top,blank_at_bottom + Logical::short_print + Real(kind=real64)::print_threshold 1000 Format(1x,A) 1020 Format( " " ) @@ -29087,19 +29096,43 @@ Subroutine MQC_Print_R4Tensor_Algebra1(Tensor,IOut,Header,blank_at_top,blank_at_ If(Present(blank_at_top)) then If(blank_at_top) Write(IOut,1020) EndIf + If(Present(short_print_threshold)) then + print_threshold = short_print_threshold + if (print_threshold.lt.0) then + short_print = .false. + else + short_print = .true. + end if + else + print_threshold = -1.0 + short_print = .false. + EndIf If(Present(Header)) Write(IOut,1000) Trim(Header) If(MQC_R4Tensor_HaveFull(Tensor)) then Do I = 1, Tensor%I Do J = 1, Tensor%J Do K = 1, Tensor%K Do l = 1, Tensor%L - If(Tensor%Data_Type.eq.'Integer') then - Write(IOut,1100) I,J,K,L,Tensor%ITen(I,J,K,L) - ElseIf(Tensor%Data_Type.eq.'Real') then - Write(IOut,1200) I,J,K,L,Tensor%RTen(I,J,K,L) - ElseIf(Tensor%Data_Type.eq.'Complex') then - Write(IOut,1300) I,J,K,L,Tensor%CTen(I,J,K,L) - EndIf + If(short_print) then + If(Tensor%Data_Type.eq.'Integer') then + If(abs(Tensor%ITen(I,J,K,L)).gt.print_threshold) & + Write(IOut,1100) I,J,K,L,Tensor%ITen(I,J,K,L) + ElseIf(Tensor%Data_Type.eq.'Real') then + If(abs(Tensor%RTen(I,J,K,L)).gt.print_threshold) & + Write(IOut,1200) I,J,K,L,Tensor%RTen(I,J,K,L) + ElseIf(Tensor%Data_Type.eq.'Complex') then + If(abs(Tensor%CTen(I,J,K,L)).gt.print_threshold) & + Write(IOut,1300) I,J,K,L,Tensor%CTen(I,J,K,L) + EndIf + Else + If(Tensor%Data_Type.eq.'Integer') then + Write(IOut,1100) I,J,K,L,Tensor%ITen(I,J,K,L) + ElseIf(Tensor%Data_Type.eq.'Real') then + Write(IOut,1200) I,J,K,L,Tensor%RTen(I,J,K,L) + ElseIf(Tensor%Data_Type.eq.'Complex') then + Write(IOut,1300) I,J,K,L,Tensor%CTen(I,J,K,L) + EndIf + EndIF EndDo EndDo EndDo @@ -29109,13 +29142,25 @@ Subroutine MQC_Print_R4Tensor_Algebra1(Tensor,IOut,Header,blank_at_top,blank_at_ Do J = 1, Tensor%J Do K = 1, Tensor%K Do l = 1, Tensor%L - If(Tensor%Data_Type.eq.'Integer') then - Write(IOut,1100) I,J,K,L,Tensor%ITen(symIndexHash(I,J,K,L),1,1,1) - ElseIf(Tensor%Data_Type.eq.'Real') then - Write(IOut,1200) I,J,K,L,Tensor%RTen(symIndexHash(I,J,K,L),1,1,1) - ElseIf(Tensor%Data_Type.eq.'Complex') then - Write(IOut,1300) I,J,K,L,Tensor%CTen(symIndexHash(I,J,K,L),1,1,1) - EndIf + If(short_print) then + If(abs(Tensor%ITen(symIndexHash(I,J,K,L),1,1,1)).gt.print_threshold ) then + If(Tensor%Data_Type.eq.'Integer') then + Write(IOut,1100) I,J,K,L,Tensor%ITen(symIndexHash(I,J,K,L),1,1,1) + ElseIf(Tensor%Data_Type.eq.'Real') then + Write(IOut,1200) I,J,K,L,Tensor%RTen(symIndexHash(I,J,K,L),1,1,1) + ElseIf(Tensor%Data_Type.eq.'Complex') then + Write(IOut,1300) I,J,K,L,Tensor%CTen(symIndexHash(I,J,K,L),1,1,1) + EndIf + EndIf + Else + If(Tensor%Data_Type.eq.'Integer') then + Write(IOut,1100) I,J,K,L,Tensor%ITen(symIndexHash(I,J,K,L),1,1,1) + ElseIf(Tensor%Data_Type.eq.'Real') then + Write(IOut,1200) I,J,K,L,Tensor%RTen(symIndexHash(I,J,K,L),1,1,1) + ElseIf(Tensor%Data_Type.eq.'Complex') then + Write(IOut,1300) I,J,K,L,Tensor%CTen(symIndexHash(I,J,K,L),1,1,1) + EndIf + EndIF EndDo EndDo EndDo diff --git a/src/mqc_est.F03 b/src/mqc_est.F03 index 66b4d114..a3f459f1 100644 --- a/src/mqc_est.F03 +++ b/src/mqc_est.F03 @@ -941,21 +941,31 @@ end subroutine mqc_print_eigenvalues !> = .True.: print blank line below output !> = .False.: do not print blank line below output. !> \endverbatim +!> +!> \param[in] Short_Print_Threshold +!> \verbatim +!> Short_Print_Threshold is Real,Optional +!> if present: print only elements with absolute value larger than Short_Print_Threshold +!> \endverbatim ! ! Authors: ! ======== -!> \author L. M. Thompson -!> \date 2017 +!> \author L. M. Thompson, M. M. F. Moraes +!> \date 2017, 2025 ! subroutine mqc_print_twoERIs(twoERIs,iOut,header, & - blank_at_top,blank_at_bottom) + blank_at_top,blank_at_bottom,short_print_threshold) ! implicit none class(mqc_twoERIs)::twoERIs integer(kind=int64),intent(in)::iOut character(len=*),intent(in)::header + Real(kind=real64),intent(in),optional::short_print_threshold character(len=64)::integralType logical,intent(In),optional::blank_at_top,blank_at_bottom + Logical::short_print + Real(kind=real64)::print_threshold + ! 1000 Format(1x,A) 1020 Format( " " ) @@ -964,57 +974,73 @@ subroutine mqc_print_twoERIs(twoERIs,iOut,header, & if(blank_at_top) write(iout,1020) endif write(iout,1000) trim(header) - + If(Present(short_print_threshold)) then + print_threshold = short_print_threshold + short_print = .true. + else + print_threshold = -1.0 + short_print = .false. + EndIf call string_change_case(twoERIs%integraltype,'L') if(twoERIs%integralType.eq.'regular') then if(twoERIs%hasSpinBlock('aaaa')) & - call twoERIs%alpha%print(iout,'Regular 2ERIs') + call twoERIs%alpha%print(iout,'Regular 2ERIs',short_print_threshold=print_threshold) elseIf(twoERIs%integralType.eq.'raffenetti1') then if(twoERIs%hasSpinBlock('aaaa')) & - call twoERIs%alpha%print(iout,'Raffenetti 1 2ERIs') + call twoERIs%alpha%print(iout,'Raffenetti 1 2ERIs',short_print_threshold=print_threshold) elseIf(twoERIs%integralType.eq.'raffenetti2') then if(twoERIs%hasSpinBlock('aaaa')) & - call twoERIs%alpha%print(iout,'Raffenetti 2 2ERIs') + call twoERIs%alpha%print(iout,'Raffenetti 2 2ERIs',short_print_threshold=print_threshold) elseIf(twoERIs%integralType.eq.'raffenetti3') then if(twoERIs%hasSpinBlock('aaaa')) & - call twoERIs%alpha%print(iout,'Raffenetti 3 2ERIs') + call twoERIs%alpha%print(iout,'Raffenetti 3 2ERIs',short_print_threshold=print_threshold) elseIf(twoERIs%integralType.eq.'space') then if(twoERIs%hasSpinBlock('aaaa')) & - call twoERIs%alpha%print(iout,'Restricted MO 2ERIs') + call twoERIs%alpha%print(iout,'Restricted MO 2ERIs',short_print_threshold=print_threshold) elseIf(twoERIs%integralType.eq.'spin') then write(iout,'(A)') 'Unrestricted MO 2ERIs' if(twoERIs%hasSpinBlock('aaaa')) & - call twoERIs%alpha%print(iout,'(aa|aa)') + call twoERIs%alpha%print(iout,'(aa|aa)',short_print_threshold=print_threshold) if(twoERIs%hasSpinBlock('bbbb')) & - call twoERIs%beta%print(iout,'(bb|bb)') + call twoERIs%beta%print(iout,'(bb|bb)',short_print_threshold=print_threshold) if(twoERIs%hasSpinBlock('aabb')) & - call twoERIs%alphaBeta%print(iout,'(aa|bb)') - if(twoERIs%storageType.eq.'full'.and.twoERIs%hasSpinBlock('bbaa')) call twoERIs%betaAlpha%print(iout,'(bb|aa)') + call twoERIs%alphaBeta%print(iout,'(aa|bb)',short_print_threshold=print_threshold) + if(twoERIs%storageType.eq.'full'.and.twoERIs%hasSpinBlock('bbaa')) & + call twoERIs%betaAlpha%print(iout,'(bb|aa)',short_print_threshold=print_threshold) elseIf(twoERIs%integralType.eq.'general') then write(iout,'(A)') 'General MO 2ERIs' if(twoERIs%hasSpinBlock('aaaa')) & - call twoERIs%alpha%print(iout,'(aa|aa)') + call twoERIs%alpha%print(iout,'(aa|aa)',short_print_threshold=print_threshold) if(twoERIs%hasSpinBlock('bbbb')) & - call twoERIs%beta%print(iout,'(bb|bb)') + call twoERIs%beta%print(iout,'(bb|bb)',short_print_threshold=print_threshold) if(twoERIs%hasSpinBlock('aabb')) & - call twoERIs%alphaBeta%print(iout,'(aa|bb)') - if(twoERIs%storageType.eq.'full'.and.twoERIs%hasSpinBlock('bbaa')) call twoERIs%betaAlpha%print(iout,'(bb|aa)') + call twoERIs%alphaBeta%print(iout,'(aa|bb)',short_print_threshold=print_threshold) + if(twoERIs%storageType.eq.'full'.and.twoERIs%hasSpinBlock('bbaa')) & + call twoERIs%betaAlpha%print(iout,'(bb|aa)',short_print_threshold=print_threshold) if(twoERIs%hasSpinBlock('abab')) & - call twoERIs%abab%print(iout,'(ab|ab)') + call twoERIs%abab%print(iout,'(ab|ab)',short_print_threshold=print_threshold) if(twoERIs%hasSpinBlock('abba')) & - call twoERIs%abba%print(iout,'(ab|ba)') - if(twoERIs%storageType.eq.'full'.and.twoERIs%hasSpinBlock('baab')) call twoERIs%baab%print(iout,'(ba|ab)') - if(twoERIs%storageType.eq.'full'.and.twoERIs%hasSpinBlock('abba')) call twoERIs%baba%print(iout,'(ba|ba)') + call twoERIs%abba%print(iout,'(ab|ba)',short_print_threshold=print_threshold) + if(twoERIs%storageType.eq.'full'.and.twoERIs%hasSpinBlock('baab')) & + call twoERIs%baab%print(iout,'(ba|ab)',short_print_threshold=print_threshold) + if(twoERIs%storageType.eq.'full'.and.twoERIs%hasSpinBlock('abba')) & + call twoERIs%baba%print(iout,'(ba|ba)',short_print_threshold=print_threshold) if(twoERIs%hasSpinBlock('aaab')) & - call twoERIs%aaab%print(iout,'(aa|ab)') - if(twoERIs%storageType.eq.'full'.and.twoERIs%hasSpinBlock('aaba')) call twoERIs%aaba%print(iout,'(aa|ba)') - if(twoERIs%storageType.eq.'full'.and.twoERIs%hasSpinBlock('abaa')) call twoERIs%abaa%print(iout,'(ab|aa)') - if(twoERIs%storageType.eq.'full'.and.twoERIs%hasSpinBlock('bbba')) call twoERIs%baaa%print(iout,'(ba|aa)') - if(twoERIs%storageType.eq.'full'.and.twoERIs%hasSpinBlock('bbab')) call twoERIs%bbba%print(iout,'(bb|ba)') - if(twoERIs%storageType.eq.'full'.and.twoERIs%hasSpinBlock('babb')) call twoERIs%bbab%print(iout,'(bb|ab)') - if(twoERIs%storageType.eq.'full') call twoERIs%babb%print(iout,'(ba|bb)') + call twoERIs%aaab%print(iout,'(aa|ab)',short_print_threshold=print_threshold) + if(twoERIs%storageType.eq.'full'.and.twoERIs%hasSpinBlock('aaba')) & + call twoERIs%aaba%print(iout,'(aa|ba)',short_print_threshold=print_threshold) + if(twoERIs%storageType.eq.'full'.and.twoERIs%hasSpinBlock('abaa')) & + call twoERIs%abaa%print(iout,'(ab|aa)',short_print_threshold=print_threshold) + if(twoERIs%storageType.eq.'full'.and.twoERIs%hasSpinBlock('bbba')) & + call twoERIs%baaa%print(iout,'(ba|aa)',short_print_threshold=print_threshold) + if(twoERIs%storageType.eq.'full'.and.twoERIs%hasSpinBlock('bbab')) & + call twoERIs%bbba%print(iout,'(bb|ba)',short_print_threshold=print_threshold) + if(twoERIs%storageType.eq.'full'.and.twoERIs%hasSpinBlock('babb')) & + call twoERIs%bbab%print(iout,'(bb|ab)',short_print_threshold=print_threshold) + if(twoERIs%storageType.eq.'full') & + call twoERIs%babb%print(iout,'(ba|bb)',short_print_threshold=print_threshold) if(twoERIs%hasSpinBlock('abbb')) & - call twoERIs%abbb%print(iout,'(ab|bb)') + call twoERIs%abbb%print(iout,'(ab|bb)',short_print_threshold=print_threshold) else call mqc_error_A('Integral type unrecogised in mqc_print_twoERIs', 6, & 'twoERIs%integralType', twoERIs%integralType ) @@ -6981,7 +7007,7 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) ERIB%getBlock('bbba'), ERIB%getBlock('bbab'),& ERIB%getBlock('babb'), ERIB%getBlock('abbb')) case default - call mqc_error_A('Unknown twoERI type in mqc_eri_difference', 6, & + call mqc_error_A('Unknown twoERI type in mqc_eri_sum', 6, & 'ERIB%integraltype', ERIB%integraltype ) end select case('spin') @@ -7014,7 +7040,7 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) ERIB%getBlock('bbba'), ERIB%getBlock('bbab'),& ERIB%getBlock('babb'), ERIB%getBlock('abbb')) case default - call mqc_error_A('Unknown twoERI type in mqc_eri_difference', 6, & + call mqc_error_A('Unknown twoERI type in mqc_eri_sum', 6, & 'ERIB%integraltype', ERIB%integraltype ) end select case('general') @@ -7065,11 +7091,11 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& aabb,bbaa,abab,abba,baab,baba,aaab,aaba,abaa,baaa,bbba,bbab,babb,abbb) case default - call mqc_error_A('Unknown twoERI type in mqc_eri_difference', 6, & + call mqc_error_A('Unknown twoERI type in mqc_eri_sum', 6, & 'ERIB%integraltype', ERIB%integraltype ) end select case default - call mqc_error_A('Unknown twoERI type in mqc_eri_difference', 6, & + call mqc_error_A('Unknown twoERI type in mqc_eri_sum', 6, & 'ERIA%integraltype', ERIA%integraltype ) end select end function mqc_eri_sum @@ -8105,7 +8131,7 @@ function mqc_twoERIs_scalar_multiply(eris,scalarIn) result(erisOut) bbaa = scalar*eris%getBlock('bbaa') if(eris%hasSpinBlock('aabb')) & aabb = scalar*eris%getBlock('aabb') - call mqc_twoeris_allocate(erisOut,myLabel,'space',aaaa,bbbb,bbaa,aabb) + call mqc_twoeris_allocate(erisOut,myLabel,'space',aaaa,bbbb,aabb,bbaa) case('general') if(eris%hasSpinBlock('aaaa')) & aaaa = scalar*eris%getBlock('aaaa') @@ -8143,7 +8169,7 @@ function mqc_twoERIs_scalar_multiply(eris,scalarIn) result(erisOut) babb = scalar*eris%getBlock('babb') if(eris%hasSpinBlock('abbb')) & abbb = scalar*eris%getBlock('abbb') - call mqc_twoeris_allocate(erisOut,myLabel,'general',aaaa,bbbb,bbaa,aabb,& + call mqc_twoeris_allocate(erisOut,myLabel,'general',aaaa,bbbb,aabb,bbaa,& abab,abba,baab,baba,& aaab,aaba,abaa,baaa,& bbba,bbab,babb,abbb) @@ -8229,7 +8255,7 @@ function mqc_scalar_twoERIs_multiply(scalarIn,eris) result(erisOut) bbaa = scalar*eris%getBlock('bbaa') if(eris%hasSpinBlock('aabb')) & aabb = scalar*eris%getBlock('aabb') - call mqc_twoeris_allocate(erisOut,myLabel,'space',aaaa,bbbb,bbaa,aabb) + call mqc_twoeris_allocate(erisOut,myLabel,'space',aaaa,bbbb,aabb,bbaa) case('general') if(eris%hasSpinBlock('aaaa')) & aaaa = scalar*eris%getBlock('aaaa') @@ -8239,7 +8265,6 @@ function mqc_scalar_twoERIs_multiply(scalarIn,eris) result(erisOut) bbaa = scalar*eris%getBlock('bbaa') if(eris%hasSpinBlock('aabb')) & aabb = scalar*eris%getBlock('aabb') - aabb = scalar*eris%getBlock('aabb') if(eris%hasSpinBlock('baba')) & baba = scalar*eris%getBlock('baba') if(eris%hasSpinBlock('baab')) & @@ -8264,7 +8289,7 @@ function mqc_scalar_twoERIs_multiply(scalarIn,eris) result(erisOut) babb = scalar*eris%getBlock('babb') if(eris%hasSpinBlock('abbb')) & abbb = scalar*eris%getBlock('abbb') - call mqc_twoeris_allocate(erisOut,myLabel,'general',aaaa,bbbb,bbaa,aabb,& + call mqc_twoeris_allocate(erisOut,myLabel,'general',aaaa,bbbb,aabb,bbaa,& abab,abba,baab,baba,& aaab,aaba,abaa,baaa,& bbba,bbab,babb,abbb) From 2269586eef038d0546c11e90be5fd355d488afb8 Mon Sep 17 00:00:00 2001 From: Matheus Moraes Date: Fri, 11 Jul 2025 15:06:35 -0400 Subject: [PATCH 05/37] OMP in R4Tensor contraction --- src/mqc_algebra.F03 | 32 +++++++++++++++++++++----------- src/mqc_est.F03 | 16 ++++++++-------- 2 files changed, 29 insertions(+), 19 deletions(-) diff --git a/src/mqc_algebra.F03 b/src/mqc_algebra.F03 index e6130f47..e6a28452 100644 --- a/src/mqc_algebra.F03 +++ b/src/mqc_algebra.F03 @@ -27469,10 +27469,10 @@ Function MQC_Givens_Matrix(m_size,angle,p,q) ! ! Authors: ! ======== -!> \author L. M. Thompson -!> \date 2019 +!> \author L. M. Thompson, M. M. F. Moraes +!> \date 2019, 2025 ! - Function MQC_Matrix_Matrix_Outer(matrix1,matrix2) result(outer) + Function MQC_Matrix_Matrix_Outer(matrix1,matrix2) result(outer) ! ! Variable Declarations. Implicit None @@ -27486,7 +27486,9 @@ Function MQC_Matrix_Matrix_Outer(matrix1,matrix2) result(outer) P = size(matrix2,2) call outer%init(M,N,O,P) - + +!$OMP PARALLEL DO DEFAULT(NONE), & +!$OMP SHARED(M,N,O,P,outer,matrix1,matrix2) do i = 1,M do j = 1,N do k = 1,O @@ -27496,10 +27498,8 @@ Function MQC_Matrix_Matrix_Outer(matrix1,matrix2) result(outer) endDo endDo endDo - - end function MQC_Matrix_Matrix_Outer - - +!$OMP END PARALLEL DO + end function MQC_Matrix_Matrix_Outer ! ! ! PROCEDURE MQC_Matrix_Matrix_Cross_Outer @@ -30543,8 +30543,8 @@ End Subroutine MQC_R4Tensor_Copy_Complex2Real ! ! Authors: ! ======== -!> \author L. M. Thompson -!> \date 2019 +!> \author L. M. Thompson, M. M. F. Moraes +!> \date 2019, 2025 ! Function MQC_R4Tensor_R4Tensor_Contraction(R4Tensor1,R4Tensor2) Result(Contraction) ! @@ -30553,6 +30553,7 @@ Function MQC_R4Tensor_R4Tensor_Contraction(R4Tensor1,R4Tensor2) Result(Contracti Implicit None Type(MQC_R4Tensor),Intent(In)::R4Tensor1,R4Tensor2 Type(MQC_Scalar)::Contraction + Type(MQC_Scalar),dimension(:),allocatable::ContractionVec Integer(kind=int64)::M,N,O,P,i,j,k,l ! Contraction = 0.0 @@ -30560,15 +30561,24 @@ Function MQC_R4Tensor_R4Tensor_Contraction(R4Tensor1,R4Tensor2) Result(Contracti N = Min(size(R4Tensor1,2),size(R4Tensor2,2)) O = Min(size(R4Tensor1,3),size(R4Tensor2,3)) P = Min(size(R4Tensor1,4),size(R4Tensor2,4)) + allocate(ContractionVec(M)) +!$OMP PARALLEL DO DEFAULT(NONE), & +!$OMP SHARED(M,N,O,P,ContractionVec,R4Tensor1,R4Tensor2),& +!$OMP PRIVATE(j,k,l) Do i = 1,M + ContractionVec(i) = 0.0 Do j = 1,N Do k = 1,O Do l = 1,P - Contraction = Contraction + R4Tensor1%at(i,j,k,l)*R4Tensor2%at(i,j,k,l) + ContractionVec(i) = ContractionVec(i) + R4Tensor1%at(i,j,k,l)*R4Tensor2%at(i,j,k,l) EndDo EndDo EndDo EndDo +!$OMP END PARALLEL DO + Do i = 1,M + Contraction = Contraction + ContractionVec(i) + EndDo ! End Function MQC_R4Tensor_R4Tensor_Contraction ! diff --git a/src/mqc_est.F03 b/src/mqc_est.F03 index 8b6e0dbb..e3393828 100644 --- a/src/mqc_est.F03 +++ b/src/mqc_est.F03 @@ -981,23 +981,23 @@ subroutine mqc_print_twoERIs(twoERIs,iOut,header, & print_threshold = -1.0 short_print = .false. EndIf - call string_change_case(twoERIs%integraltype,'L') - if(twoERIs%integralType.eq.'regular') then + call string_change_case(trim(twoERIs%integraltype),'L') + if(trim(twoERIs%integralType).eq.'regular') then if(twoERIs%hasSpinBlock('aaaa')) & call twoERIs%alpha%print(iout,'Regular 2ERIs',short_print_threshold=print_threshold) - elseIf(twoERIs%integralType.eq.'raffenetti1') then + elseIf(trim(twoERIs%integralType).eq.'raffenetti1') then if(twoERIs%hasSpinBlock('aaaa')) & call twoERIs%alpha%print(iout,'Raffenetti 1 2ERIs',short_print_threshold=print_threshold) - elseIf(twoERIs%integralType.eq.'raffenetti2') then + elseIf(trim(twoERIs%integralType).eq.'raffenetti2') then if(twoERIs%hasSpinBlock('aaaa')) & call twoERIs%alpha%print(iout,'Raffenetti 2 2ERIs',short_print_threshold=print_threshold) - elseIf(twoERIs%integralType.eq.'raffenetti3') then + elseIf(trim(twoERIs%integralType).eq.'raffenetti3') then if(twoERIs%hasSpinBlock('aaaa')) & call twoERIs%alpha%print(iout,'Raffenetti 3 2ERIs',short_print_threshold=print_threshold) - elseIf(twoERIs%integralType.eq.'space') then + elseIf(trim(twoERIs%integralType).eq.'space') then if(twoERIs%hasSpinBlock('aaaa')) & call twoERIs%alpha%print(iout,'Restricted MO 2ERIs',short_print_threshold=print_threshold) - elseIf(twoERIs%integralType.eq.'spin') then + elseIf(trim(twoERIs%integralType).eq.'spin') then write(iout,'(A)') 'Unrestricted MO 2ERIs' if(twoERIs%hasSpinBlock('aaaa')) & call twoERIs%alpha%print(iout,'(aa|aa)',short_print_threshold=print_threshold) @@ -1007,7 +1007,7 @@ subroutine mqc_print_twoERIs(twoERIs,iOut,header, & call twoERIs%alphaBeta%print(iout,'(aa|bb)',short_print_threshold=print_threshold) if(twoERIs%storageType.eq.'full'.and.twoERIs%hasSpinBlock('bbaa')) & call twoERIs%betaAlpha%print(iout,'(bb|aa)',short_print_threshold=print_threshold) - elseIf(twoERIs%integralType.eq.'general') then + elseIf(trim(twoERIs%integralType).eq.'general') then write(iout,'(A)') 'General MO 2ERIs' if(twoERIs%hasSpinBlock('aaaa')) & call twoERIs%alpha%print(iout,'(aa|aa)',short_print_threshold=print_threshold) From 8eb0998ceba954512481af905f6369685b8b40c4 Mon Sep 17 00:00:00 2001 From: Lee Thompson Date: Tue, 9 Sep 2025 16:52:02 -0400 Subject: [PATCH 06/37] Added a vector of vectors object to mqc_algebra --- src/mqc_algebra.F03 | 8 ++++++++ src/mqc_est.F03 | 47 +++++---------------------------------------- 2 files changed, 13 insertions(+), 42 deletions(-) diff --git a/src/mqc_algebra.F03 b/src/mqc_algebra.F03 index c9b9863e..db78caa3 100644 --- a/src/mqc_algebra.F03 +++ b/src/mqc_algebra.F03 @@ -184,6 +184,14 @@ Module MQC_Algebra Procedure, Public::diagf => MQC_Matrix_DiagMatrix_Put_Vector_func End Type MQC_Vector ! +! Vectors of Vectors... +! +!> \brief Vector of Vectors variable + Type MQC_VoV + Type(MQC_Vector),Public::Vector + Type(MQC_VoV),Public,Dimension(:),Allocatable::VoV + End Type MQC_VoV +! ! Matrices... ! Lower triangular matrix is stored in a row-major manner so that it is stored one row at a time. ! Matrices with StorSymm flag are symmetric for both real and complex parts. StorHerm, StorASymm diff --git a/src/mqc_est.F03 b/src/mqc_est.F03 index fde1be32..614cb56e 100644 --- a/src/mqc_est.F03 +++ b/src/mqc_est.F03 @@ -14906,7 +14906,11 @@ function mqc_eigenvalues_at(eigenvalues,i,spinBlockIn) result(element) element = eigenvalues%alpha%at(myI) elseIf(myI.le.eigenvalues%blockSize('full')) then myI = myI - eigenvalues%blockSize('alpha') - element = eigenvalues%beta%at(myI) + if(eigenvalues%array_type.eq.'space') then + element = eigenvalues%alpha%at(myI) + elseIf(eigenvalues%array_type.eq.'spin'.or.eigenvalues%array_type.eq.'general') then + element = eigenvalues%beta%at(myI) + endIf else call mqc_error_i('Requested index is outside size of eigenvalues object',6,'myI',myI) endIf @@ -14914,47 +14918,6 @@ function mqc_eigenvalues_at(eigenvalues,i,spinBlockIn) result(element) call mqc_error_A('SpinBlock type not valid in MQC_Eigenvalues_At',6,'SpinBlock',SpinBlock) end select -! -! if(present(spinBlockIn)) then -! call string_change_case(spinBlockIn,'L',spinBlock) -! if(eigenvalues%array_type.eq.'space') then -! if(spinBlock.eq.'alpha'.or.spinBlock.eq.'beta') then -! element = eigenvalues%alpha%at(myI) -! else -! call mqc_error_A('SpinBlock type not valid in MQC_Eigenvalues_At',6,'SpinBlock',SpinBlock) -! endIf -! elseIf(eigenvalues%array_type.eq.'spin'.or.eigenvalues%array_type.eq.'general') then -! if(spinBlock.eq.'alpha') then -! element = eigenvalues%alpha%at(myI) -! elseif(spinblock.eq.'beta') then -! element = eigenvalues%beta%at(myI) -! else -! call mqc_error_A('SpinBlock type not valid in MQC_Eigenvalues_At',6,'SpinBlock',SpinBlock) -! endIf -! else -! call mqc_error_A('Array type not valid in MQC_Eigenvalues_At',6,'Array_Type',eigenvalues%array_type) -! endIf -! else -! if(eigenvalues%array_type.eq.'space') then -! if(myI.gt.eigenvalues%blockSize('alpha')) myI = myI - eigenvalues%blockSize('alpha') -! if(myI.lt.(-1)*eigenvalues%blockSize('alpha')) myI = myI + eigenvalues%blockSize('alpha') -! element = eigenvalues%alpha%at(myI) -! elseIf(eigenvalues%array_type.eq.'spin'.or.eigenvalues%array_type.eq.'general') then -! if(myI.gt.eigenvalues%blockSize('alpha')) then -! element = eigenvalues%beta%at(myI) -! elseIf(myI.ge.0) then -! element = eigenvalues%alpha%at(myI) -! elseIf(myI.lt.(-1)*eigenvalues%blockSize('alpha')) then -! myI = myI + eigenvalues%blockSize('alpha') -! element = eigenvalues%beta%at(myI) -! else -! element = eigenvalues%alpha%at(myI) -! endIf -! else -! call mqc_error_A('Array type not valid in MQC_Eigenvalues_At',6,'Array_Type',eigenvalues%array_type) -! endIf -! endIf - end function mqc_eigenvalues_at ! ! From d26629fea209c9a0c212b0710ac55893d2b3acf9 Mon Sep 17 00:00:00 2001 From: Matheus Moraes Date: Wed, 24 Sep 2025 15:35:33 -0400 Subject: [PATCH 07/37] Conjugated transpose for R4Tensor and 2ERIs Added: Conjugated transpose function for R4Tensor and 2ERIs objects Fix: Generate a MQC_SCF_integral with a single dimension equals to zero does not focer other indexes to be zero. --- src/mqc_algebra.F03 | 146 +++++++++++++++++++++++++-- src/mqc_est.F03 | 241 +++++++++++++++++++++++++++++++++----------- 2 files changed, 323 insertions(+), 64 deletions(-) diff --git a/src/mqc_algebra.F03 b/src/mqc_algebra.F03 index 67c4a952..0a050200 100644 --- a/src/mqc_algebra.F03 +++ b/src/mqc_algebra.F03 @@ -298,6 +298,8 @@ Module MQC_Algebra Procedure, Public::tat => MQC_R4Tensor_R4Tensor_At Procedure, Private::put_sca => MQC_R4Tensor_Put_Scalar Procedure, Private::put_int => MQC_R4Tensor_Put_Int +!> \brief Returns the Hemitian transpose of the MQC R4Tensor + Procedure, Public::dagger => MQC_R4Tensor_Conjugate_Transpose !> \brief Update the specified element in the MQC R4Tensor with the !> specified value Generic, Public::put => put_sca, put_int @@ -423,6 +425,7 @@ Module MQC_Algebra Interface Dagger Module Procedure MQC_Vector_Conjugate_Transpose Module Procedure MQC_Matrix_Conjugate_Transpose + Module Procedure MQC_R4Tensor_Conjugate_Transpose End Interface ! !> \brief Defines a complex number @@ -24097,11 +24100,15 @@ Function MQC_MatrixVectorDotProduct(MA,VB) Result(VC) Type(MQC_Matrix)::MAreal,Tmp1 Integer(kind=int64),Allocatable::Result(:,:) - If (.not. VB%Column .or. MA%NCol /= VB%Length) then + If (MA%NCol /= VB%Length) then Call MQC_Error_I('Matrix and vector are not conformable for multiplication', 6, & 'MA%NCol', MA%NCol, & 'VB%Length', VB%Length) EndIf + If (.not. VB%Column) then + Call MQC_Error_I('Row type vector are not conformable for a right size multiplication with a matrix', 6) + EndIf + If (MQC_Matrix_HaveInteger(MA)) MAreal = MQC_Cast_Real(MA) If (MQC_Vector_HaveInteger(VB)) VBreal = MQC_Cast_Real(VB) @@ -24275,11 +24282,15 @@ Function MQC_VectormatrixDotProduct(VA,MB) Result(VC) Type(MQC_Matrix)::MBreal,Tmp1 Integer(kind=int64),Allocatable::Result(:,:) - If (VA%Column .or. VA%Length /= MB%NRow) then + If ( VA%Length /= MB%NRow) then Call MQC_Error_i('Matrix and vector are not conformable for multiplication', 6, & 'VA%Length', VA%Length, & 'MB%NRow', MB%NRow) EndIf + If (VA%Column) then + Call MQC_Error_I('Column type vector are not conformable for a left size multiplication with a matrix', 6) + EndIf + If (MQC_Matrix_HaveReal(MB) .and. MQC_Vector_HaveReal(VA)) then Call MQC_Allocate_Vector(MB%NCol,VC,'Real') @@ -27487,8 +27498,8 @@ Function MQC_Matrix_Matrix_Outer(matrix1,matrix2) result(outer) call outer%init(M,N,O,P) -!$OMP PARALLEL DO DEFAULT(NONE), & -!$OMP SHARED(M,N,O,P,outer,matrix1,matrix2) +!!!$OMP PARALLEL DO DEFAULT(NONE), & +!!!$OMP SHARED(M,N,O,P,outer,matrix1,matrix2) do i = 1,M do j = 1,N do k = 1,O @@ -27498,7 +27509,7 @@ Function MQC_Matrix_Matrix_Outer(matrix1,matrix2) result(outer) endDo endDo endDo -!$OMP END PARALLEL DO +!!!$OMP END PARALLEL DO end function MQC_Matrix_Matrix_Outer ! ! @@ -30564,7 +30575,7 @@ Function MQC_R4Tensor_R4Tensor_Contraction(R4Tensor1,R4Tensor2) Result(Contracti allocate(ContractionVec(M)) !$OMP PARALLEL DO DEFAULT(NONE), & !$OMP SHARED(M,N,O,P,ContractionVec,R4Tensor1,R4Tensor2),& -!$OMP PRIVATE(j,k,l) +!$OMP PRIVATE(j,k,l,i) Do i = 1,M ContractionVec(i) = 0.0 Do j = 1,N @@ -33111,6 +33122,129 @@ Function MQC_R4Tensor_R4Tensor_Partial_Contraction(RA,RB,orderA,orderB) Result(M !$OMP END PARALLEL DO EndFunction MQC_R4Tensor_R4Tensor_Partial_Contraction +! +! +! PROCEDURE MQC_R4Tensor_Conjugate_Transpose +! +!> \brief MQC_R4Tensor_Conjugate_Transpose is a function that returns the +!> conjugate transpose of a MQC R4Tensor +!> +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_R4Tensor_Conjugate_Transpose is a function that returns the conjugate +!> transpose of a MQC R4Tensor. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] R4Tensor +!> \verbatim +!> Matrix is Type(MQC_R4Tensor) +!> The MQC R4Tensor to be conjugate transposed. +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2025 +! + Function MQC_R4Tensor_Conjugate_Transpose(R4Tensor) +! +! Variable Declarations. + Implicit None + Type(MQC_R4Tensor)::MQC_R4Tensor_Conjugate_Transpose + Class(MQC_R4Tensor),Intent(In)::R4Tensor + Integer(kind=int64)::I,J,L,K +! + If(MQC_R4Tensor_HaveReal(R4Tensor)) then + Call MQC_Allocate_R4Tensor(R4Tensor%L,R4Tensor%K,R4Tensor%J,R4Tensor%I,& + MQC_R4Tensor_Conjugate_Transpose,'Real',R4Tensor%Storage) + If (R4Tensor%Storage.eq.'StorFull') then + do I=1, R4Tensor%I + do J=1, R4Tensor%J + do L=1, R4Tensor%L + do K=1, R4Tensor%K + MQC_R4Tensor_Conjugate_Transpose%RTen(L,K,J,I)=R4Tensor%RTen(I,J,K,L) + end do + end do + end do + end do + ElseIf (R4Tensor%Storage.eq.'StorSymm') then + do I=1, R4Tensor%I + do J=1, R4Tensor%J + do L=1, R4Tensor%L + do K=1, R4Tensor%K + MQC_R4Tensor_Conjugate_Transpose%RTen(L,K,J,I)=R4Tensor%RTen(I,J,K,L) + end do + end do + end do + end do + Else + Call MQC_Error_A('Unrecognise R4Tensor storage type in MQC_R4Tensor_Conjugate_Transpose', 6, & + 'R4Tensor%Storage', R4Tensor%Storage ) + EndIf + ElseIf(MQC_R4Tensor_HaveInteger(R4Tensor)) then + Call MQC_Allocate_R4Tensor(R4Tensor%I,R4Tensor%J,R4Tensor%K,R4Tensor%L,& + MQC_R4Tensor_Conjugate_Transpose,'Integer',R4Tensor%Storage) + If (R4Tensor%Storage.eq.'StorFull') then + do I=1, R4Tensor%I + do J=1, R4Tensor%J + do L=1, R4Tensor%L + do K=1, R4Tensor%K + MQC_R4Tensor_Conjugate_Transpose%ITen(L,K,J,I)=R4Tensor%ITen(I,J,K,L) + end do + end do + end do + end do + ElseIf (R4Tensor%Storage.eq.'StorSymm') then + do I=1, R4Tensor%I + do J=1, R4Tensor%J + do L=1, R4Tensor%L + do K=1, R4Tensor%K + MQC_R4Tensor_Conjugate_Transpose%ITen(L,K,J,I)=R4Tensor%ITen(I,J,K,L) + end do + end do + end do + end do + Else + Call MQC_Error_A('Unrecognise R4Tensor storage type in MQC_R4Tensor_Conjugate_Transpose', 6, & + 'R4Tensor%Storage', R4Tensor%Storage ) + EndIf + ElseIf(MQC_R4Tensor_HaveComplex(R4Tensor)) then + Call MQC_Allocate_R4Tensor(R4Tensor%I,R4Tensor%J,R4Tensor%K,R4Tensor%L,& + MQC_R4Tensor_Conjugate_Transpose,'Complex',R4Tensor%Storage) + If (R4Tensor%Storage.eq.'StorFull') then + do I=1, R4Tensor%I + do J=1, R4Tensor%J + do L=1, R4Tensor%L + do K=1, R4Tensor%K + MQC_R4Tensor_Conjugate_Transpose%CTen(L,K,J,I)=conjg(R4Tensor%CTen(I,J,K,L)) + end do + end do + end do + end do + ElseIf (R4Tensor%Storage.eq.'StorSymm') then + do I=1, R4Tensor%I + do J=1, R4Tensor%J + do L=1, R4Tensor%L + do K=1, R4Tensor%K + MQC_R4Tensor_Conjugate_Transpose%CTen(L,K,J,I)=conjg(R4Tensor%CTen(I,J,K,L)) + end do + end do + end do + end do + Else + Call MQC_Error_A('Unrecognise R4Tensor storage type in MQC_R4Tensor_Conjugate_Transpose', 6, & + 'R4Tensor%Storage', R4Tensor%Storage ) + EndIf + EndIf +! + Return + End Function MQC_R4Tensor_Conjugate_Transpose ! ! diff --git a/src/mqc_est.F03 b/src/mqc_est.F03 index cb2a57d4..68a4a260 100644 --- a/src/mqc_est.F03 +++ b/src/mqc_est.F03 @@ -20,6 +20,7 @@ !> 4. MQC_PSCF_Wavefunction: EST intermediates of post-Hartree-Fock methods !> 5. MQC_Determinant: Binary strings reresenting occupation number vectors !> 6. MQC_TwoERIs: Two-electron resonance integrals +!> 7. MQC_TwoERIset: Set of two-electron resonance integrals !> !> This module is level 2 in the MQC hierarchy and so depends on level 0 and 1 !> modules. @@ -342,6 +343,7 @@ Module MQC_EST !> \brief Returns the Hermitian conjugate Interface Dagger Module Procedure MQC_Integral_Conjugate_Transpose + Module Procedure MQC_TwoERIS_Conjugate_Transpose End Interface ! !> \brief Contracts two objects @@ -2718,7 +2720,7 @@ end subroutine mqc_twoeris_allocate ! ! Authors: ! ======== -!> \author L. M. Thompson +!> \author L. M. Thompson, M. M. F. Moraes !> \date 2016, 2025 ! subroutine mqc_integral_allocate(integral,arrayName,arrayType,alpha, & @@ -2749,23 +2751,27 @@ subroutine mqc_integral_allocate(integral,arrayName,arrayType,alpha, & integral%nARows = size(integral%alpha,1) integral%nACols = size(integral%alpha,2) if(present(nDimA1)) then - if(nDimA1.ne.integral%nARows) call mqc_error_i('Mismatch in integral dimensions & + if(nDimA1.ne.integral%nARows.and.nDimA1.ne.0) call mqc_error_i('Mismatch in integral dimensions & &provided in mqc_integral_allocate',6,'nDimA1',nDimA1,'integral%nARows',& integral%nARows) endIf if(present(nDimA2)) then - if(nDimA2.ne.integral%nACols) call mqc_error_i('Mismatch in integral dimensions & + if(nDimA2.ne.integral%nACols.and.nDimA2.ne.0) call mqc_error_i('Mismatch in integral dimensions & &provided in mqc_integral_allocate',6,'nDimA2',nDimA2,'integral%nACols',& integral%nACols) endIf else if(present(nDimA1)) then integral%nARows = nDimA1 + else if (present(alpha).and.allocated(alpha).and.size(alpha,1).ne.0) then + integral%nARows = size(integral%alpha,1) else integral%nARows = 0 endIf if(present(nDimA2)) then integral%nACols = nDimA2 + else if (present(alpha).and.allocated(alpha).and.size(alpha,2).ne.0) then + integral%nACols = size(integral%alpha,2) else integral%nACols = 0 endIf @@ -2780,23 +2786,27 @@ subroutine mqc_integral_allocate(integral,arrayName,arrayType,alpha, & integral%nBRows = size(integral%beta,1) integral%nBCols = size(integral%beta,2) if(present(nDimB1)) then - if(nDimB1.ne.integral%nBRows) call mqc_error_i('Mismatch in integral dimensions & + if(nDimB1.ne.integral%nBRows.and.nDimB1.ne.0) call mqc_error_i('Mismatch in integral dimensions & &provided in mqc_integral_allocate',6,'nDimB1',nDimB1,'integral%nBRows',& integral%nBRows) endIf if(present(nDimB2)) then - if(nDimB2.ne.integral%nBCols) call mqc_error_i('Mismatch in integral dimensions & + if(nDimB2.ne.integral%nBCols.and.nDimB2.ne.0) call mqc_error_i('Mismatch in integral dimensions & &provided in mqc_integral_allocate',6,'nDimB2',nDimB2,'integral%nBCols',& integral%nBCols) endIf else if(present(nDimB1)) then integral%nBRows = nDimB1 + else if(present(beta).and.allocated(beta).and.size(beta,1).ne.0) then + integral%nBRows = size(integral%beta,1) else integral%nBRows = 0 endIf if(present(nDimB2)) then integral%nBCols = nDimB2 + else if(present(beta).and.allocated(beta).and.size(beta,2).ne.0) then + integral%nBCols = size(integral%beta,2) else integral%nBCols = 0 endIf @@ -2806,8 +2816,10 @@ subroutine mqc_integral_allocate(integral,arrayName,arrayType,alpha, & if(myArrayType.eq.'general') then if(present(alphaBeta).and.allocated(alphaBeta).and.size(alphaBeta,1).ne.0.and.size(alphaBeta,2).ne.0) then integral%alphaBeta = alphaBeta + if(integral%nBRows.eq.0) integral%nBRows = size(integral%alphaBeta,1) + if(integral%nACols.eq.0) integral%nACols = size(integral%alphaBeta,2) if(size(integral%alphaBeta,1).ne.integral%nBRows.or.& - size(integral%alphaBeta,2).ne.integral%nACols) & + size(integral%alphaBeta,2).ne.integral%nACols) & call mqc_error_i('Alpha-beta array size mismatch in & &mqc_integral_allocate',6,'size(integral%alphaBeta,1)',& size(integral%alphaBeta,1),'integral%nBRows',integral%nBRows,& @@ -2816,8 +2828,10 @@ subroutine mqc_integral_allocate(integral,arrayName,arrayType,alpha, & endIf if(present(betaAlpha).and.allocated(betaAlpha).and.size(betaAlpha,1).ne.0.and.size(betaAlpha,2).ne.0) then integral%betaAlpha = betaAlpha + if(integral%nARows.eq.0) integral%nARows = size(integral%betaAlpha,1) + if(integral%nBCols.eq.0) integral%nBCols = size(integral%betaAlpha,2) if(size(integral%betaAlpha,1).ne.integral%nARows.or.& - size(integral%betaAlpha,2).ne.integral%nBCols) & + size(integral%betaAlpha,2).ne.integral%nBCols) & call mqc_error_i('Beta-Alpha array size mismatch in & &mqc_integral_allocate',6,'size(integral%betaAlpha,1)',& size(integral%betaAlpha,1),'integral%nARows',integral%nARows,& @@ -3563,8 +3577,8 @@ end function mqc_integral_identity_func ! ! Authors: ! ======== -!> \author L. M. Thompson -!> \date 2017 +!> \author L. M. Thompson, M. M. F. Moraes +!> \date 2017, 2025 ! subroutine mqc_integral_initialize(integral,nAlpha,nBeta,scalar,label,nAlpha2,nBeta2) ! @@ -3574,7 +3588,7 @@ subroutine mqc_integral_initialize(integral,nAlpha,nBeta,scalar,label,nAlpha2,nB character(Len=*),optional,intent(in)::label class(*),optional,intent(in)::Scalar integer,intent(in),optional::nAlpha2,nBeta2 - type(mqc_matrix)::tmpMatrixAlpha,tmpMatrixBeta + type(mqc_matrix)::tmpMatrixAlpha,tmpMatrixBeta,tmpMatrixAlphaBeta,tmpMatrixBetaAlpha Character(Len=64)::myLabel integer::my_nAlpha2,my_nBeta2 ! @@ -3599,7 +3613,14 @@ subroutine mqc_integral_initialize(integral,nAlpha,nBeta,scalar,label,nAlpha2,nB call mqc_integral_allocate(integral,myLabel,'space',tmpMatrixAlpha) else call tmpMatrixBeta%init(nBeta,my_nBeta2,scalar) - call mqc_integral_allocate(integral,myLabel,'spin',tmpMatrixAlpha,tmpMatrixBeta) + if(my_nBeta2.eq.0.or.nBeta.eq.0.or.my_nAlpha2.eq.0.or.nAlpha.eq.0) then + call tmpMatrixAlphaBeta%init(nAlpha,my_nBeta2) + call tmpMatrixBetaAlpha%init(nBeta,my_nAlpha2) + call mqc_integral_allocate(integral,myLabel,'general',tmpMatrixAlpha,tmpMatrixBeta,& + tmpMatrixAlphaBeta,tmpMatrixBetaAlpha) + else + call mqc_integral_allocate(integral,myLabel,'spin',tmpMatrixAlpha,tmpMatrixBeta) + endIf endIf else call tmpMatrixAlpha%init(nAlpha,my_nAlpha2) @@ -3607,7 +3628,14 @@ subroutine mqc_integral_initialize(integral,nAlpha,nBeta,scalar,label,nAlpha2,nB call mqc_integral_allocate(integral,myLabel,'space',tmpMatrixAlpha) else call tmpMatrixBeta%init(nBeta,my_nBeta2) - call mqc_integral_allocate(integral,myLabel,'spin',tmpMatrixAlpha,tmpMatrixBeta) + if(my_nBeta2.eq.0.or.nBeta.eq.0.or.my_nAlpha2.eq.0.or.nAlpha.eq.0) then + call tmpMatrixAlphaBeta%init(nAlpha,my_nBeta2) + call tmpMatrixBetaAlpha%init(nBeta,my_nAlpha2) + call mqc_integral_allocate(integral,myLabel,'general',tmpMatrixAlpha,tmpMatrixBeta,& + tmpMatrixAlphaBeta,tmpMatrixBetaAlpha) + else + call mqc_integral_allocate(integral,myLabel,'spin',tmpMatrixAlpha,tmpMatrixBeta) + endIf endIf endIf ! @@ -11798,52 +11826,54 @@ function mqc_eri_eri_partial_contraction_2eri(eris1,eris2,index1,index2) result( active_conf_2=full_array(j) active_conf=trim(active_conf_1(3:4))//trim(active_conf_2(3:4)) str2=mqc_index_to_string([ib,jb,kb,lb],active_conf_2) - select case (active_conf) - case('aaaa') - aaaa = aaaa + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& - eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - case('bbbb') - bbbb = bbbb + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& - eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - case('aabb') - aabb = aabb + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& - eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - case('abab') - eriType='general' - abab = abab + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& - eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - case('abba') - eriType='general' - abba = abba + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& - eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - case('baab') - eriType='general' - baab = baab + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& - eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - case('baba') - eriType='general' - baba = baba + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& - eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - case('bbaa') - bbaa = bbaa + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& - eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - case('abbb') - eriType='general' - abbb = abbb + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& - eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - case('babb') - eriType='general' - babb = babb + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& - eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - case('bbab') - eriType='general' - bbab = bbab + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& - eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - case('bbba') - eriType='general' - bbba = bbba + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& - eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - end select + if (active_conf_1(1:2).eq.active_conf_2(1:2)) then + select case (active_conf) + case('aaaa') + aaaa = aaaa + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + case('bbbb') + bbbb = bbbb + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + case('aabb') + aabb = aabb + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + case('abab') + eriType='general' + abab = abab + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + case('abba') + eriType='general' + abba = abba + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + case('baab') + eriType='general' + baab = baab + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + case('baba') + eriType='general' + baba = baba + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + case('bbaa') + bbaa = bbaa + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + case('abbb') + eriType='general' + abbb = abbb + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + case('babb') + eriType='general' + babb = babb + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + case('bbab') + eriType='general' + bbab = bbab + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + case('bbba') + eriType='general' + bbba = bbba + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + end select + end if enddo enddo @@ -21351,6 +21381,101 @@ Subroutine TwoERI_Trans(IOut,IPrint,MO_Coeff,ERIs,MO_ERIs,Right_MOs) EndIf ! End Subroutine TwoERI_Trans +! +! +! PROCEDURE MQC_TwoERIs_Conjugate_Transpose +! +!> \brief MQC_TwoERIs_Conjugate_Transpose is used to compute the conjugate +!> transpose of a MQC two ERIs type variable +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_TwoERIs_Conjugate_Transpose is used to compute the conjugate +!> transpose of a MQC two ERIs type variable +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] ERIs +!> \verbatim +!> Integral is type(mqc_twoERIs) +!> The MQC two ERIs type variable to conjugate transpose. +!> \endverbatim +!> +!> \param[in] Label +!> \verbatim +!> Label is Character(Len=*),optional +!> A description tag for the conjugate transposed integral. +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2025 +! + function mqc_twoeris_conjugate_transpose(ERIs,label) result(ERIsOut) +! + implicit none + type(mqc_twoERIs),intent(in)::ERIs + Character(Len=*),optional,intent(in)::label + type(mqc_twoERIs)::ERIsOut + Character(Len=64)::myLabel + type(mqc_R4Tensor)::tmpaaaa,tmpbbbb,tmpaabb,tmpbbaa,tmpabab,tmpabba,tmpbaab,tmpbaba,& + tmpaaab,tmpaaba,tmpabaa,tmpbaaa,tmpbbba,tmpbbab,tmpbabb,tmpabbb + + + +! + if(present(label)) then + call string_change_case(label,'l',myLabel) + else + myLabel = '' + endIf + + select case (ERIs%integralType) + case('space') + tmpaaaa = dagger(ERIs%getblock('aaaa')) + call mqc_twoeris_allocate(ERIsOut,myLabel,'space',tmpaaaa)!, & + ! nDimA1=size(integral,'alpha',2),nDimA2=size(integral,'alpha',1),& + ! nDimB1=size(integral,'beta',2),nDimB2=size(integral,'beta',1)) + case('spin') + tmpaaaa = dagger(ERIs%getblock('aaaa')) + tmpaabb = dagger(ERIs%getblock('bbaa')) + tmpbbaa = dagger(ERIs%getblock('aabb')) + tmpbbbb = dagger(ERIs%getblock('bbbb')) + call mqc_twoeris_allocate(ERIsOut,myLabel,'spin',tmpaaaa,tmpbbbb,tmpaabb,tmpbbaa)!, & + case('general') + tmpaaaa = dagger(ERIs%getblock('aaaa')) + tmpaabb = dagger(ERIs%getblock('bbaa')) + tmpbbaa = dagger(ERIs%getblock('aabb')) + tmpbbbb = dagger(ERIs%getblock('bbbb')) + tmpaaab = dagger(ERIs%getblock('baaa')) + tmpaaba = dagger(ERIs%getblock('abaa')) + tmpabaa = dagger(ERIs%getblock('aaba')) + tmpbaaa = dagger(ERIs%getblock('aaab')) + tmpabab = dagger(ERIs%getblock('baba')) + tmpbaab = dagger(ERIs%getblock('baab')) + tmpbaba = dagger(ERIs%getblock('abab')) + tmpabba = dagger(ERIs%getblock('abba')) + tmpabbb = dagger(ERIs%getblock('bbba')) + tmpbabb = dagger(ERIs%getblock('bbab')) + tmpbbab = dagger(ERIs%getblock('babb')) + tmpbbba = dagger(ERIs%getblock('abbb')) + call mqc_twoeris_allocate(ERIsOut,myLabel,'general',tmpaaaa,tmpbbbb,tmpaabb,tmpbbaa,& + tmpabab,tmpabba,tmpbaab,tmpbaba,& + tmpaaab,tmpaaba,tmpabaa,tmpbaaa,& + tmpbbba,tmpbbab,tmpbabb,tmpabbb) + case default + call mqc_error_A('Unknown integral type in mqc_twoERIs_conjugate_transpose', 6, & + 'ERIs%integralType', ERIs%integralType ) + end select +! + end function mqc_twoeris_conjugate_transpose +! ! ! PROCEDURE MQC_Integral_Outer From f09b9829e2959ab32436e403800caf404674d79b Mon Sep 17 00:00:00 2001 From: Lee Thompson Date: Thu, 25 Sep 2025 12:00:46 -0400 Subject: [PATCH 08/37] Added some vector routines and changed trci string generator to allow return of only HF string. --- src/mqc_algebra.F03 | 269 +++++++++++++++++++++++++++++++++++++++++++- src/mqc_est.F03 | 148 +++++++++++++++++++----- 2 files changed, 389 insertions(+), 28 deletions(-) diff --git a/src/mqc_algebra.F03 b/src/mqc_algebra.F03 index 753cf048..e7252c96 100644 --- a/src/mqc_algebra.F03 +++ b/src/mqc_algebra.F03 @@ -152,6 +152,8 @@ Module MQC_Algebra Procedure, Public::pop => MQC_Vector_Pop !> \brief Removes the first element of the MQC_Vector and returns the value Procedure, Public::shift => MQC_Vector_Shift +!> \brief Returns a vector of elements that meet a logical criteria + Procedure, Public::pack => MQC_Vector_Pack !> \brief Returns the maximum value in the MQC_Vector Procedure, Public::maxval => MQC_Vector_MaxVal !> \brief Returns the minimum value in the MQC_Vector @@ -165,6 +167,8 @@ Module MQC_Algebra !> \brief Returns the MQC_Vector sorted from low to high unless vector specifying !> index order is provided Procedure, Public::sort => MQC_Vector_sort +!> \brief Returns the sorted MQC_Vector with unique elements + Procedure, Public::unique => MQC_Vector_unique !> \brief Returns the square root of each element in the MQC_Vector Procedure, Public::sqrt => MQC_Vector_Sqrt !> \brief Returns the exponential of the MQC Vector @@ -220,7 +224,7 @@ Module MQC_Algebra Procedure, Public::norm => MQC_Matrix_Norm !> \brief Returns the transpose of the MQC Matrix Procedure, Public::transpose => MQC_Matrix_Transpose -!> \brief Returns the Hemitian transpose of the MQC Matrix +!> \brief Returns the Hermitian transpose of the MQC Matrix Procedure, Public::dagger => MQC_Matrix_Conjugate_Transpose !> \brief Returns the eigenvalues and eigenvalues of a symmetric or !> hermitian MQC Matrix @@ -369,6 +373,7 @@ Module MQC_Algebra !> \brief Returns the object as an integer intrinsic Interface int Module Procedure MQC_Scalar_Get_Intrinsic_Integer + Module Procedure MQC_Set_Vector2IntegerArray_Func End Interface ! !> \brief Determines in an array is real type @@ -461,6 +466,16 @@ Module MQC_Algebra Module Procedure MQC_Vector_MinLoc End Interface ! +!> \brief Sorts an MQC_Vector + Interface sort + Module Procedure MQC_Vector_Sort + End Interface +! +!> \brief Unique sort of an MQC_Vector + Interface unique + Module Procedure MQC_Vector_Unique + End Interface +! !> \brief Returns the square root Interface Sqrt Module Procedure MQC_Scalar_Sqrt @@ -590,6 +605,11 @@ Module MQC_Algebra Module Procedure MQC_Matrix_Sum End Interface ! +!> \brief Returns the Minkowski sum of the MQC_Vector + Interface Minkowski + Module Procedure MQC_Vector_Minkowski_Sum + End Interface +! !> \brief Reshapes arrays Interface Reshape Module Procedure MQC_Vector_Reshape_Matrix @@ -677,6 +697,11 @@ Module MQC_Algebra module procedure MQC_Matrix_Initialize_Func end interface ! +!> \brief Returns a vector of elements that meet a logical criteria + interface pack + module procedure MQC_Vector_Pack + end interface +! !---------------------------------------------------------------- ! | ! OPERATOR INTERFACES | @@ -8411,6 +8436,48 @@ Subroutine MQC_Set_Vector2IntegerArray(ArrayOut,VectorIn) End Subroutine MQC_Set_Vector2IntegerArray ! ! +! PROCEDURE MQC_Set_Vector2IntegerArray_Func +! +!> \brief MQC_Set_Vector2IntegerArray_Func is a function that outputs an MQC +!> vector to a rank 1 intrinsic integer array +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_Set_Vector2IntegerArray_Func is a function that outputs an MQC vector to +!> a rank 1 intrinsic integer array. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] VectorIn +!> \verbatim +!> VectorIn is Type(MQC_Vector) +!> The MQC_Vector whose data will be output into the intrinsic +!> array. +!> \endverbatim +! +! Authors: +! ======== +!> \author L. M. Thompson +!> \date 2025 +! + Function MQC_Set_Vector2IntegerArray_Func(VectorIn) Result(ArrayOut) +! +! Variable Declarations. + Implicit None + Integer(kind=int64),Allocatable::ArrayOut(:) + Type(MQC_Vector),Intent(In)::VectorIn +! + ArrayOut = VectorIn +! + Return + End Function MQC_Set_Vector2IntegerArray_Func +! +! ! PROCEDURE MQC_Set_Vector2RealArray ! !> \brief MQC_Set_Vector2RealArray is a subroutine that outputs an MQC @@ -11918,6 +11985,103 @@ Function MQC_Vector_Shift(Vector) result(Output) end function mqc_vector_shift ! ! +! PROCEDURE MQC_Vector_Pack +! +!> \brief MQC_Vector_Pack is a function that returns a vector made up of elements +!> who satisfy a mask condition +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_Vector_Pack is a function that returns a vector made up of elements whose +!> mask condition equals true. Optionally, a vector argument can be provided which +!> is of equal or greater length than the number of true elements in mask, such that +!> the resulting vector will be of the same size as the optional vector agruments +!> with the elements after the true mask elements taken from this vector. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] Vector +!> \verbatim +!> Vector is Class(MQC_Vector) +!> The name of the MQC_Vector variable. +!> \endverbatim +!> +!> \param[in] Mask +!> \verbatim +!> Mask is Logical,Dimension(:) +!> The mask vector of the same length as the +!> input vector. +!> \endverbatim +!> +!> \param[in] Padding +!> \verbatim +!> Padding is Type(MQC_Vector),Optional +!> The pad vector which must be equal or +!> greater in size to the number of true +!> elements in mask. +!> \endverbatim +!> +! Authors: +! ======== +!> \author L. M. Thompson +!> \date 2025 +! + Function MQC_Vector_Pack(Vector,Mask,Padding) result(Output) +! +! Variable Declarations. + implicit none + class(mqc_vector),intent(in)::vector + logical,dimension(:),intent(in)::mask + type(mqc_vector),optional,intent(in)::padding + type(mqc_vector)::output + + integer(kind=int64),dimension(:),allocatable::tempInt,tempInt2 + real(kind=real64),dimension(:),allocatable::tempReal,tempReal2 + complex(kind=real64),dimension(:),allocatable::tempCmplx,tempCmplx2 +! + if(size(mask).ne.size(vector)) & + call mqc_error_i('mask and vector dimensions are inconsistent in mqc_vector_pack',& + 6,'size(vector)',size(vector),'size(mask)',size(mask)) + + select case(vector%data_type) + case('Integer') + tempInt = vector + if(present(padding)) then + tempInt2 = padding + output = pack(tempInt,mask,tempInt2) + else + output = pack(tempInt,mask) + endIf + case('Real') + tempReal = vector + if(present(padding)) then + tempReal2 = padding + output = pack(tempReal,mask,tempReal2) + else + output = pack(tempReal,mask) + endIf + case('Complex') + tempCmplx = vector + if(present(padding)) then + tempCmplx2 = padding + output = pack(tempCmplx,mask,tempCmplx2) + else + output = pack(tempCmplx,mask) + endIf + case default + call mqc_error_a('Unrecognized data type in mqc_vector_pack',6,'vector%data_type',& + vector%data_type) + end select +! + return + end function mqc_vector_pack +! +! ! PROCEDURE MQC_Vector_MaxVal ! !> \brief MQC_Vector_MaxVal is a function that returns the largest value in @@ -12181,6 +12345,56 @@ Function MQC_Vector_ArgSort(Vector) result(Output) end function mqc_vector_argsort ! ! +! PROCEDURE MQC_Vector_Unique +! +!> \brief MQC_Vector_Unique is a function that returns a sorted MQC +!> vector with unique elements +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_Vector_Unique is a function that returns a sorted MQC vector with unique +!> elements. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] Vector +!> \verbatim +!> Vector is Class(MQC_Vector) +!> The name of the MQC_Vector variable. +!> \endverbatim +!> +! +! Authors: +! ======== +!> \author L. M. Thompson +!> \date 2025 +! + Function MQC_Vector_Unique(Vector) result(VecOut) +! +! Variable Declarations. + implicit none + class(mqc_vector),intent(in)::vector + type(mqc_vector)::VecOut + + type(mqc_vector)::tmpVec + integer::i +! + tmpVec = vector + call sort(tmpVec) + call vecOut%push(tmpVec%at(1)) + do i = 2, size(tmpVec) + if(tmpVec%at(i).ne.tmpVec%at(i-1)) call vecOut%push(tmpVec%at(i)) + endDo +! + return + end function mqc_vector_unique +! +! ! PROCEDURE MQC_Vector_Sort ! !> \brief MQC_Vector_Sort is a function that returns an MQC vector sorted @@ -12912,6 +13126,59 @@ function mqc_vector_product(A) result(output) end function mqc_vector_product ! ! +! PROCEDURE MQC_Vector_Minkowski_Sum +! +!> \brief MQC_Vector_Minkowski_Sum is a function that returns the Minkowski sum +!> of two MQC vectors +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_Vector_Minkowski_Sum is a function that returns the Minkowski sum of two MQC +!> vectors. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] A +!> \verbatim +!> A is Class(MQC_Vector) +!> The name of the first MQC_Vector variable. +!> \endverbatim +!> +!> \param[in] B +!> \verbatim +!> B is Class(MQC_Vector) +!> The name of the second MQC_Vector variable. +!> \endverbatim +! +! Authors: +! ======== +!> \author L. M. Thompson +!> \date 2025 +! + function mqc_vector_minkowski_sum(A,B) result(output) +! + Implicit None + class(mqc_vector),intent(in)::A,B + type(mqc_vector)::output + integer(kind=int64)::i,j +! +! Do the work. +! + call output%init(size(A)*size(B)) + do i=1,size(A) + do j=1,size(B) + call output%put(A%at(i)+B%at(j),(i-1)*size(A)+j) + endDo + endDo +! + end function mqc_vector_minkowski_sum +! +! ! PROCEDURE MQC_Vector_Complex_Conjugate ! !> \brief MQC_Vector_Complex_Conjugate is a function that returns the complex conjugate diff --git a/src/mqc_est.F03 b/src/mqc_est.F03 index 2dc4ccc1..5ef39c85 100644 --- a/src/mqc_est.F03 +++ b/src/mqc_est.F03 @@ -319,6 +319,7 @@ Module MQC_EST interface Allocated module procedure mqc_eigenvalues_isAllocated module procedure mqc_integral_isAllocated + module procedure mqc_determinant_isAllocated end interface ! !> \brief Multiplies two objects @@ -1195,6 +1196,48 @@ Function MQC_Eigenvalues_isAllocated(Eigenvalues) Result(isAllocated) End Function MQC_Eigenvalues_isAllocated ! ! +! PROCEDURE MQC_Determinant_isAllocated +! +!> \brief MQC_Determinant_isAllocated is a function that returns TRUE if an MQC +!> determinant object is allocated and FALSE if it is not +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_Determinant_isAllocated is a function that returns TRUE if an MQC determinant +!> object is allocated and FALSE if it is not. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] Determinant +!> \verbatim +!> Integral is Class(MQC_Determinant) +!> The name of the MQC_Determinant variable. +!> \endverbatim +! +! Authors: +! ======== +!> \author L. M. Thompson +!> \date 2025 +! + Function MQC_Determinant_isAllocated(Determinant) Result(isAllocated) +! + Implicit None + Class(MQC_Determinant),Intent(In)::Determinant + Logical::isAllocated +! + isAllocated = .False. + If(allocated(Determinant%Strings%Alpha)) isAllocated = .True. + If(allocated(Determinant%Strings%Beta)) isAllocated = .True. +! + Return + End Function MQC_Determinant_isAllocated +! +! ! PROCEDURE MQC_Integral_Has_Alpha ! !> \brief MQC_Integral_Has_Alpha is a function that returns TRUE if an MQC EST @@ -16117,8 +16160,8 @@ subroutine TRCI_DETS_STRING(iOut,iPrint,nBasisIn,nAlphaIn,nBetaIn,& arrStart,arrEnd,holeStart,partStart,holeInd,partInd type(mqc_bits),dimension(:),allocatable::Alpha_Strings,Beta_Strings integer(kind=int64),dimension(:),intent(in)::substitutions + integer(kind=int64),dimension(:),allocatable::subs type(mqc_bits)::initstr - type(mqc_vector)::subs type(mqc_matrix)::alpha_arr_hole,alpha_arr_part,beta_arr_hole,beta_arr_part type(mqc_vector)::nums_alpha_hole,nums_alpha_part,nums_beta_hole,& nums_beta_part,nah,nap,nbh,nbp @@ -16182,7 +16225,24 @@ subroutine TRCI_DETS_STRING(iOut,iPrint,nBasisIn,nAlphaIn,nBetaIn,& else nVirt = 0 endIf - call trci_dets_arr(nBasis,nAlpha,nBeta,substitutions,alpha_arr_hole, & + + if(any(substitutions.ge.1).and.any(substitutions.eq.0)) then + if(allocated(subs)) deallocate(subs) + allocate(subs(size(substitutions)-1)) + j = 1 + do i = 1, size(substitutions) + if(substitutions(i).ne.0) then + subs(j) = substitutions(i) + j = j+ 1 + endIf + endDo + elseIf(any(substitutions.eq.0)) then + subs = [0] + else + subs = substitutions + endIf + if(any(substitutions.ge.1)) & + call trci_dets_arr(nBasis,nAlpha,nBeta,subs,alpha_arr_hole, & alpha_arr_part,beta_arr_hole,beta_arr_part,nah,nap,nbh,nbp) ! ! Initialize Arrays @@ -16289,15 +16349,15 @@ subroutine TRCI_DETS_STRING(iOut,iPrint,nBasisIn,nAlphaIn,nBetaIn,& determinants%nVirt = nVirt determinants%NBasis = NBasis+nCore+nVirt call determinants%nSubsAlpha%init(maxval(substitutions)+1,0) - call determinants%nSubsAlpha%put(1,1) - do i = 1, size(substitutions) - call determinants%nSubsAlpha%put(nah%at(i)*nap%at(i),substitutions(i)+1) - endDo call determinants%nSubsBeta%init(maxval(substitutions)+1,0) + call determinants%nSubsAlpha%put(1,1) call determinants%nSubsBeta%put(1,1) - do i = 1, size(substitutions) - call determinants%nSubsBeta%put(nbh%at(i)*nbp%at(i),substitutions(i)+1) - endDo + if(any(substitutions.ge.1)) then + do i = 1, size(subs) + call determinants%nSubsAlpha%put(nah%at(i)*nap%at(i),subs(i)+1) + call determinants%nSubsBeta%put(nbh%at(i)*nbp%at(i),subs(i)+1) + endDo + endIf deallocate(alpha_strings,beta_strings) ! @@ -16349,7 +16409,7 @@ end subroutine TRCI_DETS_STRING !> \param[in] Substitutions !> \verbatim !> Substitutions is Type(MQC_Vector) -!> The number of beta electrons. +!> The substitution levels requested. !> \endverbatim !> !> \param[out] Alpha_Arr_Hole @@ -16642,23 +16702,54 @@ end subroutine build_trci_ph_list !> String is Type(MQC_Bits) !> The bit string to be analyzed. !> \endverbatim +!> +!> \param[in] Option +!> \verbatim +!> Option is Character(len=*),Optional +!> = 'occupied': returns vector with indices of 1 bits +!> = 'virtual': returns vector with indices of 0 bits +!> = 'sorted': returns vector with indices of 1 bits +!> followed by indices of 0 bits +!> \endverbatim ! ! Authors: ! ======== !> \author L. M. Thompson !> \date 2024 ! - function mqc_detString_to_occArray(string) result(arrayOut) + function mqc_detString_to_occArray(string,option) result(arrayOut) implicit none type(mqc_bits),intent(in)::string integer(kind=int64),dimension(:),allocatable::arrayOut + character(len=*),optional,intent(in)::option - integer::nBitInts,temp_int,i,j,nBasis + integer::i,j,iEnd type(mqc_vector)::tmpArray + character(len=64)::myOption - do i = 0, string%nBits-1 - if(btest(string,i)) call tmpArray%push(i+1) + if(present(option)) then + call string_change_case(option,'l',myOption) + else + myOption = 'occupied' + endIf + + if(myOption.eq.'occupied'.or.myOption.eq.'virtual') then + iEnd = 1 + elseIf(myOption.eq.'sorted') then + iEnd = 2 + else + call mqc_error_a('Unrecognized option in mqc_detString_to_occArray',6,& + 'myOption',myOption) + endIf + + do i = 1, iEnd + do j = 0, string%nBits-1 + if((myOption.eq.'occupied'.or.(myOption.eq.'sorted'.and.i.eq.1)).and.btest(string,j)) & + call tmpArray%push(j+1) + if((myOption.eq.'virtual'.or.(myOption.eq.'sorted'.and.i.eq.2)).and..not.btest(string,j)) & + call tmpArray%push(j+1) + endDo endDo allocate(arrayOut(size(tmpArray))) arrayOut = tmpArray @@ -23359,9 +23450,8 @@ Subroutine MQC_SubStrings_At_Index(IOut,IPrint,IndIn,Determinants,SubsA,SubsB,Su type(mqc_vector),Dimension(:),Intent(In)::SubsA,SubsB,SubsT type(MQC_bits),intent(Out)::aString,bString - Integer(kind=int64)::i,j + Integer(kind=int64)::i Integer(kind=int64),Dimension(:),Allocatable::NDets,NDetsA,NDetsB - type(mqc_bits)::alphaStrTemp,betaStrTemp allocate(NDets(Size(Determinants)),NDetsA(Size(Determinants)),& NDetsB(Size(Determinants))) @@ -23369,16 +23459,20 @@ Subroutine MQC_SubStrings_At_Index(IOut,IPrint,IndIn,Determinants,SubsA,SubsB,Su call get_expansion_size(Determinants(i),SubsT(i),SubsA(i),SubsB(i),& NDets(i),NDetsA(i),NDetsB(i)) EndDo - aString = mqc_bits(0) - bString = mqc_bits(0) - Do I = 1, size(determinants) - J = mod((IndIn-1)/product(NDets(1:i-1)),NDets(i))+1 - call mqc_strings_at_index(iout,iprint,j,Determinants(i),subsA(i),SubsB(i),& - SubsT(i),AlphaStrTemp,BetaStrTemp) - aString = MQC_concatenate_bits(alphaStrTemp,aString) - bString = MQC_concatenate_bits(betaStrTemp,bString) - EndDo - Return + + call mqc_get_string_from_substring(iout,iprint,indIn,determinants,nDets,& + subsA,subsB,subsT,aString,bString) + +! aString = mqc_bits(0) +! bString = mqc_bits(0) +! Do I = 1, size(determinants) +! J = mod((IndIn-1)/product(NDets(1:i-1)),NDets(i))+1 +! call mqc_strings_at_index(iout,iprint,j,Determinants(i),subsA(i),SubsB(i),& +! SubsT(i),AlphaStrTemp,BetaStrTemp) +! aString = MQC_concatenate_bits(alphaStrTemp,aString) +! bString = MQC_concatenate_bits(betaStrTemp,bString) +! EndDo +! Return ! End Subroutine MQC_SubStrings_At_Index ! @@ -24025,7 +24119,7 @@ subroutine get_subLevels(Determinants,subsA,subsB,subsAOut,subsBOut,subsTOut) Implicit None Type(MQC_Determinant),Intent(In)::Determinants - integer(kind=int64),dimension(:),allocatable,intent(In)::subsA,subsB + integer(kind=int64),dimension(:),intent(In)::subsA,subsB type(mqc_vector),intent(Out)::subsAOut,subsBOut,subsTOut integer(kind=int64)::i,j From 4513797f50485d3942fbbed0a856d9e35f5ac238 Mon Sep 17 00:00:00 2001 From: Lee Thompson Date: Thu, 25 Sep 2025 13:19:52 -0400 Subject: [PATCH 09/37] Fixed bug in vector of vector assignments --- src/mqc_algebra.F03 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/mqc_algebra.F03 b/src/mqc_algebra.F03 index e7252c96..7ddde935 100644 --- a/src/mqc_algebra.F03 +++ b/src/mqc_algebra.F03 @@ -193,7 +193,7 @@ Module MQC_Algebra !> \brief Vector of Vectors variable Type MQC_VoV Type(MQC_Vector),Public::Vector - Type(MQC_VoV),Public,Dimension(:),Allocatable::VoV + Type(MQC_VoV),Public,Dimension(:),Pointer::VoV=>null() End Type MQC_VoV ! ! Matrices... From 555986a79907a8d98bc81844e87f1eb95c7b99e6 Mon Sep 17 00:00:00 2001 From: Matheus Moraes Date: Wed, 22 Oct 2025 14:33:50 -0400 Subject: [PATCH 10/37] Complex-Matrix multiplication bugfix --- src/mqc_algebra.F03 | 91 +++++++++++++++++++++++++++------------------ src/mqc_est.F03 | 10 ++--- 2 files changed, 60 insertions(+), 41 deletions(-) diff --git a/src/mqc_algebra.F03 b/src/mqc_algebra.F03 index 0ff23bc2..18fd17cf 100644 --- a/src/mqc_algebra.F03 +++ b/src/mqc_algebra.F03 @@ -22239,8 +22239,8 @@ End Function MQC_Matrix_Symmetrize ! ! Authors: ! ======== -!> \author L. M. Thompson -!> \date 2016 +!> \author L. M. Thompson, M. M. F. Moraes +!> \date 2016, 2025 ! Subroutine MQC_Matrix_Full2Symm(Matrix) ! @@ -22264,11 +22264,12 @@ Subroutine MQC_Matrix_Full2Symm(Matrix) ElseIf(MQC_Matrix_Test_Symmetric(Matrix,'antihermitian')) then label = 'antihermitian' Else - Call MQC_Error_L('Input matrix must be symmetric/antisymmetric/hermitian in MQC_Matrix_Full2Symm', 6, & - 'MQC_Matrix_Test_Symmetric(Matrix)', MQC_Matrix_Test_Symmetric(Matrix), & - "MQC_Matrix_Test_Symmetric(Matrix,'antisymmetric')", MQC_Matrix_Test_Symmetric(Matrix,'antisymmetric'), & - "MQC_Matrix_Test_Symmetric(Matrix,'hermitian')", MQC_Matrix_Test_Symmetric(Matrix,'hermitian'), & - "MQC_Matrix_Test_Symmetric(Matrix,'antihermitian')", MQC_Matrix_Test_Symmetric(Matrix,'antihermitian') ) + Return + !Call MQC_Error_L('Input matrix must be symmetric/antisymmetric/hermitian in MQC_Matrix_Full2Symm', 6, & + ! 'MQC_Matrix_Test_Symmetric(Matrix)', MQC_Matrix_Test_Symmetric(Matrix), & + ! "MQC_Matrix_Test_Symmetric(Matrix,'antisymmetric')", MQC_Matrix_Test_Symmetric(Matrix,'antisymmetric'), & + ! "MQC_Matrix_Test_Symmetric(Matrix,'hermitian')", MQC_Matrix_Test_Symmetric(Matrix,'hermitian'), & + ! "MQC_Matrix_Test_Symmetric(Matrix,'antihermitian')", MQC_Matrix_Test_Symmetric(Matrix,'antihermitian') ) EndIf If(MQC_Matrix_HaveReal(Matrix)) then Allocate(Temp(MQC_Matrix_Rows(Matrix),MQC_Matrix_Columns(Matrix))) @@ -22374,9 +22375,9 @@ Subroutine MQC_Matrix_Symm2Full(Matrix) Integer(kind=int64)::I,J,II,N,NTT Character(len=10)::storage ! - If(.not.(Matrix%Storage.eq.'StorSymm'.or.Matrix%Storage.eq.'StorAsym'.or. & - Matrix%Storage.eq.'StorHerm'.or.Matrix%Storage.eq.'StorAhrm')) & - Call MQC_Error_A('Input matrix must be lower-triangular packed & + If((Matrix%Storage.ne.'StorSymm').and.(Matrix%Storage.ne.'StorAsym').and. & + (Matrix%Storage.ne.'StorHerm').and.(Matrix%Storage.ne.'StorAhrm')) & + Call MQC_Error_A('Input matrix must be lower-triangular packed& & in MQC_Matrix_Symm2Full', 6, 'Matrix%Storage', Matrix%Storage ) N = MQC_Matrix_Columns(Matrix) NTT = (N*(N+1))/2 @@ -22863,8 +22864,8 @@ End Subroutine MQC_Matrix_Diag2Symm ! ! Authors: ! ======== -!> \author X. Sheng -!> \date 2017 +!> \author X. Sheng, M. M. F. Moraes +!> \date 2017, 2025 ! Function MQC_Matrix_Symm2Full_Func(Matrix) Result(Temp) ! @@ -22873,10 +22874,12 @@ Function MQC_Matrix_Symm2Full_Func(Matrix) Result(Temp) Type(MQC_Matrix),Intent(In)::Matrix type(MQC_Matrix)::Temp Integer(kind=int64)::I,J,II,N -! - If(.not.Matrix%Storage.eq.'StorSymm') Call MQC_Error_A('Input matrix must be & - & lower-triangular packed in MQC_Matrix_Symm2Full', 6, & - 'Matrix%Storage', Matrix%Storage ) + + If((Matrix%Storage.ne.'StorSymm').and.(Matrix%Storage.ne.'StorAsym').and. & + (Matrix%Storage.ne.'StorHerm').and.(Matrix%Storage.ne.'StorAhrm')) & + Call MQC_Error_A('Input matrix must be & + &lower-triangular packed in MQC_Matrix_Symm2Full_Func', 6, & + 'Matrix%Storage', Matrix%Storage ) N = MQC_Matrix_Columns(Matrix) Call MQC_Allocate_Matrix(Matrix%NRow,Matrix%NCol,Temp,Matrix%Data_Type,'StorFull') If(Matrix%Data_Type.eq.'Real') then @@ -25115,27 +25118,35 @@ End Function MQC_MatrixRealProduct ! ! Authors: ! ======== -!> \author L. M. Thompson -!> \date 2019 +!> \author L. M. Thompson, M. M. F. Moraes +!> \date 2019, 2025 ! Function MQC_ComplexMatrixProduct(Comp,Matrix) Result(Matrix_Res) ! Implicit None Complex(kind=real64),Intent(In)::Comp Type(MQC_Matrix),Intent(In)::Matrix - Type(MQC_Matrix)::Matrix_Res + Type(MQC_Matrix)::Matrix_Res,TmpMatrix Call MQC_Deallocate_Matrix(Matrix_Res) - If (Matrix%Data_Type.eq.'Integer') then - Call MQC_Allocate_Matrix(Matrix%NRow,Matrix%NCol,Matrix_Res,'Complex',Matrix%Storage) + Call MQC_Allocate_Matrix(Matrix%NRow,Matrix%NCol,Matrix_Res,'Complex','StorFull') + if (Matrix%Storage.ne.'StorFull') then + TmpMatrix = MQC_Matrix_Symm2Full_Func(Matrix) + if (TmpMatrix%Data_Type.eq.'Integer') then + Matrix_Res%MatC = Comp *TmpMatrix%MatI + else if (TmpMatrix%Data_Type.eq.'Real') then + Matrix_Res%MatC = Comp *TmpMatrix%MatR + else + Matrix_Res%MatC = Comp *TmpMatrix%MatC + end if + else if (Matrix%Data_Type.eq.'Integer') then Matrix_Res%MatC = Comp * Matrix%MatI - Else If (Matrix%Data_Type.eq.'Real') then - Call MQC_Allocate_Matrix(Matrix%NRow,Matrix%NCol,Matrix_Res,'Complex',Matrix%Storage) + else if (Matrix%Data_Type.eq.'Real') then Matrix_Res%MatC = Comp * Matrix%MatR - Else If (Matrix%Data_Type.eq.'Complex') then - Call MQC_Allocate_Matrix(Matrix%NRow,Matrix%NCol,Matrix_Res,'Complex',Matrix%Storage) + else Matrix_Res%MatC = Comp * Matrix%MatC - EndIf + end if + call MQC_Matrix_Full2Symm(Matrix_Res) End Function MQC_ComplexMatrixProduct ! @@ -25171,27 +25182,35 @@ End Function MQC_ComplexMatrixProduct ! ! Authors: ! ======== -!> \author L. M. Thompson -!> \date 2019 +!> \author L. M. Thompson, M. M. F. Moraes +!> \date 2019, 2025 ! Function MQC_MatrixComplexProduct(Matrix,Comp) Result(Matrix_Res) ! Implicit None Complex(kind=real64),Intent(In)::Comp Type(MQC_Matrix),Intent(In)::Matrix - Type(MQC_Matrix)::Matrix_Res + Type(MQC_Matrix)::Matrix_Res,TmpMatrix Call MQC_Deallocate_Matrix(Matrix_Res) - If (Matrix%Data_Type.eq.'Integer') then - Call MQC_Allocate_Matrix(Matrix%NRow,Matrix%NCol,Matrix_Res,'Complex',Matrix%Storage) + Call MQC_Allocate_Matrix(Matrix%NRow,Matrix%NCol,Matrix_Res,'Complex','StorFull') + if (Matrix%Storage.ne.'StorFull') then + TmpMatrix = MQC_Matrix_Symm2Full_Func(Matrix) + if (TmpMatrix%Data_Type.eq.'Integer') then + Matrix_Res%MatC = Comp *TmpMatrix%MatI + else if (TmpMatrix%Data_Type.eq.'Real') then + Matrix_Res%MatC = Comp *TmpMatrix%MatR + else + Matrix_Res%MatC = Comp *TmpMatrix%MatC + end if + else if (Matrix%Data_Type.eq.'Integer') then Matrix_Res%MatC = Comp * Matrix%MatI - Else If (Matrix%Data_Type.eq.'Real') then - Call MQC_Allocate_Matrix(Matrix%NRow,Matrix%NCol,Matrix_Res,'Complex',Matrix%Storage) + else if (Matrix%Data_Type.eq.'Real') then Matrix_Res%MatC = Comp * Matrix%MatR - Else If (Matrix%Data_Type.eq.'Complex') then - Call MQC_Allocate_Matrix(Matrix%NRow,Matrix%NCol,Matrix_Res,'Complex',Matrix%Storage) + else Matrix_Res%MatC = Comp * Matrix%MatC - EndIf + end if + call MQC_Matrix_Full2Symm(Matrix_Res) End Function MQC_MatrixComplexProduct ! diff --git a/src/mqc_est.F03 b/src/mqc_est.F03 index 6ab76179..0bbb66d0 100644 --- a/src/mqc_est.F03 +++ b/src/mqc_est.F03 @@ -15452,10 +15452,10 @@ subroutine mqc_integral_put(integral,element,i,j,spinBlockIn) else if(spinBlock.eq.'beta') then integral = integral%changeType('spin') call integral%beta%put(element,myI,myJ) - elseIf(spinBlock.ne.'alphabeta') then + elseIf(spinBlock.eq.'alphabeta') then integral = integral%changeType('general') call integral%alphabeta%put(element,myI,myJ) - elseIf(spinBlock.ne.'betaalpha') then + elseIf(spinBlock.eq.'betaalpha') then integral = integral%changeType('general') call integral%betaalpha%put(element,myI,myJ) endIf @@ -15464,10 +15464,10 @@ subroutine mqc_integral_put(integral,element,i,j,spinBlockIn) if(integral%hasAlpha()) call integral%alpha%put(element,myI,myJ) elseif(spinblock.eq.'beta') then if(integral%hasBeta()) call integral%beta%put(element,myI,myJ) - elseIf(spinBlock.ne.'alphabeta') then + elseIf(spinBlock.eq.'alphabeta') then integral = integral%changeType('general') call integral%alphabeta%put(element,myI,myJ) - elseIf(spinBlock.ne.'betaalpha') then + elseIf(spinBlock.eq.'betaalpha') then integral = integral%changeType('general') call integral%betaalpha%put(element,myI,myJ) endIf @@ -21535,7 +21535,7 @@ function mqc_twoeris_conjugate_transpose(ERIs,label) result(ERIsOut) if(present(label)) then call string_change_case(label,'l',myLabel) else - myLabel = '' + myLabel = 'full' endIf select case (ERIs%integralType) From 5bb1c5c461024e57378f924572dba22200a2d0c5 Mon Sep 17 00:00:00 2001 From: Lee Thompson Date: Tue, 16 Dec 2025 17:58:42 -0500 Subject: [PATCH 11/37] Updated yaml file to avoid disk full error on commit check. --- .github/workflows/linux.yml | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/.github/workflows/linux.yml b/.github/workflows/linux.yml index f9390904..d1675430 100644 --- a/.github/workflows/linux.yml +++ b/.github/workflows/linux.yml @@ -8,6 +8,13 @@ jobs: runs-on: ubuntu-latest steps: + - name: Free up disk space + run: | + sudo apt-get clean + sudo apt-get autoremove -y + sudo rm -rf /usr/share/dotnet /usr/local/lib/android /opt/ghc + df -h + - name: Checkout repository uses: actions/checkout@v4 From 772e09fbcd6bad3a9c1a3a238fb2718fd1e0782f Mon Sep 17 00:00:00 2001 From: Lee Thompson Date: Tue, 16 Dec 2025 18:04:44 -0500 Subject: [PATCH 12/37] Updated yaml file to avoid disk full error on commit check 2 --- .github/workflows/linux.yml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/.github/workflows/linux.yml b/.github/workflows/linux.yml index d1675430..ccfb3968 100644 --- a/.github/workflows/linux.yml +++ b/.github/workflows/linux.yml @@ -9,11 +9,11 @@ jobs: steps: - name: Free up disk space - run: | - sudo apt-get clean - sudo apt-get autoremove -y - sudo rm -rf /usr/share/dotnet /usr/local/lib/android /opt/ghc - df -h + run: | + sudo apt-get clean + sudo apt-get autoremove -y + sudo rm -rf /usr/share/dotnet /usr/local/lib/android /opt/ghc + df -h - name: Checkout repository uses: actions/checkout@v4 From 7183897d0d23e4c462cef699d69a7edd76a0323b Mon Sep 17 00:00:00 2001 From: Lee Thompson Date: Wed, 7 Jan 2026 14:21:17 -0500 Subject: [PATCH 13/37] Changes to matrix pad routine --- src/mqc_algebra.F03 | 22 +++++++++++----------- src/mqc_est.F03 | 6 +++--- 2 files changed, 14 insertions(+), 14 deletions(-) diff --git a/src/mqc_algebra.F03 b/src/mqc_algebra.F03 index c67a425e..e34fbc2b 100644 --- a/src/mqc_algebra.F03 +++ b/src/mqc_algebra.F03 @@ -15170,7 +15170,7 @@ Recursive Subroutine MQC_Matrix_Vector_Put(Mat,VectorIn,Rows,Cols) If(Column) Mat%MatC(IndI:IndJ,IndK) = VectorIn%VecC If(.not.Column) Mat%MatC(IndK,IndI:IndJ) = VectorIn%VecC Else - Call MQC_Error_A('VectorIn type not defined in MQC_Vector_Vector_Put', 6, & + Call MQC_Error_A('VectorIn type not defined in MQC_Matrix_Vector_Put', 6, & 'VectorIn%Data_Type', VectorIn%Data_Type ) EndIf ElseIf (Mat%Data_Type.eq.'Real') then @@ -15185,7 +15185,7 @@ Recursive Subroutine MQC_Matrix_Vector_Put(Mat,VectorIn,Rows,Cols) If(Column) Mat%MatC(IndI:IndJ,IndK) = VectorIn%VecC If(.not.Column) Mat%MatC(IndK,IndI:IndJ) = VectorIn%VecC Else - Call MQC_Error_A('VectorIn type not defined in MQC_Vector_Vector_Put', 6, & + Call MQC_Error_A('VectorIn type not defined in MQC_Matrix_Vector_Put', 6, & 'VectorIn%Data_Type', VectorIn%Data_Type ) EndIf ElseIf (Mat%Data_Type.eq.'Complex') then @@ -15199,11 +15199,11 @@ Recursive Subroutine MQC_Matrix_Vector_Put(Mat,VectorIn,Rows,Cols) If(Column) Mat%MatC(IndI:IndJ,IndK) = VectorIn%VecC If(.not.Column) Mat%MatC(IndK,IndI:IndJ) = VectorIn%VecC Else - Call MQC_Error_A('VectorIn type not defined in MQC_Vector_Vector_Put', 6, & + Call MQC_Error_A('VectorIn type not defined in MQC_Matrix_Vector_Put', 6, & 'VectorIn%Data_Type', VectorIn%Data_Type ) EndIf Else - Call MQC_Error_A('Mat type not defined in MQC_Vector_Vector_Put', 6, & + Call MQC_Error_A('Mat type not defined in MQC_Matrix_Vector_Put', 6, & 'Mat%Data_Type', Mat%Data_Type ) EndIf ElseIf (Mat%Storage.eq.'StorSymm') then @@ -16454,7 +16454,7 @@ Recursive Subroutine MQC_Matrix_Matrix_Put(Mat,MatrixIn,Rows,Cols) 'MatrixIn%Storage', MatrixIn%Storage ) EndIf Else - Call MQC_Error_A('MatrixIn type not defined in MQC_Vector_Vector_Put', 6, & + Call MQC_Error_A('MatrixIn type not defined in MQC_Matrix_Matrix_Put', 6, & 'MatrixIn%Data_Type', MatrixIn%Data_Type ) EndIf ElseIf (Mat%Data_Type.eq.'Real') then @@ -16607,7 +16607,7 @@ Recursive Subroutine MQC_Matrix_Matrix_Put(Mat,MatrixIn,Rows,Cols) 'MatrixIn%Storage', MatrixIn%Storage ) EndIf Else - Call MQC_Error_A('MatrixIn type not defined in MQC_Vector_Vector_Put', 6, & + Call MQC_Error_A('MatrixIn type not defined in MQC_Matrix_Matrix_Put', 6, & 'MatrixIn%Data_Type', MatrixIn%Data_Type ) EndIf ElseIf (Mat%Data_Type.eq.'Complex') then @@ -16759,11 +16759,11 @@ Recursive Subroutine MQC_Matrix_Matrix_Put(Mat,MatrixIn,Rows,Cols) 'MatrixIn%Storage', MatrixIn%Storage) EndIf Else - Call MQC_Error_A('MatrixIn type not defined in MQC_Vector_Vector_Put', 6, & + Call MQC_Error_A('MatrixIn type not defined in MQC_Matrix_Matrix_Put', 6, & 'MatrixIn%Data_Type', MatrixIn%Data_Type ) EndIf Else - Call MQC_Error_A('Mat type not defined in MQC_Vector_Vector_Put', 6, & + Call MQC_Error_A('Mat type not defined in MQC_Matrix_Matrix_Put', 6, & 'Mat%Data_Type', Mat%Data_Type ) EndIf ElseIf (Mat%Storage.eq.'StorSymm') then @@ -16864,19 +16864,19 @@ function MQC_Matrix_Pad(Matrix,Rows,Cols) result(MatrixOut) if (Rows.le.Matrix%NRow) then if (Cols.le.Matrix%NCol) then MatrixOut = Matrix + return else call MatrixOut%init(Matrix%NRow,Cols) - call MatrixOut%mput(Matrix,[1,Matrix%NRow],[1,Matrix%NCol]) end if else if (Cols.le.Matrix%NCol) then call MatrixOut%init(Rows,Matrix%NCol) - call MatrixOut%mput(Matrix,[1,Matrix%NRow],[1,Matrix%NCol]) else call MatrixOut%init(Rows,Cols) - call MatrixOut%mput(Matrix,[1,Matrix%NRow],[1,Matrix%NCol]) end if end if + if(Matrix%NRow.gt.0.and.Matrix%NCol.gt.0) & + call MatrixOut%mput(Matrix,[1,Matrix%NRow],[1,Matrix%NCol]) ! end function MQC_Matrix_Pad ! diff --git a/src/mqc_est.F03 b/src/mqc_est.F03 index 2752c749..46f18f34 100644 --- a/src/mqc_est.F03 +++ b/src/mqc_est.F03 @@ -16833,7 +16833,7 @@ Subroutine Gen_Det_Str(IOut,IPrint,NBasisIn,NAlphaIn,NBetaIn, & ! Add core strings if NCore present ! if(present(NCoreIn)) then - Write(iOut,'(A,I4,A)') ' Adding ',NCore,' core orbitals to string' + If(IPrint.ge.4) Write(iOut,'(A,I4,A)') ' Adding ',NCore,' core orbitals to string' alpha_core = mqc_bits(nCore) Do I = 0, NCore-1 Alpha_Core = IBSet(Alpha_Core,I) @@ -17049,7 +17049,7 @@ subroutine TRCI_DETS_STRING(iOut,iPrint,nBasisIn,nAlphaIn,nBetaIn,& class default call mqc_error('NCoreIn type is not integer or MQC scalar') end Select - write(iOut,'(A,I4,A)') ' Adding ',nCore,' core orbitals to string.' + If(IPrint.ge.4) write(iOut,'(A,I4,A)') ' Adding ',nCore,' core orbitals to string.' else nCore = 0 endIf @@ -17063,7 +17063,7 @@ subroutine TRCI_DETS_STRING(iOut,iPrint,nBasisIn,nAlphaIn,nBetaIn,& class default call mqc_error('NVirtIn type is not integer or MQC scalar') end Select - write(iOut,'(A,I4,A)') ' Adding ',nVirt,' virtual orbitals to string.' + If(IPrint.ge.4) write(iOut,'(A,I4,A)') ' Adding ',nVirt,' virtual orbitals to string.' else nVirt = 0 endIf From 566cd2f68d098e0877d5eb5aed64037520927645 Mon Sep 17 00:00:00 2001 From: Matheus Moraes Date: Fri, 16 Jan 2026 15:12:32 -0500 Subject: [PATCH 14/37] Fixes in complex-related operations --- examples/fullci/OUTPUT/out | 52 -------------------------------------- src/mqc_algebra.F03 | 16 ++++++++---- src/mqc_est.F03 | 3 ++- 3 files changed, 13 insertions(+), 58 deletions(-) diff --git a/examples/fullci/OUTPUT/out b/examples/fullci/OUTPUT/out index d1843c79..11fa17d8 100644 --- a/examples/fullci/OUTPUT/out +++ b/examples/fullci/OUTPUT/out @@ -140,58 +140,6 @@ Complex = F 1 2 1 -0.572516 0.000000 2 0.000000 -0.572319 - Doing O(N**5) integral transformation algorithm - Transformed MO 2ERIs (aa|aa) - ( 1, 1| 1, 1) = 0.44017177 - ( 1, 1| 1, 2) = 0.00000000 - ( 1, 1| 2, 1) = 0.00000000 - ( 1, 1| 2, 2) = 0.44022069 - ( 1, 2| 1, 1) = 0.00000000 - ( 1, 2| 1, 2) = 0.33438525 - ( 1, 2| 2, 1) = 0.33438525 - ( 1, 2| 2, 2) = 0.00000000 - ( 2, 1| 1, 1) = 0.00000000 - ( 2, 1| 1, 2) = 0.33438525 - ( 2, 1| 2, 1) = 0.33438525 - ( 2, 1| 2, 2) = 0.00000000 - ( 2, 2| 1, 1) = 0.44022069 - ( 2, 2| 1, 2) = 0.00000000 - ( 2, 2| 2, 1) = 0.00000000 - ( 2, 2| 2, 2) = 0.44026964 - Transformed MO 2ERIs (bb|bb) - ( 1, 1| 1, 1) = 0.44017177 - ( 1, 1| 1, 2) = 0.00000000 - ( 1, 1| 2, 1) = 0.00000000 - ( 1, 1| 2, 2) = 0.44022069 - ( 1, 2| 1, 1) = 0.00000000 - ( 1, 2| 1, 2) = 0.33438525 - ( 1, 2| 2, 1) = 0.33438525 - ( 1, 2| 2, 2) = 0.00000000 - ( 2, 1| 1, 1) = 0.00000000 - ( 2, 1| 1, 2) = 0.33438525 - ( 2, 1| 2, 1) = 0.33438525 - ( 2, 1| 2, 2) = 0.00000000 - ( 2, 2| 1, 1) = 0.44022069 - ( 2, 2| 1, 2) = 0.00000000 - ( 2, 2| 2, 1) = 0.00000000 - ( 2, 2| 2, 2) = 0.44026964 - Transformed MO 2ERIs (aa|bb) - ( 1, 1| 1, 1) = 0.44017177 - ( 1, 1| 1, 2) = 0.00000000 - ( 1, 1| 2, 1) = 0.00000000 - ( 1, 1| 2, 2) = 0.44022069 - ( 1, 2| 1, 1) = 0.00000000 - ( 1, 2| 1, 2) = 0.33438525 - ( 1, 2| 2, 1) = 0.33438525 - ( 1, 2| 2, 2) = 0.00000000 - ( 2, 1| 1, 1) = 0.00000000 - ( 2, 1| 1, 2) = 0.33438525 - ( 2, 1| 2, 1) = 0.33438525 - ( 2, 1| 2, 2) = 0.00000000 - ( 2, 2| 1, 1) = 0.44022069 - ( 2, 2| 1, 2) = 0.00000000 - ( 2, 2| 2, 1) = 0.00000000 - ( 2, 2| 2, 2) = 0.44026964 CI Hamiltonian The matrix being printed is hermitian 1 2 3 4 diff --git a/src/mqc_algebra.F03 b/src/mqc_algebra.F03 index 18fd17cf..7ac723eb 100644 --- a/src/mqc_algebra.F03 +++ b/src/mqc_algebra.F03 @@ -9908,18 +9908,18 @@ Function mqc_outer(VA,VB) result(M) call M%init(VA%length,VB%length,(0.0,0.0)) if (mqc_have_int(VA)) then VC = mqc_cast_complex(VA) - call zgerc(VA%length,VB%length,1.0,VC%vecc,1,VB%vecc,1,M%matc,VA%length) + call zgerc(VA%length,VB%length,1.0,VC%vecc,1,conjg(VB%vecc),1,M%matc,VA%length) elseif (mqc_have_int(VB)) then VC = mqc_cast_complex(VB) - call zgerc(VA%length,VB%length,1.0,VA%vecc,1,VC%vecc,1,M%matc,VA%length) + call zgerc(VA%length,VB%length,1.0,VA%vecc,1,conjg(VC%vecc),1,M%matc,VA%length) elseif (mqc_have_real(VA)) then VC = mqc_cast_complex(VA) - call zgerc(VA%length,VB%length,1.0,VC%vecc,1,VB%vecc,1,M%matc,VA%length) + call zgerc(VA%length,VB%length,1.0,VC%vecc,1,conjg(VB%vecc),1,M%matc,VA%length) elseif (mqc_have_real(VB)) then VC = mqc_cast_complex(VB) - call zgerc(VA%length,VB%length,1.0,VA%vecc,1,VC%vecc,1,M%matc,VA%length) + call zgerc(VA%length,VB%length,1.0,VA%vecc,1,conjg(VC%vecc),1,M%matc,VA%length) else - call zgerc(VA%length,VB%length,1.0,VA%vecc,1,VB%vecc,1,M%matc,VA%length) + call zgerc(VA%length,VB%length,1.0,VA%vecc,1,conjg(VB%vecc),1,M%matc,VA%length) endif endif @@ -33125,6 +33125,7 @@ Function MQC_R4Tensor_Matrix_Contraction(RA,MB,inorder) Result(MC) select case(ib) case(1) tmpR = transpose(RA%mat(vb,va,[i],[j])) + !tmpR = dagger(RA%mat(vb,va,[i],[j])) case(3) tmpR = RA%mat([i],va,vb,[j]) case(4) @@ -33134,8 +33135,10 @@ Function MQC_R4Tensor_Matrix_Contraction(RA,MB,inorder) Result(MC) select case(ib) case(1) tmpR = transpose(RA%mat(vb,[i],va,[j])) + !tmpR = dagger(RA%mat(vb,[i],va,[j])) case(2) tmpR = transpose(RA%mat([i],vb,va,[j])) + !tmpR = dagger(RA%mat([i],vb,va,[j])) case(4) tmpR = RA%mat([i],[j],va,vb) end select @@ -33143,10 +33146,13 @@ Function MQC_R4Tensor_Matrix_Contraction(RA,MB,inorder) Result(MC) select case(ib) case(1) tmpR = transpose(RA%mat(vb,[i],[j],va)) + !tmpR = dagger(RA%mat(vb,[i],[j],va)) case(2) tmpR = transpose(RA%mat([i],vb,[j],va)) + !tmpR = dagger(RA%mat([i],vb,[j],va)) case(3) tmpR = transpose(RA%mat([i],[j],vb,va)) + !tmpR = dagger(RA%mat([i],[j],vb,va)) end select end select call MC%put(Contraction(tmpR,MB),i,j) diff --git a/src/mqc_est.F03 b/src/mqc_est.F03 index 0bbb66d0..4fbf275c 100644 --- a/src/mqc_est.F03 +++ b/src/mqc_est.F03 @@ -3186,7 +3186,8 @@ subroutine mqc_twoeris_transform(twoERIs,integralType,mo_coefficients,mo_coeff_2 type(mqc_r4tensor)::aaaa real(kind=real64),dimension(:),allocatable::aaaaLoc type(mqc_twoERIs)::temp - integer::i,j,k,l,cnt,ip,kp,bs,bsntt,iOut=6,iPrint=4 + integer::i,j,k,l,cnt,ip,kp,bs,bsntt,iOut=6,iPrint=0 + !!! TODO: make iOut and iPrint NOT static values!! call string_change_case(integralType,'l',my_integralType) if(present(transform)) transform = .true. From 2e5683145fee485a79f6e53e6f4f92cd347ebb85 Mon Sep 17 00:00:00 2001 From: Lee Thompson Date: Mon, 9 Feb 2026 17:47:24 -0500 Subject: [PATCH 15/37] Added a few est eigenvalues functions. --- src/mqc_est.F03 | 139 +++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 137 insertions(+), 2 deletions(-) diff --git a/src/mqc_est.F03 b/src/mqc_est.F03 index 46f18f34..bce6d934 100644 --- a/src/mqc_est.F03 +++ b/src/mqc_est.F03 @@ -203,6 +203,8 @@ Module MQC_EST Procedure, Public::maxloc => MQC_Eigenvalues_MaxLoc !> \brief Returns the absolute values of elements in MQC_SCF_Eigenvalues Procedure, Public::abs => MQC_Eigenvalues_Abs +!> \brief Returns a mqc_scf_integral with values specified by the mqc_scf_eigenvalues + Procedure, Public::diagf => mqc_eigenvalues_to_integral End Type ! !> \brief EST intermediates of single determinant wavefunctions @@ -459,6 +461,11 @@ Module MQC_EST Module Procedure MQC_Element_Integral_Multiply End Interface ! +!> \brief Exponentiates a variable to the power of another + Interface Operator (**) + Module Procedure MQC_eigenvalues_Power_func + End Interface +! ! !---------------------------------------------------------------- ! | @@ -16533,6 +16540,134 @@ function mqc_eigenvalues_abs(eigenvalues) result(output) end function mqc_eigenvalues_abs ! ! +! PROCEDURE MQC_Eigenvalues_to_Integral +! +!> \brief MQC_Eigenvalues_to_integral is a function that returns +!> an MQC_SCF_Integral object with the MQC_SCF_Eigenvalues values +!> on the diagonal +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_Eigenvalues_to_integral is a function that returns an +!> MQC_SCF_Integral object with the MQC_SCF_Eigenvalues values +!> on the diagonal. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] Eigenvalues +!> \verbatim +!> Eigenvalues is Class(MQC_Eigenvalues) +!> The name of the MQC_Eigenvalues variable. +!> \endverbatim +! +! Authors: +! ======== +!> \author L. M. Thompson +!> \date 2026 +! + function mqc_eigenvalues_to_integral(eigenvalues) result(output) +! + implicit none + class(mqc_scf_eigenvalues),intent(in)::eigenvalues + type(mqc_scf_integral)::output +! + select case(eigenvalues%array_type) + case('space') + call mqc_integral_allocate(output,'','space',& + MQC_Matrix_DiagMatrix_Put_Vector_Func(eigenvalues%getBlock('alpha'))) + case('spin','general') + call mqc_integral_allocate(output,'','spin',& + MQC_Matrix_DiagMatrix_Put_Vector_Func(eigenvalues%getBlock('alpha')),& + MQC_Matrix_DiagMatrix_Put_Vector_Func(eigenvalues%getBlock('beta'))) + case default + call mqc_error_a('Unrecognized data type in & + &mqc_eigenvalues_to_integral',6,'eigenvalues%array_type',& + eigenvalues%array_type) + end select +! + end function mqc_eigenvalues_to_integral +! +! +! PROCEDURE MQC_Eigenvalues_Power_Func +! +!> \brief MQC_Eigenvalues_Power_Func is a function that returns the value of all +!> elements of an MQC Eigenvalues raised to a power +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_Eigenvalues_Power_Func is a function that returns the value of all elements of +!> an MQC Eigenvalues raised to a power. The power can be integer, real, complex or an +!> MQC scalar. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in,out] A +!> \verbatim +!> A is Class(MQC_SCF_Eigenvalues) +!> The name of the MQC_SCF_Eigenvalues variable. +!> \endverbatim +!> +!> \param[in] P +!> \verbatim +!> P is Class(*) +!> The power to raise elements of the MQC vector. +!> \endverbatim +! +! Authors: +! ======== +!> \author L. M. Thompson +!> \date 2026 +! + function mqc_eigenvalues_power_func(A,P) result(AOut) +! + Implicit None + class(mqc_scf_eigenvalues),intent(in)::A + class(*),intent(in)::P + type(mqc_scf_eigenvalues)::AOut + + type(mqc_scalar)::scalar +! +! Do the work. +! + select type(P) + type is (integer) + scalar = P + type is (real) + scalar = P + type is (complex) + scalar = P + type is (mqc_scalar) + scalar = P + class default + call mqc_error_I('P type not defined in MQC_Eigenvalues_Power_Func',6) + end select +! + AOut = A + call AOut%power(P) +! case select (A%array_type()) +! case ('space') +! AOut%alpha = A%alpha**scalar +! case ('spin','general') +! AOut%alpha = A%alpha**scalar +! AOut%beta = A%beta**scalar +! case default +! call mqc_error_a('Unrecognized A array type in MQC_Eigenvalues_Power_Func',6,& +! 'A%array_type()',A%array_type()) +! end select +! + end function mqc_eigenvalues_power_func +! +! !===================================================================== ! ! POST-SCF ROUTINES @@ -24218,7 +24353,7 @@ Subroutine MQC_Strings_At_Index(IOut,IPrint,IndIn,Determinants,SubsA,SubsB,SubsT ! Figure out what substitution level the index refers to and the start and end strings ! associated with that substitution level ! Compute composite substitution level offset -! X_{k} = sum_{l in Kallowed, l Date: Tue, 17 Feb 2026 17:34:03 -0500 Subject: [PATCH 19/37] Merge with master --- highlight.css | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) create mode 100644 highlight.css diff --git a/highlight.css b/highlight.css new file mode 100644 index 00000000..bbce7f95 --- /dev/null +++ b/highlight.css @@ -0,0 +1,24 @@ +/* Style definition file generated by highlight 4.10, http://www.andre-simon.de/ */ +/* highlight theme: Kwrite Editor */ +body.hl { background-color:#e0eaee; } +pre.hl { color:#000000; background-color:#e0eaee; font-size:10pt; font-family:'Courier New',monospace; white-space: pre-wrap; } +.hl.num { color:#b07e00; } +.hl.esc { color:#ff00ff; } +.hl.sng { color:#bf0303; } +.hl.pps { color:#818100; } +.hl.slc { color:#838183; font-style:italic; } +.hl.com { color:#838183; font-style:italic; } +.hl.ppc { color:#008200; } +.hl.opt { color:#000000; } +.hl.ipl { color:#0057ae; } +.hl.lin { color:#555555; user-select: none; } +.hl.hvr { cursor:help; } +.hl.erm { color:#ff0000; font-weight:bold; border:solid 1px red; margin-left: 3em; } +.hl.err { color:#ff0000; font-weight:bold; } +.hl.kwa { color:#000000; font-weight:bold; } +.hl.kwb { color:#0057ae; } +.hl.kwc { color:#000000; } +.hl.kwd { color:#010181; } +.hl.kwe { color:#0d5bc3; } +.hl.kwf { color:#750dc3; } + From 9b9ae516e3ddfb2bc9a8f29c69cd669b7ded9885 Mon Sep 17 00:00:00 2001 From: Lee Thompson Date: Mon, 16 Mar 2026 12:23:17 -0400 Subject: [PATCH 20/37] Added EST routines for integrals and eigenvalues objects --- src/mqc_algebra.F03 | 11 +- src/mqc_est.F03 | 459 +++++++++++++++++++++++++++++++++++++++++--- 2 files changed, 441 insertions(+), 29 deletions(-) diff --git a/src/mqc_algebra.F03 b/src/mqc_algebra.F03 index e34fbc2b..619b2366 100644 --- a/src/mqc_algebra.F03 +++ b/src/mqc_algebra.F03 @@ -11736,7 +11736,7 @@ Function MQC_Vector_isAllocated(Vector) Result(isAllocated) ! ! Variable Declarations. Implicit None - Class(MQC_Vector),Intent(InOut)::Vector + Class(MQC_Vector),Intent(In)::Vector Logical::isAllocated ! isAllocated = .False. @@ -26721,23 +26721,24 @@ function mqc_matrix_cofactor(a,i,j) result(cofactor) ! integer(kind=int64)::iUse,jUse ! + call a%print(6,'LMTLMT in mqc_matrix_cofactor') if(abs(i).gt.mqc_matrix_rows(a)) & - call mqc_error_i('Badly defined index in mqc_matrix_minor',6,'i',i) + call mqc_error_i('Badly defined index in mqc_matrix_cofactor',6,'i',i) if(abs(j).gt.mqc_matrix_columns(a)) & - call mqc_error_i('Badly defined index in mqc_matrix_minor',6,'j',j) + call mqc_error_i('Badly defined index in mqc_matrix_cofactor',6,'j',j) if(i.lt.0) then iUse = mqc_matrix_rows(a)+i+1 elseif(i.gt.0) then iUse = i else - call mqc_error_i('Badly defined index in mqc_matrix_minor',6,'i',i) + call mqc_error_i('Badly defined index in mqc_matrix_cofactor',6,'i',i) endIf if(j.lt.0) then jUse = mqc_matrix_columns(a)+j+1 elseif(i.gt.0) then jUse = j else - call mqc_error_i('Badly defined index in mqc_matrix_minor',6,'j',j) + call mqc_error_i('Badly defined index in mqc_matrix_cofactor',6,'j',j) endIf cofactor = (-1)**(iUse+jUse)*a%minor(iUse,jUse) diff --git a/src/mqc_est.F03 b/src/mqc_est.F03 index bce6d934..4b561f36 100644 --- a/src/mqc_est.F03 +++ b/src/mqc_est.F03 @@ -101,6 +101,8 @@ Module MQC_EST Procedure, Public::addLabel => mqc_integral_add_name !> \brief Return a new MQC_SCF_Integral object with distinct Array_type Procedure, Public::changeType => mqc_integral_change_type +!> \brief Returns an MQC_SCF_Integral object with maximum symmetry + Procedure, Public::updateType => mqc_integral_update_type !> \brief Return a spin block of MQC_SCF_Integral object as an MQC matrix Procedure, Public::getBlock => mqc_integral_output_block !> \brief Set an MQC_SCF_Integral object as the identity matrix @@ -135,6 +137,7 @@ Module MQC_EST Procedure, Public::setEList => mqc_integral_set_energy_list Procedure, Public::getEList => mqc_integral_get_energy_list Procedure, Public::deleteEList => mqc_integral_delete_energy_list + Procedure, Public::hasEList => mqc_integral_has_energy_list Procedure, Public::ipad => mqc_integral_pad !> \brief Returns the sum of elements in the MQC_Matrix Procedure, Public::esum => MQC_Integral_Sum_Elements @@ -205,6 +208,9 @@ Module MQC_EST Procedure, Public::abs => MQC_Eigenvalues_Abs !> \brief Returns a mqc_scf_integral with values specified by the mqc_scf_eigenvalues Procedure, Public::diagf => mqc_eigenvalues_to_integral +!> \brief Returns the eigenvalues sorted from low to high unless vector specifying +!> index order is provided + Procedure, Public::sort => mqc_eigenvalues_sort End Type ! !> \brief EST intermediates of single determinant wavefunctions @@ -412,6 +418,12 @@ Module MQC_EST module procedure MQC_Integral_Identity_Func end interface ! +!> \brief Returns the eigenvalues sorted from low to high unless vector specifying +!> index order is provided + interface sort + module procedure mqc_eigenvalues_sort + end interface +! ! !---------------------------------------------------------------- ! | @@ -428,6 +440,7 @@ Module MQC_EST Module Procedure MQC_Eigenvalues_Output_Array Module Procedure mqc_2ERIs_output_array Module Procedure mqc_set_integral2integral + Module Procedure mqc_set_eigs2eigs End Interface ! !> \brief Sums two variables @@ -1985,6 +1998,75 @@ function mqc_integral_change_type(integral,newType) result(integralOut) end function mqc_integral_change_type ! ! +! PROCEDURE MQC_Integral_Update_Type +! +!> \brief MQC_Integral_Update_Type is a subroutine that updates an MQC_Integral +!> to a reduced symmetry if possible +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_Integral_Update_Type is a subroutine that updates an MQC_Integral to a reduced +!> symmetry if possible. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] Integral +!> \verbatim +!> Integral is Class(MQC_SCF_Integral) +!> The name of the MQC_SCF_Integral variable. +!> \endverbatim +!> +! +! Authors: +! ======== +!> \author L. M. Thompson +!> \date 2026 +! + subroutine mqc_integral_update_type(integral) +! + implicit none + class(mqc_scf_integral)::integral + real(kind=real64)::zeroThresh + parameter(zeroThresh=1.0e-14) +! + select case(integral%array_Type) + case ('space') + return + case('spin') + if(integral%blockSize('Alpha',1).ne.integral%blockSize('Beta',1).or.& + integral%blockSize('Alpha',2).ne.integral%blockSize('Beta',2)) return + if(MQC_Matrix_Norm(integral%getBlock('aa')-integral%getBlock('bb')).lt.1.0e-14) & + call mqc_integral_allocate(integral,'','space',integral%getBlock('aa')) + return + case('general') + if(integral%blockSize('Alpha',1).eq.integral%blockSize('Beta',1).and.& + integral%blockSize('Alpha',2).eq.integral%blockSize('Beta',2)) then + if(MQC_Matrix_Norm(integral%getBlock('aa')-integral%getBlock('bb')).lt.zeroThresh.and.& + MQC_Matrix_Norm(integral%getBlock('ab')).lt.zeroThresh.and.& + MQC_Matrix_Norm(integral%getBlock('ba')).lt.zeroThresh) then + call mqc_integral_allocate(integral,'','space',integral%getBlock('aa')) + elseIf(MQC_Matrix_Norm(integral%getBlock('ab')).lt.zeroThresh.and.& + MQC_Matrix_Norm(integral%getBlock('ba')).lt.zeroThresh) then + call mqc_integral_allocate(integral,'','spin',integral%getBlock('aa'),integral%getBlock('bb')) + endIf + elseIf(MQC_Matrix_Norm(integral%getBlock('ab')).lt.zeroThresh.and.& + MQC_Matrix_Norm(integral%getBlock('ba')).lt.zeroThresh) then + call mqc_integral_allocate(integral,'','spin',integral%getBlock('aa'),integral%getBlock('bb')) + endIf + return + case default + call mqc_error_A('Unrecognised integral type in mqc_integral_update_type', 6, & + 'integral%array_Type',integral%Array_Type) + end select +! + end subroutine mqc_integral_update_type +! +! ! PROCEDURE MQC_eigenvalues_Add_Name ! !> \brief MQC_Eigenvalues_Add_Name is a function that sets the label of an MQC @@ -6034,6 +6116,57 @@ function mqc_2ERISet_get_erinum(eriSet,ERIType) result(pos) end function mqc_2ERISet_get_erinum ! ! +! PROCEDURE MQC_Set_Eigs2Eigs +! +!> \brief MQC_Set_Eigs2Eigs is used to output an MQC eigenvalues type +!> variable to another MQC eigenvalues type +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_Set_Eigs2Eigs is used to output an MQC eigenvalues type variable to +!> another MQC eigenvalues type. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in,out] EigsOut +!> \verbatim +!> EigsOut is type(mqc_scf_eigenvalues) +!> The MQC eigenvalues variable to output. +!> \endverbatim +!> +!> \param[in] EigsIn +!> \verbatim +!> EigsIn is Class(MQC_SCF_Eigenvalues) +!> MQC eigenvalues variable input. +!> \endverbatim +! +! Authors: +! ======== +!> \author L. M. Thompson +!> \date 2026 +! + subroutine mqc_set_eigs2eigs(eigsOut,eigsIn) +! + implicit none + class(mqc_scf_eigenvalues),intent(in)::eigsIn + type(mqc_scf_eigenvalues),intent(out)::eigsOut +! + EigsOut%Array_Name = EigsIn%Array_Name + EigsOut%Array_Type = EigsIn%Array_Type + + if(allocated(EigsIn%alpha)) & + EigsOut%alpha = EigsIn%alpha + if(allocated(EigsIn%beta)) & + EigsOut%beta = EigsIn%beta +! + end subroutine mqc_set_eigs2eigs +! +! ! PROCEDURE MQC_Set_Integral2Integral ! !> \brief MQC_Set_Integral2Integral is used to output an MQC integral type @@ -9713,7 +9846,7 @@ end function mqc_integral_norm !> \author A. D. Mahler !> \date 2017, 2018 ! - subroutine mqc_matrix_spinBlockGHF(array,nelec,multi,elist) + subroutine mqc_matrix_spinBlockGHF(array,nelec,multi,elist,doRowsIn) ! implicit none integer(kind=int64)::i,j,k,rows,columns,blockSize,acols,bcols,nalphas,nbetas, & @@ -9725,6 +9858,8 @@ subroutine mqc_matrix_spinBlockGHF(array,nelec,multi,elist) character(len=1),dimension(:),allocatable::abarray integer(kind=int64),optional::nelec,multi integer(kind=int64),dimension(:),allocatable,optional::elist + logical,optional,intent(in)::doRowsIn + logical::doRows ! ! Check that both optional arguments are defined or both ! are absent @@ -9732,6 +9867,11 @@ subroutine mqc_matrix_spinBlockGHF(array,nelec,multi,elist) call mqc_error_I('NElectrons, Multiplicity, or energy list missing & & in mqc_matrix_spinBlockGHF', 6) end if + if(present(doRowsIn)) then + doRows = doRowsIn + else + doRows = .true. + endIf ! ! ! Do the work... @@ -9762,21 +9902,25 @@ subroutine mqc_matrix_spinBlockGHF(array,nelec,multi,elist) blockSize = rows/2 allocate(abarray(columns)) if(present(elist)) allocate(elist(columns)) - call tmpMatrix%init(rows,columns) - j = 1 - k = rows/2+1 - do i = 1,rows - if(mod(i,2).eq.1) then - call tmpMatrix%vput(array%vat([i],[0]),[j],[0]) - j = j+1 - elseIf(mod(i,2).eq.0) then - call tmpMatrix%vput(array%vat([i],[0]),[k],[0]) - k = k+1 - else - call mqc_error_i('mqc_matrix_spinBlockGHF is confused.', 6, & - 'mod(i,2)', mod(i,2) ) - endIf - endDo + if(doRows) then + call tmpMatrix%init(rows,columns) + j = 1 + k = rows/2+1 + do i = 1,rows + if(mod(i,2).eq.1) then + call tmpMatrix%vput(array%vat([i],[0]),[j],[0]) + j = j+1 + elseIf(mod(i,2).eq.0) then + call tmpMatrix%vput(array%vat([i],[0]),[k],[0]) + k = k+1 + else + call mqc_error_i('mqc_matrix_spinBlockGHF is confused.', 6, & + 'mod(i,2)', mod(i,2) ) + endIf + endDo + else + tmpMatrix = array + endIf ! ! Begin new column ordering procedure for columns ! and intialize spin ordering array @@ -9915,6 +10059,80 @@ subroutine mqc_matrix_spinBlockGHF(array,nelec,multi,elist) end subroutine mqc_matrix_spinBlockGHF ! ! +! PROCEDURE MQC_Integral_SpinBlockGHF +! +!> \brief MQC_Integral_SpinBlockGHF is used to reorder a mqc_scf_integral +!> object so that it is properly spin blocked +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_Integral_SpinBlockGHF is used to reorder a mqc_scf_integral +!> object so that it is properly spin blocked. Ideally this routine should never +!> be used, but there are cases where a routine cannot know that the output +!> integral should be spin blocked (e.g. SVD) where this routine is required. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in,out] Integral +!> \verbatim +!> Integral is type(mqc_scf_integral) +!> The MQC integral to be spin reordered. +!> \endverbatim +!> +!> \param[in] NElec +!> \verbatim +!> NElec is integer +!> The number of electrons. +!> \endverbatim +!> +!> \param[in] Multi +!> \verbatim +!> Multi is integer +!> The multiplicity. +!> \endverbatim +! +! Authors: +! ======== +!> \author L. M. Thompson +!> \date 2026 +! + subroutine mqc_integral_spinBlockGHF(integral,nelec,multi) +! + implicit none + type(mqc_scf_integral),intent(inOut)::integral + integer(kind=int64),intent(in)::nelec,multi + + integer(kind=int64)::nDimAlpha1=0,nDimAlpha2=0,nDimBeta1=0,nDimBeta2=0 + type(mqc_matrix)::tmpMat,tmpMat2,tmpMat3,tmpMat4 + integer(kind=int64),dimension(:),allocatable::elist +! +! Do the work... +! + if(integral%type().eq.'general') then + nDimAlpha1 = integral%blockSize('alpha',1) + nDimAlpha2 = integral%blockSize('alpha',2) + nDimBeta1 = integral%blockSize('beta',1) + nDimBeta2 = integral%blockSize('beta',2) + tmpMat = integral%getBlock('full') + call mqc_matrix_spinBlockGHF(tmpMat,nelec,multi,elist,.false.) + tmpMat2 = tmpMat%mat([1,NDimAlpha1],[1,NDimAlpha1]) + tmpMat3 = tmpMat%mat([NDimAlpha1+1,-1],[1,NDimAlpha1]) + tmpMat4 = tmpMat%mat([1,NDimAlpha1],[NDimAlpha1+1,-1]) + tmpMat = tmpMat%mat([NDimAlpha1+1,-1],[NDimAlpha1+1,-1]) + call mqc_integral_allocate(integral,'','general',tmpMat2,& + tmpMat,tmpMat3,tmpMat4) + call integral%setEList(elist) + endIf +! + return + end subroutine mqc_integral_spinBlockGHF +! +! ! PROCEDURE MQC_Matrix_UndoSpinBlockGHF_Eigenvalues ! !> \brief MQC_Matrix_UndoSpinBlockGHF_Eigenvalues is used to return a spin @@ -13645,6 +13863,46 @@ subroutine mqc_integral_delete_energy_list(integral) end subroutine mqc_integral_delete_energy_list ! ! +! PROCEDURE MQC_Integral_Has_Energy_List +! +!> \brief MQC_Integral_Has_Energy_List is a function that returns true +!> if the energy list object of an MQC integral is allocated +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_Integral_Has_Energy_List is a function that returns true +!> if the energy list object of an MQC integral is allocated. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] Integral +!> \verbatim +!> Integral is Class(MQC_SCF_Integral) +!> The MQC integral. +!> \endverbatim +! +! Authors: +! ======== +!> \author L. M. Thompson +!> \date 2026 +! + function mqc_integral_has_energy_list(integral) result(hasEList) +! + implicit none + class(mqc_scf_integral)::integral + logical::hasEList + + hasEList = .false. + if(allocated(integral%Energy_List)) hasEList = .true. +! + end function mqc_integral_has_energy_list +! +! ! PROCEDURE MQC_Integral_Sum_Elements ! !> \brief MQC_Integral_Sum_Elements is a function that returns the sum of all elements @@ -15895,13 +16153,14 @@ subroutine mqc_eigenvalues_put(eigenvalues,element,i,spinBlockIn) if(present(spinBlockIn)) then call string_change_case(spinBlockIn,'L',spinBlock) - if(eigenvalues%array_type.eq.'space') then + select case (eigenvalues%array_type) + case ('space') if(spinBlock.eq.'alpha'.or.spinBlock.eq.'beta') then if(eigenvalues%hasAlpha()) call eigenvalues%alpha%put(element,myI) else call mqc_error_A('SpinBlock type not valid in MQC_Integral_Put',6,'SpinBlock',SpinBlock) endIf - elseIf(eigenvalues%array_type.eq.'spin') then + case ('spin','general') if(spinBlock.eq.'alpha') then if(eigenvalues%hasAlpha()) call eigenvalues%alpha%put(element,myI) elseif(spinblock.eq.'beta') then @@ -15909,27 +16168,28 @@ subroutine mqc_eigenvalues_put(eigenvalues,element,i,spinBlockIn) else call mqc_error_A('SpinBlock type not valid in MQC_Integral_Put',6,'SpinBlock',SpinBlock) endIf - else + case default call mqc_error_A('Array type not valid in MQC_Eigenvalues_Put',6,'Array_Type',eigenvalues%array_type) - endIf + end select else - if(eigenvalues%array_type.eq.'space') then + select case (eigenvalues%array_type) + case ('space') if(myI.le.eigenvalues%blockSize('alpha')) then if(eigenvalues%hasAlpha()) call eigenvalues%alpha%put(element,myI) elseIf(myI.gt.eigenvalues%blockSize('alpha')) then myI = myI - eigenvalues%blockSize('alpha') if(eigenvalues%hasAlpha()) call eigenvalues%alpha%put(element,myI) endIf - elseIf(eigenvalues%array_type.eq.'spin') then + case ('spin','general') if(myI.le.eigenvalues%blockSize('alpha')) then if(eigenvalues%hasAlpha()) call eigenvalues%alpha%put(element,myI) elseIf(myI.gt.eigenvalues%blockSize('alpha')) then myI = myI - eigenvalues%blockSize('alpha') if(eigenvalues%hasBeta()) call eigenvalues%beta%put(element,myI) endIf - else + case default call mqc_error_A('Array type not valid in MQC_Eigenvalues_Put',6,'Array_Type',eigenvalues%array_type) - endIf + end select endIf end subroutine mqc_eigenvalues_put @@ -16668,6 +16928,157 @@ function mqc_eigenvalues_power_func(A,P) result(AOut) end function mqc_eigenvalues_power_func ! ! +! PROCEDURE MQC_Eigenvalues_Sort +! +!> \brief MQC_Eigenvalues_Sort is a function that returns the value of all +!> elements of an MQC Eigenvalues sorted from low to high unless optional +!> argument idx is present which gives the new order of the eigenvalues +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_Eigenvalues_Sort is a function that returns the value of all +!> elements of an MQC Eigenvalues sorted from low to high unless optional +!> argument idx is present which gives the new order of the eigenvalues. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in,out] A +!> \verbatim +!> A is Class(MQC_SCF_Eigenvalues) +!> The name of the MQC_SCF_Eigenvalues variable. +!> \endverbatim +!> +!> \param[in] P +!> \verbatim +!> P is Class(*) +!> The power to raise elements of the MQC vector. +!> \endverbatim +! +! Authors: +! ======== +!> \author L. M. Thompson +!> \date 2026 +! + subroutine mqc_eigenvalues_sort(Eigs,idxA,idxB) +! + Implicit None + class(mqc_scf_eigenvalues),intent(inOut)::Eigs + type(mqc_vector),optional,intent(in)::idxA,idxB + type(mqc_scf_eigenvalues)::EigsOut + type(mqc_vector)::tmpVecA,tmpVecB +! +! Do the work. +! + if(present(idxA)) then + if(size(idxA).ne.Eigs%blocksize('alpha')) then + if(size(idxA).ne.Eigs%blocksize('full')) & + call mqc_error_i('idxA must be length of Eigs alpha block or & + &full block',6,'size(idxA)',size(idxA),'Eigs%blocksize("alpha")',& + Eigs%blocksize('alpha'),'Eigs%blocksize("full")',Eigs%blocksize('full')) + if(present(idxB)) & + call mqc_error_i('Combined length of idxA and idxB not equal to full & + &block',6,'size(idxA)',size(idxA),'size(idxB)',size(idxB),& + 'Eigs%blocksize("full")',Eigs%blocksize('full')) + else + if(present(idxB)) then + if(size(idxB).ne.Eigs%blocksize('beta')) & + call mqc_error_i('Combined length of idxA and idxB not equal to full & + &block',6,'size(idxA)',size(idxA),'size(idxB)',size(idxB),& + 'Eigs%blocksize("full")',Eigs%blocksize('full')) + endIf + endIf + endIf + + if(present(idxB)) then + if(size(idxB).ne.Eigs%blocksize('beta')) & + call mqc_error_i('idxB must be length of Eigs beta block',& + 6,'size(idxB)',size(idxB),'Eigs%blocksize("beta")',Eigs%blocksize('beta')) + endIf + + select case (Eigs%type()) + case ('space') + if(present(idxA).and.present(idxB)) then + if(all(int(idxA).eq.int(idxB))) then + tmpVecA = Eigs%getBlock('alpha') + call tmpVecA%sort(idxA) + call mqc_eigenvalues_allocate(EigsOut,'','space',tmpVecA) + else + tmpVecA = Eigs%getBlock('alpha') + tmpVecB = Eigs%getBlock('beta') + call tmpVecA%sort(idxA) + call tmpVecB%sort(idxB) + call mqc_eigenvalues_allocate(EigsOut,'','spin',tmpVecA,tmpVecB) + endIf + elseIf(present(idxA)) then + if(size(idxA).eq.Eigs%blocksize('alpha')) then + tmpVecA = Eigs%getBlock('alpha') + call tmpVecA%sort(idxA) + call mqc_eigenvalues_allocate(EigsOut,'','spin',tmpVecA,& + Eigs%alpha) + else + tmpVecA = Eigs%getBlock('full') + call tmpVecA%sort(idxA) + call mqc_eigenvalues_allocate(EigsOut,'','spin',& + tmpVecA%vat(1,Eigs%blocksize('alpha')),& + tmpVecA%vat(Eigs%blocksize('alpha')+1,-1)) + endIf + elseIf(present(idxB)) then + tmpVecB = Eigs%getBlock('beta') + call tmpVecB%sort(idxB) + call mqc_eigenvalues_allocate(EigsOut,'','spin',Eigs%alpha,& + tmpVecB) + else + tmpVecA = Eigs%getBlock('alpha') + call tmpVecA%sort() + call mqc_eigenvalues_allocate(EigsOut,'','space',tmpVecA) + endIf + case ('spin','general') + if(present(idxA).and.present(idxB)) then + tmpVecA = Eigs%getBlock('alpha') + tmpVecB = Eigs%getBlock('beta') + call tmpVecA%sort(idxA) + call tmpVecB%sort(idxB) + call mqc_eigenvalues_allocate(EigsOut,'','spin',tmpVecA,tmpVecB) + elseIf(present(idxA)) then + if(size(idxA).eq.Eigs%blocksize('alpha')) then + tmpVecA = Eigs%getBlock('alpha') + call tmpVecA%sort(idxA) + call mqc_eigenvalues_allocate(EigsOut,'','spin',tmpVecA,& + Eigs%beta) + else + tmpVecA = Eigs%getBlock('full') + call tmpVecA%sort(idxA) + call mqc_eigenvalues_allocate(EigsOut,'','spin',& + tmpVecA%vat(1,Eigs%blocksize('alpha')),& + tmpVecA%vat(Eigs%blocksize('alpha')+1,-1)) + endIf + elseIf(present(idxB)) then + tmpVecB = Eigs%getBlock('beta') + call tmpVecB%sort(idxB) + call mqc_eigenvalues_allocate(EigsOut,'','spin',Eigs%alpha,& + tmpVecB) + else + tmpVecA = Eigs%getBlock('alpha') + tmpVecB = Eigs%getBlock('beta') + call tmpVecA%sort() + call tmpVecB%sort() + call mqc_eigenvalues_allocate(EigsOut,'','spin',tmpVecA,& + tmpVecB) + endIf + case default + call mqc_error_a('Unrecognized array type in MQC_Eigenvalues_Sort',6,& + 'Eigs%type()',Eigs%type()) + end select + Eigs = EigsOut +! + end subroutine mqc_eigenvalues_sort +! +! !===================================================================== ! ! POST-SCF ROUTINES From d170e9f6e4ab90f32348e3b5695ff0698e37cd8d Mon Sep 17 00:00:00 2001 From: Lee Thompson Date: Fri, 3 Apr 2026 16:35:24 -0400 Subject: [PATCH 21/37] Bug fixes in ERI partial contraction routine --- src/mqc_algebra.F03 | 1 - src/mqc_est.F03 | 44 +++++++++++++++++++++++++++++++++++--------- 2 files changed, 35 insertions(+), 10 deletions(-) diff --git a/src/mqc_algebra.F03 b/src/mqc_algebra.F03 index 619b2366..e63f4fe9 100644 --- a/src/mqc_algebra.F03 +++ b/src/mqc_algebra.F03 @@ -26721,7 +26721,6 @@ function mqc_matrix_cofactor(a,i,j) result(cofactor) ! integer(kind=int64)::iUse,jUse ! - call a%print(6,'LMTLMT in mqc_matrix_cofactor') if(abs(i).gt.mqc_matrix_rows(a)) & call mqc_error_i('Badly defined index in mqc_matrix_cofactor',6,'i',i) if(abs(j).gt.mqc_matrix_columns(a)) & diff --git a/src/mqc_est.F03 b/src/mqc_est.F03 index 4b561f36..0c900c14 100644 --- a/src/mqc_est.F03 +++ b/src/mqc_est.F03 @@ -293,6 +293,8 @@ Module MQC_EST !> \brief Return a spin block of MQC_TwoERIs object as an MQC rank-4 tensor procedure, public:: getBlock => mqc_2eris_output_block procedure, public::type => mqc_eris_array_type +!> \brief Return a specified interaction of a MQC_TwoERIs + procedure, public::interaction => mqc_eri_interaction end type mqc_twoERIs ! ! Parent Type @@ -8856,16 +8858,16 @@ function mqc_integral_integral_outer_product(integralA,integralB) result(ERIsOut endif if(intType.eq.'general') then if(integralA%array_type.eq.'general') then - AlBeA=integralA%getBlock('alphabeta') - BeAlA=integralA%getBlock('betaalpha') + AlBeA=integralA%getBlock('betaalpha') + BeAlA=integralA%getBlock('alphabeta') abaa = AlBeA.outer.AlphaB baaa = BeAlA.outer.AlphaB abbb = AlBeA.outer.BetaB babb = BeAlA.outer.BetaB end if if(integralB%array_type.eq.'general') then - AlBeB=integralB%getBlock('alphabeta') - BeAlB=integralB%getBlock('betaalpha') + AlBeB=integralB%getBlock('betaalpha') + BeAlB=integralB%getBlock('alphabeta') aaab = AlphaA.outer.AlBeB aaba = AlphaA.outer.BeAlB bbab = BetaA.outer.AlBeB @@ -12092,15 +12094,23 @@ function mqc_eri_eri_partial_contraction_2eri(eris1,eris2,index1,index2) result( eris2%blockSize('alpha',kb),eris2%blockSize('beta',lb)) call bbba%init(eris1%blockSize('beta',ka),eris1%blockSize('beta',la),& eris2%blockSize('beta',kb),eris2%blockSize('alpha',lb)) + call baaa%init(eris1%blockSize('beta',ka),eris1%blockSize('alpha',la),& + eris2%blockSize('alpha',kb),eris2%blockSize('alpha',lb)) + call abaa%init(eris1%blockSize('alpha',ka),eris1%blockSize('beta',la),& + eris2%blockSize('alpha',kb),eris2%blockSize('alpha',lb)) + call aaba%init(eris1%blockSize('alpha',ka),eris1%blockSize('alpha',la),& + eris2%blockSize('beta',kb),eris2%blockSize('alpha',lb)) + call aaab%init(eris1%blockSize('alpha',ka),eris1%blockSize('alpha',la),& + eris2%blockSize('alpha',kb),eris2%blockSize('beta',lb)) eriType='spin' do i=1,16 - active_conf_1=full_array(i) - str1=mqc_index_to_string([ia,ja,ka,la],active_conf_1) + str1=full_array(i) + active_conf_1=mqc_index_to_string([ia,ja,ka,la],str1) do j=1,16 - active_conf_2=full_array(j) + str2=full_array(j) + active_conf_2=mqc_index_to_string([ib,jb,kb,lb],str2) active_conf=trim(active_conf_1(3:4))//trim(active_conf_2(3:4)) - str2=mqc_index_to_string([ib,jb,kb,lb],active_conf_2) if (active_conf_1(1:2).eq.active_conf_2(1:2)) then select case (active_conf) case('aaaa') @@ -12147,6 +12157,22 @@ function mqc_eri_eri_partial_contraction_2eri(eris1,eris2,index1,index2) result( eriType='general' bbba = bbba + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + case('baaa') + eriType='general' + baaa = baaa + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + case('abaa') + eriType='general' + abaa = abaa + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + case('aaba') + eriType='general' + aaba = aaba + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + case('aaab') + eriType='general' + aaab = aaab + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) end select end if enddo @@ -12575,7 +12601,7 @@ end function mqc_index_to_string function mqc_eri_interaction(eris,label) result(output) ! implicit none - type(mqc_twoERIs),intent(in)::eris + class(mqc_twoERIs),intent(in)::eris character(len=*),optional,intent(in)::label type(mqc_twoERIs)::output character(len=64)::mylabel From 18cc6ef3826424e935e57f6659e6c1d5325fb68a Mon Sep 17 00:00:00 2001 From: mm Date: Tue, 28 Apr 2026 14:29:05 -0400 Subject: [PATCH 22/37] Manjor changes in ERIs label and bugfixes Additional storageType and integralType added to 2ERIs. These types are designed to treat non-orbital integral terms, such as double excitations. MQC_algebra.F03 - R4Terson correctly short prints complex elements; - R4Tenson_R4Tensor_partial_contraction uses the correct indexes; MQC_est.F03 - mqc_eigenvalues_dimension and mqc_eigenvalues_array_type implemented; - mqc_eris_storage_type and mqc_eri_dimension_swap implemented; - Major changes in ERI getBlock and init to conform with the new Types; - Swap of wrong 'alphabeta' and 'betaalpha' labels; - Fixes on .outer2ERI. and ERI_ERI_partial_contraction; - Improvements: ERI_ERI_SUM and ERI scalar Multiplication --- src/mqc_algebra.F03 | 92 +- src/mqc_est.F03 | 3252 ++++++++++++++++++++++++++++++++++++------- 2 files changed, 2789 insertions(+), 555 deletions(-) diff --git a/src/mqc_algebra.F03 b/src/mqc_algebra.F03 index 619b2366..92780fd2 100644 --- a/src/mqc_algebra.F03 +++ b/src/mqc_algebra.F03 @@ -29449,7 +29449,7 @@ Subroutine MQC_Print_R4Tensor_Algebra1(Tensor,IOut,Header,blank_at_top,blank_at_ Do K = 1, Tensor%K Do l = 1, Tensor%L If(short_print) then - If(abs(Tensor%ITen(symIndexHash(I,J,K,L),1,1,1)).gt.print_threshold ) then + If(abs(Tensor%at(I,J,K,L)).gt.print_threshold ) then If(Tensor%Data_Type.eq.'Integer') then Write(IOut,1100) I,J,K,L,Tensor%ITen(symIndexHash(I,J,K,L),1,1,1) ElseIf(Tensor%Data_Type.eq.'Real') then @@ -31106,7 +31106,7 @@ End Function MQC_R4Tensor_R4Tensor_Difference !> !> \verbatim !> -!> MQC_R4Tensor_R4Tensor_At is a function that returns the vector between indices +!> MQC_R4Tensor_Vector_At is a function that returns the vector between indices !> D1, D2, D3 and D4. If the values in the index specification are negative, the !> index is counted back from the final element. !> @@ -31928,8 +31928,8 @@ End Subroutine MQC_R4Tensor_Matrix_Put ! Authors: ! ======== ! -!> \author L. M. Thompson -!> \date 2019 +!> \author L. M. Thompson, M. M. F. Moraes +!> \date 2019, 2026 ! Function MQC_R4Tensor_R4Tensor_At(TensorIn,D1,D2,D3,D4) Result(TensorOut) ! @@ -31986,56 +31986,56 @@ Function MQC_R4Tensor_R4Tensor_At(TensorIn,D1,D2,D3,D4) Result(TensorOut) If (IndI.lt.0) IndI = Size(TensorIn,1) + IndI + 1 If (IndJ.lt.0) IndJ = Size(TensorIn,1) + IndJ + 1 Len1 = IndJ-IndI+1 - If (Len1.le.0.or.Len1.gt.Size(TensorIn,1)) Call MQC_Error_I('Dimension 1 length badly & - & defined in MQC_R4Tensor_R4Tensor_At',6,'Len1',Len1,'Size(TensorIn,1)', & + If (Len1.lt.0.or.Len1.gt.Size(TensorIn,1)) Call MQC_Error_I('Dimension 1 length badly & + &defined in MQC_R4Tensor_R4Tensor_At',6,'Len1',Len1,'Size(TensorIn,1)', & Size(TensorIn,1) ) - If (IndI.le.0.or.IndI.gt.(Size(TensorIn,1)-Len1+1)) Call MQC_Error_I('Index I out of & - & bounds in MQC_R4Tensor_R4Tensor_At',6,'IndI',IndI,'Size(TensorIn,1)', & + If (IndI.lt.0.or.IndI.gt.(Size(TensorIn,1)-Len1+1)) Call MQC_Error_I('Index I out of & + &bounds in MQC_R4Tensor_R4Tensor_At',6,'IndI',IndI,'Size(TensorIn,1)', & Size(TensorIn,1),'Len1', Len1 ) If (IndJ.lt.Len1.or.IndJ.gt.Size(TensorIn,1)) Call MQC_Error_I('Index J out of bounds & - & in MQC_R4Tensor_R4Tensor_At',6,'IndJ',IndJ,'Len1',Len1,'Size(TensorIn,1)', & + &in MQC_R4Tensor_R4Tensor_At',6,'IndJ',IndJ,'Len1',Len1,'Size(TensorIn,1)', & Size(TensorIn,1)) IndK = K IndL = L If (IndK.lt.0) IndK = Size(TensorIn,2) + IndK + 1 If (IndL.lt.0) IndL = Size(TensorIn,2) + IndL + 1 Len2 = IndL-IndK+1 - If (Len2.le.0.or.Len2.gt.Size(TensorIn,2)) Call MQC_Error_I('Dimension 2 length badly & - & defined in MQC_R4Tensor_R4Tensor_At',6,'Len2',Len2,'Size(TensorIn,2)', & + If (Len2.lt.0.or.Len2.gt.Size(TensorIn,2)) Call MQC_Error_I('Dimension 2 length badly & + &defined in MQC_R4Tensor_R4Tensor_At',6,'Len2',Len2,'Size(TensorIn,2)', & Size(TensorIn,2) ) - If (IndK.le.0.or.IndK.gt.(Size(TensorIn,2)-Len2+1)) Call MQC_Error_I('Index K out of & - & bounds in MQC_R4Tensor_R4Tensor_At',6,'IndK',IndK,'Size(TensorIn,2)', & + If (IndK.lt.0.or.IndK.gt.(Size(TensorIn,2)-Len2+1)) Call MQC_Error_I('Index K out of & + &bounds in MQC_R4Tensor_R4Tensor_At',6,'IndK',IndK,'Size(TensorIn,2)', & Size(TensorIn,2),'Len2', Len2 ) If (IndL.lt.Len2.or.IndL.gt.Size(TensorIn,2)) Call MQC_Error_I('Index L out of bounds & - & in MQC_R4Tensor_R4Tensor_At',6,'IndL',IndL,'Len2',Len2,'Size(TensorIn,2)', & + &in MQC_R4Tensor_R4Tensor_At',6,'IndL',IndL,'Len2',Len2,'Size(TensorIn,2)', & Size(TensorIn,2)) IndM = M IndN = N If (IndM.lt.0) IndM = Size(TensorIn,3) + IndM + 1 If (IndN.lt.0) IndN = Size(TensorIn,3) + IndN + 1 Len3 = IndN-IndM+1 - If (Len3.le.0.or.Len3.gt.Size(TensorIn,3)) Call MQC_Error_I('Dimension 3 length badly & - & defined in MQC_R4Tensor_R4Tensor_At',6,'Len3',Len3,'Size(TensorIn,3)', & + If (Len3.lt.0.or.Len3.gt.Size(TensorIn,3)) Call MQC_Error_I('Dimension 3 length badly & + &defined in MQC_R4Tensor_R4Tensor_At',6,'Len3',Len3,'Size(TensorIn,3)', & Size(TensorIn,3) ) - If (IndM.le.0.or.IndM.gt.(Size(TensorIn,3)-Len3+1)) Call MQC_Error_I('Index M out of & - & bounds in MQC_R4Tensor_R4Tensor_At',6,'IndM',IndM,'Size(TensorIn,3)', & + If (IndM.lt.0.or.IndM.gt.(Size(TensorIn,3)-Len3+1)) Call MQC_Error_I('Index M out of & + &bounds in MQC_R4Tensor_R4Tensor_At',6,'IndM',IndM,'Size(TensorIn,3)', & Size(TensorIn,3),'Len3', Len3 ) If (IndN.lt.Len3.or.IndN.gt.Size(TensorIn,3)) Call MQC_Error_I('Index N out of bounds & - & in MQC_R4Tensor_R4Tensor_At',6,'IndN',IndN,'Len3',Len3,'Size(TensorIn,3)', & + &in MQC_R4Tensor_R4Tensor_At',6,'IndN',IndN,'Len3',Len3,'Size(TensorIn,3)', & Size(TensorIn,3)) IndO = O IndP = P If (IndO.lt.0) IndO = Size(TensorIn,4) + IndO + 1 If (IndP.lt.0) IndP = Size(TensorIn,4) + IndP + 1 Len4 = IndP-IndO+1 - If (Len4.le.0.or.Len4.gt.Size(TensorIn,4)) Call MQC_Error_I('Dimension 4 length badly & - & defined in MQC_R4Tensor_R4Tensor_At',6,'Len4',Len4,'Size(TensorIn,4)', & + If (Len4.lt.0.or.Len4.gt.Size(TensorIn,4)) Call MQC_Error_I('Dimension 4 length badly & + &defined in MQC_R4Tensor_R4Tensor_At',6,'Len4',Len4,'Size(TensorIn,4)', & Size(TensorIn,4) ) - If (IndO.le.0.or.IndO.gt.(Size(TensorIn,4)-Len4+1)) Call MQC_Error_I('Index O out of & - & bounds in MQC_R4Tensor_R4Tensor_At',6,'IndO',IndO,'Size(TensorIn,4)', & + If (IndO.lt.0.or.IndO.gt.(Size(TensorIn,4)-Len4+1)) Call MQC_Error_I('Index O out of & + &bounds in MQC_R4Tensor_R4Tensor_At',6,'IndO',IndO,'Size(TensorIn,4)', & Size(TensorIn,4),'Len4', Len4 ) If (IndP.lt.Len4.or.IndP.gt.Size(TensorIn,4)) Call MQC_Error_I('Index P out of bounds & - & in MQC_R4Tensor_R4Tensor_At',6,'IndP',IndP,'Len4',Len4,'Size(TensorIn,4)', & + &in MQC_R4Tensor_R4Tensor_At',6,'IndP',IndP,'Len4',Len4,'Size(TensorIn,4)', & Size(TensorIn,4)) If (MQC_R4Tensor_HaveFull(TensorIn)) then @@ -33309,8 +33309,8 @@ Function MQC_R4Tensor_R4Tensor_Partial_Contraction(RA,RB,orderA,orderB) Result(M !$OMP SHARED(RA,RB,vi,vj,ia,ja,la,ka,& !$OMP ib,jb,lb,kb,MC,dimAl,dimAk),& !$OMP PRIVATE(tmpRA,tmpRB,k,l) - do k=1,dimAl - do l=1,dimAk + do k=1,dimAk + do l=1,dimAl select case(ia) case(1) select case(ja) @@ -33361,7 +33361,7 @@ Function MQC_R4Tensor_R4Tensor_Partial_Contraction(RA,RB,orderA,orderB) Result(M if(ka.eq.2) tmpRA = transpose(RA%mat([l],[k],vj,vi)) end select end select - select case(ib) + select case(ib) case(1) select case(jb) case(2) @@ -33375,7 +33375,7 @@ Function MQC_R4Tensor_R4Tensor_Partial_Contraction(RA,RB,orderA,orderB) Result(M if(kb.eq.3) tmpRB = RB%mat(vi,[l],[k],vj) end select case(2) - select case(ja) + select case(jb) case(1) if(kb.eq.3) tmpRB = transpose(RB%mat(vj,vi,[k],[l])) if(kb.eq.4) tmpRB = transpose(RB%mat(vj,vi,[l],[k])) @@ -33387,7 +33387,7 @@ Function MQC_R4Tensor_R4Tensor_Partial_Contraction(RA,RB,orderA,orderB) Result(M if(kb.eq.3) tmpRB = RB%mat([l],vi,[k],vj) end select case(3) - select case(ja) + select case(jb) case(1) if(kb.eq.2) tmpRB = transpose(RB%mat(vj,[k],vi,[l])) if(kb.eq.4) tmpRB = transpose(RB%mat(vj,[l],vi,[k])) @@ -33399,7 +33399,7 @@ Function MQC_R4Tensor_R4Tensor_Partial_Contraction(RA,RB,orderA,orderB) Result(M if(kb.eq.2) tmpRB = RB%mat([l],[k],vi,vj) end select case(4) - select case(ib) + select case(jb) case(1) if(kb.eq.2) tmpRB = transpose(RB%mat(vj,[k],[l],vi)) if(kb.eq.3) tmpRB = transpose(RB%mat(vj,[l],[k],vi)) @@ -33691,8 +33691,8 @@ Function MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(RA,RB,orderA,orderB !$OMP SHARED(RA,RB,vi,vj,ia,ja,la,ka,& !$OMP ib,jb,lb,kb,RC,dimAl,dimAk,dimBl,dimBk),& !$OMP PRIVATE(tmpRA,tmpRB,k,l,p,q) - do k=1,dimAl - do l=1,dimAk + do k=1,dimAk + do l=1,dimAl select case(ia) case(1) select case(ja) @@ -33711,6 +33711,8 @@ Function MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(RA,RB,orderA,orderB case(1) if(ka.eq.3) tmpRA = transpose(RA%mat(vj,vi,[k],[l])) if(ka.eq.4) tmpRA = transpose(RA%mat(vj,vi,[l],[k])) + !if(ka.eq.3) tmpRA = dagger(RA%mat(vj,vi,[k],[l])) + !if(ka.eq.4) tmpRA = dagger(RA%mat(vj,vi,[l],[k])) case(3) if(ka.eq.1) tmpRA = RA%mat([k],vi,vj,[l]) if(ka.eq.4) tmpRA = RA%mat([l],vi,vj,[k]) @@ -33723,9 +33725,13 @@ Function MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(RA,RB,orderA,orderB case(1) if(ka.eq.2) tmpRA = transpose(RA%mat(vj,[k],vi,[l])) if(ka.eq.4) tmpRA = transpose(RA%mat(vj,[l],vi,[k])) + !if(ka.eq.2) tmpRA = dagger(RA%mat(vj,[k],vi,[l])) + !if(ka.eq.4) tmpRA = dagger(RA%mat(vj,[l],vi,[k])) case(2) if(ka.eq.1) tmpRA = transpose(RA%mat([k],vj,vi,[l])) if(ka.eq.4) tmpRA = transpose(RA%mat([l],vj,vi,[k])) + !if(ka.eq.1) tmpRA = dagger(RA%mat([k],vj,vi,[l])) + !if(ka.eq.4) tmpRA = dagger(RA%mat([l],vj,vi,[k])) case(4) if(ka.eq.1) tmpRA = RA%mat([k],[l],vi,vj) if(ka.eq.2) tmpRA = RA%mat([l],[k],vi,vj) @@ -33735,16 +33741,22 @@ Function MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(RA,RB,orderA,orderB case(1) if(ka.eq.2) tmpRA = transpose(RA%mat(vj,[k],[l],vi)) if(ka.eq.3) tmpRA = transpose(RA%mat(vj,[l],[k],vi)) + !if(ka.eq.2) tmpRA = dagger(RA%mat(vj,[k],[l],vi)) + !if(ka.eq.3) tmpRA = dagger(RA%mat(vj,[l],[k],vi)) case(2) if(ka.eq.1) tmpRA = transpose(RA%mat([k],vj,[l],vi)) if(ka.eq.3) tmpRA = transpose(RA%mat([l],vj,[k],vi)) + !if(ka.eq.1) tmpRA = dagger(RA%mat([k],vj,[l],vi)) + !if(ka.eq.3) tmpRA = dagger(RA%mat([l],vj,[k],vi)) case(3) if(ka.eq.1) tmpRA = transpose(RA%mat([k],[l],vj,vi)) if(ka.eq.2) tmpRA = transpose(RA%mat([l],[k],vj,vi)) + !if(ka.eq.1) tmpRA = dagger(RA%mat([k],[l],vj,vi)) + !if(ka.eq.2) tmpRA = dagger(RA%mat([l],[k],vj,vi)) end select end select - do p=1,dimBl - do q=1,dimBk + do p=1,dimBk + do q=1,dimBl select case(ib) case(1) select case(jb) @@ -33763,6 +33775,8 @@ Function MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(RA,RB,orderA,orderB case(1) if(kb.eq.3) tmpRB = transpose(RB%mat(vj,vi,[p],[q])) if(kb.eq.4) tmpRB = transpose(RB%mat(vj,vi,[q],[p])) + !if(kb.eq.3) tmpRB = dagger(RB%mat(vj,vi,[p],[q])) + !if(kb.eq.4) tmpRB = dagger(RB%mat(vj,vi,[q],[p])) case(3) if(kb.eq.1) tmpRB = RB%mat([p],vi,vj,[q]) if(kb.eq.4) tmpRB = RB%mat([q],vi,vj,[p]) @@ -33775,9 +33789,13 @@ Function MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(RA,RB,orderA,orderB case(1) if(kb.eq.2) tmpRB = transpose(RB%mat(vj,[p],vi,[q])) if(kb.eq.4) tmpRB = transpose(RB%mat(vj,[q],vi,[p])) + !if(kb.eq.2) tmpRB = dagger(RB%mat(vj,[p],vi,[q])) + !if(kb.eq.4) tmpRB = dagger(RB%mat(vj,[q],vi,[p])) case(2) if(kb.eq.1) tmpRB = transpose(RB%mat([p],vj,vi,[q])) if(kb.eq.4) tmpRB = transpose(RB%mat([q],vj,vi,[p])) + !if(kb.eq.1) tmpRB = dagger(RB%mat([p],vj,vi,[q])) + !if(kb.eq.4) tmpRB = dagger(RB%mat([q],vj,vi,[p])) case(4) if(kb.eq.1) tmpRB = RB%mat([p],[q],vi,vj) if(kb.eq.2) tmpRB = RB%mat([q],[p],vi,vj) @@ -33787,12 +33805,18 @@ Function MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(RA,RB,orderA,orderB case(1) if(kb.eq.2) tmpRB = transpose(RB%mat(vj,[p],[q],vi)) if(kb.eq.3) tmpRB = transpose(RB%mat(vj,[q],[p],vi)) + !if(kb.eq.2) tmpRB = dagger(RB%mat(vj,[p],[q],vi)) + !if(kb.eq.3) tmpRB = dagger(RB%mat(vj,[q],[p],vi)) case(2) if(kb.eq.1) tmpRB = transpose(RB%mat([p],vj,[q],vi)) if(kb.eq.3) tmpRB = transpose(RB%mat([q],vj,[p],vi)) + !if(kb.eq.1) tmpRB = dagger(RB%mat([p],vj,[q],vi)) + !if(kb.eq.3) tmpRB = dagger(RB%mat([q],vj,[p],vi)) case(3) if(kb.eq.1) tmpRB = transpose(RB%mat([p],[q],vj,vi)) if(kb.eq.2) tmpRB = transpose(RB%mat([q],[p],vj,vi)) + !if(kb.eq.1) tmpRB = dagger(RB%mat([p],[q],vj,vi)) + !if(kb.eq.2) tmpRB = dagger(RB%mat([q],[p],vj,vi)) end select end select call RC%put(Contraction(tmpRA,tmpRB),k,l,p,q) diff --git a/src/mqc_est.F03 b/src/mqc_est.F03 index 4b561f36..83465eb3 100644 --- a/src/mqc_est.F03 +++ b/src/mqc_est.F03 @@ -173,9 +173,9 @@ Module MQC_EST Procedure, Public::print => mqc_print_eigenvalues Procedure, Private::hasAlpha => mqc_eigenvalues_has_alpha Procedure, Private::hasBeta => mqc_eigenvalues_has_beta - Procedure, Private::type => mqc_eigenvalues_array_type - Procedure, Private::blockSize => mqc_eigenvalues_dimension -!> \brief Initilizes the MQC_SCF_Eigenvalues object + Procedure, Public::type => mqc_eigenvalues_array_type + Procedure, Public::blockSize => mqc_eigenvalues_dimension +!> \brief Initializes the MQC_SCF_Eigenvalues object Procedure, Public::init => mqc_eigenvalues_initialize !> \brief Return the label of the MQC_SCF_Eigenvalues object Procedure, Public::getLabel => mqc_eigenvalues_array_name @@ -281,8 +281,35 @@ Module MQC_EST type mqc_twoERIs type(mqc_r4tensor),private::alpha,beta,alphaBeta,betaAlpha,aaab,aaba,abaa,baaa,abab, & baab,baba,abba,bbba,bbab,babb,abbb - character(Len=64),private::integralType !regular,raffenetti1,raffenetti2,raffenetti3,space,spin,general - character(Len=64),private::storageType !full,symm + character(Len=64),private::integralType !regular,raffenetti1,raffenetti2,raffenetti3,space,spin,general,empty + character(Len=64),private::storageType !full,symm,coulomb,exchange,inverted,doublebar,ms +!> +!> Definition of non-zero MO elements based on integralType and storageType +!> integralType = space +!> Block= |coulomb|exchange|inverted +!> -------+-------+--------+-------- +!> aaaa = | aaaa | aaaa | aaaa +!> bbbb = | aaaa | aaaa | aaaa +!> aabb = | aaaa | 0 | 0 +!> bbaa = | aaaa | 0 | 0 +!> abba = | 0 | aaaa | 0 +!> baab = | 0 | aaaa | 0 +!> abab = | 0 | 0 | aaaa +!> baba = | 0 | 0 | aaaa +!> +!> integralType = spin +!> Block= |coulomb|exchange|inverted|doublebar| ms +!> -------+-------+--------+--------+---------+------ +!> aaaa = | aaaa | aaaa | aaaa | aaaa | aaaa +!> bbbb = | bbbb | bbbb | bbbb | bbbb | bbbb +!> aabb = | aabb | 0 | 0 | aabb | aabb +!> bbaa = | bbaa | 0 | 0 | bbaa | bbaa +!> abba = | 0 | aabb | 0 | abba | abba +!> baab = | 0 | bbaa | 0 | baab | baab +!> abab = | 0 | 0 | aabb | 0 | abab +!> baba = | 0 | 0 | bbaa | 0 | baba +!> +!> contains !> \brief Print the MQC_TwoERIs object procedure, public::print => mqc_print_twoERIs @@ -293,6 +320,8 @@ Module MQC_EST !> \brief Return a spin block of MQC_TwoERIs object as an MQC rank-4 tensor procedure, public:: getBlock => mqc_2eris_output_block procedure, public::type => mqc_eris_array_type + procedure, public::storType => mqc_eris_storage_type + procedure, public::swap => mqc_eri_dimension_swap end type mqc_twoERIs ! ! Parent Type @@ -1038,10 +1067,28 @@ subroutine mqc_print_twoERIs(twoERIs,iOut,header, & call twoERIs%alpha%print(iout,'(aa|aa)',short_print_threshold=print_threshold) if(twoERIs%hasSpinBlock('bbbb')) & call twoERIs%beta%print(iout,'(bb|bb)',short_print_threshold=print_threshold) - if(twoERIs%hasSpinBlock('aabb')) & + if((twoERIs%storageType.eq.'coulomb'.or.twoERIs%storageType.eq.'doublebar'& + .or.twoERIs%storageType.eq.'ms').and.twoERIs%hasSpinBlock('aabb')) & call twoERIs%alphaBeta%print(iout,'(aa|bb)',short_print_threshold=print_threshold) - if(twoERIs%storageType.eq.'full'.and.twoERIs%hasSpinBlock('bbaa')) & + if((twoERIs%storageType.eq.'coulomb'.or.twoERIs%storageType.eq.'doublebar'& + .or.twoERIs%storageType.eq.'ms').and.twoERIs%hasSpinBlock('bbaa')) & call twoERIs%betaAlpha%print(iout,'(bb|aa)',short_print_threshold=print_threshold) + if(((twoERIs%storageType.eq.'exchange').and.twoERIs%hasSpinBlock('aabb'))) & + call twoERIs%alphaBeta%print(iout,'(ab|ba)',short_print_threshold=print_threshold) + if(((twoERIs%storageType.eq.'exchange').and.twoERIs%hasSpinBlock('bbaa'))) & + call twoERIs%betaAlpha%print(iout,'(ba|ab)',short_print_threshold=print_threshold) + if(((twoERIs%storageType.eq.'inverted').and.twoERIs%hasSpinBlock('aabb'))) & + call twoERIs%alphaBeta%print(iout,'(ab|ab)',short_print_threshold=print_threshold) + if(((twoERIs%storageType.eq.'inverted').and.twoERIs%hasSpinBlock('bbaa'))) & + call twoERIs%betaAlpha%print(iout,'(ba|ba)',short_print_threshold=print_threshold) + if(((twoERIs%storageType.eq.'doublebar'.or.twoERIs%storageType.eq.'ms').and.twoERIs%hasSpinBlock('abba'))) & + call twoERIs%abba%print(iout,'(ab|ba)',short_print_threshold=print_threshold) + if(((twoERIs%storageType.eq.'doublebar'.or.twoERIs%storageType.eq.'ms').and.twoERIs%hasSpinBlock('baab'))) & + call twoERIs%abba%print(iout,'(ba|ab)',short_print_threshold=print_threshold) + if((twoERIs%storageType.eq.'ms'.and.twoERIs%hasSpinBlock('abab'))) & + call twoERIs%abab%print(iout,'(ab|ab)',short_print_threshold=print_threshold) + if((twoERIs%storageType.eq.'ms'.and.twoERIs%hasSpinBlock('baba'))) & + call twoERIs%baba%print(iout,'(ba|ba)',short_print_threshold=print_threshold) elseIf(trim(twoERIs%integralType).eq.'general') then write(iout,'(A)') 'General MO 2ERIs' if(twoERIs%hasSpinBlock('aaaa')) & @@ -1775,6 +1822,45 @@ function mqc_eris_array_type(eris) result(arrayType) end function mqc_eris_array_type ! ! +! PROCEDURE MQC_ERIs_Storage_Type +! +!> \brief MQC_ERIs_Storage_Type is a function that returns an MQC 2ERIs +!> internal storageType variable. +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_ERIs_Storage_Type is a function that returns an MQC 2ERIs +!> internal storageType variable. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in,out] ERIs +!> \verbatim +!> Integral is Class(MQC_TwoERIs) +!> The name of the MQC_TwoERIs variable. +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_eris_storage_type(eris) result(arrayType) +! + implicit none + class(mqc_twoeris)::eris + Character(Len=64)::arrayType +! + arrayType = eris%storagetype +! + end function mqc_eris_storage_type +! +! ! PROCEDURE MQC_Integral_Array_Name ! !> \brief MQC_Integral_Array_Name is a function that returns the label of an @@ -2373,11 +2459,8 @@ subroutine mqc_eigenvalues_initialize(eigenvalues,length,scalar,lengthBeta) endIf eigenvalues%Alpha = vecAlpha if(eigenvaluesType.eq.'spin') eigenvalues%Beta = vecBeta - +! end subroutine mqc_eigenvalues_initialize - - - ! ! ! PROCEDURE MQC_ERIs_Dimension @@ -2717,43 +2800,102 @@ end subroutine mqc_twoeriset_allocate !> ABBB is type(mqc_r4tensor),optional !> The abbb spin block 2ERI integrals. !> \endverbatim +!> +!> \param[in] allocationVector +!> \verbatim +!> allocationVector is logical,dimension(16),optional +!> Each vector element changes if an associated R4Tensor is +!> allocated or not based on a AND logic table. +!> R4 is present | vector | allocation +!> --------------+---------+----------- +!> .true. | .true. | .true. +!> .true. | .false. | .false. +!> .false. | .true. | .false. +!> .false. | .false. | .false. +!> \endverbatim +!> ! ! Authors: ! ======== -!> \author L. M. Thompson -!> \date 2017 +!> \author L. M. Thompson, M. M. F. Moraes +!> \date 2017, 2026 ! subroutine mqc_twoeris_allocate(twoERIs,storageType,integralType,alpha, & beta,alphaBeta,betaAlpha,abab,abba,baab,baba,aaab,aaba,abaa,baaa,bbba, & - bbab,babb,abbb) + bbab,babb,abbb,allocationVector) ! implicit none class(mqc_twoERIs)::twoERIs character(len=*)::storageType,integralType type(mqc_r4tensor),optional::alpha,beta,alphaBeta,betaAlpha,abab,abba,baab, & baba,aaab,aaba,abaa,baaa,bbba,bbab,babb,abbb + logical,dimension(16),optional::allocationVector + logical,dimension(16)::allocVec + integer::i ! call string_change_case(storageType,'L') call string_change_case(integralType,'L') twoERIs%storageType = storageType twoERIs%integralType = integralType + if(present(allocationVector)) then + allocVec=allocationVector + else + do i = 1,16 + allocVec(i)=.true. + end do + end if ! - if(present(alpha)) twoERIs%alpha = alpha - if(present(beta)) twoERIs%beta = beta - if(present(alphaBeta)) twoERIs%alphaBeta = alphaBeta - if(present(betaAlpha)) twoERIs%betaAlpha = betaAlpha - if(present(abab)) twoERIs%abab = abab - if(present(abba)) twoERIs%abba = abba - if(present(baab)) twoERIs%baab = baab - if(present(baba)) twoERIs%baba = baba - if(present(aaab)) twoERIs%aaab = aaab - if(present(aaba)) twoERIs%aaba = aaba - if(present(abaa)) twoERIs%abaa = abaa - if(present(baaa)) twoERIs%baaa = baaa - if(present(bbba)) twoERIs%bbba = bbba - if(present(bbab)) twoERIs%bbab = bbab - if(present(babb)) twoERIs%babb = babb - if(present(abbb)) twoERIs%abbb = abbb + if(integralType.eq.'space'.and.storageType.ne.'full'& + .and.(present(beta).or.& + present(alphaBeta).or.present(betaAlpha))) call mqc_error_A(& + 'Excess spin-r4tensor presented in mqc_twoeris_allocate',6,& + 'integralType',integralType) + if(integralType.eq.'space'.and.storageType.ne.'full'.and.& + (present(abab).or.present(abba).or.present(baab).or.& + present(baba).or.present(aaab).or.present(aaba).or.& + present(abaa).or.present(baaa).or.present(bbba).or.& + present(bbab).or.present(babb).or.present(abbb))) call mqc_error_A(& + 'Excess ladder-r4tensor presented in mqc_twoeris_allocate',6,& + 'integralType',integralType,'storageType',storageType) + if(integralType.eq.'spin'.and.(storageType.eq.'coulomb'.or.& + storageType.eq.'exchange'.or.storageType.eq.'inverted').and.& + (present(abab).or.present(abba).or.present(baab).or.& + present(baba).or.present(aaab).or.present(aaba).or.& + present(abaa).or.present(baaa).or.present(bbba).or.& + present(bbab).or.present(babb).or.present(abbb))) call mqc_error_A(& + 'Excess ladder-r4tensor presented in mqc_twoeris_allocate',6,& + 'integralType',integralType,'storageType',storageType) + if(integralType.eq.'spin'.and.(storageType.eq.'doublebar').and.& + (present(abab).or.& + present(baba).or.present(aaab).or.present(aaba).or.& + present(abaa).or.present(baaa).or.present(bbba).or.& + present(bbab).or.present(babb).or.present(abbb))) call mqc_error_A(& + 'Excess ladder-r4tensor presented in mqc_twoeris_allocate',6,& + 'integralType',integralType,'storageType',storageType) + if(integralType.eq.'spin'.and.(storageType.eq.'ms').and.& + (present(aaab).or.present(aaba).or.& + present(abaa).or.present(baaa).or.present(bbba).or.& + present(bbab).or.present(babb).or.present(abbb))) call mqc_error_A(& + 'Excess ladder-r4tensor presented in mqc_twoeris_allocate',6,& + 'integralType',integralType,'storageType',storageType) + + + if(present(alpha).and.allocVec(1)) twoERIs%alpha = alpha + if(present(beta).and.allocVec(2)) twoERIs%beta = beta + if(present(alphaBeta).and.allocVec(3)) twoERIs%alphaBeta = alphaBeta + if(present(betaAlpha).and.allocVec(4)) twoERIs%betaAlpha = betaAlpha + if(present(abab).and.allocVec(5)) twoERIs%abab = abab + if(present(abba).and.allocVec(6)) twoERIs%abba = abba + if(present(baab).and.allocVec(7)) twoERIs%baab = baab + if(present(baba).and.allocVec(8)) twoERIs%baba = baba + if(present(aaab).and.allocVec(9)) twoERIs%aaab = aaab + if(present(aaba).and.allocVec(10)) twoERIs%aaba = aaba + if(present(abaa).and.allocVec(11)) twoERIs%abaa = abaa + if(present(baaa).and.allocVec(12)) twoERIs%baaa = baaa + if(present(bbba).and.allocVec(13)) twoERIs%bbba = bbba + if(present(bbab).and.allocVec(14)) twoERIs%bbab = bbab + if(present(babb).and.allocVec(15)) twoERIs%babb = babb + if(present(abbb).and.allocVec(16)) twoERIs%abbb = abbb ! end subroutine mqc_twoeris_allocate ! @@ -3756,7 +3898,7 @@ subroutine mqc_integral_initialize(integral,nAlpha,nBeta,scalar,label,nAlpha2,nB call tmpMatrixAlphaBeta%init(nAlpha,my_nBeta2,scalar) call tmpMatrixBetaAlpha%init(nBeta,my_nAlpha2,scalar) call mqc_integral_allocate(integral,myLabel,'general',tmpMatrixAlpha,tmpMatrixBeta,& - tmpMatrixAlphaBeta,tmpMatrixBetaAlpha) + tmpMatrixBetaAlpha,tmpMatrixAlphaBeta) else call mqc_integral_allocate(integral,myLabel,'spin',tmpMatrixAlpha,tmpMatrixBeta) endIf @@ -3771,7 +3913,7 @@ subroutine mqc_integral_initialize(integral,nAlpha,nBeta,scalar,label,nAlpha2,nB call tmpMatrixAlphaBeta%init(nAlpha,my_nBeta2) call tmpMatrixBetaAlpha%init(nBeta,my_nAlpha2) call mqc_integral_allocate(integral,myLabel,'general',tmpMatrixAlpha,tmpMatrixBeta,& - tmpMatrixAlphaBeta,tmpMatrixBetaAlpha) + tmpMatrixBetaAlpha,tmpMatrixAlphaBeta) else call mqc_integral_allocate(integral,myLabel,'spin',tmpMatrixAlpha,tmpMatrixBeta) endIf @@ -5514,9 +5656,7 @@ function mqc_2ERIs_output_block(eris,blockName) result(r4tOut) call r4tOut%init(NDimAlpha1,NDimAlpha2,NDimAlpha3,NDimAlpha4,zeroR) endIf case('beta','bbbb','beta-beta') - if (eris%hasSpinBlock('bbbb')) then - r4tOut = eris%beta - elseIf (eris%type().eq.'regular'.or.eris%type().eq.'raffenetti1'.or. & + if (eris%type().eq.'regular'.or.eris%type().eq.'raffenetti1'.or. & eris%type().eq.'raffenetti2'.or.eris%type().eq.'raffenetti3'.or. & eris%type().eq.'space') then if (eris%hasSpinBlock('aaaa')) then @@ -5524,12 +5664,20 @@ function mqc_2ERIs_output_block(eris,blockName) result(r4tOut) else call r4tOut%init(NDimAlpha1,NDimAlpha2,NDimAlpha3,NDimAlpha4,zeroR) endIf + elseIf (eris%hasSpinBlock('bbbb')) then + r4tOut = eris%beta else call r4tOut%init(NDimBeta1,NDimBeta2,NDimBeta3,NDimBeta4,zeroR) endIf - case('alpha-beta','aabb') - if (eris%hasSpinBlock('aabb')) then - r4tOut = eris%alphaBeta + case('alpha-beta','alphabeta','aabb') + If (eris%storageType.eq.'exchange'.or.eris%storageType.eq.'inverted') then + call r4tOut%init(NDimAlpha1,NDimAlpha2,NDimBeta3,NDimBeta4,zeroR) + elseIf (eris%integralType.eq.'spin') then + if (eris%hasSpinBlock('aabb')) then + r4tOut = eris%alphaBeta + else + call r4tOut%init(NDimAlpha1,NDimAlpha2,NDimBeta3,NDimBeta4,zeroR) + end if elseIf (eris%type().eq.'regular'.or.eris%type().eq.'raffenetti1'.or. & eris%type().eq.'raffenetti2'.or.eris%type().eq.'raffenetti3'.or. & eris%type().eq.'space') then @@ -5538,77 +5686,153 @@ function mqc_2ERIs_output_block(eris,blockName) result(r4tOut) else call r4tOut%init(NDimAlpha1,NDimAlpha2,NDimBeta3,NDimBeta4,zeroR) endIf + else if (eris%hasSpinBlock('aabb')) then + r4tOut = eris%alphaBeta else call r4tOut%init(NDimAlpha1,NDimAlpha2,NDimBeta3,NDimBeta4,zeroR) endIf - case('beta-alpha','bbaa') - if (eris%hasSpinBlock('bbaa')) then - r4tOut = eris%betaAlpha - elseif (eris%type().eq.'regular'.or.eris%type().eq.'raffenetti1'.or. & + case('beta-alpha','betaalpha','bbaa') + If (eris%storageType.eq.'exchange'.or.eris%storageType.eq.'inverted') then + call r4tOut%init(NDimBeta1,NDimBeta2,NDimAlpha3,NDimAlpha4,zeroR) + elseIf (eris%integralType.eq.'spin') then + if (eris%hasSpinBlock('bbaa')) then + r4tOut = eris%betaAlpha + else + call r4tOut%init(NDimBeta1,NDimBeta2,NDimAlpha3,NDimAlpha4,zeroR) + end if + elseIf (eris%type().eq.'regular'.or.eris%type().eq.'raffenetti1'.or. & eris%type().eq.'raffenetti2'.or.eris%type().eq.'raffenetti3'.or. & eris%type().eq.'space') then - if (eris%hasSpinBlock('aaaa')) then + If (eris%hasSpinBlock('aaaa')) then r4tOut = eris%alpha else - call r4tOut%init(NDimBeta1,NDimBeta2,NDimAlpha3,NDimAlpha4,zeroR) - endIf - elseIf((eris%type().eq.'spin'.or.eris%type().eq.'general').and.eris%storageType.eq.'symm') then - if (eris%hasSpinBlock('aabb')) then - r4tOut = eris%alphaBeta - else - call r4tOut%init(NDimBeta1,NDimBeta2,NDimAlpha3,NDimAlpha4,zeroR) + call r4tOut%init(NDimAlpha1,NDimAlpha2,NDimBeta3,NDimBeta4,zeroR) endIf + else if (eris%hasSpinBlock('bbaa')) then + r4tOut = eris%betaAlpha else call r4tOut%init(NDimBeta1,NDimBeta2,NDimAlpha3,NDimAlpha4,zeroR) endIf case('abab') - if (eris%hasSpinBlock('abab')) then + If (eris%storageType.eq.'inverted') then + If (eris%type().eq.'regular'.or.eris%type().eq.'raffenetti1'.or. & + eris%type().eq.'raffenetti2'.or.eris%type().eq.'raffenetti3'.or. & + eris%type().eq.'space') then + If (eris%hasSpinBlock('aaaa')) then + r4tOut = eris%alpha + else + call r4tOut%init(NDimAlpha1,NDimBeta2,NDimAlpha3,NDimBeta4,zeroR) + endIf + elseIf (eris%type().eq.'spin') then + If (eris%hasSpinBlock('aabb')) then + r4tOut = eris%alphaBeta + else + call r4tOut%init(NDimAlpha1,NDimBeta2,NDimAlpha3,NDimBeta4,zeroR) + endIf + else + If (eris%hasSpinBlock('abab')) then + r4tOut = eris%abab + else + call r4tOut%init(NDimAlpha1,NDimBeta2,NDimAlpha3,NDimBeta4,zeroR) + endIf + endIf + elseIf (eris%hasSpinBlock('abab')) then r4tOut = eris%abab else call r4tOut%init(NDimAlpha1,NDimBeta2,NDimAlpha3,NDimBeta4,zeroR) endIf case('abba') - if (eris%hasSpinBlock('abba')) then + If (eris%storageType.eq.'exchange') then + If (eris%type().eq.'regular'.or.eris%type().eq.'raffenetti1'.or. & + eris%type().eq.'raffenetti2'.or.eris%type().eq.'raffenetti3'.or. & + eris%type().eq.'space') then + If (eris%hasSpinBlock('aaaa')) then + r4tOut = eris%alpha + else + call r4tOut%init(NDimAlpha1,NDimBeta2,NDimBeta3,NDimAlpha4,zeroR) + endIf + elseIf (eris%type().eq.'spin') then + If (eris%hasSpinBlock('aabb')) then + r4tOut = eris%alphaBeta + else + call r4tOut%init(NDimAlpha1,NDimBeta2,NDimBeta3,NDimAlpha4,zeroR) + endIf + else + If (eris%hasSpinBlock('abba')) then + r4tOut = eris%abba + else + call r4tOut%init(NDimAlpha1,NDimBeta2,NDimBeta3,NDimAlpha4,zeroR) + endIf + endIf + elseIf (eris%hasSpinBlock('abba')) then r4tOut = eris%abba else call r4tOut%init(NDimAlpha1,NDimBeta2,NDimBeta3,NDimAlpha4,zeroR) endIf case('baab') - if (eris%hasSpinBlock('baab')) then - r4tOut = eris%baab - else - if(eris%type().eq.'general'.and.eris%storageType.eq.'symm') then - if (eris%hasSpinBlock('abba')) then - r4tOut = eris%abba + If (eris%storageType.eq.'exchange') then + If (eris%type().eq.'regular'.or.eris%type().eq.'raffenetti1'.or. & + eris%type().eq.'raffenetti2'.or.eris%type().eq.'raffenetti3'.or. & + eris%type().eq.'space') then + If (eris%hasSpinBlock('aaaa')) then + r4tOut = eris%alpha else - call r4tOut%init(NDimbeta1,NDimAlpha2,NDimAlpha3,NDimBeta4,zeroR) + call r4tOut%init(NDimBeta1,NDimAlpha2,NDimAlpha3,NDimBeta4,zeroR) + endIf + elseIf (eris%type().eq.'spin') then + If (eris%hasSpinBlock('bbaa')) then + r4tOut = eris%betaAlpha + else + call r4tOut%init(NDimBeta1,NDimAlpha2,NDimAlpha3,NDimBeta4,zeroR) endIf else - call r4tOut%init(NDimbeta1,NDimAlpha2,NDimAlpha3,NDimBeta4,zeroR) + If (eris%hasSpinBlock('baab')) then + r4tOut = eris%baab + else + call r4tOut%init(NDimBeta1,NDimAlpha2,NDimAlpha3,NDimBeta4,zeroR) + endIf endIf + elseIf (eris%hasSpinBlock('baab')) then + r4tOut = eris%baab + else + call r4tOut%init(NDimBeta1,NDimAlpha2,NDimAlpha3,NDimBeta4,zeroR) endIf case('baba') - if (eris%hasSpinBlock('baba')) then - r4tOut = eris%baba - else - if(eris%type().eq.'general'.and.eris%storageType.eq.'symm') then - if (eris%hasSpinBlock('abab')) then - r4tOut = conjg(eris%abab) + If (eris%storageType.eq.'inverted') then + If (eris%type().eq.'regular'.or.eris%type().eq.'raffenetti1'.or. & + eris%type().eq.'raffenetti2'.or.eris%type().eq.'raffenetti3'.or. & + eris%type().eq.'space') then + If (eris%hasSpinBlock('aaaa')) then + r4tOut = eris%alpha + else + call r4tOut%init(NDimBeta1,NDimAlpha2,NDimBeta3,NDimAlpha4,zeroR) + endIf + elseIf (eris%type().eq.'spin') then + If (eris%hasSpinBlock('bbaa')) then + r4tOut = eris%betaAlpha else call r4tOut%init(NDimBeta1,NDimAlpha2,NDimBeta3,NDimAlpha4,zeroR) endIf else - call r4tOut%init(NDimBeta1,NDimAlpha2,NDimBeta3,NDimAlpha4,zeroR) + If (eris%hasSpinBlock('baba')) then + r4tOut = eris%baba + else + call r4tOut%init(NDimBeta1,NDimAlpha2,NDimBeta3,NDimAlpha4,zeroR) + endIf endIf + elseIf (eris%hasSpinBlock('baba')) then + r4tOut = eris%baba + else + call r4tOut%init(NDimBeta1,NDimAlpha2,NDimBeta3,NDimAlpha4,zeroR) endIf case('aaab') - if (eris%hasSpinBlock('aaab')) then + if (eris%type().eq.'general'.and.eris%hasSpinBlock('aaab')) then r4tOut = eris%aaab else call r4tOut%init(NDimAlpha1,NDimAlpha2,NDimAlpha3,NDimBeta4,zeroR) endIf case('aaba') - if (eris%hasSpinBlock('aaba')) then + if (eris%type().eq.'general'.and.eris%hasSpinBlock('aaba')) then r4tOut = eris%aaba else if(eris%type().eq.'general'.and.eris%storageType.eq.'symm') then @@ -5622,7 +5846,7 @@ function mqc_2ERIs_output_block(eris,blockName) result(r4tOut) endIf endIf case('abaa') - if (eris%hasSpinBlock('abaa')) then + if (eris%type().eq.'general'.and.eris%hasSpinBlock('abaa')) then r4tOut = eris%abaa else if(eris%type().eq.'general'.and.eris%storageType.eq.'symm') then @@ -5636,7 +5860,7 @@ function mqc_2ERIs_output_block(eris,blockName) result(r4tOut) endIf endIf case('baaa') - if (eris%hasSpinBlock('baaa')) then + if (eris%type().eq.'general'.and.eris%hasSpinBlock('baaa')) then r4tOut = eris%baaa else if(eris%type().eq.'general'.and.eris%storageType.eq.'symm') then @@ -5650,7 +5874,7 @@ function mqc_2ERIs_output_block(eris,blockName) result(r4tOut) endIf endIf case('bbba') - if (eris%hasSpinBlock('bbba')) then + if (eris%type().eq.'general'.and.eris%hasSpinBlock('bbba')) then r4tOut = eris%bbba else if(eris%type().eq.'general'.and.eris%storageType.eq.'symm') then @@ -5664,7 +5888,7 @@ function mqc_2ERIs_output_block(eris,blockName) result(r4tOut) endIf endIf case('bbab') - if (eris%hasSpinBlock('bbab')) then + if (eris%type().eq.'general'.and.eris%hasSpinBlock('bbab')) then r4tOut = eris%bbab else if(eris%type().eq.'general'.and.eris%storageType.eq.'symm') then @@ -5678,7 +5902,7 @@ function mqc_2ERIs_output_block(eris,blockName) result(r4tOut) endIf endIf case('babb') - if (eris%hasSpinBlock('babb')) then + if (eris%type().eq.'general'.and.eris%hasSpinBlock('babb')) then r4tOut = eris%babb else if(eris%type().eq.'general'.and.eris%storageType.eq.'symm') then @@ -5692,13 +5916,13 @@ function mqc_2ERIs_output_block(eris,blockName) result(r4tOut) endIf endIf case('abbb') - if (eris%hasSpinBlock('abbb')) then + if (eris%type().eq.'general'.and.eris%hasSpinBlock('abbb')) then r4tOut = eris%abbb else call r4tOut%init(NDimAlpha1,NDimBeta2,NDimBeta3,NDimBeta4,zeroR) endIf case default - call mqc_error_A('unrecognised block name in mqc_eris_output_block', 6, & + call mqc_error_A('unrecognised block name in mqc_2eris_output_block', 6, & 'myBlockName', myBlockName ) end select ! @@ -7007,7 +7231,7 @@ end function mqc_integral_pad ! ========== !> \param[in] IntegralA !> \verbatim -!> IntegralA is type(mqc_matrix) +!> IntegralA is type(mqc_scf_integral) !> The first MQC integral variable to sum. !> \endverbatim !> @@ -7280,7 +7504,7 @@ end function mqc_integral_sum ! Authors: ! ======== !> \author M. M. F. Moraes -!> \date 2024 +!> \date 2024, 2026 ! function mqc_eri_sum(ERIA,ERIB) result(ERIOut) ! @@ -7290,28 +7514,277 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) type(mqc_r4tensor)::aaaa,bbbb,aabb,bbaa,abab,abba,baab,baba,& aaab,aaba,abaa,baaa,bbba,bbab,babb,abbb ! + if(ERIA%integraltype.eq.'empty') then + ERIOut = ERIB + return + elseif(ERIB%integraltype.eq.'empty') then + ERIOut = ERIA + return + end if select case(ERIA%integraltype) case('space') select case (ERIB%integraltype) case('space') - aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') - call mqc_twoeris_allocate(ERIOut,'full','space',aaaa) + select case(ERIA%storType()) + case('coulomb') + select case(ERIB%storType()) + case('coulomb') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + call mqc_twoeris_allocate(ERIOut,'coulomb','space',aaaa) + case('exchange') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + aabb = ERIA%getBlock('aaaa') + abba = ERIB%getBlock('aaaa') + call mqc_twoeris_allocate(ERIOut,'doublebar','spin',& + aaaa,aaaa,aabb,bbaa,abba=abba,baab=baab) + case('inverted') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + aabb = ERIA%getBlock('aaaa') + abab = ERIB%getBlock('aaaa') + call mqc_twoeris_allocate(ERIOut,'ms','spin',& + aaaa,aaaa,aabb,bbaa,baba=baba,abab=abab) + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & + 'ERIB%istoragetype', ERIB%stortype() ) + end select + case('exchange') + select case(ERIB%storType()) + case('coulomb') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + aabb = ERIB%getBlock('aaaa') + abba = ERIA%getBlock('aaaa') + call mqc_twoeris_allocate(ERIOut,'doublebar','spin',& + aaaa,aaaa,aabb,bbaa,abba=abba,baab=baab) + case('exchange') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + call mqc_twoeris_allocate(ERIOut,'exchange','space',aaaa) + case('inverted') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + abba = ERIA%getBlock('aaaa') + abab = ERIB%getBlock('aaaa') + call mqc_twoeris_allocate(ERIOut,'ms','spin',& + aaaa,aaaa,abba=abba,baab=baab,baba=baba,abab=abab) + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & + 'ERIB%istoragetype', ERIB%stortype() ) + end select + case('inverted') + select case(ERIB%storType()) + case('coulomb') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + aabb = ERIB%getBlock('aaaa') + abab = ERIA%getBlock('aaaa') + call mqc_twoeris_allocate(ERIOut,'ms','spin',& + aaaa,aaaa,aabb,bbaa,baba=baba,abab=abab) + case('exchange') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + abba = ERIB%getBlock('aaaa') + abab = ERIA%getBlock('aaaa') + call mqc_twoeris_allocate(ERIOut,'ms','spin',& + aaaa,aaaa,abba=abba,baab=baab,baba=baba,abab=abab) + case('inverted') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + call mqc_twoeris_allocate(ERIOut,'inverted','space',aaaa) + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & + 'ERIB%istoragetype', ERIB%stortype() ) + end select + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & + 'ERIA%istoragetype', ERIA%stortype() ) + end select case('spin') - aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') - bbbb = ERIA%getBlock('aaaa')+ERIB%getBlock('bbbb') - aabb = ERIA%getBlock('aaaa')+ERIB%getBlock('aabb') - bbaa = ERIA%getBlock('aaaa')+ERIB%getBlock('bbaa') - call mqc_twoeris_allocate(ERIOut,'full','spin',aaaa,bbbb,& - aabb,bbaa) + select case(ERIA%storType()) + case('coulomb') + select case(ERIB%storType()) + case('coulomb') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('aaaa')+ERIB%getBlock('bbbb') + aabb = ERIA%getBlock('aaaa')+ERIB%getBlock('aabb') + bbaa = ERIA%getBlock('aaaa')+ERIB%getBlock('bbaa') + call mqc_twoeris_allocate(ERIOut,'coulomb','spin',aaaa,bbbb,aabb,bbaa) + case('exchange') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('aaaa')+ERIB%getBlock('bbbb') + bbaa = ERIA%getBlock('aaaa') + aabb = ERIA%getBlock('aaaa') + abba = ERIB%getBlock('abba') + baab = ERIB%getBlock('baab') + call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab) + case('inverted') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('aaaa')+ERIB%getBlock('bbbb') + bbaa = ERIA%getBlock('aaaa') + aabb = ERIA%getBlock('aaaa') + abab = ERIB%getBlock('abab') + baba = ERIB%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abab=abab,baba=baba) + case('doublebar') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('aaaa')+ERIB%getBlock('bbbb') + bbaa = ERIA%getBlock('aaaa')+ERIB%getBlock('bbaa') + aabb = ERIA%getBlock('aaaa')+ERIB%getBlock('aabb') + abba = ERIB%getBlock('abba') + baab = ERIB%getBlock('baab') + call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab) + case('ms') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('aaaa')+ERIB%getBlock('bbbb') + bbaa = ERIA%getBlock('aaaa')+ERIB%getBlock('bbaa') + aabb = ERIA%getBlock('aaaa')+ERIB%getBlock('aabb') + abba = ERIB%getBlock('abba') + baab = ERIB%getBlock('baab') + abab = ERIB%getBlock('abab') + baba = ERIB%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab,abab=abab,baba=baba) + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & + 'ERIB%istoragetype', ERIB%stortype()) + end select + case('exchange') + select case(ERIB%storType()) + case('coulomb') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('aaaa')+ERIB%getBlock('bbbb') + bbaa = ERIB%getBlock('aaaa') + aabb = ERIB%getBlock('aaaa') + abba = ERIA%getBlock('abba') + baab = ERIA%getBlock('baab') + call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab) + case('exchange') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('aaaa')+ERIB%getBlock('bbbb') + aabb = ERIA%getBlock('aaaa')+ERIB%getBlock('abba') + bbaa = ERIA%getBlock('aaaa')+ERIB%getBlock('abba') + call mqc_twoeris_allocate(ERIOut,'exchange','spin',aaaa,bbbb,aabb,bbaa) + case('inverted') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('aaaa')+ERIB%getBlock('bbbb') + baab = ERIA%getBlock('aaaa') + abba = ERIA%getBlock('aaaa') + abab = ERIB%getBlock('abab') + baba = ERIB%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,& + abba=abba,baab=baab,abab=abab,baba=baba) + case('doublebar') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('aaaa')+ERIB%getBlock('bbbb') + abba = ERIA%getBlock('aaaa')+ERIB%getBlock('abba') + baab = ERIA%getBlock('aaaa')+ERIB%getBlock('baab') + bbaa = ERIB%getBlock('bbaa') + aabb = ERIB%getBlock('aabb') + call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab) + case('ms') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('aaaa')+ERIB%getBlock('bbbb') + bbaa = ERIB%getBlock('bbaa') + aabb = ERIB%getBlock('aabb') + abba = ERIA%getBlock('aaaa')+ERIB%getBlock('abba') + baab = ERIA%getBlock('aaaa')+ERIB%getBlock('baab') + abab = ERIB%getBlock('abab') + baba = ERIB%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab,abab=abab,baba=baba) + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & + 'ERIB%istoragetype', ERIB%stortype() ) + end select + case('inverted') + select case(ERIB%storType()) + case('coulomb') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('aaaa')+ERIB%getBlock('bbbb') + bbaa = ERIB%getBlock('bbaa') + aabb = ERIB%getBlock('aabb') + abab = ERIA%getBlock('aaaa') + baba = ERIA%getBlock('aaaa') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abab=abab,baba=baba) + case('exchange') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('aaaa')+ERIB%getBlock('bbbb') + baab = ERIB%getBlock('baab') + abba = ERIB%getBlock('abba') + abab = ERIA%getBlock('aaaa') + baba = ERIA%getBlock('aaaa') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,& + abba=abba,baab=baab,abab=abab,baba=baba) + case('inverted') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('aaaa')+ERIB%getBlock('bbbb') + aabb = ERIA%getBlock('aaaa')+ERIB%getBlock('abab') + bbaa = ERIA%getBlock('aaaa')+ERIB%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'inverted','spin',aaaa,bbbb,& + abab,baba) + case('doublebar') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('aaaa')+ERIB%getBlock('bbbb') + abba = ERIB%getBlock('abba') + baab = ERIB%getBlock('baab') + bbaa = ERIB%getBlock('bbaa') + aabb = ERIB%getBlock('aabb') + abab = ERIA%getBlock('aaaa') + baba = ERIA%getBlock('aaaa') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab,abab=abab,baba=baba) + case('ms') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('aaaa')+ERIB%getBlock('bbbb') + abba = ERIB%getBlock('abba') + baab = ERIB%getBlock('baab') + bbaa = ERIB%getBlock('bbaa') + aabb = ERIB%getBlock('aabb') + abab = ERIA%getBlock('aaaa')+ERIB%getBlock('abab') + baba = ERIA%getBlock('aaaa')+ERIB%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab,abab=abab,baba=baba) + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & + 'ERIB%istoragetype', ERIB%stortype() ) + end select + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & + 'ERIA%istoragetype', ERIA%stortype() ) + end select case('general') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('aaaa')+ERIB%getBlock('bbbb') - aabb = ERIA%getBlock('aaaa')+ERIB%getBlock('aabb') - bbaa = ERIA%getBlock('aaaa')+ERIB%getBlock('bbaa') + select case(ERIA%storType()) + case('coulomb') + aabb = ERIA%getBlock('aaaa')+ERIB%getBlock('aabb') + bbaa = ERIA%getBlock('aaaa')+ERIB%getBlock('bbaa') + abab = ERIB%getBlock('abab') + baba = ERIB%getBlock('baba') + baab = ERIB%getBlock('baab') + abba = ERIB%getBlock('abba') + case('exchange') + aabb = ERIB%getBlock('aabb') + bbaa = ERIB%getBlock('bbaa') + abab = ERIB%getBlock('abab') + baba = ERIB%getBlock('baba') + baab = ERIA%getBlock('aaaa')+ERIB%getBlock('baab') + abba = ERIA%getBlock('aaaa')+ERIB%getBlock('abba') + case('inverted') + aabb = ERIB%getBlock('aabb') + bbaa = ERIB%getBlock('bbaa') + abab = ERIA%getBlock('aaaa')+ERIB%getBlock('abab') + baba = ERIA%getBlock('aaaa')+ERIB%getBlock('baba') + baab = ERIB%getBlock('baab') + abba = ERIB%getBlock('abba') + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & + 'ERIA%storagetype', ERIA%stortype() ) + end select call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& aabb,bbaa,& - ERIB%getBlock('abab'), ERIB%getBlock('abba'),& - ERIB%getBlock('baab'), ERIB%getBlock('baba'),& + abab,abba,& + baab,baba,& ERIB%getBlock('aaab'), ERIB%getBlock('aaba'),& ERIB%getBlock('abaa'), ERIB%getBlock('baaa'),& ERIB%getBlock('bbba'), ERIB%getBlock('bbab'),& @@ -7323,6 +7796,176 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) case('spin') select case (ERIB%integraltype) case('space') + select case(ERIA%storType()) + case('coulomb') + select case(ERIB%storType()) + case('coulomb') + aaaa = ERIB%getBlock('aaaa')+ERIA%getBlock('aaaa') + bbbb = ERIB%getBlock('aaaa')+ERIA%getBlock('bbbb') + aabb = ERIB%getBlock('aaaa')+ERIA%getBlock('aabb') + bbaa = ERIB%getBlock('aaaa')+ERIA%getBlock('bbaa') + call mqc_twoeris_allocate(ERIOut,'coulomb','spin',aaaa,bbbb,aabb,bbaa) + case('exchange') + aaaa = ERIB%getBlock('aaaa')+ERIA%getBlock('aaaa') + bbbb = ERIB%getBlock('aaaa')+ERIA%getBlock('bbbb') + bbaa = ERIB%getBlock('aaaa') + aabb = ERIB%getBlock('aaaa') + abba = ERIA%getBlock('abba') + baab = ERIA%getBlock('baab') + call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab) + case('inverted') + aaaa = ERIB%getBlock('aaaa')+ERIA%getBlock('aaaa') + bbbb = ERIB%getBlock('aaaa')+ERIA%getBlock('bbbb') + bbaa = ERIB%getBlock('aaaa') + aabb = ERIB%getBlock('aaaa') + abab = ERIA%getBlock('abab') + baba = ERIA%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abab=abab,baba=baba) + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & + 'ERIB%itoragetype', ERIB%stortype() ) + end select + case('exchange') + select case(ERIB%storType()) + case('coulomb') + aaaa = ERIB%getBlock('aaaa')+ERIA%getBlock('aaaa') + bbbb = ERIB%getBlock('aaaa')+ERIA%getBlock('bbbb') + bbaa = ERIA%getBlock('aaaa') + aabb = ERIA%getBlock('aaaa') + abba = ERIB%getBlock('abba') + baab = ERIB%getBlock('baab') + call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab) + case('exchange') + aaaa = ERIB%getBlock('aaaa')+ERIA%getBlock('aaaa') + bbbb = ERIB%getBlock('aaaa')+ERIA%getBlock('bbbb') + aabb = ERIB%getBlock('aaaa')+ERIA%getBlock('abba') + bbaa = ERIB%getBlock('aaaa')+ERIA%getBlock('abba') + call mqc_twoeris_allocate(ERIOut,'exchange','spin',aaaa,bbbb,aabb,bbaa) + case('inverted') + aaaa = ERIB%getBlock('aaaa')+ERIA%getBlock('aaaa') + bbbb = ERIB%getBlock('aaaa')+ERIA%getBlock('bbbb') + baab = ERIB%getBlock('aaaa') + abba = ERIB%getBlock('aaaa') + abab = ERIA%getBlock('abab') + baba = ERIA%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,& + abba=abba,baab=baab,abab=abab,baba=baba) + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & + 'ERIB%itoragetype', ERIB%stortype() ) + end select + case('inverted') + select case(ERIB%storType()) + case('coulomb') + aaaa = ERIB%getBlock('aaaa')+ERIA%getBlock('aaaa') + bbbb = ERIB%getBlock('aaaa')+ERIA%getBlock('bbbb') + bbaa = ERIA%getBlock('bbaa') + aabb = ERIA%getBlock('aabb') + abab = ERIB%getBlock('aaaa') + baba = ERIB%getBlock('aaaa') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abab=abab,baba=baba) + case('exchange') + aaaa = ERIB%getBlock('aaaa')+ERIA%getBlock('aaaa') + bbbb = ERIB%getBlock('aaaa')+ERIA%getBlock('bbbb') + baab = ERIA%getBlock('baab') + abba = ERIA%getBlock('abba') + abab = ERIB%getBlock('aaaa') + baba = ERIB%getBlock('aaaa') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,& + abba=abba,baab=baab,abab=abab,baba=baba) + case('inverted') + aaaa = ERIB%getBlock('aaaa')+ERIA%getBlock('aaaa') + bbbb = ERIB%getBlock('aaaa')+ERIA%getBlock('bbbb') + aabb = ERIB%getBlock('aaaa')+ERIA%getBlock('abab') + bbaa = ERIB%getBlock('aaaa')+ERIA%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'inverted','spin',aaaa,bbbb,& + abab,baba) + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & + 'ERIB%itoragetype', ERIB%stortype() ) + end select + case('doublebar') + select case(ERIB%storType()) + case('coulomb') + aaaa = ERIB%getBlock('aaaa')+ERIA%getBlock('aaaa') + bbbb = ERIB%getBlock('aaaa')+ERIA%getBlock('bbbb') + bbaa = ERIB%getBlock('aaaa')+ERIA%getBlock('bbaa') + aabb = ERIB%getBlock('aaaa')+ERIA%getBlock('aabb') + abba = ERIA%getBlock('abba') + baab = ERIA%getBlock('baab') + call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab) + case('exchange') + aaaa = ERIB%getBlock('aaaa')+ERIA%getBlock('aaaa') + bbbb = ERIB%getBlock('aaaa')+ERIA%getBlock('bbbb') + abba = ERIB%getBlock('aaaa')+ERIA%getBlock('abba') + baab = ERIB%getBlock('aaaa')+ERIA%getBlock('baab') + bbaa = ERIA%getBlock('bbaa') + aabb = ERIA%getBlock('aabb') + call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab) + case('inverted') + aaaa = ERIB%getBlock('aaaa')+ERIA%getBlock('aaaa') + bbbb = ERIB%getBlock('aaaa')+ERIA%getBlock('bbbb') + abba = ERIA%getBlock('abba') + baab = ERIA%getBlock('baab') + bbaa = ERIA%getBlock('bbaa') + aabb = ERIA%getBlock('aabb') + abab = ERIB%getBlock('aaaa') + baba = ERIB%getBlock('aaaa') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab,abab=abab,baba=baba) + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & + 'ERIB%itoragetype', ERIB%stortype() ) + end select + case('ms') + select case(ERIB%storType()) + case('coulomb') + aaaa = ERIB%getBlock('aaaa')+ERIA%getBlock('aaaa') + bbbb = ERIB%getBlock('aaaa')+ERIA%getBlock('bbbb') + bbaa = ERIB%getBlock('aaaa')+ERIA%getBlock('bbaa') + aabb = ERIB%getBlock('aaaa')+ERIA%getBlock('aabb') + abba = ERIA%getBlock('abba') + baab = ERIA%getBlock('baab') + abab = ERIA%getBlock('abab') + baba = ERIA%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab,abab=abab,baba=baba) + case('exchange') + aaaa = ERIB%getBlock('aaaa')+ERIA%getBlock('aaaa') + bbbb = ERIB%getBlock('aaaa')+ERIA%getBlock('bbbb') + bbaa = ERIA%getBlock('bbaa') + aabb = ERIA%getBlock('aabb') + abba = ERIB%getBlock('aaaa')+ERIA%getBlock('abba') + baab = ERIB%getBlock('aaaa')+ERIA%getBlock('baab') + abab = ERIA%getBlock('abab') + baba = ERIA%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab,abab=abab,baba=baba) + case('inverted') + aaaa = ERIB%getBlock('aaaa')+ERIA%getBlock('aaaa') + bbbb = ERIB%getBlock('aaaa')+ERIA%getBlock('bbbb') + abba = ERIA%getBlock('abba') + baab = ERIA%getBlock('baab') + bbaa = ERIA%getBlock('bbaa') + aabb = ERIA%getBlock('aabb') + abab = ERIB%getBlock('aaaa')+ERIA%getBlock('abab') + baba = ERIB%getBlock('aaaa')+ERIA%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab,abab=abab,baba=baba) + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & + 'ERIB%itoragetype', ERIB%stortype() ) + end select + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & + 'ERIA%storagetype', ERIA%stortype() ) + end select aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('aaaa') aabb = ERIA%getBlock('aabb')+ERIB%getBlock('aaaa') @@ -7330,6 +7973,279 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) call mqc_twoeris_allocate(ERIOut,'full','spin',aaaa,bbbb,& aabb,bbaa) case('spin') + select case(ERIA%storType()) + case('coulomb') + select case(ERIB%storType()) + case('coulomb') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') + aabb = ERIA%getBlock('aabb')+ERIB%getBlock('aabb') + bbaa = ERIA%getBlock('bbaa')+ERIB%getBlock('bbaa') + call mqc_twoeris_allocate(ERIOut,'coulomb','spin',aaaa,bbbb,aabb,bbaa) + case('exchange') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') + bbaa = ERIA%getBlock('bbaa') + aabb = ERIA%getBlock('aabb') + abba = ERIB%getBlock('abba') + baab = ERIB%getBlock('baab') + call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab) + case('inverted') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') + bbaa = ERIA%getBlock('bbaa') + aabb = ERIA%getBlock('aabb') + abab = ERIB%getBlock('abab') + baba = ERIB%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abab=abab,baba=baba) + case('doublebar') + aaaa = ERIB%getBlock('aaaa')+ERIA%getBlock('aaaa') + bbbb = ERIB%getBlock('bbbb')+ERIA%getBlock('bbbb') + bbaa = ERIB%getBlock('bbaa')+ERIA%getBlock('bbaa') + aabb = ERIB%getBlock('aabb')+ERIA%getBlock('aabb') + abba = ERIB%getBlock('abba') + baab = ERIB%getBlock('baab') + call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab) + case('ms') + aaaa = ERIB%getBlock('aaaa')+ERIA%getBlock('aaaa') + bbbb = ERIB%getBlock('bbbb')+ERIA%getBlock('bbbb') + bbaa = ERIB%getBlock('bbaa')+ERIA%getBlock('bbaa') + aabb = ERIB%getBlock('aabb')+ERIA%getBlock('aabb') + abba = ERIB%getBlock('abba') + baab = ERIB%getBlock('baab') + abab = ERIB%getBlock('abab') + baba = ERIA%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab,abab=abab,baba=baba) + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & + 'ERIB%storagetype', ERIB%stortype() ) + end select + case('exchange') + select case(ERIB%storType()) + case('coulomb') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') + bbaa = ERIB%getBlock('bbaa') + aabb = ERIB%getBlock('aabb') + abba = ERIA%getBlock('abba') + baab = ERIA%getBlock('baab') + call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab) + case('exchange') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') + aabb = ERIA%getBlock('abba')+ERIB%getBlock('abba') + bbaa = ERIA%getBlock('baab')+ERIB%getBlock('baab') + call mqc_twoeris_allocate(ERIOut,'exchange','spin',aaaa,bbbb,aabb,bbaa) + case('inverted') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') + abba = ERIA%getBlock('abba') + baab = ERIA%getBlock('baab') + abab = ERIB%getBlock('abab') + baba = ERIB%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,& + abba=abba,baab=baab,abab=abab,baba=baba) + case('doublebar') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') + bbaa = ERIB%getBlock('bbaa') + aabb = ERIB%getBlock('aabb') + abba = ERIA%getBlock('abba')+ERIB%getBlock('abba') + baab = ERIA%getBlock('baab')+ERIB%getBlock('baab') + call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab) + case('ms') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') + bbaa = ERIB%getBlock('bbaa') + aabb = ERIB%getBlock('aabb') + abba = ERIA%getBlock('abba')+ERIB%getBlock('abba') + baab = ERIA%getBlock('baab')+ERIB%getBlock('baab') + abab = ERIB%getBlock('abab') + baba = ERIB%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab,abab=abab,baba=baba) + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & + 'ERIB%storagetype', ERIB%stortype() ) + end select + case('inverted') + select case(ERIB%storType()) + case('coulomb') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') + bbaa = ERIB%getBlock('bbaa') + aabb = ERIB%getBlock('aabb') + abab = ERIA%getBlock('abab') + baba = ERIA%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abab=abab,baba=baba) + case('exchange') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') + abba = ERIB%getBlock('abba') + baab = ERIB%getBlock('baab') + abab = ERIA%getBlock('abab') + baba = ERIA%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,& + abba=abba,baab=baab,abab=abab,baba=baba) + case('inverted') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') + aabb = ERIA%getBlock('abab')+ERIB%getBlock('abab') + bbaa = ERIA%getBlock('abab')+ERIB%getBlock('abab') + call mqc_twoeris_allocate(ERIOut,'inverted','spin',aaaa,bbbb,aabb,bbaa) + case('doublebar') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') + bbaa = ERIB%getBlock('bbaa') + aabb = ERIB%getBlock('aabb') + abba = ERIB%getBlock('abba') + baab = ERIB%getBlock('baab') + abab = ERIA%getBlock('abab') + baba = ERIA%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab,abab=abab,baba=baba) + case('ms') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') + bbaa = ERIB%getBlock('bbaa') + aabb = ERIB%getBlock('aabb') + abba = ERIB%getBlock('abba') + baab = ERIB%getBlock('baab') + abab = ERIA%getBlock('abab')+ERIB%getBlock('abab') + baba = ERIA%getBlock('baba')+ERIB%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab,abab=abab,baba=baba) + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & + 'ERIB%storagetype', ERIB%stortype() ) + end select + case('doublebar') + select case(ERIB%storType()) + case('coulomb') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') + bbaa = ERIA%getBlock('bbaa')+ERIB%getBlock('bbaa') + aabb = ERIA%getBlock('aabb')+ERIB%getBlock('aabb') + abba = ERIA%getBlock('abba') + baab = ERIA%getBlock('baab') + call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab) + case('exchange') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') + bbaa = ERIA%getBlock('bbaa') + aabb = ERIA%getBlock('aabb') + abba = ERIA%getBlock('abba')+ERIB%getBlock('abba') + baab = ERIA%getBlock('baab')+ERIB%getBlock('baab') + call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab) + case('inverted') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') + bbaa = ERIA%getBlock('bbaa') + aabb = ERIA%getBlock('aabb') + abba = ERIA%getBlock('abba') + baab = ERIA%getBlock('baab') + abab = ERIB%getBlock('abab') + baba = ERIB%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab,abab=abab,baba=baba) + case('doublebar') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') + bbaa = ERIA%getBlock('bbaa')+ERIB%getBlock('bbaa') + aabb = ERIA%getBlock('aabb')+ERIB%getBlock('aabb') + abba = ERIA%getBlock('abba')+ERIB%getBlock('abba') + baab = ERIA%getBlock('baab')+ERIB%getBlock('baab') + call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab) + case('ms') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') + bbaa = ERIA%getBlock('bbaa')+ERIB%getBlock('bbaa') + aabb = ERIA%getBlock('aabb')+ERIB%getBlock('aabb') + abba = ERIA%getBlock('abba')+ERIB%getBlock('abba') + baab = ERIA%getBlock('baab')+ERIB%getBlock('baab') + abab = ERIB%getBlock('abab') + baba = ERIB%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab,abab=abab,baba=baba) + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & + 'ERIB%storagetype', ERIB%stortype() ) + end select + case('ms') + select case(ERIB%storType()) + case('coulomb') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') + bbaa = ERIA%getBlock('bbaa')+ERIB%getBlock('bbaa') + aabb = ERIA%getBlock('aabb')+ERIB%getBlock('aabb') + abba = ERIA%getBlock('abba') + baab = ERIA%getBlock('baab') + abab = ERIA%getBlock('abab') + baba = ERIA%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab,abab=abab,baba=baba) + case('exchange') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') + bbaa = ERIA%getBlock('bbaa') + aabb = ERIA%getBlock('aabb') + abba = ERIA%getBlock('abba')+ERIB%getBlock('abba') + baab = ERIA%getBlock('baab')+ERIB%getBlock('baab') + abab = ERIA%getBlock('abab') + baba = ERIA%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab,abab=abab,baba=baba) + case('inverted') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') + bbaa = ERIA%getBlock('bbaa') + aabb = ERIA%getBlock('aabb') + abba = ERIA%getBlock('abba') + baab = ERIA%getBlock('baab') + abab = ERIA%getBlock('abab')+ERIB%getBlock('abab') + baba = ERIA%getBlock('baba')+ERIB%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab,abab=abab,baba=baba) + case('doublebar') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') + bbaa = ERIA%getBlock('bbaa')+ERIB%getBlock('bbaa') + aabb = ERIA%getBlock('aabb')+ERIB%getBlock('aabb') + abba = ERIA%getBlock('abba')+ERIB%getBlock('abba') + baab = ERIA%getBlock('baab')+ERIB%getBlock('baab') + abab = ERIA%getBlock('abab') + baba = ERIA%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab,abab=abab,baba=baba) + case('ms') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') + bbaa = ERIA%getBlock('bbaa')+ERIB%getBlock('bbaa') + aabb = ERIA%getBlock('aabb')+ERIB%getBlock('aabb') + abba = ERIA%getBlock('abba')+ERIB%getBlock('abba') + baab = ERIA%getBlock('baab')+ERIB%getBlock('baab') + abab = ERIA%getBlock('abab')+ERIB%getBlock('abab') + baba = ERIA%getBlock('baba')+ERIB%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab,abab=abab,baba=baba) + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & + 'ERIB%storagetype', ERIB%stortype() ) + end select + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & + 'ERIA%storagetype', ERIA%stortype() ) + end select aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') aabb = ERIA%getBlock('aabb')+ERIB%getBlock('aabb') @@ -7358,12 +8274,36 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) case('space') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('aaaa') - aabb = ERIA%getBlock('aabb')+ERIB%getBlock('aaaa') - bbaa = ERIA%getBlock('bbaa')+ERIB%getBlock('aaaa') + select case(ERIB%storType()) + case('coulomb') + aabb = ERIA%getBlock('aabb')+ERIB%getBlock('aaaa') + bbaa = ERIA%getBlock('bbaa')+ERIB%getBlock('aaaa') + abab = ERIA%getBlock('abab') + baba = ERIA%getBlock('baba') + baab = ERIA%getBlock('baab') + abba = ERIA%getBlock('abba') + case('exchange') + aabb = ERIA%getBlock('aabb') + bbaa = ERIA%getBlock('bbaa') + abab = ERIA%getBlock('abab') + baba = ERIA%getBlock('baba') + baab = ERIA%getBlock('baab')+ERIB%getBlock('aaaa') + abba = ERIA%getBlock('abba')+ERIB%getBlock('aaaa') + case('inverted') + aabb = ERIA%getBlock('aabb') + bbaa = ERIA%getBlock('bbaa') + abab = ERIA%getBlock('abab')+ERIB%getBlock('aaaa') + baba = ERIA%getBlock('baba')+ERIB%getBlock('aaaa') + baab = ERIA%getBlock('baab') + abba = ERIA%getBlock('abba') + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & + 'ERIB%storagetype', ERIB%stortype() ) + end select call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& aabb,bbaa,& - ERIA%getBlock('abab'), ERIA%getBlock('abba'),& - ERIA%getBlock('baab'), ERIA%getBlock('baba'),& + abab,abba,& + baab,baba,& ERIA%getBlock('aaab'), ERIA%getBlock('aaba'),& ERIA%getBlock('abaa'), ERIA%getBlock('baaa'),& ERIA%getBlock('bbba'), ERIA%getBlock('bbab'),& @@ -7371,12 +8311,50 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) case('spin') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') - aabb = ERIA%getBlock('aabb')+ERIB%getBlock('aabb') - bbaa = ERIA%getBlock('bbaa')+ERIB%getBlock('bbaa') + select case(ERIA%storType()) + case('coulomb') + aabb = ERIA%getBlock('aabb')+ERIB%getBlock('aabb') + bbaa = ERIA%getBlock('bbaa')+ERIB%getBlock('bbaa') + abab = ERIB%getBlock('abab') + baba = ERIB%getBlock('baba') + baab = ERIB%getBlock('baab') + abba = ERIB%getBlock('abba') + case('exchange') + aabb = ERIB%getBlock('aabb') + bbaa = ERIB%getBlock('bbaa') + abab = ERIB%getBlock('abab') + baba = ERIB%getBlock('baba') + baab = ERIA%getBlock('baab')+ERIB%getBlock('baab') + abba = ERIA%getBlock('abba')+ERIB%getBlock('abba') + case('inverted') + aabb = ERIB%getBlock('aabb') + bbaa = ERIB%getBlock('bbaa') + abab = ERIA%getBlock('abab')+ERIB%getBlock('abab') + baba = ERIA%getBlock('baba')+ERIB%getBlock('baba') + baab = ERIB%getBlock('baab') + abba = ERIB%getBlock('abba') + case('doublebar') + aabb = ERIB%getBlock('aabb')+ERIB%getBlock('aabb') + bbaa = ERIB%getBlock('bbaa')+ERIB%getBlock('bbaa') + abab = ERIB%getBlock('abab') + baba = ERIB%getBlock('baba') + baab = ERIA%getBlock('baab')+ERIB%getBlock('baab') + abba = ERIA%getBlock('abba')+ERIB%getBlock('abba') + case('ms') + aabb = ERIB%getBlock('aabb')+ERIB%getBlock('aabb') + bbaa = ERIB%getBlock('bbaa')+ERIB%getBlock('bbaa') + abab = ERIB%getBlock('abab')+ERIB%getBlock('abab') + baba = ERIB%getBlock('baba')+ERIB%getBlock('baba') + baab = ERIA%getBlock('baab')+ERIB%getBlock('baab') + abba = ERIA%getBlock('abba')+ERIB%getBlock('abba') + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & + 'ERIA%storagetype', ERIA%stortype() ) + end select call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& aabb,bbaa,& - ERIA%getBlock('abab'), ERIA%getBlock('abba'),& - ERIA%getBlock('baab'), ERIA%getBlock('baba'),& + abab,abba,& + baab,baba,& ERIA%getBlock('aaab'), ERIA%getBlock('aaba'),& ERIA%getBlock('abaa'), ERIA%getBlock('baaa'),& ERIA%getBlock('bbba'), ERIA%getBlock('bbab'),& @@ -7408,6 +8386,7 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) call mqc_error_A('Unknown twoERI type in mqc_eri_sum', 6, & 'ERIA%integraltype', ERIA%integraltype ) end select +! end function mqc_eri_sum ! ! @@ -7962,7 +8941,7 @@ end function mqc_eri_difference ! ========== !> \param[in] IntegralA !> \verbatim -!> IntegralA is type(mqc_matrix) +!> IntegralA is type(mqc_scf_integral) !> The first MQC integral type variable to multiply. !> \endverbatim !> @@ -8168,7 +9147,7 @@ end function mqc_integral_integral_multiply !> \verbatim !> !> MQC_Scalar_Integral_Multiply is used to multiply an MQC scalar with an MQC -!> integral type variable and returns an MQC integral +!> integral type variable and returns an MQC integral !> !> \endverbatim ! @@ -8790,14 +9769,14 @@ function mqc_integral_integral_outer_product(integralA,integralB) result(ERIsOut implicit none class(mqc_scf_integral),intent(in)::integralA type(mqc_scf_integral),intent(in)::integralB - type(mqc_twoERIs)::ERIsOut - + type(mqc_twoERIs)::ERIsOut Character(len=15)::intType - Integer(kind=int64)::NBasis + Integer(kind=int64)::NRowAlphaA,NRowBetaA,NRowAlphaB,NRowBetaB + Integer(kind=int64)::NColAlphaA,NColBetaA,NColAlphaB,NColBetaB Type(mqc_matrix)::AlphaA,AlphaB,BetaA,BetaB,AlBeA,AlBeB,BeAlA,BeAlB Type(mqc_r4tensor)::Alpha,Beta,AlphaBeta,BetaAlpha,aaab,aaba,abaa,baaa,abab, & baab,baba,abba,bbba,bbab,babb,abbb - +! if(integralA%array_type.eq.'general'.or.integralB%array_type.eq.'general') then intType='general' elseif(integralA%array_type.eq.'spin'.or.integralB%array_type.eq.'spin') then @@ -8809,31 +9788,41 @@ function mqc_integral_integral_outer_product(integralA,integralB) result(ERIsOut 'integralA%array_type', integralA%array_type,& 'integralB%array_type', integralB%array_type ) end if + NRowAlphaA = MQC_Matrix_Rows(integralA%Alpha) + NRowAlphaB = MQC_Matrix_Rows(integralB%Alpha) + NColAlphaA = MQC_Matrix_Columns(integralA%Alpha) + NColAlphaB = MQC_Matrix_Columns(integralB%Alpha) if(integralA%array_type.eq.'general'.or.integralA%array_type.eq.'spin') then - NBasis = max(MQC_Matrix_Rows(integralA%Alpha),MQC_Matrix_Rows(integralA%Beta)) + NRowBetaA = MQC_Matrix_Rows(integralA%Beta) + NRowBetaB = MQC_Matrix_Rows(integralB%Beta) + NColBetaA = MQC_Matrix_Columns(integralA%Beta) + NColBetaB = MQC_Matrix_Columns(integralB%Beta) else - NBasis = MQC_Matrix_Rows(integralA%Alpha) + NRowBetaA = NRowAlphaA + NRowBetaB = NRowAlphaB + NColBetaA = NColAlphaA + NColBetaB = NColAlphaB end if - call Alpha%init(NBasis,NBasis,NBasis,NBasis) + call Alpha%init(NRowAlphaA,NColAlphaA,NRowAlphaB,NColAlphaB) if(intType.ne.'space') then - call Beta%init(NBasis,NBasis,NBasis,NBasis) - call AlphaBeta%init(NBasis,NBasis,NBasis,NBasis) - call BetaAlpha%init(NBasis,NBasis,NBasis,NBasis) + call Beta%init(NRowBetaA,NColBetaA,NRowBetaB,NColBetaB) + call AlphaBeta%init(NRowAlphaA,NColAlphaA,NRowBetaB,NColBetaB) + call BetaAlpha%init(NRowBetaA,NColBetaA,NRowAlphaB,NColAlphaB) endif if(intType.ne.'general') then - call aaab%init(NBasis,NBasis,NBasis,NBasis) - call aaba%init(NBasis,NBasis,NBasis,NBasis) - call abaa%init(NBasis,NBasis,NBasis,NBasis) - call baaa%init(NBasis,NBasis,NBasis,NBasis) - call abab%init(NBasis,NBasis,NBasis,NBasis) - call baab%init(NBasis,NBasis,NBasis,NBasis) - call baba%init(NBasis,NBasis,NBasis,NBasis) - call abba%init(NBasis,NBasis,NBasis,NBasis) - call bbba%init(NBasis,NBasis,NBasis,NBasis) - call bbab%init(NBasis,NBasis,NBasis,NBasis) - call babb%init(NBasis,NBasis,NBasis,NBasis) - call abbb%init(NBasis,NBasis,NBasis,NBasis) + ! call aaab%init(NRowAlphaA,NColAlphaA,NRowAlphaB,NColBetaB) + ! call aaba%init(NRowAlphaA,NColAlphaA,NRowBetaB,NColAlphaB) + ! call abaa%init(NRowAlphaA,NColBetaA,NRowAlphaB,NColAlphaB) + ! call baaa%init(NRowBetaA,NColAlphaA,NRowAlphaB,NColAlphaB) + call abab%init(NRowAlphaA,NColBetaA,NRowAlphaB,NColBetaB) + call baab%init(NRowBetaA,NColAlphaA,NRowAlphaB,NColBetaB) + call baba%init(NRowBetaA,NColAlphaA,NRowBetaB,NColAlphaB) + call abba%init(NRowAlphaA,NColBetaA,NRowBetaB,NColAlphaB) + ! call bbba%init(NRowBetaA,NColBetaA,NRowBetaB,NColAlphaB) + ! call bbab%init(NRowBetaA,NColBetaA,NRowAlphaB,NColBetaB) + ! call babb%init(NRowBetaA,NColAlphaA,NRowBetaB,NColBetaB) + ! call abbb%init(NRowAlphaA,NColBetaA,NRowBetaB,NColBetaB) endif AlphaA=integralA%getBlock('alpha') @@ -8856,16 +9845,16 @@ function mqc_integral_integral_outer_product(integralA,integralB) result(ERIsOut endif if(intType.eq.'general') then if(integralA%array_type.eq.'general') then - AlBeA=integralA%getBlock('alphabeta') - BeAlA=integralA%getBlock('betaalpha') + AlBeA=integralA%getBlock('betaalpha') + BeAlA=integralA%getBlock('alphabeta') abaa = AlBeA.outer.AlphaB baaa = BeAlA.outer.AlphaB abbb = AlBeA.outer.BetaB babb = BeAlA.outer.BetaB end if if(integralB%array_type.eq.'general') then - AlBeB=integralB%getBlock('alphabeta') - BeAlB=integralB%getBlock('betaalpha') + AlBeB=integralB%getBlock('betaalpha') + BeAlB=integralB%getBlock('alphabeta') aaab = AlphaA.outer.AlBeB aaba = AlphaA.outer.BeAlB bbab = BetaA.outer.AlBeB @@ -8879,15 +9868,17 @@ function mqc_integral_integral_outer_product(integralA,integralB) result(ERIsOut end if end if if (intType.eq.'space') then - call mqc_twoeris_allocate(ERIsOut,'full','space',Alpha) + call mqc_twoeris_allocate(ERIsOut,'coulomb','space',Alpha) elseif (intType.eq.'spin') then - call mqc_twoeris_allocate(ERIsOut,'full','spin',Alpha,Beta,AlphaBeta,BetaAlpha) + call mqc_twoeris_allocate(ERIsOut,'coulomb','spin',Alpha,Beta,AlphaBeta,BetaAlpha) elseif (intType.eq.'general') then call mqc_twoeris_allocate(ERIsOut,'full','general',Alpha,Beta,AlphaBeta,BetaAlpha,& abab,abba,baab,baba,aaab,aaba,abaa,baaa,bbba,bbab,babb,abbb) + !call mqc_twoeris_allocate(ERIsOut,'ms','spin',Alpha,Beta,AlphaBeta,BetaAlpha,& + ! abab,abba,baab,baba) endif +! end function mqc_integral_integral_outer_product - ! ! ! PROCEDURE MQC_Integral_Integral_CrossOuter_Product @@ -8928,13 +9919,13 @@ function mqc_integral_integral_crossouter_product(integralA,integralB) result(ER class(mqc_scf_integral),intent(in)::integralA type(mqc_scf_integral),intent(in)::integralB type(mqc_twoERIs)::ERIsOut - +! Character(len=15)::intType Integer(kind=int64)::NBasis Type(mqc_matrix)::AlphaA,AlphaB,BetaA,BetaB,AlBeA,AlBeB,BeAlA,BeAlB Type(mqc_r4tensor)::Alpha,Beta,AlphaBeta,BetaAlpha,aaab,aaba,abaa,baaa,abab, & baab,baba,abba,bbba,bbab,babb,abbb - +! if(integralA%array_type.eq.'general'.or.integralB%array_type.eq.'general') then intType='general' elseif(integralA%array_type.eq.'spin'.or.integralB%array_type.eq.'spin') then @@ -8946,28 +9937,28 @@ function mqc_integral_integral_crossouter_product(integralA,integralB) result(ER 'integralA%array_type', integralA%array_type,& 'integralB%array_type', integralB%array_type ) end if - if(integralA%array_type.eq.'general'.or.integralA%array_type.eq.'spin') then - NBasis = max(MQC_Matrix_Rows(integralA%Alpha),MQC_Matrix_Rows(integralA%Beta)) - else - NBasis = MQC_Matrix_Rows(integralA%Alpha) - end if - - call Alpha%init(NBasis,NBasis,NBasis,NBasis) - call Beta%init(NBasis,NBasis,NBasis,NBasis) - call AlphaBeta%init(NBasis,NBasis,NBasis,NBasis) - call BetaAlpha%init(NBasis,NBasis,NBasis,NBasis) - call aaab%init(NBasis,NBasis,NBasis,NBasis) - call aaba%init(NBasis,NBasis,NBasis,NBasis) - call abaa%init(NBasis,NBasis,NBasis,NBasis) - call baaa%init(NBasis,NBasis,NBasis,NBasis) - call abab%init(NBasis,NBasis,NBasis,NBasis) - call baab%init(NBasis,NBasis,NBasis,NBasis) - call baba%init(NBasis,NBasis,NBasis,NBasis) - call abba%init(NBasis,NBasis,NBasis,NBasis) - call bbba%init(NBasis,NBasis,NBasis,NBasis) - call bbab%init(NBasis,NBasis,NBasis,NBasis) - call babb%init(NBasis,NBasis,NBasis,NBasis) - call abbb%init(NBasis,NBasis,NBasis,NBasis) + !if(integralA%array_type.eq.'general'.or.integralA%array_type.eq.'spin') then + ! NBasis = max(MQC_Matrix_Rows(integralA%Alpha),MQC_Matrix_Rows(integralA%Beta)) + !else + ! NBasis = MQC_Matrix_Rows(integralA%Alpha) + !end if + + !call Alpha%init(NBasis,NBasis,NBasis,NBasis) + !call Beta%init(NBasis,NBasis,NBasis,NBasis) + !call AlphaBeta%init(NBasis,NBasis,NBasis,NBasis) + !call BetaAlpha%init(NBasis,NBasis,NBasis,NBasis) + !call aaab%init(NBasis,NBasis,NBasis,NBasis) + !call aaba%init(NBasis,NBasis,NBasis,NBasis) + !call abaa%init(NBasis,NBasis,NBasis,NBasis) + !call baaa%init(NBasis,NBasis,NBasis,NBasis) + !call abab%init(NBasis,NBasis,NBasis,NBasis) + !call baab%init(NBasis,NBasis,NBasis,NBasis) + !call baba%init(NBasis,NBasis,NBasis,NBasis) + !call abba%init(NBasis,NBasis,NBasis,NBasis) + !call bbba%init(NBasis,NBasis,NBasis,NBasis) + !call bbab%init(NBasis,NBasis,NBasis,NBasis) + !call babb%init(NBasis,NBasis,NBasis,NBasis) + !call abbb%init(NBasis,NBasis,NBasis,NBasis) AlphaA=integralA%getBlock('alpha') AlphaB=integralB%getBlock('alpha') @@ -9007,10 +9998,16 @@ function mqc_integral_integral_crossouter_product(integralA,integralB) result(ER BetaAlpha = BeAlA.crossouter.AlBeB baba = BeAlA.crossouter.BeAlB end if - call mqc_twoeris_allocate(ERIsOut,'full','general',Alpha,Beta,AlphaBeta,BetaAlpha,& - abab,abba,baab,baba,aaab,aaba,abaa,baaa,bbba,bbab,babb,abbb) + if (intType.eq.'space') then + call mqc_twoeris_allocate(ERIsOut,'exchange','space',Alpha) + elseif (intType.eq.'spin') then + call mqc_twoeris_allocate(ERIsOut,'exchange','spin',Alpha,Beta,AlphaBeta,BetaAlpha) + elseif (intType.eq.'general') then + call mqc_twoeris_allocate(ERIsOut,'full','general',Alpha,Beta,AlphaBeta,BetaAlpha,& + abab,abba,baab,baba,aaab,aaba,abaa,baaa,bbba,bbab,babb,abbb) + endif +! end function mqc_integral_integral_crossouter_product - ! ! ! PROCEDURE MQC_Eigen_Eigen_Outer_Product @@ -11604,7 +12601,7 @@ function mqc_eri_eri_partial_contraction(eris1,eris2,index1,index2) result(IntOu type(mqc_twoERIs),intent(in)::eris1,eris2 integer(kind=int64),dimension(4),intent(in),optional::index1,index2 type(mqc_scf_integral)::IntOut - +! type(mqc_matrix)::aa,ab,ba,bb character(len=64)::mylabel,intType integer(kind=int64)::r4t1,r4t2,r4t3,r4t4,nB1,nB2,nB3,nB4 @@ -11613,9 +12610,8 @@ function mqc_eri_eri_partial_contraction(eris1,eris2,index1,index2) result(IntOu Integer(kind=int64)::dimAi,dimAj,dimAk,dimAl,dimBi,dimBj,dimBk,dimBl character(len=4)::str1,str2,active_conf character(len=4),dimension(4)::allowed_spin,a_bbb_array,aaa_b_array - character(len=4),dimension(6)::aa_bb_array - - + character(len=4),dimension(6)::aa_bb_array +! aa_bb_array=['aabb','abab','abba','baab','baba','bbaa'] a_bbb_array=['abbb','babb','bbab','bbba'] aaa_b_array=['baaa','abaa','aaba','aaab'] @@ -11981,7 +12977,7 @@ end function mqc_eri_eri_partial_contraction ! Authors: ! ======== !> \author M. M. F. Moraes -!> \date 2025 +!> \date 2025, 2026 ! function mqc_eri_eri_partial_contraction_2eri(eris1,eris2,index1,index2) result(eriOut) ! @@ -11993,7 +12989,7 @@ function mqc_eri_eri_partial_contraction_2eri(eris1,eris2,index1,index2) result( type(MQC_R4Tensor)::aaaa,aaab,aaba,abaa,baaa,aabb,abab,baab,abba,baba,bbaa,& abbb,babb,bbab,bbba,bbbb type(MQC_R4Tensor)::tmp_aaaa,tmp_bbbb - character(len=64)::mylabel,eriType + character(len=64)::mylabel,eriType,storType integer(kind=int64)::r4t1,r4t2,r4t3,r4t4,nB1,nB2,nB3,nB4 type(mqc_twoERIs)::temp Integer(kind=int64)::ia,ja,ka,la,ib,jb,kb,lb,i,j,k,l @@ -12002,13 +12998,13 @@ function mqc_eri_eri_partial_contraction_2eri(eris1,eris2,index1,index2) result( character(len=4),dimension(4)::allowed_spin,a_bbb_array,aaa_b_array character(len=4),dimension(6)::aa_bb_array character(len=4),dimension(16)::full_array - + logical,dimension(16)::allocVec +! full_array =['aaaa','bbbb','aabb','abab','abba','baab','baba','bbaa',& 'abbb','babb','bbab','bbba','baaa','abaa','aaba','aaab'] aa_bb_array=['aabb','abab','abba','baab','baba','bbaa'] a_bbb_array=['abbb','babb','bbab','bbba'] aaa_b_array=['baaa','abaa','aaba','aaab'] - ! if(present(index1)) then ia=index1(1) @@ -12062,11 +13058,17 @@ function mqc_eri_eri_partial_contraction_2eri(eris1,eris2,index1,index2) result( la.gt.4.or.la.le.0.or.lb.gt.4.or.lb.le.0.) Call MQC_Error(& 'Index out of range in MQC_ERI_ERI_Partial_Contraction_2eri', 6) - if (eris1%blockSize('alpha',ia).ne.eris2%blockSize('alpha',ib).or.& - eris1%blockSize('alpha',ja).ne.eris2%blockSize('alpha',jb))& - call mqc_error_i('2ERIs not correctly dimensioned in mqc_eri_eri_contraction_2eri',6,& - 'dim1',eris1%blockSize('alpha',ia),'dim2',eris2%blockSize('alpha',ib),& - 'dim3',eris1%blockSize('alpha',ja),'dim4',eris2%blockSize('alpha',jb)) + if(eris1%storageType.eq.'empty'.or.eris2%storageType.eq.'empty') then + call mqc_twoeris_allocate(eriOut,'empty','empty') + return + end if + + + if (eris1%blockSize('alpha',ia).ne.eris2%blockSize('alpha',ib).or.& + eris1%blockSize('alpha',ja).ne.eris2%blockSize('alpha',jb))& + call mqc_error_i('2ERIs not correctly dimensioned in mqc_eri_eri_contraction_2eri',6,& + 'dim1',eris1%blockSize('alpha',ia),'dim2',eris2%blockSize('alpha',ib),& + 'dim3',eris1%blockSize('alpha',ja),'dim4',eris2%blockSize('alpha',jb)) call aaaa%init(eris1%blockSize('alpha',ka),eris1%blockSize('alpha',la),& eris2%blockSize('alpha',kb),eris2%blockSize('alpha',lb)) @@ -12092,378 +13094,227 @@ function mqc_eri_eri_partial_contraction_2eri(eris1,eris2,index1,index2) result( eris2%blockSize('alpha',kb),eris2%blockSize('beta',lb)) call bbba%init(eris1%blockSize('beta',ka),eris1%blockSize('beta',la),& eris2%blockSize('beta',kb),eris2%blockSize('alpha',lb)) + call baaa%init(eris1%blockSize('beta',ka),eris1%blockSize('alpha',la),& + eris2%blockSize('alpha',kb),eris2%blockSize('alpha',lb)) + call abaa%init(eris1%blockSize('alpha',ka),eris1%blockSize('beta',la),& + eris2%blockSize('alpha',kb),eris2%blockSize('alpha',lb)) + call aaba%init(eris1%blockSize('alpha',ka),eris1%blockSize('alpha',la),& + eris2%blockSize('beta',kb),eris2%blockSize('alpha',lb)) + call aaab%init(eris1%blockSize('alpha',ka),eris1%blockSize('alpha',la),& + eris2%blockSize('alpha',kb),eris2%blockSize('beta',lb)) - eriType='spin' + storType='unknown' + eriType='empty' do i=1,16 - active_conf_1=full_array(i) - str1=mqc_index_to_string([ia,ja,ka,la],active_conf_1) + allocVec(i)=.true. + end do + eriType='space' + do i=1,16 + str1=full_array(i) + active_conf_1=mqc_index_to_string([ia,ja,ka,la],str1) do j=1,16 - active_conf_2=full_array(j) + str2=full_array(j) + active_conf_2=mqc_index_to_string([ib,jb,kb,lb],str2) active_conf=trim(active_conf_1(3:4))//trim(active_conf_2(3:4)) - str2=mqc_index_to_string([ib,jb,kb,lb],active_conf_2) if (active_conf_1(1:2).eq.active_conf_2(1:2)) then + if((eris1%storageType.eq.'coulomb'.or.& + eris1%storageType.eq.'regular').and.(& + str1.ne.'aaaa'.and.str1.ne.'aabb'.and.& + str1.ne.'bbaa'.and.str1.ne.'bbbb')) cycle + if((eris2%storageType.eq.'coulomb'.or.& + eris2%storageType.eq.'regular').and.(& + str2.ne.'aaaa'.and.str2.ne.'aabb'.and.& + str2.ne.'bbaa'.and.str2.ne.'bbbb')) cycle + if(eris1%storageType.eq.'exchange'.and.(& + str1.ne.'aaaa'.and.str1.ne.'baab'.and.& + str1.ne.'abba'.and.str1.ne.'bbbb')) cycle + if(eris2%storageType.eq.'exchange'.and.(& + str2.ne.'aaaa'.and.str2.ne.'baab'.and.& + str2.ne.'abba'.and.str2.ne.'bbbb')) cycle + if(eris1%storageType.eq.'inverted'.and.(& + str1.ne.'aaaa'.and.str1.ne.'baba'.and.& + str1.ne.'abab'.and.str1.ne.'bbbb')) cycle + if(eris2%storageType.eq.'inverted'.and.(& + str2.ne.'aaaa'.and.str2.ne.'baba'.and.& + str2.ne.'abab'.and.str2.ne.'bbbb')) cycle + if(eris1%storageType.eq.'doublebar'.and.(& + str1.ne.'aaaa'.and.str1.ne.'abba'.and.& + str1.ne.'baab'.and.str1.ne.'bbbb'.and.& + str1.ne.'bbaa'.and.str1.ne.'aabb')) cycle + if(eris2%storageType.eq.'doublebar'.and.(& + str2.ne.'aaaa'.and.str2.ne.'abba'.and.& + str2.ne.'baab'.and.str2.ne.'bbbb'.and.& + str2.ne.'bbaa'.and.str2.ne.'aabb')) cycle + if(eris1%storageType.eq.'ms'.and.(& + str1.ne.'aaaa'.and.str1.ne.'bbbb'.and.& + str1.ne.'abab'.and.str1.ne.'baba'.and.& + str1.ne.'baab'.and.str1.ne.'abba'.and.& + str1.ne.'bbaa'.and.str1.ne.'aabb')) cycle + if(eris2%storageType.eq.'ms'.and.(& + str2.ne.'aaaa'.and.str2.ne.'bbbb'.and.& + str2.ne.'abab'.and.str2.ne.'baba'.and.& + str2.ne.'baab'.and.str2.ne.'abba'.and.& + str2.ne.'bbaa'.and.str2.ne.'aabb')) cycle select case (active_conf) case('aaaa') + if(eriType.eq.'empty') eriType = 'space' + write(*,*) 'aaaa from '//trim(str1)//' '//trim(str2) + call mqc_print(eris1%getBlock(str1),6,'eri1') + call mqc_print(eris2%getBlock(str2),6,'eri2') aaaa = aaaa + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + call mqc_print(aaaa,6,'aaaa updated') + allocVec(1)=.true. case('bbbb') + if(eriType.eq.'space'.or.eriType.eq.'empty') eriType = 'spin' bbbb = bbbb + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + allocVec(2)=.true. case('aabb') + if(eriType.eq.'space'.or.eriType.eq.'empty') eriType = 'spin' + if(storType.eq.'unknown') storType = 'coulomb' + if(storType.eq.'exchange') storType = 'doublebar' + if(storType.eq.'inverted') storType = 'ms' aabb = aabb + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + allocVec(3)=.true. + case('bbaa') + if(eriType.eq.'space'.or.eriType.eq.'empty') eriType = 'spin' + if(storType.eq.'unknown') storType = 'coulomb' + if(storType.eq.'exchange') storType = 'doublebar' + if(storType.eq.'inverted') storType = 'ms' + bbaa = bbaa + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + allocVec(4)=.true. case('abab') - eriType='general' + if(eriType.eq.'space'.or.eriType.eq.'empty') eriType = 'spin' + if(storType.eq.'unknown') storType = 'inverted' + if(storType.eq.'exchange'.or.storType.eq.'coulomb'.or.& + storType.eq.'doublebar'.or.storType.eq.'unknown') storType = 'ms' abab = abab + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + allocVec(5)=.true. case('abba') - eriType='general' + if(eriType.eq.'space'.or.eriType.eq.'empty') eriType = 'spin' + if(storType.eq.'unknown') storType = 'exchange' + if(storType.eq.'coulomb') storType = 'doublebar' + if(storType.eq.'inverted') storType = 'ms' abba = abba + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + allocVec(6)=.true. case('baab') - eriType='general' + if(eriType.eq.'space'.or.eriType.eq.'empty') eriType = 'spin' + if(storType.eq.'unknown') storType = 'exchange' + if(storType.eq.'coulomb') storType = 'doublebar' + if(storType.eq.'inverted') storType = 'ms' baab = baab + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + allocVec(7)=.true. case('baba') - eriType='general' + if(eriType.eq.'space'.or.eriType.eq.'empty') eriType = 'spin' + if(storType.eq.'unknown') storType = 'inverted' + if(storType.eq.'exchange'.or.storType.eq.'coulomb'.or.& + storType.eq.'doublebar'.or.storType.eq.'unknown') storType = 'ms' baba = baba + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - case('bbaa') - bbaa = bbaa + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& - eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + allocVec(8)=.true. case('abbb') - eriType='general' - abbb = abbb + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& - eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + if(eris1%storageType.ne.'general'.and.eris2%storageType.ne.'general') cycle + if(eris1%hasSpinBlock(str1).and.eris2%hasSpinBlock(str2)) then + eriType='general' + storType = 'full' + abbb = abbb + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + allocVec(16)=.true. + end if case('babb') - eriType='general' - babb = babb + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& - eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + if(eris1%storageType.ne.'general'.and.eris2%storageType.ne.'general') cycle + if(eris1%hasSpinBlock(str1).and.eris2%hasSpinBlock(str2)) then + eriType='general' + storType = 'full' + babb = babb + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + allocVec(15)=.true. + end if case('bbab') - eriType='general' - bbab = bbab + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& - eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + if(eris1%storageType.ne.'general'.and.eris2%storageType.ne.'general') cycle + if(eris1%hasSpinBlock(str1).and.eris2%hasSpinBlock(str2)) then + eriType='general' + storType = 'full' + bbab = bbab + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + allocVec(14)=.true. + end if case('bbba') - eriType='general' - bbba = bbba + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& - eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + if(eris1%storageType.ne.'general'.and.eris2%storageType.ne.'general') cycle + if(eris1%hasSpinBlock(str1).and.eris2%hasSpinBlock(str2)) then + eriType='general' + storType = 'full' + bbba = bbba + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + allocVec(13)=.true. + end if + case('baaa') + if(eris1%storageType.ne.'general'.and.eris2%storageType.ne.'general') cycle + if(eris1%hasSpinBlock(str1).and.eris2%hasSpinBlock(str2)) then + eriType='general' + storType = 'full' + baaa = baaa + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + allocVec(12)=.true. + end if + case('abaa') + if(eris1%storageType.ne.'general'.and.eris2%storageType.ne.'general') cycle + if(eris1%hasSpinBlock(str1).and.eris2%hasSpinBlock(str2)) then + eriType='general' + storType = 'full' + abaa = abaa + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + allocVec(11)=.true. + end if + case('aaba') + if(eris1%storageType.ne.'general'.and.eris2%storageType.ne.'general') cycle + if(eris1%hasSpinBlock(str1).and.eris2%hasSpinBlock(str2)) then + eriType='general' + storType = 'full' + aaba = aaba + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + allocVec(10)=.true. + end if + case('aaab') + if(eris1%storageType.ne.'general'.and.eris2%storageType.ne.'general') cycle + if(eris1%hasSpinBlock(str1).and.eris2%hasSpinBlock(str2)) then + eriType='general' + storType = 'full' + aaab = aaab + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + allocVec(9)=.true. + end if end select end if enddo enddo - !!!! TODO: Use the space symmetry - ! aaaa = MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& - ! eris1%getBlock('aaaa'),eris2%getBlock('aaaa'),index1,index2) - ! select case (eris1%type()) - ! case ('space','regular') - ! select case (eris2%type()) - ! case ('space','regular') - ! eriType='space' - ! case ('spin') - ! eriType='spin' - ! bbbb = MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& - ! eris1%getBlock('aaaa'),eris2%getBlock('bbbb'),index1,index2) - ! tmp_aaaa = aaaa - ! tmp_bbbb = bbbb - ! do i=1,6 - ! active_conf_1=aa_bb_array(i) - ! str1=mqc_index_to_string([ia,ja,ka,la],active_conf_1) - ! if(str1.eq.'aabb'.or.str1.eq.'bbaa') then - ! if (active_conf_1(3:4).eq.'aa') then - ! aabb = aabb + tmp_bbbb - ! else if (active_conf_1(3:4).eq.'bb') then - ! bbaa = bbaa + tmp_aaaa - ! end if - ! do j=1,6 - ! active_conf_2=aa_bb_array(j) - ! active_conf=trim(active_conf_1(3:4))//trim(active_conf_2(3:4)) - ! str2=mqc_index_to_string([ib,jb,kb,lb],active_conf_2) - ! if(str2.eq.'aabb'.or.str2.eq.'bbaa') then - ! if(i.eq.1.and.active_conf_2(3:4).eq.'aa') then - ! bbaa = bbaa + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& - ! eris1%getBlock('aaaa'),eris2%getBlock(str2),index1,index2) - ! else if (i.eq.1.and.active_conf_2(3:4).eq.'bb') then - ! aabb = aabb + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& - ! eris1%getBlock('aaaa'),eris2%getBlock(str2),index1,index2) - ! end if - - ! select case (active_conf) - ! case('aaaa') then - ! aaaa = aaaa + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& - ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - ! case('bbbb') then - ! bbbb = bbbb + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - ! case('aabb') then - ! aabb = aabb + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - ! case('abab') then - ! eriType='general' - ! abab = abab + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - ! case('abba') then - ! eriType='general' - ! abba = abba + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - ! case('baab') then - ! eriType='general' - ! baab = baab + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - ! case('baba') then - ! eriType='general' - ! baba = baba + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - ! case('bbaa') then - ! bbaa = bbaa + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - ! end select - ! end if - ! end do - ! end if - ! end do - ! case ('general') - ! eriType='spin' - ! bbbb = MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& - ! eris1%getBlock('aaaa'),eris2%getBlock('bbbb'),index1,index2) - ! tmp_aaaa = aaaa - ! tmp_bbbb = bbbb - ! do i=1,6 - ! active_conf_1=aa_bb_array(i) - ! str1=mqc_index_to_string([ia,ja,ka,la],active_conf_1) - ! if(str1.eq.'aabb'.or.str1.eq.'bbaa') then - ! if (active_conf_1(3:4).eq.'aa') then - ! aabb = aabb + tmp_bbbb - ! else if (active_conf_1(3:4).eq.'bb') then - ! bbaa = bbaa + tmp_aaaa - ! end if - ! do j=1,6 - ! active_conf_2=aa_bb_array(j) - ! active_conf=trim(active_conf_1(3:4))//trim(active_conf_2(3:4)) - ! str2=mqc_index_to_string([ib,jb,kb,lb],active_conf_2) - ! if(str2.eq.'aabb'.or.str2.eq.'bbaa') then - ! if(i.eq.1.and.active_conf_2(3:4).eq.'aa') then - ! bbaa = bbaa + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& - ! eris1%getBlock('aaaa'),eris2%getBlock(str2),index1,index2) - ! else if (i.eq.1.and.active_conf_2(3:4).eq.'bb') then - ! aabb = aabb + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& - ! eris1%getBlock('aaaa'),eris2%getBlock(str2),index1,index2) - ! end if - - ! select case (active_conf) - ! case('aaaa') then - ! aaaa = aaaa + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& - ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - ! case('bbbb') then - ! bbbb = bbbb + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - ! case('aabb') then - ! aabb = aabb + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - ! case('abab') then - ! eriType='general' - ! abab = abab + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - ! case('abba') then - ! eriType='general' - ! abba = abba + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - ! case('baab') then - ! eriType='general' - ! baab = baab + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - ! case('baba') then - ! eriType='general' - ! baba = baba + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - ! case('bbaa') then - ! bbaa = bbaa + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - ! end select - ! end if - ! end do - ! do j=1,4 - ! active_conf_2=a_bbb_array(i) - ! active_conf=trim(active_conf_1(3:4))//trim(active_conf_2(3:4)) - ! str2=mqc_index_to_string([ib,jb,kb,lb],active_conf_2) - ! if(str2(1:2).eq.'aa'.or.str2(1:2).eq.'bb') then - ! - ! end if - ! end do - ! end if - ! end do - ! case default - ! call mqc_error_a('Unrecognized 2ERI integral type',6,& - ! 'eris2%type',eris2%type()) - ! end select - ! case ('spin') - ! select case (eris2%type()) - ! case ('space','regular','spin') - ! intType='spin' - ! bb = bb + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock('bbbb'),eris2%getBlock('bbbb'),index1,index2) - ! do i=1,6 - ! active_conf=aa_bb_array(i) - ! str1=mqc_index_to_string([ia,ja,ka,la],active_conf) - ! str2=mqc_index_to_string([ib,jb,kb,lb],active_conf) - ! if(str1.eq.'aabb'.or.str1.eq.'bbaa') then - ! if(str2.eq.'aabb'.or.str1.eq.'bbaa') then - ! if (active_conf(3:4).eq.'aa') then - ! aa = aa + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - ! else if (active_conf(3:4).eq.'bb') then - ! bb = bb + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - ! else if (active_conf(3:4).eq.'ab') then - ! intType='general' - ! ab = ab + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - ! else if (active_conf(3:4).eq.'ba') then - ! intType='general' - ! ba = ba + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - ! end if - ! end if - ! end if - ! end do - ! case ('general') - ! intType='spin' - ! bb = bb + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock('bbbb'),eris2%getBlock('bbbb'),index1,index2) - ! do i=1,6 - ! active_conf=aa_bb_array(i) - ! str1=mqc_index_to_string([ia,ja,ka,la],active_conf) - ! str2=mqc_index_to_string([ib,jb,kb,lb],active_conf) - ! if(str1.eq.'aabb'.or.str1.eq.'bbaa') then - ! if (active_conf(3:4).eq.'aa') then - ! aa = aa + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - ! else if (active_conf(3:4).eq.'bb') then - ! bb = bb + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - ! else if (active_conf(3:4).eq.'ab') then - ! intType='general' - ! ab = ab + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - ! else if (active_conf(3:4).eq.'ba') then - ! intType='general' - ! ba = ba + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - ! end if - ! end if - ! end do - ! case default - ! call mqc_error_a('Unrecognized 2ERI integral type',6,& - ! 'eris2%type',eris2%type()) - ! end select - ! case ('general') - ! select case (eris2%type()) - ! case ('space','regular','spin') - ! intType='spin' - ! bb = bb + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock('bbbb'),eris2%getBlock('bbbb'),index1,index2) - ! do i=1,6 - ! active_conf=aa_bb_array(i) - ! str1=mqc_index_to_string([ia,ja,ka,la],active_conf) - ! str2=mqc_index_to_string([ib,jb,kb,lb],active_conf) - ! if(str2.eq.'aabb'.or.str2.eq.'bbaa') then - ! if (active_conf(3:4).eq.'aa') then - ! aa = aa + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - ! else if (active_conf(3:4).eq.'bb') then - ! bb = bb + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - ! else if (active_conf(3:4).eq.'ab') then - ! intType='general' - ! ab = ab + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - ! else if (active_conf(3:4).eq.'ba') then - ! intType='general' - ! ba = ba + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - ! end if - ! end if - ! end do - ! case ('general') - ! intType='spin' - ! bb = bb + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock('bbbb'),eris2%getBlock('bbbb'),index1,index2) - ! do i=1,6 - ! active_conf=aa_bb_array(i) - ! str1=mqc_index_to_string([ia,ja,ka,la],active_conf) - ! str2=mqc_index_to_string([ib,jb,kb,lb],active_conf) - ! if (active_conf(3:4).eq.'aa') then - ! aa = aa + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - ! else if (active_conf(3:4).eq.'bb') then - ! bb = bb + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - ! else if (active_conf(3:4).eq.'ab') then - ! intType='general' - ! ab = ab + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - ! else if (active_conf(3:4).eq.'ba') then - ! intType='general' - ! ba = ba + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - ! end if - ! end do - ! do i=1,4 - ! active_conf=a_bbb_array(i) - ! str1=mqc_index_to_string([ia,ja,ka,la],active_conf) - ! str2=mqc_index_to_string([ib,jb,kb,lb],active_conf) - ! if (active_conf(3:4) == 'aa') then - ! aa = aa + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - ! else if (active_conf(3:4) == 'bb') then - ! bb = bb + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - ! else if (active_conf(3:4) == 'ab') then - ! intType='general' - ! ab = ab + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - ! else if (active_conf(3:4) == 'ba') then - ! intType='general' - ! ba = ba + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - ! end if - ! end do - ! do i=1,4 - ! active_conf=aaa_b_array(i) - ! str1=mqc_index_to_string([ia,ja,ka,la],active_conf) - ! str2=mqc_index_to_string([ib,jb,kb,lb],active_conf) - ! if (active_conf(3:4) == 'aa') then - ! aa = aa + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - ! else if (active_conf(3:4) == 'bb') then - ! bb = bb + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - ! else if (active_conf(3:4) == 'ab') then - ! intType='general' - ! ab = ab + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - ! else |if (active_conf(3:4) == 'ba') then - ! intType='general' - ! ba = ba + MQC_R4Tensor_R4Tensor_Partial_Contraction(& - ! eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - ! end if - ! end do - ! case default - ! call mqc_error_a('Unrecognized 2ERI integral type',6,& - ! 'eris2%type',eris2%type()) - ! end select - ! case default - ! call mqc_error_a('Unrecognized 2ERI integral type',6,& - ! 'eris1%type',eris1%type()) - ! end select - if (eriType.eq.'space') then - call mqc_twoeris_allocate(eriOut,'full','space',aaaa) + if(storType.eq.'unknown') storType = 'ful' + if (eriType.eq.'empty') then + call mqc_twoeris_allocate(eriOut,'empty','empty') + else if (eriType.eq.'space') then + call mqc_twoeris_allocate(eriOut,storType,'space',aaaa,allocationVector=allocVec) elseif (eriType.eq.'spin') then - call mqc_twoeris_allocate(eriOut,'full','spin',aaaa,bbbb,aabb,bbaa) + if (storType.eq.'coulomb') then + call mqc_twoeris_allocate(eriOut,storType,'spin',aaaa,bbbb,aabb,bbaa) + else if (storType.eq.'exchange') then + call mqc_twoeris_allocate(eriOut,storType,'spin',aaaa,bbbb,abba,baab) + else if (storType.eq.'inverted') then + call mqc_twoeris_allocate(eriOut,storType,'spin',aaaa,bbbb,abab,baba) + else + call mqc_twoeris_allocate(eriOut,storType,'spin',aaaa,bbbb,aabb,bbaa,& + abab=abab,baba=baba,abba=abba,baab=baab,allocationVector=allocVec) + end if elseif (eriType.eq.'general') then - call mqc_twoeris_allocate(eriOut,'full','general',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(eriOut,storType,'general',aaaa,bbbb,aabb,bbaa,& abab,abba,baab,baba,aaab,aaba,abaa,baaa,bbba,& - bbab,babb,abbb) + bbab,babb,abbb,allocationVector=allocVec) endif ! @@ -12532,6 +13383,1357 @@ end function mqc_index_to_string ! ! ! +! PROCEDURE MQC_ERI_Dimension_Swap +! +!> \brief MQC_ERI_Dimension_Swap is used to return a two-electron integral +!> after swap two of its dimensions +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_ERI_Dimension_Swap is used to return a two-electron integral +!> after swap two of its dimensions +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] ERIs +!> \verbatim +!> ERIs is type(mqc_twoERIs) +!> The 2ERIs from which to swap dimensions. +!> \endverbatim +!> +!> \param[in] Dim1 +!> \verbatim +!> Dim1 is integer, between 1 and 4. +!> \endverbatim +!> +!> \param[in] Dim2 +!> \verbatim +!> Dim2 is integer, between 1 and 4. +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_eri_dimension_swap(eris,dim1,dim2) result(output) +! + implicit none + class(mqc_twoERIs),intent(in)::eris + integer(kind=int64),intent(in)::dim1,dim2 + integer(kind=int64)::mydim1,mydim2,i,j + integer(kind=int64)::nB1a,nB2a,nB3a,nB4a + integer(kind=int64)::nB1b,nB2b,nB3b,nB4b + type(mqc_twoERIs)::output + type(mqc_r4tensor)::alpha,beta,alphaBeta,betaAlpha,abab,abba,baab, & + baba,aaab,aaba,abaa,baaa,bbba,bbab,babb,abbb + type(mqc_r4tensor)::taaaa,tbbbb,taabb,tbbaa,tabab,tabba,tbaab, & + tbaba,taaab,taaba,tabaa,tbaaa,tbbba,tbbab,tbabb,tabbb + logical,dimension(16)::allocVec,finalAllocVec + + if (dim1.le.0.or.dim1.gt.4) call mqc_error_I( & + 'First dimension out of bounds in mqc_eri_dimension_swap',6,& + 'dim1',dim1) + if (dim2.le.0.or.dim2.gt.4) call mqc_error_I( & + 'Second dimension out of bounds in mqc_eri_dimension_swap',6,& + 'dim2',dim2) + + if (dim1.eq.dim2) then + output = eris + return + else if (dim1.gt.dim2) then + mydim1 = dim2 + mydim2 = dim1 + else + mydim1 = dim1 + mydim2 = dim2 + end if + nB1a = eris%blockSize('alpha',1) + nB2a = eris%blockSize('alpha',2) + nB3a = eris%blockSize('alpha',3) + nB4a = eris%blockSize('alpha',4) + nB1b = eris%blockSize('beta',1) + nB2b = eris%blockSize('beta',2) + nB3b = eris%blockSize('beta',3) + nB4b = eris%blockSize('beta',4) + + select case (eris%type()) + case ('space') + taaaa = eris%getBlock('alpha') + select case (mydim1) + case (1) + select case (mydim2) + case (2) + call alpha%init(nB2a,nB1a,nB3a,nB4a) + do i = 1, nB1a + do j = 1, nB2a + call alpha%tput(taaaa%tat([i,i],[j,j],[0],[0]),[j,j],[i,i],[0],[0]) + endDo + endDo + if(eris%storageType.eq.'exchange') then + call mqc_twoeris_allocate(output,'inverted','space',alpha) + else if(eris%storageType.eq.'coulomb') then + call mqc_twoeris_allocate(output,'coulomb','space',alpha) + else if(eris%storageType.eq.'inverted') then + call mqc_twoeris_allocate(output,'exchange','space',alpha) + else + call mqc_twoeris_allocate(output,'full','space',alpha) + end if + case (3) + call alpha%init(nB3a,nB2a,nB1a,nB4a) + do i = 1, nB1a + do j = 1, nB3a + call alpha%tput(taaaa%tat([i,i],[0],[j,j],[0]),[j,j],[0],[i,i],[0]) + endDo + endDo + if(eris%storageType.eq.'coulomb') then + call mqc_twoeris_allocate(output,'exchange','space',alpha) + else if(eris%storageType.eq.'exchange') then + call mqc_twoeris_allocate(output,'coulomb','space',alpha) + else if(eris%storageType.eq.'inverted') then + call mqc_twoeris_allocate(output,'inverted','space',alpha) + else + call mqc_twoeris_allocate(output,'full','space',alpha) + end if + case (4) + call alpha%init(nB4a,nB2a,nB3a,nB1a) + do i = 1, nB1a + do j = 1, nB4a + call alpha%tput(taaaa%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + endDo + endDo + if(eris%storageType.eq.'coulomb') then + call mqc_twoeris_allocate(output,'inverted','space',alpha) + else if(eris%storageType.eq.'exchange') then + call mqc_twoeris_allocate(output,'exchange','space',alpha) + else if(eris%storageType.eq.'inverted') then + call mqc_twoeris_allocate(output,'coulomb','space',alpha) + else + call mqc_twoeris_allocate(output,'full','space',alpha) + end if + end select + case (2) + select case (mydim2) + case (3) + call alpha%init(nB1a,nB3a,nB2a,nB4a) + do i = 1, nB2a + do j = 1, nB3a + call alpha%tput(taaaa%tat([0],[i,i],[j,j],[0]),[0],[j,j],[i,i],[0]) + endDo + endDo + if(eris%storageType.eq.'coulomb') then + call mqc_twoeris_allocate(output,'inverted','space',alpha) + else if(eris%storageType.eq.'exchange') then + call mqc_twoeris_allocate(output,'exchange','space',alpha) + else if(eris%storageType.eq.'inverted') then + call mqc_twoeris_allocate(output,'coulomb','space',alpha) + else + call mqc_twoeris_allocate(output,'full','space',alpha) + end if + case (4) + call alpha%init(nB1a,nB4a,nB3a,nB2a) + do i = 1, nB2a + do j = 1, nB4a + call alpha%tput(taaaa%tat([0],[i,i],[0],[j,j]),[0],[j,j],[0],[i,i]) + endDo + endDo + if(eris%storageType.eq.'coulomb') then + call mqc_twoeris_allocate(output,'exchange','space',alpha) + else if(eris%storageType.eq.'exchange') then + call mqc_twoeris_allocate(output,'coulomb','space',alpha) + else if(eris%storageType.eq.'inverted') then + call mqc_twoeris_allocate(output,'inverted','space',alpha) + else + call mqc_twoeris_allocate(output,'full','space',alpha) + end if + end select + case (3) + call alpha%init(nB1a,nB2a,nB4a,nB3a) + do i = 1, nB3a + do j = 1, nB4a + call alpha%tput(taaaa%tat([0],[0],[i,i],[j,j]),[0],[0],[j,j],[i,i]) + endDo + endDo + if(eris%storageType.eq.'coulomb') then + call mqc_twoeris_allocate(output,'coulomb','space',alpha) + else if(eris%storageType.eq.'exchange') then + call mqc_twoeris_allocate(output,'exchange','space',alpha) + else if(eris%storageType.eq.'inverted') then + call mqc_twoeris_allocate(output,'inverted','space',alpha) + else + call mqc_twoeris_allocate(output,'full','space',alpha) + end if + end select + case ('spin') + taaaa = eris%getBlock('alpha') + tbbbb = eris%getBlock('beta') + if(eris%storageType.eq.'coulomb') then + taabb = eris%getBlock('AlphaBeta') + tbbaa = eris%getBlock('BetaAlpha') + else if(eris%storageType.eq.'exchange') then + taabb = eris%getBlock('abba') + tbbaa = eris%getBlock('baab') + else if(eris%storageType.eq.'inverted') then + taabb = eris%getBlock('abab') + tbbaa = eris%getBlock('baba') + else + taabb = eris%getBlock('AlphaBeta') + tbbaa = eris%getBlock('BetaAlpha') + end if + select case (mydim1) + case (1) + select case (mydim2) + case (2) + call alpha%init(nB2a,nB1a,nB3a,nB4a) + call alphaBeta%init(nB2a,nB1a,nB3b,nB4b) + call betaAlpha%init(nB2b,nB1b,nB3a,nB4a) + call beta%init(nB2b,nB1b,nB3b,nB4b) + do i = 1, nB1a + do j = 1, nB2a + call alpha%tput(taaaa%tat([i,i],[j,j],[0],[0]),[j,j],[i,i],[0],[0]) + call alphaBeta%tput(taabb%tat([i,i],[j,j],[0],[0]),[j,j],[i,i],[0],[0]) + endDo + endDo + do i = 1, nB1b + do j = 1, nB2b + call betaAlpha%tput(tbbaa%tat([i,i],[j,j],[0],[0]),[j,j],[i,i],[0],[0]) + call beta%tput(tbbbb%tat([i,i],[j,j],[0],[0]),[j,j],[i,i],[0],[0]) + endDo + endDo + if(eris%storageType.eq.'exchange') then + call mqc_twoeris_allocate(output,'inverted','spin',& + alpha,beta,alphaBeta,betaAlpha) + else if(eris%storageType.eq.'coulomb') then + call mqc_twoeris_allocate(output,'coulomb','spin',& + alpha,beta,alphaBeta,betaAlpha) + else if(eris%storageType.eq.'inverted') then + call mqc_twoeris_allocate(output,'exchange','spin',& + alpha,beta,alphaBeta,betaAlpha) + else + call mqc_twoeris_allocate(output,'full','spin',& + alpha,beta,alphaBeta,betaAlpha) + end if + case (3) + call alpha%init(nB3a,nB2a,nB1a,nB4a) + call alphaBeta%init(nB3a,nB2a,nB1b,nB4b) + call betaAlpha%init(nB3b,nB2b,nB1a,nB4a) + call beta%init(nB3b,nB2b,nB1b,nB4b) + do i = 1, nB1a + do j = 1, nB3a + call alpha%tput(taaaa%tat([i,i],[0],[j,j],[0]),[j,j],[0],[i,i],[0]) + call betaAlpha%tput(taabb%tat([i,i],[0],[j,j],[0]),[j,j],[0],[i,i],[0]) + endDo + endDo + do i = 1, nB1b + do j = 1, nB3b + call alphaBeta%tput(tbbaa%tat([i,i],[0],[j,j],[0]),[j,j],[0],[i,i],[0]) + call beta%tput(tbbbb%tat([i,i],[0],[j,j],[0]),[j,j],[0],[i,i],[0]) + endDo + endDo + if(eris%storageType.eq.'exchange') then + call mqc_twoeris_allocate(output,'inverted','spin',& + alpha,beta,alphaBeta,betaAlpha) + else if(eris%storageType.eq.'coulomb') then + call mqc_twoeris_allocate(output,'coulomb','spin',& + alpha,beta,alphaBeta,betaAlpha) + else if(eris%storageType.eq.'inverted') then + call mqc_twoeris_allocate(output,'exchange','spin',& + alpha,beta,alphaBeta,betaAlpha) + else + call mqc_twoeris_allocate(output,'full','spin',& + alpha,beta,alphaBeta,betaAlpha) + end if + case (4) + call alpha%init(nB4a,nB2a,nB3a,nB1a) + call alphaBeta%init(nB4a,nB2a,nB3b,nB1b) + call betaAlpha%init(nB4b,nB2b,nB3a,nB1a) + call beta%init(nB4b,nB2b,nB3b,nB1b) + do i = 1, nB1a + do j = 1, nB4a + call alpha%tput(taaaa%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + call betaAlpha%tput(taabb%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + endDo + endDo + do i = 1, nB1b + do j = 1, nB4b + call alphaBeta%tput(tbbaa%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + call beta%tput(tbbbb%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + endDo + endDo + if(eris%storageType.eq.'coulomb') then + call mqc_twoeris_allocate(output,'exchange','spin',& + alpha,beta,alphaBeta,betaAlpha) + else if(eris%storageType.eq.'exchange') then + call mqc_twoeris_allocate(output,'inverted','spin',& + alpha,beta,alphaBeta,betaAlpha) + else if(eris%storageType.eq.'inverted') then + call mqc_twoeris_allocate(output,'coulomb','spin',& + alpha,beta,alphaBeta,betaAlpha) + else + call mqc_twoeris_allocate(output,'full','spin',& + alpha,beta,alphaBeta,betaAlpha) + endIf + end select + case (2) + select case (mydim2) + case (3) + call alpha%init(nB1a,nB3a,nB2a,nB4a) + call alphaBeta%init(nB1a,nB3a,nB2b,nB4b) + call betaAlpha%init(nB1b,nB3b,nB2a,nB4a) + call beta%init(nB1b,nB3b,nB2b,nB4b) + do i = 1, nB2a + do j = 1, nB3a + call alpha%tput(taaaa%tat([0],[i,i],[j,j],[0]),[0],[j,j],[i,i],[0]) + call alphaBeta%tput(taabb%tat([0],[i,i],[j,j],[0]),[0],[j,j],[i,i],[0]) + endDo + endDo + do i = 1, nB2b + do j = 1, nB3b + call betaAlpha%tput(tbbaa%tat([0],[i,i],[j,j],[0]),[0],[j,j],[i,i],[0]) + call beta%tput(tbbbb%tat([0],[i,i],[j,j],[0]),[0],[j,j],[i,i],[0]) + endDo + endDo + if(eris%storageType.eq.'coulomb') then + call mqc_twoeris_allocate(output,'inverted','spin',& + alpha,beta,alphaBeta,betaAlpha) + else if(eris%storageType.eq.'exchange') then + call mqc_twoeris_allocate(output,'exchange','spin',& + alpha,beta,alphaBeta,betaAlpha) + else if(eris%storageType.eq.'inverted') then + call mqc_twoeris_allocate(output,'coulomb','spin',& + alpha,beta,alphaBeta,betaAlpha) + else + call mqc_twoeris_allocate(output,'full','spin',& + alpha,beta,alphaBeta,betaAlpha) + endIf + case (4) + call alpha%init(nB1a,nB4a,nB3a,nB2a) + call alphaBeta%init(nB1a,nB4a,nB3b,nB2b) + call betaAlpha%init(nB1b,nB4b,nB3a,nB2a) + call beta%init(nB1b,nB4b,nB3b,nB2b) + do i = 1, nB2a + do j = 1, nB4a + call alpha%tput(taaaa%tat([0],[i,i],[0],[j,j]),[0],[j,j],[0],[i,i]) + call alphaBeta%tput(taabb%tat([0],[i,i],[0],[j,j]),[0],[j,j],[0],[i,i]) + endDo + endDo + do i = 1, nB2b + do j = 1, nB4b + call betaAlpha%tput(tbbaa%tat([0],[i,i],[0],[j,j]),[0],[j,j],[0],[i,i]) + call beta%tput(tbbbb%tat([0],[i,i],[0],[j,j]),[0],[j,j],[0],[i,i]) + endDo + endDo + if(eris%storageType.eq.'coulomb') then + call mqc_twoeris_allocate(output,'exchange','spin',& + alpha,beta,alphaBeta,betaAlpha) + else if(eris%storageType.eq.'exchange') then + call mqc_twoeris_allocate(output,'coulomb','spin',& + alpha,beta,alphaBeta,betaAlpha) + else if(eris%storageType.eq.'inverted') then + call mqc_twoeris_allocate(output,'inverted','spin',& + alpha,beta,alphaBeta,betaAlpha) + else + call mqc_twoeris_allocate(output,'full','spin',& + alpha,beta,alphaBeta,betaAlpha) + endIf + end select + case (3) + call alpha%init(nB1a,nB2a,nB4a,nB3a) + call alphaBeta%init(nB1a,nB2a,nB4b,nB3b) + call betaAlpha%init(nB1b,nB2b,nB4a,nB3a) + call beta%init(nB1b,nB2b,nB4b,nB3b) + do i = 1, nB3a + do j = 1, nB4a + call alpha%tput(taaaa%tat([0],[0],[i,i],[j,j]),[0],[0],[j,j],[i,i]) + call alphaBeta%tput(taabb%tat([0],[0],[i,i],[j,j]),[0],[0],[j,j],[i,i]) + endDo + endDo + do i = 1, nB3b + do j = 1, nB4b + call betaAlpha%tput(tbbaa%tat([0],[0],[i,i],[j,j]),[0],[0],[j,j],[i,i]) + call beta%tput(tbbbb%tat([0],[0],[i,i],[j,j]),[0],[0],[j,j],[i,i]) + endDo + endDo + if(eris%storageType.eq.'coulomb') then + call mqc_twoeris_allocate(output,'coulomb','spin',& + alpha,beta,alphaBeta,betaAlpha) + else if(eris%storageType.eq.'exchange') then + call mqc_twoeris_allocate(output,'inverted','spin',& + alpha,beta,alphaBeta,betaAlpha) + else if(eris%storageType.eq.'inverted') then + call mqc_twoeris_allocate(output,'coulomb','spin',& + alpha,beta,alphaBeta,betaAlpha) + else + call mqc_twoeris_allocate(output,'full','spin',& + alpha,beta,alphaBeta,betaAlpha) + endIf + end select + case ('general') + do i = 1, 16 + allocVec(i)=.false. + finalAllocVec(i)=.false. + end do + if(eris%hasSpinBlock('aaaa')) then + taaaa = eris%getBlock('alpha') + allocVec(1)=.true. + end if + if(eris%hasSpinBlock('bbbb')) then + taaaa = eris%getBlock('beta') + allocVec(2)=.true. + end if + if(eris%hasSpinBlock('AlphaBeta')) then + taabb = eris%getBlock('AlphaBeta') + allocVec(3)=.true. + end if + if(eris%hasSpinBlock('BetaAlpha')) then + taabb = eris%getBlock('BetaAlpha') + allocVec(4)=.true. + end if + if(eris%hasSpinBlock('abab')) then + taabb = eris%getBlock('abab') + allocVec(5)=.true. + end if + if(eris%hasSpinBlock('abba')) then + taabb = eris%getBlock('abba') + allocVec(6)=.true. + end if + if(eris%hasSpinBlock('baab')) then + taabb = eris%getBlock('baab') + allocVec(7)=.true. + end if + if(eris%hasSpinBlock('baba')) then + taabb = eris%getBlock('baba') + allocVec(8)=.true. + end if + if(eris%hasSpinBlock('aaab')) then + taabb = eris%getBlock('aaab') + allocVec(9)=.true. + end if + if(eris%hasSpinBlock('aaba')) then + taabb = eris%getBlock('aaba') + allocVec(10)=.true. + end if + if(eris%hasSpinBlock('abaa')) then + taabb = eris%getBlock('abaa') + allocVec(11)=.true. + end if + if(eris%hasSpinBlock('baaa')) then + taabb = eris%getBlock('baaa') + allocVec(12)=.true. + end if + if(eris%hasSpinBlock('bbba')) then + taabb = eris%getBlock('bbba') + allocVec(13)=.true. + end if + if(eris%hasSpinBlock('bbab')) then + taabb = eris%getBlock('bbab') + allocVec(14)=.true. + end if + if(eris%hasSpinBlock('babb')) then + taabb = eris%getBlock('babb') + allocVec(15)=.true. + end if + if(eris%hasSpinBlock('abbb')) then + taabb = eris%getBlock('abbb') + allocVec(16)=.true. + end if + select case (mydim1) + case (1) + select case (mydim2) + case (2) + if(allocVec(1)) then + call alpha%init(nB2a,nB1a,nB3a,nB4a) + do i = 1, nB1a + do j = 1, nB2a + call alpha%tput(taaaa%tat([i,i],[j,j],[0],[0]),[j,j],[i,i],[0],[0]) + endDo + endDo + finalAllocVec(1)=.true. + end if + if(allocVec(2)) then + call beta%init(nB2b,nB1b,nB3b,nB4b) + do i = 1, nB1b + do j = 1, nB2b + call beta%tput(tbbbb%tat([i,i],[j,j],[0],[0]),[j,j],[i,i],[0],[0]) + endDo + endDo + finalAllocVec(2)=.true. + end if + if(allocVec(3)) then + call alphaBeta%init(nB2a,nB1a,nB3b,nB4b) + do i = 1, nB1a + do j = 1, nB2a + call alphaBeta%tput(taabb%tat([i,i],[j,j],[0],[0]),[j,j],[i,i],[0],[0]) + endDo + endDo + finalAllocVec(3)=.true. + end if + if(allocVec(4)) then + call betaAlpha%init(nB2b,nB1b,nB3a,nB4a) + do i = 1, nB1b + do j = 1, nB2b + call betaAlpha%tput(tbbaa%tat([i,i],[j,j],[0],[0]),[j,j],[i,i],[0],[0]) + endDo + endDo + finalAllocVec(4)=.true. + end if + if(allocVec(5)) then + call baab%init(nB2b,nB1a,nB3a,nB4b) + do i = 1, nB1a + do j = 1, nB2b + call baab%tput(tabab%tat([i,i],[j,j],[0],[0]),[j,j],[i,i],[0],[0]) + endDo + endDo + finalAllocVec(7)=.true. + end if + if(allocVec(6)) then + call baba%init(nB2b,nB1a,nB3b,nB4a) + do i = 1, nB1a + do j = 1, nB2b + call baba%tput(tabba%tat([i,i],[j,j],[0],[0]),[j,j],[i,i],[0],[0]) + endDo + endDo + finalAllocVec(8)=.true. + end if + if(allocVec(7)) then + call abab%init(nB2a,nB1b,nB3a,nB4b) + do i = 1, nB1b + do j = 1, nB2a + call abab%tput(tbaab%tat([i,i],[j,j],[0],[0]),[j,j],[i,i],[0],[0]) + endDo + endDo + finalAllocVec(5)=.true. + end if + if(allocVec(8)) then + call abba%init(nB2a,nB1b,nB3b,nB4a) + do i = 1, nB1b + do j = 1, nB2a + call abba%tput(tbaba%tat([i,i],[j,j],[0],[0]),[j,j],[i,i],[0],[0]) + endDo + endDo + finalAllocVec(6)=.true. + end if + if(allocVec(9)) then + call aaab%init(nB2a,nB1a,nB3a,nB4b) + do i = 1, nB1a + do j = 1, nB2a + call aaab%tput(taaab%tat([i,i],[j,j],[0],[0]),[j,j],[i,i],[0],[0]) + endDo + endDo + finalAllocVec(9)=.true. + end if + if(allocVec(10)) then + call aaba%init(nB2a,nB1a,nB3b,nB4a) + do i = 1, nB1a + do j = 1, nB2a + call aaba%tput(taaba%tat([i,i],[j,j],[0],[0]),[j,j],[i,i],[0],[0]) + endDo + endDo + finalAllocVec(10)=.true. + end if + if(allocVec(11)) then + call baaa%init(nB2b,nB1a,nB3a,nB4a) + do i = 1, nB1a + do j = 1, nB2b + call baaa%tput(tabaa%tat([i,i],[j,j],[0],[0]),[j,j],[i,i],[0],[0]) + endDo + endDo + finalAllocVec(12)=.true. + end if + if(allocVec(12)) then + call abaa%init(nB2a,nB1b,nB3a,nB4a) + do i = 1, nB1b + do j = 1, nB2a + call abaa%tput(tbaaa%tat([i,i],[j,j],[0],[0]),[j,j],[i,i],[0],[0]) + endDo + endDo + finalAllocVec(11)=.true. + end if + if(allocVec(13)) then + call bbba%init(nB2b,nB1b,nB3b,nB4a) + do i = 1, nB1b + do j = 1, nB2b + call bbba%tput(tbbba%tat([i,i],[j,j],[0],[0]),[j,j],[i,i],[0],[0]) + endDo + endDo + finalAllocVec(13)=.true. + end if + if(allocVec(14)) then + call bbab%init(nB2b,nB1b,nB3a,nB4b) + do i = 1, nB1b + do j = 1, nB2b + call bbab%tput(tbbab%tat([i,i],[j,j],[0],[0]),[j,j],[i,i],[0],[0]) + endDo + endDo + finalAllocVec(14)=.true. + end if + if(allocVec(15)) then + call abbb%init(nB2a,nB1b,nB3b,nB4b) + do i = 1, nB1b + do j = 1, nB2a + call abbb%tput(tbabb%tat([i,i],[j,j],[0],[0]),[j,j],[i,i],[0],[0]) + endDo + endDo + finalAllocVec(16)=.true. + end if + if(allocVec(16)) then + call babb%init(nB2b,nB1a,nB3b,nB4b) + do i = 1, nB1a + do j = 1, nB2b + call babb%tput(tabbb%tat([i,i],[j,j],[0],[0]),[j,j],[i,i],[0],[0]) + endDo + endDo + finalAllocVec(15)=.true. + end if + case (3) + if(allocVec(1)) then + call alpha%init(nB3a,nB2a,nB1a,nB4a) + do i = 1, nB1a + do j = 1, nB3a + call alpha%tput(taaaa%tat([i,i],[0],[j,j],[0]),[j,j],[0],[i,i],[0]) + endDo + endDo + finalAllocVec(1)=.true. + end if + if(allocVec(2)) then + call beta%init(nB3b,nB2b,nB1b,nB4b) + do i = 1, nB1b + do j = 1, nB3b + call beta%tput(tbbbb%tat([i,i],[0],[j,j],[0]),[j,j],[0],[i,i],[0]) + endDo + endDo + finalAllocVec(2)=.true. + end if + if(allocVec(3)) then + call baab%init(nB3b,nB2a,nB1a,nB4b) + do i = 1, nB1a + do j = 1, nB3b + call baab%tput(taabb%tat([i,i],[0],[j,j],[0]),[j,j],[0],[i,i],[0]) + endDo + endDo + finalAllocVec(7)=.true. + end if + if(allocVec(4)) then + call abba%init(nB3a,nB2b,nB1b,nB4a) + do i = 1, nB1b + do j = 1, nB3a + call abba%tput(tbbaa%tat([i,i],[0],[j,j],[0]),[j,j],[0],[i,i],[0]) + endDo + endDo + finalAllocVec(6)=.true. + end if + if(allocVec(5)) then + call abab%init(nB3a,nB2b,nB1a,nB4b) + do i = 1, nB1a + do j = 1, nB3a + call abab%tput(tabab%tat([i,i],[0],[j,j],[0]),[j,j],[0],[i,i],[0]) + endDo + endDo + finalAllocVec(5)=.true. + end if + if(allocVec(6)) then + call betaAlpha%init(nB3b,nB2b,nB1a,nB4a) + do i = 1, nB1a + do j = 1, nB3b + call betaAlpha%tput(tabba%tat([i,i],[0],[j,j],[0]),[j,j],[0],[i,i],[0]) + endDo + endDo + finalAllocVec(4)=.true. + end if + if(allocVec(7)) then + call alphaBeta%init(nB3a,nB2a,nB1b,nB4b) + do i = 1, nB1b + do j = 1, nB3a + call alphaBeta%tput(tbaab%tat([i,i],[0],[j,j],[0]),[j,j],[0],[i,i],[0]) + endDo + endDo + finalAllocVec(3)=.true. + end if + if(allocVec(8)) then + call baba%init(nB3b,nB2a,nB1b,nB4a) + do i = 1, nB1a + do j = 1, nB3b + call baba%tput(tbaba%tat([i,i],[0],[j,j],[0]),[j,j],[0],[i,i],[0]) + endDo + endDo + finalAllocVec(8)=.true. + end if + if(allocVec(9)) then + call aaab%init(nB3a,nB2a,nB1a,nB4b) + do i = 1, nB1a + do j = 1, nB3a + call aaab%tput(taaab%tat([i,i],[0],[j,j],[0]),[j,j],[0],[i,i],[0]) + endDo + endDo + finalAllocVec(9)=.true. + end if + if(allocVec(10)) then + call baaa%init(nB3b,nB2a,nB1a,nB4a) + do i = 1, nB1a + do j = 1, nB3b + call baaa%tput(taaba%tat([i,i],[0],[j,j],[0]),[j,j],[0],[i,i],[0]) + endDo + endDo + finalAllocVec(12)=.true. + end if + if(allocVec(11)) then + call abaa%init(nB3a,nB2b,nB1a,nB4a) + do i = 1, nB1a + do j = 1, nB3a + call abaa%tput(tabaa%tat([i,i],[0],[j,j],[0]),[j,j],[0],[i,i],[0]) + endDo + endDo + finalAllocVec(11)=.true. + end if + if(allocVec(12)) then + call aaba%init(nB3a,nB2a,nB1b,nB4a) + do i = 1, nB1b + do j = 1, nB3a + call aaba%tput(tbaaa%tat([i,i],[0],[j,j],[0]),[j,j],[0],[i,i],[0]) + endDo + endDo + finalAllocVec(10)=.true. + end if + if(allocVec(13)) then + call bbba%init(nB3b,nB2b,nB1b,nB4a) + do i = 1, nB1b + do j = 1, nB3b + call bbba%tput(tbbba%tat([i,i],[0],[j,j],[0]),[j,j],[0],[i,i],[0]) + endDo + endDo + finalAllocVec(13)=.true. + end if + if(allocVec(14)) then + call abbb%init(nB3a,nB2b,nB1b,nB4b) + do i = 1, nB1b + do j = 1, nB3a + call abbb%tput(tbbab%tat([i,i],[0],[j,j],[0]),[j,j],[0],[i,i],[0]) + endDo + endDo + finalAllocVec(16)=.true. + end if + if(allocVec(15)) then + call babb%init(nB3b,nB2a,nB1b,nB4b) + do i = 1, nB1b + do j = 1, nB3b + call babb%tput(tbabb%tat([i,i],[0],[j,j],[0]),[j,j],[0],[i,i],[0]) + endDo + endDo + finalAllocVec(15)=.true. + end if + if(allocVec(16)) then + call bbab%init(nB3b,nB2b,nB1a,nB4b) + do i = 1, nB1a + do j = 1, nB3b + call bbab%tput(tabbb%tat([i,i],[0],[j,j],[0]),[j,j],[0],[i,i],[0]) + endDo + endDo + finalAllocVec(14)=.true. + end if + case (4) + if(allocVec(1)) then + call alpha%init(nB4a,nB2a,nB3a,nB1a) + do i = 1, nB1a + do j = 1, nB4a + call alpha%tput(taaaa%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + endDo + endDo + finalAllocVec(1)=.true. + end if + if(allocVec(2)) then + call beta%init(nB4b,nB2b,nB3b,nB1b) + do i = 1, nB1b + do j = 1, nB4b + call beta%tput(tbbbb%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + endDo + endDo + finalAllocVec(2)=.true. + end if + if(allocVec(3)) then + call baba%init(nB4b,nB2a,nB3b,nB1a) + do i = 1, nB1a + do j = 1, nB4b + call baba%tput(taabb%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + endDo + endDo + finalAllocVec(8)=.true. + end if + if(allocVec(4)) then + call abab%init(nB4a,nB2b,nB3a,nB1b) + do i = 1, nB1b + do j = 1, nB4a + call abab%tput(tbbaa%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + endDo + endDo + finalAllocVec(5)=.true. + end if + if(allocVec(5)) then + call abab%init(nB4a,nB2b,nB3a,nB1b) + do i = 1, nB1b + do j = 1, nB4a + call abab%tput(tabab%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + endDo + endDo + finalAllocVec(5)=.true. + end if + if(allocVec(6)) then + call abba%init(nB4a,nB2b,nB3b,nB1a) + do i = 1, nB1a + do j = 1, nB4a + call abba%tput(tabba%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + endDo + endDo + finalAllocVec(6)=.true. + end if + if(allocVec(7)) then + call baab%init(nB4b,nB2a,nB3a,nB1b) + do i = 1, nB1b + do j = 1, nB4b + call baab%tput(tbaab%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + endDo + endDo + finalAllocVec(7)=.true. + end if + if(allocVec(8)) then + call alphaBeta%init(nB4a,nB2a,nB3b,nB1b) + do i = 1, nB1b + do j = 1, nB4a + call alphaBeta%tput(tbaba%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + endDo + endDo + finalAllocVec(3)=.true. + end if + if(allocVec(9)) then + call baaa%init(nB4b,nB2a,nB3a,nB1a) + do i = 1, nB1a + do j = 1, nB4b + call baaa%tput(taaab%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + endDo + endDo + finalAllocVec(12)=.true. + end if + if(allocVec(10)) then + call aaba%init(nB4a,nB2a,nB3b,nB1a) + do i = 1, nB1a + do j = 1, nB4a + call aaba%tput(taaba%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + endDo + endDo + finalAllocVec(10)=.true. + end if + if(allocVec(11)) then + call abaa%init(nB4a,nB2b,nB3a,nB1a) + do i = 1, nB1a + do j = 1, nB4a + call abaa%tput(tabaa%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + endDo + endDo + finalAllocVec(11)=.true. + end if + if(allocVec(12)) then + call aaab%init(nB4a,nB2a,nB3a,nB1b) + do i = 1, nB1b + do j = 1, nB4a + call aaab%tput(tbaaa%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + endDo + endDo + finalAllocVec(9)=.true. + end if + if(allocVec(13)) then + call abbb%init(nB4a,nB2b,nB3b,nB1b) + do i = 1, nB1b + do j = 1, nB4a + call abbb%tput(tbbba%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + endDo + endDo + finalAllocVec(16)=.true. + end if + if(allocVec(14)) then + call bbab%init(nB4b,nB2b,nB3a,nB1b) + do i = 1, nB1b + do j = 1, nB4b + call bbab%tput(tbbab%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + endDo + endDo + finalAllocVec(14)=.true. + end if + if(allocVec(15)) then + call babb%init(nB4b,nB2a,nB3b,nB1b) + do i = 1, nB1b + do j = 1, nB4b + call babb%tput(tbabb%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + endDo + endDo + finalAllocVec(15)=.true. + end if + if(allocVec(16)) then + call bbba%init(nB4b,nB2b,nB3b,nB1a) + do i = 1, nB1a + do j = 1, nB4b + call bbba%tput(tabbb%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + endDo + endDo + finalAllocVec(13)=.true. + end if + end select + case (2) + select case (mydim2) + case (3) + if(allocVec(1)) then + call alpha%init(nB1a,nB3a,nB2a,nB4a) + do i = 1, nB2a + do j = 1, nB3a + call alpha%tput(taaaa%tat([0],[i,i],[j,j],[0]),[0],[j,j],[i,i],[0]) + endDo + endDo + finalAllocVec(1)=.true. + end if + if(allocVec(2)) then + call beta%init(nB1b,nB3b,nB2b,nB4b) + do i = 1, nB2b + do j = 1, nB3b + call beta%tput(tbbbb%tat([0],[i,i],[j,j],[0]),[0],[j,j],[i,i],[0]) + endDo + endDo + finalAllocVec(2)=.true. + end if + if(allocVec(3)) then + call abab%init(nB1a,nB3b,nB2a,nB4b) + do i = 1, nB2a + do j = 1, nB3b + call abab%tput(taabb%tat([0],[i,i],[j,j],[0]),[0],[j,j],[i,i],[0]) + endDo + endDo + finalAllocVec(5)=.true. + end if + if(allocVec(4)) then + call baba%init(nB1b,nB3a,nB2b,nB4a) + do i = 1, nB2b + do j = 1, nB3a + call baba%tput(tbbaa%tat([0],[i,i],[j,j],[0]),[0],[j,j],[i,i],[0]) + endDo + endDo + finalAllocVec(8)=.true. + end if + if(allocVec(5)) then + call alphaBeta%init(nB1a,nB3a,nB2b,nB4b) + do i = 1, nB2b + do j = 1, nB3a + call alphaBeta%tput(tabab%tat([0],[i,i],[j,j],[0]),[0],[j,j],[i,i],[0]) + endDo + endDo + finalAllocVec(3)=.true. + end if + if(allocVec(6)) then + call abba%init(nB1a,nB3b,nB2b,nB4a) + do i = 1, nB2b + do j = 1, nB3b + call abba%tput(tabba%tat([0],[i,i],[j,j],[0]),[0],[j,j],[i,i],[0]) + endDo + endDo + finalAllocVec(6)=.true. + end if + if(allocVec(7)) then + call baab%init(nB1b,nB3a,nB2a,nB4b) + do i = 1, nB2a + do j = 1, nB3a + call baab%tput(tbaab%tat([0],[i,i],[j,j],[0]),[0],[j,j],[i,i],[0]) + endDo + endDo + finalAllocVec(7)=.true. + end if + if(allocVec(8)) then + call betaAlpha%init(nB1b,nB3b,nB2a,nB4a) + do i = 1, nB2a + do j = 1, nB3b + call betaAlpha%tput(tbaba%tat([0],[i,i],[j,j],[0]),[0],[j,j],[i,i],[0]) + endDo + endDo + finalAllocVec(7)=.true. + end if + if(allocVec(9)) then + call aaab%init(nB1a,nB3a,nB2a,nB4b) + do i = 1, nB2a + do j = 1, nB3a + call aaab%tput(taaab%tat([0],[i,i],[j,j],[0]),[0],[j,j],[i,i],[0]) + endDo + endDo + finalAllocVec(9)=.true. + end if + if(allocVec(10)) then + call abaa%init(nB1a,nB3b,nB2a,nB4a) + do i = 1, nB2a + do j = 1, nB3b + call abaa%tput(taaba%tat([0],[i,i],[j,j],[0]),[0],[j,j],[i,i],[0]) + endDo + endDo + finalAllocVec(11)=.true. + end if + if(allocVec(11)) then + call aaba%init(nB1a,nB3a,nB2b,nB4a) + do i = 1, nB2b + do j = 1, nB3a + call aaba%tput(tabaa%tat([0],[i,i],[j,j],[0]),[0],[j,j],[i,i],[0]) + endDo + endDo + finalAllocVec(10)=.true. + end if + if(allocVec(12)) then + call baaa%init(nB1b,nB3a,nB2a,nB4a) + do i = 1, nB2a + do j = 1, nB3a + call baaa%tput(tbaaa%tat([0],[i,i],[j,j],[0]),[0],[j,j],[i,i],[0]) + endDo + endDo + finalAllocVec(12)=.true. + end if + if(allocVec(13)) then + call bbba%init(nB1b,nB3b,nB2b,nB4a) + do i = 1, nB2b + do j = 1, nB3b + call bbba%tput(tbbba%tat([0],[i,i],[j,j],[0]),[0],[j,j],[i,i],[0]) + endDo + endDo + finalAllocVec(13)=.true. + end if + if(allocVec(14)) then + call babb%init(nB1b,nB3a,nB2b,nB4b) + do i = 1, nB2b + do j = 1, nB3a + call babb%tput(tbbab%tat([0],[i,i],[j,j],[0]),[0],[j,j],[i,i],[0]) + endDo + endDo + finalAllocVec(15)=.true. + end if + if(allocVec(15)) then + call bbab%init(nB1b,nB3b,nB2a,nB4b) + do i = 1, nB2a + do j = 1, nB3b + call bbab%tput(tbabb%tat([0],[i,i],[j,j],[0]),[0],[j,j],[i,i],[0]) + endDo + endDo + finalAllocVec(14)=.true. + end if + if(allocVec(16)) then + call abbb%init(nB1a,nB3b,nB2b,nB4b) + do i = 1, nB2b + do j = 1, nB3b + call abbb%tput(tabbb%tat([0],[i,i],[j,j],[0]),[0],[j,j],[i,i],[0]) + endDo + endDo + finalAllocVec(16)=.true. + end if + case (4) + if(allocVec(1)) then + call alpha%init(nB1a,nB4a,nB3a,nB2a) + do i = 1, nB2a + do j = 1, nB4a + call alpha%tput(taaaa%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + endDo + endDo + finalAllocVec(1)=.true. + end if + if(allocVec(2)) then + call beta%init(nB1b,nB4b,nB2b,nB2b) + do i = 1, nB2b + do j = 1, nB4b + call beta%tput(tbbbb%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + endDo + endDo + finalAllocVec(2)=.true. + end if + if(allocVec(3)) then + call abba%init(nB1a,nB4b,nB3b,nB2a) + do i = 1, nB2a + do j = 1, nB4b + call abba%tput(taabb%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + endDo + endDo + finalAllocVec(6)=.true. + end if + if(allocVec(4)) then + call baab%init(nB1b,nB4a,nB3a,nB2b) + do i = 1, nB2b + do j = 1, nB4a + call baab%tput(tbbaa%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + endDo + endDo + finalAllocVec(7)=.true. + end if + if(allocVec(5)) then + call abab%init(nB1a,nB4b,nB3a,nB2b) + do i = 1, nB2b + do j = 1, nB4b + call abab%tput(tabab%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + endDo + endDo + finalAllocVec(5)=.true. + end if + if(allocVec(6)) then + call alphaBeta%init(nB1a,nB4a,nB3b,nB2b) + do i = 1, nB2b + do j = 1, nB4a + call alphaBeta%tput(tabba%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + endDo + endDo + finalAllocVec(3)=.true. + end if + if(allocVec(7)) then + call betaAlpha%init(nB1b,nB4b,nB3a,nB2a) + do i = 1, nB2a + do j = 1, nB4b + call betaAlpha%tput(tbaab%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + endDo + endDo + finalAllocVec(4)=.true. + end if + if(allocVec(8)) then + call baba%init(nB1b,nB4a,nB3b,nB2a) + do i = 1, nB2a + do j = 1, nB4a + call baba%tput(tbaba%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + endDo + endDo + finalAllocVec(8)=.true. + end if + if(allocVec(9)) then + call abaa%init(nB1a,nB4b,nB3a,nB2a) + do i = 1, nB2a + do j = 1, nB4b + call abaa%tput(taaab%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + endDo + endDo + finalAllocVec(11)=.true. + end if + if(allocVec(10)) then + call aaba%init(nB1a,nB4a,nB3b,nB2a) + do i = 1, nB2a + do j = 1, nB4a + call aaba%tput(taaba%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + endDo + endDo + finalAllocVec(10)=.true. + end if + if(allocVec(11)) then + call aaab%init(nB1a,nB4a,nB3a,nB2b) + do i = 1, nB2b + do j = 1, nB4a + call aaab%tput(tabaa%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + endDo + endDo + finalAllocVec(9)=.true. + end if + if(allocVec(12)) then + call baaa%init(nB1b,nB4a,nB3a,nB2a) + do i = 1, nB2a + do j = 1, nB4a + call baaa%tput(tbaaa%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + endDo + endDo + finalAllocVec(12)=.true. + end if + if(allocVec(13)) then + call babb%init(nB1b,nB4a,nB3b,nB2b) + do i = 1, nB2b + do j = 1, nB4a + call babb%tput(tbbba%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + endDo + endDo + finalAllocVec(15)=.true. + end if + if(allocVec(14)) then + call bbab%init(nB1b,nB4b,nB3a,nB2b) + do i = 1, nB2b + do j = 1, nB4b + call bbab%tput(tbbab%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + endDo + endDo + finalAllocVec(14)=.true. + end if + if(allocVec(15)) then + call bbba%init(nB1b,nB4b,nB3b,nB2a) + do i = 1, nB2a + do j = 1, nB4b + call bbba%tput(tbabb%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + endDo + endDo + finalAllocVec(13)=.true. + end if + if(allocVec(16)) then + call abbb%init(nB1a,nB4b,nB3b,nB2b) + do i = 1, nB2b + do j = 1, nB4b + call abbb%tput(tabbb%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + endDo + endDo + finalAllocVec(16)=.true. + end if + end select + case (3) + if(allocVec(1)) then + call alpha%init(nB1a,nB2a,nB4a,nB3a) + do i = 1, nB3a + do j = 1, nB4a + call alpha%tput(taaaa%tat([0],[0],[i,i],[j,j]),[0],[0],[j,j],[i,i]) + endDo + endDo + finalAllocVec(1)=.true. + end if + if(allocVec(2)) then + call beta%init(nB1b,nB2b,nB4b,nB3b) + do i = 1, nB4b + do j = 1, nB3b + call beta%tput(tbbbb%tat([0],[0],[i,i],[j,j]),[0],[0],[j,j],[i,i]) + endDo + endDo + finalAllocVec(2)=.true. + end if + if(allocVec(3)) then + call alphaBeta%init(nB1a,nB2a,nB4b,nB3b) + do i = 1, nB3b + do j = 1, nB4b + call alphaBeta%tput(taabb%tat([0],[0],[i,i],[j,j]),[0],[0],[j,j],[i,i]) + endDo + endDo + finalAllocVec(3)=.true. + end if + if(allocVec(4)) then + call betaAlpha%init(nB1b,nB2b,nB4a,nB3a) + do i = 1, nB3a + do j = 1, nB4a + call betaAlpha%tput(tbbaa%tat([0],[0],[i,i],[j,j]),[0],[0],[j,j],[i,i]) + endDo + endDo + finalAllocVec(4)=.true. + end if + if(allocVec(5)) then + call abba%init(nB1a,nB2b,nB4b,nB3a) + do i = 1, nB3a + do j = 1, nB4b + call abba%tput(tabab%tat([0],[0],[i,i],[j,j]),[0],[0],[j,j],[i,i]) + endDo + endDo + finalAllocVec(6)=.true. + end if + if(allocVec(6)) then + call abab%init(nB1a,nB2b,nB4a,nB3b) + do i = 1, nB3b + do j = 1, nB4a + call abab%tput(tabba%tat([0],[0],[i,i],[j,j]),[0],[0],[j,j],[i,i]) + endDo + endDo + finalAllocVec(5)=.true. + end if + if(allocVec(7)) then + call baba%init(nB1b,nB2a,nB4b,nB3a) + do i = 1, nB3a + do j = 1, nB4b + call baba%tput(tbaab%tat([0],[0],[i,i],[j,j]),[0],[0],[j,j],[i,i]) + endDo + endDo + finalAllocVec(8)=.true. + end if + if(allocVec(8)) then + call baab%init(nB1b,nB2a,nB4a,nB3b) + do i = 1, nB3b + do j = 1, nB4a + call baab%tput(tbaba%tat([0],[0],[i,i],[j,j]),[0],[0],[j,j],[i,i]) + endDo + endDo + finalAllocVec(7)=.true. + end if + if(allocVec(9)) then + call aaba%init(nB1a,nB2a,nB4b,nB3a) + do i = 1, nB3a + do j = 1, nB4b + call aaba%tput(taaab%tat([0],[0],[i,i],[j,j]),[0],[0],[j,j],[i,i]) + endDo + endDo + finalAllocVec(10)=.true. + end if + if(allocVec(10)) then + call aaab%init(nB1a,nB2a,nB4a,nB3b) + do i = 1, nB3b + do j = 1, nB4a + call aaab%tput(taaba%tat([0],[0],[i,i],[j,j]),[0],[0],[j,j],[i,i]) + endDo + endDo + finalAllocVec(9)=.true. + end if + if(allocVec(11)) then + call abaa%init(nB1a,nB2b,nB4a,nB3a) + do i = 1, nB3a + do j = 1, nB4a + call abaa%tput(tabaa%tat([0],[0],[i,i],[j,j]),[0],[0],[j,j],[i,i]) + endDo + endDo + finalAllocVec(11)=.true. + end if + if(allocVec(12)) then + call baaa%init(nB1b,nB2a,nB4a,nB3a) + do i = 1, nB3a + do j = 1, nB4a + call baaa%tput(tbaaa%tat([0],[0],[i,i],[j,j]),[0],[0],[j,j],[i,i]) + endDo + endDo + finalAllocVec(12)=.true. + end if + if(allocVec(13)) then + call bbab%init(nB1b,nB2b,nB4a,nB3b) + do i = 1, nB3b + do j = 1, nB4a + call bbab%tput(tbbba%tat([0],[0],[i,i],[j,j]),[0],[0],[j,j],[i,i]) + endDo + endDo + finalAllocVec(14)=.true. + end if + if(allocVec(14)) then + call bbba%init(nB1b,nB2b,nB4b,nB3a) + do i = 1, nB3a + do j = 1, nB4b + call bbba%tput(tbbab%tat([0],[0],[i,i],[j,j]),[0],[0],[j,j],[i,i]) + endDo + endDo + finalAllocVec(13)=.true. + end if + if(allocVec(15)) then + call babb%init(nB1b,nB2a,nB4b,nB3b) + do i = 1, nB3b + do j = 1, nB4b + call babb%tput(tbabb%tat([0],[0],[i,i],[j,j]),[0],[0],[j,j],[i,i]) + endDo + endDo + finalAllocVec(15)=.true. + end if + if(allocVec(16)) then + call abbb%init(nB1a,nB2b,nB4b,nB3b) + do i = 1, nB3b + do j = 1, nB4b + call abbb%tput(tabbb%tat([0],[0],[i,i],[j,j]),[0],[0],[j,j],[i,i]) + endDo + endDo + finalAllocVec(16)=.true. + end if + end select + call mqc_twoeris_allocate(output,'full','general',& + alpha,beta,alphaBeta,betaAlpha,& + abab,abba,baab,baba,& + aaab,aaba,abaa,baaa,& + bbba,bbab,babb,abbb,finalAllocVec) + case default + call mqc_error_a('2ERI type either not recognized or not yet implemented in & + & mqc_eri_interaction',6,'eris%type()',eris%type()) + end select +! + end function mqc_eri_dimension_swap +! +! +! ! PROCEDURE MQC_ERI_Interaction ! !> \brief MQC_ERI_Interaction is used to return the two-electron integrals of @@ -12569,8 +14771,8 @@ end function mqc_index_to_string ! ! Authors: ! ======== -!> \author L. M. Thompson -!> \date 2019 +!> \author L. M. Thompson, M. M. F. Moraes +!> \date 2019, 2026 ! function mqc_eri_interaction(eris,label) result(output) ! @@ -12588,6 +14790,17 @@ function mqc_eri_interaction(eris,label) result(output) myLabel = 'coulomb' endIf + if (myLabel.eq.'exchange'.or.myLabel.eq.'doublebar') then + if (eris%blockSize('alpha',4).ne.eris%blockSize('alpha',2).or.& + eris%blockSize('beta',4).ne.eris%blockSize('beta',2)) then + write(6,'(A,1x,I5,1x)4') 'Dim 4 alpha = ',eris%blockSize('alpha',4),& + 'Dim 2 alpha = ',eris%blockSize('alpha',2),& + 'Dim 4 beta = ',eris%blockSize('beta',4),& + 'Dim 2 beta = ',eris%blockSize('beta',2) + call mqc_error_a('Uncoformed dimensions in mqc_eri_interaction',& + 6,'myLabel',myLabel) + end if + end if select case (eris%type()) case ('regular') select case (myLabel) @@ -12596,7 +14809,7 @@ function mqc_eri_interaction(eris,label) result(output) case('exchange') temp = eris temp2 = eris - nBasis = eris%blockSize('alpha') + nBasis = eris%blockSize('alpha',2) do i = 1, nBasis do j = 1, nBasis call temp%tput(temp2%tat([0],[i,i],[0],[j,j]),[0],[j,j],[0],[i,i]) @@ -12606,7 +14819,7 @@ function mqc_eri_interaction(eris,label) result(output) case('doublebar') temp = eris temp2 = eris - nBasis = eris%blockSize('alpha') + nBasis = eris%blockSize('alpha',2) do i = 1, nBasis do j = 1, nBasis call temp%tput(temp2%tat([0],[i,i],[0],[j,j]),[0],[j,j],[0],[i,i]) @@ -12625,7 +14838,7 @@ function mqc_eri_interaction(eris,label) result(output) case('exchange') temp = eris temp2 = eris - nBasis = eris%blockSize('alpha') + nBasis = eris%blockSize('alpha',2) do i = 1, nBasis do j = 1, nBasis call temp%tput(temp2%tat([0],[i,i],[0],[j,j]),[0],[j,j],[0],[i,i]) @@ -12635,11 +14848,11 @@ function mqc_eri_interaction(eris,label) result(output) case('doublebar') temp = eris temp2 = eris - nBasis = eris%blockSize('alpha') + nBasis = eris%blockSize('alpha',2) do i = 1, nBasis do j = 1, nBasis call temp%tput(temp2%tat([0],[i,i],[0],[j,j]),[0],[j,j],[0],[i,i]) - endDo + endDo endDo temp = temp2 - temp call mqc_twoeris_allocate(output,'full','space',temp) @@ -12665,7 +14878,7 @@ function mqc_eri_interaction(eris,label) result(output) ! Note that the result will have many zeros and so there are ! probably better alternatives to this routine ! - nBasis = eris%blockSize('alpha') + nBasis = eris%blockSize('alpha',2) call temp%init(2*nBasis,2*nBasis,2*nBasis,2*nBasis) temp2 = eris do i = 1, nBasis @@ -12722,7 +14935,7 @@ function mqc_eri_interaction(eris,label) result(output) ! Note that the result will have many zeros and so there are ! probably better alternatives to this routine ! - nBasis = eris%blockSize('alpha') + nBasis = eris%blockSize('alpha',2) call temp%init(2*nBasis,2*nBasis,2*nBasis,2*nBasis) temp2 = eris do i = 1, nBasis @@ -12775,7 +14988,7 @@ function mqc_eri_interaction(eris,label) result(output) case('coulomb') output = eris case('exchange') - nBasis = eris%blockSize('alpha') + nBasis = eris%blockSize('alpha',2) call temp%init(2*nBasis,2*nBasis,2*nBasis,2*nBasis) temp2 = eris do i = 1, nBasis @@ -12862,7 +15075,7 @@ function mqc_eri_interaction(eris,label) result(output) abbb=temp%tat([1,nBasis],[nBasis+1,2*nBasis],[nBasis+1,2*nBasis],[nBasis+1,2*nBasis])) endIf case('doublebar') - nBasis = eris%blockSize('alpha') + nBasis = eris%blockSize('alpha',2) call temp%init(2*nBasis,2*nBasis,2*nBasis,2*nBasis) temp2 = eris do i = 1, nBasis @@ -22074,14 +24287,11 @@ function mqc_twoeris_conjugate_transpose(ERIs,label) result(ERIsOut) Character(Len=64)::myLabel type(mqc_R4Tensor)::tmpaaaa,tmpbbbb,tmpaabb,tmpbbaa,tmpabab,tmpabba,tmpbaab,tmpbaba,& tmpaaab,tmpaaba,tmpabaa,tmpbaaa,tmpbbba,tmpbbab,tmpbabb,tmpabbb - - - ! if(present(label)) then call string_change_case(label,'l',myLabel) else - myLabel = 'full' + myLabel = ERIs%storageType endIf select case (ERIs%integralType) @@ -22179,12 +24389,12 @@ function mqc_integral_outer(integral,integral2,cross) result(R4out) ! !! TODO:check if the sizes are consistent - tmp1=integral%getBlock('full') - tmp2=integral2%getBlock('full') + tmp1 = integral%getBlock('full') + tmp2 = integral2%getBlock('full') if(cross) then - R4out=tmp1.crossouter.tmp2 + R4out = tmp1.crossouter.tmp2 else - R4out=tmp1.outer.tmp2 + R4out = tmp1.outer.tmp2 end if ! end function mqc_integral_outer From 199cb283a421dad1e0e652b11a870176ee573f4b Mon Sep 17 00:00:00 2001 From: Lee Thompson Date: Fri, 1 May 2026 10:42:23 -0400 Subject: [PATCH 23/37] Added Kronecker product option to mqc algerbra. --- src/mqc_algebra.F03 | 62 ++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 61 insertions(+), 1 deletion(-) diff --git a/src/mqc_algebra.F03 b/src/mqc_algebra.F03 index e63f4fe9..097b7621 100644 --- a/src/mqc_algebra.F03 +++ b/src/mqc_algebra.F03 @@ -972,6 +972,10 @@ Module MQC_Algebra Interface Operator (.crossouter.) Module Procedure MQC_Matrix_Matrix_Cross_Outer End Interface +! + Interface Operator (.kron.) + Module Procedure MQC_Matrix_Matrix_Kronecker_Product + End Interface ! ! Rank 4 tensor operators... ! @@ -27819,7 +27823,7 @@ end function MQC_Matrix_Matrix_Outer !> \verbatim !> !> MQC_Matrix_Matrix_Cross_Outer is a function that returns the rank-4 tensor containing -!> the M1(i,l)xM(k,j) outer product of two MQC matrices . +!> the M1(i,l)xM(k,j) outer product of two MQC matrices. !> !> \endverbatim ! @@ -27869,8 +27873,64 @@ Function MQC_Matrix_Matrix_Cross_Outer(matrix1,matrix2) result(outer) endDo end function MQC_Matrix_Matrix_Cross_Outer +! +! +! PROCEDURE MQC_Matrix_Matrix_Kronecker_Product +! +!> \brief MQC_Matrix_Matrix_Kronecker_Product computes the Kronecker product of +!> two matrices . +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_Matrix_Matrix_Kronecker_Product computes the Kronecker product of two +!> matrices. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] Matrix1 +!> \verbatim +!> Matrix1 is type(mqc_matrix) +!> The first matrix in the kronecker product. +!> \endverbatim +!> +!> \param[in] Matrix2 +!> \verbatim +!> Matrix2 is type(mqc_matrix) +!> The second matrix in the kronecker product. +!> \endverbatim +!> +! +! Authors: +! ======== +!> \author L. M. Thompson +!> \date 2026 +! + Function MQC_Matrix_Matrix_Kronecker_Product(matrix1,matrix2) result(kron) +! +! Variable Declarations. + Implicit None + type(mqc_matrix)::kron + type(mqc_matrix),intent(in)::matrix1,matrix2 + integer(kind=int64)::i,j,iStart,iEnd,jStart,jEnd + + call kron%init(size(matrix1,1)*size(matrix2,1),size(matrix1,2)*size(matrix2,2)) + do i = 1,size(matrix1,1) + iStart = size(matrix1,1)*(i-1)+1 + iEnd = size(matrix1,1)*i + do j = 1,size(matrix1,2) + jStart = size(matrix1,2)*(j-1)+1 + jEnd = size(matrix1,2)*j + call kron%mput(matrix1%at(i,j)*matrix2,[iStart,iEnd],[jStart,jEnd]) + endDo + endDo + end function MQC_Matrix_Matrix_Kronecker_Product ! ! ! PROCEDURE MQC_Matrix_Complex_RealPart From 562a571db801f2145c7ffb9555ee14c826157803 Mon Sep 17 00:00:00 2001 From: m0mora14 Date: Fri, 1 May 2026 13:48:09 -0400 Subject: [PATCH 24/37] Fix format --- src/mqc_general.F03 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/mqc_general.F03 b/src/mqc_general.F03 index cd0b84b5..7443463b 100644 --- a/src/mqc_general.F03 +++ b/src/mqc_general.F03 @@ -1586,7 +1586,7 @@ function complex2character(complexIn,formatString) result(complexString) else myFormatString = 'f20.5' endIf - myFormatString = '('//TRIM(myFormatString)//',SP,'//TRIM(myFormatString)//'"i")' + myFormatString = '('//TRIM(myFormatString)//',SP,'//TRIM(myFormatString)//',"i")' write(complexString,myFormatString) complexIn complexString = ADJUSTL(complexString) ! From bc3dd481bc5ab4a7ff49d35c02302c6d2ee500eb Mon Sep 17 00:00:00 2001 From: mm Date: Mon, 4 May 2026 13:06:52 -0400 Subject: [PATCH 25/37] Bug fixes in ERI SUM and Scalar multiplication --- src/mqc_algebra.F03 | 22 +- src/mqc_est.F03 | 1094 ++++++++++++++++++++++++++++++++++++++----- 2 files changed, 987 insertions(+), 129 deletions(-) diff --git a/src/mqc_algebra.F03 b/src/mqc_algebra.F03 index 95adc882..b8916644 100644 --- a/src/mqc_algebra.F03 +++ b/src/mqc_algebra.F03 @@ -32218,10 +32218,10 @@ Recursive Subroutine MQC_R4Tensor_R4Tensor_Put(Ten,TensorIn,D1,D2,D3,D4) If (IndI.lt.0) IndI = Size(Ten,1) + IndI + 1 If (IndJ.lt.0) IndJ = Size(Ten,1) + IndJ + 1 Len1 = IndJ-IndI+1 - If (Len1.le.0.or.Len1.ne.Size(TensorIn,1).or.Len1.gt.Size(Ten,1)) & + If (Len1.lt.0.or.Len1.ne.Size(TensorIn,1).or.Len1.gt.Size(Ten,1)) & Call MQC_Error_I('Dimension 1 length badly defined in MQC_R4Tensor_R4Tensor_Put', & 6,'Len1',Len1,'Size(TensorIn,1)',Size(TensorIn,1),'Size(Ten,1)',Size(Ten,1)) - If (IndI.le.0.or.IndI.gt.(Size(Ten,1)-Len1+1)) Call MQC_Error_I('Index I out of & + If (IndI.lt.0.or.IndI.gt.(Size(Ten,1)-Len1+1)) Call MQC_Error_I('Index I out of & & bounds in MQC_R4Tensor_R4Tensor_Put',6,'IndI',IndI,'Size(Ten,1)', Size(Ten,1), & 'Len1', Len1 ) If (IndJ.gt.Size(Ten,1)) Call MQC_Error_I('Index J out of bounds in & @@ -32231,10 +32231,10 @@ Recursive Subroutine MQC_R4Tensor_R4Tensor_Put(Ten,TensorIn,D1,D2,D3,D4) If (IndK.lt.0) IndK = Size(Ten,2) + IndK + 1 If (IndL.lt.0) IndL = Size(Ten,2) + IndL + 1 Len2 = IndL-IndK+1 - If (Len2.le.0.or.Len2.ne.Size(TensorIn,2).or.Len2.gt.Size(Ten,2)) & + If (Len2.lt.0.or.Len2.ne.Size(TensorIn,2).or.Len2.gt.Size(Ten,2)) & Call MQC_Error_I('Dimension 2 length badly defined in MQC_R4Tensor_R4Tensor_Put', & - 6,'Len2',Len2,'Size(TensorIn,2)', Size(TensorIn,2) ) - If (IndK.le.0.or.IndK.gt.(Size(Ten,2)-Len2+1)) Call MQC_Error_I('Index K out of & + 6,'Len2',Len2,'Size(TensorIn,2)', Size(TensorIn,2),'Size(Ten,2)',Size(Ten,2) ) + If (IndK.lt.0.or.IndK.gt.(Size(Ten,2)-Len2+1)) Call MQC_Error_I('Index K out of & & bounds in MQC_R4Tensor_R4Tensor_Put',6,'IndK',IndK,'Size(Ten,2)', & Size(Ten,2),'Len2', Len2 ) If (IndL.gt.Size(Ten,2)) Call MQC_Error_I('Index L out of bounds in & @@ -32244,10 +32244,10 @@ Recursive Subroutine MQC_R4Tensor_R4Tensor_Put(Ten,TensorIn,D1,D2,D3,D4) If (IndM.lt.0) IndM = Size(Ten,3) + IndM + 1 If (IndN.lt.0) IndN = Size(Ten,3) + IndN + 1 Len3 = IndN-IndM+1 - If (Len3.le.0.or.Len3.ne.Size(TensorIn,3).or.Len3.gt.Size(Ten,3)) & + If (Len3.lt.0.or.Len3.ne.Size(TensorIn,3).or.Len3.gt.Size(Ten,3)) & Call MQC_Error_I('Dimension 3 length badly defined in MQC_R4Tensor_R4Tensor_Put', & - 6,'Len3',Len3,'Size(TensorIn,3)',Size(TensorIn,3) ) - If (IndM.le.0.or.IndM.gt.(Size(Ten,3)-Len3+1)) Call MQC_Error_I('Index M out of & + 6,'Len3',Len3,'Size(TensorIn,3)',Size(TensorIn,3),'Size(Ten,3)',Size(Ten,3) ) + If (IndM.lt.0.or.IndM.gt.(Size(Ten,3)-Len3+1)) Call MQC_Error_I('Index M out of & & bounds in MQC_R4Tensor_R4Tensor_Put',6,'IndM',IndM,'Size(Ten,3)', Size(Ten,3), & 'Len3', Len3 ) If (IndN.gt.Size(Ten,3)) Call MQC_Error_I('Index N out of bounds in & @@ -32257,10 +32257,10 @@ Recursive Subroutine MQC_R4Tensor_R4Tensor_Put(Ten,TensorIn,D1,D2,D3,D4) If (IndO.lt.0) IndO = Size(Ten,4) + IndO + 1 If (IndP.lt.0) IndP = Size(Ten,4) + IndP + 1 Len4 = IndP-IndO+1 - If (Len4.le.0.or.Len4.ne.Size(TensorIn,4).or.Len4.gt.Size(Ten,4)) & + If (Len4.lt.0.or.Len4.ne.Size(TensorIn,4).or.Len4.gt.Size(Ten,4)) & Call MQC_Error_I('Dimension 4 length badly defined in MQC_R4Tensor_R4Tensor_Put',6, & - 'Len4',Len4,'Size(TensorIn,4)',Size(TensorIn,4) ) - If (IndO.le.0.or.IndO.gt.(Size(Ten,4)-Len4+1)) Call MQC_Error_I('Index O out of & + 'Len4',Len4,'Size(TensorIn,4)',Size(TensorIn,4),'Size(Ten,4)',Size(Ten,4) ) + If (IndO.lt.0.or.IndO.gt.(Size(Ten,4)-Len4+1)) Call MQC_Error_I('Index O out of & & bounds in MQC_R4Tensor_R4Tensor_Put',6,'IndO',IndO,'Size(Ten,4)', Size(Ten,4), & 'Len4', Len4 ) If (IndP.gt.Size(Ten,4)) Call MQC_Error_I('Index P out of bounds in & diff --git a/src/mqc_est.F03 b/src/mqc_est.F03 index 80359adf..fda45c15 100644 --- a/src/mqc_est.F03 +++ b/src/mqc_est.F03 @@ -395,6 +395,7 @@ Module MQC_EST Interface Contraction Module Procedure mqc_scf_integral_contraction Module Procedure mqc_eri_integral_contraction + Module Procedure mqc_eriSet_integral_contraction Module Procedure mqc_eri_r4tensor_contraction Module Procedure mqc_eri_eri_contraction End Interface @@ -1673,9 +1674,9 @@ function mqc_eris_has_spinBlock(eris,label) result(hasBlock) if(MQC_R4Tensor_isAllocated(eris%alpha)) hasBlock = .true. elseIf(mylabel.eq.'bbbb'.or.mylabel.eq.'beta'.or.mylabel.eq.'beta-beta') then if(MQC_R4Tensor_isAllocated(eris%beta)) hasBlock = .true. - elseIf(mylabel.eq.'aabb'.or.mylabel.eq.'alpha-beta') then + elseIf(mylabel.eq.'aabb'.or.mylabel.eq.'alpha-beta'.or.mylabel.eq.'alphabeta') then if(MQC_R4Tensor_isAllocated(eris%alphaBeta)) hasBlock = .true. - elseIf(mylabel.eq.'bbaa'.or.mylabel.eq.'beta-alpha') then + elseIf(mylabel.eq.'bbaa'.or.mylabel.eq.'beta-alpha'.or.mylabel.eq.'betaalpha') then if(MQC_R4Tensor_isAllocated(eris%betaAlpha)) hasBlock = .true. elseIf(mylabel.eq.'aaab') then if(MQC_R4Tensor_isAllocated(eris%aaab)) hasBlock = .true. @@ -3948,8 +3949,8 @@ end subroutine mqc_integral_initialize ! ========== !> \param[in,out] ERI !> \verbatim -!> ERI is class(mqc__twoERIs) -!> The MQC__twoERIs variable to initialize. +!> ERI is class(mqc_twoERIs) +!> The MQC_twoERIs variable to initialize. !> \endverbatim !> ! @@ -4032,10 +4033,12 @@ subroutine mqc_twoERIs_initialize(ERIOut,nAlpha,nBeta,label,& - if (eriType.eq.'space') then - call mqc_twoeris_allocate(eriOut,'full','space',aaaa) + if (eriType.eq.'empty') then + call mqc_twoeris_allocate(eriOut,'empty','space',aaaa) + else if (eriType.eq.'space') then + call mqc_twoeris_allocate(eriOut,'coulomb','space',aaaa) elseif (eriType.eq.'spin') then - call mqc_twoeris_allocate(eriOut,'full','spin',aaaa,bbbb,aabb,bbaa) + call mqc_twoeris_allocate(eriOut,'coulob','spin',aaaa,bbbb,aabb,bbaa) elseif (eriType.eq.'general') then call mqc_twoeris_allocate(eriOut,'full','general',aaaa,bbbb,aabb,bbaa,& abab,abba,baab,baba,aaab,aaba,abaa,baaa,bbba,& @@ -7637,6 +7640,10 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) type(mqc_r4tensor)::aaaa,bbbb,aabb,bbaa,abab,abba,baab,baba,& aaab,aaba,abaa,baaa,bbba,bbab,babb,abbb ! + write(*,*) 'Debug SUM:' + write(*,*) 'ERIA => ',ERIA%integraltype,ERIA%storagetype + write(*,*) 'ERIB => ',ERIB%integraltype,ERIB%storagetype + if(ERIA%integraltype.eq.'empty') then ERIOut = ERIB return @@ -8376,18 +8383,82 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) call mqc_twoeris_allocate(ERIOut,'full','spin',aaaa,bbbb,& aabb,bbaa) case('general') - aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') - bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') - aabb = ERIA%getBlock('aabb')+ERIB%getBlock('aabb') - bbaa = ERIA%getBlock('bbaa')+ERIB%getBlock('bbaa') - call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& - aabb,bbaa,& - ERIB%getBlock('abab'), ERIB%getBlock('abba'),& - ERIB%getBlock('baab'), ERIB%getBlock('baba'),& - ERIB%getBlock('aaab'), ERIB%getBlock('aaba'),& - ERIB%getBlock('abaa'), ERIB%getBlock('baaa'),& - ERIB%getBlock('bbba'), ERIB%getBlock('bbab'),& - ERIB%getBlock('babb'), ERIB%getBlock('abbb')) + select case(ERIA%storType()) + case('coulomb') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') + aabb = ERIA%getBlock('aabb')+ERIB%getBlock('aabb') + bbaa = ERIA%getBlock('bbaa')+ERIB%getBlock('bbaa') + call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& + aabb,bbaa,& + ERIB%getBlock('abab'), ERIB%getBlock('abba'),& + ERIB%getBlock('baab'), ERIB%getBlock('baba'),& + ERIB%getBlock('aaab'), ERIB%getBlock('aaba'),& + ERIB%getBlock('abaa'), ERIB%getBlock('baaa'),& + ERIB%getBlock('bbba'), ERIB%getBlock('bbab'),& + ERIB%getBlock('babb'), ERIB%getBlock('abbb')) + case('exchange') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') + abba = ERIA%getBlock('abba')+ERIB%getBlock('abba') + baab = ERIA%getBlock('baab')+ERIB%getBlock('baab') + call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& + ERIB%getBlock('aabb'), ERIB%getBlock('bbaa'),& + ERIB%getBlock('abab'), abba,& + baab, ERIB%getBlock('baba'),& + ERIB%getBlock('aaab'), ERIB%getBlock('aaba'),& + ERIB%getBlock('abaa'), ERIB%getBlock('baaa'),& + ERIB%getBlock('bbba'), ERIB%getBlock('bbab'),& + ERIB%getBlock('babb'), ERIB%getBlock('abbb')) + case('inverted') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') + abab = ERIA%getBlock('abab')+ERIB%getBlock('abab') + baba = ERIA%getBlock('baba')+ERIB%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& + ERIB%getBlock('aabb'), ERIB%getBlock('bbaa'),& + abab, ERIB%getBlock('abba'),& + ERIB%getBlock('baab'), baba,& + ERIB%getBlock('aaab'), ERIB%getBlock('aaba'),& + ERIB%getBlock('abaa'), ERIB%getBlock('baaa'),& + ERIB%getBlock('bbba'), ERIB%getBlock('bbab'),& + ERIB%getBlock('babb'), ERIB%getBlock('abbb')) + case('doublebar') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') + aabb = ERIA%getBlock('aabb')+ERIB%getBlock('aabb') + bbaa = ERIA%getBlock('bbaa')+ERIB%getBlock('bbaa') + abba = ERIA%getBlock('abba')+ERIB%getBlock('abba') + baab = ERIA%getBlock('baab')+ERIB%getBlock('baab') + call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& + aabb , bbaa ,& + abab , ERIB%getBlock('abba'),& + ERIB%getBlock('baab'), baba ,& + ERIB%getBlock('aaab'), ERIB%getBlock('aaba'),& + ERIB%getBlock('abaa'), ERIB%getBlock('baaa'),& + ERIB%getBlock('bbba'), ERIB%getBlock('bbab'),& + ERIB%getBlock('babb'), ERIB%getBlock('abbb')) + case('ms') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') + aabb = ERIA%getBlock('aabb')+ERIB%getBlock('aabb') + bbaa = ERIA%getBlock('bbaa')+ERIB%getBlock('bbaa') + abba = ERIA%getBlock('abba')+ERIB%getBlock('abba') + baab = ERIA%getBlock('baab')+ERIB%getBlock('baab') + abab = ERIA%getBlock('abab')+ERIB%getBlock('abab') + baba = ERIA%getBlock('baba')+ERIB%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& + aabb , bbaa ,& + abab , abba ,& + baab , baba ,& + ERIB%getBlock('aaab'), ERIB%getBlock('aaba'),& + ERIB%getBlock('abaa'), ERIB%getBlock('baaa'),& + ERIB%getBlock('bbba'), ERIB%getBlock('bbab'),& + ERIB%getBlock('babb'), ERIB%getBlock('abbb')) + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & + 'ERIA%storagetype', ERIA%stortype() ) + end select case default call mqc_error_A('Unknown twoERI type in mqc_eri_sum', 6, & 'ERIB%integraltype', ERIB%integraltype ) @@ -8434,45 +8505,45 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) case('spin') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') - select case(ERIA%storType()) + select case(ERIB%storType()) case('coulomb') aabb = ERIA%getBlock('aabb')+ERIB%getBlock('aabb') bbaa = ERIA%getBlock('bbaa')+ERIB%getBlock('bbaa') - abab = ERIB%getBlock('abab') - baba = ERIB%getBlock('baba') - baab = ERIB%getBlock('baab') - abba = ERIB%getBlock('abba') + abab = ERIA%getBlock('abab') + baba = ERIA%getBlock('baba') + baab = ERIA%getBlock('baab') + abba = ERIA%getBlock('abba') case('exchange') - aabb = ERIB%getBlock('aabb') - bbaa = ERIB%getBlock('bbaa') - abab = ERIB%getBlock('abab') - baba = ERIB%getBlock('baba') + aabb = ERIA%getBlock('aabb') + bbaa = ERIA%getBlock('bbaa') + abab = ERIA%getBlock('abab') + baba = ERIA%getBlock('baba') baab = ERIA%getBlock('baab')+ERIB%getBlock('baab') abba = ERIA%getBlock('abba')+ERIB%getBlock('abba') case('inverted') - aabb = ERIB%getBlock('aabb') - bbaa = ERIB%getBlock('bbaa') + aabb = ERIA%getBlock('aabb') + bbaa = ERIA%getBlock('bbaa') abab = ERIA%getBlock('abab')+ERIB%getBlock('abab') baba = ERIA%getBlock('baba')+ERIB%getBlock('baba') - baab = ERIB%getBlock('baab') - abba = ERIB%getBlock('abba') + baab = ERIA%getBlock('baab') + abba = ERIA%getBlock('abba') case('doublebar') - aabb = ERIB%getBlock('aabb')+ERIB%getBlock('aabb') - bbaa = ERIB%getBlock('bbaa')+ERIB%getBlock('bbaa') - abab = ERIB%getBlock('abab') - baba = ERIB%getBlock('baba') + aabb = ERIA%getBlock('aabb')+ERIB%getBlock('aabb') + bbaa = ERIA%getBlock('bbaa')+ERIB%getBlock('bbaa') + abab = ERIA%getBlock('abab') + baba = ERIA%getBlock('baba') baab = ERIA%getBlock('baab')+ERIB%getBlock('baab') abba = ERIA%getBlock('abba')+ERIB%getBlock('abba') case('ms') - aabb = ERIB%getBlock('aabb')+ERIB%getBlock('aabb') - bbaa = ERIB%getBlock('bbaa')+ERIB%getBlock('bbaa') - abab = ERIB%getBlock('abab')+ERIB%getBlock('abab') - baba = ERIB%getBlock('baba')+ERIB%getBlock('baba') + aabb = ERIA%getBlock('aabb')+ERIB%getBlock('aabb') + bbaa = ERIA%getBlock('bbaa')+ERIB%getBlock('bbaa') + abab = ERIA%getBlock('abab')+ERIB%getBlock('abab') + baba = ERIA%getBlock('baba')+ERIB%getBlock('baba') baab = ERIA%getBlock('baab')+ERIB%getBlock('baab') abba = ERIA%getBlock('abba')+ERIB%getBlock('abba') case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & - 'ERIA%storagetype', ERIA%stortype() ) + 'ERIB%storagetype', ERIB%stortype() ) end select call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& aabb,bbaa,& @@ -9514,7 +9585,7 @@ function mqc_twoERIs_scalar_multiply(eris,scalarIn) result(erisOut) type(mqc_scalar)::scalar Character(Len=64)::myLabel - myLabel = 'full' + myLabel = eris%storageType select type(scalarIn) type is (integer) @@ -9539,11 +9610,54 @@ function mqc_twoERIs_scalar_multiply(eris,scalarIn) result(erisOut) aaaa = scalar*eris%getBlock('aaaa') if(eris%hasSpinBlock('bbbb')) & bbbb = scalar*eris%getBlock('bbbb') - if(eris%hasSpinBlock('bbaa')) & - bbaa = scalar*eris%getBlock('bbaa') - if(eris%hasSpinBlock('aabb')) & - aabb = scalar*eris%getBlock('aabb') - call mqc_twoeris_allocate(erisOut,myLabel,'space',aaaa,bbbb,aabb,bbaa) + if (eris%storageType.eq.'coulomb') then + if(eris%hasSpinBlock('bbaa')) & + bbaa = scalar*eris%getBlock('bbaa') + if(eris%hasSpinBlock('aabb')) & + aabb = scalar*eris%getBlock('aabb') + call mqc_twoeris_allocate(erisOut,myLabel,'spin',aaaa,bbbb,aabb,bbaa) + else if (eris%storageType.eq.'exchange') then + if(eris%hasSpinBlock('baab')) & + bbaa = scalar*eris%getBlock('baab') + if(eris%hasSpinBlock('abba')) & + aabb = scalar*eris%getBlock('abba') + call mqc_twoeris_allocate(erisOut,myLabel,'spin',aaaa,bbbb,aabb,bbaa) + else if (eris%storageType.eq.'inverted') then + if(eris%hasSpinBlock('baba')) & + bbaa = scalar*eris%getBlock('baba') + if(eris%hasSpinBlock('abab')) & + aabb = scalar*eris%getBlock('abab') + call mqc_twoeris_allocate(erisOut,myLabel,'spin',aaaa,bbbb,aabb,bbaa) + else if (eris%storageType.eq.'doublebar') then + if(eris%hasSpinBlock('bbaa')) & + bbaa = scalar*eris%getBlock('bbaa') + if(eris%hasSpinBlock('aabb')) & + aabb = scalar*eris%getBlock('aabb') + if(eris%hasSpinBlock('baab')) & + baab = scalar*eris%getBlock('baab') + if(eris%hasSpinBlock('abba')) & + abba = scalar*eris%getBlock('abba') + call mqc_twoeris_allocate(erisOut,myLabel,'spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab) + else if (eris%storageType.eq.'ms') then + if(eris%hasSpinBlock('bbaa')) & + bbaa = scalar*eris%getBlock('bbaa') + if(eris%hasSpinBlock('aabb')) & + aabb = scalar*eris%getBlock('aabb') + if(eris%hasSpinBlock('baab')) & + baab = scalar*eris%getBlock('baab') + if(eris%hasSpinBlock('abba')) & + abba = scalar*eris%getBlock('abba') + if(eris%hasSpinBlock('abab')) & + abab = scalar*eris%getBlock('abab') + if(eris%hasSpinBlock('baba')) & + baba = scalar*eris%getBlock('baba') + call mqc_twoeris_allocate(erisOut,myLabel,'spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab,baba=baba,abab=abab) + else + call mqc_error_A('Unknown twoERI storage type in mqc_scalar_twoeris_multiply', 6, & + 'ERIS%itortype()', ERIS%stortype() ) + end if case('general') if(eris%hasSpinBlock('aaaa')) & aaaa = scalar*eris%getBlock('aaaa') @@ -9638,7 +9752,7 @@ function mqc_scalar_twoERIs_multiply(scalarIn,eris) result(erisOut) type(mqc_scalar)::scalar Character(Len=64)::myLabel - myLabel = 'full' + myLabel = eris%storType() select type(scalarIn) type is (integer) @@ -9663,11 +9777,55 @@ function mqc_scalar_twoERIs_multiply(scalarIn,eris) result(erisOut) aaaa = scalar*eris%getBlock('aaaa') if(eris%hasSpinBlock('bbbb')) & bbbb = scalar*eris%getBlock('bbbb') - if(eris%hasSpinBlock('bbaa')) & - bbaa = scalar*eris%getBlock('bbaa') - if(eris%hasSpinBlock('aabb')) & - aabb = scalar*eris%getBlock('aabb') - call mqc_twoeris_allocate(erisOut,myLabel,'space',aaaa,bbbb,aabb,bbaa) + if (eris%storageType.eq.'coulomb') then + if(eris%hasSpinBlock('bbaa')) & + bbaa = scalar*eris%getBlock('bbaa') + if(eris%hasSpinBlock('aabb')) & + aabb = scalar*eris%getBlock('aabb') + call mqc_twoeris_allocate(erisOut,myLabel,'spin',aaaa,bbbb,aabb,bbaa) + else if (eris%storageType.eq.'exchange') then + if(eris%hasSpinBlock('baab')) & + bbaa = scalar*eris%getBlock('baab') + if(eris%hasSpinBlock('abba')) & + aabb = scalar*eris%getBlock('abba') + call mqc_twoeris_allocate(erisOut,myLabel,'spin',aaaa,bbbb,aabb,bbaa) + else if (eris%storageType.eq.'inverted') then + if(eris%hasSpinBlock('baba')) & + bbaa = scalar*eris%getBlock('baba') + if(eris%hasSpinBlock('abab')) & + aabb = scalar*eris%getBlock('abab') + call mqc_twoeris_allocate(erisOut,myLabel,'spin',aaaa,bbbb,aabb,bbaa) + else if (eris%storageType.eq.'doublebar') then + if(eris%hasSpinBlock('bbaa')) & + bbaa = scalar*eris%getBlock('bbaa') + if(eris%hasSpinBlock('aabb')) & + aabb = scalar*eris%getBlock('aabb') + if(eris%hasSpinBlock('baab')) & + baab = scalar*eris%getBlock('baab') + if(eris%hasSpinBlock('abba')) & + abba = scalar*eris%getBlock('abba') + call mqc_twoeris_allocate(erisOut,myLabel,'spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab) + else if (eris%storageType.eq.'ms') then + if(eris%hasSpinBlock('bbaa')) & + bbaa = scalar*eris%getBlock('bbaa') + if(eris%hasSpinBlock('aabb')) & + aabb = scalar*eris%getBlock('aabb') + if(eris%hasSpinBlock('baab')) & + baab = scalar*eris%getBlock('baab') + if(eris%hasSpinBlock('abba')) & + abba = scalar*eris%getBlock('abba') + if(eris%hasSpinBlock('abab')) & + abab = scalar*eris%getBlock('abab') + if(eris%hasSpinBlock('baba')) & + baba = scalar*eris%getBlock('baba') + + call mqc_twoeris_allocate(erisOut,myLabel,'spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab,baba=baba,abab=abab) + else + call mqc_error_A('Unknown twoERI storage type in mqc_scalar_twoeris_multiply', 6, & + 'ERIS%stortype()', ERIS%stortype() ) + end if case('general') if(eris%hasSpinBlock('aaaa')) & aaaa = scalar*eris%getBlock('aaaa') @@ -10100,20 +10258,20 @@ function mqc_integral_integral_crossouter_product(integralA,integralB) result(ER abba = AlphaA.crossouter.BetaB baab = BetaA.crossouter.AlphaB if(integralA%array_type.eq.'general') then - AlBeA=integralA%getBlock('alphabeta') - BeAlA=integralA%getBlock('betaalpha') + AlBeA=integralA%getBlock('betaalpha') + BeAlA=integralA%getBlock('alphabeta') aaab = AlBeA.crossouter.AlphaB baaa = BeAlA.crossouter.AlphaB abbb = AlBeA.crossouter.BetaB bbba = BeAlA.crossouter.BetaB end if if(integralB%array_type.eq.'general') then - AlBeB=integralB%getBlock('alphabeta') - BeAlB=integralB%getBlock('betaalpha') + AlBeB=integralB%getBlock('betaalpha') + BeAlB=integralB%getBlock('alphabeta') abaa = AlphaA.crossouter.AlBeB aaba = AlphaA.crossouter.BeAlB bbab = BetaA.crossouter.AlBeB - babb = BetaA.outer.BeAlB + babb = BetaA.crossouter.BeAlB end if if(integralA%array_type.eq.'general'.and.integralB%array_type.eq.'general') then abab = AlBeA.crossouter.AlBeB @@ -11496,9 +11654,9 @@ function mqc_scf_integral_contraction(integral1,integral2) result(output) end function mqc_scf_integral_contraction ! ! -! PROCEDURE MQC_ERI_Integral_Contraction +! PROCEDURE MQC_ERISet_Integral_Contraction ! -!> \brief MQC_ERI_Integral_Contraction is used to return the contraction of +!> \brief MQC_ERISet_Integral_Contraction is used to return the contraction of !> two-ERIs with an MQC integral ! !> \par Purpose: @@ -11506,7 +11664,7 @@ end function mqc_scf_integral_contraction !> !> \verbatim !> -!> MQC_ERI_Integral_Contraction is used to return the contraction of two-ERIs with +!> MQC_ERISet_Integral_Contraction is used to return the contraction of two-ERIs with !> an MQC integral. Optional argument label can be used to return contractions !> with single bar ERIs (coulomb or exchange), or the complete contraction with !> double-bar integrals. The following options are available: @@ -11521,8 +11679,8 @@ end function mqc_scf_integral_contraction ! ========== !> \param[in] ERIs !> \verbatim -!> ERIs is type(mqc_twoERIs) -!> The 2ERIs to be contracted. +!> ERIs is type(mqc_twoERIsSet) +!> The 2ERIs Set to be contracted. !> \endverbatim !> !> \param[in] Integral @@ -11552,7 +11710,7 @@ end function mqc_scf_integral_contraction !> \author L. M. Thompson !> \date 2018 ! - function mqc_eri_integral_contraction(eris,integral,zeroIn,label) result(output) + function mqc_eriSet_integral_contraction(eris,integral,zeroIn,label) result(output) ! implicit none type(mqc_twoERISet),intent(in)::eris @@ -11583,7 +11741,7 @@ function mqc_eri_integral_contraction(eris,integral,zeroIn,label) result(output) ! half = 0.5 if(algorithm.ne.'square'.and.algorithm.ne.'regular') & - call mqc_error_A('Unknown algorithm option in mqc_eri_integral_contraction',6, & + call mqc_error_A('Unknown algorithm option in mqc_eriSet_integral_contraction',6, & 'algorithm',algorithm) ! if(present(zeroIn)) then @@ -11594,27 +11752,25 @@ function mqc_eri_integral_contraction(eris,integral,zeroIn,label) result(output) ! if(present(label)) then call string_change_case(label,'L',myLabel) - if(algorithm.eq.'regular'.and.myLabel.ne.'doublebar') & - call mqc_error_a('Regular algorithm only returns double bar integrals',6, & - 'algorithm',algorithm,'myLabel',myLabel) + if(myLabel.ne.'doublebar') algorithm = 'square' else myLabel = 'doublebar' endIf if(integral%blockSize('alpha',1).ne.integral%blockSize('alpha',2)) & - call mqc_error_I('Arrays are not sized as expected in MQC_ERI_Integral_Contraction', & - 6,'integral%blockSize(alpha,1)', integral%blockSize('alpha',1), & + call mqc_error_I('Arrays are not sized as expected in MQC_ERISet_Integral_Contraction', & + 6,'integral%blockSize(alpha,1)', integral%blockSize('alpha',1), & 'integral%blockSize(alpha,2)',integral%blockSize('alpha',2)) if(integral%blockSize('beta',1).ne.integral%blockSize('beta',2)) & - call mqc_error_I('Arrays are not sized as expected in MQC_ERI_Integral_Contraction' & + call mqc_error_I('Arrays are not sized as expected in MQC_ERISet_Integral_Contraction' & ,6,'integral%blockSize(beta,1)', integral%blockSize('beta',1), & 'integral%blockSize(beta,2)',integral%blockSize('beta',2)) if(integral%blockSize('alpha',1).ne.integral%blockSize('beta',2)) & - call mqc_error_I('Arrays are not sized as expected in MQC_ERI_Integral_Contraction', & + call mqc_error_I('Arrays are not sized as expected in MQC_ERISet_Integral_Contraction', & 6,'integral%blockSize(alpha,1)', integral%blockSize('alpha',1), & 'integral%blockSize(beta,2)',integral%blockSize('beta',2)) if(integral%blockSize('beta',1).ne.integral%blockSize('alpha',2)) & - call mqc_error_I('Arrays are not sized as expected in MQC_ERI_Integral_Contraction', & + call mqc_error_I('Arrays are not sized as expected in MQC_ERISet_Integral_Contraction', & 6,'integral%blockSize(beta,1)', integral%blockSize('beta',1), & 'integral%blockSize(alpha,2)',integral%blockSize('alpha',2)) if(myLabel.ne.'doublebar'.and.algorithm.eq.'regular') & @@ -11631,7 +11787,7 @@ function mqc_eri_integral_contraction(eris,integral,zeroIn,label) result(output) if(eris%erinum('regular').eq.0.and.eris%erinum('raffenetti1').eq.0) & call mqc_error('Regular or Raffenetti integrals are required in & - &mqc_eri_integral_contraction') + &mqc_eriset_integral_contraction') nBasis = integral%blockSize('alpha') ntt = (nBasis*(nBasis+1))/2 @@ -11953,7 +12109,7 @@ function mqc_eri_integral_contraction(eris,integral,zeroIn,label) result(output) if(kp.eq.mp) raf1 = 0.5*raf1 else call mqc_error('Regular or Raffenetti 1 type TwoERIs missing in & - & mqc_eri_integral_contraction') + & mqc_eriset_integral_contraction') endIf if(mod(flag,10).gt.0) then if(eris%erinum('raffenetti2').ne.0) then @@ -11964,7 +12120,7 @@ function mqc_eri_integral_contraction(eris,integral,zeroIn,label) result(output) if(kp.eq.mp) raf2 = 0.5*raf2 else call mqc_error('Regular or Raffenetti 2 type TwoERIs missing in & - & mqc_eri_integral_contraction') + & mqc_eriset_integral_contraction') endIf else raf2 = 0.0 @@ -11979,7 +12135,7 @@ function mqc_eri_integral_contraction(eris,integral,zeroIn,label) result(output) if(kp.eq.mp) raf3 = 0.5*raf3 else call mqc_error('Regular or Raffenetti 3 type TwoERIs missing in & - & mqc_eri_integral_contraction') + & mqc_eriset_integral_contraction') endIf endIf else @@ -12273,7 +12429,7 @@ function mqc_eri_integral_contraction(eris,integral,zeroIn,label) result(output) if(eris%erinum('regular').eq.0) call mqc_error('Square algorithm twoERI & &contraction only implemented with regular integrals in & - &mqc_eri_integral_contraction') + &mqc_eriSet_integral_contraction') ! !$OMP PARALLEL REDUCTION(+:alpha,beta,alphaBeta,betaAlpha) DEFAULT(NONE), & !$OMP PARALLEL DEFAULT(NONE), & @@ -12352,6 +12508,705 @@ function mqc_eri_integral_contraction(eris,integral,zeroIn,label) result(output) ! if(DEBUG) call output%print(6,'Final Fock matrix') + end function mqc_eriSet_integral_contraction +! +! +! PROCEDURE MQC_ERI_Integral_Contraction +! +!> \brief MQC_ERI_Integral_Contraction is used to return the contraction of +!> two-ERIs with an MQC integral +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_ERI_Integral_Contraction is used to return the contraction of two-ERIs with +!> an MQC integral. Optional argument inored can be used define the indexes to be +!> contracted. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] ERIsIn +!> \verbatim +!> ERIsIn is type(mqc_twoERIs) +!> The 2ERIs to be contracted. +!> \endverbatim +!> +!> \param[in] Integral +!> \verbatim +!> Integral is type(mqc_scf_integral) +!> The MQC integral to be contracted. +!> \endverbatim +!> +!> \param[in] inorder +!> \verbatim +!> inorder is Integer(kind=int64),dimension(2),Intent(In),optional +!> contain the two ERI indexes to be contracted (default=[1,2]) +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2024 +! + function mqc_eri_integral_contraction(erisIn,integral,inorder) result(output) +! + implicit none + type(mqc_twoERIs),intent(in)::erisIn + type(mqc_scf_integral),intent(in)::integral + Integer(kind=int64),dimension(2),Intent(In),optional::inorder + Integer(kind=int64),dimension(2)::ind + character(len=64)::FinalType + type(mqc_twoERIs)::eris + type(mqc_scf_integral)::output + type(mqc_matrix)::aa,bb,ab,ba,tmpM + logical::same + integer::ia,ib +! + eris = erisIn + if(present(inorder)) then + same=.false. + ind=inorder + ia=inorder(1) + ib=inorder(2) + if (ia.eq.ib) Call MQC_Error_I('Duplicated index in MQC_ERI_Integral_Contraction', 6, & + 'ia', ia,'ib',ib) + if (ia.gt.4.or.ia.le.0.or.ib.gt.4.or.ib.le.0) Call MQC_Error_I(& + 'Index out of range in MQC_ERI_Integral_Contraction', 6, & + 'ia', ia,'ib',ib) + if (ia.eq.1.or.ia.eq.2) then + if (ib.eq.1.or.ib.eq.2) same=.true. + else + if (ib.eq.3.or.ib.eq.4) same=.true. + endif + else + ind=[1,2] + ia=1 + ib=2 + same=.true. + endif + select case (eris%type()) + case ('space','regular') + select case (integral%type()) + case ('space') + aa=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaaa'),& + integral%getBlock('aa'),ind) + if(same) aa=2*aa + FinalType='space' + case ('spin') + aa=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaaa'),& + integral%getBlock('aa'),ind) + tmpM=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaaa'),& + integral%getBlock('bb'),ind) + if(same) then + aa=aa+tmpM + FinalType='space' + else + bb=tmpM + FinalType='spin' + endif + case ('general') + aa=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaaa'),& + integral%getBlock('aa'),ind) + tmpM=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaaa'),& + integral%getBlock('bb'),ind) + if(same) then + aa=aa+tmpM + FinalType='space' + else + bb=tmpM + if (ia.lt.ib) then + ab=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaaa'),& + integral%getBlock('ab'),ind) + ba=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaaa'),& + integral%getBlock('ba'),ind) + else + ba=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaaa'),& + integral%getBlock('ab'),ind) + ab=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaaa'),& + integral%getBlock('ba'),ind) + endif + FinalType='general' + endif + end select + case ('spin') + select case (integral%type()) + case ('space') + aa=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaaa'),& + integral%getBlock('aa'),ind) + bb=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbbb'),& + integral%getBlock('aa'),ind) + if(same) then + if(ia.eq.1.or.ia.eq.2) then + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbaa'),& + integral%getBlock('aa'),ind) + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aabb'),& + integral%getBlock('aa'),ind) + else + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aabb'),& + integral%getBlock('aa'),ind) + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbaa'),& + integral%getBlock('aa'),ind) + endif + FinalType='spin' + else + FinalType='spin' + endif + case ('spin') + aa=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaaa'),& + integral%getBlock('aa'),ind) + bb=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbbb'),& + integral%getBlock('bb'),ind) + if(same) then + if(ia.eq.1.or.ia.eq.2) then + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbaa'),& + integral%getBlock('bb'),ind) + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aabb'),& + integral%getBlock('aa'),ind) + else + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aabb'),& + integral%getBlock('bb'),ind) + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbaa'),& + integral%getBlock('aa'),ind) + endif + FinalType='spin' + else + FinalType='spin' + endif + case ('general') + aa=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaaa'),& + integral%getBlock('aa'),ind) + bb=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbbb'),& + integral%getBlock('bb'),ind) + if(same) then + if(ia.eq.1.or.ia.eq.2) then + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbaa'),& + integral%getBlock('bb'),ind) + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aabb'),& + integral%getBlock('aa'),ind) + else + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aabb'),& + integral%getBlock('bb'),ind) + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbaa'),& + integral%getBlock('aa'),ind) + endif + FinalType='spin' + else + if (ia.lt.ib) then + ab=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aabb'),& + integral%getBlock('ab'),ind) + ba=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaaa'),& + integral%getBlock('ba'),ind) + else + ba=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaaa'),& + integral%getBlock('ab'),ind) + ab=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaaa'),& + integral%getBlock('ba'),ind) + endif + FinalType='general' + endif + end select + case ('general') + select case (integral%type()) + case ('space') + aa=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaaa'),& + integral%getBlock('aa'),ind) + bb=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbbb'),& + integral%getBlock('aa'),ind) + if(same) then + if(ia.eq.1.or.ia.eq.2) then + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbaa'),& + integral%getBlock('aa'),ind) + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aabb'),& + integral%getBlock('aa'),ind) + ab=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaab'),& + integral%getBlock('aa'),ind) + ab=ab+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbab'),& + integral%getBlock('aa'),ind) + ba=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaba'),& + integral%getBlock('aa'),ind) + ba=ba+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbba'),& + integral%getBlock('aa'),ind) + else + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aabb'),& + integral%getBlock('aa'),ind) + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbaa'),& + integral%getBlock('aa'),ind) + ab=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abaa'),& + integral%getBlock('aa'),ind) + ab=ab+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abbb'),& + integral%getBlock('aa'),ind) + ba=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baaa'),& + integral%getBlock('aa'),ind) + ba=ba+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('babb'),& + integral%getBlock('aa'),ind) + endif + FinalType='general' + else + if (ia.lt.ib) then + if (ib.eq.4) then + ab=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaba'),& + integral%getBlock('aa'),ind) + ba=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbab'),& + integral%getBlock('aa'),ind) + endif + if (ib.eq.3) then + ab=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaab'),& + integral%getBlock('aa'),ind) + ba=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbba'),& + integral%getBlock('aa'),ind) + endif + if(ia.eq.1.and.ib.eq.3) then + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abab'),& + integral%getBlock('aa'),ind) + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baba'),& + integral%getBlock('aa'),ind) + elseif(ia.eq.1.and.ib.eq.4) then + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abba'),& + integral%getBlock('aa'),ind) + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baab'),& + integral%getBlock('aa'),ind) + elseif(ia.eq.2.and.ib.eq.3) then + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baab'),& + integral%getBlock('aa'),ind) + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abba'),& + integral%getBlock('aa'),ind) + elseif(ia.eq.2.and.ib.eq.4) then + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baba'),& + integral%getBlock('aa'),ind) + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abab'),& + integral%getBlock('aa'),ind) + endif + else + if (ia.eq.4) then + ab=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaba'),& + integral%getBlock('aa'),ind) + ba=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbab'),& + integral%getBlock('aa'),ind) + endif + if (ia.eq.3) then + ab=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaab'),& + integral%getBlock('aa'),ind) + ba=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbba'),& + integral%getBlock('aa'),ind) + endif + if(ib.eq.1.and.ia.eq.3) then + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abab'),& + integral%getBlock('aa'),ind) + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baba'),& + integral%getBlock('aa'),ind) + elseif(ib.eq.1.and.ia.eq.4) then + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abba'),& + integral%getBlock('aa'),ind) + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baab'),& + integral%getBlock('aa'),ind) + elseif(ib.eq.2.and.ia.eq.3) then + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baab'),& + integral%getBlock('aa'),ind) + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abba'),& + integral%getBlock('aa'),ind) + elseif(ib.eq.2.and.ia.eq.4) then + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baba'),& + integral%getBlock('aa'),ind) + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abab'),& + integral%getBlock('aa'),ind) + endif + endif + FinalType='general' + endif + case ('spin') + aa=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaaa'),& + integral%getBlock('aa'),ind) + bb=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbbb'),& + integral%getBlock('bb'),ind) + if(same) then + if(ia.eq.1.or.ia.eq.2) then + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbaa'),& + integral%getBlock('bb'),ind) + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aabb'),& + integral%getBlock('aa'),ind) + ab=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaab'),& + integral%getBlock('aa'),ind) + ab=ab+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbab'),& + integral%getBlock('bb'),ind) + ba=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaba'),& + integral%getBlock('aa'),ind) + ba=ba+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbba'),& + integral%getBlock('bb'),ind) + else + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aabb'),& + integral%getBlock('bb'),ind) + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbaa'),& + integral%getBlock('aa'),ind) + ab=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abaa'),& + integral%getBlock('aa'),ind) + ab=ab+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abbb'),& + integral%getBlock('bb'),ind) + ba=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baaa'),& + integral%getBlock('aa'),ind) + ba=ba+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('babb'),& + integral%getBlock('bb'),ind) + endif + FinalType='general' + else + if (ia.lt.ib) then + if (ib.eq.4) then + ab=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaba'),& + integral%getBlock('aa'),ind) + ba=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbab'),& + integral%getBlock('bb'),ind) + endif + if (ib.eq.3) then + ab=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaab'),& + integral%getBlock('aa'),ind) + ba=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbba'),& + integral%getBlock('bb'),ind) + endif + if(ia.eq.1.and.ib.eq.3) then + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abab'),& + integral%getBlock('aa'),ind) + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baba'),& + integral%getBlock('bb'),ind) + elseif(ia.eq.1.and.ib.eq.4) then + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abba'),& + integral%getBlock('aa'),ind) + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baab'),& + integral%getBlock('bb'),ind) + elseif(ia.eq.2.and.ib.eq.3) then + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baab'),& + integral%getBlock('aa'),ind) + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abba'),& + integral%getBlock('bb'),ind) + elseif(ia.eq.2.and.ib.eq.4) then + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baba'),& + integral%getBlock('aa'),ind) + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abab'),& + integral%getBlock('bb'),ind) + endif + else + if (ia.eq.4) then + ab=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaba'),& + integral%getBlock('aa'),ind) + ba=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbab'),& + integral%getBlock('bb'),ind) + endif + if (ia.eq.3) then + ab=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaab'),& + integral%getBlock('aa'),ind) + ab=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbba'),& + integral%getBlock('bb'),ind) + endif + if(ib.eq.1.and.ia.eq.3) then + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abab'),& + integral%getBlock('aa'),ind) + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baba'),& + integral%getBlock('bb'),ind) + elseif(ib.eq.1.and.ia.eq.4) then + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abba'),& + integral%getBlock('aa'),ind) + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baab'),& + integral%getBlock('bb'),ind) + elseif(ib.eq.2.and.ia.eq.3) then + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baab'),& + integral%getBlock('aa'),ind) + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abba'),& + integral%getBlock('bb'),ind) + elseif(ib.eq.2.and.ia.eq.4) then + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baba'),& + integral%getBlock('aa'),ind) + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abab'),& + integral%getBlock('bb'),ind) + endif + endif + FinalType='general' + endif + case ('general') + aa=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaaa'),& + integral%getBlock('aa'),ind) + bb=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbbb'),& + integral%getBlock('bb'),ind) + if(same) then + if(ia.eq.1.or.ia.eq.2) then + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbaa'),& + integral%getBlock('bb'),ind) + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aabb'),& + integral%getBlock('aa'),ind) + ab=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaab'),& + integral%getBlock('aa'),ind) + ab=ab+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbab'),& + integral%getBlock('bb'),ind) + ba=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaba'),& + integral%getBlock('aa'),ind) + ba=ba+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbba'),& + integral%getBlock('bb'),ind) + if(ia.eq.1) then + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abaa'),& + integral%getBlock('ab'),ind) + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baaa'),& + integral%getBlock('ba'),ind) + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abbb'),& + integral%getBlock('ab'),ind) + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('babb'),& + integral%getBlock('ba'),ind) + ab=ab+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abab'),& + integral%getBlock('ab'),ind) + ab=ab+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baab'),& + integral%getBlock('ba'),ind) + ba=ba+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baba'),& + integral%getBlock('ba'),ind) + ba=ba+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abba'),& + integral%getBlock('ab'),ind) + else + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baaa'),& + integral%getBlock('ab'),ind) + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abaa'),& + integral%getBlock('ba'),ind) + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('babb'),& + integral%getBlock('ab'),ind) + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abbb'),& + integral%getBlock('ba'),ind) + ab=ab+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abab'),& + integral%getBlock('ba'),ind) + ab=ab+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baab'),& + integral%getBlock('ab'),ind) + ba=ba+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baba'),& + integral%getBlock('ab'),ind) + ba=ba+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abba'),& + integral%getBlock('ba'),ind) + endif + else + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aabb'),& + integral%getBlock('bb'),ind) + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbaa'),& + integral%getBlock('aa'),ind) + ab=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abaa'),& + integral%getBlock('aa'),ind) + ab=ab+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abbb'),& + integral%getBlock('bb'),ind) + ba=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baaa'),& + integral%getBlock('aa'),ind) + ba=ba+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('babb'),& + integral%getBlock('bb'),ind) + if(ia.eq.3) then + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaab'),& + integral%getBlock('ab'),ind) + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaba'),& + integral%getBlock('ba'),ind) + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbab'),& + integral%getBlock('ab'),ind) + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbba'),& + integral%getBlock('ba'),ind) + ab=ab+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abab'),& + integral%getBlock('ab'),ind) + ab=ab+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abba'),& + integral%getBlock('ba'),ind) + ba=ba+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baba'),& + integral%getBlock('ba'),ind) + ba=ba+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baab'),& + integral%getBlock('ab'),ind) + else + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaba'),& + integral%getBlock('ab'),ind) + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaab'),& + integral%getBlock('ba'),ind) + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbba'),& + integral%getBlock('ab'),ind) + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbab'),& + integral%getBlock('ba'),ind) + ab=ab+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abab'),& + integral%getBlock('ba'),ind) + ab=ab+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abba'),& + integral%getBlock('ab'),ind) + ba=ba+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baba'),& + integral%getBlock('ab'),ind) + ba=ba+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baab'),& + integral%getBlock('ba'),ind) + endif + endif + FinalType='general' + else + if (ia.lt.ib) then + ab=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aabb'),& + integral%getBlock('ab'),ind) + ba=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbaa'),& + integral%getBlock('ba'),ind) + if (ib.eq.4) then + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaab'),& + integral%getBlock('ab'),ind) + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbba'),& + integral%getBlock('ba'),ind) + ab=ab+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaba'),& + integral%getBlock('aa'),ind) + ba=ba+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbab'),& + integral%getBlock('bb'),ind) + endif + if (ib.eq.3) then + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaba'),& + integral%getBlock('ab'),ind) + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbab'),& + integral%getBlock('ba'),ind) + ab=ab+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaab'),& + integral%getBlock('aa'),ind) + ba=ba+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbba'),& + integral%getBlock('bb'),ind) + endif + if (ia.eq.1) then + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abbb'),& + integral%getBlock('ab'),ind) + ab=ab+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('babb'),& + integral%getBlock('bb'),ind) + ba=ba+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abaa'),& + integral%getBlock('aa'),ind) + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baaa'),& + integral%getBlock('ba'),ind) + endif + if (ia.eq.2) then + ab=ab+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abbb'),& + integral%getBlock('bb'),ind) + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('babb'),& + integral%getBlock('ab'),ind) + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abaa'),& + integral%getBlock('ba'),ind) + ba=ba+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baaa'),& + integral%getBlock('aa'),ind) + endif + if(ia.eq.1.and.ib.eq.3) then + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abab'),& + integral%getBlock('aa'),ind) + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baba'),& + integral%getBlock('bb'),ind) + ab=ab+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baab'),& + integral%getBlock('ba'),ind) + ba=ba+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abba'),& + integral%getBlock('ab'),ind) + elseif(ia.eq.1.and.ib.eq.4) then + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abba'),& + integral%getBlock('aa'),ind) + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baab'),& + integral%getBlock('bb'),ind) + ab=ab+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baba'),& + integral%getBlock('ba'),ind) + ba=ba+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abab'),& + integral%getBlock('ab'),ind) + elseif(ia.eq.2.and.ib.eq.3) then + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baab'),& + integral%getBlock('aa'),ind) + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abba'),& + integral%getBlock('bb'),ind) + ab=ab+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abab'),& + integral%getBlock('ba'),ind) + ba=ba+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baba'),& + integral%getBlock('ab'),ind) + elseif(ia.eq.2.and.ib.eq.4) then + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baba'),& + integral%getBlock('aa'),ind) + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abab'),& + integral%getBlock('bb'),ind) + ab=ab+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abba'),& + integral%getBlock('ba'),ind) + ba=ba+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baab'),& + integral%getBlock('ab'),ind) + endif + else + ab=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aabb'),& + integral%getBlock('ba'),ind) + ba=MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbaa'),& + integral%getBlock('ab'),ind) + if (ia.eq.4) then + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaab'),& + integral%getBlock('ba'),ind) + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbba'),& + integral%getBlock('ab'),ind) + ab=ab+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaba'),& + integral%getBlock('aa'),ind) + ba=ba+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbab'),& + integral%getBlock('bb'),ind) + endif + if (ia.eq.3) then + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaba'),& + integral%getBlock('ba'),ind) + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbab'),& + integral%getBlock('ab'),ind) + ab=ab+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('aaab'),& + integral%getBlock('aa'),ind) + ba=ba+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('bbba'),& + integral%getBlock('bb'),ind) + endif + if (ib.eq.1) then + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abbb'),& + integral%getBlock('ba'),ind) + ab=ab+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('babb'),& + integral%getBlock('bb'),ind) + ba=ba+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abaa'),& + integral%getBlock('aa'),ind) + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baaa'),& + integral%getBlock('ab'),ind) + endif + if (ib.eq.2) then + ab=ab+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abbb'),& + integral%getBlock('bb'),ind) + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('babb'),& + integral%getBlock('ba'),ind) + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abaa'),& + integral%getBlock('ab'),ind) + ba=ba+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baaa'),& + integral%getBlock('aa'),ind) + endif + if(ib.eq.1.and.ia.eq.3) then + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abab'),& + integral%getBlock('aa'),ind) + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baba'),& + integral%getBlock('bb'),ind) + ab=ab+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baab'),& + integral%getBlock('ab'),ind) + ba=ba+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abba'),& + integral%getBlock('ba'),ind) + elseif(ib.eq.1.and.ia.eq.4) then + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abba'),& + integral%getBlock('aa'),ind) + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baab'),& + integral%getBlock('bb'),ind) + ab=ab+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baba'),& + integral%getBlock('ab'),ind) + ba=ba+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abab'),& + integral%getBlock('ba'),ind) + elseif(ib.eq.2.and.ia.eq.3) then + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baab'),& + integral%getBlock('aa'),ind) + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abba'),& + integral%getBlock('bb'),ind) + ab=ab+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abab'),& + integral%getBlock('ab'),ind) + ba=ba+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baba'),& + integral%getBlock('ba'),ind) + elseif(ib.eq.2.and.ia.eq.4) then + bb=bb+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baba'),& + integral%getBlock('aa'),ind) + aa=aa+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abab'),& + integral%getBlock('bb'),ind) + ab=ab+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('abba'),& + integral%getBlock('ab'),ind) + ba=ba+MQC_R4Tensor_Matrix_Contraction(eris%getBlock('baab'),& + integral%getBlock('ba'),ind) + endif + endif + FinalType='general' + endif + end select + end select + + select case (FinalType) + case ('space') + call mqc_integral_allocate(output,'','space',aa) + case ('spin') + call mqc_integral_allocate(output,'','spin',aa,bb) + case ('general') + call mqc_integral_allocate(output,'','general',aa,bb,ab,ba) + end select +! end function mqc_eri_integral_contraction ! ! @@ -13181,9 +14036,15 @@ function mqc_eri_eri_partial_contraction_2eri(eris1,eris2,index1,index2) result( la.gt.4.or.la.le.0.or.lb.gt.4.or.lb.le.0.) Call MQC_Error(& 'Index out of range in MQC_ERI_ERI_Partial_Contraction_2eri', 6) - if(eris1%storageType.eq.'empty'.or.eris2%storageType.eq.'empty') then + if(eris1%storageType.eq.'empty'.and.eris2%storageType.eq.'empty') then call mqc_twoeris_allocate(eriOut,'empty','empty') return + else if(eris1%storageType.eq.'empty') then + eriOut = eris2 + return + else if(eris2%storageType.eq.'empty') then + eriOut = eris1 + return end if @@ -13281,12 +14142,8 @@ function mqc_eri_eri_partial_contraction_2eri(eris1,eris2,index1,index2) result( select case (active_conf) case('aaaa') if(eriType.eq.'empty') eriType = 'space' - write(*,*) 'aaaa from '//trim(str1)//' '//trim(str2) - call mqc_print(eris1%getBlock(str1),6,'eri1') - call mqc_print(eris2%getBlock(str2),6,'eri2') aaaa = aaaa + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) - call mqc_print(aaaa,6,'aaaa updated') allocVec(1)=.true. case('bbbb') if(eriType.eq.'space'.or.eriType.eq.'empty') eriType = 'spin' @@ -13418,7 +14275,8 @@ function mqc_eri_eri_partial_contraction_2eri(eris1,eris2,index1,index2) result( enddo enddo - if(storType.eq.'unknown') storType = 'ful' + if(storType.eq.'unknown') & + call mqc_error('Final StorageType unknown in mqc_eri_eri_partial_contraction_2eri',6) if (eriType.eq.'empty') then call mqc_twoeris_allocate(eriOut,'empty','empty') else if (eriType.eq.'space') then @@ -13906,7 +14764,7 @@ function mqc_eri_dimension_swap(eris,dim1,dim2) result(output) allocVec(1)=.true. end if if(eris%hasSpinBlock('bbbb')) then - taaaa = eris%getBlock('beta') + tbbbb = eris%getBlock('beta') allocVec(2)=.true. end if if(eris%hasSpinBlock('AlphaBeta')) then @@ -13914,55 +14772,55 @@ function mqc_eri_dimension_swap(eris,dim1,dim2) result(output) allocVec(3)=.true. end if if(eris%hasSpinBlock('BetaAlpha')) then - taabb = eris%getBlock('BetaAlpha') + tbbaa = eris%getBlock('BetaAlpha') allocVec(4)=.true. end if if(eris%hasSpinBlock('abab')) then - taabb = eris%getBlock('abab') + tabab = eris%getBlock('abab') allocVec(5)=.true. end if if(eris%hasSpinBlock('abba')) then - taabb = eris%getBlock('abba') + tabba = eris%getBlock('abba') allocVec(6)=.true. end if if(eris%hasSpinBlock('baab')) then - taabb = eris%getBlock('baab') + tbaab = eris%getBlock('baab') allocVec(7)=.true. end if if(eris%hasSpinBlock('baba')) then - taabb = eris%getBlock('baba') + tbaba = eris%getBlock('baba') allocVec(8)=.true. end if if(eris%hasSpinBlock('aaab')) then - taabb = eris%getBlock('aaab') + taaab = eris%getBlock('aaab') allocVec(9)=.true. end if if(eris%hasSpinBlock('aaba')) then - taabb = eris%getBlock('aaba') + taaba = eris%getBlock('aaba') allocVec(10)=.true. end if if(eris%hasSpinBlock('abaa')) then - taabb = eris%getBlock('abaa') + tabaa = eris%getBlock('abaa') allocVec(11)=.true. end if if(eris%hasSpinBlock('baaa')) then - taabb = eris%getBlock('baaa') + tbaaa = eris%getBlock('baaa') allocVec(12)=.true. end if if(eris%hasSpinBlock('bbba')) then - taabb = eris%getBlock('bbba') + tbbba = eris%getBlock('bbba') allocVec(13)=.true. end if if(eris%hasSpinBlock('bbab')) then - taabb = eris%getBlock('bbab') + tbbab = eris%getBlock('bbab') allocVec(14)=.true. end if if(eris%hasSpinBlock('babb')) then - taabb = eris%getBlock('babb') + tbabb = eris%getBlock('babb') allocVec(15)=.true. end if if(eris%hasSpinBlock('abbb')) then - taabb = eris%getBlock('abbb') + tabbb = eris%getBlock('abbb') allocVec(16)=.true. end if select case (mydim1) @@ -14556,16 +15414,16 @@ function mqc_eri_dimension_swap(eris,dim1,dim2) result(output) call alpha%init(nB1a,nB4a,nB3a,nB2a) do i = 1, nB2a do j = 1, nB4a - call alpha%tput(taaaa%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + call alpha%tput(taaaa%tat([0],[i,i],[0],[j,j]),[0],[j,j],[0],[i,i]) endDo endDo finalAllocVec(1)=.true. end if if(allocVec(2)) then - call beta%init(nB1b,nB4b,nB2b,nB2b) + call beta%init(nB1b,nB4b,nB3b,nB2b) do i = 1, nB2b do j = 1, nB4b - call beta%tput(tbbbb%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + call beta%tput(tbbbb%tat([0],[i,i],[0],[j,j]),[0],[j,j],[0],[i,i]) endDo endDo finalAllocVec(2)=.true. @@ -14574,7 +15432,7 @@ function mqc_eri_dimension_swap(eris,dim1,dim2) result(output) call abba%init(nB1a,nB4b,nB3b,nB2a) do i = 1, nB2a do j = 1, nB4b - call abba%tput(taabb%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + call abba%tput(taabb%tat([0],[i,i],[0],[j,j]),[0],[j,j],[0],[i,i]) endDo endDo finalAllocVec(6)=.true. @@ -14583,7 +15441,7 @@ function mqc_eri_dimension_swap(eris,dim1,dim2) result(output) call baab%init(nB1b,nB4a,nB3a,nB2b) do i = 1, nB2b do j = 1, nB4a - call baab%tput(tbbaa%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + call baab%tput(tbbaa%tat([0],[i,i],[0],[j,j]),[0],[j,j],[0],[i,i]) endDo endDo finalAllocVec(7)=.true. @@ -14592,7 +15450,7 @@ function mqc_eri_dimension_swap(eris,dim1,dim2) result(output) call abab%init(nB1a,nB4b,nB3a,nB2b) do i = 1, nB2b do j = 1, nB4b - call abab%tput(tabab%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + call abab%tput(tabab%tat([0],[i,i],[0],[j,j]),[0],[j,j],[0],[i,i]) endDo endDo finalAllocVec(5)=.true. @@ -14601,7 +15459,7 @@ function mqc_eri_dimension_swap(eris,dim1,dim2) result(output) call alphaBeta%init(nB1a,nB4a,nB3b,nB2b) do i = 1, nB2b do j = 1, nB4a - call alphaBeta%tput(tabba%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + call alphaBeta%tput(tabba%tat([0],[i,i],[0],[j,j]),[0],[j,j],[0],[i,i]) endDo endDo finalAllocVec(3)=.true. @@ -14610,7 +15468,7 @@ function mqc_eri_dimension_swap(eris,dim1,dim2) result(output) call betaAlpha%init(nB1b,nB4b,nB3a,nB2a) do i = 1, nB2a do j = 1, nB4b - call betaAlpha%tput(tbaab%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + call betaAlpha%tput(tbaab%tat([0],[i,i],[0],[j,j]),[0],[j,j],[0],[i,i]) endDo endDo finalAllocVec(4)=.true. @@ -14619,7 +15477,7 @@ function mqc_eri_dimension_swap(eris,dim1,dim2) result(output) call baba%init(nB1b,nB4a,nB3b,nB2a) do i = 1, nB2a do j = 1, nB4a - call baba%tput(tbaba%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + call baba%tput(tbaba%tat([0],[i,i],[0],[j,j]),[0],[j,j],[0],[i,i]) endDo endDo finalAllocVec(8)=.true. @@ -14628,7 +15486,7 @@ function mqc_eri_dimension_swap(eris,dim1,dim2) result(output) call abaa%init(nB1a,nB4b,nB3a,nB2a) do i = 1, nB2a do j = 1, nB4b - call abaa%tput(taaab%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + call abaa%tput(taaab%tat([0],[i,i],[0],[j,j]),[0],[j,j],[0],[i,i]) endDo endDo finalAllocVec(11)=.true. @@ -14637,7 +15495,7 @@ function mqc_eri_dimension_swap(eris,dim1,dim2) result(output) call aaba%init(nB1a,nB4a,nB3b,nB2a) do i = 1, nB2a do j = 1, nB4a - call aaba%tput(taaba%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + call aaba%tput(taaba%tat([0],[i,i],[0],[j,j]),[0],[j,j],[0],[i,i]) endDo endDo finalAllocVec(10)=.true. @@ -14646,7 +15504,7 @@ function mqc_eri_dimension_swap(eris,dim1,dim2) result(output) call aaab%init(nB1a,nB4a,nB3a,nB2b) do i = 1, nB2b do j = 1, nB4a - call aaab%tput(tabaa%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + call aaab%tput(tabaa%tat([0],[i,i],[0],[j,j]),[0],[j,j],[0],[i,i]) endDo endDo finalAllocVec(9)=.true. @@ -14655,7 +15513,7 @@ function mqc_eri_dimension_swap(eris,dim1,dim2) result(output) call baaa%init(nB1b,nB4a,nB3a,nB2a) do i = 1, nB2a do j = 1, nB4a - call baaa%tput(tbaaa%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + call baaa%tput(tbaaa%tat([0],[i,i],[0],[j,j]),[0],[j,j],[0],[i,i]) endDo endDo finalAllocVec(12)=.true. @@ -14664,7 +15522,7 @@ function mqc_eri_dimension_swap(eris,dim1,dim2) result(output) call babb%init(nB1b,nB4a,nB3b,nB2b) do i = 1, nB2b do j = 1, nB4a - call babb%tput(tbbba%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + call babb%tput(tbbba%tat([0],[i,i],[0],[j,j]),[0],[j,j],[0],[i,i]) endDo endDo finalAllocVec(15)=.true. @@ -14673,7 +15531,7 @@ function mqc_eri_dimension_swap(eris,dim1,dim2) result(output) call bbab%init(nB1b,nB4b,nB3a,nB2b) do i = 1, nB2b do j = 1, nB4b - call bbab%tput(tbbab%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + call bbab%tput(tbbab%tat([0],[i,i],[0],[j,j]),[0],[j,j],[0],[i,i]) endDo endDo finalAllocVec(14)=.true. @@ -14682,7 +15540,7 @@ function mqc_eri_dimension_swap(eris,dim1,dim2) result(output) call bbba%init(nB1b,nB4b,nB3b,nB2a) do i = 1, nB2a do j = 1, nB4b - call bbba%tput(tbabb%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + call bbba%tput(tbabb%tat([0],[i,i],[0],[j,j]),[0],[j,j],[0],[i,i]) endDo endDo finalAllocVec(13)=.true. @@ -14691,7 +15549,7 @@ function mqc_eri_dimension_swap(eris,dim1,dim2) result(output) call abbb%init(nB1a,nB4b,nB3b,nB2b) do i = 1, nB2b do j = 1, nB4b - call abbb%tput(tabbb%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) + call abbb%tput(tabbb%tat([0],[i,i],[0],[j,j]),[0],[j,j],[0],[i,i]) endDo endDo finalAllocVec(16)=.true. @@ -14917,9 +15775,9 @@ function mqc_eri_interaction(eris,label) result(output) if (eris%blockSize('alpha',4).ne.eris%blockSize('alpha',2).or.& eris%blockSize('beta',4).ne.eris%blockSize('beta',2)) then write(6,'(A,1x,I5,1x)4') 'Dim 4 alpha = ',eris%blockSize('alpha',4),& - 'Dim 2 alpha = ',eris%blockSize('alpha',2),& - 'Dim 4 beta = ',eris%blockSize('beta',4),& - 'Dim 2 beta = ',eris%blockSize('beta',2) + 'Dim 2 alpha = ',eris%blockSize('alpha',2),& + 'Dim 4 beta = ',eris%blockSize('beta',4),& + 'Dim 2 beta = ',eris%blockSize('beta',2) call mqc_error_a('Uncoformed dimensions in mqc_eri_interaction',& 6,'myLabel',myLabel) end if From 614b730c171b1bb3c7ca9295219ebee4988d8eb5 Mon Sep 17 00:00:00 2001 From: mm Date: Mon, 4 May 2026 17:19:08 -0400 Subject: [PATCH 26/37] Bug Fix: mqc_eri_eri_contraction --- src/mqc_est.F03 | 734 ++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 653 insertions(+), 81 deletions(-) diff --git a/src/mqc_est.F03 b/src/mqc_est.F03 index fda45c15..750b3b1a 100644 --- a/src/mqc_est.F03 +++ b/src/mqc_est.F03 @@ -321,7 +321,7 @@ Module MQC_EST procedure, public::blockSize => mqc_eris_dimension procedure, private::hasSpinBlock => mqc_eris_has_spinBlock !> \brief Return a spin block of MQC_TwoERIs object as an MQC rank-4 tensor - procedure, public:: getBlock => mqc_2eris_output_block + procedure, public::getBlock => mqc_2eris_output_block procedure, public::type => mqc_eris_array_type procedure, public::storType => mqc_eris_storage_type procedure, public::swap => mqc_eri_dimension_swap @@ -7640,10 +7640,6 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) type(mqc_r4tensor)::aaaa,bbbb,aabb,bbaa,abab,abba,baab,baba,& aaab,aaba,abaa,baaa,bbba,bbab,babb,abbb ! - write(*,*) 'Debug SUM:' - write(*,*) 'ERIA => ',ERIA%integraltype,ERIA%storagetype - write(*,*) 'ERIB => ',ERIB%integraltype,ERIB%storagetype - if(ERIA%integraltype.eq.'empty') then ERIOut = ERIB return @@ -13407,109 +13403,685 @@ function mqc_eri_eri_contraction(eris1,eris2,label) result(output) myLabel = 'doublebar' endIf ! - if (eris1%blockSize('alpha',1).ne.eris2%blockSize('alpha',1).or.& + if(myLabel.ne.'coulomb'.and.myLabel.ne.'exchange'.and.myLabel.ne.'doublebar') & + call mqc_error_a('Unrecognized 2ERI integral interaction specified',& + 6,'myLabel',myLabel) + if(myLabel.ne.'exchange'.and.& + (eris1%blockSize('alpha',1).ne.eris2%blockSize('alpha',1).or.& eris1%blockSize('alpha',2).ne.eris2%blockSize('alpha',2).or.& eris1%blockSize('alpha',3).ne.eris2%blockSize('alpha',3).or.& - eris1%blockSize('alpha',4).ne.eris2%blockSize('alpha',4))& + eris1%blockSize('alpha',4).ne.eris2%blockSize('alpha',4)))& call mqc_error_i('2ERIs not correctly dimensioned in mqc_eri_eri_contraction',6,& 'dim1',eris1%blockSize('alpha',1)-eris2%blockSize('alpha',1),& 'dim2',eris1%blockSize('alpha',2)-eris2%blockSize('alpha',2),& 'dim3',eris1%blockSize('alpha',3)-eris2%blockSize('alpha',3),& 'dim4',eris1%blockSize('alpha',4)-eris2%blockSize('alpha',4)) - - select case (myLabel) - case ('coulomb') - temp = eris1 - case ('exchange') - temp = mqc_eri_interaction(eris1,'exchange') - case ('doublebar') - temp = mqc_eri_interaction(eris1,'doublebar') - case default - call mqc_error_a('Unrecognized 2ERI integral interaction specified',& - 6,'myLabel',myLabel) - end select - + if(myLabel.ne.'coulomb'.and.& + (eris1%blockSize('alpha',1).ne.eris2%blockSize('alpha',1).or.& + eris1%blockSize('alpha',4).ne.eris2%blockSize('alpha',2).or.& + eris1%blockSize('alpha',3).ne.eris2%blockSize('alpha',3).or.& + eris1%blockSize('alpha',2).ne.eris2%blockSize('alpha',4)))& + call mqc_error_i('2ERIs not correctly dimensioned in mqc_eri_eri_contraction',6,& + 'dim1',eris1%blockSize('alpha',1)-eris2%blockSize('alpha',1),& + 'dim2',eris1%blockSize('alpha',4)-eris2%blockSize('alpha',2),& + 'dim3',eris1%blockSize('alpha',3)-eris2%blockSize('alpha',3),& + 'dim4',eris1%blockSize('alpha',2)-eris2%blockSize('alpha',4)) + + !select case (myLabel) + !case ('coulomb') + ! temp = eris1 + !case ('exchange') + ! temp = mqc_eri_interaction(eris1,'exchange') + !case ('doublebar') + ! temp = mqc_eri_interaction(eris1,'doublebar') + !case default + ! call mqc_error_a('Unrecognized 2ERI integral interaction specified',& + ! 6,'myLabel',myLabel) + !end select + + if(myLabel.ne.'coulomb') temp = eris1%swap(2,4) output = 0.0 + if(eris1%storType().eq.'empty'.or.eris2%storType().eq.'empty') return + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('aaaa'),eris2%getBlock('aaaa')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('aaaa'),eris2%getBlock('aaaa')) select case (eris1%type()) case ('space','regular') - output = output + contraction(temp%getBlock('aaaa'),eris2%getBlock('aaaa')) select case (eris2%type()) case ('space','regular') - if(myLabel.eq.'coulomb') output = 4*output - if(myLabel.eq.'exchange') output = 2*output - if(myLabel.eq.'doublebar') & - output = 2*output + 2*contraction(eris1%getBlock('aaaa'),eris2%getBlock('aaaa')) - case ('spin') - output = output + contraction(temp%getBlock('aaaa'),eris2%getBlock('bbbb')) - if(myLabel.ne.'exchange') then - output = output + contraction(eris1%getBlock('aaaa'),eris2%getBlock('aabb')) - output = output + contraction(eris1%getBlock('aaaa'),eris2%getBlock('bbaa')) + if(eris1%storType().eq.eris2%storType()) then + if((eris1%storType().eq.'coulomb'.or.eris1%storType().eq.'symm').or.eris1%storType().eq.'exchange') then + if(myLabel.eq.'coulomb') output = 4*output + if(myLabel.eq.'exchange') output = 2*output + if(myLabel.eq.'doublebar') & + output = 2*output + 2*contraction(eris1%getBlock('aaaa'),eris2%getBlock('aaaa')) + else if(eris1%storType().eq.'inverted') then + if(myLabel.eq.'coulomb'.or.myLabel.eq.'exchange') output = 4*output + if(myLabel.eq.'doublebar') & + output = 2*output + 2*contraction(eris1%getBlock('aaaa'),eris2%getBlock('aaaa')) + end if + else if(eris1%storType().eq.'coulomb'.or.eris2%storType().eq.'coulomb'.or. & + eris1%storType().eq.'symm'.or.eris2%storType().eq.'symm') then + if(eris1%storType().eq.'exchange'.or.eris2%storType().eq.'exchange') then + if(myLabel.eq.'coulomb') output = 2*output + if(myLabel.eq.'exchange') output = 4*output + if(myLabel.eq.'doublebar') & + output = 2*output - 2*contraction(temp%getBlock('aaaa'),eris2%getBlock('aaaa')) + else if(eris1%storType().eq.'inverted'.or.eris2%storType().eq.'inverted') then + output = 2*output + else + call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & + 'ERIs1%stortype', ERIs1%stortype(), 'ERIs2%stortype', ERIs2%stortype()) + end if + else if(eris1%storType().eq.'exchange'.or.eris2%storType().eq.'exchange') then + if(eris1%storType().eq.'inverted'.or.eris2%storType().eq.'inverted') then + output = 2*output + else + call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & + 'ERIs1%stortype', ERIs1%stortype(), 'ERIs2%stortype', ERIs2%stortype()) + end if + else + call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & + 'ERIs1%stortype', ERIs1%stortype(), 'ERIs2%stortype', ERIs2%stortype()) end if + case ('spin') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('aaaa'),eris2%getBlock('bbbb')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('aaaa'),eris2%getBlock('bbbb')) + select case(eris1%storType()) + case ('coulomb','sym') + select case(eris2%storType()) + case ('sym') + if(myLabel.ne.'exchange') & + output = output + 2*contraction(eris1%getBlock('aaaa'),eris2%getBlock('aabb')) + case ('coulomb') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('aaaa'),eris2%getBlock('aabb')) & + + contraction(eris1%getBlock('aaaa'),eris2%getBlock('bbaa')) + case ('exchange') + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('aaaa'),eris2%getBlock('abba')) & + - contraction(temp%getBlock('aaaa'),eris2%getBlock('baab')) + case ('inverted') + ! Done + case ('doublebar') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('aaaa'),eris2%getBlock('aabb')) & + + contraction(eris1%getBlock('aaaa'),eris2%getBlock('bbaa')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('aaaa'),eris2%getBlock('abba')) & + - contraction(temp%getBlock('aaaa'),eris2%getBlock('baab')) + case ('ms') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('aaaa'),eris2%getBlock('aabb')) & + + contraction(eris1%getBlock('aaaa'),eris2%getBlock('bbaa')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('aaaa'),eris2%getBlock('abba')) & + - contraction(temp%getBlock('aaaa'),eris2%getBlock('baab')) + case default + call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & + 'ERIs2%stortype', ERIs2%stortype()) + end select + case ('exchange') + select case(eris2%storType()) + case ('symm') + if(myLabel.ne.'coulomb') & + output = output - 2*contraction(temp%getBlock('aaaa'),eris2%getBlock('aabb')) + case ('coulomb') + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('aaaa'),eris2%getBlock('aabb')) & + - contraction(temp%getBlock('aaaa'),eris2%getBlock('bbaa')) + case ('exchange') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('aaaa'),eris2%getBlock('abba')) & + + contraction(eris1%getBlock('aaaa'),eris2%getBlock('baab')) + case ('inverted') + ! Done + case ('doublebar') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('aaaa'),eris2%getBlock('abba')) & + + contraction(eris1%getBlock('aaaa'),eris2%getBlock('baab')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('aaaa'),eris2%getBlock('aabb')) & + - contraction(temp%getBlock('aaaa'),eris2%getBlock('bbaa')) + case ('ms') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('aaaa'),eris2%getBlock('abba')) & + + contraction(eris1%getBlock('aaaa'),eris2%getBlock('baab')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('aaaa'),eris2%getBlock('aabb')) & + - contraction(temp%getBlock('aaaa'),eris2%getBlock('bbaa')) + case default + call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & + 'ERIs2%stortype', ERIs2%stortype()) + end select + case ('inverted') + select case(eris2%storType()) + case ('coulomb','symm','exchange','doublebar') + ! Done + case ('inverted') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('aaaa'),eris2%getBlock('abab')) & + + contraction(eris1%getBlock('aaaa'),eris2%getBlock('baba')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('aaaa'),eris2%getBlock('abab')) & + - contraction(temp%getBlock('aaaa'),eris2%getBlock('baba')) + case ('ms') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('aaaa'),eris2%getBlock('abab')) & + + contraction(eris1%getBlock('aaaa'),eris2%getBlock('baba')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('aaaa'),eris2%getBlock('abab')) & + - contraction(temp%getBlock('aaaa'),eris2%getBlock('baba')) + case default + call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & + 'ERIs2%stortype', ERIs2%stortype()) + end select + case default + call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & + 'ERIs1%stortype', ERIs1%stortype()) + end select case ('general') - output = output + contraction(temp%getBlock('aaaa'),eris2%getBlock('bbbb')) - if(myLabel.ne.'exchange') then - output = output + contraction(temp%getBlock('aaaa'),eris2%getBlock('aabb')) - output = output + contraction(temp%getBlock('aaaa'),eris2%getBlock('bbaa')) - end if - if(myLabel.ne.'coulomb') then - output = output + contraction(eris1%getBlock('abba'),eris2%getBlock('abba')) - output = output + contraction(eris1%getBlock('abba'),eris2%getBlock('baab')) - end if + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('aaaa'),eris2%getBlock('bbbb')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('aaaa'),eris2%getBlock('bbbb')) + select case(eris1%storType()) + case ('coulomb','symm') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('aaaa'),eris2%getBlock('aabb')) & + + contraction(eris1%getBlock('aaaa'),eris2%getBlock('bbaa')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('aaaa'),eris2%getBlock('abba')) & + - contraction(temp%getBlock('aaaa'),eris2%getBlock('baab')) + case ('exchange') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('aaaa'),eris2%getBlock('abba')) & + + contraction(eris1%getBlock('aaaa'),eris2%getBlock('baab')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('aaaa'),eris2%getBlock('aabb')) & + - contraction(temp%getBlock('aaaa'),eris2%getBlock('bbaa')) + case ('inverted') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('aaaa'),eris2%getBlock('abab')) & + + contraction(eris1%getBlock('aaaa'),eris2%getBlock('baba')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('aaaa'),eris2%getBlock('abab')) & + - contraction(temp%getBlock('aaaa'),eris2%getBlock('baba')) + case default + call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & + 'ERIs1%stortype', ERIs1%stortype()) + end select + case default + call mqc_error_A('Unknown or not implemented twoERI type in mqc_eri_eri_contraction', 6, & + 'ERIs2%type', ERIs2%type()) end select case ('spin') - output = output + contraction(temp%getBlock('aaaa'),eris2%getBlock('aaaa')) + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('bbbb'),eris2%getBlock('bbbb')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('bbbb'),eris2%getBlock('bbbb')) select case (eris2%type()) case ('space','regular') - output = output + contraction(temp%getBlock('bbbb'),eris2%getBlock('aaaa')) - if(myLabel.ne.'exchange') then - output = output + contraction(temp%getBlock('aabb'),eris2%getBlock('aaaa')) - output = output + contraction(temp%getBlock('bbaa'),eris2%getBlock('aaaa')) - end if + select case(eris2%storType()) + case ('coulomb','symm') + select case(eris1%storType()) + case ('coulomb') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('aabb'),eris2%getBlock('aaaa')) & + + contraction(eris1%getBlock('bbaa'),eris2%getBlock('aaaa')) + case ('exchange') + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('abba'),eris2%getBlock('aaaa')) & + - contraction(temp%getBlock('baab'),eris2%getBlock('aaaa')) + case ('inverted') + ! Done + case ('doublebar') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('aabb'),eris2%getBlock('aaaa')) & + + contraction(eris1%getBlock('bbaa'),eris2%getBlock('aaaa')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('abba'),eris2%getBlock('aaaa')) & + - contraction(temp%getBlock('baab'),eris2%getBlock('aaaa')) + case ('ms') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('aabb'),eris2%getBlock('aaaa')) & + + contraction(eris1%getBlock('bbaa'),eris2%getBlock('aaaa')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('abba'),eris2%getBlock('aaaa')) & + - contraction(temp%getBlock('baab'),eris2%getBlock('aaaa')) + case default + call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & + 'ERIs1%stortype', ERIs1%stortype()) + end select + case ('exchange') + select case(eris1%storType()) + case ('coulomb','symm') + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('aabb'),eris2%getBlock('aaaa')) & + - contraction(temp%getBlock('bbaa'),eris2%getBlock('aaaa')) + case ('exchange') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('aaaa'),eris2%getBlock('abba''aaaa')) & + + contraction(eris1%getBlock('aaaa'),eris2%getBlock('baab''aaaa')) + case ('inverted') + ! Done + case ('doublebar') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('abba'),eris2%getBlock('aaaa')) & + + contraction(eris1%getBlock('baab'),eris2%getBlock('aaaa')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('aabb'),eris2%getBlock('aaaa')) & + - contraction(temp%getBlock('bbaa'),eris2%getBlock('aaaa')) + case ('ms') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('abba'),eris2%getBlock('aaaa')) & + + contraction(eris1%getBlock('baab'),eris2%getBlock('aaaa')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('aabb'),eris2%getBlock('aaaa')) & + - contraction(temp%getBlock('bbaa'),eris2%getBlock('aaaa')) + case default + call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & + 'ERIs1%stortype', ERIs1%stortype()) + end select + case ('inverted') + select case(eris1%storType()) + case ('coulomb','symm','exchange','doublebar') + ! Done + case ('inverted') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('abab'),eris2%getBlock('aaaa')) & + + contraction(eris1%getBlock('baba'),eris2%getBlock('aaaa')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('abab'),eris2%getBlock('aaaa')) & + - contraction(temp%getBlock('baba'),eris2%getBlock('aaaa')) + case ('ms') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('abab'),eris2%getBlock('aaaa')) & + + contraction(eris1%getBlock('baba'),eris2%getBlock('aaaa')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('abab'),eris2%getBlock('aaaa')) & + - contraction(temp%getBlock('baba'),eris2%getBlock('aaaa')) + case default + call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & + 'ERIs1%stortype', ERIs1%stortype()) + end select + case default + call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & + 'ERIs2%stortype', ERIs2%stortype()) + end select case ('spin') - output = output + contraction(temp%getBlock('bbbb'),eris2%getBlock('bbbb')) - if(myLabel.ne.'exchange') then - output = output + contraction(temp%getBlock('aabb'),eris2%getBlock('aabb')) - output = output + contraction(temp%getBlock('bbaa'),eris2%getBlock('bbaa')) - end if + select case(eris1%storType()) + case ('coulomb','symm') + select case(eris2%storType()) + case ('coulomb','symm') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('aabb'),eris2%getBlock('aabb')) & + + contraction(eris1%getBlock('bbaa'),eris2%getBlock('bbaa')) + case ('exchange') + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('abba'),eris2%getBlock('abba')) & + - contraction(temp%getBlock('baab'),eris2%getBlock('baab')) + case ('inverted') + ! Done + case ('doublebar') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('aabb'),eris2%getBlock('aabb')) & + + contraction(eris1%getBlock('bbaa'),eris2%getBlock('bbaa')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('abba'),eris2%getBlock('abba')) & + - contraction(temp%getBlock('baab'),eris2%getBlock('baab')) + case ('ms') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('aabb'),eris2%getBlock('aabb')) & + + contraction(eris1%getBlock('bbaa'),eris2%getBlock('bbaa')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('abba'),eris2%getBlock('abba')) & + - contraction(temp%getBlock('baab'),eris2%getBlock('baab')) + case default + call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & + 'ERIs2%stortype', ERIs2%stortype()) + end select + case ('exchange') + select case(eris2%storType()) + case ('coulomb','symm') + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('aabb'),eris2%getBlock('aabb')) & + - contraction(temp%getBlock('bbaa'),eris2%getBlock('bbaa')) + case ('exchange') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('abba'),eris2%getBlock('abba')) & + + contraction(eris1%getBlock('baab'),eris2%getBlock('baab')) + case ('inverted') + ! Done + case ('doublebar') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('abba'),eris2%getBlock('abba')) & + + contraction(eris1%getBlock('baab'),eris2%getBlock('baab')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('aabb'),eris2%getBlock('aabb')) & + - contraction(temp%getBlock('bbaa'),eris2%getBlock('bbaa')) + case ('ms') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('abba'),eris2%getBlock('abba')) & + + contraction(eris1%getBlock('baab'),eris2%getBlock('baab')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('aabb'),eris2%getBlock('aabb')) & + - contraction(temp%getBlock('bbaa'),eris2%getBlock('bbaa')) + case default + call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & + 'ERIs2%stortype', ERIs2%stortype()) + end select + case ('inverted') + select case(eris2%storType()) + case ('coulomb','symm') + ! Done + case ('exchange') + ! Done + case ('inverted') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('abab'),eris2%getBlock('abab')) & + + contraction(eris1%getBlock('baba'),eris2%getBlock('baba')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('abab'),eris2%getBlock('abab')) & + - contraction(temp%getBlock('baba'),eris2%getBlock('baba')) + case ('doublebar') + ! Done + case ('ms') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('abab'),eris2%getBlock('abab')) & + + contraction(eris1%getBlock('baba'),eris2%getBlock('baba')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('abab'),eris2%getBlock('abab')) & + - contraction(temp%getBlock('baba'),eris2%getBlock('baba')) + case default + call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & + 'ERIs2%stortype', ERIs2%stortype()) + end select + case ('doublebar') + select case(eris2%storType()) + case ('coulomb','symm') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('aabb'),eris2%getBlock('aabb')) & + + contraction(eris1%getBlock('bbaa'),eris2%getBlock('bbaa')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('aabb'),eris2%getBlock('aabb')) & + - contraction(temp%getBlock('bbaa'),eris2%getBlock('bbaa')) + case ('exchange') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('abba'),eris2%getBlock('abba')) & + + contraction(eris1%getBlock('baab'),eris2%getBlock('baab')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('abba'),eris2%getBlock('abba')) & + - contraction(temp%getBlock('baab'),eris2%getBlock('baab')) + case ('inverted') + ! Done + case ('doublebar') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('abba'),eris2%getBlock('abba')) & + + contraction(eris1%getBlock('baab'),eris2%getBlock('baab')) & + + contraction(eris1%getBlock('aabb'),eris2%getBlock('aabb')) & + + contraction(eris1%getBlock('bbaa'),eris2%getBlock('bbaa')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('aabb'),eris2%getBlock('aabb')) & + - contraction(temp%getBlock('bbaa'),eris2%getBlock('bbaa')) & + - contraction(temp%getBlock('abba'),eris2%getBlock('abba')) & + - contraction(temp%getBlock('baab'),eris2%getBlock('baab')) + case ('ms') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('abba'),eris2%getBlock('abba')) & + + contraction(eris1%getBlock('baab'),eris2%getBlock('baab')) & + + contraction(eris1%getBlock('aabb'),eris2%getBlock('aabb')) & + + contraction(eris1%getBlock('bbaa'),eris2%getBlock('bbaa')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('aabb'),eris2%getBlock('aabb')) & + - contraction(temp%getBlock('bbaa'),eris2%getBlock('bbaa')) & + - contraction(temp%getBlock('abba'),eris2%getBlock('abba')) & + - contraction(temp%getBlock('baab'),eris2%getBlock('baab')) + case default + call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & + 'ERIs2%stortype', ERIs2%stortype()) + end select + case ('ms') + select case(eris2%storType()) + case ('coulomb','symm') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('aabb'),eris2%getBlock('aabb')) & + + contraction(eris1%getBlock('bbaa'),eris2%getBlock('bbaa')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('aabb'),eris2%getBlock('aabb')) & + - contraction(temp%getBlock('bbaa'),eris2%getBlock('bbaa')) + case ('exchange') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('abba'),eris2%getBlock('abba')) & + + contraction(eris1%getBlock('baab'),eris2%getBlock('baab')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('abba'),eris2%getBlock('abba')) & + - contraction(temp%getBlock('baab'),eris2%getBlock('baab')) + case ('inverted') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('abab'),eris2%getBlock('abab')) & + + contraction(eris1%getBlock('baba'),eris2%getBlock('baba')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('abab'),eris2%getBlock('abab')) & + - contraction(temp%getBlock('baba'),eris2%getBlock('baba')) + case ('doublebar') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('abba'),eris2%getBlock('abba')) & + + contraction(eris1%getBlock('baab'),eris2%getBlock('baab')) & + + contraction(eris1%getBlock('aabb'),eris2%getBlock('aabb')) & + + contraction(eris1%getBlock('bbaa'),eris2%getBlock('bbaa')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('aabb'),eris2%getBlock('aabb')) & + - contraction(temp%getBlock('bbaa'),eris2%getBlock('bbaa')) & + - contraction(temp%getBlock('abba'),eris2%getBlock('abba')) & + - contraction(temp%getBlock('baab'),eris2%getBlock('baab')) + case ('ms') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('abba'),eris2%getBlock('abba')) & + + contraction(eris1%getBlock('baab'),eris2%getBlock('baab')) & + + contraction(eris1%getBlock('aabb'),eris2%getBlock('aabb')) & + + contraction(eris1%getBlock('bbaa'),eris2%getBlock('bbaa')) & + + contraction(eris1%getBlock('abab'),eris2%getBlock('abab')) & + + contraction(eris1%getBlock('baba'),eris2%getBlock('baba')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('aabb'),eris2%getBlock('aabb')) & + - contraction(temp%getBlock('bbaa'),eris2%getBlock('bbaa')) & + - contraction(temp%getBlock('abba'),eris2%getBlock('abba')) & + - contraction(temp%getBlock('baab'),eris2%getBlock('baab')) & + - contraction(temp%getBlock('abab'),eris2%getBlock('abab')) & + - contraction(temp%getBlock('baba'),eris2%getBlock('baba')) + case default + call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & + 'ERIs2%stortype', ERIs2%stortype()) + end select + case default + call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & + 'ERIs1%stortype', ERIs1%stortype()) + end select case ('general') - output = output + contraction(temp%getBlock('bbbb'),eris2%getBlock('bbbb')) - if(myLabel.ne.'exchange') then - output = output + contraction(temp%getBlock('aabb'),eris2%getBlock('aabb')) - output = output + contraction(temp%getBlock('bbaa'),eris2%getBlock('bbaa')) - end if - if(myLabel.ne.'coulomb') then - output = output + contraction(temp%getBlock('abba'),eris2%getBlock('abba')) - output = output + contraction(temp%getBlock('baab'),eris2%getBlock('baab')) - end if + select case(eris1%storType()) + case ('coulomb','symm') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('aabb'),eris2%getBlock('aabb')) & + + contraction(eris1%getBlock('bbaa'),eris2%getBlock('bbaa')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('abba'),eris2%getBlock('abba')) & + - contraction(temp%getBlock('baab'),eris2%getBlock('baab')) + case ('exchange') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('abba'),eris2%getBlock('abba')) & + + contraction(eris1%getBlock('baab'),eris2%getBlock('baab')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('aabb'),eris2%getBlock('aabb')) & + - contraction(temp%getBlock('bbaa'),eris2%getBlock('bbaa')) + case ('inverted') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('abab'),eris2%getBlock('abab')) & + + contraction(eris1%getBlock('baba'),eris2%getBlock('baba')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('abab'),eris2%getBlock('abab')) & + - contraction(temp%getBlock('baba'),eris2%getBlock('baba')) + case ('doublebar') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('aabb'),eris2%getBlock('aabb')) & + + contraction(eris1%getBlock('bbaa'),eris2%getBlock('bbaa')) & + + contraction(eris1%getBlock('abba'),eris2%getBlock('abba')) & + + contraction(eris1%getBlock('baab'),eris2%getBlock('baab')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('abba'),eris2%getBlock('abba')) & + - contraction(temp%getBlock('baab'),eris2%getBlock('baab')) & + - contraction(temp%getBlock('aabb'),eris2%getBlock('aabb')) & + - contraction(temp%getBlock('bbaa'),eris2%getBlock('bbaa')) + case ('ms') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('aabb'),eris2%getBlock('aabb')) & + + contraction(eris1%getBlock('bbaa'),eris2%getBlock('bbaa')) & + + contraction(eris1%getBlock('abba'),eris2%getBlock('abba')) & + + contraction(eris1%getBlock('baab'),eris2%getBlock('baab')) & + + contraction(eris1%getBlock('abab'),eris2%getBlock('abab')) & + + contraction(eris1%getBlock('baba'),eris2%getBlock('baba')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('abba'),eris2%getBlock('abba')) & + - contraction(temp%getBlock('baab'),eris2%getBlock('baab')) & + - contraction(temp%getBlock('aabb'),eris2%getBlock('aabb')) & + - contraction(temp%getBlock('bbaa'),eris2%getBlock('bbaa')) & + - contraction(temp%getBlock('abab'),eris2%getBlock('abab')) & + - contraction(temp%getBlock('baba'),eris2%getBlock('baba')) + case default + call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & + 'ERIs1%stortype', ERIs1%stortype()) + end select + case default + call mqc_error_A('Unknown or not implemented twoERI type in mqc_eri_eri_contraction', 6, & + 'ERIs2%type', ERIs2%type()) end select case ('general') - output = output + contraction(temp%getBlock('aaaa'),eris2%getBlock('aaaa')) + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('bbbb'),eris2%getBlock('bbbb')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('bbbb'),eris2%getBlock('bbbb')) select case (eris2%type()) case ('space','regular') - output = output + contraction(temp%getBlock('bbbb'),eris2%getBlock('aaaa')) - output = output + contraction(temp%getBlock('aabb'),eris2%getBlock('aaaa')) - output = output + contraction(temp%getBlock('bbaa'),eris2%getBlock('aaaa')) + select case(eris2%storType()) + case ('coulomb','symm') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('aabb'),eris2%getBlock('aaaa')) & + + contraction(eris1%getBlock('bbaa'),eris2%getBlock('aaaa')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('abba'),eris2%getBlock('aaaa')) & + - contraction(temp%getBlock('baab'),eris2%getBlock('aaaa')) + case ('exchange') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('abba'),eris2%getBlock('aaaa')) & + + contraction(eris1%getBlock('baab'),eris2%getBlock('aaaa')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('aabb'),eris2%getBlock('aaaa')) & + - contraction(temp%getBlock('bbaa'),eris2%getBlock('aaaa')) + case ('inverted') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('abab'),eris2%getBlock('aaaa')) & + + contraction(eris1%getBlock('baba'),eris2%getBlock('aaaa')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('abab'),eris2%getBlock('aaaa')) & + - contraction(temp%getBlock('baba'),eris2%getBlock('aaaa')) + case default + call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & + 'ERIs2%stortype', ERIs2%stortype()) + end select case ('spin') - output = output + contraction(temp%getBlock('bbbb'),eris2%getBlock('bbbb')) - output = output + contraction(temp%getBlock('aabb'),eris2%getBlock('aabb')) - output = output + contraction(temp%getBlock('bbaa'),eris2%getBlock('bbaa')) + select case(eris2%storType()) + case ('coulomb','symm') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('aabb'),eris2%getBlock('aabb')) & + + contraction(eris1%getBlock('bbaa'),eris2%getBlock('bbaa')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('abba'),eris2%getBlock('abba')) & + - contraction(temp%getBlock('baab'),eris2%getBlock('baab')) + case ('exchange') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('abba'),eris2%getBlock('abba')) & + + contraction(eris1%getBlock('baab'),eris2%getBlock('baab')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('aabb'),eris2%getBlock('aabb')) & + - contraction(temp%getBlock('bbaa'),eris2%getBlock('bbaa')) + case ('inverted') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('abab'),eris2%getBlock('abab')) & + + contraction(eris1%getBlock('baba'),eris2%getBlock('baba')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('abab'),eris2%getBlock('abab')) & + - contraction(temp%getBlock('baba'),eris2%getBlock('baba')) + case ('doublebar') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('aabb'),eris2%getBlock('aabb')) & + + contraction(eris1%getBlock('bbaa'),eris2%getBlock('bbaa')) & + + contraction(eris1%getBlock('abba'),eris2%getBlock('abba')) & + + contraction(eris1%getBlock('baab'),eris2%getBlock('baab')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('abba'),eris2%getBlock('abba')) & + - contraction(temp%getBlock('baab'),eris2%getBlock('baab')) & + - contraction(temp%getBlock('aabb'),eris2%getBlock('aabb')) & + - contraction(temp%getBlock('bbaa'),eris2%getBlock('bbaa')) + case ('ms') + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('aabb'),eris2%getBlock('aabb')) & + + contraction(eris1%getBlock('bbaa'),eris2%getBlock('bbaa')) & + + contraction(eris1%getBlock('abba'),eris2%getBlock('abba')) & + + contraction(eris1%getBlock('baab'),eris2%getBlock('baab')) & + + contraction(eris1%getBlock('abab'),eris2%getBlock('abab')) & + + contraction(eris1%getBlock('baba'),eris2%getBlock('baba')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('abba'),eris2%getBlock('abba')) & + - contraction(temp%getBlock('baab'),eris2%getBlock('baab')) & + - contraction(temp%getBlock('aabb'),eris2%getBlock('aabb')) & + - contraction(temp%getBlock('bbaa'),eris2%getBlock('bbaa')) & + - contraction(temp%getBlock('abab'),eris2%getBlock('abab')) & + - contraction(temp%getBlock('baba'),eris2%getBlock('baba')) + case default + call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & + 'ERIs2%stortype', ERIs2%stortype()) + end select case ('general') - output = output + contraction(temp%getBlock('bbbb'),eris2%getBlock('bbbb')) - output = output + contraction(temp%getBlock('aabb'),eris2%getBlock('aabb')) - output = output + contraction(temp%getBlock('bbaa'),eris2%getBlock('bbaa')) - output = output + contraction(temp%getBlock('baab'),eris2%getBlock('baab')) - output = output + contraction(temp%getBlock('abba'),eris2%getBlock('abba')) - output = output + contraction(temp%getBlock('baba'),eris2%getBlock('baba')) - output = output + contraction(temp%getBlock('abab'),eris2%getBlock('abab')) - output = output + contraction(temp%getBlock('aaab'),eris2%getBlock('aaab')) - output = output + contraction(temp%getBlock('aaba'),eris2%getBlock('aaba')) - output = output + contraction(temp%getBlock('abaa'),eris2%getBlock('abaa')) - output = output + contraction(temp%getBlock('baaa'),eris2%getBlock('baaa')) - output = output + contraction(temp%getBlock('bbba'),eris2%getBlock('bbba')) - output = output + contraction(temp%getBlock('bbab'),eris2%getBlock('bbab')) - output = output + contraction(temp%getBlock('babb'),eris2%getBlock('babb')) - output = output + contraction(temp%getBlock('abbb'),eris2%getBlock('abbb')) + if(myLabel.ne.'exchange') & + output = output + contraction(eris1%getBlock('aabb'),eris2%getBlock('aabb'))& + + contraction(eris1%getBlock('bbaa'),eris2%getBlock('bbaa'))& + + contraction(eris1%getBlock('baab'),eris2%getBlock('baab'))& + + contraction(eris1%getBlock('abba'),eris2%getBlock('abba'))& + + contraction(eris1%getBlock('baba'),eris2%getBlock('baba'))& + + contraction(eris1%getBlock('abab'),eris2%getBlock('abab'))& + + contraction(eris1%getBlock('aaab'),eris2%getBlock('aaab'))& + + contraction(eris1%getBlock('aaba'),eris2%getBlock('aaba'))& + + contraction(eris1%getBlock('abaa'),eris2%getBlock('abaa'))& + + contraction(eris1%getBlock('baaa'),eris2%getBlock('baaa'))& + + contraction(eris1%getBlock('bbba'),eris2%getBlock('bbba'))& + + contraction(eris1%getBlock('bbab'),eris2%getBlock('bbab'))& + + contraction(eris1%getBlock('babb'),eris2%getBlock('babb'))& + + contraction(eris1%getBlock('abbb'),eris2%getBlock('abbb')) + if(myLabel.ne.'coulomb') & + output = output - contraction(temp%getBlock('aabb'),eris2%getBlock('aabb'))& + - contraction(temp%getBlock('bbaa'),eris2%getBlock('bbaa'))& + - contraction(temp%getBlock('baab'),eris2%getBlock('baab'))& + - contraction(temp%getBlock('abba'),eris2%getBlock('abba'))& + - contraction(temp%getBlock('baba'),eris2%getBlock('baba'))& + - contraction(temp%getBlock('abab'),eris2%getBlock('abab'))& + - contraction(temp%getBlock('aaab'),eris2%getBlock('aaab'))& + - contraction(temp%getBlock('aaba'),eris2%getBlock('aaba'))& + - contraction(temp%getBlock('abaa'),eris2%getBlock('abaa'))& + - contraction(temp%getBlock('baaa'),eris2%getBlock('baaa'))& + - contraction(temp%getBlock('bbba'),eris2%getBlock('bbba'))& + - contraction(temp%getBlock('bbab'),eris2%getBlock('bbab'))& + - contraction(temp%getBlock('babb'),eris2%getBlock('babb'))& + - contraction(temp%getBlock('abbb'),eris2%getBlock('abbb')) + case default + call mqc_error_A('Unknown or not implemented twoERI type in mqc_eri_eri_contraction', 6, & + 'ERIs2%type', ERIs2%type()) end select + case default + call mqc_error_A('Unknown or not implemented twoERI type in mqc_eri_eri_contraction', 6, & + 'ERIs1%type', ERIs1%type()) end select ! end function mqc_eri_eri_contraction From 758fb3483454cdf3429de76c556542ed588fe715 Mon Sep 17 00:00:00 2001 From: mm Date: Mon, 4 May 2026 23:36:58 -0400 Subject: [PATCH 27/37] Bugfix ERI SUM and DIFFERENCE --- src/mqc_est.F03 | 926 ++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 865 insertions(+), 61 deletions(-) diff --git a/src/mqc_est.F03 b/src/mqc_est.F03 index 750b3b1a..0b2725f7 100644 --- a/src/mqc_est.F03 +++ b/src/mqc_est.F03 @@ -8092,12 +8092,6 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & 'ERIA%storagetype', ERIA%stortype() ) end select - aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') - bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('aaaa') - aabb = ERIA%getBlock('aabb')+ERIB%getBlock('aaaa') - bbaa = ERIA%getBlock('bbaa')+ERIB%getBlock('aaaa') - call mqc_twoeris_allocate(ERIOut,'full','spin',aaaa,bbbb,& - aabb,bbaa) case('spin') select case(ERIA%storType()) case('coulomb') @@ -8143,7 +8137,7 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) abba = ERIB%getBlock('abba') baab = ERIB%getBlock('baab') abab = ERIB%getBlock('abab') - baba = ERIA%getBlock('baba') + baba = ERIB%getBlock('baba') call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab,abab=abab,baba=baba) case default @@ -8372,12 +8366,6 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & 'ERIA%storagetype', ERIA%stortype() ) end select - aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') - bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') - aabb = ERIA%getBlock('aabb')+ERIB%getBlock('aabb') - bbaa = ERIA%getBlock('bbaa')+ERIB%getBlock('bbaa') - call mqc_twoeris_allocate(ERIOut,'full','spin',aaaa,bbbb,& - aabb,bbaa) case('general') select case(ERIA%storType()) case('coulomb') @@ -8989,28 +8977,277 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) type(mqc_r4tensor)::aaaa,bbbb,aabb,bbaa,abab,abba,baab,baba,& aaab,aaba,abaa,baaa,bbba,bbab,babb,abbb ! + if(ERIA%integraltype.eq.'empty') then + ERIOut = (-1)*ERIB + return + elseif(ERIB%integraltype.eq.'empty') then + ERIOut = ERIA + return + end if select case(ERIA%integraltype) case('space') select case (ERIB%integraltype) case('space') - aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') - call mqc_twoeris_allocate(ERIOut,'full','space',aaaa) + select case(ERIA%storType()) + case('coulomb') + select case(ERIB%storType()) + case('coulomb') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + call mqc_twoeris_allocate(ERIOut,'coulomb','space',aaaa) + case('exchange') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + aabb = ERIA%getBlock('aaaa') + abba = (-1)*ERIB%getBlock('aaaa') + call mqc_twoeris_allocate(ERIOut,'doublebar','spin',& + aaaa,aaaa,aabb,bbaa,abba=abba,baab=baab) + case('inverted') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + aabb = ERIA%getBlock('aaaa') + abab = (-1)*ERIB%getBlock('aaaa') + call mqc_twoeris_allocate(ERIOut,'ms','spin',& + aaaa,aaaa,aabb,bbaa,baba=baba,abab=abab) + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & + 'ERIB%storagetype', ERIB%stortype() ) + end select + case('exchange') + select case(ERIB%storType()) + case('coulomb') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + aabb = (-1)*ERIB%getBlock('aaaa') + abba = ERIA%getBlock('aaaa') + call mqc_twoeris_allocate(ERIOut,'doublebar','spin',& + aaaa,aaaa,aabb,bbaa,abba=abba,baab=baab) + case('exchange') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + call mqc_twoeris_allocate(ERIOut,'exchange','space',aaaa) + case('inverted') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + abba = ERIA%getBlock('aaaa') + abab = (-1)*ERIB%getBlock('aaaa') + call mqc_twoeris_allocate(ERIOut,'ms','spin',& + aaaa,aaaa,abba=abba,baab=baab,baba=baba,abab=abab) + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & + 'ERIB%storagetype', ERIB%stortype() ) + end select + case('inverted') + select case(ERIB%storType()) + case('coulomb') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + aabb = (-1)*ERIB%getBlock('aaaa') + abab = ERIA%getBlock('aaaa') + call mqc_twoeris_allocate(ERIOut,'ms','spin',& + aaaa,aaaa,aabb,bbaa,baba=baba,abab=abab) + case('exchange') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + abba = (-1)*ERIB%getBlock('aaaa') + abab = ERIA%getBlock('aaaa') + call mqc_twoeris_allocate(ERIOut,'ms','spin',& + aaaa,aaaa,abba=abba,baab=baab,baba=baba,abab=abab) + case('inverted') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + call mqc_twoeris_allocate(ERIOut,'inverted','space',aaaa) + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & + 'ERIB%storagetype', ERIB%stortype() ) + end select + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & + 'ERIA%storagetype', ERIA%stortype() ) + end select case('spin') - aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') - bbbb = ERIA%getBlock('aaaa')-ERIB%getBlock('bbbb') - aabb = ERIA%getBlock('aaaa')-ERIB%getBlock('aabb') - bbaa = ERIA%getBlock('aaaa')-ERIB%getBlock('bbaa') - call mqc_twoeris_allocate(ERIOut,'full','spin',aaaa,bbbb,& - aabb,bbaa) + select case(ERIA%storType()) + case('coulomb') + select case(ERIB%storType()) + case('coulomb') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('aaaa')-ERIB%getBlock('bbbb') + aabb = ERIA%getBlock('aaaa')-ERIB%getBlock('aabb') + bbaa = ERIA%getBlock('aaaa')-ERIB%getBlock('bbaa') + call mqc_twoeris_allocate(ERIOut,'coulomb','spin',aaaa,bbbb,aabb,bbaa) + case('exchange') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('aaaa')-ERIB%getBlock('bbbb') + bbaa = ERIA%getBlock('aaaa') + aabb = ERIA%getBlock('aaaa') + abba = (-1)*ERIB%getBlock('abba') + baab = (-1)*ERIB%getBlock('baab') + call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab) + case('inverted') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('aaaa')-ERIB%getBlock('bbbb') + bbaa = ERIA%getBlock('aaaa') + aabb = ERIA%getBlock('aaaa') + abab = (-1)*ERIB%getBlock('abab') + baba = (-1)*ERIB%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abab=abab,baba=baba) + case('doublebar') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('aaaa')-ERIB%getBlock('bbbb') + bbaa = ERIA%getBlock('aaaa')-ERIB%getBlock('bbaa') + aabb = ERIA%getBlock('aaaa')-ERIB%getBlock('aabb') + abba = (-1)*ERIB%getBlock('abba') + baab = (-1)*ERIB%getBlock('baab') + call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab) + case('ms') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('aaaa')-ERIB%getBlock('bbbb') + bbaa = ERIA%getBlock('aaaa')-ERIB%getBlock('bbaa') + aabb = ERIA%getBlock('aaaa')-ERIB%getBlock('aabb') + abba = (-1)*ERIB%getBlock('abba') + baab = (-1)*ERIB%getBlock('baab') + abab = (-1)*ERIB%getBlock('abab') + baba = (-1)*ERIB%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab,abab=abab,baba=baba) + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & + 'ERIB%storagetype', ERIB%stortype()) + end select + case('exchange') + select case(ERIB%storType()) + case('coulomb') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('aaaa')-ERIB%getBlock('bbbb') + bbaa = (-1)*ERIB%getBlock('aaaa') + aabb = (-1)*ERIB%getBlock('aaaa') + abba = ERIA%getBlock('abba') + baab = ERIA%getBlock('baab') + call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab) + case('exchange') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('aaaa')-ERIB%getBlock('bbbb') + aabb = ERIA%getBlock('aaaa')-ERIB%getBlock('abba') + bbaa = ERIA%getBlock('aaaa')-ERIB%getBlock('abba') + call mqc_twoeris_allocate(ERIOut,'exchange','spin',aaaa,bbbb,aabb,bbaa) + case('inverted') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('aaaa')-ERIB%getBlock('bbbb') + baab = ERIA%getBlock('aaaa') + abba = ERIA%getBlock('aaaa') + abab = (-1)*ERIB%getBlock('abab') + baba = (-1)*ERIB%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,& + abba=abba,baab=baab,abab=abab,baba=baba) + case('doublebar') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('aaaa')-ERIB%getBlock('bbbb') + abba = ERIA%getBlock('aaaa')-ERIB%getBlock('abba') + baab = ERIA%getBlock('aaaa')-ERIB%getBlock('baab') + bbaa = (-1)*ERIB%getBlock('bbaa') + aabb = (-1)*ERIB%getBlock('aabb') + call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab) + case('ms') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('aaaa')-ERIB%getBlock('bbbb') + bbaa = (-1)*ERIB%getBlock('bbaa') + aabb = (-1)*ERIB%getBlock('aabb') + abba = ERIA%getBlock('aaaa')-ERIB%getBlock('abba') + baab = ERIA%getBlock('aaaa')-ERIB%getBlock('baab') + abab = (-1)*ERIB%getBlock('abab') + baba = (-1)*ERIB%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab,abab=abab,baba=baba) + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & + 'ERIB%storagetype', ERIB%stortype() ) + end select + case('inverted') + select case(ERIB%storType()) + case('coulomb') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('aaaa')-ERIB%getBlock('bbbb') + bbaa = (-1)*ERIB%getBlock('bbaa') + aabb = (-1)*ERIB%getBlock('aabb') + abab = ERIA%getBlock('aaaa') + baba = ERIA%getBlock('aaaa') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abab=abab,baba=baba) + case('exchange') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('aaaa')-ERIB%getBlock('bbbb') + baab = (-1)*ERIB%getBlock('baab') + abba = (-1)*ERIB%getBlock('abba') + abab = ERIA%getBlock('aaaa') + baba = ERIA%getBlock('aaaa') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,& + abba=abba,baab=baab,abab=abab,baba=baba) + case('inverted') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('aaaa')-ERIB%getBlock('bbbb') + aabb = ERIA%getBlock('aaaa')-ERIB%getBlock('abab') + bbaa = ERIA%getBlock('aaaa')-ERIB%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'inverted','spin',aaaa,bbbb,& + abab,baba) + case('doublebar') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('aaaa')-ERIB%getBlock('bbbb') + abba = (-1)*ERIB%getBlock('abba') + baab = (-1)*ERIB%getBlock('baab') + bbaa = (-1)*ERIB%getBlock('bbaa') + aabb = (-1)*ERIB%getBlock('aabb') + abab = ERIA%getBlock('aaaa') + baba = ERIA%getBlock('aaaa') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab,abab=abab,baba=baba) + case('ms') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('aaaa')-ERIB%getBlock('bbbb') + abba = (-1)*ERIB%getBlock('abba') + baab = (-1)*ERIB%getBlock('baab') + bbaa = (-1)*ERIB%getBlock('bbaa') + aabb = (-1)*ERIB%getBlock('aabb') + abab = ERIA%getBlock('aaaa')-ERIB%getBlock('abab') + baba = ERIA%getBlock('aaaa')-ERIB%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab,abab=abab,baba=baba) + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & + 'ERIB%storagetype', ERIB%stortype() ) + end select + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & + 'ERIA%storagetype', ERIA%stortype() ) + end select case('general') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('aaaa')-ERIB%getBlock('bbbb') - aabb = ERIA%getBlock('aaaa')-ERIB%getBlock('aabb') - bbaa = ERIA%getBlock('aaaa')-ERIB%getBlock('bbaa') + select case(ERIA%storType()) + case('coulomb') + aabb = ERIA%getBlock('aaaa')-ERIB%getBlock('aabb') + bbaa = ERIA%getBlock('aaaa')-ERIB%getBlock('bbaa') + abab = (-1)*ERIB%getBlock('abab') + baba = (-1)*ERIB%getBlock('baba') + baab = (-1)*ERIB%getBlock('baab') + abba = (-1)*ERIB%getBlock('abba') + case('exchange') + aabb = (-1)*ERIB%getBlock('aabb') + bbaa = (-1)*ERIB%getBlock('bbaa') + abab = (-1)*ERIB%getBlock('abab') + baba = (-1)*ERIB%getBlock('baba') + baab = ERIA%getBlock('aaaa')-ERIB%getBlock('baab') + abba = ERIA%getBlock('aaaa')-ERIB%getBlock('abba') + case('inverted') + aabb = (-1)*ERIB%getBlock('aabb') + bbaa = (-1)*ERIB%getBlock('bbaa') + abab = ERIA%getBlock('aaaa')-ERIB%getBlock('abab') + baba = ERIA%getBlock('aaaa')-ERIB%getBlock('baba') + baab = (-1)*ERIB%getBlock('baab') + abba = (-1)*ERIB%getBlock('abba') + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & + 'ERIA%storagetype', ERIA%stortype() ) + end select call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& aabb,bbaa,& - (-1)*ERIB%getBlock('abab'),(-1)*ERIB%getBlock('abba'),& - (-1)*ERIB%getBlock('baab'),(-1)*ERIB%getBlock('baba'),& + abab,abba,& + baab,baba,& (-1)*ERIB%getBlock('aaab'),(-1)*ERIB%getBlock('aaba'),& (-1)*ERIB%getBlock('abaa'),(-1)*ERIB%getBlock('baaa'),& (-1)*ERIB%getBlock('bbba'),(-1)*ERIB%getBlock('bbab'),& @@ -9022,32 +9259,527 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) case('spin') select case (ERIB%integraltype) case('space') - aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') - bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('aaaa') - aabb = ERIA%getBlock('aabb')-ERIB%getBlock('aaaa') - bbaa = ERIA%getBlock('bbaa')-ERIB%getBlock('aaaa') - call mqc_twoeris_allocate(ERIOut,'full','spin',aaaa,bbbb,& - aabb,bbaa) + select case(ERIA%storType()) + case('coulomb') + select case(ERIB%storType()) + case('coulomb') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('aaaa') + aabb = ERIA%getBlock('aabb')-ERIB%getBlock('aaaa') + bbaa = ERIA%getBlock('bbaa')-ERIB%getBlock('aaaa') + call mqc_twoeris_allocate(ERIOut,'coulomb','spin',aaaa,bbbb,aabb,bbaa) + case('exchange') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('aaaa') + bbaa = (-1)*ERIB%getBlock('aaaa') + aabb = (-1)*ERIB%getBlock('aaaa') + abba = ERIA%getBlock('abba') + baab = ERIA%getBlock('baab') + call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab) + case('inverted') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('aaaa') + bbaa = (-1)*ERIB%getBlock('aaaa') + aabb = (-1)*ERIB%getBlock('aaaa') + abab = ERIA%getBlock('abab') + baba = ERIA%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abab=abab,baba=baba) + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & + 'ERIB%storagetype', ERIB%stortype() ) + end select + case('exchange') + select case(ERIB%storType()) + case('coulomb') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('aaaa') + bbaa = ERIA%getBlock('aaaa') + aabb = ERIA%getBlock('aaaa') + abba = (-1)*ERIB%getBlock('abba') + baab = (-1)*ERIB%getBlock('baab') + call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab) + case('exchange') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('aaaa') + aabb = ERIA%getBlock('abba')-ERIB%getBlock('aaaa') + bbaa = ERIA%getBlock('abba')-ERIB%getBlock('aaaa') + call mqc_twoeris_allocate(ERIOut,'exchange','spin',aaaa,bbbb,aabb,bbaa) + case('inverted') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('aaaa') + baab = ERIB%getBlock('aaaa') + abba = ERIB%getBlock('aaaa') + abab = (-1)*ERIA%getBlock('abab') + baba = (-1)*ERIA%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,& + abba=abba,baab=baab,abab=abab,baba=baba) + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & + 'ERIB%storagetype', ERIB%stortype() ) + end select + case('inverted') + select case(ERIB%storType()) + case('coulomb') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('aaaa') + bbaa = ERIA%getBlock('bbaa') + aabb = ERIA%getBlock('aabb') + abab = (-1)*ERIB%getBlock('aaaa') + baba = (-1)*ERIB%getBlock('aaaa') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abab=abab,baba=baba) + case('exchange') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('aaaa') + baab = ERIA%getBlock('baab') + abba = ERIA%getBlock('abba') + abab = (-1)*ERIB%getBlock('aaaa') + baba = (-1)*ERIB%getBlock('aaaa') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,& + abba=abba,baab=baab,abab=abab,baba=baba) + case('inverted') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('aaaa') + aabb = ERIA%getBlock('abab')-ERIB%getBlock('aaaa') + bbaa = ERIA%getBlock('baba')-ERIB%getBlock('aaaa') + call mqc_twoeris_allocate(ERIOut,'inverted','spin',aaaa,bbbb,& + abab,baba) + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & + 'ERIB%storagetype', ERIB%stortype() ) + end select + case('doublebar') + select case(ERIB%storType()) + case('coulomb') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('aaaa') + bbaa = ERIA%getBlock('bbaa')-ERIB%getBlock('aaaa') + aabb = ERIA%getBlock('aabb')-ERIB%getBlock('aaaa') + abba = ERIA%getBlock('abba') + baab = ERIA%getBlock('baab') + call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab) + case('exchange') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('aaaa') + abba = ERIA%getBlock('abba')-ERIB%getBlock('aaaa') + baab = ERIA%getBlock('baab')-ERIB%getBlock('aaaa') + bbaa = ERIA%getBlock('bbaa') + aabb = ERIA%getBlock('aabb') + call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab) + case('inverted') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('aaaa') + abba = ERIA%getBlock('abba') + baab = ERIA%getBlock('baab') + bbaa = ERIA%getBlock('bbaa') + aabb = ERIA%getBlock('aabb') + abab = (-1)*ERIB%getBlock('aaaa') + baba = (-1)*ERIB%getBlock('aaaa') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab,abab=abab,baba=baba) + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & + 'ERIB%storagetype', ERIB%stortype() ) + end select + case('ms') + select case(ERIB%storType()) + case('coulomb') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('aaaa') + bbaa = ERIA%getBlock('bbaa')-ERIB%getBlock('aaaa') + aabb = ERIA%getBlock('aabb')-ERIB%getBlock('aaaa') + abba = ERIA%getBlock('abba') + baab = ERIA%getBlock('baab') + abab = ERIA%getBlock('abab') + baba = ERIA%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab,abab=abab,baba=baba) + case('exchange') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('aaaa') + bbaa = ERIA%getBlock('bbaa') + aabb = ERIA%getBlock('aabb') + abba = ERIA%getBlock('abba')-ERIB%getBlock('aaaa') + baab = ERIA%getBlock('baab')-ERIB%getBlock('aaaa') + abab = ERIA%getBlock('abab') + baba = ERIA%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab,abab=abab,baba=baba) + case('inverted') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('aaaa') + abba = ERIA%getBlock('abba') + baab = ERIA%getBlock('baab') + bbaa = ERIA%getBlock('bbaa') + aabb = ERIA%getBlock('aabb') + abab = ERIA%getBlock('abab')-ERIB%getBlock('aaaa') + baba = ERIA%getBlock('baba')-ERIB%getBlock('aaaa') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab,abab=abab,baba=baba) + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & + 'ERIB%storagetype', ERIB%stortype() ) + end select + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & + 'ERIA%storagetype', ERIA%stortype() ) + end select case('spin') - aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') - bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') - aabb = ERIA%getBlock('aabb')-ERIB%getBlock('aabb') - bbaa = ERIA%getBlock('bbaa')-ERIB%getBlock('bbaa') - call mqc_twoeris_allocate(ERIOut,'full','spin',aaaa,bbbb,& - aabb,bbaa) + select case(ERIA%storType()) + case('coulomb') + select case(ERIB%storType()) + case('coulomb') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') + aabb = ERIA%getBlock('aabb')-ERIB%getBlock('aabb') + bbaa = ERIA%getBlock('bbaa')-ERIB%getBlock('bbaa') + call mqc_twoeris_allocate(ERIOut,'coulomb','spin',aaaa,bbbb,aabb,bbaa) + case('exchange') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') + bbaa = ERIA%getBlock('bbaa') + aabb = ERIA%getBlock('aabb') + abba = (-1)*ERIB%getBlock('abba') + baab = (-1)*ERIB%getBlock('baab') + call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab) + case('inverted') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') + bbaa = ERIA%getBlock('bbaa') + aabb = ERIA%getBlock('aabb') + abab = (-1)*ERIB%getBlock('abab') + baba = (-1)*ERIB%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abab=abab,baba=baba) + case('doublebar') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') + bbaa = ERIA%getBlock('bbaa')-ERIB%getBlock('bbaa') + aabb = ERIA%getBlock('aabb')-ERIB%getBlock('aabb') + abba = (-1)*ERIB%getBlock('abba') + baab = (-1)*ERIB%getBlock('baab') + call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab) + case('ms') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') + bbaa = ERIA%getBlock('bbaa')-ERIB%getBlock('bbaa') + aabb = ERIA%getBlock('aabb')-ERIB%getBlock('aabb') + abba = (-1)*ERIB%getBlock('abba') + baab = (-1)*ERIB%getBlock('baab') + abab = (-1)*ERIB%getBlock('abab') + baba = (-1)*ERIB%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab,abab=abab,baba=baba) + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & + 'ERIB%storagetype', ERIB%stortype() ) + end select + case('exchange') + select case(ERIB%storType()) + case('coulomb') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') + bbaa = (-1)*ERIB%getBlock('bbaa') + aabb = (-1)*ERIB%getBlock('aabb') + abba = ERIA%getBlock('abba') + baab = ERIA%getBlock('baab') + call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab) + case('exchange') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') + aabb = ERIA%getBlock('abba')-ERIB%getBlock('abba') + bbaa = ERIA%getBlock('baab')-ERIB%getBlock('baab') + call mqc_twoeris_allocate(ERIOut,'exchange','spin',aaaa,bbbb,aabb,bbaa) + case('inverted') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') + abba = ERIA%getBlock('abba') + baab = ERIA%getBlock('baab') + abab = ERIB%getBlock('abab') + baba = ERIB%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,& + abba=abba,baab=baab,abab=abab,baba=baba) + case('doublebar') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') + bbaa = (-1)*ERIB%getBlock('bbaa') + aabb = (-1)*ERIB%getBlock('aabb') + abba = ERIA%getBlock('abba')-ERIB%getBlock('abba') + baab = ERIA%getBlock('baab')-ERIB%getBlock('baab') + call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab) + case('ms') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') + bbaa = (-1)*ERIB%getBlock('bbaa') + aabb = (-1)*ERIB%getBlock('aabb') + abba = ERIA%getBlock('abba')-ERIB%getBlock('abba') + baab = ERIA%getBlock('baab')-ERIB%getBlock('baab') + abab = (-1)*ERIB%getBlock('abab') + baba = (-1)*ERIB%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab,abab=abab,baba=baba) + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & + 'ERIB%storagetype', ERIB%stortype() ) + end select + case('inverted') + select case(ERIB%storType()) + case('coulomb') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') + bbaa = (-1)*ERIB%getBlock('bbaa') + aabb = (-1)*ERIB%getBlock('aabb') + abab = ERIA%getBlock('abab') + baba = ERIA%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abab=abab,baba=baba) + case('exchange') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') + abba = (-1)*ERIB%getBlock('abba') + baab = (-1)*ERIB%getBlock('baab') + abab = ERIA%getBlock('abab') + baba = ERIA%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,& + abba=abba,baab=baab,abab=abab,baba=baba) + case('inverted') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') + aabb = ERIA%getBlock('abab')-ERIB%getBlock('abab') + bbaa = ERIA%getBlock('abab')-ERIB%getBlock('abab') + call mqc_twoeris_allocate(ERIOut,'inverted','spin',aaaa,bbbb,aabb,bbaa) + case('doublebar') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') + bbaa = (-1)*ERIB%getBlock('bbaa') + aabb = (-1)*ERIB%getBlock('aabb') + abba = (-1)*ERIB%getBlock('abba') + baab = (-1)*ERIB%getBlock('baab') + abab = ERIA%getBlock('abab') + baba = ERIA%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab,abab=abab,baba=baba) + case('ms') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') + bbaa = (-1)*ERIB%getBlock('bbaa') + aabb = (-1)*ERIB%getBlock('aabb') + abba = (-1)*ERIB%getBlock('abba') + baab = (-1)*ERIB%getBlock('baab') + abab = ERIA%getBlock('abab')-ERIB%getBlock('abab') + baba = ERIA%getBlock('baba')-ERIB%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab,abab=abab,baba=baba) + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & + 'ERIB%storagetype', ERIB%stortype() ) + end select + case('doublebar') + select case(ERIB%storType()) + case('coulomb') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') + bbaa = ERIA%getBlock('bbaa')-ERIB%getBlock('bbaa') + aabb = ERIA%getBlock('aabb')-ERIB%getBlock('aabb') + abba = ERIA%getBlock('abba') + baab = ERIA%getBlock('baab') + call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab) + case('exchange') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') + bbaa = ERIA%getBlock('bbaa') + aabb = ERIA%getBlock('aabb') + abba = ERIA%getBlock('abba')-ERIB%getBlock('abba') + baab = ERIA%getBlock('baab')-ERIB%getBlock('baab') + call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab) + case('inverted') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') + bbaa = ERIA%getBlock('bbaa') + aabb = ERIA%getBlock('aabb') + abba = ERIA%getBlock('abba') + baab = ERIA%getBlock('baab') + abab = (-1)*ERIB%getBlock('abab') + baba = (-1)*ERIB%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab,abab=abab,baba=baba) + case('doublebar') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') + bbaa = ERIA%getBlock('bbaa')-ERIB%getBlock('bbaa') + aabb = ERIA%getBlock('aabb')-ERIB%getBlock('aabb') + abba = ERIA%getBlock('abba')-ERIB%getBlock('abba') + baab = ERIA%getBlock('baab')-ERIB%getBlock('baab') + call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab) + case('ms') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') + bbaa = ERIA%getBlock('bbaa')-ERIB%getBlock('bbaa') + aabb = ERIA%getBlock('aabb')-ERIB%getBlock('aabb') + abba = ERIA%getBlock('abba')-ERIB%getBlock('abba') + baab = ERIA%getBlock('baab')-ERIB%getBlock('baab') + abab = (-1)*ERIB%getBlock('abab') + baba = (-1)*ERIB%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab,abab=abab,baba=baba) + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & + 'ERIB%storagetype', ERIB%stortype() ) + end select + case('ms') + select case(ERIB%storType()) + case('coulomb') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') + bbaa = ERIA%getBlock('bbaa')-ERIB%getBlock('bbaa') + aabb = ERIA%getBlock('aabb')-ERIB%getBlock('aabb') + abba = ERIA%getBlock('abba') + baab = ERIA%getBlock('baab') + abab = ERIA%getBlock('abab') + baba = ERIA%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab,abab=abab,baba=baba) + case('exchange') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') + bbaa = ERIA%getBlock('bbaa') + aabb = ERIA%getBlock('aabb') + abba = ERIA%getBlock('abba')-ERIB%getBlock('abba') + baab = ERIA%getBlock('baab')-ERIB%getBlock('baab') + abab = ERIA%getBlock('abab') + baba = ERIA%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab,abab=abab,baba=baba) + case('inverted') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') + bbaa = ERIA%getBlock('bbaa') + aabb = ERIA%getBlock('aabb') + abba = ERIA%getBlock('abba') + baab = ERIA%getBlock('baab') + abab = ERIA%getBlock('abab')-ERIB%getBlock('abab') + baba = ERIA%getBlock('baba')-ERIB%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab,abab=abab,baba=baba) + case('doublebar') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') + bbaa = ERIA%getBlock('bbaa')-ERIB%getBlock('bbaa') + aabb = ERIA%getBlock('aabb')-ERIB%getBlock('aabb') + abba = ERIA%getBlock('abba')-ERIB%getBlock('abba') + baab = ERIA%getBlock('baab')-ERIB%getBlock('baab') + abab = ERIA%getBlock('abab') + baba = ERIA%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab,abab=abab,baba=baba) + case('ms') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') + bbaa = ERIA%getBlock('bbaa')-ERIB%getBlock('bbaa') + aabb = ERIA%getBlock('aabb')-ERIB%getBlock('aabb') + abba = ERIA%getBlock('abba')-ERIB%getBlock('abba') + baab = ERIA%getBlock('baab')-ERIB%getBlock('baab') + abab = ERIA%getBlock('abab')-ERIB%getBlock('abab') + baba = ERIA%getBlock('baba')-ERIB%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + abba=abba,baab=baab,abab=abab,baba=baba) + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & + 'ERIB%storagetype', ERIB%stortype() ) + end select + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & + 'ERIA%storagetype', ERIA%stortype() ) + end select case('general') - aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') - bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') - aabb = ERIA%getBlock('aabb')-ERIB%getBlock('aabb') - bbaa = ERIA%getBlock('bbaa')-ERIB%getBlock('bbaa') - call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& - aabb,bbaa,& - (-1)*ERIB%getBlock('abab'),(-1)*ERIB%getBlock('abba'),& - (-1)*ERIB%getBlock('baab'),(-1)*ERIB%getBlock('baba'),& - (-1)*ERIB%getBlock('aaab'),(-1)*ERIB%getBlock('aaba'),& - (-1)*ERIB%getBlock('abaa'),(-1)*ERIB%getBlock('baaa'),& - (-1)*ERIB%getBlock('bbba'),(-1)*ERIB%getBlock('bbab'),& - (-1)*ERIB%getBlock('babb'),(-1)*ERIB%getBlock('abbb')) + select case(ERIA%storType()) + case('coulomb') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') + aabb = ERIA%getBlock('aabb')-ERIB%getBlock('aabb') + bbaa = ERIA%getBlock('bbaa')-ERIB%getBlock('bbaa') + call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& + aabb,bbaa,& + (-1)*ERIB%getBlock('abab'),(-1)*ERIB%getBlock('abba'),& + (-1)*ERIB%getBlock('baab'),(-1)*ERIB%getBlock('baba'),& + (-1)*ERIB%getBlock('aaab'),(-1)*ERIB%getBlock('aaba'),& + (-1)*ERIB%getBlock('abaa'),(-1)*ERIB%getBlock('baaa'),& + (-1)*ERIB%getBlock('bbba'),(-1)*ERIB%getBlock('bbab'),& + (-1)*ERIB%getBlock('babb'),(-1)*ERIB%getBlock('abbb')) + case('exchange') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') + abba = ERIA%getBlock('abba')-ERIB%getBlock('abba') + baab = ERIA%getBlock('baab')-ERIB%getBlock('baab') + call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& + (-1)*ERIB%getBlock('aabb'),(-1)*ERIB%getBlock('bbaa'),& + (-1)*ERIB%getBlock('abab'), abba,& + baab,(-1)*ERIB%getBlock('baba'),& + (-1)*ERIB%getBlock('aaab'),(-1)*ERIB%getBlock('aaba'),& + (-1)*ERIB%getBlock('abaa'),(-1)*ERIB%getBlock('baaa'),& + (-1)*ERIB%getBlock('bbba'),(-1)*ERIB%getBlock('bbab'),& + (-1)*ERIB%getBlock('babb'),(-1)*ERIB%getBlock('abbb')) + case('inverted') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') + abab = ERIA%getBlock('abab')-ERIB%getBlock('abab') + baba = ERIA%getBlock('baba')-ERIB%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& + (-1)*ERIB%getBlock('aabb'),(-1)*ERIB%getBlock('bbaa'),& + abab,(-1)*ERIB%getBlock('abba'),& + (-1)*ERIB%getBlock('baab'), baba,& + (-1)*ERIB%getBlock('aaab'),(-1)*ERIB%getBlock('aaba'),& + (-1)*ERIB%getBlock('abaa'),(-1)*ERIB%getBlock('baaa'),& + (-1)*ERIB%getBlock('bbba'),(-1)*ERIB%getBlock('bbab'),& + (-1)*ERIB%getBlock('babb'),(-1)*ERIB%getBlock('abbb')) + case('doublebar') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') + aabb = ERIA%getBlock('aabb')-ERIB%getBlock('aabb') + bbaa = ERIA%getBlock('bbaa')-ERIB%getBlock('bbaa') + abba = ERIA%getBlock('abba')-ERIB%getBlock('abba') + baab = ERIA%getBlock('baab')-ERIB%getBlock('baab') + call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& + aabb , bbaa ,& + abab ,(-1)*ERIB%getBlock('abba'),& + (-1)*ERIB%getBlock('baab'), baba ,& + (-1)*ERIB%getBlock('aaab'),(-1)*ERIB%getBlock('aaba'),& + (-1)*ERIB%getBlock('abaa'),(-1)*ERIB%getBlock('baaa'),& + (-1)*ERIB%getBlock('bbba'),(-1)*ERIB%getBlock('bbab'),& + (-1)*ERIB%getBlock('babb'),(-1)*ERIB%getBlock('abbb')) + case('ms') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') + bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') + aabb = ERIA%getBlock('aabb')-ERIB%getBlock('aabb') + bbaa = ERIA%getBlock('bbaa')-ERIB%getBlock('bbaa') + abba = ERIA%getBlock('abba')-ERIB%getBlock('abba') + baab = ERIA%getBlock('baab')-ERIB%getBlock('baab') + abab = ERIA%getBlock('abab')-ERIB%getBlock('abab') + baba = ERIA%getBlock('baba')-ERIB%getBlock('baba') + call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& + aabb , bbaa ,& + abab , abba ,& + baab , baba ,& + (-1)*ERIB%getBlock('aaab'),(-1)*ERIB%getBlock('aaba'),& + (-1)*ERIB%getBlock('abaa'),(-1)*ERIB%getBlock('baaa'),& + (-1)*ERIB%getBlock('bbba'),(-1)*ERIB%getBlock('bbab'),& + (-1)*ERIB%getBlock('babb'),(-1)*ERIB%getBlock('abbb')) + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & + 'ERIA%storagetype', ERIA%stortype() ) + end select case default call mqc_error_A('Unknown twoERI type in mqc_eri_difference', 6, & 'ERIB%integraltype', ERIB%integraltype ) @@ -9057,12 +9789,36 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) case('space') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('aaaa') - aabb = ERIA%getBlock('aabb')-ERIB%getBlock('aaaa') - bbaa = ERIA%getBlock('bbaa')-ERIB%getBlock('aaaa') + select case(ERIB%storType()) + case('coulomb') + aabb = ERIA%getBlock('aabb')-ERIB%getBlock('aaaa') + bbaa = ERIA%getBlock('bbaa')-ERIB%getBlock('aaaa') + abab = ERIA%getBlock('abab') + baba = ERIA%getBlock('baba') + baab = ERIA%getBlock('baab') + abba = ERIA%getBlock('abba') + case('exchange') + aabb = ERIA%getBlock('aabb') + bbaa = ERIA%getBlock('bbaa') + abab = ERIA%getBlock('abab') + baba = ERIA%getBlock('baba') + baab = ERIA%getBlock('baab')-ERIB%getBlock('aaaa') + abba = ERIA%getBlock('abba')-ERIB%getBlock('aaaa') + case('inverted') + aabb = ERIA%getBlock('aabb') + bbaa = ERIA%getBlock('bbaa') + abab = ERIA%getBlock('abab')-ERIB%getBlock('aaaa') + baba = ERIA%getBlock('baba')-ERIB%getBlock('aaaa') + baab = ERIA%getBlock('baab') + abba = ERIA%getBlock('abba') + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & + 'ERIB%storagetype', ERIB%stortype() ) + end select call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& aabb,bbaa,& - ERIA%getBlock('abab'), ERIA%getBlock('abba'),& - ERIA%getBlock('baab'), ERIA%getBlock('baba'),& + abab,abba,& + baab,baba,& ERIA%getBlock('aaab'), ERIA%getBlock('aaba'),& ERIA%getBlock('abaa'), ERIA%getBlock('baaa'),& ERIA%getBlock('bbba'), ERIA%getBlock('bbab'),& @@ -9070,12 +9826,50 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) case('spin') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') - aabb = ERIA%getBlock('aabb')-ERIB%getBlock('aabb') - bbaa = ERIA%getBlock('bbaa')-ERIB%getBlock('bbaa') + select case(ERIB%storType()) + case('coulomb') + aabb = ERIA%getBlock('aabb')-ERIB%getBlock('aabb') + bbaa = ERIA%getBlock('bbaa')-ERIB%getBlock('bbaa') + abab = ERIA%getBlock('abab') + baba = ERIA%getBlock('baba') + baab = ERIA%getBlock('baab') + abba = ERIA%getBlock('abba') + case('exchange') + aabb = ERIA%getBlock('aabb') + bbaa = ERIA%getBlock('bbaa') + abab = ERIA%getBlock('abab') + baba = ERIA%getBlock('baba') + baab = ERIA%getBlock('baab')-ERIB%getBlock('baab') + abba = ERIA%getBlock('abba')-ERIB%getBlock('abba') + case('inverted') + aabb = ERIA%getBlock('aabb') + bbaa = ERIA%getBlock('bbaa') + abab = ERIA%getBlock('abab')-ERIB%getBlock('abab') + baba = ERIA%getBlock('baba')-ERIB%getBlock('baba') + baab = ERIA%getBlock('baab') + abba = ERIA%getBlock('abba') + case('doublebar') + aabb = ERIA%getBlock('aabb')-ERIB%getBlock('aabb') + bbaa = ERIA%getBlock('bbaa')-ERIB%getBlock('bbaa') + abab = ERIA%getBlock('abab') + baba = ERIA%getBlock('baba') + baab = ERIA%getBlock('baab')-ERIB%getBlock('baab') + abba = ERIA%getBlock('abba')-ERIB%getBlock('abba') + case('ms') + aabb = ERIA%getBlock('aabb')-ERIB%getBlock('aabb') + bbaa = ERIA%getBlock('bbaa')-ERIB%getBlock('bbaa') + abab = ERIA%getBlock('abab')-ERIB%getBlock('abab') + baba = ERIA%getBlock('baba')-ERIB%getBlock('baba') + baab = ERIA%getBlock('baab')-ERIB%getBlock('baab') + abba = ERIA%getBlock('abba')-ERIB%getBlock('abba') + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & + 'ERIB%storagetype', ERIB%stortype() ) + end select call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& aabb,bbaa,& - ERIA%getBlock('abab'), ERIA%getBlock('abba'),& - ERIA%getBlock('baab'), ERIA%getBlock('baba'),& + abab,abba,& + baab,baba,& ERIA%getBlock('aaab'), ERIA%getBlock('aaba'),& ERIA%getBlock('abaa'), ERIA%getBlock('baaa'),& ERIA%getBlock('bbba'), ERIA%getBlock('bbab'),& @@ -13439,6 +14233,10 @@ function mqc_eri_eri_contraction(eris1,eris2,label) result(output) ! 6,'myLabel',myLabel) !end select + write(*,*) 'DEBUG: ERI_ERI Contraction' + write(*,*) 'ERIs 1',eris1%Type(),eris1%storType() + write(*,*) 'ERIs 2',eris2%Type(),eris2%storType() + if(myLabel.ne.'coulomb') temp = eris1%swap(2,4) output = 0.0 if(eris1%storType().eq.'empty'.or.eris2%storType().eq.'empty') return @@ -13463,7 +14261,13 @@ function mqc_eri_eri_contraction(eris1,eris2,label) result(output) end if else if(eris1%storType().eq.'coulomb'.or.eris2%storType().eq.'coulomb'.or. & eris1%storType().eq.'symm'.or.eris2%storType().eq.'symm') then - if(eris1%storType().eq.'exchange'.or.eris2%storType().eq.'exchange') then + if(eris1%storType().eq.'coulomb'.or.eris2%storType().eq.'coulomb'.or. & + eris1%storType().eq.'symm'.or.eris2%storType().eq.'symm') then + if(myLabel.eq.'coulomb') output = 4*output + if(myLabel.eq.'exchange') output = 2*output + if(myLabel.eq.'doublebar') & + output = 2*output + 2*contraction(eris1%getBlock('aaaa'),eris2%getBlock('aaaa')) + else if(eris1%storType().eq.'exchange'.or.eris2%storType().eq.'exchange') then if(myLabel.eq.'coulomb') output = 2*output if(myLabel.eq.'exchange') output = 4*output if(myLabel.eq.'doublebar') & @@ -13491,9 +14295,9 @@ function mqc_eri_eri_contraction(eris1,eris2,label) result(output) if(myLabel.ne.'coulomb') & output = output - contraction(temp%getBlock('aaaa'),eris2%getBlock('bbbb')) select case(eris1%storType()) - case ('coulomb','sym') + case ('coulomb','symm') select case(eris2%storType()) - case ('sym') + case ('symm') if(myLabel.ne.'exchange') & output = output + 2*contraction(eris1%getBlock('aaaa'),eris2%getBlock('aabb')) case ('coulomb') @@ -13628,7 +14432,7 @@ function mqc_eri_eri_contraction(eris1,eris2,label) result(output) select case(eris2%storType()) case ('coulomb','symm') select case(eris1%storType()) - case ('coulomb') + case ('coulomb','symm') if(myLabel.ne.'exchange') & output = output + contraction(eris1%getBlock('aabb'),eris2%getBlock('aaaa')) & + contraction(eris1%getBlock('bbaa'),eris2%getBlock('aaaa')) From e148279d2448b288a50be78a5fae171f0df432ec Mon Sep 17 00:00:00 2001 From: Lee Thompson Date: Fri, 8 May 2026 13:09:24 -0400 Subject: [PATCH 28/37] Bug fixes in new ERI structure routines --- src/mqc_est.F03 | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/src/mqc_est.F03 b/src/mqc_est.F03 index 0b2725f7..dd021a79 100644 --- a/src/mqc_est.F03 +++ b/src/mqc_est.F03 @@ -1074,7 +1074,8 @@ subroutine mqc_print_twoERIs(twoERIs,iOut,header, & if(twoERIs%hasSpinBlock('bbbb')) & call twoERIs%beta%print(iout,'(bb|bb)',short_print_threshold=print_threshold) if((twoERIs%storageType.eq.'coulomb'.or.twoERIs%storageType.eq.'doublebar'& - .or.twoERIs%storageType.eq.'ms').and.twoERIs%hasSpinBlock('aabb')) & + .or.twoERIs%storageType.eq.'ms'.or.twoERIs%storageType.eq.'symm').and.& + twoERIs%hasSpinBlock('aabb')) & call twoERIs%alphaBeta%print(iout,'(aa|bb)',short_print_threshold=print_threshold) if((twoERIs%storageType.eq.'coulomb'.or.twoERIs%storageType.eq.'doublebar'& .or.twoERIs%storageType.eq.'ms').and.twoERIs%hasSpinBlock('bbaa')) & @@ -23793,11 +23794,9 @@ Subroutine TwoERI_Trans(IOut,IPrint,MO_Coeff,ERIs,MO_ERIs,Right_MOs) ! MO_Coeff_4 = MO_Coeff_2 !EndIf ! - If(MO_Coeff%type().eq.'general'.or.MO_Coeff_2%type().eq.'general'.or.& - MO_Coeff_3%type().eq.'general'.or.MO_Coeff_4%type().eq.'general') then + If(MO_Coeff%type().eq.'general'.or.MO_Coeff_2%type().eq.'general') then intType = 'general' - ElseIf(MO_Coeff%type().eq.'spin'.or.MO_Coeff_2%type().eq.'spin'.or.& - MO_Coeff_2%type().eq.'spin'.or.MO_Coeff_4%type().eq.'spin') then + ElseIf(MO_Coeff%type().eq.'spin'.or.MO_Coeff_2%type().eq.'spin') then intType = 'spin' Else intType = 'space' @@ -26616,9 +26615,9 @@ Subroutine TwoERI_Trans(IOut,IPrint,MO_Coeff,ERIs,MO_ERIs,Right_MOs) EndIf If(intType.eq.'space') then - call mqc_twoeris_allocate(mo_eris,'full','space',tmpR4TensorAlpha) + call mqc_twoeris_allocate(mo_eris,'coulomb','space',tmpR4TensorAlpha) ElseIf(intType.eq.'spin'.and.storage.eq.'full') then - call mqc_twoeris_allocate(mo_eris,'full','spin',tmpR4TensorAlpha,tmpR4TensorBeta, & + call mqc_twoeris_allocate(mo_eris,'coulomb','spin',tmpR4TensorAlpha,tmpR4TensorBeta, & tmpR4TensorAlphaBeta,tmpR4TensorBetaAlpha) ElseIf(intType.eq.'spin'.and.storage.eq.'symm') then call mqc_twoeris_allocate(mo_eris,'symm','spin',tmpR4TensorAlpha,tmpR4TensorBeta, & From 5214a1a5b75cde312dfbcaf17619e7bc6ca412f6 Mon Sep 17 00:00:00 2001 From: Lee Thompson Date: Fri, 15 May 2026 16:28:30 -0400 Subject: [PATCH 29/37] Updated the twoERIs storage and interation types. The subroutines still need to mbe modified to ensure they work for different cases. --- src/mqc_algebra.F03 | 8 + src/mqc_est.F03 | 2137 ++++++++++++++++++++++++++----------------- 2 files changed, 1282 insertions(+), 863 deletions(-) diff --git a/src/mqc_algebra.F03 b/src/mqc_algebra.F03 index 4da36cd2..b8f13c5f 100644 --- a/src/mqc_algebra.F03 +++ b/src/mqc_algebra.F03 @@ -640,6 +640,14 @@ Module MQC_Algebra module procedure MQC_R4Tensor_IsAllocated end interface ! +!> \brief Deallocates an object + interface Deallocate + module procedure MQC_Deallocate_Scalar + module procedure MQC_Deallocate_Vector + module procedure MQC_Deallocate_Matrix + module procedure MQC_Deallocate_R4Tensor + end interface +! !> \brief Returns the value of the vector at the specied index interface MQC_Vector_Scalar_At module procedure MQC_Vector_Scalar_At_Scalar diff --git a/src/mqc_est.F03 b/src/mqc_est.F03 index dd021a79..2734a8e9 100644 --- a/src/mqc_est.F03 +++ b/src/mqc_est.F03 @@ -282,23 +282,30 @@ Module MQC_EST type mqc_twoERIs type(mqc_r4tensor),private::alpha,beta,alphaBeta,betaAlpha,aaab,aaba,abaa,baaa,abab, & baab,baba,abba,bbba,bbab,babb,abbb - character(Len=64),private::integralType !regular,raffenetti1,raffenetti2,raffenetti3,space,spin,general,empty - character(Len=64),private::storageType !full,symm,coulomb,exchange,inverted,doublebar,ms -!> -!> Definition of non-zero MO elements based on integralType and storageType -!> integralType = space -!> Block= |coulomb|exchange|inverted -!> -------+-------+--------+-------- -!> aaaa = | aaaa | aaaa | aaaa -!> bbbb = | aaaa | aaaa | aaaa -!> aabb = | aaaa | 0 | 0 -!> bbaa = | aaaa | 0 | 0 -!> abba = | 0 | aaaa | 0 -!> baab = | 0 | aaaa | 0 -!> abab = | 0 | 0 | aaaa -!> baba = | 0 | 0 | aaaa + character(Len=64),private::integralType !regular,raffenetti1,raffenetti2,raffenetti3,space,spin,general + character(Len=64),private::interactionType !coulomb,exchange,inverted,doublebar,ms, + character(Len=64),private::storageType !full,symm +!> +!> Definition of non-zero MO elements based on integralType, interactionType and +!> storageType +!> +!> integralType = space +!> storageType = symm/full +!> interactionType => +!> Block= |coulomb|exchange|inverted|doublebar| ms +!> -------+-------+--------+--------+---------+------ +!> aaaa = | aaaa | aaaa | aaaa | aaaa | aaaa +!> bbbb = | aaaa | aaaa | aaaa | aaaa | aaaa +!> aabb = | aaaa | 0 | 0 | aabb | aaaa +!> bbaa = | aaaa | 0 | 0 | aabb | aaaa +!> abba = | 0 | aaaa | 0 | abba | aaaa +!> baab = | 0 | aaaa | 0 | abba | aaaa +!> abab = | 0 | 0 | aaaa | 0 | aaaa +!> baba = | 0 | 0 | aaaa | 0 | aaaa !> !> integralType = spin +!> storageType = full +!> interactionType => !> Block= |coulomb|exchange|inverted|doublebar| ms !> -------+-------+--------+--------+---------+------ !> aaaa = | aaaa | aaaa | aaaa | aaaa | aaaa @@ -310,6 +317,41 @@ Module MQC_EST !> abab = | 0 | 0 | aabb | 0 | abab !> baba = | 0 | 0 | bbaa | 0 | baba !> +!> integralType = spin +!> storageType = symm +!> interactionType => +!> Block= |coulomb|exchange|inverted|doublebar| ms +!> -------+-------+--------+--------+---------+------ +!> aaaa = | aaaa | aaaa | aaaa | aaaa | aaaa +!> bbbb = | bbbb | bbbb | bbbb | bbbb | bbbb +!> aabb = | aabb | 0 | 0 | aabb | aabb +!> bbaa = | aabb | 0 | 0 | aabb | aabb +!> abba = | 0 | aabb | 0 | abba | abba +!> baab = | 0 | aabb | 0 | abba | abba +!> abab = | 0 | 0 | aabb | 0 | abab +!> baba = | 0 | 0 | aabb | 0 | abab +!> +!> integralType = general +!> interactionType = coulomb/exchange/inverted/doublebar/ms +!> storageType => +!> Block= | symm | full +!> -------+------+------ +!> aaaa = | aaaa | aaaa +!> bbbb = | bbbb | bbbb +!> aabb = | aabb | aabb +!> bbaa = | aabb | bbaa +!> abba = | abba | abba +!> baab = | abba | baab +!> abab = | abab | abab +!> baba = | abab | baba +!> aaab = | aaab | aaab +!> aaba = | aaab | aaba +!> abaa = | aaab | abaa +!> baaa = | aaab | baaa +!> bbba = | abbb | bbba +!> bbab = | abbb | bbab +!> babb = | abbb | babb +!> abbb = | abbb | abbb !> contains !> \brief Print the MQC_TwoERIs object @@ -323,6 +365,7 @@ Module MQC_EST !> \brief Return a spin block of MQC_TwoERIs object as an MQC rank-4 tensor procedure, public::getBlock => mqc_2eris_output_block procedure, public::type => mqc_eris_array_type + procedure, public::intType => mqc_eris_interaction_type procedure, public::storType => mqc_eris_storage_type procedure, public::swap => mqc_eri_dimension_swap !> \brief Return a specified interaction of a MQC_TwoERIs @@ -362,9 +405,17 @@ Module MQC_EST interface Allocated module procedure mqc_eigenvalues_isAllocated module procedure mqc_integral_isAllocated + module procedure mqc_twoeris_isAllocated module procedure mqc_determinant_isAllocated end interface ! +!> \brief Deallocates an object + interface Deallocate + module procedure mqc_eigenvalues_Deallocate + module procedure mqc_integral_Deallocate + module procedure mqc_twoeris_Deallocate + end interface +! !> \brief Multiplies two objects Interface MatMul Module Procedure MQC_Integral_Matrix_Multiply @@ -1072,30 +1123,39 @@ subroutine mqc_print_twoERIs(twoERIs,iOut,header, & if(twoERIs%hasSpinBlock('aaaa')) & call twoERIs%alpha%print(iout,'(aa|aa)',short_print_threshold=print_threshold) if(twoERIs%hasSpinBlock('bbbb')) & - call twoERIs%beta%print(iout,'(bb|bb)',short_print_threshold=print_threshold) - if((twoERIs%storageType.eq.'coulomb'.or.twoERIs%storageType.eq.'doublebar'& - .or.twoERIs%storageType.eq.'ms'.or.twoERIs%storageType.eq.'symm').and.& - twoERIs%hasSpinBlock('aabb')) & - call twoERIs%alphaBeta%print(iout,'(aa|bb)',short_print_threshold=print_threshold) - if((twoERIs%storageType.eq.'coulomb'.or.twoERIs%storageType.eq.'doublebar'& - .or.twoERIs%storageType.eq.'ms').and.twoERIs%hasSpinBlock('bbaa')) & - call twoERIs%betaAlpha%print(iout,'(bb|aa)',short_print_threshold=print_threshold) - if(((twoERIs%storageType.eq.'exchange').and.twoERIs%hasSpinBlock('aabb'))) & - call twoERIs%alphaBeta%print(iout,'(ab|ba)',short_print_threshold=print_threshold) - if(((twoERIs%storageType.eq.'exchange').and.twoERIs%hasSpinBlock('bbaa'))) & - call twoERIs%betaAlpha%print(iout,'(ba|ab)',short_print_threshold=print_threshold) - if(((twoERIs%storageType.eq.'inverted').and.twoERIs%hasSpinBlock('aabb'))) & - call twoERIs%alphaBeta%print(iout,'(ab|ab)',short_print_threshold=print_threshold) - if(((twoERIs%storageType.eq.'inverted').and.twoERIs%hasSpinBlock('bbaa'))) & - call twoERIs%betaAlpha%print(iout,'(ba|ba)',short_print_threshold=print_threshold) - if(((twoERIs%storageType.eq.'doublebar'.or.twoERIs%storageType.eq.'ms').and.twoERIs%hasSpinBlock('abba'))) & - call twoERIs%abba%print(iout,'(ab|ba)',short_print_threshold=print_threshold) - if(((twoERIs%storageType.eq.'doublebar'.or.twoERIs%storageType.eq.'ms').and.twoERIs%hasSpinBlock('baab'))) & - call twoERIs%abba%print(iout,'(ba|ab)',short_print_threshold=print_threshold) - if((twoERIs%storageType.eq.'ms'.and.twoERIs%hasSpinBlock('abab'))) & - call twoERIs%abab%print(iout,'(ab|ab)',short_print_threshold=print_threshold) - if((twoERIs%storageType.eq.'ms'.and.twoERIs%hasSpinBlock('baba'))) & - call twoERIs%baba%print(iout,'(ba|ba)',short_print_threshold=print_threshold) + call twoERIs%beta%print(iout,'(bb|bb)',short_print_threshold=print_threshold) + if((twoERIs%interactionType.eq.'coulomb'.or.twoERIs%interactionType.eq.'doublebar'& + .or.twoERIs%interactionType.eq.'ms').and.twoERIs%hasSpinBlock('aabb')) & + call twoERIs%alphaBeta%print(iout,'(aa|bb)',short_print_threshold=print_threshold) + if((twoERIs%interactionType.eq.'coulomb'.or.twoERIs%interactionType.eq.'doublebar'& + .or.twoERIs%interactionType.eq.'ms').and.twoERIs%storageType.eq.'full'.and.& + twoERIs%hasSpinBlock('bbaa')) & + call twoERIs%betaAlpha%print(iout,'(bb|aa)',short_print_threshold=print_threshold) + if(twoERIs%interactionType.eq.'exchange'.and.twoERIs%hasSpinBlock('aabb')) then + call twoERIs%alphaBeta%print(iout,'(ab|ba)',short_print_threshold=print_threshold) + elseif((twoERIs%interactionType.eq.'doublebar'.or.twoERIs%interactionType.eq.'ms').and.& + twoERIs%hasSpinBlock('abba')) then + call twoERIs%abba%print(iout,'(ab|ba)',short_print_threshold=print_threshold) + endIf + if(twoERIs%interactionType.eq.'exchange'.and.twoERIs%storageType.eq.'full'.and.& + twoERIs%hasSpinBlock('bbaa')) then + call twoERIs%betaAlpha%print(iout,'(ba|ab)',short_print_threshold=print_threshold) + elseif((twoERIs%interactionType.eq.'doublebar'.or.twoERIs%interactionType.eq.'ms').and.& + twoERIs%storageType.eq.'full'.and.twoERIs%hasSpinBlock('baab')) then + call twoERIs%abba%print(iout,'(ba|ab)',short_print_threshold=print_threshold) + endIf + if(twoERIs%interactionType.eq.'inverted'.and.twoERIs%hasSpinBlock('aabb')) then + call twoERIs%alphaBeta%print(iout,'(ab|ab)',short_print_threshold=print_threshold) + elseif(twoERIs%interactionType.eq.'ms'.and.twoERIs%hasSpinBlock('abab')) then + call twoERIs%abab%print(iout,'(ab|ab)',short_print_threshold=print_threshold) + endIf + if(twoERIs%interactionType.eq.'inverted'.and.twoERIs%storageType.eq.'full'.and.& + twoERIs%hasSpinBlock('bbaa')) then + call twoERIs%betaAlpha%print(iout,'(ba|ba)',short_print_threshold=print_threshold) + elseif(twoERIs%interactionType.eq.'ms'.and.twoERIs%storageType.eq.'full'.and.& + twoERIs%hasSpinBlock('baba')) then + call twoERIs%baba%print(iout,'(ba|ba)',short_print_threshold=print_threshold) + endIf elseIf(trim(twoERIs%integralType).eq.'general') then write(iout,'(A)') 'General MO 2ERIs' if(twoERIs%hasSpinBlock('aaaa')) & @@ -1112,7 +1172,7 @@ subroutine mqc_print_twoERIs(twoERIs,iOut,header, & call twoERIs%abba%print(iout,'(ab|ba)',short_print_threshold=print_threshold) if(twoERIs%storageType.eq.'full'.and.twoERIs%hasSpinBlock('baab')) & call twoERIs%baab%print(iout,'(ba|ab)',short_print_threshold=print_threshold) - if(twoERIs%storageType.eq.'full'.and.twoERIs%hasSpinBlock('abba')) & + if(twoERIs%storageType.eq.'full'.and.twoERIs%hasSpinBlock('baba')) & call twoERIs%baba%print(iout,'(ba|ba)',short_print_threshold=print_threshold) if(twoERIs%hasSpinBlock('aaab')) & call twoERIs%aaab%print(iout,'(aa|ab)',short_print_threshold=print_threshold) @@ -1357,6 +1417,62 @@ Function MQC_Determinant_isAllocated(Determinant) Result(isAllocated) End Function MQC_Determinant_isAllocated ! ! +! PROCEDURE MQC_TwoERIs_isAllocated +! +!> \brief MQC_ERIs_isAllocated is a function that returns TRUE if an MQC +!> TwoERIs object is allocated and FALSE if it is not +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_TwoERIs_isAllocated is a function that returns TRUE if an MQC TwoERIs +!> object is allocated and FALSE if it is not. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] ERIs +!> \verbatim +!> ERIs is Class(MQC_TwoERIs) +!> The name of the MQC_TwoERIs variable. +!> \endverbatim +! +! Authors: +! ======== +!> \author L. M. Thompson +!> \date 2026 +! + Function MQC_TwoERIs_isAllocated(eris) Result(isAllocated) +! + Implicit None + Class(MQC_TwoERIs),Intent(In)::eris + Logical::isAllocated +! + isAllocated = .False. + If(allocated(eris%Alpha)) isAllocated = .True. + If(allocated(eris%Beta)) isAllocated = .True. + If(allocated(eris%AlphaBeta)) isAllocated = .True. + If(allocated(eris%BetaAlpha)) isAllocated = .True. + If(allocated(eris%aaab)) isAllocated = .True. + If(allocated(eris%aaba)) isAllocated = .True. + If(allocated(eris%abaa)) isAllocated = .True. + If(allocated(eris%baaa)) isAllocated = .True. + If(allocated(eris%abab)) isAllocated = .True. + If(allocated(eris%baab)) isAllocated = .True. + If(allocated(eris%baba)) isAllocated = .True. + If(allocated(eris%abba)) isAllocated = .True. + If(allocated(eris%bbba)) isAllocated = .True. + If(allocated(eris%bbab)) isAllocated = .True. + If(allocated(eris%babb)) isAllocated = .True. + If(allocated(eris%abbb)) isAllocated = .True. +! + Return + End Function MQC_TwoERIs_isAllocated +! +! ! PROCEDURE MQC_Integral_Has_Alpha ! !> \brief MQC_Integral_Has_Alpha is a function that returns TRUE if an MQC EST @@ -1829,6 +1945,45 @@ function mqc_eris_array_type(eris) result(arrayType) end function mqc_eris_array_type ! ! +! PROCEDURE MQC_ERIs_Interaction_Type +! +!> \brief MQC_ERIs_Interaction_Type is a function that returns an MQC 2ERIs +!> internal interactionType variable. +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_ERIs_Interaction_Type is a function that returns an MQC 2ERIs +!> internal InteractionType variable. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in,out] ERIs +!> \verbatim +!> Integral is Class(MQC_TwoERIs) +!> The name of the MQC_TwoERIs variable. +!> \endverbatim +! +! Authors: +! ======== +!> \author L. M. Thompson +!> \date 2026 +! + function mqc_eris_interaction_type(eris) result(arrayType) +! + implicit none + class(mqc_twoeris)::eris + Character(Len=64)::arrayType +! + arrayType = eris%interactiontype +! + end function mqc_eris_interaction_type +! +! ! PROCEDURE MQC_ERIs_Storage_Type ! !> \brief MQC_ERIs_Storage_Type is a function that returns an MQC 2ERIs @@ -2643,21 +2798,35 @@ end subroutine mqc_twoeriset_allocate !> MQC_TwoERIs_Allocate is used to allocate a two-electron integral type variable !> of the MQC_twoERIs class. The following options are available: !> -!> 1. StorageType = 'Full' declares the MQC_TwoERIs variable is unpacked. -!> 2. StorageType = 'Symm' declares the MQC_TwoERIs variable is symmetric packed. -!> 3. IntegralType = 'Regular' declares the MQC_TwoERIs variable contains regular +!> 1. StorIntType = 'Full-Coulomb' declares the MQC_TwoERIs contains unpacked +!> Coulomb integrals. +!> 2. StorIntType = 'Full-Exchange' declares the MQC_TwoERIs contains unpacked +!> Exchange integrals. +!> 3. StorIntType = 'Full-Inverted' declares the MQC_TwoERIs contains unpacked +!> Inverted integrals (intermediates required for some operations). +!> 4. StorIntType = 'Full-DoubleBar' declares the MQC_TwoERIs contains unpacked +!> double bar integrals. +!> 5. StorIntType = 'Full-Ms' declares the MQC_TwoERIs contains unpacked +!> Ms integrals (intermediates required for some operations). +!> 6. StorIntType = 'Symm-Coulomb' declares the MQC_TwoERIs contains symmetric +!> packed Coulomb integrals. +!> 7. StorIntType = 'Symm-Exchange' declares the MQC_TwoERIs contains symmetric +!> packed Exchange integrals. +!> 8. StorIntType = 'Symm-DoubleBar' declares the MQC_TwoERIs contains symmetric +!> packed double bar integrals. +!> 9. IntegralType = 'Regular' declares the MQC_TwoERIs variable contains regular !> atomic orbital 2ERIs. -!> 4. IntegralType = 'Raffenetti1' declares the MQC_TwoERIs variable contains +!> 10. IntegralType = 'Raffenetti1' declares the MQC_TwoERIs variable contains !> raffenetti type 1 atomic orbital 2ERIs. -!> 5. IntegralType = 'Raffenetti2 declares the MQC_TwoERIs variable contains +!> 11. IntegralType = 'Raffenetti2 declares the MQC_TwoERIs variable contains !> raffenetti type 2 atomic orbital 2ERIs. -!> 6. IntegralType = 'Raffenetti3' declares the MQC_TwoERIs variable contains +!> 12. IntegralType = 'Raffenetti3' declares the MQC_TwoERIs variable contains !> raffenetti type 3 atomic orbital 2ERIs. -!> 7. IntegralType = 'space' declares the MQC_TwoERIs variable contains restricted +!> 13. IntegralType = 'space' declares the MQC_TwoERIs variable contains restricted !> molecular orbital 2ERIs. -!> 8. IntegralType = 'spin' declares the MQC_TwoERIs variable contains unrestricted +!> 14. IntegralType = 'spin' declares the MQC_TwoERIs variable contains unrestricted !> molecular orbital 2ERIs. -!> 9. IntegralType = 'general' declares the MQC_TwoERIs variable contains general +!> 15. IntegralType = 'general' declares the MQC_TwoERIs variable contains general !> molecular orbital 2ERIs. !> !> \endverbatim @@ -2670,9 +2839,11 @@ end subroutine mqc_twoeriset_allocate !> The MQC_TwoERIs variable to allocate. !> \endverbatim !> -!> \param[in,out] StorageType +!> \param[in,out] StorIntType !> \verbatim -!> StorageType is Character(len=*) +!> StorIntType is Character(len=*) +!> Label consited of a hyphen or other character separated sting. +!> The first part of the string contains the storage flag: !> = 'Full': the MQC_TwoERIs variable is upacked !> = 'Symm': if the MQC_TwoERIs variable is AO (regular, raffenetti) !> or space, then Symm=Full and the assignment is arbitrary, @@ -2686,7 +2857,20 @@ end subroutine mqc_twoeriset_allocate !> [ab|ab]=[ba|ba]*, [ab|ba]=[ba|ab], !> [aa|ab]=[ab|aa]=[aa|ba]*=[ba|aa]*, !> [ab|bb]=[bb|ab]=[bb|ba]*=[ba|bb]* -!> +!> +!> The second par of the string contains the interaction flag. This +!> defaults to coulomb if only the storage flag is present. +!> = 'coulomb': the MQC_TwoERIs variable contains +!> Coulomb integrals. +!> = 'exchange': the MQC_TwoERIs variable contains +!> exchange integrals. +!> = 'inverted': the MQC_TwoERIs variable contains +!> inverted integrals. +!> = 'doublebar': the MQC_TwoERIs variable contains +!> double-bar integral (coulomb minus +!> exchange +!> = 'ms': the MQC_TwoERIs variable contains +!> triplet integrals. !> \endverbatim !> !> \param[in,out] IntegralType @@ -2827,23 +3011,57 @@ end subroutine mqc_twoeriset_allocate !> \author L. M. Thompson, M. M. F. Moraes !> \date 2017, 2026 ! - subroutine mqc_twoeris_allocate(twoERIs,storageType,integralType,alpha, & - beta,alphaBeta,betaAlpha,abab,abba,baab,baba,aaab,aaba,abaa,baaa,bbba, & + subroutine mqc_twoeris_allocate(twoERIs,storIntType,integralType,alpha,beta,& + alphaBeta,betaAlpha,abab,abba,baab,baba,aaab,aaba,abaa,baaa,bbba, & bbab,babb,abbb,allocationVector) ! implicit none class(mqc_twoERIs)::twoERIs - character(len=*)::storageType,integralType + character(len=*)::storIntType,integralType type(mqc_r4tensor),optional::alpha,beta,alphaBeta,betaAlpha,abab,abba,baab, & baba,aaab,aaba,abaa,baaa,bbba,bbab,babb,abbb logical,dimension(16),optional::allocationVector logical,dimension(16)::allocVec integer::i ! - call string_change_case(storageType,'L') + call string_change_case(storIntType,'L') call string_change_case(integralType,'L') - twoERIs%storageType = storageType - twoERIs%integralType = integralType + storIntType = trim(storIntType) + twoERIs%storageType = storIntType(1:4) + if(len(storIntType).eq.4) then + twoERIs%interactionType = 'coulomb' + else + twoERIs%interactionType = storIntType(6:) + endIf + twoERIs%integralType = trim(integralType) + if(twoERIs%storageType.ne.'symm'.and.& + twoERIs%storageType.ne.'full') & + call mqc_error_a('Unrecognized storage type in mqc_twoeris_allocate',6,& + 'twoERIs%storageType',twoERIs%storageType) + if(twoERIs%interactionType.ne.'coulomb'.and.& + twoERIs%interactionType.ne.'exchange'.and.& + twoERIs%interactionType.ne.'inverted'.and.& + twoERIs%interactionType.ne.'doublebar'.and.& + twoERIs%interactionType.ne.'ms') & + call mqc_error_a('Unrecognized interaction type in mqc_twoeris_allocate',6,& + 'twoERIs%interactionType',twoERIs%interactionType) + if(twoERIs%integralType.ne.'regular'.and.& + twoERIs%integralType.ne.'raffenetti1'.and.& + twoERIs%integralType.ne.'raffenetti2'.and.& + twoERIs%integralType.ne.'raffenetti3'.and.& + twoERIs%integralType.ne.'space'.and.& + twoERIs%integralType.ne.'spin'.and.& + twoERIs%integralType.ne.'general') & + call mqc_error_a('Unrecognized integral type in mqc_twoeris_allocate',6,& + 'twoERIs%integralType',twoERIs%integralType) + if((twoERIs%interactionType.eq.'inverted'.or.twoERIs%interactionType.eq.'ms').and.& + twoERIs%storageType.eq.'symm'.and.(twoERIs%integralType.eq.'spin'.or.& + twoERIs%integralType.eq.'general')) & + call mqc_error('Attempting to allocate symmetric packed inverted or ms ERIs in & + &mqc_twoeris_allocate') + if(twoERIs%storageType.ne.'full'.and.(twoERIs%integralType.ne.'spin'.and.& + twoERIs%integralType.ne.'general')) twoERIs%storageType = 'full' + if(present(allocationVector)) then allocVec=allocationVector else @@ -2852,40 +3070,57 @@ subroutine mqc_twoeris_allocate(twoERIs,storageType,integralType,alpha, & end do end if ! - if(integralType.eq.'space'.and.storageType.ne.'full'& - .and.(present(beta).or.& - present(alphaBeta).or.present(betaAlpha))) call mqc_error_A(& - 'Excess spin-r4tensor presented in mqc_twoeris_allocate',6,& - 'integralType',integralType) - if(integralType.eq.'space'.and.storageType.ne.'full'.and.& - (present(abab).or.present(abba).or.present(baab).or.& - present(baba).or.present(aaab).or.present(aaba).or.& - present(abaa).or.present(baaa).or.present(bbba).or.& - present(bbab).or.present(babb).or.present(abbb))) call mqc_error_A(& - 'Excess ladder-r4tensor presented in mqc_twoeris_allocate',6,& - 'integralType',integralType,'storageType',storageType) - if(integralType.eq.'spin'.and.(storageType.eq.'coulomb'.or.& - storageType.eq.'exchange'.or.storageType.eq.'inverted').and.& - (present(abab).or.present(abba).or.present(baab).or.& - present(baba).or.present(aaab).or.present(aaba).or.& - present(abaa).or.present(baaa).or.present(bbba).or.& - present(bbab).or.present(babb).or.present(abbb))) call mqc_error_A(& - 'Excess ladder-r4tensor presented in mqc_twoeris_allocate',6,& - 'integralType',integralType,'storageType',storageType) - if(integralType.eq.'spin'.and.(storageType.eq.'doublebar').and.& - (present(abab).or.& - present(baba).or.present(aaab).or.present(aaba).or.& - present(abaa).or.present(baaa).or.present(bbba).or.& - present(bbab).or.present(babb).or.present(abbb))) call mqc_error_A(& - 'Excess ladder-r4tensor presented in mqc_twoeris_allocate',6,& - 'integralType',integralType,'storageType',storageType) - if(integralType.eq.'spin'.and.(storageType.eq.'ms').and.& - (present(aaab).or.present(aaba).or.& - present(abaa).or.present(baaa).or.present(bbba).or.& - present(bbab).or.present(babb).or.present(abbb))) call mqc_error_A(& - 'Excess ladder-r4tensor presented in mqc_twoeris_allocate',6,& - 'integralType',integralType,'storageType',storageType) - + if(twoERIs%integralType.eq.'space'.and.twoERIs%interactionType.ne.'doublebar'.and.& + (present(beta).or.present(alphaBeta).or.present(betaAlpha).or.& + present(abab).or.present(abba).or.present(baab).or.& + present(baba).or.present(aaab).or.present(aaba).or.& + present(abaa).or.present(baaa).or.present(bbba).or.& + present(bbab).or.present(babb).or.present(abbb))) & + call mqc_error_A('Excess spin blocks in mqc_twoeris_allocate',6,& + 'integralType',twoERIs%integralType,'interactionType',twoERIs%interactionType,& + 'storageType',twoERIs%storageType) + if(twoERIs%integralType.eq.'space'.and.twoERIs%interactionType.eq.'doublebar'.and.& + (present(beta).or.present(betaAlpha).or.present(abab).or.& + present(baab).or.present(baba).or.present(aaab).or.present(aaba).or.& + present(abaa).or.present(baaa).or.present(bbba).or.& + present(bbab).or.present(babb).or.present(abbb))) & + call mqc_error_A('Excess spin blocks in mqc_twoeris_allocate',6,& + 'integralType',twoERIs%integralType,'interactionType',twoERIs%interactionType,& + 'storageType',twoERIs%storageType) + if(twoERIs%integralType.eq.'spin'.and.(twoERIs%interactionType.eq.'coulomb'.or.& + twoERIs%interactionType.eq.'exchange'.or.twoERIs%interactionType.eq.'inverted').and.& + ((twoERIs%storageType.eq.'symm'.and.present(betaAlpha)).or.present(abab).or.& + present(abba).or.present(baab).or.present(baba).or.present(aaab).or.& + present(aaba).or.present(abaa).or.present(baaa).or.present(bbba).or.& + present(bbab).or.present(babb).or.present(abbb))) & + call mqc_error_A('Excess spin blocks in mqc_twoeris_allocate',6,& + 'integralType',twoERIs%integralType,'interactionType',twoERIs%interactionType,& + 'storageType',twoERIs%storageType) + if(twoERIs%integralType.eq.'spin'.and.twoERIs%interactionType.eq.'doublebar'.and.& + ((twoERIs%storageType.eq.'symm'.and.present(betaAlpha)).or.present(abab).or.& + present(abba).or.(twoERIs%storageType.eq.'symm'.and.present(baab)).or.& + present(baba).or.present(aaab).or.present(aaba).or.present(abaa).or.& + present(baaa).or.present(bbba).or.present(bbab).or.present(babb).or.& + present(abbb))) & + call mqc_error_A('Excess spin blocks in mqc_twoeris_allocate',6,& + 'integralType',twoERIs%integralType,'interactionType',twoERIs%interactionType,& + 'storageType',twoERIs%storageType) + if(twoERIs%integralType.eq.'spin'.and.twoERIs%interactionType.eq.'ms'.and.& + ((twoERIs%storageType.eq.'symm'.and.present(betaAlpha)).or.& + (twoERIs%storageType.eq.'symm'.and.present(baab)).or.& + (twoERIs%storageType.eq.'symm'.and.present(baba)).or.present(aaab).or.& + present(aaba).or.present(abaa).or.present(baaa).or.present(bbba).or.& + present(bbab).or.present(babb).or.present(abbb))) & + call mqc_error_A('Excess spin blocks in mqc_twoeris_allocate',6,& + 'integralType',twoERIs%integralType,'interactionType',twoERIs%interactionType,& + 'storageType',twoERIs%storageType) + if(twoERIs%integralType.eq.'general'.and.twoERIs%storageType.eq.'symm'.and.& + (present(betaAlpha).or.present(baab).or.present(baba).or.present(aaba).or.& + present(abaa).or.present(baaa).or.present(bbba).or.present(bbab).or.& + present(babb))) & + call mqc_error_A('Excess spin blocks in mqc_twoeris_allocate',6,& + 'integralType',twoERIs%integralType,'interactionType',twoERIs%interactionType,& + 'storageType',twoERIs%storageType) if(present(alpha).and.allocVec(1)) twoERIs%alpha = alpha if(present(beta).and.allocVec(2)) twoERIs%beta = beta @@ -3333,6 +3568,154 @@ subroutine mqc_eigenvalues_allocate(eigenvalues,arrayName,arrayType,alpha, & end subroutine mqc_eigenvalues_allocate ! ! +! PROCEDURE MQC_Eigenvalues_Deallocate +! +!> \brief MQC_Eigenvalues_Deallocate is used to deallocate a MQC eigenvalues type +!> variable of the MQC_SCF_Eigenvalues class +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_Eigenvalues_Deallocate is used to allocate a MQC SCF eigenvalues type +!> variable of the MQC_SCF_Eigenvalues class. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in,out] Eigenvalues +!> \verbatim +!> Eigenvalues is class(mqc_scf_eigenvalues) +!> The MQC_SCF_Eigenvalues variable to allocate. +!> \endverbatim +!> +! +! Authors: +! ======== +!> \author L. M. Thompson +!> \date 2026 +! + subroutine mqc_eigenvalues_deallocate(eigenvalues) +! + implicit none + class(mqc_scf_eigenvalues)::eigenvalues +! + eigenvalues%array_type = '' + eigenvalues%array_name = '' + if(allocated(eigenvalues%alpha)) call deallocate(eigenvalues%alpha) + if(allocated(eigenvalues%beta)) call deallocate(eigenvalues%beta) +! + end subroutine mqc_eigenvalues_deallocate +! +! +! PROCEDURE MQC_Integral_Deallocate +! +!> \brief MQC_Integra_Deallocate is used to deallocate a MQC SCF integral type +!> variable of the MQC_SCF_Integral class +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_Integral_Deallocate is used to allocate a MQC SCF integral type +!> variable of the MQC_SCF_Integral class. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in,out] Integral +!> \verbatim +!> Integral is class(mqc_scf_integral) +!> The MQC_SCF_Integral variable to allocate. +!> \endverbatim +!> +! +! Authors: +! ======== +!> \author L. M. Thompson +!> \date 2026 +! + subroutine mqc_integral_deallocate(integral) +! + implicit none + class(mqc_scf_integral)::integral +! + integral%array_type = '' + integral%array_name = '' + integral%nARows = 0 + integral%nACols = 0 + integral%nBRows = 0 + integral%nBCols = 0 + if(allocated(integral%Energy_List)) deallocate(integral%Energy_List) + if(allocated(integral%alpha)) call deallocate(integral%alpha) + if(allocated(integral%beta)) call deallocate(integral%beta) + if(allocated(integral%alphaBeta)) call deallocate(integral%alphaBeta) + if(allocated(integral%betaAlpha)) call deallocate(integral%betaAlpha) +! + end subroutine mqc_integral_deallocate +! +! +! PROCEDURE MQC_TwoERIs_Deallocate +! +!> \brief MQC_TwoERIs_Deallocate is used to deallocate a MQC TwoERIs type +!> variable of the MQC_TwoERIs class +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_TwoERIs_Deallocate is used to allocate a MQC TwoERIs type +!> variable of the MQC_TwoERIs class. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in,out] TwoERIs +!> \verbatim +!> TwoERIs is class(mqc_twoeris) +!> The MQC_TwoERIs variable to allocate. +!> \endverbatim +!> +! +! Authors: +! ======== +!> \author L. M. Thompson +!> \date 2026 +! + subroutine mqc_twoeris_deallocate(twoeris) +! + implicit none + class(mqc_twoERIs)::twoERIs +! + twoeris%integralType = '' + twoeris%storageType = '' + twoeris%interactionType = '' + if(allocated(twoeris%alpha)) call deallocate(twoeris%alpha) + if(allocated(twoeris%beta)) call deallocate(twoeris%beta) + if(allocated(twoeris%alphaBeta)) call deallocate(twoeris%alphaBeta) + if(allocated(twoeris%betaAlpha)) call deallocate(twoeris%betaAlpha) + if(allocated(twoeris%aaab)) call deallocate(twoeris%aaab) + if(allocated(twoeris%aaba)) call deallocate(twoeris%aaba) + if(allocated(twoeris%abaa)) call deallocate(twoeris%abaa) + if(allocated(twoeris%baaa)) call deallocate(twoeris%baaa) + if(allocated(twoeris%bbba)) call deallocate(twoeris%bbba) + if(allocated(twoeris%bbab)) call deallocate(twoeris%bbab) + if(allocated(twoeris%babb)) call deallocate(twoeris%babb) + if(allocated(twoeris%abbb)) call deallocate(twoeris%abbb) + if(allocated(twoeris%abba)) call deallocate(twoeris%abba) + if(allocated(twoeris%baab)) call deallocate(twoeris%baab) + if(allocated(twoeris%abab)) call deallocate(twoeris%abab) + if(allocated(twoeris%baba)) call deallocate(twoeris%baba) +! + end subroutine mqc_twoeris_deallocate +! +! ! PROCEDURE MQC_TwoERIs_Transform ! !> \brief MQC_TwoERIs_Transform is used to transform two-electron integral @@ -3468,7 +3851,7 @@ subroutine mqc_twoeris_transform(twoERIs,integralType,mo_coefficients,mo_coeff_2 endDo !$OMP END PARALLEL DO call MQC_Matrix_SymmSymmR4Tensor_Put_Real(aaaa,aaaaLoc) - call mqc_twoeris_allocate(twoERIs,'symm','raffenetti1',aaaa) + call mqc_twoeris_allocate(twoERIs,'full-coulomb','raffenetti1',aaaa) return elseIf(my_integralType.eq.'raffenetti2') then bs = twoERIs%blockSize('alpha',1) @@ -3504,7 +3887,7 @@ subroutine mqc_twoeris_transform(twoERIs,integralType,mo_coefficients,mo_coeff_2 endDo !$OMP END PARALLEL DO call MQC_Matrix_SymmSymmR4Tensor_Put_Real(aaaa,aaaaLoc) - call mqc_twoeris_allocate(twoERIs,'symm','raffenetti2',aaaa) + call mqc_twoeris_allocate(twoERIs,'full-coulomb','raffenetti2',aaaa) return elseIf(my_integralType.eq.'raffenetti3') then bs = twoERIs%blockSize('alpha',1) @@ -3540,7 +3923,7 @@ subroutine mqc_twoeris_transform(twoERIs,integralType,mo_coefficients,mo_coeff_2 endDo !$OMP END PARALLEL DO call MQC_Matrix_SymmSymmR4Tensor_Put_Real(aaaa,aaaaLoc) - call mqc_twoeris_allocate(twoERIs,'symm','raffenetti3',aaaa) + call mqc_twoeris_allocate(twoERIs,'full-coulomb','raffenetti3',aaaa) return elseIf(my_integralType.eq.'molecular') then if(.not.present(mo_coefficients)) call mqc_error_l('MO oefficients must be present to& @@ -4031,17 +4414,12 @@ subroutine mqc_twoERIs_initialize(ERIOut,nAlpha,nBeta,label,& call aaba%init(nAlpha,my_nAlpha2,my_nBeta3,my_nAlpha4) call aaab%init(nAlpha,my_nAlpha2,my_nAlpha3,my_nBeta4) endIf - - - - if (eriType.eq.'empty') then - call mqc_twoeris_allocate(eriOut,'empty','space',aaaa) - else if (eriType.eq.'space') then - call mqc_twoeris_allocate(eriOut,'coulomb','space',aaaa) + if (eriType.eq.'space') then + call mqc_twoeris_allocate(eriOut,'full-coulomb','space',aaaa) elseif (eriType.eq.'spin') then - call mqc_twoeris_allocate(eriOut,'coulob','spin',aaaa,bbbb,aabb,bbaa) + call mqc_twoeris_allocate(eriOut,'full-coulomb','spin',aaaa,bbbb,aabb,bbaa) elseif (eriType.eq.'general') then - call mqc_twoeris_allocate(eriOut,'full','general',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(eriOut,'full-coulomb','general',aaaa,bbbb,aabb,bbaa,& abab,abba,baab,baba,aaab,aaba,abaa,baaa,bbba,& bbab,babb,abbb) endif @@ -5674,27 +6052,102 @@ function mqc_2ERIs_output_block(eris,blockName) result(r4tOut) select case (myBlockName) case('full') - if (eris%type().eq.'regular'.or.eris%type().eq.'raffenetti1'.or. & - eris%type().eq.'raffenetti2'.or.eris%type().eq.'raffenetti3'.or. & - eris%type().eq.'space') then + if (eris%intType().ne.'doublebar'.and.(eris%type().eq.'regular'.or.& + eris%type().eq.'raffenetti1'.or.eris%type().eq.'raffenetti2'.or.& + eris%type().eq.'raffenetti3'.or.eris%type().eq.'space')) then call r4tOut%init(nDimAlpha1,nDimAlpha2,nDimAlpha3,nDimAlpha4) if(eris%hasSpinBlock('aaaa')) call r4tOut%tput(eris%alpha,[1,nDimAlpha1],[1,nDimAlpha2], & [1,nDimAlpha3],[1,nDimAlpha4]) - elseIf (eris%type().eq.'spin') then + elseIf (eris%type().eq.'spin'.or.(eris%type().eq.'space'.and.& + eris%intType().eq.'doublebar')) then call r4tOut%init(nDimTotal1,nDimTotal2,nDimTotal3,nDimTotal4) if(eris%hasSpinBlock('aaaa')) call r4tOut%tput(eris%alpha,[1,nDimAlpha1],[1,nDimAlpha2], & [1,nDimAlpha3],[1,nDimAlpha4]) - if(eris%hasSpinBlock('bbbb')) call r4tOut%tput(eris%beta,[nDimAlpha1+1,nDimTotal1],& + if(eris%type().eq.'space') then + if(eris%hasSpinBlock('aaaa')) call r4tOut%tput(eris%alpha,[nDimAlpha1+1,nDimTotal1],& [nDimAlpha2+1,nDimTotal2],[nDimAlpha3+1,nDimTotal3],[nDimAlpha4+1,nDimTotal4]) - if(eris%hasSpinBlock('aabb')) call r4tOut%tput(eris%alphaBeta,[1,nDimAlpha1],[1,nDimAlpha2], & - [nDimAlpha3+1,nDimTotal3],[nDimAlpha4+1,nDimTotal4]) - if(eris%storageType.eq.'full') then - if(eris%hasSpinBlock('bbaa')) call r4tOut%tput(eris%betaAlpha,[nDimAlpha1+1,nDimTotal1], & - [nDimAlpha2+1,nDimTotal2],[1,nDimAlpha3],[1,nDimAlpha4]) else - if(eris%hasSpinBlock('aabb')) call r4tOut%tput(eris%alphaBeta,[nDimAlpha1+1,nDimTotal1], & - [nDimAlpha2+1,nDimTotal2],[1,nDimAlpha3],[1,nDimAlpha4]) + if(eris%hasSpinBlock('bbbb')) call r4tOut%tput(eris%beta,[nDimAlpha1+1,nDimTotal1],& + [nDimAlpha2+1,nDimTotal2],[nDimAlpha3+1,nDimTotal3],[nDimAlpha4+1,nDimTotal4]) + endIf + if(eris%hasSpinBlock('aabb')) then + select case (eris%intType()) + case('coulomb','doublebar','ms') + call r4tOut%tput(eris%alphaBeta,[1,nDimAlpha1],[1,nDimAlpha2], & + [nDimAlpha3+1,nDimTotal3],[nDimAlpha4+1,nDimTotal4]) + case('exchange') + call r4tOut%tput(eris%alphaBeta,[1,nDimAlpha1],[nDimAlpha2+1,nDimTotal2], & + [nDimAlpha3+1,nDimTotal3],[1,nDimAlpha4]) + case('inverted') + call r4tOut%tput(eris%alphaBeta,[1,nDimAlpha1],[nDimAlpha2+1,nDimTotal2], & + [1,nDimAlpha3],[nDimAlpha4+1,nDimTotal4]) + case default + call mqc_error_a('Unrecognized interaction type in mqc_2ERIs_Output_Block',6,& + 'eris%intType()',eris%intType()) + end select + if(eris%storageType.eq.'symm'.or.eris%type().eq.'space') then + select case (eris%intType()) + case('coulomb','doublebar','ms') + call r4tOut%tput(eris%alphaBeta,[nDimAlpha1+1,nDimTotal1],& + [nDimAlpha2+1,nDimTotal2],[1,nDimAlpha3],[1,nDimAlpha4]) + case('exchange') + call r4tOut%tput(eris%alphaBeta,[nDimAlpha1+1,nDimTotal1],& + [1,nDimTotal2],[1,nDimAlpha3],[nDimAlpha4+1,nDimTotal4]) + case('inverted') + call r4tOut%tput(eris%alphaBeta,[nDimAlpha1+1,nDimTotal1],& + [1,nDimTotal2],[nDimAlpha3+1,nDimTotal3],[1,nDimAlpha4]) + case default + call mqc_error_a('Unrecognized interaction type in mqc_2ERIs_Output_Block',6,& + 'eris%intType()',eris%intType()) + end select + endIf + endIf + if(eris%storageType.eq.'full'.and..not.eris%type().eq.'space'.and.& + eris%hasSpinBlock('bbaa')) then + select case (eris%intType()) + case('coulomb','doublebar','ms') + call r4tOut%tput(eris%betaAlpha,[nDimAlpha1+1,nDimTotal1],& + [nDimAlpha2+1,nDimTotal2],[1,nDimAlpha3],[1,nDimAlpha4]) + case('exchange') + call r4tOut%tput(eris%betaAlpha,[nDimAlpha1+1,nDimTotal1],& + [1,nDimTotal2],[1,nDimAlpha3],[nDimAlpha4+1,nDimTotal4]) + case('inverted') + call r4tOut%tput(eris%betaAlpha,[nDimAlpha1+1,nDimTotal1],& + [1,nDimTotal2],[nDimAlpha3+1,nDimTotal3],[1,nDimAlpha4]) + case default + call mqc_error_a('Unrecognized interaction type in mqc_2ERIs_Output_Block',6,& + 'eris%intType()',eris%intType()) + end select endIf + if((eris%inttype().eq.'doublebar'.or.(eris%inttype().eq.'ms'.and..not.& + eris%type().eq.'space')).and.eris%hasSpinBlock('abba')) then + call r4tOut%tput(eris%abba,[1,nDimAlpha1],[nDimAlpha2+1,nDimTotal2], & + [nDimAlpha3+1,nDimTotal3],[1,nDimAlpha4]) + if(eris%storageType.eq.'symm'.or.eris%type().eq.'space') then + call r4tOut%tput(eris%abba,[nDimAlpha1+1,nDimTotal1],& + [1,nDimTotal2],[1,nDimAlpha3],[nDimAlpha4+1,nDimTotal4]) + endIf + endIf + if(eris%storageType.eq.'full'.and..not.eris%type().eq.'space'.and.& + (eris%inttype().eq.'doublebar'.or.eris%inttype().eq.'ms').and.& + eris%hasSpinBlock('baab')) then + call r4tOut%tput(eris%baab,[nDimAlpha1+1,nDimTotal1],& + [1,nDimTotal2],[1,nDimAlpha3],[nDimAlpha4+1,nDimTotal4]) + endIf + if(eris%inttype().eq.'ms'.and.eris%hasSpinBlock('abab')) then + call r4tOut%tput(eris%abab,[1,nDimAlpha1],[nDimAlpha2+1,nDimTotal2], & + [1,nDimAlpha3],[nDimAlpha4+1,nDimTotal4]) + if(eris%storageType.eq.'symm') then + call r4tOut%tput(eris%abab,[nDimAlpha1+1,nDimTotal1],& + [1,nDimTotal2],[nDimAlpha3+1,nDimTotal3],[1,nDimAlpha4]) + endIf + endIf + if((eris%storageType.eq.'full'.and.eris%inttype().eq.'ms').and.& + eris%hasSpinBlock('baba')) then + call r4tOut%tput(eris%baba,[nDimAlpha1+1,nDimTotal1],& + [1,nDimTotal2],[nDimAlpha3+1,nDimTotal3],[1,nDimAlpha4]) + endIf + elseIf (eris%type().eq.'general') then call r4tOut%init(nDimTotal1,nDimTotal2,nDimTotal3,nDimTotal4) if(eris%hasSpinBlock('aaaa')) call r4tOut%tput(eris%alpha,[1,nDimAlpha1],[1,nDimAlpha2],& @@ -5797,9 +6250,11 @@ function mqc_2ERIs_output_block(eris,blockName) result(r4tOut) call r4tOut%init(NDimBeta1,NDimBeta2,NDimBeta3,NDimBeta4,zeroR) endIf case('alpha-beta','alphabeta','aabb') - If (eris%storageType.eq.'exchange'.or.eris%storageType.eq.'inverted') then + If (eris%type().ne.'general'.and.(eris%intType().eq.'exchange'.or.& + eris%intType().eq.'inverted')) then call r4tOut%init(NDimAlpha1,NDimAlpha2,NDimBeta3,NDimBeta4,zeroR) - elseIf (eris%integralType.eq.'spin') then + elseIf (eris%type().eq.'spin'.or.eris%type().eq.'general'.or.& + (eris%type().eq.'space'.and.eris%inttype().eq.'doublebar')) then if (eris%hasSpinBlock('aabb')) then r4tOut = eris%alphaBeta else @@ -5819,14 +6274,24 @@ function mqc_2ERIs_output_block(eris,blockName) result(r4tOut) call r4tOut%init(NDimAlpha1,NDimAlpha2,NDimBeta3,NDimBeta4,zeroR) endIf case('beta-alpha','betaalpha','bbaa') - If (eris%storageType.eq.'exchange'.or.eris%storageType.eq.'inverted') then + If (eris%type().ne.'general'.and.(eris%intType().eq.'exchange'.or.& + eris%intType().eq.'inverted')) then call r4tOut%init(NDimBeta1,NDimBeta2,NDimAlpha3,NDimAlpha4,zeroR) - elseIf (eris%integralType.eq.'spin') then - if (eris%hasSpinBlock('bbaa')) then - r4tOut = eris%betaAlpha - else - call r4tOut%init(NDimBeta1,NDimBeta2,NDimAlpha3,NDimAlpha4,zeroR) - end if + elseIf (eris%type().eq.'spin'.or.eris%type().eq.'general'.or.& + (eris%type().eq.'space'.and.eris%inttype().eq.'doublebar')) then + if(eris%stortype().eq.'symm') then + if (eris%hasSpinBlock('aabb')) then + r4tOut = eris%alphaBeta + else + call r4tOut%init(NDimBeta1,NDimBeta2,NDimAlpha3,NDimAlpha4,zeroR) + endIf + elseif(eris%stortype().eq.'full') then + if (eris%hasSpinBlock('bbaa')) then + r4tOut = eris%betaAlpha + else + call r4tOut%init(NDimBeta1,NDimBeta2,NDimAlpha3,NDimAlpha4,zeroR) + end if + endIf elseIf (eris%type().eq.'regular'.or.eris%type().eq.'raffenetti1'.or. & eris%type().eq.'raffenetti2'.or.eris%type().eq.'raffenetti3'.or. & eris%type().eq.'space') then @@ -5841,27 +6306,22 @@ function mqc_2ERIs_output_block(eris,blockName) result(r4tOut) call r4tOut%init(NDimBeta1,NDimBeta2,NDimAlpha3,NDimAlpha4,zeroR) endIf case('abab') - If (eris%storageType.eq.'inverted') then - If (eris%type().eq.'regular'.or.eris%type().eq.'raffenetti1'.or. & + If (eris%type().ne.'general'.and.(eris%intType().eq.'coulomb'.or.& + eris%intType().eq.'exchange'.or.eris%intType().eq.'doublebar')) then + call r4tOut%init(NDimAlpha1,NDimBeta2,NDimAlpha3,NDimBeta4,zeroR) + elseIf (eris%type().eq.'regular'.or.eris%type().eq.'raffenetti1'.or. & eris%type().eq.'raffenetti2'.or.eris%type().eq.'raffenetti3'.or. & eris%type().eq.'space') then - If (eris%hasSpinBlock('aaaa')) then - r4tOut = eris%alpha - else - call r4tOut%init(NDimAlpha1,NDimBeta2,NDimAlpha3,NDimBeta4,zeroR) - endIf - elseIf (eris%type().eq.'spin') then - If (eris%hasSpinBlock('aabb')) then - r4tOut = eris%alphaBeta - else - call r4tOut%init(NDimAlpha1,NDimBeta2,NDimAlpha3,NDimBeta4,zeroR) - endIf + If (eris%hasSpinBlock('aaaa')) then + r4tOut = eris%alpha else - If (eris%hasSpinBlock('abab')) then - r4tOut = eris%abab - else - call r4tOut%init(NDimAlpha1,NDimBeta2,NDimAlpha3,NDimBeta4,zeroR) - endIf + call r4tOut%init(NDimAlpha1,NDimBeta2,NDimAlpha3,NDimBeta4,zeroR) + endIf + elseIf (eris%type().eq.'spin') then + If (eris%hasSpinBlock('aabb')) then + r4tOut = eris%alphaBeta + else + call r4tOut%init(NDimAlpha1,NDimBeta2,NDimAlpha3,NDimBeta4,zeroR) endIf elseIf (eris%hasSpinBlock('abab')) then r4tOut = eris%abab @@ -5869,88 +6329,106 @@ function mqc_2ERIs_output_block(eris,blockName) result(r4tOut) call r4tOut%init(NDimAlpha1,NDimBeta2,NDimAlpha3,NDimBeta4,zeroR) endIf case('abba') - If (eris%storageType.eq.'exchange') then - If (eris%type().eq.'regular'.or.eris%type().eq.'raffenetti1'.or. & + If (eris%type().ne.'general'.and.(eris%intType().eq.'coulomb'.or.& + eris%intType().eq.'inverted')) then + call r4tOut%init(NDimAlpha1,NDimBeta2,NDimBeta3,NDimAlpha4,zeroR) + elseIf (eris%type().eq.'regular'.or.eris%type().eq.'raffenetti1'.or. & eris%type().eq.'raffenetti2'.or.eris%type().eq.'raffenetti3'.or. & - eris%type().eq.'space') then - If (eris%hasSpinBlock('aaaa')) then - r4tOut = eris%alpha - else - call r4tOut%init(NDimAlpha1,NDimBeta2,NDimBeta3,NDimAlpha4,zeroR) - endIf - elseIf (eris%type().eq.'spin') then - If (eris%hasSpinBlock('aabb')) then - r4tOut = eris%alphaBeta - else - call r4tOut%init(NDimAlpha1,NDimBeta2,NDimBeta3,NDimAlpha4,zeroR) - endIf + (eris%type().eq.'space'.and.eris%inttype().ne.'doublebar')) then + If (eris%hasSpinBlock('aaaa')) then + r4tOut = eris%alpha else - If (eris%hasSpinBlock('abba')) then - r4tOut = eris%abba - else - call r4tOut%init(NDimAlpha1,NDimBeta2,NDimBeta3,NDimAlpha4,zeroR) - endIf + call r4tOut%init(NDimAlpha1,NDimBeta2,NDimBeta3,NDimAlpha4,zeroR) + endIf + elseIf (eris%type().eq.'spin'.and.eris%inttype().eq.'exchange') then + If (eris%hasSpinBlock('aabb')) then + r4tOut = eris%alphaBeta + else + call r4tOut%init(NDimAlpha1,NDimBeta2,NDimBeta3,NDimAlpha4,zeroR) endIf - elseIf (eris%hasSpinBlock('abba')) then - r4tOut = eris%abba else - call r4tOut%init(NDimAlpha1,NDimBeta2,NDimBeta3,NDimAlpha4,zeroR) + If (eris%hasSpinBlock('abba')) then + r4tOut = eris%abba + else + call r4tOut%init(NDimAlpha1,NDimBeta2,NDimBeta3,NDimAlpha4,zeroR) + endIf endIf case('baab') - If (eris%storageType.eq.'exchange') then - If (eris%type().eq.'regular'.or.eris%type().eq.'raffenetti1'.or. & + If (eris%type().ne.'general'.and.(eris%intType().eq.'coulomb'.or.& + eris%intType().eq.'inverted')) then + call r4tOut%init(NDimAlpha1,NDimBeta2,NDimBeta3,NDimAlpha4,zeroR) + elseIf (eris%type().eq.'regular'.or.eris%type().eq.'raffenetti1'.or. & eris%type().eq.'raffenetti2'.or.eris%type().eq.'raffenetti3'.or. & - eris%type().eq.'space') then - If (eris%hasSpinBlock('aaaa')) then - r4tOut = eris%alpha - else - call r4tOut%init(NDimBeta1,NDimAlpha2,NDimAlpha3,NDimBeta4,zeroR) - endIf - elseIf (eris%type().eq.'spin') then + (eris%type().eq.'space'.and.eris%inttype().ne.'doublebar')) then + If (eris%hasSpinBlock('aaaa')) then + r4tOut = eris%alpha + else + call r4tOut%init(NDimBeta1,NDimAlpha2,NDimAlpha3,NDimBeta4,zeroR) + endIf + elseIf (eris%type().eq.'spin'.and.eris%inttype().eq.'exchange') then + If(eris%storType().eq.'full') then If (eris%hasSpinBlock('bbaa')) then r4tOut = eris%betaAlpha else call r4tOut%init(NDimBeta1,NDimAlpha2,NDimAlpha3,NDimBeta4,zeroR) endIf - else - If (eris%hasSpinBlock('baab')) then - r4tOut = eris%baab + elseIf(eris%storType().eq.'symm') then + If (eris%hasSpinBlock('aabb')) then + r4tOut = eris%alphaBeta else call r4tOut%init(NDimBeta1,NDimAlpha2,NDimAlpha3,NDimBeta4,zeroR) endIf endIf + elseIf(eris%storType().eq.'symm'.or.(eris%type().eq.'space'.and.& + eris%inttype().eq.'doublebar')) then + If (eris%hasSpinBlock('abba')) then + r4tOut = eris%abba + else + call r4tOut%init(NDimBeta1,NDimAlpha2,NDimAlpha3,NDimBeta4,zeroR) + endIf elseIf (eris%hasSpinBlock('baab')) then r4tOut = eris%baab else call r4tOut%init(NDimBeta1,NDimAlpha2,NDimAlpha3,NDimBeta4,zeroR) endIf case('baba') - If (eris%storageType.eq.'inverted') then - If (eris%type().eq.'regular'.or.eris%type().eq.'raffenetti1'.or. & + If (eris%type().ne.'general'.and.(eris%intType().eq.'coulomb'.or.& + eris%intType().eq.'exchange'.or.eris%intType().eq.'doublebar')) then + call r4tOut%init(NDimBeta1,NDimAlpha2,NDimBeta3,NDimAlpha4,zeroR) + elseIf (eris%type().eq.'regular'.or.eris%type().eq.'raffenetti1'.or. & eris%type().eq.'raffenetti2'.or.eris%type().eq.'raffenetti3'.or. & eris%type().eq.'space') then - If (eris%hasSpinBlock('aaaa')) then - r4tOut = eris%alpha - else - call r4tOut%init(NDimBeta1,NDimAlpha2,NDimBeta3,NDimAlpha4,zeroR) - endIf - elseIf (eris%type().eq.'spin') then + If (eris%hasSpinBlock('aaaa')) then + r4tOut = eris%alpha + else + call r4tOut%init(NDimBeta1,NDimAlpha2,NDimBeta3,NDimAlpha4,zeroR) + endIf + elseIf (eris%type().eq.'spin'.and.eris%intType().eq.'inverted') then + If(eris%storType().eq.'full') then If (eris%hasSpinBlock('bbaa')) then r4tOut = eris%betaAlpha else call r4tOut%init(NDimBeta1,NDimAlpha2,NDimBeta3,NDimAlpha4,zeroR) endIf - else - If (eris%hasSpinBlock('baba')) then - r4tOut = eris%baba + elseIf(eris%storType().eq.'symm') then + If (eris%hasSpinBlock('aabb')) then + r4tOut = eris%alphaBeta else call r4tOut%init(NDimBeta1,NDimAlpha2,NDimBeta3,NDimAlpha4,zeroR) endIf endIf - elseIf (eris%hasSpinBlock('baba')) then - r4tOut = eris%baba + elseIf(eris%storType().eq.'symm') then + If (eris%hasSpinBlock('abab')) then + r4tOut = eris%abab + else + call r4tOut%init(NDimBeta1,NDimAlpha2,NDimBeta3,NDimAlpha4,zeroR) + endIf else - call r4tOut%init(NDimBeta1,NDimAlpha2,NDimBeta3,NDimAlpha4,zeroR) + If (eris%hasSpinBlock('baba')) then + r4tOut = eris%baba + else + call r4tOut%init(NDimBeta1,NDimAlpha2,NDimBeta3,NDimAlpha4,zeroR) + endIf endIf case('aaab') if (eris%type().eq.'general'.and.eris%hasSpinBlock('aaab')) then @@ -7641,10 +8119,10 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) type(mqc_r4tensor)::aaaa,bbbb,aabb,bbaa,abab,abba,baab,baba,& aaab,aaba,abaa,baaa,bbba,bbab,babb,abbb ! - if(ERIA%integraltype.eq.'empty') then + if(.not.allocated(ERIA)) then ERIOut = ERIB return - elseif(ERIB%integraltype.eq.'empty') then + elseif(.not.allocated(ERIB)) then ERIOut = ERIA return end if @@ -7652,84 +8130,84 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) case('space') select case (ERIB%integraltype) case('space') - select case(ERIA%storType()) + select case(ERIA%intType()) case('coulomb') - select case(ERIB%storType()) + select case(ERIB%intType()) case('coulomb') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') - call mqc_twoeris_allocate(ERIOut,'coulomb','space',aaaa) + call mqc_twoeris_allocate(ERIOut,'full-coulomb','space',aaaa) case('exchange') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') aabb = ERIA%getBlock('aaaa') abba = ERIB%getBlock('aaaa') - call mqc_twoeris_allocate(ERIOut,'doublebar','spin',& + call mqc_twoeris_allocate(ERIOut,'full-doublebar','spin',& aaaa,aaaa,aabb,bbaa,abba=abba,baab=baab) case('inverted') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') aabb = ERIA%getBlock('aaaa') abab = ERIB%getBlock('aaaa') - call mqc_twoeris_allocate(ERIOut,'ms','spin',& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',& aaaa,aaaa,aabb,bbaa,baba=baba,abab=abab) case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & - 'ERIB%istoragetype', ERIB%stortype() ) + 'ERIB%inttype', ERIB%inttype() ) end select case('exchange') - select case(ERIB%storType()) + select case(ERIB%intType()) case('coulomb') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') aabb = ERIB%getBlock('aaaa') abba = ERIA%getBlock('aaaa') - call mqc_twoeris_allocate(ERIOut,'doublebar','spin',& + call mqc_twoeris_allocate(ERIOut,'full-doublebar','spin',& aaaa,aaaa,aabb,bbaa,abba=abba,baab=baab) case('exchange') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') - call mqc_twoeris_allocate(ERIOut,'exchange','space',aaaa) + call mqc_twoeris_allocate(ERIOut,'full-exchange','space',aaaa) case('inverted') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') abba = ERIA%getBlock('aaaa') abab = ERIB%getBlock('aaaa') - call mqc_twoeris_allocate(ERIOut,'ms','spin',& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',& aaaa,aaaa,abba=abba,baab=baab,baba=baba,abab=abab) case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & - 'ERIB%istoragetype', ERIB%stortype() ) + 'ERIB%inttype', ERIB%inttype() ) end select case('inverted') - select case(ERIB%storType()) + select case(ERIB%intType()) case('coulomb') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') aabb = ERIB%getBlock('aaaa') abab = ERIA%getBlock('aaaa') - call mqc_twoeris_allocate(ERIOut,'ms','spin',& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',& aaaa,aaaa,aabb,bbaa,baba=baba,abab=abab) case('exchange') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') abba = ERIB%getBlock('aaaa') abab = ERIA%getBlock('aaaa') - call mqc_twoeris_allocate(ERIOut,'ms','spin',& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',& aaaa,aaaa,abba=abba,baab=baab,baba=baba,abab=abab) case('inverted') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') - call mqc_twoeris_allocate(ERIOut,'inverted','space',aaaa) + call mqc_twoeris_allocate(ERIOut,'full-inverted','space',aaaa) case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & - 'ERIB%istoragetype', ERIB%stortype() ) + 'ERIB%inttype', ERIB%inttype() ) end select case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & - 'ERIA%istoragetype', ERIA%stortype() ) + 'ERIA%inttype', ERIA%inttype() ) end select case('spin') - select case(ERIA%storType()) + select case(ERIA%intType()) case('coulomb') - select case(ERIB%storType()) + select case(ERIB%intType()) case('coulomb') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('aaaa')+ERIB%getBlock('bbbb') aabb = ERIA%getBlock('aaaa')+ERIB%getBlock('aabb') bbaa = ERIA%getBlock('aaaa')+ERIB%getBlock('bbaa') - call mqc_twoeris_allocate(ERIOut,'coulomb','spin',aaaa,bbbb,aabb,bbaa) + call mqc_twoeris_allocate(ERIOut,'full-coulomb','spin',aaaa,bbbb,aabb,bbaa) case('exchange') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('aaaa')+ERIB%getBlock('bbbb') @@ -7737,7 +8215,7 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) aabb = ERIA%getBlock('aaaa') abba = ERIB%getBlock('abba') baab = ERIB%getBlock('baab') - call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-doublebar','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab) case('inverted') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') @@ -7746,7 +8224,7 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) aabb = ERIA%getBlock('aaaa') abab = ERIB%getBlock('abab') baba = ERIB%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abab=abab,baba=baba) case('doublebar') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') @@ -7755,7 +8233,7 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) aabb = ERIA%getBlock('aaaa')+ERIB%getBlock('aabb') abba = ERIB%getBlock('abba') baab = ERIB%getBlock('baab') - call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-doublebar','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab) case('ms') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') @@ -7766,14 +8244,14 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) baab = ERIB%getBlock('baab') abab = ERIB%getBlock('abab') baba = ERIB%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-doublebar','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab,abab=abab,baba=baba) case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & - 'ERIB%istoragetype', ERIB%stortype()) + 'ERIB%inttype', ERIB%inttype()) end select case('exchange') - select case(ERIB%storType()) + select case(ERIB%intType()) case('coulomb') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('aaaa')+ERIB%getBlock('bbbb') @@ -7781,14 +8259,14 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) aabb = ERIB%getBlock('aaaa') abba = ERIA%getBlock('abba') baab = ERIA%getBlock('baab') - call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-doublebar','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab) case('exchange') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('aaaa')+ERIB%getBlock('bbbb') aabb = ERIA%getBlock('aaaa')+ERIB%getBlock('abba') bbaa = ERIA%getBlock('aaaa')+ERIB%getBlock('abba') - call mqc_twoeris_allocate(ERIOut,'exchange','spin',aaaa,bbbb,aabb,bbaa) + call mqc_twoeris_allocate(ERIOut,'full-exchange','spin',aaaa,bbbb,aabb,bbaa) case('inverted') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('aaaa')+ERIB%getBlock('bbbb') @@ -7796,7 +8274,7 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) abba = ERIA%getBlock('aaaa') abab = ERIB%getBlock('abab') baba = ERIB%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,& abba=abba,baab=baab,abab=abab,baba=baba) case('doublebar') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') @@ -7805,7 +8283,7 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) baab = ERIA%getBlock('aaaa')+ERIB%getBlock('baab') bbaa = ERIB%getBlock('bbaa') aabb = ERIB%getBlock('aabb') - call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-doublebar','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab) case('ms') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') @@ -7816,14 +8294,14 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) baab = ERIA%getBlock('aaaa')+ERIB%getBlock('baab') abab = ERIB%getBlock('abab') baba = ERIB%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-doublebar','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab,abab=abab,baba=baba) case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & - 'ERIB%istoragetype', ERIB%stortype() ) + 'ERIB%inttype', ERIB%inttype() ) end select case('inverted') - select case(ERIB%storType()) + select case(ERIB%intType()) case('coulomb') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('aaaa')+ERIB%getBlock('bbbb') @@ -7831,7 +8309,7 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) aabb = ERIB%getBlock('aabb') abab = ERIA%getBlock('aaaa') baba = ERIA%getBlock('aaaa') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abab=abab,baba=baba) case('exchange') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') @@ -7840,14 +8318,14 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) abba = ERIB%getBlock('abba') abab = ERIA%getBlock('aaaa') baba = ERIA%getBlock('aaaa') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,& abba=abba,baab=baab,abab=abab,baba=baba) case('inverted') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('aaaa')+ERIB%getBlock('bbbb') aabb = ERIA%getBlock('aaaa')+ERIB%getBlock('abab') bbaa = ERIA%getBlock('aaaa')+ERIB%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'inverted','spin',aaaa,bbbb,& + call mqc_twoeris_allocate(ERIOut,'full-inverted','spin',aaaa,bbbb,& abab,baba) case('doublebar') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') @@ -7858,7 +8336,7 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) aabb = ERIB%getBlock('aabb') abab = ERIA%getBlock('aaaa') baba = ERIA%getBlock('aaaa') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab,abab=abab,baba=baba) case('ms') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') @@ -7869,20 +8347,20 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) aabb = ERIB%getBlock('aabb') abab = ERIA%getBlock('aaaa')+ERIB%getBlock('abab') baba = ERIA%getBlock('aaaa')+ERIB%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab,abab=abab,baba=baba) case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & - 'ERIB%istoragetype', ERIB%stortype() ) + 'ERIB%inttype', ERIB%inttype() ) end select case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & - 'ERIA%istoragetype', ERIA%stortype() ) + 'ERIA%inttype', ERIA%inttype() ) end select case('general') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('aaaa')+ERIB%getBlock('bbbb') - select case(ERIA%storType()) + select case(ERIA%intType()) case('coulomb') aabb = ERIA%getBlock('aaaa')+ERIB%getBlock('aabb') bbaa = ERIA%getBlock('aaaa')+ERIB%getBlock('bbaa') @@ -7906,9 +8384,10 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) abba = ERIB%getBlock('abba') case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & - 'ERIA%storagetype', ERIA%stortype() ) + 'ERIA%inttype', ERIA%inttype() ) end select - call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& + !LMTLMT THINK ABOUT THIS ASSIGNMENT PROPERLY + call mqc_twoeris_allocate(ERIOut,'full-coulomb','general',aaaa,bbbb,& aabb,bbaa,& abab,abba,& baab,baba,& @@ -7923,15 +8402,15 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) case('spin') select case (ERIB%integraltype) case('space') - select case(ERIA%storType()) + select case(ERIA%intType()) case('coulomb') - select case(ERIB%storType()) + select case(ERIB%intType()) case('coulomb') aaaa = ERIB%getBlock('aaaa')+ERIA%getBlock('aaaa') bbbb = ERIB%getBlock('aaaa')+ERIA%getBlock('bbbb') aabb = ERIB%getBlock('aaaa')+ERIA%getBlock('aabb') bbaa = ERIB%getBlock('aaaa')+ERIA%getBlock('bbaa') - call mqc_twoeris_allocate(ERIOut,'coulomb','spin',aaaa,bbbb,aabb,bbaa) + call mqc_twoeris_allocate(ERIOut,'full-coulomb','spin',aaaa,bbbb,aabb,bbaa) case('exchange') aaaa = ERIB%getBlock('aaaa')+ERIA%getBlock('aaaa') bbbb = ERIB%getBlock('aaaa')+ERIA%getBlock('bbbb') @@ -7939,7 +8418,7 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) aabb = ERIB%getBlock('aaaa') abba = ERIA%getBlock('abba') baab = ERIA%getBlock('baab') - call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-doublebar','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab) case('inverted') aaaa = ERIB%getBlock('aaaa')+ERIA%getBlock('aaaa') @@ -7948,14 +8427,14 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) aabb = ERIB%getBlock('aaaa') abab = ERIA%getBlock('abab') baba = ERIA%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abab=abab,baba=baba) case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & - 'ERIB%itoragetype', ERIB%stortype() ) + 'ERIB%inttype', ERIB%inttype() ) end select case('exchange') - select case(ERIB%storType()) + select case(ERIB%intType()) case('coulomb') aaaa = ERIB%getBlock('aaaa')+ERIA%getBlock('aaaa') bbbb = ERIB%getBlock('aaaa')+ERIA%getBlock('bbbb') @@ -7963,14 +8442,14 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) aabb = ERIA%getBlock('aaaa') abba = ERIB%getBlock('abba') baab = ERIB%getBlock('baab') - call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-doublebar','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab) case('exchange') aaaa = ERIB%getBlock('aaaa')+ERIA%getBlock('aaaa') bbbb = ERIB%getBlock('aaaa')+ERIA%getBlock('bbbb') aabb = ERIB%getBlock('aaaa')+ERIA%getBlock('abba') bbaa = ERIB%getBlock('aaaa')+ERIA%getBlock('abba') - call mqc_twoeris_allocate(ERIOut,'exchange','spin',aaaa,bbbb,aabb,bbaa) + call mqc_twoeris_allocate(ERIOut,'full-exchange','spin',aaaa,bbbb,aabb,bbaa) case('inverted') aaaa = ERIB%getBlock('aaaa')+ERIA%getBlock('aaaa') bbbb = ERIB%getBlock('aaaa')+ERIA%getBlock('bbbb') @@ -7978,14 +8457,14 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) abba = ERIB%getBlock('aaaa') abab = ERIA%getBlock('abab') baba = ERIA%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,& abba=abba,baab=baab,abab=abab,baba=baba) case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & - 'ERIB%itoragetype', ERIB%stortype() ) + 'ERIB%inttype', ERIB%inttype() ) end select case('inverted') - select case(ERIB%storType()) + select case(ERIB%intType()) case('coulomb') aaaa = ERIB%getBlock('aaaa')+ERIA%getBlock('aaaa') bbbb = ERIB%getBlock('aaaa')+ERIA%getBlock('bbbb') @@ -7993,7 +8472,7 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) aabb = ERIA%getBlock('aabb') abab = ERIB%getBlock('aaaa') baba = ERIB%getBlock('aaaa') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abab=abab,baba=baba) case('exchange') aaaa = ERIB%getBlock('aaaa')+ERIA%getBlock('aaaa') @@ -8002,21 +8481,21 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) abba = ERIA%getBlock('abba') abab = ERIB%getBlock('aaaa') baba = ERIB%getBlock('aaaa') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,& abba=abba,baab=baab,abab=abab,baba=baba) case('inverted') aaaa = ERIB%getBlock('aaaa')+ERIA%getBlock('aaaa') bbbb = ERIB%getBlock('aaaa')+ERIA%getBlock('bbbb') aabb = ERIB%getBlock('aaaa')+ERIA%getBlock('abab') bbaa = ERIB%getBlock('aaaa')+ERIA%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'inverted','spin',aaaa,bbbb,& + call mqc_twoeris_allocate(ERIOut,'full-inverted','spin',aaaa,bbbb,& abab,baba) case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & - 'ERIB%itoragetype', ERIB%stortype() ) + 'ERIB%inttype', ERIB%inttype() ) end select case('doublebar') - select case(ERIB%storType()) + select case(ERIB%intType()) case('coulomb') aaaa = ERIB%getBlock('aaaa')+ERIA%getBlock('aaaa') bbbb = ERIB%getBlock('aaaa')+ERIA%getBlock('bbbb') @@ -8024,7 +8503,7 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) aabb = ERIB%getBlock('aaaa')+ERIA%getBlock('aabb') abba = ERIA%getBlock('abba') baab = ERIA%getBlock('baab') - call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-doublebar','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab) case('exchange') aaaa = ERIB%getBlock('aaaa')+ERIA%getBlock('aaaa') @@ -8033,7 +8512,7 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) baab = ERIB%getBlock('aaaa')+ERIA%getBlock('baab') bbaa = ERIA%getBlock('bbaa') aabb = ERIA%getBlock('aabb') - call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-doublebar','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab) case('inverted') aaaa = ERIB%getBlock('aaaa')+ERIA%getBlock('aaaa') @@ -8044,14 +8523,14 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) aabb = ERIA%getBlock('aabb') abab = ERIB%getBlock('aaaa') baba = ERIB%getBlock('aaaa') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab,abab=abab,baba=baba) case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & - 'ERIB%itoragetype', ERIB%stortype() ) + 'ERIB%inttype', ERIB%inttype() ) end select case('ms') - select case(ERIB%storType()) + select case(ERIB%intType()) case('coulomb') aaaa = ERIB%getBlock('aaaa')+ERIA%getBlock('aaaa') bbbb = ERIB%getBlock('aaaa')+ERIA%getBlock('bbbb') @@ -8061,7 +8540,7 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) baab = ERIA%getBlock('baab') abab = ERIA%getBlock('abab') baba = ERIA%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab,abab=abab,baba=baba) case('exchange') aaaa = ERIB%getBlock('aaaa')+ERIA%getBlock('aaaa') @@ -8072,7 +8551,7 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) baab = ERIB%getBlock('aaaa')+ERIA%getBlock('baab') abab = ERIA%getBlock('abab') baba = ERIA%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab,abab=abab,baba=baba) case('inverted') aaaa = ERIB%getBlock('aaaa')+ERIA%getBlock('aaaa') @@ -8083,26 +8562,26 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) aabb = ERIA%getBlock('aabb') abab = ERIB%getBlock('aaaa')+ERIA%getBlock('abab') baba = ERIB%getBlock('aaaa')+ERIA%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab,abab=abab,baba=baba) case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & - 'ERIB%itoragetype', ERIB%stortype() ) + 'ERIB%inttype', ERIB%inttype() ) end select case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & - 'ERIA%storagetype', ERIA%stortype() ) + 'ERIA%inttype', ERIA%inttype() ) end select case('spin') - select case(ERIA%storType()) + select case(ERIA%intType()) case('coulomb') - select case(ERIB%storType()) + select case(ERIB%intType()) case('coulomb') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') aabb = ERIA%getBlock('aabb')+ERIB%getBlock('aabb') bbaa = ERIA%getBlock('bbaa')+ERIB%getBlock('bbaa') - call mqc_twoeris_allocate(ERIOut,'coulomb','spin',aaaa,bbbb,aabb,bbaa) + call mqc_twoeris_allocate(ERIOut,'full-coulomb','spin',aaaa,bbbb,aabb,bbaa) case('exchange') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') @@ -8110,7 +8589,7 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) aabb = ERIA%getBlock('aabb') abba = ERIB%getBlock('abba') baab = ERIB%getBlock('baab') - call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-doublebar','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab) case('inverted') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') @@ -8119,7 +8598,7 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) aabb = ERIA%getBlock('aabb') abab = ERIB%getBlock('abab') baba = ERIB%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abab=abab,baba=baba) case('doublebar') aaaa = ERIB%getBlock('aaaa')+ERIA%getBlock('aaaa') @@ -8128,7 +8607,7 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) aabb = ERIB%getBlock('aabb')+ERIA%getBlock('aabb') abba = ERIB%getBlock('abba') baab = ERIB%getBlock('baab') - call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-doublebar','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab) case('ms') aaaa = ERIB%getBlock('aaaa')+ERIA%getBlock('aaaa') @@ -8139,14 +8618,14 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) baab = ERIB%getBlock('baab') abab = ERIB%getBlock('abab') baba = ERIB%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab,abab=abab,baba=baba) case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & - 'ERIB%storagetype', ERIB%stortype() ) + 'ERIB%inttype', ERIB%inttype() ) end select case('exchange') - select case(ERIB%storType()) + select case(ERIB%intType()) case('coulomb') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') @@ -8154,14 +8633,14 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) aabb = ERIB%getBlock('aabb') abba = ERIA%getBlock('abba') baab = ERIA%getBlock('baab') - call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-doublebar','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab) case('exchange') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') aabb = ERIA%getBlock('abba')+ERIB%getBlock('abba') bbaa = ERIA%getBlock('baab')+ERIB%getBlock('baab') - call mqc_twoeris_allocate(ERIOut,'exchange','spin',aaaa,bbbb,aabb,bbaa) + call mqc_twoeris_allocate(ERIOut,'full-exchange','spin',aaaa,bbbb,aabb,bbaa) case('inverted') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') @@ -8169,7 +8648,7 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) baab = ERIA%getBlock('baab') abab = ERIB%getBlock('abab') baba = ERIB%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,& abba=abba,baab=baab,abab=abab,baba=baba) case('doublebar') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') @@ -8178,7 +8657,7 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) aabb = ERIB%getBlock('aabb') abba = ERIA%getBlock('abba')+ERIB%getBlock('abba') baab = ERIA%getBlock('baab')+ERIB%getBlock('baab') - call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-doublebar','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab) case('ms') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') @@ -8189,14 +8668,14 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) baab = ERIA%getBlock('baab')+ERIB%getBlock('baab') abab = ERIB%getBlock('abab') baba = ERIB%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab,abab=abab,baba=baba) case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & - 'ERIB%storagetype', ERIB%stortype() ) + 'ERIB%inttype', ERIB%inttype() ) end select case('inverted') - select case(ERIB%storType()) + select case(ERIB%intType()) case('coulomb') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') @@ -8204,7 +8683,7 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) aabb = ERIB%getBlock('aabb') abab = ERIA%getBlock('abab') baba = ERIA%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abab=abab,baba=baba) case('exchange') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') @@ -8213,14 +8692,14 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) baab = ERIB%getBlock('baab') abab = ERIA%getBlock('abab') baba = ERIA%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,& abba=abba,baab=baab,abab=abab,baba=baba) case('inverted') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') aabb = ERIA%getBlock('abab')+ERIB%getBlock('abab') bbaa = ERIA%getBlock('abab')+ERIB%getBlock('abab') - call mqc_twoeris_allocate(ERIOut,'inverted','spin',aaaa,bbbb,aabb,bbaa) + call mqc_twoeris_allocate(ERIOut,'full-inverted','spin',aaaa,bbbb,aabb,bbaa) case('doublebar') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') @@ -8230,7 +8709,7 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) baab = ERIB%getBlock('baab') abab = ERIA%getBlock('abab') baba = ERIA%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab,abab=abab,baba=baba) case('ms') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') @@ -8241,14 +8720,14 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) baab = ERIB%getBlock('baab') abab = ERIA%getBlock('abab')+ERIB%getBlock('abab') baba = ERIA%getBlock('baba')+ERIB%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab,abab=abab,baba=baba) case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & - 'ERIB%storagetype', ERIB%stortype() ) + 'ERIB%ointtype', ERIB%inttype() ) end select case('doublebar') - select case(ERIB%storType()) + select case(ERIB%intType()) case('coulomb') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') @@ -8256,7 +8735,7 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) aabb = ERIA%getBlock('aabb')+ERIB%getBlock('aabb') abba = ERIA%getBlock('abba') baab = ERIA%getBlock('baab') - call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-doublebar','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab) case('exchange') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') @@ -8265,7 +8744,7 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) aabb = ERIA%getBlock('aabb') abba = ERIA%getBlock('abba')+ERIB%getBlock('abba') baab = ERIA%getBlock('baab')+ERIB%getBlock('baab') - call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-doublebar','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab) case('inverted') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') @@ -8276,7 +8755,7 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) baab = ERIA%getBlock('baab') abab = ERIB%getBlock('abab') baba = ERIB%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab,abab=abab,baba=baba) case('doublebar') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') @@ -8285,7 +8764,7 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) aabb = ERIA%getBlock('aabb')+ERIB%getBlock('aabb') abba = ERIA%getBlock('abba')+ERIB%getBlock('abba') baab = ERIA%getBlock('baab')+ERIB%getBlock('baab') - call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-doublebar','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab) case('ms') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') @@ -8296,14 +8775,14 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) baab = ERIA%getBlock('baab')+ERIB%getBlock('baab') abab = ERIB%getBlock('abab') baba = ERIB%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab,abab=abab,baba=baba) case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & - 'ERIB%storagetype', ERIB%stortype() ) + 'ERIB%inttype', ERIB%inttype() ) end select case('ms') - select case(ERIB%storType()) + select case(ERIB%intType()) case('coulomb') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') @@ -8313,7 +8792,7 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) baab = ERIA%getBlock('baab') abab = ERIA%getBlock('abab') baba = ERIA%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab,abab=abab,baba=baba) case('exchange') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') @@ -8324,7 +8803,7 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) baab = ERIA%getBlock('baab')+ERIB%getBlock('baab') abab = ERIA%getBlock('abab') baba = ERIA%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab,abab=abab,baba=baba) case('inverted') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') @@ -8335,7 +8814,7 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) baab = ERIA%getBlock('baab') abab = ERIA%getBlock('abab')+ERIB%getBlock('abab') baba = ERIA%getBlock('baba')+ERIB%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab,abab=abab,baba=baba) case('doublebar') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') @@ -8346,7 +8825,7 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) baab = ERIA%getBlock('baab')+ERIB%getBlock('baab') abab = ERIA%getBlock('abab') baba = ERIA%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab,abab=abab,baba=baba) case('ms') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') @@ -8357,24 +8836,24 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) baab = ERIA%getBlock('baab')+ERIB%getBlock('baab') abab = ERIA%getBlock('abab')+ERIB%getBlock('abab') baba = ERIA%getBlock('baba')+ERIB%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab,abab=abab,baba=baba) case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & - 'ERIB%storagetype', ERIB%stortype() ) + 'ERIB%inttype', ERIB%inttype() ) end select case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & - 'ERIA%storagetype', ERIA%stortype() ) + 'ERIA%inttype', ERIA%inttype() ) end select case('general') - select case(ERIA%storType()) + select case(ERIA%intType()) case('coulomb') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') aabb = ERIA%getBlock('aabb')+ERIB%getBlock('aabb') bbaa = ERIA%getBlock('bbaa')+ERIB%getBlock('bbaa') - call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& + call mqc_twoeris_allocate(ERIOut,'full-coulomb','general',aaaa,bbbb,& aabb,bbaa,& ERIB%getBlock('abab'), ERIB%getBlock('abba'),& ERIB%getBlock('baab'), ERIB%getBlock('baba'),& @@ -8387,7 +8866,7 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') abba = ERIA%getBlock('abba')+ERIB%getBlock('abba') baab = ERIA%getBlock('baab')+ERIB%getBlock('baab') - call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& + call mqc_twoeris_allocate(ERIOut,'full-exchange','general',aaaa,bbbb,& ERIB%getBlock('aabb'), ERIB%getBlock('bbaa'),& ERIB%getBlock('abab'), abba,& baab, ERIB%getBlock('baba'),& @@ -8400,7 +8879,7 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') abab = ERIA%getBlock('abab')+ERIB%getBlock('abab') baba = ERIA%getBlock('baba')+ERIB%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& + call mqc_twoeris_allocate(ERIOut,'full-inverted','general',aaaa,bbbb,& ERIB%getBlock('aabb'), ERIB%getBlock('bbaa'),& abab, ERIB%getBlock('abba'),& ERIB%getBlock('baab'), baba,& @@ -8415,7 +8894,7 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) bbaa = ERIA%getBlock('bbaa')+ERIB%getBlock('bbaa') abba = ERIA%getBlock('abba')+ERIB%getBlock('abba') baab = ERIA%getBlock('baab')+ERIB%getBlock('baab') - call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& + call mqc_twoeris_allocate(ERIOut,'full-doublebar','general',aaaa,bbbb,& aabb , bbaa ,& abab , ERIB%getBlock('abba'),& ERIB%getBlock('baab'), baba ,& @@ -8432,7 +8911,7 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) baab = ERIA%getBlock('baab')+ERIB%getBlock('baab') abab = ERIA%getBlock('abab')+ERIB%getBlock('abab') baba = ERIA%getBlock('baba')+ERIB%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& + call mqc_twoeris_allocate(ERIOut,'full-ms','general',aaaa,bbbb,& aabb , bbaa ,& abab , abba ,& baab , baba ,& @@ -8442,7 +8921,7 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) ERIB%getBlock('babb'), ERIB%getBlock('abbb')) case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & - 'ERIA%storagetype', ERIA%stortype() ) + 'ERIA%inttype', ERIA%inttype() ) end select case default call mqc_error_A('Unknown twoERI type in mqc_eri_sum', 6, & @@ -8453,7 +8932,7 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) case('space') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('aaaa') - select case(ERIB%storType()) + select case(ERIB%intType()) case('coulomb') aabb = ERIA%getBlock('aabb')+ERIB%getBlock('aaaa') bbaa = ERIA%getBlock('bbaa')+ERIB%getBlock('aaaa') @@ -8477,9 +8956,9 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) abba = ERIA%getBlock('abba') case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & - 'ERIB%storagetype', ERIB%stortype() ) + 'ERIB%inttype', ERIB%inttype() ) end select - call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& + call mqc_twoeris_allocate(ERIOut,'full-coulomb','general',aaaa,bbbb,& aabb,bbaa,& abab,abba,& baab,baba,& @@ -8490,7 +8969,7 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) case('spin') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') - select case(ERIB%storType()) + select case(ERIB%intType()) case('coulomb') aabb = ERIA%getBlock('aabb')+ERIB%getBlock('aabb') bbaa = ERIA%getBlock('bbaa')+ERIB%getBlock('bbaa') @@ -8528,9 +9007,9 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) abba = ERIA%getBlock('abba')+ERIB%getBlock('abba') case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & - 'ERIB%storagetype', ERIB%stortype() ) + 'ERIB%inttype', ERIB%inttype() ) end select - call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& + call mqc_twoeris_allocate(ERIOut,'full-coulomb','general',aaaa,bbbb,& aabb,bbaa,& abab,abba,& baab,baba,& @@ -8555,7 +9034,7 @@ function mqc_eri_sum(ERIA,ERIB) result(ERIOut) abab = ERIA%getBlock('abab')+ERIB%getBlock('abab') baab = ERIA%getBlock('baab')+ERIB%getBlock('baab') baba = ERIA%getBlock('baba')+ERIB%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& + call mqc_twoeris_allocate(ERIOut,'full-coulomb','general',aaaa,bbbb,& aabb,bbaa,abab,abba,baab,baba,aaab,aaba,abaa,baaa,bbba,bbab,babb,abbb) case default call mqc_error_A('Unknown twoERI type in mqc_eri_sum', 6, & @@ -8978,10 +9457,14 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) type(mqc_r4tensor)::aaaa,bbbb,aabb,bbaa,abab,abba,baab,baba,& aaab,aaba,abaa,baaa,bbba,bbab,babb,abbb ! - if(ERIA%integraltype.eq.'empty') then + write(*,*) 'LMTLMT ERIA%integraltype',ERIA%integraltype + write(*,*) 'LMTLMT ERIB%integraltype',ERIB%integraltype + write(*,*) 'LMTLMT ERIA%inttype',ERIA%inttype() + write(*,*) 'LMTLMT ERIB%inttype',ERIB%inttype() + if(.not.allocated(ERIA)) then ERIOut = (-1)*ERIB return - elseif(ERIB%integraltype.eq.'empty') then + elseif(.not.allocated(ERIB)) then ERIOut = ERIA return end if @@ -8989,84 +9472,84 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) case('space') select case (ERIB%integraltype) case('space') - select case(ERIA%storType()) + select case(ERIA%intType()) case('coulomb') - select case(ERIB%storType()) + select case(ERIB%intType()) case('coulomb') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') - call mqc_twoeris_allocate(ERIOut,'coulomb','space',aaaa) + call mqc_twoeris_allocate(ERIOut,'full-coulomb','space',aaaa) case('exchange') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') aabb = ERIA%getBlock('aaaa') abba = (-1)*ERIB%getBlock('aaaa') - call mqc_twoeris_allocate(ERIOut,'doublebar','spin',& + call mqc_twoeris_allocate(ERIOut,'full-doublebar','spin',& aaaa,aaaa,aabb,bbaa,abba=abba,baab=baab) case('inverted') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') aabb = ERIA%getBlock('aaaa') abab = (-1)*ERIB%getBlock('aaaa') - call mqc_twoeris_allocate(ERIOut,'ms','spin',& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',& aaaa,aaaa,aabb,bbaa,baba=baba,abab=abab) case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & - 'ERIB%storagetype', ERIB%stortype() ) + 'ERIB%inttype', ERIB%inttype() ) end select case('exchange') - select case(ERIB%storType()) + select case(ERIB%intType()) case('coulomb') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') aabb = (-1)*ERIB%getBlock('aaaa') abba = ERIA%getBlock('aaaa') - call mqc_twoeris_allocate(ERIOut,'doublebar','spin',& + call mqc_twoeris_allocate(ERIOut,'full-doublebar','spin',& aaaa,aaaa,aabb,bbaa,abba=abba,baab=baab) case('exchange') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') - call mqc_twoeris_allocate(ERIOut,'exchange','space',aaaa) + call mqc_twoeris_allocate(ERIOut,'full-exchange','space',aaaa) case('inverted') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') abba = ERIA%getBlock('aaaa') abab = (-1)*ERIB%getBlock('aaaa') - call mqc_twoeris_allocate(ERIOut,'ms','spin',& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',& aaaa,aaaa,abba=abba,baab=baab,baba=baba,abab=abab) case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & - 'ERIB%storagetype', ERIB%stortype() ) + 'ERIB%inttype', ERIB%inttype() ) end select case('inverted') - select case(ERIB%storType()) + select case(ERIB%intType()) case('coulomb') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') aabb = (-1)*ERIB%getBlock('aaaa') abab = ERIA%getBlock('aaaa') - call mqc_twoeris_allocate(ERIOut,'ms','spin',& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',& aaaa,aaaa,aabb,bbaa,baba=baba,abab=abab) case('exchange') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') abba = (-1)*ERIB%getBlock('aaaa') abab = ERIA%getBlock('aaaa') - call mqc_twoeris_allocate(ERIOut,'ms','spin',& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',& aaaa,aaaa,abba=abba,baab=baab,baba=baba,abab=abab) case('inverted') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') - call mqc_twoeris_allocate(ERIOut,'inverted','space',aaaa) + call mqc_twoeris_allocate(ERIOut,'full-inverted','space',aaaa) case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & - 'ERIB%storagetype', ERIB%stortype() ) + 'ERIB%inttype', ERIB%inttype() ) end select case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & - 'ERIA%storagetype', ERIA%stortype() ) + 'ERIA%inttype', ERIA%inttype() ) end select case('spin') - select case(ERIA%storType()) + select case(ERIA%intType()) case('coulomb') - select case(ERIB%storType()) + select case(ERIB%intType()) case('coulomb') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('aaaa')-ERIB%getBlock('bbbb') aabb = ERIA%getBlock('aaaa')-ERIB%getBlock('aabb') bbaa = ERIA%getBlock('aaaa')-ERIB%getBlock('bbaa') - call mqc_twoeris_allocate(ERIOut,'coulomb','spin',aaaa,bbbb,aabb,bbaa) + call mqc_twoeris_allocate(ERIOut,'full-coulomb','spin',aaaa,bbbb,aabb,bbaa) case('exchange') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('aaaa')-ERIB%getBlock('bbbb') @@ -9074,7 +9557,7 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) aabb = ERIA%getBlock('aaaa') abba = (-1)*ERIB%getBlock('abba') baab = (-1)*ERIB%getBlock('baab') - call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-doublebar','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab) case('inverted') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') @@ -9083,7 +9566,7 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) aabb = ERIA%getBlock('aaaa') abab = (-1)*ERIB%getBlock('abab') baba = (-1)*ERIB%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abab=abab,baba=baba) case('doublebar') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') @@ -9092,7 +9575,7 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) aabb = ERIA%getBlock('aaaa')-ERIB%getBlock('aabb') abba = (-1)*ERIB%getBlock('abba') baab = (-1)*ERIB%getBlock('baab') - call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-doublebar','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab) case('ms') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') @@ -9103,14 +9586,14 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) baab = (-1)*ERIB%getBlock('baab') abab = (-1)*ERIB%getBlock('abab') baba = (-1)*ERIB%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-doublebar','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab,abab=abab,baba=baba) case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & - 'ERIB%storagetype', ERIB%stortype()) + 'ERIB%inttype', ERIB%inttype()) end select case('exchange') - select case(ERIB%storType()) + select case(ERIB%intType()) case('coulomb') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('aaaa')-ERIB%getBlock('bbbb') @@ -9118,14 +9601,14 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) aabb = (-1)*ERIB%getBlock('aaaa') abba = ERIA%getBlock('abba') baab = ERIA%getBlock('baab') - call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-doublebar','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab) case('exchange') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('aaaa')-ERIB%getBlock('bbbb') aabb = ERIA%getBlock('aaaa')-ERIB%getBlock('abba') bbaa = ERIA%getBlock('aaaa')-ERIB%getBlock('abba') - call mqc_twoeris_allocate(ERIOut,'exchange','spin',aaaa,bbbb,aabb,bbaa) + call mqc_twoeris_allocate(ERIOut,'full-exchange','spin',aaaa,bbbb,aabb,bbaa) case('inverted') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('aaaa')-ERIB%getBlock('bbbb') @@ -9133,7 +9616,7 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) abba = ERIA%getBlock('aaaa') abab = (-1)*ERIB%getBlock('abab') baba = (-1)*ERIB%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,& abba=abba,baab=baab,abab=abab,baba=baba) case('doublebar') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') @@ -9142,7 +9625,7 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) baab = ERIA%getBlock('aaaa')-ERIB%getBlock('baab') bbaa = (-1)*ERIB%getBlock('bbaa') aabb = (-1)*ERIB%getBlock('aabb') - call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-doublebar','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab) case('ms') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') @@ -9153,14 +9636,14 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) baab = ERIA%getBlock('aaaa')-ERIB%getBlock('baab') abab = (-1)*ERIB%getBlock('abab') baba = (-1)*ERIB%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-doublebar','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab,abab=abab,baba=baba) case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & - 'ERIB%storagetype', ERIB%stortype() ) + 'ERIB%inttype', ERIB%inttype() ) end select case('inverted') - select case(ERIB%storType()) + select case(ERIB%intType()) case('coulomb') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('aaaa')-ERIB%getBlock('bbbb') @@ -9168,7 +9651,7 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) aabb = (-1)*ERIB%getBlock('aabb') abab = ERIA%getBlock('aaaa') baba = ERIA%getBlock('aaaa') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abab=abab,baba=baba) case('exchange') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') @@ -9177,14 +9660,14 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) abba = (-1)*ERIB%getBlock('abba') abab = ERIA%getBlock('aaaa') baba = ERIA%getBlock('aaaa') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,& abba=abba,baab=baab,abab=abab,baba=baba) case('inverted') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('aaaa')-ERIB%getBlock('bbbb') aabb = ERIA%getBlock('aaaa')-ERIB%getBlock('abab') bbaa = ERIA%getBlock('aaaa')-ERIB%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'inverted','spin',aaaa,bbbb,& + call mqc_twoeris_allocate(ERIOut,'full-inverted','spin',aaaa,bbbb,& abab,baba) case('doublebar') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') @@ -9195,7 +9678,7 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) aabb = (-1)*ERIB%getBlock('aabb') abab = ERIA%getBlock('aaaa') baba = ERIA%getBlock('aaaa') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab,abab=abab,baba=baba) case('ms') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') @@ -9206,20 +9689,20 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) aabb = (-1)*ERIB%getBlock('aabb') abab = ERIA%getBlock('aaaa')-ERIB%getBlock('abab') baba = ERIA%getBlock('aaaa')-ERIB%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab,abab=abab,baba=baba) case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & - 'ERIB%storagetype', ERIB%stortype() ) + 'ERIB%inttype', ERIB%inttype() ) end select case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & - 'ERIA%storagetype', ERIA%stortype() ) + 'ERIA%inttype', ERIA%inttype() ) end select case('general') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('aaaa')-ERIB%getBlock('bbbb') - select case(ERIA%storType()) + select case(ERIA%intType()) case('coulomb') aabb = ERIA%getBlock('aaaa')-ERIB%getBlock('aabb') bbaa = ERIA%getBlock('aaaa')-ERIB%getBlock('bbaa') @@ -9243,9 +9726,9 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) abba = (-1)*ERIB%getBlock('abba') case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & - 'ERIA%storagetype', ERIA%stortype() ) + 'ERIA%inttype', ERIA%inttype() ) end select - call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& + call mqc_twoeris_allocate(ERIOut,'full-coulomb','general',aaaa,bbbb,& aabb,bbaa,& abab,abba,& baab,baba,& @@ -9260,15 +9743,15 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) case('spin') select case (ERIB%integraltype) case('space') - select case(ERIA%storType()) + select case(ERIA%intType()) case('coulomb') - select case(ERIB%storType()) + select case(ERIB%intType()) case('coulomb') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('aaaa') aabb = ERIA%getBlock('aabb')-ERIB%getBlock('aaaa') bbaa = ERIA%getBlock('bbaa')-ERIB%getBlock('aaaa') - call mqc_twoeris_allocate(ERIOut,'coulomb','spin',aaaa,bbbb,aabb,bbaa) + call mqc_twoeris_allocate(ERIOut,'full-coulomb','spin',aaaa,bbbb,aabb,bbaa) case('exchange') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('aaaa') @@ -9276,7 +9759,7 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) aabb = (-1)*ERIB%getBlock('aaaa') abba = ERIA%getBlock('abba') baab = ERIA%getBlock('baab') - call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-doublebar','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab) case('inverted') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') @@ -9285,14 +9768,14 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) aabb = (-1)*ERIB%getBlock('aaaa') abab = ERIA%getBlock('abab') baba = ERIA%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abab=abab,baba=baba) case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & - 'ERIB%storagetype', ERIB%stortype() ) + 'ERIB%inttype', ERIB%inttype() ) end select case('exchange') - select case(ERIB%storType()) + select case(ERIB%intType()) case('coulomb') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('aaaa') @@ -9300,14 +9783,14 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) aabb = ERIA%getBlock('aaaa') abba = (-1)*ERIB%getBlock('abba') baab = (-1)*ERIB%getBlock('baab') - call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-doublebar','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab) case('exchange') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('aaaa') aabb = ERIA%getBlock('abba')-ERIB%getBlock('aaaa') bbaa = ERIA%getBlock('abba')-ERIB%getBlock('aaaa') - call mqc_twoeris_allocate(ERIOut,'exchange','spin',aaaa,bbbb,aabb,bbaa) + call mqc_twoeris_allocate(ERIOut,'full-exchange','spin',aaaa,bbbb,aabb,bbaa) case('inverted') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('aaaa') @@ -9315,14 +9798,14 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) abba = ERIB%getBlock('aaaa') abab = (-1)*ERIA%getBlock('abab') baba = (-1)*ERIA%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,& abba=abba,baab=baab,abab=abab,baba=baba) case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & - 'ERIB%storagetype', ERIB%stortype() ) + 'ERIB%inttype', ERIB%inttype() ) end select case('inverted') - select case(ERIB%storType()) + select case(ERIB%intType()) case('coulomb') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('aaaa') @@ -9330,7 +9813,7 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) aabb = ERIA%getBlock('aabb') abab = (-1)*ERIB%getBlock('aaaa') baba = (-1)*ERIB%getBlock('aaaa') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abab=abab,baba=baba) case('exchange') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') @@ -9339,21 +9822,21 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) abba = ERIA%getBlock('abba') abab = (-1)*ERIB%getBlock('aaaa') baba = (-1)*ERIB%getBlock('aaaa') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,& abba=abba,baab=baab,abab=abab,baba=baba) case('inverted') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('aaaa') aabb = ERIA%getBlock('abab')-ERIB%getBlock('aaaa') bbaa = ERIA%getBlock('baba')-ERIB%getBlock('aaaa') - call mqc_twoeris_allocate(ERIOut,'inverted','spin',aaaa,bbbb,& + call mqc_twoeris_allocate(ERIOut,'full-inverted','spin',aaaa,bbbb,& abab,baba) case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & - 'ERIB%storagetype', ERIB%stortype() ) + 'ERIB%inttype', ERIB%inttype() ) end select case('doublebar') - select case(ERIB%storType()) + select case(ERIB%intType()) case('coulomb') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('aaaa') @@ -9361,7 +9844,7 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) aabb = ERIA%getBlock('aabb')-ERIB%getBlock('aaaa') abba = ERIA%getBlock('abba') baab = ERIA%getBlock('baab') - call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-doublebar','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab) case('exchange') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') @@ -9370,7 +9853,7 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) baab = ERIA%getBlock('baab')-ERIB%getBlock('aaaa') bbaa = ERIA%getBlock('bbaa') aabb = ERIA%getBlock('aabb') - call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-doublebar','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab) case('inverted') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') @@ -9381,14 +9864,14 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) aabb = ERIA%getBlock('aabb') abab = (-1)*ERIB%getBlock('aaaa') baba = (-1)*ERIB%getBlock('aaaa') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab,abab=abab,baba=baba) case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & - 'ERIB%storagetype', ERIB%stortype() ) + 'ERIB%inttype', ERIB%inttype() ) end select case('ms') - select case(ERIB%storType()) + select case(ERIB%intType()) case('coulomb') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('aaaa') @@ -9398,7 +9881,7 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) baab = ERIA%getBlock('baab') abab = ERIA%getBlock('abab') baba = ERIA%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab,abab=abab,baba=baba) case('exchange') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') @@ -9409,7 +9892,7 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) baab = ERIA%getBlock('baab')-ERIB%getBlock('aaaa') abab = ERIA%getBlock('abab') baba = ERIA%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab,abab=abab,baba=baba) case('inverted') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') @@ -9420,26 +9903,26 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) aabb = ERIA%getBlock('aabb') abab = ERIA%getBlock('abab')-ERIB%getBlock('aaaa') baba = ERIA%getBlock('baba')-ERIB%getBlock('aaaa') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab,abab=abab,baba=baba) case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & - 'ERIB%storagetype', ERIB%stortype() ) + 'ERIB%storagetype', ERIB%type() ) end select case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & - 'ERIA%storagetype', ERIA%stortype() ) + 'ERIA%inttype', ERIA%inttype() ) end select case('spin') - select case(ERIA%storType()) + select case(ERIA%intType()) case('coulomb') - select case(ERIB%storType()) + select case(ERIB%intType()) case('coulomb') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') aabb = ERIA%getBlock('aabb')-ERIB%getBlock('aabb') bbaa = ERIA%getBlock('bbaa')-ERIB%getBlock('bbaa') - call mqc_twoeris_allocate(ERIOut,'coulomb','spin',aaaa,bbbb,aabb,bbaa) + call mqc_twoeris_allocate(ERIOut,'full-coulomb','spin',aaaa,bbbb,aabb,bbaa) case('exchange') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') @@ -9447,7 +9930,7 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) aabb = ERIA%getBlock('aabb') abba = (-1)*ERIB%getBlock('abba') baab = (-1)*ERIB%getBlock('baab') - call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-doublebar','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab) case('inverted') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') @@ -9456,7 +9939,7 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) aabb = ERIA%getBlock('aabb') abab = (-1)*ERIB%getBlock('abab') baba = (-1)*ERIB%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abab=abab,baba=baba) case('doublebar') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') @@ -9465,7 +9948,7 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) aabb = ERIA%getBlock('aabb')-ERIB%getBlock('aabb') abba = (-1)*ERIB%getBlock('abba') baab = (-1)*ERIB%getBlock('baab') - call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-doublebar','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab) case('ms') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') @@ -9476,14 +9959,14 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) baab = (-1)*ERIB%getBlock('baab') abab = (-1)*ERIB%getBlock('abab') baba = (-1)*ERIB%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab,abab=abab,baba=baba) case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & - 'ERIB%storagetype', ERIB%stortype() ) + 'ERIB%inttype', ERIB%inttype() ) end select case('exchange') - select case(ERIB%storType()) + select case(ERIB%intType()) case('coulomb') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') @@ -9491,14 +9974,14 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) aabb = (-1)*ERIB%getBlock('aabb') abba = ERIA%getBlock('abba') baab = ERIA%getBlock('baab') - call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-doublebar','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab) case('exchange') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') aabb = ERIA%getBlock('abba')-ERIB%getBlock('abba') bbaa = ERIA%getBlock('baab')-ERIB%getBlock('baab') - call mqc_twoeris_allocate(ERIOut,'exchange','spin',aaaa,bbbb,aabb,bbaa) + call mqc_twoeris_allocate(ERIOut,'full-exchange','spin',aaaa,bbbb,aabb,bbaa) case('inverted') aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')+ERIB%getBlock('bbbb') @@ -9506,7 +9989,7 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) baab = ERIA%getBlock('baab') abab = ERIB%getBlock('abab') baba = ERIB%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,& abba=abba,baab=baab,abab=abab,baba=baba) case('doublebar') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') @@ -9515,7 +9998,7 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) aabb = (-1)*ERIB%getBlock('aabb') abba = ERIA%getBlock('abba')-ERIB%getBlock('abba') baab = ERIA%getBlock('baab')-ERIB%getBlock('baab') - call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-doublebar','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab) case('ms') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') @@ -9526,14 +10009,14 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) baab = ERIA%getBlock('baab')-ERIB%getBlock('baab') abab = (-1)*ERIB%getBlock('abab') baba = (-1)*ERIB%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab,abab=abab,baba=baba) case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & - 'ERIB%storagetype', ERIB%stortype() ) + 'ERIB%inttype', ERIB%inttype() ) end select case('inverted') - select case(ERIB%storType()) + select case(ERIB%intType()) case('coulomb') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') @@ -9541,7 +10024,7 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) aabb = (-1)*ERIB%getBlock('aabb') abab = ERIA%getBlock('abab') baba = ERIA%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abab=abab,baba=baba) case('exchange') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') @@ -9550,14 +10033,14 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) baab = (-1)*ERIB%getBlock('baab') abab = ERIA%getBlock('abab') baba = ERIA%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,& abba=abba,baab=baab,abab=abab,baba=baba) case('inverted') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') aabb = ERIA%getBlock('abab')-ERIB%getBlock('abab') bbaa = ERIA%getBlock('abab')-ERIB%getBlock('abab') - call mqc_twoeris_allocate(ERIOut,'inverted','spin',aaaa,bbbb,aabb,bbaa) + call mqc_twoeris_allocate(ERIOut,'full-inverted','spin',aaaa,bbbb,aabb,bbaa) case('doublebar') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') @@ -9567,7 +10050,7 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) baab = (-1)*ERIB%getBlock('baab') abab = ERIA%getBlock('abab') baba = ERIA%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab,abab=abab,baba=baba) case('ms') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') @@ -9578,14 +10061,14 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) baab = (-1)*ERIB%getBlock('baab') abab = ERIA%getBlock('abab')-ERIB%getBlock('abab') baba = ERIA%getBlock('baba')-ERIB%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab,abab=abab,baba=baba) case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & - 'ERIB%storagetype', ERIB%stortype() ) + 'ERIB%inttype', ERIB%inttype() ) end select case('doublebar') - select case(ERIB%storType()) + select case(ERIB%intType()) case('coulomb') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') @@ -9593,7 +10076,7 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) aabb = ERIA%getBlock('aabb')-ERIB%getBlock('aabb') abba = ERIA%getBlock('abba') baab = ERIA%getBlock('baab') - call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-doublebar','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab) case('exchange') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') @@ -9602,7 +10085,7 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) aabb = ERIA%getBlock('aabb') abba = ERIA%getBlock('abba')-ERIB%getBlock('abba') baab = ERIA%getBlock('baab')-ERIB%getBlock('baab') - call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-doublebar','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab) case('inverted') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') @@ -9613,7 +10096,7 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) baab = ERIA%getBlock('baab') abab = (-1)*ERIB%getBlock('abab') baba = (-1)*ERIB%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab,abab=abab,baba=baba) case('doublebar') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') @@ -9622,7 +10105,7 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) aabb = ERIA%getBlock('aabb')-ERIB%getBlock('aabb') abba = ERIA%getBlock('abba')-ERIB%getBlock('abba') baab = ERIA%getBlock('baab')-ERIB%getBlock('baab') - call mqc_twoeris_allocate(ERIOut,'doublebar','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-doublebar','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab) case('ms') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') @@ -9633,14 +10116,14 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) baab = ERIA%getBlock('baab')-ERIB%getBlock('baab') abab = (-1)*ERIB%getBlock('abab') baba = (-1)*ERIB%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab,abab=abab,baba=baba) case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & - 'ERIB%storagetype', ERIB%stortype() ) + 'ERIB%inttype', ERIB%inttype() ) end select case('ms') - select case(ERIB%storType()) + select case(ERIB%intType()) case('coulomb') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') @@ -9650,7 +10133,7 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) baab = ERIA%getBlock('baab') abab = ERIA%getBlock('abab') baba = ERIA%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab,abab=abab,baba=baba) case('exchange') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') @@ -9661,7 +10144,7 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) baab = ERIA%getBlock('baab')-ERIB%getBlock('baab') abab = ERIA%getBlock('abab') baba = ERIA%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab,abab=abab,baba=baba) case('inverted') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') @@ -9672,7 +10155,7 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) baab = ERIA%getBlock('baab') abab = ERIA%getBlock('abab')-ERIB%getBlock('abab') baba = ERIA%getBlock('baba')-ERIB%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab,abab=abab,baba=baba) case('doublebar') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') @@ -9683,7 +10166,7 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) baab = ERIA%getBlock('baab')-ERIB%getBlock('baab') abab = ERIA%getBlock('abab') baba = ERIA%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab,abab=abab,baba=baba) case('ms') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') @@ -9694,24 +10177,24 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) baab = ERIA%getBlock('baab')-ERIB%getBlock('baab') abab = ERIA%getBlock('abab')-ERIB%getBlock('abab') baba = ERIA%getBlock('baba')-ERIB%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'ms','spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(ERIOut,'full-ms','spin',aaaa,bbbb,aabb,bbaa,& abba=abba,baab=baab,abab=abab,baba=baba) case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & - 'ERIB%storagetype', ERIB%stortype() ) + 'ERIB%inttype', ERIB%inttype() ) end select case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & - 'ERIA%storagetype', ERIA%stortype() ) + 'ERIA%inttype', ERIA%inttype() ) end select case('general') - select case(ERIA%storType()) + select case(ERIA%intType()) case('coulomb') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') aabb = ERIA%getBlock('aabb')-ERIB%getBlock('aabb') bbaa = ERIA%getBlock('bbaa')-ERIB%getBlock('bbaa') - call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& + call mqc_twoeris_allocate(ERIOut,'full-coulomb','general',aaaa,bbbb,& aabb,bbaa,& (-1)*ERIB%getBlock('abab'),(-1)*ERIB%getBlock('abba'),& (-1)*ERIB%getBlock('baab'),(-1)*ERIB%getBlock('baba'),& @@ -9724,7 +10207,7 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') abba = ERIA%getBlock('abba')-ERIB%getBlock('abba') baab = ERIA%getBlock('baab')-ERIB%getBlock('baab') - call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& + call mqc_twoeris_allocate(ERIOut,'full-exchange','general',aaaa,bbbb,& (-1)*ERIB%getBlock('aabb'),(-1)*ERIB%getBlock('bbaa'),& (-1)*ERIB%getBlock('abab'), abba,& baab,(-1)*ERIB%getBlock('baba'),& @@ -9737,7 +10220,7 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') abab = ERIA%getBlock('abab')-ERIB%getBlock('abab') baba = ERIA%getBlock('baba')-ERIB%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& + call mqc_twoeris_allocate(ERIOut,'full-coulomb','general',aaaa,bbbb,& (-1)*ERIB%getBlock('aabb'),(-1)*ERIB%getBlock('bbaa'),& abab,(-1)*ERIB%getBlock('abba'),& (-1)*ERIB%getBlock('baab'), baba,& @@ -9752,7 +10235,7 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) bbaa = ERIA%getBlock('bbaa')-ERIB%getBlock('bbaa') abba = ERIA%getBlock('abba')-ERIB%getBlock('abba') baab = ERIA%getBlock('baab')-ERIB%getBlock('baab') - call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& + call mqc_twoeris_allocate(ERIOut,'full-doublebar','general',aaaa,bbbb,& aabb , bbaa ,& abab ,(-1)*ERIB%getBlock('abba'),& (-1)*ERIB%getBlock('baab'), baba ,& @@ -9769,7 +10252,7 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) baab = ERIA%getBlock('baab')-ERIB%getBlock('baab') abab = ERIA%getBlock('abab')-ERIB%getBlock('abab') baba = ERIA%getBlock('baba')-ERIB%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& + call mqc_twoeris_allocate(ERIOut,'full-coulomb','general',aaaa,bbbb,& aabb , bbaa ,& abab , abba ,& baab , baba ,& @@ -9779,7 +10262,7 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) (-1)*ERIB%getBlock('babb'),(-1)*ERIB%getBlock('abbb')) case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & - 'ERIA%storagetype', ERIA%stortype() ) + 'ERIA%inttype', ERIA%inttype() ) end select case default call mqc_error_A('Unknown twoERI type in mqc_eri_difference', 6, & @@ -9790,7 +10273,7 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) case('space') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('aaaa') - select case(ERIB%storType()) + select case(ERIB%intType()) case('coulomb') aabb = ERIA%getBlock('aabb')-ERIB%getBlock('aaaa') bbaa = ERIA%getBlock('bbaa')-ERIB%getBlock('aaaa') @@ -9814,9 +10297,9 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) abba = ERIA%getBlock('abba') case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & - 'ERIB%storagetype', ERIB%stortype() ) + 'ERIB%inttype', ERIB%inttype() ) end select - call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& + call mqc_twoeris_allocate(ERIOut,'full-coulomb','general',aaaa,bbbb,& aabb,bbaa,& abab,abba,& baab,baba,& @@ -9827,7 +10310,7 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) case('spin') aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('aaaa') bbbb = ERIA%getBlock('bbbb')-ERIB%getBlock('bbbb') - select case(ERIB%storType()) + select case(ERIB%intType()) case('coulomb') aabb = ERIA%getBlock('aabb')-ERIB%getBlock('aabb') bbaa = ERIA%getBlock('bbaa')-ERIB%getBlock('bbaa') @@ -9865,9 +10348,9 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) abba = ERIA%getBlock('abba')-ERIB%getBlock('abba') case default call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & - 'ERIB%storagetype', ERIB%stortype() ) + 'ERIB%inttype', ERIB%inttype() ) end select - call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& + call mqc_twoeris_allocate(ERIOut,'full-coulomb','general',aaaa,bbbb,& aabb,bbaa,& abab,abba,& baab,baba,& @@ -9892,7 +10375,7 @@ function mqc_eri_difference(ERIA,ERIB) result(ERIOut) abab = ERIA%getBlock('abab')-ERIB%getBlock('abab') baab = ERIA%getBlock('baab')-ERIB%getBlock('baab') baba = ERIA%getBlock('baba')-ERIB%getBlock('baba') - call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& + call mqc_twoeris_allocate(ERIOut,'full-coulomb','general',aaaa,bbbb,& aabb,bbaa,abab,abba,baab,baba,aaab,aaba,abaa,baaa,bbba,bbab,babb,abbb) case default call mqc_error_A('Unknown twoERI type in mqc_eri_difference', 6, & @@ -10374,9 +10857,10 @@ function mqc_twoERIs_scalar_multiply(eris,scalarIn) result(erisOut) type(mqc_R4Tensor)::aaaa,bbbb,aabb,bbaa,abab,abba,baab,baba,& aaab,aaba,abaa,baaa,bbba,bbab,babb,abbb type(mqc_scalar)::scalar - Character(Len=64)::myLabel + Character(Len=64)::myLabel,myInt myLabel = eris%storageType + myInt = eris%interactionType select type(scalarIn) type is (integer) @@ -10393,85 +10877,97 @@ function mqc_twoERIs_scalar_multiply(eris,scalarIn) result(erisOut) select case (eris%integralType) case('space','regular','raffenetti1','raffenetti2','raffenetti3') - if(eris%hasSpinBlock('aaaa')) & - aaaa = scalar*eris%getBlock('aaaa') - call mqc_twoeris_allocate(erisOut,myLabel,'space',aaaa) + if(eris%hasSpinBlock('aaaa')) & + aaaa = scalar*eris%getBlock('aaaa') + if (eris%intType().eq.'doublebar') then + if(eris%hasSpinBlock('aabb')) & + aabb = scalar*eris%getBlock('aabb') + if(eris%hasSpinBlock('abba')) & + abba = scalar*eris%getBlock('abba') + call mqc_twoeris_allocate(erisOut,myLabel//'-'//myInt,'space',aaaa,alphaBeta=aabb,abba=abba) + elseif(eris%intType().eq.'coulomb'.or.eris%intType().eq.'exchange'.or.& + eris%intType().eq.'inverted'.or.eris%intType().eq.'ms') then + call mqc_twoeris_allocate(erisOut,myLabel//'-'//myInt,'space',aaaa) + else + call mqc_error_A('Unknown twoERI storage type in mqc_scalar_twoeris_multiply',& + 6,'ERIS%inttype()',ERIS%inttype()) + endIf case('spin') - if(eris%hasSpinBlock('aaaa')) & - aaaa = scalar*eris%getBlock('aaaa') - if(eris%hasSpinBlock('bbbb')) & - bbbb = scalar*eris%getBlock('bbbb') - if (eris%storageType.eq.'coulomb') then - if(eris%hasSpinBlock('bbaa')) & - bbaa = scalar*eris%getBlock('bbaa') - if(eris%hasSpinBlock('aabb')) & - aabb = scalar*eris%getBlock('aabb') - call mqc_twoeris_allocate(erisOut,myLabel,'spin',aaaa,bbbb,aabb,bbaa) - else if (eris%storageType.eq.'exchange') then + if(eris%hasSpinBlock('aaaa')) & + aaaa = scalar*eris%getBlock('aaaa') + if(eris%hasSpinBlock('bbbb')) & + bbbb = scalar*eris%getBlock('bbbb') + if(eris%hasSpinBlock('aabb')) & + aabb = scalar*eris%getBlock('aabb') + if((eris%intType().eq.'doublebar'.or.eris%intType().eq.'ms').and.& + eris%hasSpinBlock('abba')) & + abba = scalar*eris%getBlock('abba') + if((eris%intType().eq.'ms').and.eris%hasSpinBlock('abab')) & + abab = scalar*eris%getBlock('abab') + if(eris%storType().eq.'full') then + if(eris%hasSpinBlock('bbaa')) & + bbaa = scalar*eris%getBlock('bbaa') + if(eris%intType().eq.'doublebar'.or.eris%intType().eq.'ms') then if(eris%hasSpinBlock('baab')) & - bbaa = scalar*eris%getBlock('baab') - if(eris%hasSpinBlock('abba')) & - aabb = scalar*eris%getBlock('abba') - call mqc_twoeris_allocate(erisOut,myLabel,'spin',aaaa,bbbb,aabb,bbaa) - else if (eris%storageType.eq.'inverted') then - if(eris%hasSpinBlock('baba')) & - bbaa = scalar*eris%getBlock('baba') - if(eris%hasSpinBlock('abab')) & - aabb = scalar*eris%getBlock('abab') - call mqc_twoeris_allocate(erisOut,myLabel,'spin',aaaa,bbbb,aabb,bbaa) - else if (eris%storageType.eq.'doublebar') then - if(eris%hasSpinBlock('bbaa')) & - bbaa = scalar*eris%getBlock('bbaa') - if(eris%hasSpinBlock('aabb')) & - aabb = scalar*eris%getBlock('aabb') - if(eris%hasSpinBlock('baab')) & - baab = scalar*eris%getBlock('baab') - if(eris%hasSpinBlock('abba')) & - abba = scalar*eris%getBlock('abba') - call mqc_twoeris_allocate(erisOut,myLabel,'spin',aaaa,bbbb,aabb,bbaa,& - abba=abba,baab=baab) - else if (eris%storageType.eq.'ms') then - if(eris%hasSpinBlock('bbaa')) & - bbaa = scalar*eris%getBlock('bbaa') - if(eris%hasSpinBlock('aabb')) & - aabb = scalar*eris%getBlock('aabb') - if(eris%hasSpinBlock('baab')) & baab = scalar*eris%getBlock('baab') - if(eris%hasSpinBlock('abba')) & - abba = scalar*eris%getBlock('abba') - if(eris%hasSpinBlock('abab')) & - abab = scalar*eris%getBlock('abab') - if(eris%hasSpinBlock('baba')) & - baba = scalar*eris%getBlock('baba') - call mqc_twoeris_allocate(erisOut,myLabel,'spin',aaaa,bbbb,aabb,bbaa,& - abba=abba,baab=baab,baba=baba,abab=abab) - else - call mqc_error_A('Unknown twoERI storage type in mqc_scalar_twoeris_multiply', 6, & - 'ERIS%itortype()', ERIS%stortype() ) - end if + if(eris%intType().eq.'ms') then + if(eris%hasSpinBlock('baba')) & + baba = scalar*eris%getBlock('baba') + call mqc_twoeris_allocate(erisOut,myLabel//'-'//myInt,'spin',aaaa,bbbb,& + aabb,bbaa,abab,abba,baab,baba) + else + call mqc_twoeris_allocate(erisOut,myLabel//'-'//myInt,'spin',aaaa,bbbb,& + aabb,bbaa,abba=abba,baab=baab) + endIf + elseif(eris%intType().eq.'coulomb'.or.eris%intType().eq.'exchange'.or.& + eris%intType().eq.'inverted') then + call mqc_twoeris_allocate(erisOut,myLabel//'-'//myInt,'spin',aaaa,bbbb,& + aabb,bbaa) + else + call mqc_error_A('Unknown twoERI storage type in mqc_scalar_twoeris_multiply',& + 6,'ERIS%inttype()',ERIS%inttype()) + endIf + elseif(eris%storType().eq.'symm') then + if(eris%intType().eq.'ms') then + call mqc_twoeris_allocate(erisOut,myLabel//'-'//myInt,'spin',aaaa,bbbb,& + aabb,abab=abab,abba=abba) + elseif(eris%intType().eq.'doublebar') then + call mqc_twoeris_allocate(erisOut,myLabel//'-'//myInt,'spin',aaaa,bbbb,& + aabb,abba=abba) + elseif(eris%intType().eq.'coulomb'.or.eris%intType().eq.'exchange'.or.& + eris%intType().eq.'inverted') then + call mqc_twoeris_allocate(erisOut,myLabel//'-'//myInt,'spin',aaaa,bbbb,& + aabb) + else + call mqc_error_A('Unknown twoERI storage type in mqc_scalar_twoeris_multiply',& + 6,'ERIS%inttype()',ERIS%inttype()) + endIf + else + call mqc_error_A('Unknown storage type in mqc_twoeris_scalar_multiply', 6, & + 'twoeris%storType()',eris%storType()) + endIf case('general') - if(eris%hasSpinBlock('aaaa')) & - aaaa = scalar*eris%getBlock('aaaa') - if(eris%hasSpinBlock('bbbb')) & - bbbb = scalar*eris%getBlock('bbbb') + if(eris%hasSpinBlock('aaaa')) & + aaaa = scalar*eris%getBlock('aaaa') + if(eris%hasSpinBlock('bbbb')) & + bbbb = scalar*eris%getBlock('bbbb') + if(eris%hasSpinBlock('aabb')) & + aabb = scalar*eris%getBlock('aabb') + if(eris%hasSpinBlock('abba')) & + abba = scalar*eris%getBlock('abba') + if(eris%hasSpinBlock('abab')) & + abab = scalar*eris%getBlock('abab') + if(eris%hasSpinBlock('aaab')) & + aaab = scalar*eris%getBlock('aaab') + if(eris%hasSpinBlock('abbb')) & + abbb = scalar*eris%getBlock('abbb') + if(eris%storType().eq.'full') then if(eris%hasSpinBlock('bbaa')) & bbaa = scalar*eris%getBlock('bbaa') - if(eris%hasSpinBlock('aabb')) & - aabb = scalar*eris%getBlock('aabb') if(eris%hasSpinBlock('baba')) & baba = scalar*eris%getBlock('baba') if(eris%hasSpinBlock('baab')) & baab = scalar*eris%getBlock('baab') - if(eris%hasSpinBlock('abba')) & - abba = scalar*eris%getBlock('abba') - if(eris%hasSpinBlock('abab')) & - abab = scalar*eris%getBlock('abab') - if(eris%hasSpinBlock('aabb')) & - aabb = scalar*eris%getBlock('aabb') - if(eris%hasSpinBlock('aabb')) & - aabb = scalar*eris%getBlock('aabb') - if(eris%hasSpinBlock('aaab')) & - aaab = scalar*eris%getBlock('aaab') if(eris%hasSpinBlock('aaba')) & aaba = scalar*eris%getBlock('aaba') if(eris%hasSpinBlock('abaa')) & @@ -10484,12 +10980,15 @@ function mqc_twoERIs_scalar_multiply(eris,scalarIn) result(erisOut) bbab = scalar*eris%getBlock('bbab') if(eris%hasSpinBlock('babb')) & babb = scalar*eris%getBlock('babb') - if(eris%hasSpinBlock('abbb')) & - abbb = scalar*eris%getBlock('abbb') - call mqc_twoeris_allocate(erisOut,myLabel,'general',aaaa,bbbb,aabb,bbaa,& - abab,abba,baab,baba,& - aaab,aaba,abaa,baaa,& - bbba,bbab,babb,abbb) + call mqc_twoeris_allocate(erisOut,myLabel//'-'//myInt,'general',aaaa,bbbb,aabb,bbaa,& + abab,abba,baab,baba,aaab,aaba,abaa,baaa,bbba,bbab,babb,abbb) + elseif(eris%storType().eq.'symm') then + call mqc_twoeris_allocate(erisOut,myLabel//'-'//myInt,'general',aaaa,bbbb,aabb,& + abab=abab,abba=abba,aaab=aaab,abbb=abbb) + else + call mqc_error_A('Unknown storage type in mqc_twoeris_scalar_multiply', 6, & + 'twoeris%storType()',eris%storType()) + endIf case default call mqc_error_A('Unknown integral type in mqc_twoeris_scalar_multiply', 6, & 'twoeris%integralType', eris%integralType ) @@ -10538,13 +11037,8 @@ function mqc_scalar_twoERIs_multiply(scalarIn,eris) result(erisOut) type(mqc_twoERIs),intent(in)::eris class(*),intent(in)::scalarIn type(mqc_twoERIs)::erisOut - type(mqc_R4Tensor)::aaaa,bbbb,aabb,bbaa,abab,abba,baab,baba,& - aaab,aaba,abaa,baaa,bbba,bbab,babb,abbb type(mqc_scalar)::scalar - Character(Len=64)::myLabel - - myLabel = eris%storType() - +! select type(scalarIn) type is (integer) scalar = scalarIn @@ -10555,112 +11049,13 @@ function mqc_scalar_twoERIs_multiply(scalarIn,eris) result(erisOut) type is (mqc_scalar) scalar = scalarIn class default - call mqc_error_I('scalarIn type not defined in mqc_scalar_twoERIs_multiply',6) + call mqc_error_I('scalarIn type not defined in mqc_twoERIs_scalar_multiply',6) end select - select case (eris%integralType) - case('space','regular','raffenetti1','raffenetti2','raffenetti3') - if(eris%hasSpinBlock('aaaa')) & - aaaa = scalar*eris%getBlock('aaaa') - call mqc_twoeris_allocate(erisOut,myLabel,'space',aaaa) - case('spin') - if(eris%hasSpinBlock('aaaa')) & - aaaa = scalar*eris%getBlock('aaaa') - if(eris%hasSpinBlock('bbbb')) & - bbbb = scalar*eris%getBlock('bbbb') - if (eris%storageType.eq.'coulomb') then - if(eris%hasSpinBlock('bbaa')) & - bbaa = scalar*eris%getBlock('bbaa') - if(eris%hasSpinBlock('aabb')) & - aabb = scalar*eris%getBlock('aabb') - call mqc_twoeris_allocate(erisOut,myLabel,'spin',aaaa,bbbb,aabb,bbaa) - else if (eris%storageType.eq.'exchange') then - if(eris%hasSpinBlock('baab')) & - bbaa = scalar*eris%getBlock('baab') - if(eris%hasSpinBlock('abba')) & - aabb = scalar*eris%getBlock('abba') - call mqc_twoeris_allocate(erisOut,myLabel,'spin',aaaa,bbbb,aabb,bbaa) - else if (eris%storageType.eq.'inverted') then - if(eris%hasSpinBlock('baba')) & - bbaa = scalar*eris%getBlock('baba') - if(eris%hasSpinBlock('abab')) & - aabb = scalar*eris%getBlock('abab') - call mqc_twoeris_allocate(erisOut,myLabel,'spin',aaaa,bbbb,aabb,bbaa) - else if (eris%storageType.eq.'doublebar') then - if(eris%hasSpinBlock('bbaa')) & - bbaa = scalar*eris%getBlock('bbaa') - if(eris%hasSpinBlock('aabb')) & - aabb = scalar*eris%getBlock('aabb') - if(eris%hasSpinBlock('baab')) & - baab = scalar*eris%getBlock('baab') - if(eris%hasSpinBlock('abba')) & - abba = scalar*eris%getBlock('abba') - call mqc_twoeris_allocate(erisOut,myLabel,'spin',aaaa,bbbb,aabb,bbaa,& - abba=abba,baab=baab) - else if (eris%storageType.eq.'ms') then - if(eris%hasSpinBlock('bbaa')) & - bbaa = scalar*eris%getBlock('bbaa') - if(eris%hasSpinBlock('aabb')) & - aabb = scalar*eris%getBlock('aabb') - if(eris%hasSpinBlock('baab')) & - baab = scalar*eris%getBlock('baab') - if(eris%hasSpinBlock('abba')) & - abba = scalar*eris%getBlock('abba') - if(eris%hasSpinBlock('abab')) & - abab = scalar*eris%getBlock('abab') - if(eris%hasSpinBlock('baba')) & - baba = scalar*eris%getBlock('baba') - - call mqc_twoeris_allocate(erisOut,myLabel,'spin',aaaa,bbbb,aabb,bbaa,& - abba=abba,baab=baab,baba=baba,abab=abab) - else - call mqc_error_A('Unknown twoERI storage type in mqc_scalar_twoeris_multiply', 6, & - 'ERIS%stortype()', ERIS%stortype() ) - end if - case('general') - if(eris%hasSpinBlock('aaaa')) & - aaaa = scalar*eris%getBlock('aaaa') - if(eris%hasSpinBlock('bbbb')) & - bbbb = scalar*eris%getBlock('bbbb') - if(eris%hasSpinBlock('bbaa')) & - bbaa = scalar*eris%getBlock('bbaa') - if(eris%hasSpinBlock('aabb')) & - aabb = scalar*eris%getBlock('aabb') - if(eris%hasSpinBlock('baba')) & - baba = scalar*eris%getBlock('baba') - if(eris%hasSpinBlock('baab')) & - baab = scalar*eris%getBlock('baab') - if(eris%hasSpinBlock('abba')) & - abba = scalar*eris%getBlock('abba') - if(eris%hasSpinBlock('abab')) & - abab = scalar*eris%getBlock('abab') - if(eris%hasSpinBlock('aaab')) & - aaab = scalar*eris%getBlock('aaab') - if(eris%hasSpinBlock('aaba')) & - aaba = scalar*eris%getBlock('aaba') - if(eris%hasSpinBlock('abaa')) & - abaa = scalar*eris%getBlock('abaa') - if(eris%hasSpinBlock('baaa')) & - baaa = scalar*eris%getBlock('baaa') - if(eris%hasSpinBlock('bbba')) & - bbba = scalar*eris%getBlock('bbba') - if(eris%hasSpinBlock('bbab')) & - bbab = scalar*eris%getBlock('bbab') - if(eris%hasSpinBlock('babb')) & - babb = scalar*eris%getBlock('babb') - if(eris%hasSpinBlock('abbb')) & - abbb = scalar*eris%getBlock('abbb') - call mqc_twoeris_allocate(erisOut,myLabel,'general',aaaa,bbbb,aabb,bbaa,& - abab,abba,baab,baba,& - aaab,aaba,abaa,baaa,& - bbba,bbab,babb,abbb) - case default - call mqc_error_A('Unknown integral type in mqc_scalar_twoeris_multiply', 6, & - 'twoeris%integralType', eris%integralType ) - end select + erisOut = mqc_twoERIs_scalar_multiply(eris,scalar) ! end function mqc_scalar_twoERIs_multiply - +! ! ! PROCEDURE MQC_Element_Integral_Multiply ! @@ -10940,11 +11335,11 @@ function mqc_integral_integral_outer_product(integralA,integralB) result(ERIsOut end if end if if (intType.eq.'space') then - call mqc_twoeris_allocate(ERIsOut,'coulomb','space',Alpha) + call mqc_twoeris_allocate(ERIsOut,'full-coulomb','space',Alpha) elseif (intType.eq.'spin') then - call mqc_twoeris_allocate(ERIsOut,'coulomb','spin',Alpha,Beta,AlphaBeta,BetaAlpha) + call mqc_twoeris_allocate(ERIsOut,'full-coulomb','spin',Alpha,Beta,AlphaBeta,BetaAlpha) elseif (intType.eq.'general') then - call mqc_twoeris_allocate(ERIsOut,'full','general',Alpha,Beta,AlphaBeta,BetaAlpha,& + call mqc_twoeris_allocate(ERIsOut,'full-coulomb','general',Alpha,Beta,AlphaBeta,BetaAlpha,& abab,abba,baab,baba,aaab,aaba,abaa,baaa,bbba,bbab,babb,abbb) !call mqc_twoeris_allocate(ERIsOut,'ms','spin',Alpha,Beta,AlphaBeta,BetaAlpha,& ! abab,abba,baab,baba) @@ -11071,11 +11466,11 @@ function mqc_integral_integral_crossouter_product(integralA,integralB) result(ER baba = BeAlA.crossouter.BeAlB end if if (intType.eq.'space') then - call mqc_twoeris_allocate(ERIsOut,'exchange','space',Alpha) + call mqc_twoeris_allocate(ERIsOut,'full-exchange','space',Alpha) elseif (intType.eq.'spin') then - call mqc_twoeris_allocate(ERIsOut,'exchange','spin',Alpha,Beta,AlphaBeta,BetaAlpha) + call mqc_twoeris_allocate(ERIsOut,'full-exchange','spin',Alpha,Beta,AlphaBeta,BetaAlpha) elseif (intType.eq.'general') then - call mqc_twoeris_allocate(ERIsOut,'full','general',Alpha,Beta,AlphaBeta,BetaAlpha,& + call mqc_twoeris_allocate(ERIsOut,'full-exchange','general',Alpha,Beta,AlphaBeta,BetaAlpha,& abab,abba,baab,baba,aaab,aaba,abaa,baaa,bbba,bbab,babb,abbb) endif ! @@ -14235,12 +14630,12 @@ function mqc_eri_eri_contraction(eris1,eris2,label) result(output) !end select write(*,*) 'DEBUG: ERI_ERI Contraction' - write(*,*) 'ERIs 1',eris1%Type(),eris1%storType() - write(*,*) 'ERIs 2',eris2%Type(),eris2%storType() + write(*,*) 'ERIs 1',eris1%Type(),eris1%intType() + write(*,*) 'ERIs 2',eris2%Type(),eris2%intType() if(myLabel.ne.'coulomb') temp = eris1%swap(2,4) output = 0.0 - if(eris1%storType().eq.'empty'.or.eris2%storType().eq.'empty') return + if(.not.allocated(eris1).or..not.allocated(eris2)) return if(myLabel.ne.'exchange') & output = output + contraction(eris1%getBlock('aaaa'),eris2%getBlock('aaaa')) if(myLabel.ne.'coulomb') & @@ -14249,55 +14644,53 @@ function mqc_eri_eri_contraction(eris1,eris2,label) result(output) case ('space','regular') select case (eris2%type()) case ('space','regular') - if(eris1%storType().eq.eris2%storType()) then - if((eris1%storType().eq.'coulomb'.or.eris1%storType().eq.'symm').or.eris1%storType().eq.'exchange') then + if(eris1%intType().eq.eris2%intType()) then + if(eris1%intType().eq.'coulomb'.or.eris1%intType().eq.'exchange') then if(myLabel.eq.'coulomb') output = 4*output if(myLabel.eq.'exchange') output = 2*output if(myLabel.eq.'doublebar') & output = 2*output + 2*contraction(eris1%getBlock('aaaa'),eris2%getBlock('aaaa')) - else if(eris1%storType().eq.'inverted') then + else if(eris1%intType().eq.'inverted') then if(myLabel.eq.'coulomb'.or.myLabel.eq.'exchange') output = 4*output if(myLabel.eq.'doublebar') & output = 2*output + 2*contraction(eris1%getBlock('aaaa'),eris2%getBlock('aaaa')) end if - else if(eris1%storType().eq.'coulomb'.or.eris2%storType().eq.'coulomb'.or. & - eris1%storType().eq.'symm'.or.eris2%storType().eq.'symm') then - if(eris1%storType().eq.'coulomb'.or.eris2%storType().eq.'coulomb'.or. & - eris1%storType().eq.'symm'.or.eris2%storType().eq.'symm') then + else if(eris1%intType().eq.'coulomb'.or.eris2%intType().eq.'coulomb') then + if(eris1%intType().eq.'coulomb'.or.eris2%intType().eq.'coulomb') then if(myLabel.eq.'coulomb') output = 4*output if(myLabel.eq.'exchange') output = 2*output if(myLabel.eq.'doublebar') & output = 2*output + 2*contraction(eris1%getBlock('aaaa'),eris2%getBlock('aaaa')) - else if(eris1%storType().eq.'exchange'.or.eris2%storType().eq.'exchange') then + else if(eris1%intType().eq.'exchange'.or.eris2%intType().eq.'exchange') then if(myLabel.eq.'coulomb') output = 2*output if(myLabel.eq.'exchange') output = 4*output if(myLabel.eq.'doublebar') & output = 2*output - 2*contraction(temp%getBlock('aaaa'),eris2%getBlock('aaaa')) - else if(eris1%storType().eq.'inverted'.or.eris2%storType().eq.'inverted') then + else if(eris1%intType().eq.'inverted'.or.eris2%intType().eq.'inverted') then output = 2*output else call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & - 'ERIs1%stortype', ERIs1%stortype(), 'ERIs2%stortype', ERIs2%stortype()) + 'ERIs1%inttype', ERIs1%inttype(), 'ERIs2%inttype', ERIs2%inttype()) end if - else if(eris1%storType().eq.'exchange'.or.eris2%storType().eq.'exchange') then - if(eris1%storType().eq.'inverted'.or.eris2%storType().eq.'inverted') then + else if(eris1%intType().eq.'exchange'.or.eris2%intType().eq.'exchange') then + if(eris1%intType().eq.'inverted'.or.eris2%intType().eq.'inverted') then output = 2*output else call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & - 'ERIs1%stortype', ERIs1%stortype(), 'ERIs2%stortype', ERIs2%stortype()) + 'ERIs1%inttype', ERIs1%inttype(), 'ERIs2%inttype', ERIs2%inttype()) end if else call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & - 'ERIs1%stortype', ERIs1%stortype(), 'ERIs2%stortype', ERIs2%stortype()) + 'ERIs1%inttype', ERIs1%inttype(), 'ERIs2%inttype', ERIs2%inttype()) end if case ('spin') if(myLabel.ne.'exchange') & output = output + contraction(eris1%getBlock('aaaa'),eris2%getBlock('bbbb')) if(myLabel.ne.'coulomb') & output = output - contraction(temp%getBlock('aaaa'),eris2%getBlock('bbbb')) - select case(eris1%storType()) + select case(eris1%intType()) case ('coulomb','symm') - select case(eris2%storType()) + select case(eris2%intType()) case ('symm') if(myLabel.ne.'exchange') & output = output + 2*contraction(eris1%getBlock('aaaa'),eris2%getBlock('aabb')) @@ -14327,10 +14720,10 @@ function mqc_eri_eri_contraction(eris1,eris2,label) result(output) - contraction(temp%getBlock('aaaa'),eris2%getBlock('baab')) case default call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & - 'ERIs2%stortype', ERIs2%stortype()) + 'ERIs2%inttype', ERIs2%inttype()) end select case ('exchange') - select case(eris2%storType()) + select case(eris2%intType()) case ('symm') if(myLabel.ne.'coulomb') & output = output - 2*contraction(temp%getBlock('aaaa'),eris2%getBlock('aabb')) @@ -14360,10 +14753,10 @@ function mqc_eri_eri_contraction(eris1,eris2,label) result(output) - contraction(temp%getBlock('aaaa'),eris2%getBlock('bbaa')) case default call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & - 'ERIs2%stortype', ERIs2%stortype()) + 'ERIs2%inttype', ERIs2%inttype()) end select case ('inverted') - select case(eris2%storType()) + select case(eris2%intType()) case ('coulomb','symm','exchange','doublebar') ! Done case ('inverted') @@ -14382,18 +14775,18 @@ function mqc_eri_eri_contraction(eris1,eris2,label) result(output) - contraction(temp%getBlock('aaaa'),eris2%getBlock('baba')) case default call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & - 'ERIs2%stortype', ERIs2%stortype()) + 'ERIs2%inttype', ERIs2%inttype()) end select case default call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & - 'ERIs1%stortype', ERIs1%stortype()) + 'ERIs1%inttype', ERIs1%inttype()) end select case ('general') if(myLabel.ne.'exchange') & output = output + contraction(eris1%getBlock('aaaa'),eris2%getBlock('bbbb')) if(myLabel.ne.'coulomb') & output = output - contraction(temp%getBlock('aaaa'),eris2%getBlock('bbbb')) - select case(eris1%storType()) + select case(eris1%intType()) case ('coulomb','symm') if(myLabel.ne.'exchange') & output = output + contraction(eris1%getBlock('aaaa'),eris2%getBlock('aabb')) & @@ -14417,7 +14810,7 @@ function mqc_eri_eri_contraction(eris1,eris2,label) result(output) - contraction(temp%getBlock('aaaa'),eris2%getBlock('baba')) case default call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & - 'ERIs1%stortype', ERIs1%stortype()) + 'ERIs1%inttype', ERIs1%inttype()) end select case default call mqc_error_A('Unknown or not implemented twoERI type in mqc_eri_eri_contraction', 6, & @@ -14430,10 +14823,10 @@ function mqc_eri_eri_contraction(eris1,eris2,label) result(output) output = output - contraction(temp%getBlock('bbbb'),eris2%getBlock('bbbb')) select case (eris2%type()) case ('space','regular') - select case(eris2%storType()) - case ('coulomb','symm') - select case(eris1%storType()) - case ('coulomb','symm') + select case(eris2%intType()) + case ('coulomb') + select case(eris1%intType()) + case ('coulomb') if(myLabel.ne.'exchange') & output = output + contraction(eris1%getBlock('aabb'),eris2%getBlock('aaaa')) & + contraction(eris1%getBlock('bbaa'),eris2%getBlock('aaaa')) @@ -14459,10 +14852,10 @@ function mqc_eri_eri_contraction(eris1,eris2,label) result(output) - contraction(temp%getBlock('baab'),eris2%getBlock('aaaa')) case default call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & - 'ERIs1%stortype', ERIs1%stortype()) + 'ERIs1%inttype', ERIs1%inttype()) end select case ('exchange') - select case(eris1%storType()) + select case(eris1%intType()) case ('coulomb','symm') if(myLabel.ne.'coulomb') & output = output - contraction(temp%getBlock('aabb'),eris2%getBlock('aaaa')) & @@ -14489,11 +14882,11 @@ function mqc_eri_eri_contraction(eris1,eris2,label) result(output) - contraction(temp%getBlock('bbaa'),eris2%getBlock('aaaa')) case default call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & - 'ERIs1%stortype', ERIs1%stortype()) + 'ERIs1%inttype', ERIs1%inttype()) end select case ('inverted') - select case(eris1%storType()) - case ('coulomb','symm','exchange','doublebar') + select case(eris1%intType()) + case ('coulomb','exchange','doublebar') ! Done case ('inverted') if(myLabel.ne.'exchange') & @@ -14511,17 +14904,17 @@ function mqc_eri_eri_contraction(eris1,eris2,label) result(output) - contraction(temp%getBlock('baba'),eris2%getBlock('aaaa')) case default call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & - 'ERIs1%stortype', ERIs1%stortype()) + 'ERIs1%inttype', ERIs1%inttype()) end select case default call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & - 'ERIs2%stortype', ERIs2%stortype()) + 'ERIs2%inttype', ERIs2%inttype()) end select case ('spin') - select case(eris1%storType()) - case ('coulomb','symm') - select case(eris2%storType()) - case ('coulomb','symm') + select case(eris1%intType()) + case ('coulomb') + select case(eris2%intType()) + case ('coulomb') if(myLabel.ne.'exchange') & output = output + contraction(eris1%getBlock('aabb'),eris2%getBlock('aabb')) & + contraction(eris1%getBlock('bbaa'),eris2%getBlock('bbaa')) @@ -14547,11 +14940,11 @@ function mqc_eri_eri_contraction(eris1,eris2,label) result(output) - contraction(temp%getBlock('baab'),eris2%getBlock('baab')) case default call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & - 'ERIs2%stortype', ERIs2%stortype()) + 'ERIs2%inttype', ERIs2%inttype()) end select case ('exchange') - select case(eris2%storType()) - case ('coulomb','symm') + select case(eris2%intType()) + case ('coulomb') if(myLabel.ne.'coulomb') & output = output - contraction(temp%getBlock('aabb'),eris2%getBlock('aabb')) & - contraction(temp%getBlock('bbaa'),eris2%getBlock('bbaa')) @@ -14577,11 +14970,11 @@ function mqc_eri_eri_contraction(eris1,eris2,label) result(output) - contraction(temp%getBlock('bbaa'),eris2%getBlock('bbaa')) case default call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & - 'ERIs2%stortype', ERIs2%stortype()) + 'ERIs2%inttype', ERIs2%inttype()) end select case ('inverted') - select case(eris2%storType()) - case ('coulomb','symm') + select case(eris2%intType()) + case ('coulomb') ! Done case ('exchange') ! Done @@ -14603,11 +14996,11 @@ function mqc_eri_eri_contraction(eris1,eris2,label) result(output) - contraction(temp%getBlock('baba'),eris2%getBlock('baba')) case default call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & - 'ERIs2%stortype', ERIs2%stortype()) + 'ERIs2%inttype', ERIs2%inttype()) end select case ('doublebar') - select case(eris2%storType()) - case ('coulomb','symm') + select case(eris2%intType()) + case ('coulomb') if(myLabel.ne.'exchange') & output = output + contraction(eris1%getBlock('aabb'),eris2%getBlock('aabb')) & + contraction(eris1%getBlock('bbaa'),eris2%getBlock('bbaa')) @@ -14647,11 +15040,11 @@ function mqc_eri_eri_contraction(eris1,eris2,label) result(output) - contraction(temp%getBlock('baab'),eris2%getBlock('baab')) case default call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & - 'ERIs2%stortype', ERIs2%stortype()) + 'ERIs2%inttype', ERIs2%inttype()) end select case ('ms') - select case(eris2%storType()) - case ('coulomb','symm') + select case(eris2%intType()) + case ('coulomb') if(myLabel.ne.'exchange') & output = output + contraction(eris1%getBlock('aabb'),eris2%getBlock('aabb')) & + contraction(eris1%getBlock('bbaa'),eris2%getBlock('bbaa')) @@ -14700,15 +15093,15 @@ function mqc_eri_eri_contraction(eris1,eris2,label) result(output) - contraction(temp%getBlock('baba'),eris2%getBlock('baba')) case default call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & - 'ERIs2%stortype', ERIs2%stortype()) + 'ERIs2%inttype', ERIs2%inttype()) end select case default call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & - 'ERIs1%stortype', ERIs1%stortype()) + 'ERIs1%inttype', ERIs1%inttype()) end select case ('general') - select case(eris1%storType()) - case ('coulomb','symm') + select case(eris1%intType()) + case ('coulomb') if(myLabel.ne.'exchange') & output = output + contraction(eris1%getBlock('aabb'),eris2%getBlock('aabb')) & + contraction(eris1%getBlock('bbaa'),eris2%getBlock('bbaa')) @@ -14757,7 +15150,7 @@ function mqc_eri_eri_contraction(eris1,eris2,label) result(output) - contraction(temp%getBlock('baba'),eris2%getBlock('baba')) case default call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & - 'ERIs1%stortype', ERIs1%stortype()) + 'ERIs1%inttype', ERIs1%inttype()) end select case default call mqc_error_A('Unknown or not implemented twoERI type in mqc_eri_eri_contraction', 6, & @@ -14770,8 +15163,8 @@ function mqc_eri_eri_contraction(eris1,eris2,label) result(output) output = output - contraction(temp%getBlock('bbbb'),eris2%getBlock('bbbb')) select case (eris2%type()) case ('space','regular') - select case(eris2%storType()) - case ('coulomb','symm') + select case(eris2%intType()) + case ('coulomb') if(myLabel.ne.'exchange') & output = output + contraction(eris1%getBlock('aabb'),eris2%getBlock('aaaa')) & + contraction(eris1%getBlock('bbaa'),eris2%getBlock('aaaa')) @@ -14794,11 +15187,11 @@ function mqc_eri_eri_contraction(eris1,eris2,label) result(output) - contraction(temp%getBlock('baba'),eris2%getBlock('aaaa')) case default call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & - 'ERIs2%stortype', ERIs2%stortype()) + 'ERIs2%inttype', ERIs2%inttype()) end select case ('spin') - select case(eris2%storType()) - case ('coulomb','symm') + select case(eris2%intType()) + case ('coulomb') if(myLabel.ne.'exchange') & output = output + contraction(eris1%getBlock('aabb'),eris2%getBlock('aabb')) & + contraction(eris1%getBlock('bbaa'),eris2%getBlock('bbaa')) @@ -14847,7 +15240,7 @@ function mqc_eri_eri_contraction(eris1,eris2,label) result(output) - contraction(temp%getBlock('baba'),eris2%getBlock('baba')) case default call mqc_error_A('Unknown or not implemented twoERI storage type in mqc_eri_eri_contraction', 6, & - 'ERIs2%stortype', ERIs2%stortype()) + 'ERIs2%inttype', ERIs2%inttype()) end select case ('general') if(myLabel.ne.'exchange') & @@ -15344,7 +15737,7 @@ function mqc_eri_eri_partial_contraction_2eri(eris1,eris2,index1,index2) result( type(MQC_R4Tensor)::aaaa,aaab,aaba,abaa,baaa,aabb,abab,baab,abba,baba,bbaa,& abbb,babb,bbab,bbba,bbbb type(MQC_R4Tensor)::tmp_aaaa,tmp_bbbb - character(len=64)::mylabel,eriType,storType + character(len=64)::mylabel,eriType,intType integer(kind=int64)::r4t1,r4t2,r4t3,r4t4,nB1,nB2,nB3,nB4 type(mqc_twoERIs)::temp Integer(kind=int64)::ia,ja,ka,la,ib,jb,kb,lb,i,j,k,l @@ -15413,13 +15806,13 @@ function mqc_eri_eri_partial_contraction_2eri(eris1,eris2,index1,index2) result( la.gt.4.or.la.le.0.or.lb.gt.4.or.lb.le.0.) Call MQC_Error(& 'Index out of range in MQC_ERI_ERI_Partial_Contraction_2eri', 6) - if(eris1%storageType.eq.'empty'.and.eris2%storageType.eq.'empty') then - call mqc_twoeris_allocate(eriOut,'empty','empty') + if(.not.allocated(eris1).and..not.allocated(eris2)) then + if(allocated(eriOut)) call deallocate(eriOut) return - else if(eris1%storageType.eq.'empty') then + else if(.not.allocated(eris1)) then eriOut = eris2 return - else if(eris2%storageType.eq.'empty') then + else if(.not.allocated(eris2)) then eriOut = eris1 return end if @@ -15464,7 +15857,7 @@ function mqc_eri_eri_partial_contraction_2eri(eris1,eris2,index1,index2) result( call aaab%init(eris1%blockSize('alpha',ka),eris1%blockSize('alpha',la),& eris2%blockSize('alpha',kb),eris2%blockSize('beta',lb)) - storType='unknown' + intType='unknown' eriType='empty' do i=1,16 allocVec(i)=.true. @@ -15529,49 +15922,49 @@ function mqc_eri_eri_partial_contraction_2eri(eris1,eris2,index1,index2) result( allocVec(2)=.true. case('aabb') if(eriType.eq.'space'.or.eriType.eq.'empty') eriType = 'spin' - if(storType.eq.'unknown') storType = 'coulomb' - if(storType.eq.'exchange') storType = 'doublebar' - if(storType.eq.'inverted') storType = 'ms' + if(intType.eq.'unknown') intType = 'coulomb' + if(intType.eq.'exchange') intType = 'doublebar' + if(intType.eq.'inverted') intType = 'ms' aabb = aabb + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) allocVec(3)=.true. case('bbaa') if(eriType.eq.'space'.or.eriType.eq.'empty') eriType = 'spin' - if(storType.eq.'unknown') storType = 'coulomb' - if(storType.eq.'exchange') storType = 'doublebar' - if(storType.eq.'inverted') storType = 'ms' + if(intType.eq.'unknown') intType = 'coulomb' + if(intType.eq.'exchange') intType = 'doublebar' + if(intType.eq.'inverted') intType = 'ms' bbaa = bbaa + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) allocVec(4)=.true. case('abab') if(eriType.eq.'space'.or.eriType.eq.'empty') eriType = 'spin' - if(storType.eq.'unknown') storType = 'inverted' - if(storType.eq.'exchange'.or.storType.eq.'coulomb'.or.& - storType.eq.'doublebar'.or.storType.eq.'unknown') storType = 'ms' + if(intType.eq.'unknown') intType = 'inverted' + if(intType.eq.'exchange'.or.intType.eq.'coulomb'.or.& + intType.eq.'doublebar'.or.intType.eq.'unknown') intType = 'ms' abab = abab + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) allocVec(5)=.true. case('abba') if(eriType.eq.'space'.or.eriType.eq.'empty') eriType = 'spin' - if(storType.eq.'unknown') storType = 'exchange' - if(storType.eq.'coulomb') storType = 'doublebar' - if(storType.eq.'inverted') storType = 'ms' + if(intType.eq.'unknown') intType = 'exchange' + if(intType.eq.'coulomb') intType = 'doublebar' + if(intType.eq.'inverted') intType = 'ms' abba = abba + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) allocVec(6)=.true. case('baab') if(eriType.eq.'space'.or.eriType.eq.'empty') eriType = 'spin' - if(storType.eq.'unknown') storType = 'exchange' - if(storType.eq.'coulomb') storType = 'doublebar' - if(storType.eq.'inverted') storType = 'ms' + if(intType.eq.'unknown') intType = 'exchange' + if(intType.eq.'coulomb') intType = 'doublebar' + if(intType.eq.'inverted') intType = 'ms' baab = baab + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) allocVec(7)=.true. case('baba') if(eriType.eq.'space'.or.eriType.eq.'empty') eriType = 'spin' - if(storType.eq.'unknown') storType = 'inverted' - if(storType.eq.'exchange'.or.storType.eq.'coulomb'.or.& - storType.eq.'doublebar'.or.storType.eq.'unknown') storType = 'ms' + if(intType.eq.'unknown') intType = 'inverted' + if(intType.eq.'exchange'.or.intType.eq.'coulomb'.or.& + intType.eq.'doublebar'.or.intType.eq.'unknown') intType = 'ms' baba = baba + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) allocVec(8)=.true. @@ -15579,7 +15972,7 @@ function mqc_eri_eri_partial_contraction_2eri(eris1,eris2,index1,index2) result( if(eris1%storageType.ne.'general'.and.eris2%storageType.ne.'general') cycle if(eris1%hasSpinBlock(str1).and.eris2%hasSpinBlock(str2)) then eriType='general' - storType = 'full' + intType = 'coulomb' abbb = abbb + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) allocVec(16)=.true. @@ -15588,7 +15981,7 @@ function mqc_eri_eri_partial_contraction_2eri(eris1,eris2,index1,index2) result( if(eris1%storageType.ne.'general'.and.eris2%storageType.ne.'general') cycle if(eris1%hasSpinBlock(str1).and.eris2%hasSpinBlock(str2)) then eriType='general' - storType = 'full' + intType = 'coulomb' babb = babb + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) allocVec(15)=.true. @@ -15597,7 +15990,7 @@ function mqc_eri_eri_partial_contraction_2eri(eris1,eris2,index1,index2) result( if(eris1%storageType.ne.'general'.and.eris2%storageType.ne.'general') cycle if(eris1%hasSpinBlock(str1).and.eris2%hasSpinBlock(str2)) then eriType='general' - storType = 'full' + intType = 'coulomb' bbab = bbab + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) allocVec(14)=.true. @@ -15606,7 +15999,7 @@ function mqc_eri_eri_partial_contraction_2eri(eris1,eris2,index1,index2) result( if(eris1%storageType.ne.'general'.and.eris2%storageType.ne.'general') cycle if(eris1%hasSpinBlock(str1).and.eris2%hasSpinBlock(str2)) then eriType='general' - storType = 'full' + intType = 'coulomb' bbba = bbba + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) allocVec(13)=.true. @@ -15615,7 +16008,7 @@ function mqc_eri_eri_partial_contraction_2eri(eris1,eris2,index1,index2) result( if(eris1%storageType.ne.'general'.and.eris2%storageType.ne.'general') cycle if(eris1%hasSpinBlock(str1).and.eris2%hasSpinBlock(str2)) then eriType='general' - storType = 'full' + intType = 'coulomb' baaa = baaa + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) allocVec(12)=.true. @@ -15624,7 +16017,7 @@ function mqc_eri_eri_partial_contraction_2eri(eris1,eris2,index1,index2) result( if(eris1%storageType.ne.'general'.and.eris2%storageType.ne.'general') cycle if(eris1%hasSpinBlock(str1).and.eris2%hasSpinBlock(str2)) then eriType='general' - storType = 'full' + intType = 'coulomb' abaa = abaa + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) allocVec(11)=.true. @@ -15633,7 +16026,7 @@ function mqc_eri_eri_partial_contraction_2eri(eris1,eris2,index1,index2) result( if(eris1%storageType.ne.'general'.and.eris2%storageType.ne.'general') cycle if(eris1%hasSpinBlock(str1).and.eris2%hasSpinBlock(str2)) then eriType='general' - storType = 'full' + intType = 'coulomb' aaba = aaba + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) allocVec(10)=.true. @@ -15642,7 +16035,7 @@ function mqc_eri_eri_partial_contraction_2eri(eris1,eris2,index1,index2) result( if(eris1%storageType.ne.'general'.and.eris2%storageType.ne.'general') cycle if(eris1%hasSpinBlock(str1).and.eris2%hasSpinBlock(str2)) then eriType='general' - storType = 'full' + intType = 'coulomb' aaab = aaab + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) allocVec(9)=.true. @@ -15652,25 +16045,25 @@ function mqc_eri_eri_partial_contraction_2eri(eris1,eris2,index1,index2) result( enddo enddo - if(storType.eq.'unknown') & + if(intType.eq.'unknown') & call mqc_error('Final StorageType unknown in mqc_eri_eri_partial_contraction_2eri',6) if (eriType.eq.'empty') then - call mqc_twoeris_allocate(eriOut,'empty','empty') + if(allocated(eriOut)) call deallocate(eriOut) else if (eriType.eq.'space') then - call mqc_twoeris_allocate(eriOut,storType,'space',aaaa,allocationVector=allocVec) + call mqc_twoeris_allocate(eriOut,'full-'//intType,'space',aaaa,allocationVector=allocVec) elseif (eriType.eq.'spin') then - if (storType.eq.'coulomb') then - call mqc_twoeris_allocate(eriOut,storType,'spin',aaaa,bbbb,aabb,bbaa) - else if (storType.eq.'exchange') then - call mqc_twoeris_allocate(eriOut,storType,'spin',aaaa,bbbb,abba,baab) - else if (storType.eq.'inverted') then - call mqc_twoeris_allocate(eriOut,storType,'spin',aaaa,bbbb,abab,baba) + if (intType.eq.'coulomb') then + call mqc_twoeris_allocate(eriOut,'full-'//intType,'spin',aaaa,bbbb,aabb,bbaa) + else if (intType.eq.'exchange') then + call mqc_twoeris_allocate(eriOut,'full-'//intType,'spin',aaaa,bbbb,abba,baab) + else if (intType.eq.'inverted') then + call mqc_twoeris_allocate(eriOut,'full-'//intType,'spin',aaaa,bbbb,abab,baba) else - call mqc_twoeris_allocate(eriOut,storType,'spin',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(eriOut,'full-'//intType,'spin',aaaa,bbbb,aabb,bbaa,& abab=abab,baba=baba,abba=abba,baab=baab,allocationVector=allocVec) end if elseif (eriType.eq.'general') then - call mqc_twoeris_allocate(eriOut,storType,'general',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(eriOut,'full-'//intType,'general',aaaa,bbbb,aabb,bbaa,& abab,abba,baab,baba,aaab,aaba,abaa,baaa,bbba,& bbab,babb,abbb,allocationVector=allocVec) endif @@ -15833,14 +16226,14 @@ function mqc_eri_dimension_swap(eris,dim1,dim2) result(output) call alpha%tput(taaaa%tat([i,i],[j,j],[0],[0]),[j,j],[i,i],[0],[0]) endDo endDo - if(eris%storageType.eq.'exchange') then - call mqc_twoeris_allocate(output,'inverted','space',alpha) - else if(eris%storageType.eq.'coulomb') then - call mqc_twoeris_allocate(output,'coulomb','space',alpha) - else if(eris%storageType.eq.'inverted') then - call mqc_twoeris_allocate(output,'exchange','space',alpha) + if(eris%interactionType.eq.'exchange') then + call mqc_twoeris_allocate(output,'full-inverted','space',alpha) + else if(eris%interactionType.eq.'coulomb') then + call mqc_twoeris_allocate(output,'full-coulomb','space',alpha) + else if(eris%interactionType.eq.'inverted') then + call mqc_twoeris_allocate(output,'full-exchange','space',alpha) else - call mqc_twoeris_allocate(output,'full','space',alpha) + call mqc_twoeris_allocate(output,'full-coulomb','space',alpha) end if case (3) call alpha%init(nB3a,nB2a,nB1a,nB4a) @@ -15849,14 +16242,14 @@ function mqc_eri_dimension_swap(eris,dim1,dim2) result(output) call alpha%tput(taaaa%tat([i,i],[0],[j,j],[0]),[j,j],[0],[i,i],[0]) endDo endDo - if(eris%storageType.eq.'coulomb') then - call mqc_twoeris_allocate(output,'exchange','space',alpha) - else if(eris%storageType.eq.'exchange') then - call mqc_twoeris_allocate(output,'coulomb','space',alpha) - else if(eris%storageType.eq.'inverted') then - call mqc_twoeris_allocate(output,'inverted','space',alpha) + if(eris%interactionType.eq.'coulomb') then + call mqc_twoeris_allocate(output,'full-exchange','space',alpha) + else if(eris%interactionType.eq.'exchange') then + call mqc_twoeris_allocate(output,'full-coulomb','space',alpha) + else if(eris%interactionType.eq.'inverted') then + call mqc_twoeris_allocate(output,'full-inverted','space',alpha) else - call mqc_twoeris_allocate(output,'full','space',alpha) + call mqc_twoeris_allocate(output,'full-coulomb','space',alpha) end if case (4) call alpha%init(nB4a,nB2a,nB3a,nB1a) @@ -15865,14 +16258,14 @@ function mqc_eri_dimension_swap(eris,dim1,dim2) result(output) call alpha%tput(taaaa%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) endDo endDo - if(eris%storageType.eq.'coulomb') then - call mqc_twoeris_allocate(output,'inverted','space',alpha) - else if(eris%storageType.eq.'exchange') then - call mqc_twoeris_allocate(output,'exchange','space',alpha) - else if(eris%storageType.eq.'inverted') then - call mqc_twoeris_allocate(output,'coulomb','space',alpha) + if(eris%interactionType.eq.'coulomb') then + call mqc_twoeris_allocate(output,'full-inverted','space',alpha) + else if(eris%interactionType.eq.'exchange') then + call mqc_twoeris_allocate(output,'full-exchange','space',alpha) + else if(eris%interactionType.eq.'inverted') then + call mqc_twoeris_allocate(output,'full-coulomb','space',alpha) else - call mqc_twoeris_allocate(output,'full','space',alpha) + call mqc_twoeris_allocate(output,'full-coulomb','space',alpha) end if end select case (2) @@ -15884,14 +16277,14 @@ function mqc_eri_dimension_swap(eris,dim1,dim2) result(output) call alpha%tput(taaaa%tat([0],[i,i],[j,j],[0]),[0],[j,j],[i,i],[0]) endDo endDo - if(eris%storageType.eq.'coulomb') then - call mqc_twoeris_allocate(output,'inverted','space',alpha) - else if(eris%storageType.eq.'exchange') then - call mqc_twoeris_allocate(output,'exchange','space',alpha) - else if(eris%storageType.eq.'inverted') then - call mqc_twoeris_allocate(output,'coulomb','space',alpha) + if(eris%interactionType.eq.'coulomb') then + call mqc_twoeris_allocate(output,'full-inverted','space',alpha) + else if(eris%interactionType.eq.'exchange') then + call mqc_twoeris_allocate(output,'full-exchange','space',alpha) + else if(eris%interactionType.eq.'inverted') then + call mqc_twoeris_allocate(output,'full-coulomb','space',alpha) else - call mqc_twoeris_allocate(output,'full','space',alpha) + call mqc_twoeris_allocate(output,'full-coulomb','space',alpha) end if case (4) call alpha%init(nB1a,nB4a,nB3a,nB2a) @@ -15900,14 +16293,14 @@ function mqc_eri_dimension_swap(eris,dim1,dim2) result(output) call alpha%tput(taaaa%tat([0],[i,i],[0],[j,j]),[0],[j,j],[0],[i,i]) endDo endDo - if(eris%storageType.eq.'coulomb') then - call mqc_twoeris_allocate(output,'exchange','space',alpha) - else if(eris%storageType.eq.'exchange') then - call mqc_twoeris_allocate(output,'coulomb','space',alpha) - else if(eris%storageType.eq.'inverted') then - call mqc_twoeris_allocate(output,'inverted','space',alpha) + if(eris%interactionType.eq.'coulomb') then + call mqc_twoeris_allocate(output,'full-exchange','space',alpha) + else if(eris%interactionType.eq.'exchange') then + call mqc_twoeris_allocate(output,'full-coulomb','space',alpha) + else if(eris%interactionType.eq.'inverted') then + call mqc_twoeris_allocate(output,'full-inverted','space',alpha) else - call mqc_twoeris_allocate(output,'full','space',alpha) + call mqc_twoeris_allocate(output,'full-coulomb','space',alpha) end if end select case (3) @@ -15917,14 +16310,14 @@ function mqc_eri_dimension_swap(eris,dim1,dim2) result(output) call alpha%tput(taaaa%tat([0],[0],[i,i],[j,j]),[0],[0],[j,j],[i,i]) endDo endDo - if(eris%storageType.eq.'coulomb') then - call mqc_twoeris_allocate(output,'coulomb','space',alpha) - else if(eris%storageType.eq.'exchange') then - call mqc_twoeris_allocate(output,'exchange','space',alpha) - else if(eris%storageType.eq.'inverted') then - call mqc_twoeris_allocate(output,'inverted','space',alpha) + if(eris%interactionType.eq.'coulomb') then + call mqc_twoeris_allocate(output,'full-coulomb','space',alpha) + else if(eris%interactionType.eq.'exchange') then + call mqc_twoeris_allocate(output,'full-exchange','space',alpha) + else if(eris%interactionType.eq.'inverted') then + call mqc_twoeris_allocate(output,'full-inverted','space',alpha) else - call mqc_twoeris_allocate(output,'full','space',alpha) + call mqc_twoeris_allocate(output,'full-coulomb','space',alpha) end if end select case ('spin') @@ -15963,17 +16356,17 @@ function mqc_eri_dimension_swap(eris,dim1,dim2) result(output) call beta%tput(tbbbb%tat([i,i],[j,j],[0],[0]),[j,j],[i,i],[0],[0]) endDo endDo - if(eris%storageType.eq.'exchange') then - call mqc_twoeris_allocate(output,'inverted','spin',& + if(eris%interactionType.eq.'exchange') then + call mqc_twoeris_allocate(output,'full-inverted','spin',& alpha,beta,alphaBeta,betaAlpha) - else if(eris%storageType.eq.'coulomb') then - call mqc_twoeris_allocate(output,'coulomb','spin',& + else if(eris%interactionType.eq.'coulomb') then + call mqc_twoeris_allocate(output,'full-coulomb','spin',& alpha,beta,alphaBeta,betaAlpha) - else if(eris%storageType.eq.'inverted') then - call mqc_twoeris_allocate(output,'exchange','spin',& + else if(eris%interactionType.eq.'inverted') then + call mqc_twoeris_allocate(output,'full-exchange','spin',& alpha,beta,alphaBeta,betaAlpha) else - call mqc_twoeris_allocate(output,'full','spin',& + call mqc_twoeris_allocate(output,'full-coulomb','spin',& alpha,beta,alphaBeta,betaAlpha) end if case (3) @@ -15993,17 +16386,17 @@ function mqc_eri_dimension_swap(eris,dim1,dim2) result(output) call beta%tput(tbbbb%tat([i,i],[0],[j,j],[0]),[j,j],[0],[i,i],[0]) endDo endDo - if(eris%storageType.eq.'exchange') then - call mqc_twoeris_allocate(output,'inverted','spin',& + if(eris%interactionType.eq.'exchange') then + call mqc_twoeris_allocate(output,'full-inverted','spin',& alpha,beta,alphaBeta,betaAlpha) - else if(eris%storageType.eq.'coulomb') then - call mqc_twoeris_allocate(output,'coulomb','spin',& + else if(eris%interactionType.eq.'coulomb') then + call mqc_twoeris_allocate(output,'full-coulomb','spin',& alpha,beta,alphaBeta,betaAlpha) - else if(eris%storageType.eq.'inverted') then - call mqc_twoeris_allocate(output,'exchange','spin',& + else if(eris%interactionType.eq.'inverted') then + call mqc_twoeris_allocate(output,'full-exchange','spin',& alpha,beta,alphaBeta,betaAlpha) else - call mqc_twoeris_allocate(output,'full','spin',& + call mqc_twoeris_allocate(output,'full-coulomb','spin',& alpha,beta,alphaBeta,betaAlpha) end if case (4) @@ -16023,17 +16416,17 @@ function mqc_eri_dimension_swap(eris,dim1,dim2) result(output) call beta%tput(tbbbb%tat([i,i],[0],[0],[j,j]),[j,j],[0],[0],[i,i]) endDo endDo - if(eris%storageType.eq.'coulomb') then - call mqc_twoeris_allocate(output,'exchange','spin',& + if(eris%interactionType.eq.'coulomb') then + call mqc_twoeris_allocate(output,'full-exchange','spin',& alpha,beta,alphaBeta,betaAlpha) - else if(eris%storageType.eq.'exchange') then - call mqc_twoeris_allocate(output,'inverted','spin',& + else if(eris%interactionType.eq.'exchange') then + call mqc_twoeris_allocate(output,'full-inverted','spin',& alpha,beta,alphaBeta,betaAlpha) - else if(eris%storageType.eq.'inverted') then - call mqc_twoeris_allocate(output,'coulomb','spin',& + else if(eris%interactionType.eq.'inverted') then + call mqc_twoeris_allocate(output,'full-coulomb','spin',& alpha,beta,alphaBeta,betaAlpha) else - call mqc_twoeris_allocate(output,'full','spin',& + call mqc_twoeris_allocate(output,'full-coulomb','spin',& alpha,beta,alphaBeta,betaAlpha) endIf end select @@ -16056,17 +16449,17 @@ function mqc_eri_dimension_swap(eris,dim1,dim2) result(output) call beta%tput(tbbbb%tat([0],[i,i],[j,j],[0]),[0],[j,j],[i,i],[0]) endDo endDo - if(eris%storageType.eq.'coulomb') then - call mqc_twoeris_allocate(output,'inverted','spin',& + if(eris%interactionType.eq.'coulomb') then + call mqc_twoeris_allocate(output,'full-inverted','spin',& alpha,beta,alphaBeta,betaAlpha) - else if(eris%storageType.eq.'exchange') then - call mqc_twoeris_allocate(output,'exchange','spin',& + else if(eris%interactionType.eq.'exchange') then + call mqc_twoeris_allocate(output,'full-exchange','spin',& alpha,beta,alphaBeta,betaAlpha) - else if(eris%storageType.eq.'inverted') then - call mqc_twoeris_allocate(output,'coulomb','spin',& + else if(eris%interactionType.eq.'inverted') then + call mqc_twoeris_allocate(output,'full-coulomb','spin',& alpha,beta,alphaBeta,betaAlpha) else - call mqc_twoeris_allocate(output,'full','spin',& + call mqc_twoeris_allocate(output,'full-coulomb','spin',& alpha,beta,alphaBeta,betaAlpha) endIf case (4) @@ -16086,17 +16479,17 @@ function mqc_eri_dimension_swap(eris,dim1,dim2) result(output) call beta%tput(tbbbb%tat([0],[i,i],[0],[j,j]),[0],[j,j],[0],[i,i]) endDo endDo - if(eris%storageType.eq.'coulomb') then - call mqc_twoeris_allocate(output,'exchange','spin',& + if(eris%interactionType.eq.'coulomb') then + call mqc_twoeris_allocate(output,'full-exchange','spin',& alpha,beta,alphaBeta,betaAlpha) - else if(eris%storageType.eq.'exchange') then - call mqc_twoeris_allocate(output,'coulomb','spin',& + else if(eris%interactionType.eq.'exchange') then + call mqc_twoeris_allocate(output,'full-coulomb','spin',& alpha,beta,alphaBeta,betaAlpha) - else if(eris%storageType.eq.'inverted') then - call mqc_twoeris_allocate(output,'inverted','spin',& + else if(eris%interactionType.eq.'inverted') then + call mqc_twoeris_allocate(output,'full-inverted','spin',& alpha,beta,alphaBeta,betaAlpha) else - call mqc_twoeris_allocate(output,'full','spin',& + call mqc_twoeris_allocate(output,'full-coulomb','spin',& alpha,beta,alphaBeta,betaAlpha) endIf end select @@ -16117,17 +16510,17 @@ function mqc_eri_dimension_swap(eris,dim1,dim2) result(output) call beta%tput(tbbbb%tat([0],[0],[i,i],[j,j]),[0],[0],[j,j],[i,i]) endDo endDo - if(eris%storageType.eq.'coulomb') then - call mqc_twoeris_allocate(output,'coulomb','spin',& + if(eris%interactionType.eq.'coulomb') then + call mqc_twoeris_allocate(output,'full-coulomb','spin',& alpha,beta,alphaBeta,betaAlpha) - else if(eris%storageType.eq.'exchange') then - call mqc_twoeris_allocate(output,'inverted','spin',& + else if(eris%interactionType.eq.'exchange') then + call mqc_twoeris_allocate(output,'full-inverted','spin',& alpha,beta,alphaBeta,betaAlpha) - else if(eris%storageType.eq.'inverted') then - call mqc_twoeris_allocate(output,'coulomb','spin',& + else if(eris%interactionType.eq.'inverted') then + call mqc_twoeris_allocate(output,'full-coulomb','spin',& alpha,beta,alphaBeta,betaAlpha) else - call mqc_twoeris_allocate(output,'full','spin',& + call mqc_twoeris_allocate(output,'full-coulomb','spin',& alpha,beta,alphaBeta,betaAlpha) endIf end select @@ -17078,7 +17471,7 @@ function mqc_eri_dimension_swap(eris,dim1,dim2) result(output) finalAllocVec(16)=.true. end if end select - call mqc_twoeris_allocate(output,'full','general',& + call mqc_twoeris_allocate(output,'full-coulomb','general',& alpha,beta,alphaBeta,betaAlpha,& abab,abba,baab,baba,& aaab,aaba,abaa,baaa,& @@ -17142,6 +17535,11 @@ function mqc_eri_interaction(eris,label) result(output) integer(kind=int64)::nBasis,i,j type(mqc_r4tensor)::temp,temp2 ! + if(eris%intType().ne.'coulomb') & + call mqc_error_a('mqc_eri_interaction function only implemented for coulomb & + &interaction types. Please consider implementing this subroutine for other types',& + 6,'eris%intType()',eris%intType()) +! if(present(label)) then call string_change_case(label,'L',myLabel) else @@ -17151,7 +17549,7 @@ function mqc_eri_interaction(eris,label) result(output) if (myLabel.eq.'exchange'.or.myLabel.eq.'doublebar') then if (eris%blockSize('alpha',4).ne.eris%blockSize('alpha',2).or.& eris%blockSize('beta',4).ne.eris%blockSize('beta',2)) then - write(6,'(A,1x,I5,1x)4') 'Dim 4 alpha = ',eris%blockSize('alpha',4),& + write(6,'(4(A,1x,I5,1x))') 'Dim 4 alpha = ',eris%blockSize('alpha',4),& 'Dim 2 alpha = ',eris%blockSize('alpha',2),& 'Dim 4 beta = ',eris%blockSize('beta',4),& 'Dim 2 beta = ',eris%blockSize('beta',2) @@ -17173,7 +17571,7 @@ function mqc_eri_interaction(eris,label) result(output) call temp%tput(temp2%tat([0],[i,i],[0],[j,j]),[0],[j,j],[0],[i,i]) endDo endDo - call mqc_twoeris_allocate(output,'full','regular',temp) + call mqc_twoeris_allocate(output,'full-coulomb','regular',temp) case('doublebar') temp = eris temp2 = eris @@ -17184,7 +17582,7 @@ function mqc_eri_interaction(eris,label) result(output) endDo endDo temp = temp2 - temp - call mqc_twoeris_allocate(output,'full','regular',temp) + call mqc_twoeris_allocate(output,'full-coulomb','regular',temp) case default call mqc_error_a('Interaction type not recognized in mqc_eri_interaction',& 6,'myLabel',myLabel) @@ -17202,7 +17600,7 @@ function mqc_eri_interaction(eris,label) result(output) call temp%tput(temp2%tat([0],[i,i],[0],[j,j]),[0],[j,j],[0],[i,i]) endDo endDo - call mqc_twoeris_allocate(output,'full','space',temp) + call mqc_twoeris_allocate(output,'full-coulomb','space',temp) case('doublebar') temp = eris temp2 = eris @@ -17213,7 +17611,7 @@ function mqc_eri_interaction(eris,label) result(output) endDo endDo temp = temp2 - temp - call mqc_twoeris_allocate(output,'full','space',temp) + call mqc_twoeris_allocate(output,'full-coulomb','space',temp) case default call mqc_error_a('Interaction type not recognized in mqc_eri_interaction',& 6,'myLabel',myLabel) @@ -17252,7 +17650,7 @@ function mqc_eri_interaction(eris,label) result(output) endDo endDo if(eris%storageType.eq.'full') then - call mqc_twoeris_allocate(output,'full','general',& + call mqc_twoeris_allocate(output,'full-coulomb','general',& temp%tat([1,nBasis],[1,nBasis],[1,nBasis],[1,nBasis]),& temp%tat([nBasis+1,2*nBasis],[nBasis+1,2*nBasis],[nBasis+1,2*nBasis],[nBasis+1,2*nBasis]),& temp%tat([1,nBasis],[1,nBasis],[nBasis+1,2*nBasis],[nBasis+1,2*nBasis]),& @@ -17270,7 +17668,7 @@ function mqc_eri_interaction(eris,label) result(output) temp%tat([nBasis+1,2*nBasis],[1,nBasis],[nBasis+1,2*nBasis],[nBasis+1,2*nBasis]),& temp%tat([1,nBasis],[nBasis+1,2*nBasis],[nBasis+1,2*nBasis],[nBasis+1,2*nBasis])) else - call mqc_twoeris_allocate(output,'symm','general',& + call mqc_twoeris_allocate(output,'symm-coulomb','general',& temp%tat([1,nBasis],[1,nBasis],[1,nBasis],[1,nBasis]),& temp%tat([nBasis+1,2*nBasis],[nBasis+1,2*nBasis],[nBasis+1,2*nBasis],[nBasis+1,2*nBasis]),& temp%tat([1,nBasis],[1,nBasis],[nBasis+1,2*nBasis],[nBasis+1,2*nBasis]),& @@ -17310,7 +17708,7 @@ function mqc_eri_interaction(eris,label) result(output) endDo temp = temp2 - temp if(eris%storageType.eq.'full') then - call mqc_twoeris_allocate(output,'full','general',& + call mqc_twoeris_allocate(output,'full-coulomb','general',& temp%tat([1,nBasis],[1,nBasis],[1,nBasis],[1,nBasis]),& temp%tat([nBasis+1,2*nBasis],[nBasis+1,2*nBasis],[nBasis+1,2*nBasis],[nBasis+1,2*nBasis]),& temp%tat([1,nBasis],[1,nBasis],[nBasis+1,2*nBasis],[nBasis+1,2*nBasis]),& @@ -17328,7 +17726,7 @@ function mqc_eri_interaction(eris,label) result(output) temp%tat([nBasis+1,2*nBasis],[1,nBasis],[nBasis+1,2*nBasis],[nBasis+1,2*nBasis]),& temp%tat([1,nBasis],[nBasis+1,2*nBasis],[nBasis+1,2*nBasis],[nBasis+1,2*nBasis])) else - call mqc_twoeris_allocate(output,'symm','general',& + call mqc_twoeris_allocate(output,'symm-coulomb','general',& temp%tat([1,nBasis],[1,nBasis],[1,nBasis],[1,nBasis]),& temp%tat([nBasis+1,2*nBasis],[nBasis+1,2*nBasis],[nBasis+1,2*nBasis],[nBasis+1,2*nBasis]),& temp%tat([1,nBasis],[1,nBasis],[nBasis+1,2*nBasis],[nBasis+1,2*nBasis]),& @@ -17405,7 +17803,7 @@ function mqc_eri_interaction(eris,label) result(output) endDo endDo if(eris%storageType.eq.'full') then - call mqc_twoeris_allocate(output,'full','general',& + call mqc_twoeris_allocate(output,'full-coulomb','general',& temp%tat([1,nBasis],[1,nBasis],[1,nBasis],[1,nBasis]),& temp%tat([nBasis+1,2*nBasis],[nBasis+1,2*nBasis],[nBasis+1,2*nBasis],[nBasis+1,2*nBasis]),& temp%tat([1,nBasis],[1,nBasis],[nBasis+1,2*nBasis],[nBasis+1,2*nBasis]),& @@ -17423,7 +17821,7 @@ function mqc_eri_interaction(eris,label) result(output) temp%tat([nBasis+1,2*nBasis],[1,nBasis],[nBasis+1,2*nBasis],[nBasis+1,2*nBasis]),& temp%tat([1,nBasis],[nBasis+1,2*nBasis],[nBasis+1,2*nBasis],[nBasis+1,2*nBasis])) else - call mqc_twoeris_allocate(output,'symm','general',& + call mqc_twoeris_allocate(output,'symm-coulomb','general',& temp%tat([1,nBasis],[1,nBasis],[1,nBasis],[1,nBasis]),& temp%tat([nBasis+1,2*nBasis],[nBasis+1,2*nBasis],[nBasis+1,2*nBasis],[nBasis+1,2*nBasis]),& temp%tat([1,nBasis],[1,nBasis],[nBasis+1,2*nBasis],[nBasis+1,2*nBasis]),& @@ -17493,7 +17891,7 @@ function mqc_eri_interaction(eris,label) result(output) endDo temp = temp2 - temp if(eris%storageType.eq.'full') then - call mqc_twoeris_allocate(output,'full','general',& + call mqc_twoeris_allocate(output,'full-coulomb','general',& temp%tat([1,nBasis],[1,nBasis],[1,nBasis],[1,nBasis]),& temp%tat([nBasis+1,2*nBasis],[nBasis+1,2*nBasis],[nBasis+1,2*nBasis],[nBasis+1,2*nBasis]),& temp%tat([1,nBasis],[1,nBasis],[nBasis+1,2*nBasis],[nBasis+1,2*nBasis]),& @@ -17511,7 +17909,7 @@ function mqc_eri_interaction(eris,label) result(output) temp%tat([nBasis+1,2*nBasis],[1,nBasis],[nBasis+1,2*nBasis],[nBasis+1,2*nBasis]),& temp%tat([1,nBasis],[nBasis+1,2*nBasis],[nBasis+1,2*nBasis],[nBasis+1,2*nBasis])) else - call mqc_twoeris_allocate(output,'symm','general',& + call mqc_twoeris_allocate(output,'symm-coulomb','general',& temp%tat([1,nBasis],[1,nBasis],[1,nBasis],[1,nBasis]),& temp%tat([nBasis+1,2*nBasis],[nBasis+1,2*nBasis],[nBasis+1,2*nBasis],[nBasis+1,2*nBasis]),& temp%tat([1,nBasis],[1,nBasis],[nBasis+1,2*nBasis],[nBasis+1,2*nBasis]),& @@ -19216,6 +19614,11 @@ function MQC_twoERIs_At(twoERIs,i,j,k,l,spinBlockIn,interactionIn) result(elemen character(len=64)::spinBlock,interaction real(kind=real64)::zero=0.0d0 + if(twoeris%intType().ne.'coulomb') & + call mqc_error_a('mqc_twoeris_at function only implemented for coulomb & + &interaction types. Please consider implementing this subroutine for other types',& + 6,'twoeris%intType()',twoeris%intType()) + element = zero select type (i) type is (integer) @@ -23013,7 +23416,7 @@ Function Slater_Condon(IOut,IPrint,Alpha_String_1,Beta_String_1, & ISgn = ISgn-2 If(Det(1).eq.Det(2).and.Det(3).eq.Det(4)) then - ! Write(IOut,*) 'Entering case 1' +! Write(IOut,*) 'Entering case 1' ! If(Spin(1).gt.Spin(2)) ISgn = ISgn+1 If(Spin(3).gt.Spin(4)) ISgn = ISgn+1 @@ -23761,11 +24164,6 @@ Subroutine TwoERI_Trans(IOut,IPrint,MO_Coeff,ERIs,MO_ERIs,Right_MOs) Character(len=15)::storage,intType Integer(kind=int64)::NPAlpha,NPBeta,NQAlpha,NQBeta,NRAlpha,NRBeta,NSAlpha,NSBeta Integer(kind=int64)::NMuAlpha,NNuAlpha,NLambdaAlpha,NSigmaAlpha,NMuBeta,NNuBeta,NLambdaBeta,NSigmaBeta - - - - - ! 1000 Format(1x,'(',I3,',',I3,'|',I3,',',I3,') = ',F15.8) 2000 Format(1x,'Doing O(N**8) integral transformation algorithm') @@ -23775,6 +24173,10 @@ Subroutine TwoERI_Trans(IOut,IPrint,MO_Coeff,ERIs,MO_ERIs,Right_MOs) ! DoON5 = .True. ! + if(ERIs%type().ne.'regular') call mqc_error_a('twoeri_trans function only works for & + & regular integrals (AO->MO transformation)',6,'ERIs%intType()',ERIs%intType()) + if(ERIs%inttype().ne.'coulomb') call mqc_error_a('twoeri_trans function only works for & + & coulomb integrals (AO->MO transformation)',6,'ERIs%intType()',ERIs%intType()) ! If(Present(Right_MOs))then MO_Coeff_2 = Right_MOs @@ -26615,20 +27017,20 @@ Subroutine TwoERI_Trans(IOut,IPrint,MO_Coeff,ERIs,MO_ERIs,Right_MOs) EndIf If(intType.eq.'space') then - call mqc_twoeris_allocate(mo_eris,'coulomb','space',tmpR4TensorAlpha) + call mqc_twoeris_allocate(mo_eris,'full-coulomb','space',tmpR4TensorAlpha) ElseIf(intType.eq.'spin'.and.storage.eq.'full') then - call mqc_twoeris_allocate(mo_eris,'coulomb','spin',tmpR4TensorAlpha,tmpR4TensorBeta, & + call mqc_twoeris_allocate(mo_eris,'full-coulomb','spin',tmpR4TensorAlpha,tmpR4TensorBeta, & tmpR4TensorAlphaBeta,tmpR4TensorBetaAlpha) ElseIf(intType.eq.'spin'.and.storage.eq.'symm') then - call mqc_twoeris_allocate(mo_eris,'symm','spin',tmpR4TensorAlpha,tmpR4TensorBeta, & + call mqc_twoeris_allocate(mo_eris,'symm-coulomb','spin',tmpR4TensorAlpha,tmpR4TensorBeta, & tmpR4TensorAlphaBeta) ElseIf(intType.eq.'general'.and.storage.eq.'full') then - call mqc_twoeris_allocate(mo_eris,'full','general',tmpR4TensorAlpha,tmpR4TensorBeta, & + call mqc_twoeris_allocate(mo_eris,'full-coulomb','general',tmpR4TensorAlpha,tmpR4TensorBeta, & tmpR4TensorAlphaBeta,tmpR4TensorBetaAlpha,tmpR4TensorABAB,tmpR4TensorABBA,tmpR4TensorBAAB, & tmpR4TensorBABA,tmpR4TensorAAAB,tmpR4TensorAABA,tmpR4TensorABAA,tmpR4TensorBAAA,tmpR4TensorBBBA,& tmpR4TensorBBAB,tmpR4TensorBABB,tmpR4TensorABBB) ElseIf(intType.eq.'general'.and.storage.eq.'symm') then - call mqc_twoeris_allocate(mo_eris,'symm','general',tmpR4TensorAlpha,tmpR4TensorBeta, & + call mqc_twoeris_allocate(mo_eris,'symm-coulomb','general',tmpR4TensorAlpha,tmpR4TensorBeta, & tmpR4TensorAlphaBeta,abab=tmpR4TensorABAB,abba=tmpR4TensorABBA,aaab=tmpR4TensorAAAB,& abbb=tmpR4TensorABBB) Else @@ -26709,42 +27111,51 @@ function mqc_twoeris_conjugate_transpose(ERIs,label) result(ERIsOut) if(present(label)) then call string_change_case(label,'l',myLabel) else - myLabel = ERIs%storageType + myLabel = ERIs%interactionType endIf + myLabel = ERIs%storageType//'-'//mylabel select case (ERIs%integralType) - case('space') - tmpaaaa = dagger(ERIs%getblock('aaaa')) - call mqc_twoeris_allocate(ERIsOut,myLabel,'space',tmpaaaa)!, & - ! nDimA1=size(integral,'alpha',2),nDimA2=size(integral,'alpha',1),& - ! nDimB1=size(integral,'beta',2),nDimB2=size(integral,'beta',1)) + case('regular','raffenetti1','raffenetti2','raffenetti3','space') + tmpaaaa = dagger(ERIs%getblock('aaaa')) + call mqc_twoeris_allocate(ERIsOut,myLabel,'space',tmpaaaa)!, & + ! nDimA1=size(integral,'alpha',2),nDimA2=size(integral,'alpha',1),& + ! nDimB1=size(integral,'beta',2),nDimB2=size(integral,'beta',1)) case('spin') - tmpaaaa = dagger(ERIs%getblock('aaaa')) - tmpaabb = dagger(ERIs%getblock('bbaa')) + tmpaaaa = dagger(ERIs%getblock('aaaa')) + tmpaabb = dagger(ERIs%getblock('bbaa')) + tmpbbbb = dagger(ERIs%getblock('bbbb')) + if(ERIs%storageType.eq.'full') then tmpbbaa = dagger(ERIs%getblock('aabb')) - tmpbbbb = dagger(ERIs%getblock('bbbb')) call mqc_twoeris_allocate(ERIsOut,myLabel,'spin',tmpaaaa,tmpbbbb,tmpaabb,tmpbbaa)!, & + else + call mqc_twoeris_allocate(ERIsOut,myLabel,'spin',tmpaaaa,tmpbbbb,tmpaabb)!, & + endIf case('general') - tmpaaaa = dagger(ERIs%getblock('aaaa')) - tmpaabb = dagger(ERIs%getblock('bbaa')) + tmpaaaa = dagger(ERIs%getblock('aaaa')) + tmpaabb = dagger(ERIs%getblock('bbaa')) + tmpbbbb = dagger(ERIs%getblock('bbbb')) + tmpabba = dagger(ERIs%getblock('abba')) + tmpbaba = dagger(ERIs%getblock('abab')) + tmpaaab = dagger(ERIs%getblock('baaa')) + tmpbbba = dagger(ERIs%getblock('abbb')) + if(ERIs%storageType.eq.'full') then tmpbbaa = dagger(ERIs%getblock('aabb')) - tmpbbbb = dagger(ERIs%getblock('bbbb')) - tmpaaab = dagger(ERIs%getblock('baaa')) tmpaaba = dagger(ERIs%getblock('abaa')) tmpabaa = dagger(ERIs%getblock('aaba')) tmpbaaa = dagger(ERIs%getblock('aaab')) tmpabab = dagger(ERIs%getblock('baba')) tmpbaab = dagger(ERIs%getblock('baab')) - tmpbaba = dagger(ERIs%getblock('abab')) - tmpabba = dagger(ERIs%getblock('abba')) tmpabbb = dagger(ERIs%getblock('bbba')) tmpbabb = dagger(ERIs%getblock('bbab')) tmpbbab = dagger(ERIs%getblock('babb')) - tmpbbba = dagger(ERIs%getblock('abbb')) call mqc_twoeris_allocate(ERIsOut,myLabel,'general',tmpaaaa,tmpbbbb,tmpaabb,tmpbbaa,& - tmpabab,tmpabba,tmpbaab,tmpbaba,& - tmpaaab,tmpaaba,tmpabaa,tmpbaaa,& - tmpbbba,tmpbbab,tmpbabb,tmpabbb) + tmpabab,tmpabba,tmpbaab,tmpbaba,tmpaaab,tmpaaba,tmpabaa,tmpbaaa,tmpbbba,tmpbbab,& + tmpbabb,tmpabbb) + else + call mqc_twoeris_allocate(ERIsOut,myLabel,'general',tmpaaaa,tmpbbbb,tmpaabb,& + abab=tmpabab,abba=tmpabba,aaab=tmpaaab,abbb=tmpabbb) + endIf case default call mqc_error_A('Unknown integral type in mqc_twoERIs_conjugate_transpose', 6, & 'ERIs%integralType', ERIs%integralType ) From f3801a17658ade12e9bb90721ebcaabbb3817dd5 Mon Sep 17 00:00:00 2001 From: mm Date: Tue, 19 May 2026 10:13:54 -0400 Subject: [PATCH 30/37] Hot bugfix --- src/mqc_est.F03 | 344 +++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 325 insertions(+), 19 deletions(-) diff --git a/src/mqc_est.F03 b/src/mqc_est.F03 index 0b2725f7..26ab0ada 100644 --- a/src/mqc_est.F03 +++ b/src/mqc_est.F03 @@ -480,6 +480,7 @@ Module MQC_EST ! !> \brief Sums two variables Interface Operator (+) + Module Procedure MQC_Eigenvalues_Sum Module Procedure MQC_Integral_Sum Module Procedure MQC_ERI_Sum End Interface @@ -498,6 +499,8 @@ Module MQC_EST ! !> \brief Multiplies two variables Interface Operator (*) + Module Procedure MQC_Scalar_eigenvalues_Multiply + Module Procedure MQC_eigenvalues_Scalar_Multiply Module Procedure MQC_Scalar_Integral_Multiply Module Procedure MQC_Integral_Scalar_Multiply Module Procedure MQC_Scalar_twoERIs_Multiply @@ -7340,6 +7343,145 @@ function mqc_integral_pad(integral,axis1,axis2,blockname) result(integralOut) end function mqc_integral_pad ! ! +! PROCEDURE MQC_Eigenvalues_Sum +! +!> \brief MQC_Eigenvalues_Sum is used to sum two MQC Eigenvalues type variables +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_Eigenvalues_Sum is used to sum two MQC Eigenvalues type variables. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] EigA +!> \verbatim +!> EigA is type(mqc_scf_Eigenvalues) +!> The first MQC Eigenvalues variable to sum. +!> \endverbatim +!> +!> \param[in] EigB +!> \verbatim +!> EigB is type(mqc_scf_Eigenvalues) +!> The second MQC Eigenvalues variable to sum. +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_Eigenvalues_sum(EigA,EigB) result(EigOut) +! + implicit none + type(mqc_scf_Eigenvalues),intent(in)::EigA,EigB + type(mqc_scf_Eigenvalues)::EigOut + type(mqc_vector)::tmpVectorAlpha,tmpVectorBeta +! + if(size(EigA,'alpha').ne.size(EigB,'alpha').or.& + size(EigA,'beta').ne.size(EigA,'beta')) call mqc_error_i('Integral blocks are & + ¬ conformable in mqc_Eigenvalues_sum',6,& + 'size(EigA,alpha)',size(EigA,'alpha'),& + 'size(EigB,alpha)',size(EigB,'alpha'),& + 'size(EigA,beta)',size(EigA,'beta'),& + 'size(EigB,beta)',size(EigB,'beta')) +! + select case(EigA%array_type) + case('space') + select case (EigB%array_type) + case('space') + if(EigA%hasAlpha()) then + if(EigB%hasAlpha()) then + tmpVectorAlpha = EigA%alpha+EigB%alpha + else + tmpVectorAlpha = EigA%alpha + end if + else + if(EigB%hasAlpha()) tmpVectorAlpha = EigB%alpha + end if + call mqc_eigenvalues_allocate(EigOut,'','space',tmpVectorAlpha) + case('spin') + if(EigA%hasAlpha()) then + if(EigB%hasAlpha()) then + tmpVectorAlpha = EigA%alpha+EigB%alpha + else + tmpVectorAlpha = EigA%alpha + end if + else + if(EigB%hasAlpha()) tmpVectorAlpha = EigB%alpha + end if + if(EigA%hasAlpha()) then + if(EigB%hasBeta()) then + tmpVectorBeta = EigA%alpha+EigB%beta + else + tmpVectorBeta = EigA%alpha + end if + else + if(EigB%hasBeta()) tmpVectorBeta = EigB%beta + end if + call mqc_eigenvalues_allocate(EigOut,'','spin',tmpVectorAlpha,tmpVectorBeta) + case default + call mqc_error_A('Unknown integral type in mqc_eigenvalues_sum', 6, & + 'EigB%array_type', EigB%array_type ) + end select + case('spin') + select case (EigB%array_type) + case('space') + if(EigA%hasAlpha()) then + if(EigB%hasAlpha()) then + tmpVectorAlpha = EigA%alpha+EigB%alpha + else + tmpVectorAlpha = EigA%alpha + end if + else + if(EigB%hasAlpha()) tmpVectorAlpha = EigB%alpha + end if + if(EigA%hasBeta()) then + if(EigB%hasAlpha()) then + tmpVectorBeta = EigA%beta+EigB%alpha + else + tmpVectorBeta = EigA%beta + end if + else + if(EigB%hasAlpha()) tmpVectorBeta = EigB%alpha + end if + call mqc_eigenvalues_allocate(EigOut,'','spin',tmpVectorAlpha,tmpVectorBeta) + case('spin') + if(EigA%hasAlpha()) then + if(EigB%hasAlpha()) then + tmpVectorAlpha = EigA%alpha+EigB%alpha + else + tmpVectorAlpha = EigA%alpha + end if + else + if(EigB%hasAlpha()) tmpVectorAlpha = EigB%alpha + end if + if(EigA%hasBeta()) then + if(EigB%hasBeta()) then + tmpVectorBeta = EigA%beta+EigB%beta + else + tmpVectorBeta = EigA%beta + end if + else + if(EigB%hasBeta()) tmpVectorBeta = EigB%beta + end if + call mqc_eigenvalues_allocate(EigOut,'','spin',tmpVectorAlpha,tmpVectorBeta) + case default + call mqc_error_A('Unknown integral type in mqc_eigenvalues_sum', 6, & + 'EigB%array_type', EigB%array_type ) + end select + case default + call mqc_error_A('Unknown integral type in mqc_eigenvalues_sum', 6, & + 'EigA%array_type', EigA%array_type ) + end select +! + end function mqc_eigenvalues_sum +! +! ! PROCEDURE MQC_Integral_Sum ! !> \brief MQC_Integral_Sum is used to sum two MQC integral type variables @@ -7595,7 +7737,7 @@ function mqc_integral_sum(integralA,integralB) result(integralOut) call mqc_error_A('Unknown integral type in mqc_integral_sum', 6, & 'integralA%array_type', integralA%array_type ) end select - +! end function mqc_integral_sum ! ! @@ -10225,6 +10367,174 @@ function mqc_scalar_integral_multiply(scalarIn,integral) result(integralOut) end function mqc_scalar_integral_multiply ! ! +! PROCEDURE MQC_Scalar_Eigenvalues_Multiply +! +!> \brief MQC_Scalar_Eigenvalues_Multiply is used to multiply an MQC integral +!> type variable with an MQC scalar and returns an MQC Eigenvalues +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_Scalar_Eigenvalues_Multiply is used to multiply an MQC integral type variable +!> with an MQC scalar and returns an MQC Eigenvalues. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] ScalarIn +!> \verbatim +!> ScalarIn is class(*) +!> The MQC scalar type variable to multiply. +!> \endverbatim +!> +!> \param[in] EigB +!> \verbatim +!> Eig is type(mqc_scf_Eigenvalues) +!> The MQC Eigenvalues variable to multiply. +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moras +!> \date 2026 +! + function mqc_scalar_eigenvalues_multiply(scalarIn,eigB) result(eigOut) +! + implicit none + type(mqc_scf_Eigenvalues),intent(in)::eigB + class(*),intent(in)::scalarIn +! Character(Len=*),optional,intent(in)::label + type(mqc_scf_Eigenvalues)::eigOut + type(mqc_vector)::tmpVectorAlpha,tmpVectorBeta + type(mqc_scalar)::scalar + Character(Len=64)::myLabel + integer(kind=int64)::nA1,nA2,nB1,nB2 +! +! if(present(label)) then +! call string_change_case(label,'l',myLabel) +! else + myLabel = '' +! endIf + + select type(scalarIn) + type is (integer) + scalar = scalarIn + type is (real) + scalar = scalarIn + type is (complex) + scalar = scalarIn + type is (mqc_scalar) + scalar = scalarIn + class default + call mqc_error_I('scalarIn type not defined in mqc_Eigenvalues_scalar_multiply',6) + end select + + select case (EigB%array_type) + case('space') + if(EigB%hasAlpha()) & + tmpVectorAlpha = scalar*EigB%alpha + call mqc_eigenvalues_allocate(eigOut,myLabel,'space',tmpVectorAlpha) + case('spin') + if(EigB%hasAlpha()) & + tmpVectorAlpha = scalar*EigB%alpha + if(EigB%hasBeta()) & + tmpVectorBeta = scalar*EigB%beta + call mqc_eigenvalues_allocate(eigOut,myLabel,'spin',tmpVectorAlpha,tmpVectorBeta) + case default + call mqc_error_A('Unknown integral type in mqc_Eigenvalues_scalar_multiply', 6, & + 'EigB%array_type', EigB%array_type ) + end select +! + end function mqc_scalar_eigenvalues_multiply +! +! +! PROCEDURE MQC_Eigenvalues_Scalar_Multiply +! +!> \brief MQC_Eigenvalues_Scalar_Multiply is used to multiply an MQC integral +!> type variable with an MQC scalar and returns an MQC Eigenvalues +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_Eigenvalues_Scalar_Multiply is used to multiply an MQC integral type variable +!> with an MQC scalar and returns an MQC Eigenvalues. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] Eig +!> \verbatim +!> Eig is type(mqc_scf_Eigenvalues) +!> The MQC Eigenvalues variable to multiply. +!> \endverbatim +!> +!> \param[in] ScalarIn +!> \verbatim +!> ScalarIn is class(*) +!> The MQC scalar type variable to multiply. +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moras +!> \date 2026 +! + function mqc_eigenvalues_scalar_multiply(eig,scalarIn) result(eigOut) +! + implicit none + type(mqc_scf_Eigenvalues),intent(in)::eig + class(*),intent(in)::scalarIn +! Character(Len=*),optional,intent(in)::label + type(mqc_scf_Eigenvalues)::eigOut + type(mqc_vector)::tmpVectorAlpha,tmpVectorBeta + type(mqc_scalar)::scalar + Character(Len=64)::myLabel + integer(kind=int64)::nA1,nA2,nB1,nB2 +! +! if(present(label)) then +! call string_change_case(label,'l',myLabel) +! else + myLabel = '' +! endIf + select type(scalarIn) + type is (integer) + scalar = scalarIn + type is (real) + scalar = scalarIn + type is (complex) + scalar = scalarIn + type is (mqc_scalar) + scalar = scalarIn + class default + call mqc_error_I('scalarIn type not defined in mqc_Eigenvalues_scalar_multiply',6) + end select + + select case (Eig%array_type) + case('space') + if(Eig%hasAlpha()) & + tmpVectorAlpha = scalar*Eig%alpha + call mqc_eigenvalues_allocate(eigOut,myLabel,'space',tmpVectorAlpha) + case('spin') + if(Eig%hasAlpha()) & + tmpVectorAlpha = scalar*Eig%alpha + if(Eig%hasBeta()) & + tmpVectorBeta = scalar*Eig%beta + call mqc_eigenvalues_allocate(eigOut,myLabel,'spin',tmpVectorAlpha,tmpVectorBeta) + case default + call mqc_error_A('Unknown integral type in mqc_Eigenvalues_scalar_multiply', 6, & + 'Eig%array_type', Eig%array_type ) + end select +! + end function mqc_eigenvalues_scalar_multiply +! +! +! ! PROCEDURE MQC_Integral_Scalar_Multiply ! !> \brief MQC_Integral_Scalar_Multiply is used to multiply an MQC integral @@ -14233,10 +14543,6 @@ function mqc_eri_eri_contraction(eris1,eris2,label) result(output) ! 6,'myLabel',myLabel) !end select - write(*,*) 'DEBUG: ERI_ERI Contraction' - write(*,*) 'ERIs 1',eris1%Type(),eris1%storType() - write(*,*) 'ERIs 2',eris2%Type(),eris2%storType() - if(myLabel.ne.'coulomb') temp = eris1%swap(2,4) output = 0.0 if(eris1%storType().eq.'empty'.or.eris2%storType().eq.'empty') return @@ -20262,7 +20568,7 @@ subroutine mqc_integral_put(integral,element,i,j,spinBlockIn) type is (mqc_scalar) myI = i class default - call mqc_error('index type not defined in MQC_twoERIs_put') + call mqc_error('index type not defined in MQC_integral_put') end select select type (j) type is (integer) @@ -20270,7 +20576,7 @@ subroutine mqc_integral_put(integral,element,i,j,spinBlockIn) type is (mqc_scalar) myJ = j class default - call mqc_error('index type not defined in MQC_twoERIs_put') + call mqc_error('index type not defined in MQC_integral_put') end select if(myI.gt.integral%blockSize('alpha',1)+integral%blockSize('beta',1)) & @@ -20435,7 +20741,7 @@ function mqc_integral_at(integral,i,j,spinBlockIn) result(element) character(len=*),optional,intent(in)::spinBlockIn character(len=64)::spinBlock real(kind=real64)::zero=0.0d0 - +! element = zero select type (i) type is (integer) @@ -20443,7 +20749,7 @@ function mqc_integral_at(integral,i,j,spinBlockIn) result(element) type is (mqc_scalar) myI = i class default - call mqc_error('index type not defined in MQC_twoERIs_at') + call mqc_error('index type not defined in MQC_integral_at') end select select type (j) type is (integer) @@ -20451,14 +20757,14 @@ function mqc_integral_at(integral,i,j,spinBlockIn) result(element) type is (mqc_scalar) myJ = j class default - call mqc_error('index type not defined in MQC_twoERIs_at') + call mqc_error('index type not defined in MQC_integral_at') end select - +! if(myI.gt.integral%blockSize('alpha',1)+integral%blockSize('beta',1)) & call mqc_error('Requested I dimension out of bounds in mqc_integral_at') if(myJ.gt.integral%blockSize('alpha',2)+integral%blockSize('beta',2)) & call mqc_error('Requested J dimension out of bounds in mqc_integral_at') - +! if(present(spinBlockIn)) then call string_change_case(spinBlockIn,'L',spinBlock) if(integral%array_type.eq.'space') then @@ -20525,7 +20831,7 @@ function mqc_integral_at(integral,i,j,spinBlockIn) result(element) call mqc_error_A('Array type not valid in MQC_Integral_At',6,'Array_Type',integral%array_type) endIf endIf - +! end function mqc_integral_at ! ! @@ -20708,14 +21014,14 @@ subroutine mqc_eigenvalues_put(eigenvalues,element,i,spinBlockIn) character(len=*),optional,intent(in)::spinBlockIn character(len=64)::spinBlock real(kind=real64)::zero=0.0d0 - +! select type (i) type is (integer) myI = i type is (mqc_scalar) myI = i class default - call mqc_error('index type not defined in MQC_twoERIs_put') + call mqc_error('index type not defined in MQC_eigenvalues_put') end select if(myI.gt.eigenvalues%blockSize('alpha')+eigenvalues%blockSize('beta')) & @@ -20728,7 +21034,7 @@ subroutine mqc_eigenvalues_put(eigenvalues,element,i,spinBlockIn) if(spinBlock.eq.'alpha'.or.spinBlock.eq.'beta') then if(eigenvalues%hasAlpha()) call eigenvalues%alpha%put(element,myI) else - call mqc_error_A('SpinBlock type not valid in MQC_Integral_Put',6,'SpinBlock',SpinBlock) + call mqc_error_A('SpinBlock type not valid in MQC_eigenvalues_Put',6,'SpinBlock',SpinBlock) endIf case ('spin','general') if(spinBlock.eq.'alpha') then @@ -20736,7 +21042,7 @@ subroutine mqc_eigenvalues_put(eigenvalues,element,i,spinBlockIn) elseif(spinblock.eq.'beta') then if(eigenvalues%hasBeta()) call eigenvalues%beta%put(element,myI) else - call mqc_error_A('SpinBlock type not valid in MQC_Integral_Put',6,'SpinBlock',SpinBlock) + call mqc_error_A('SpinBlock type not valid in MQC_eigenvalues_Put',6,'SpinBlock',SpinBlock) endIf case default call mqc_error_A('Array type not valid in MQC_Eigenvalues_Put',6,'Array_Type',eigenvalues%array_type) @@ -20761,12 +21067,12 @@ subroutine mqc_eigenvalues_put(eigenvalues,element,i,spinBlockIn) call mqc_error_A('Array type not valid in MQC_Eigenvalues_Put',6,'Array_Type',eigenvalues%array_type) end select endIf +! end subroutine mqc_eigenvalues_put - ! ! PROCEDURE MQC_Eigenvalues_Push ! -!> \brief MQC_Eigenvalues_Put is a function that adds a value to the end +!> \brief MQC_Eigenvalues_Push is a function that adds a value to the end !> of a MQC integral variable !> !> \par Purpose: From 8db763a584de3e1bd5697dc37f2f192e42874094 Mon Sep 17 00:00:00 2001 From: mm Date: Fri, 5 Jun 2026 12:12:18 -0400 Subject: [PATCH 31/37] Initial Natura Excitation Framework (NEF) implementation --- src/Makefile.am | 4 +- src/mqc_est.F03 | 20 +- src/mqc_nef.F03 | 6360 +++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 6372 insertions(+), 12 deletions(-) create mode 100644 src/mqc_nef.F03 diff --git a/src/Makefile.am b/src/Makefile.am index d3c1e678..908806ea 100644 --- a/src/Makefile.am +++ b/src/Makefile.am @@ -2,7 +2,7 @@ AM_FCFLAGS = $(MQC_SPECIFIC_FCFLAGS) AM_CPPFLAGS = $(MQC_CPPFLAGS) lib_LIBRARIES = libmqc.a libmqc_a_LIBADD = GauOpen/qcmatrix_4.o GauOpen/qcmatrix_8.o GauOpen/qcmatrixio_4.o GauOpen/qcmatrixio_8.o -libmqc_a_SOURCES = mqc_general.F03 mqc_binary.F03 mqc_datastructures.F03 mqc_files.F03 mqc_integrals.F03 mqc_algebra.F03 mqc_algebra2.F03 mqc_molecule.F03 mqc_est.F03 mqc_util.c mqc_matwrapper.F03 mqc_gaussian.F03 mqc_FullWavefunction.F03 mqc_interface.F03 -build: mqc_general.$(OBJEXT) mqc_binary.$(OBJEXT) mqc_datastructures.$(OBJEXT) mqc_files.$(OBJEXT) mqc_integrals.$(OBJEXT) mqc_algebra.$(OBJEXT) mqc_algebra2.$(OBJEXT) mqc_molecule.$(OBJEXT) mqc_est.$(OBJEXT) mqc_util.$(OBJEXT) mqc_matwrapper.$(OBJEXT) mqc_gaussian.$(OBJEXT) mqc_FullWavefunction.$(OBJEXT) mqc_interface.$(OBJEXT) +libmqc_a_SOURCES = mqc_general.F03 mqc_binary.F03 mqc_datastructures.F03 mqc_files.F03 mqc_integrals.F03 mqc_algebra.F03 mqc_algebra2.F03 mqc_molecule.F03 mqc_est.F03 mqc_nef.F03 mqc_util.c mqc_matwrapper.F03 mqc_gaussian.F03 mqc_FullWavefunction.F03 mqc_interface.F03 +build: mqc_general.$(OBJEXT) mqc_binary.$(OBJEXT) mqc_datastructures.$(OBJEXT) mqc_files.$(OBJEXT) mqc_integrals.$(OBJEXT) mqc_algebra.$(OBJEXT) mqc_algebra2.$(OBJEXT) mqc_molecule.$(OBJEXT) mqc_est.$(OBJEXT) mqc_nef.$(OBJEXT) mqc_util.$(OBJEXT) mqc_matwrapper.$(OBJEXT) mqc_gaussian.$(OBJEXT) mqc_FullWavefunction.$(OBJEXT) mqc_interface.$(OBJEXT) diff --git a/src/mqc_est.F03 b/src/mqc_est.F03 index cd52ef7f..76af7e9a 100644 --- a/src/mqc_est.F03 +++ b/src/mqc_est.F03 @@ -11194,10 +11194,10 @@ function mqc_twoERIs_scalar_multiply(eris,scalarIn) result(erisOut) aabb = scalar*eris%getBlock('aabb') if(eris%hasSpinBlock('abba')) & abba = scalar*eris%getBlock('abba') - call mqc_twoeris_allocate(erisOut,myLabel//'-'//myInt,'space',aaaa,alphaBeta=aabb,abba=abba) + call mqc_twoeris_allocate(erisOut,trim(myLabel)//'-'//trim(myInt),'space',aaaa,alphaBeta=aabb,abba=abba) elseif(eris%intType().eq.'coulomb'.or.eris%intType().eq.'exchange'.or.& eris%intType().eq.'inverted'.or.eris%intType().eq.'ms') then - call mqc_twoeris_allocate(erisOut,myLabel//'-'//myInt,'space',aaaa) + call mqc_twoeris_allocate(erisOut,trim(myLabel)//'-'//trim(myInt),'space',aaaa) else call mqc_error_A('Unknown twoERI storage type in mqc_scalar_twoeris_multiply',& 6,'ERIS%inttype()',ERIS%inttype()) @@ -11223,15 +11223,15 @@ function mqc_twoERIs_scalar_multiply(eris,scalarIn) result(erisOut) if(eris%intType().eq.'ms') then if(eris%hasSpinBlock('baba')) & baba = scalar*eris%getBlock('baba') - call mqc_twoeris_allocate(erisOut,myLabel//'-'//myInt,'spin',aaaa,bbbb,& + call mqc_twoeris_allocate(erisOut,trim(myLabel)//'-'//trim(myInt),'spin',aaaa,bbbb,& aabb,bbaa,abab,abba,baab,baba) else - call mqc_twoeris_allocate(erisOut,myLabel//'-'//myInt,'spin',aaaa,bbbb,& + call mqc_twoeris_allocate(erisOut,trim(myLabel)//'-'//trim(myInt),'spin',aaaa,bbbb,& aabb,bbaa,abba=abba,baab=baab) endIf elseif(eris%intType().eq.'coulomb'.or.eris%intType().eq.'exchange'.or.& eris%intType().eq.'inverted') then - call mqc_twoeris_allocate(erisOut,myLabel//'-'//myInt,'spin',aaaa,bbbb,& + call mqc_twoeris_allocate(erisOut,trim(myLabel)//'-'//trim(myInt),'spin',aaaa,bbbb,& aabb,bbaa) else call mqc_error_A('Unknown twoERI storage type in mqc_scalar_twoeris_multiply',& @@ -11239,14 +11239,14 @@ function mqc_twoERIs_scalar_multiply(eris,scalarIn) result(erisOut) endIf elseif(eris%storType().eq.'symm') then if(eris%intType().eq.'ms') then - call mqc_twoeris_allocate(erisOut,myLabel//'-'//myInt,'spin',aaaa,bbbb,& + call mqc_twoeris_allocate(erisOut,trim(myLabel)//'-'//trim(myInt),'spin',aaaa,bbbb,& aabb,abab=abab,abba=abba) elseif(eris%intType().eq.'doublebar') then - call mqc_twoeris_allocate(erisOut,myLabel//'-'//myInt,'spin',aaaa,bbbb,& + call mqc_twoeris_allocate(erisOut,trim(myLabel)//'-'//trim(myInt),'spin',aaaa,bbbb,& aabb,abba=abba) elseif(eris%intType().eq.'coulomb'.or.eris%intType().eq.'exchange'.or.& eris%intType().eq.'inverted') then - call mqc_twoeris_allocate(erisOut,myLabel//'-'//myInt,'spin',aaaa,bbbb,& + call mqc_twoeris_allocate(erisOut,trim(myLabel)//'-'//trim(myInt),'spin',aaaa,bbbb,& aabb) else call mqc_error_A('Unknown twoERI storage type in mqc_scalar_twoeris_multiply',& @@ -11290,10 +11290,10 @@ function mqc_twoERIs_scalar_multiply(eris,scalarIn) result(erisOut) bbab = scalar*eris%getBlock('bbab') if(eris%hasSpinBlock('babb')) & babb = scalar*eris%getBlock('babb') - call mqc_twoeris_allocate(erisOut,myLabel//'-'//myInt,'general',aaaa,bbbb,aabb,bbaa,& + call mqc_twoeris_allocate(erisOut,trim(myLabel)//'-'//trim(myInt),'general',aaaa,bbbb,aabb,bbaa,& abab,abba,baab,baba,aaab,aaba,abaa,baaa,bbba,bbab,babb,abbb) elseif(eris%storType().eq.'symm') then - call mqc_twoeris_allocate(erisOut,myLabel//'-'//myInt,'general',aaaa,bbbb,aabb,& + call mqc_twoeris_allocate(erisOut,trim(myLabel)//'-'//trim(myInt),'general',aaaa,bbbb,aabb,& abab=abab,abba=abba,aaab=aaab,abbb=abbb) else call mqc_error_A('Unknown storage type in mqc_twoeris_scalar_multiply', 6, & diff --git a/src/mqc_nef.F03 b/src/mqc_nef.F03 new file mode 100644 index 00000000..de0c456e --- /dev/null +++ b/src/mqc_nef.F03 @@ -0,0 +1,6360 @@ + Module MQC_NEF + + use omp_lib + use mqc_algebra + use mqc_est + Use iso_fortran_env, only: int32, int64, real64 + +! +!---------------------------------------------------------------- +! | +! TYPE AND CLASS DEFINITIONS | +! | +!---------------------------------------------------------------- +! +! +!> \brief + Type MQC_NEF_Vector + Type(MQC_SCF_Eigenvalues),Dimension(:),Allocatable,Private::Main_Vector + Type(MQC_SCF_Eigenvalues),Dimension(:),Allocatable,Private::Map_Matrix + Integer,Dimension(:),Allocatable,Private::Size_vector_alpha,Size_vector_beta + Integer,Private::NumSpace=0 + Contains + Procedure, Public::print => mqc_print_nef_vector + Procedure, Public::init => mqc_nef_vector_initialize + Procedure, public::getBlockVec => mqc_nef_vector_output_block_vector + Procedure, Public::impv => mqc_nef_vector_import_vector + Procedure, Public::expand => mqc_nef_vector_dimention_expand + End Type +! +!> \brief + Type MQC_NEF_Matrix + Type(MQC_SCF_Integral),Dimension(:),Allocatable,Private::Main_Matrix + Type(MQC_SCF_Eigenvalues),Dimension(:),Allocatable,Private::Map_Matrix_Col,Map_Matrix_Row + Integer,Dimension(:),Allocatable,Private::Size_vector_alpha_col,Size_vector_beta_col + Integer,Dimension(:),Allocatable,Private::Size_vector_alpha_row,Size_vector_beta_row + Integer,Private::NumSpace_col=0,NumSpace_row=0 + Contains + Procedure, Public::print => mqc_print_nef_matrix + Procedure, Public::init => mqc_nef_matrix_initialize + Procedure, public::collapseIndex => mqc_nef_matrix_collapse_index + Procedure, public::collapseMap => mqc_nef_matrix_collapse_map + Procedure, public::blockIndex => mqc_nef_matrix_index + Procedure, public::at => mqc_nef_matrix_at + Procedure, Public::imp => mqc_nef_matrix_import_integral + Procedure, Public::export => mqc_nef_matrix_export_integral + Procedure, Public::slice => mqc_nef_matrix_dimention_slice + Procedure, Public::collapse => mqc_nef_matrix_dimention_collapse +!> \brief Outer Product of two variables into a two NEF R4 + Procedure, Public::outer2R4 => mqc_NEFMatrix_NEFMatrix_outer_product +!> \brief Outer Product of two variables into a NEF R4 + Procedure, Public::crossouter2R4 => mqc_NEFMatrix_NEFMatrix_crossouter_product + Procedure, public::getBlockMat => mqc_nef_matrix_output_block_matrix + End Type +! +!> \brief + Type MQC_NEF_R4 + Type(MQC_TwoERIs),Dimension(:),Allocatable,Private::Main_R4 + Type(MQC_SCF_Eigenvalues),Dimension(:),Allocatable,Private::Map_Matrix_1,Map_Matrix_2,& + Map_Matrix_3,Map_Matrix_4 + Integer,Dimension(:),Allocatable,Private::Size_vector_alpha_1,Size_vector_beta_1 + Integer,Dimension(:),Allocatable,Private::Size_vector_alpha_2,Size_vector_beta_2 + Integer,Dimension(:),Allocatable,Private::Size_vector_alpha_3,Size_vector_beta_3 + Integer,Dimension(:),Allocatable,Private::Size_vector_alpha_4,Size_vector_beta_4 + Integer,Private::NumSpace_1=0,NumSpace_2=0,NumSpace_3=0,NumSpace_4=0 + Contains + Procedure, Public::print => mqc_print_nef_r4 + Procedure, public::at => mqc_nef_r4_at + Procedure, public::blockSize => mqc_nef_r4_dimension + Procedure, public::blockSizeVec => mqc_nef_r4_dimension_vector + Procedure, public::blockMap => mqc_nef_r4_map + Procedure, public::blockIndex => mqc_nef_r4_index + Procedure, Public::collapse => mqc_nef_r4_dimention_collapse + Procedure, Public::collapseIndex => mqc_nef_r4_collapse_index + Procedure, public::collapseMap => mqc_nef_r4_collapse_map + End Type +! +!---------------------------------------------------------------- +! | +! PROCEDURE INTERFACES | +! | +!---------------------------------------------------------------- +! +! +!> \brief Multiplies two objects + Interface MatMul + Module Procedure MQC_NEFMatrix_Integral_Multiply + Module Procedure MQC_Integral_NEFMatrix_Multiply + Module Procedure MQC_NEFMatrix_NEFMatrix_Multiply + End Interface +! +!> \brief Returns the Hermitian conjugate + Interface Dagger + Module Procedure MQC_NEFMatrix_Conjugate_Transpose + Module Procedure MQC_NEFR4_Conjugate_Transpose + End Interface +! +!> \brief Returns the conjugate + Interface Conjg + Module Procedure MQC_NEFMatrix_Conjugate + End Interface +! +!> \brief Returns the transpose + Interface Transpose + Module Procedure MQC_NEFMatrix_Transpose + End Interface +! +!> \brief Contracts two objects + Interface Contraction + Module Procedure mqc_NEFMatrix_NEFMatrix_contraction + Module Procedure mqc_NEF_R4_NEF_R4_contraction + Module Procedure MQC_NEF_R4_NEF_Matrix_Contraction + End Interface +! +!> \brief Contracts two objects + Interface PartialContraction + Module Procedure mqc_NEF_R4_NEF_R4_partial_contraction + End Interface +! +!> \brief Contracts two objects + Interface PartialContraction2R4 + Module Procedure mqc_NEF_R4_NEF_R4_partial_contraction_2NEF_R4 + Module Procedure mqc_NEF_R4_ERI_partial_contraction_2NEF_R4 + Module Procedure mqc_ERI_NEF_R4_partial_contraction_2NEF_R4 + End Interface +! +!> \brief Returns the block length along the specified dimension + Interface Size + Module Procedure mqc_nef_r4_dimension + End Interface +! + +! +! +!---------------------------------------------------------------- +! | +! OPERATOR INTERFACES | +! | +!---------------------------------------------------------------- +! +! +!> \brief Sums two variables + Interface Operator (+) + Module Procedure MQC_NEF_Vector_Sum + Module Procedure MQC_NEFMatrix_Sum + Module Procedure MQC_NEF_R4_Sum + End Interface +! +!> \brief Multiplies two variables + Interface Operator (*) + Module Procedure MQC_Scalar_NEF_Vector_Multiply + Module Procedure MQC_NEF_Vector_Scalar_Multiply + Module Procedure MQC_Scalar_NEFMatrix_Multiply + Module Procedure MQC_NEFMatrix_Scalar_Multiply + Module Procedure MQC_Scalar_NEFR4_Multiply + Module Procedure MQC_NEFR4_Scalar_Multiply + End Interface +! +! +! +!---------------------------------------------------------------- +! | +! SUBROUTINES AND FUNCTIONS | +! | +!---------------------------------------------------------------- +! +! + CONTAINS +! +! +! PROCEDURE MQC_Print_NEF_Vector +! +!> \brief MQC_Print_NEF_Vector is a subroutine used to print an MQC +!> NEF Vector object +!> +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_Print_NEF_Vector is a subroutine used to print an MQC NEF Vector object. +!> Blank_At_Top and Blank_At_Bottom are optional logical arguments to print blank +!> lines before or after output. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] NEFVec +!> \verbatim +!> Integral is Class(MQC_NEF_Vector) +!> The MQC NEF Vector variable to be printed. +!> \endverbatim +!> +!> \param[in] IOut +!> \verbatim +!> IOut is Integer(kind=int64) +!> The Fortran file number to print to. +!> \endverbatim +!> +!> \param[in] Header +!> \verbatim +!> Header is Character(Len=*) +!> The title to print along with Integral. +!> \endverbatim +!> +!> \param[in] Blank_At_Top +!> \verbatim +!> Blank_At_Top is Logical,Optional +!> = .True.: print blank line above output +!> = .False.: do not print blank line above output. +!> \endverbatim +!> +!> \param[in] Blank_At_Bottom +!> \verbatim +!> Blank_At_Bottom is Logical,Optional +!> = .True.: print blank line below output +!> = .False.: do not print blank line below output. +!> \endverbatim +!> +!> \param[in] FormatStr +!> \verbatim +!> FormatStr is Character(Len=*),Optional +!> Formatting statement for printing. +!> \endverbatim +! +! Authors: +! ======== +!> \author M.M.F. Moraes +!> \date 2026 +! + subroutine mqc_print_nef_vector(NEFVec,iOut,header, & + blank_at_top,blank_at_bottom,formatStr) +! + implicit none + class(mqc_nef_vector)::NEFVec + integer(kind=int64),intent(in)::iOut + character(len=*),intent(in)::header + character(len=64)::arrayType + logical,intent(In),optional::blank_at_top,blank_at_bottom + character(len=*),intent(in),optional::formatStr + integer::i +! + 1000 Format(1x,A) + 1020 Format( " " ) +! + if(present(blank_at_top)) then + if(blank_at_top) write(iout,1020) + endif + write(iout,1000) trim(header) + do i = 1, NEFVec%NumSpace + call mqc_print(NEFVec%Main_vector(i),iOut,'Sub-Space '//trim(num2char(i))) + end do + + end subroutine mqc_print_nef_vector +! +! +! + subroutine mqc_nef_vector_initialize(NEFVec,initial_map_matrix,scalar) +! + implicit none + class(mqc_nef_vector),intent(inOut)::NEFVec + type(mqc_scf_eigenvalues),dimension(:),allocatable,intent(in)::initial_map_matrix + Class(*),Optional::scalar + integer::i +! + if(allocated(NEFVec%Main_vector)) deallocate(NEFVec%Main_vector) + allocate(NEFVec%Main_vector(size(initial_map_matrix))) + if(allocated(NEFVec%Size_vector_alpha)) deallocate(NEFVec%Size_vector_alpha) + allocate(NEFVec%Size_vector_alpha(size(initial_map_matrix))) + if(allocated(NEFVec%Size_vector_beta)) deallocate(NEFVec%Size_vector_beta) + allocate(NEFVec%Size_vector_beta(size(initial_map_matrix))) + NEFVec%NumSpace = size(initial_map_matrix) + NEFVec%Map_Matrix = initial_map_matrix + do i = 1, NEFVec%NumSpace + select case(initial_map_matrix(i)%type()) + case ('space') + If(Present(Scalar)) then + call NEFVec%Main_vector(i)%init(& + Size(initial_map_matrix(i),'alpha'),& + scalar=scalar) + else + call NEFVec%Main_vector(i)%init(& + Size(initial_map_matrix(i),'alpha')) + end if + NEFVec%Size_vector_alpha(i) = Size(initial_map_matrix(i),'alpha') + NEFVec%Size_vector_beta(i) = Size(initial_map_matrix(i),'alpha') + case ('spin') + If(Present(Scalar)) then + call NEFVec%Main_vector(i)%init(& + Size(initial_map_matrix(i),'alpha'),& + scalar=scalar,& + lengthBeta=Size(initial_map_matrix(i),'beta')) + else + call NEFVec%Main_vector(i)%init(& + Size(initial_map_matrix(i),'alpha'),& + lengthBeta=Size(initial_map_matrix(i),'beta')) + end if + NEFVec%Size_vector_alpha(i) = Size(initial_map_matrix(i),'alpha') + NEFVec%Size_vector_beta(i) = Size(initial_map_matrix(i),'beta') + case default + call mqc_error_A('type not valid in mqc_nef_vector_initialize', 6, & + 'initial_map_matrix(i)%type()', initial_map_matrix(i)%type() ) + end select + end do +! + end subroutine mqc_nef_vector_initialize +! +! PROCEDURE MQC_Print_NEF_Matrix +! +!> \brief MQC_Print_NEF_Matrix is a subroutine used to print an MQC +!> NEF Matrix object +!> +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_Print_NEF_Matrix is a subroutine used to print an MQC NEF Matrix object. +!> Blank_At_Top and Blank_At_Bottom are optional logical arguments to print blank +!> lines before or after output. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] NEFMat +!> \verbatim +!> Integral is Class(MQC_NEF_Matrix) +!> The MQC NEF Matrix variable to be printed. +!> \endverbatim +!> +!> \param[in] IOut +!> \verbatim +!> IOut is Integer(kind=int64) +!> The Fortran file number to print to. +!> \endverbatim +!> +!> \param[in] Header +!> \verbatim +!> Header is Character(Len=*) +!> The title to print along with Integral. +!> \endverbatim +!> +!> \param[in] Blank_At_Top +!> \verbatim +!> Blank_At_Top is Logical,Optional +!> = .True.: print blank line above output +!> = .False.: do not print blank line above output. +!> \endverbatim +!> +!> \param[in] Blank_At_Bottom +!> \verbatim +!> Blank_At_Bottom is Logical,Optional +!> = .True.: print blank line below output +!> = .False.: do not print blank line below output. +!> \endverbatim +!> +!> \param[in] FormatStr +!> \verbatim +!> FormatStr is Character(Len=*),Optional +!> Formatting statement for printing. +!> \endverbatim +! +! Authors: +! ======== +!> \author M.M.F. Moraes +!> \date 2026 +! + subroutine mqc_print_nef_matrix(NEFMat,iOut,header, & + blank_at_top,blank_at_bottom,formatStr,blockPrint) +! + implicit none + class(mqc_nef_matrix)::NEFMat + integer(kind=int64),intent(in)::iOut + character(len=*),intent(in)::header + logical,optional::blockPrint + character(len=64)::arrayType + type(mqc_scf_integral)::tmp_int + logical,intent(In),optional::blank_at_top,blank_at_bottom + character(len=*),intent(in),optional::formatStr + integer::i,j,sub_i,sub_j,line_num,col_num + logical::my_block_print + Character(Len=256)::Line +! + if (present(blockPrint)) then + my_block_print = blockPrint + else + my_block_print = .true. + end if +! + 1000 Format(1x,A) + 1020 Format( " " ) +! + if(present(blank_at_top)) then + if(blank_at_top) write(iout,1020) + endif + write(iout,1000) trim(header) + line_num = 0 + if (my_block_print) then + write(6,*) 'Alpha-Alpha' + do j = 1, NEFMat%NumSpace_row + if (j.eq.1) then + Line = ' ' + do i = 1, NEFMat%NumSpace_col + do sub_i = 1, NEFMat%Size_vector_alpha_col(i) + Line = trim(Line)//' '//num2char(NEFMat%Map_Matrix_Col(i)%at(sub_i,'alpha')) + end do + end do + write(*,*) Line + end if + do sub_j = 1, NEFMat%Size_vector_alpha_row(j) + line_num = line_num + 1 + col_num = 1 + Line = num2char(NEFMat%Map_Matrix_Row(j)%at(sub_j,'alpha')) + do i = 1, NEFMat%NumSpace_col + tmp_int = NEFMat%Main_matrix(NEFMat%blockIndex([1,j],[2,i])) + do sub_i = 1, NEFMat%Size_vector_alpha_col(i) + if (tmp_int%at(sub_j,sub_i,'alpha').eq.0.0) then + Line = trim(Line)//' '//num2char(0.00000) + else if (tmp_int%at(sub_j,sub_i,'alpha').lt.0.0) then + Line = trim(Line)//' '//num2char(tmp_int%at(sub_j,sub_i,'alpha')) + else + Line = trim(Line)//' '//num2char(tmp_int%at(sub_j,sub_i,'alpha')) + end if + if (sub_i.ne.NEFMat%Size_vector_alpha_col(i)) Line = trim(Line)//' ' + end do + if(i.ne.NEFMat%NumSpace_col) Line = trim(Line)//'|' + end do + write(6,*) Line + end do + if(j.ne.NEFMat%NumSpace_row) & + write(6,*) '----------------------------------------------------------------------& + &----------------------------------------------------------------------' + end do + line_num = 0 + write(6,*) 'Beta-Beta' + do j = 1, NEFMat%NumSpace_row + do sub_j = 1, NEFMat%Size_vector_beta_row(j) + line_num = line_num + 1 + col_num = 1 + Line = num2char(NEFMat%Map_Matrix_Row(j)%at(sub_j,'beta')) + do i = 1, NEFMat%NumSpace_col + tmp_int = NEFMat%Main_matrix(NEFMat%blockIndex([1,j],[2,i])) + do sub_i = 1, NEFMat%Size_vector_beta_col(i) + if (tmp_int%at(sub_j,sub_i,'beta').eq.0.0) then + Line = trim(Line)//' '//num2char(0.00000) + else if (tmp_int%at(sub_j,sub_i,'beta').lt.0.0) then + Line = trim(Line)//' '//num2char(tmp_int%at(sub_j,sub_i,'beta')) + else + Line = trim(Line)//' '//num2char(tmp_int%at(sub_j,sub_i,'beta')) + end if + if (sub_i.ne.NEFMat%Size_vector_beta_col(i)) Line = trim(Line)//' ' + end do + if(i.ne.NEFMat%NumSpace_col) Line = trim(Line)//'|' + end do + write(6,*) trim(Line) + end do + if(j.ne.NEFMat%NumSpace_row) & + write(6,*) '----------------------------------------------------------------------& + &----------------------------------------------------------------------' + end do + line_num = 0 + write(6,*) 'Alpha-Beta' + do j = 1, NEFMat%NumSpace_row + do sub_j = 1, NEFMat%Size_vector_beta_row(j) + line_num = line_num + 1 + col_num = 1 + Line = num2char(NEFMat%Map_Matrix_Row(j)%at(sub_j,'alpha')) + do i = 1, NEFMat%NumSpace_col + tmp_int = NEFMat%Main_matrix(NEFMat%blockIndex([1,j],[2,i])) + do sub_i = 1, NEFMat%Size_vector_alpha_col(i) + if (tmp_int%at(sub_j,sub_i,'alphabeta').eq.0.0) then + Line = trim(Line)//' '//num2char(0.00000) + else if (tmp_int%at(sub_j,sub_i,'alphabeta').lt.0.0) then + Line = trim(Line)//' '//num2char(tmp_int%at(sub_j,sub_i,'alphabeta')) + else + Line = trim(Line)//' '//num2char(tmp_int%at(sub_j,sub_i,'alphabeta')) + end if + if (sub_i.ne.NEFMat%Size_vector_beta_col(i)) Line = trim(Line)//' ' + end do + if(i.ne.NEFMat%NumSpace_col) Line = trim(Line)//'|' + end do + write(6,*) trim(Line) + end do + if(j.ne.NEFMat%NumSpace_row) & + write(6,*) '----------------------------------------------------------------------& + &----------------------------------------------------------------------' + end do + line_num = 0 + write(6,*) 'Beta-Alpha' + do j = 1, NEFMat%NumSpace_row + do sub_j = 1, NEFMat%Size_vector_alpha_row(j) + line_num = line_num + 1 + col_num = 1 + Line = num2char(NEFMat%Map_Matrix_Row(j)%at(sub_j,'beta')) + do i = 1, NEFMat%NumSpace_col + tmp_int = NEFMat%Main_matrix(NEFMat%blockIndex([1,j],[2,i])) + do sub_i = 1, NEFMat%Size_vector_beta_col(i) + if (tmp_int%at(sub_j,sub_i,'betaalpha').eq.0.0) then + Line = trim(Line)//' '//num2char(0.00000) + else if (tmp_int%at(sub_j,sub_i,'betaalpha').lt.0.0) then + Line = trim(Line)//' '//num2char(tmp_int%at(sub_j,sub_i,'betaalpha')) + else + Line = trim(Line)//' '//num2char(tmp_int%at(sub_j,sub_i,'betaalpha')) + end if + if (sub_i.ne.NEFMat%Size_vector_alpha_col(i)) Line = trim(Line)//' ' + end do + if(i.ne.NEFMat%NumSpace_col) Line = trim(Line)//'|' + end do + write(6,*) trim(Line) + end do + if(j.ne.NEFMat%NumSpace_row) & + write(6,*) '----------------------------------------------------------------------& + &----------------------------------------------------------------------' + end do + write(6,*) ' ' + else + do i = 1, NEFMat%NumSpace_col + do j = 1, NEFMat%NumSpace_row + call mqc_print(NEFMat%Main_matrix(NEFMat%blockIndex([1,j],[2,i])),iOut,& + 'Sub-Space '//trim(num2char(j))//','//trim(num2char(i))) + end do + end do + end if +! + end subroutine mqc_print_nef_matrix +! +! +! PROCEDURE MQC_NEF_Matrix_Initialize +! +!> \brief MQC_NEF_Matrix_Initialize is a subroutine that initializes a +!> NEF Matrix object +!> +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEF_Matrix_Initialize is a subroutine that initializes a MQC_NEF_Matrix. Default +!> element values are 0.0, or otherwise vector can be initialized with optional +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] NEFMat +!> \verbatim +!> Integral is Class(MQC_NEF_Matrix) +!> The MQC NEF Matrix to initialize. +!> \endverbatim +!> +!> \param[in] initial_map_matrix_row +!> \verbatim +!> initial_map_matrix_row is a type(mqc_scf_eigenvalues),dimension(:),allocatable +!> Maps each element from an original mqc_scf_integral basis into the nef basis. +!> \endverbatim +!> +!> \param[in] scalar +!> \verbatim +!> Scalar is Class(*),Optional +!> Value to set each element of Vector. If not present, +!> the value is set to 0.0. Can be of type integer, real, +!> complex or MQC_Scalar. +!> \endverbatim +!> +!> \param[in] initial_map_matrix_col +!> \verbatim +!> initial_map_matrix_row is a type(mqc_scf_eigenvalues),dimension(:),allocatable,optional +!> Maps each element from an original mqc_scf_integral basis into the nef basis on the +!> second axis (columns). If not present, the mapping is the same in both axes. +!> \endverbatim +! +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + subroutine mqc_nef_matrix_initialize(NEFMat,initial_map_matrix_row,scalar,initial_map_matrix_col) +! + implicit none + class(mqc_nef_matrix),intent(inOut)::NEFMat + type(mqc_scf_eigenvalues),dimension(:),allocatable,intent(in)::initial_map_matrix_row + type(mqc_scf_eigenvalues),dimension(:),allocatable,intent(in),optional::initial_map_matrix_col + type(mqc_scf_eigenvalues),dimension(:),allocatable::active_map_matrix_col + Class(*),Optional::scalar + logical::same_vec + integer::i,j + + NEFMat%NumSpace_row = size(initial_map_matrix_row) + NEFMat%Map_Matrix_row = initial_map_matrix_row + if(present(initial_map_matrix_col)) then + NEFMat%NumSpace_col = size(initial_map_matrix_col) + active_map_matrix_col = initial_map_matrix_col + NEFMat%Map_Matrix_col = initial_map_matrix_col + same_vec = .false. + else + NEFMat%NumSpace_col = NEFMat%NumSpace_row + active_map_matrix_col = initial_map_matrix_row + NEFMat%Map_Matrix_col = initial_map_matrix_row + same_vec = .true. + end if + if(allocated(NEFMat%Size_vector_alpha_row)) deallocate(NEFMat%Size_vector_alpha_row) + if(allocated(NEFMat%Size_vector_alpha_col)) deallocate(NEFMat%Size_vector_alpha_col) + if(allocated(NEFMat%Size_vector_beta_row)) deallocate(NEFMat%Size_vector_beta_row) + if(allocated(NEFMat%Size_vector_beta_col)) deallocate(NEFMat%Size_vector_beta_col) + if(allocated(NEFMat%Main_matrix)) deallocate(NEFMat%Main_matrix) + allocate(NEFMat%Size_vector_alpha_row(NEFMat%NumSpace_row)) + allocate(NEFMat%Size_vector_beta_row(NEFMat%NumSpace_row)) + allocate(NEFMat%Size_vector_alpha_col(NEFMat%NumSpace_col)) + allocate(NEFMat%Size_vector_beta_col(NEFMat%NumSpace_col)) + + allocate(NEFMat%Main_matrix(NEFMat%NumSpace_row*NEFMat%NumSpace_col)) + do i = 1, NEFMat%NumSpace_row + NEFMat%Size_vector_alpha_row(i) = Size(initial_map_matrix_row(i),'alpha') + NEFMat%Size_vector_beta_row(i) = Size(initial_map_matrix_row(i),'beta') + do j = 1, NEFMat%NumSpace_col + if(i.eq.1) then + NEFMat%Size_vector_alpha_col(j) = Size(active_map_matrix_col(j),'alpha') + NEFMat%Size_vector_beta_col(j) = Size(active_map_matrix_col(j),'beta') + end if + if (same_vec.and.i.eq.j) then + If(Present(Scalar)) then + call NEFMat%Main_matrix(NEFMat%blockIndex([1,i],[2,i]))%init(& + Size(initial_map_matrix_row(i),'alpha'),& + Size(initial_map_matrix_row(i),'beta'),& + scalar=scalar) + else + call NEFMat%Main_matrix(NEFMat%blockIndex([1,i],[2,i]))%init(& + Size(initial_map_matrix_row(i),'alpha'),& + Size(initial_map_matrix_row(i),'beta')) + end if + else + If(Present(Scalar)) then + call NEFMat%Main_matrix(NEFMat%blockIndex([1,i],[2,j]))%init(& + Size(initial_map_matrix_row(i),'alpha'),& + Size(initial_map_matrix_row(i),'beta'),& + scalar=scalar,& + nAlpha2=Size(active_map_matrix_col(j),'alpha'),& + nBeta2=Size(active_map_matrix_col(j),'beta')) + else + call NEFMat%Main_matrix(NEFMat%blockIndex([1,i],[2,j]))%init(& + Size(initial_map_matrix_row(i),'alpha'),& + Size(initial_map_matrix_row(i),'beta'),& + nAlpha2=Size(active_map_matrix_col(j),'alpha'),& + nBeta2=Size(active_map_matrix_col(j),'beta')) + end if + end if + end do + end do + end subroutine mqc_nef_matrix_initialize +! +! +! PROCEDURE MQC_NEF_Matrix_Import_Integral +! +!> \brief MQC_NEF_Matrix_Import_Integral is a subroutine that import the values +!> from a MQC SCF Integral object to an initiallized NEF Matrix object +!> +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEF_Matrix_Import_Integral is a subroutine that import the values +!> from a MQC SCF Integral object to an initiallized NEF Matrix object +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] NEFMat +!> \verbatim +!> NEFMat is Class(MQC_NEF_Matrix) +!> The MQC NEF Matrix to initialize. +!> \endverbatim +!> +!> \param[in] integral +!> \verbatim +!> integral is a type(mqc_scf_integral) +!> A MQC SCF Integral object containing the NEF Matrix elements in the +!> original order (in general AO or MO) +!> \endverbatim +!> +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + subroutine mqc_nef_matrix_import_integral(NEFMat,integral) +! + implicit none + class(mqc_nef_matrix),intent(inOut)::NEFMat + type(mqc_scf_integral)::integral + type(mqc_scf_integral)::tmp_integral + type(mqc_vector)::tmp_alpha,tmp_beta + integer::i,j,row,col +! + do row = 1, NEFMat%NumSpace_row + tmp_alpha = NEFMat%Map_Matrix_Row(row)%getBlock('alpha') + tmp_beta = NEFMat%Map_Matrix_Row(row)%getBlock('beta') + tmp_integral = & + integral%orbitals('useStrings',& + alphaOrbsIn = tmp_alpha%getArrayI(),& + BetaOrbsIn = tmp_beta%getArrayI(),axis=1) + do col = 1, NEFMat%NumSpace_col + tmp_alpha = NEFMat%Map_Matrix_Col(col)%getBlock('alpha') + tmp_beta = NEFMat%Map_Matrix_Col(col)%getBlock('beta') + NEFMat%Main_matrix(NEFMat%blockIndex([1,row],[2,col]))=& + tmp_integral%orbitals('useStrings',& + alphaOrbsIn = tmp_alpha%getArrayI(),& + BetaOrbsIn = tmp_beta%getArrayI(),axis=2) + end do + end do +! + end subroutine mqc_nef_matrix_import_integral +! +! +! +! PROCEDURE MQC_NEF_Matrix_Export_Integral +! +!> \brief MQC_NEF_Matrix_Export_Integral is a subroutine that export the values +!> to a MQC SCF Integral object from a NEF Matrix object +!> +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEF_Matrix_Export_Integral is a subroutine that export the values +!> to a MQC SCF Integral object from a NEF Matrix object +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] NEFMat +!> \verbatim +!> NEFMat is Class(MQC_NEF_Matrix) +!> The MQC NEF Matrix. +!> \endverbatim +!> +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_nef_matrix_export_integral(NEFMat) result(integral) +! + implicit none + class(mqc_nef_matrix),intent(inOut)::NEFMat + type(mqc_scf_integral)::integral + type(mqc_scf_integral)::tmp_integral + type(mqc_vector)::tmp_alpha,tmp_beta + integer::id,ia,ja,ib,jb,row,col,maxColAlpha,maxColBeta,maxRowAlpha,maxRowBeta +! + maxColAlpha = 0 + maxColBeta = 0 + maxRowAlpha = 0 + maxRowBeta = 0 + do row = 1, NEFMat%NumSpace_row + maxRowAlpha = maxRowAlpha + NEFMat%Size_vector_alpha_row(row) + maxRowBeta = maxRowBeta + NEFMat%Size_vector_beta_row(row) + end do + do col = 1, NEFMat%NumSpace_col + maxColAlpha = maxColAlpha + NEFMat%Size_vector_alpha_col(col) + maxColBeta = maxColBeta + NEFMat%Size_vector_beta_col(col) + end do +! + call integral%init(maxRowAlpha,maxRowBeta,nAlpha2=maxColAlpha,nBeta2=maxColBeta) + do row = 1, NEFMat%NumSpace_row + do col = 1, NEFMat%NumSpace_col + id = NEFMat%blockIndex([1,row],[2,col]) + do ia = 1, NEFMat%Size_vector_alpha_row(row) + do ja = 1, NEFMat%Size_vector_alpha_col(col) + call integral%put(NEFMat%Main_matrix(id)%at(ia,ja,'alpha'),& + NEFMat%Map_Matrix_Row(row)%at(ia,'alpha'),& + NEFMat%Map_Matrix_Col(col)%at(ja,'alpha'),'alpha') + end do + do ja = 1, NEFMat%Size_vector_beta_col(col) + call integral%put(NEFMat%Main_matrix(id)%at(ia,ja,'alphabeta'),& + NEFMat%Map_Matrix_Row(row)%at(ia,'alpha'),& + NEFMat%Map_Matrix_Col(col)%at(ja,'beta'),'alphabeta') + end do + end do + do ia = 1, NEFMat%Size_vector_beta_row(row) + do ja = 1, NEFMat%Size_vector_alpha_col(col) + call integral%put(NEFMat%Main_matrix(id)%at(ia,ja,'betaalpha'),& + NEFMat%Map_Matrix_Row(row)%at(ia,'beta'),& + NEFMat%Map_Matrix_Col(col)%at(ja,'alpha'),'betaalpha') + end do + do ja = 1, NEFMat%Size_vector_beta_col(col) + call integral%put(NEFMat%Main_matrix(id)%at(ia,ja,'beta'),& + NEFMat%Map_Matrix_Row(row)%at(ia,'beta'),& + NEFMat%Map_Matrix_Col(col)%at(ja,'beta'),'beta') + end do + end do + end do + end do +! + end function mqc_nef_matrix_export_integral +! +! +! PROCEDURE MQC_NEF_Vector_Import_Vector +! +!> \brief MQC_NEF_Vector_Import_Vector is a subroutine that import the values +!> from a MQC Vector object to an initiallized NEF Vector object +!> +!> \par Purpose: +! ============= +!> +!> MQC_NEF_Vector_Import_Vector is a subroutine that import the values +!> from a MQC Vector object to an initiallized NEF Vector object +!> \verbatim +!> +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] NEFVec +!> \verbatim +!> NEFVec is Class(MQC_NEF_Vector) +!> The MQC NEF Vector to initialize. +!> \endverbatim +!> +!> \param[in] vector +!> \verbatim +!> vector is a type(mqc_vector) +!> A MQC Vector object containing the NEF Vector elements in the +!> original order (in general AO or MO) +!> \endverbatim +!> +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + subroutine mqc_nef_vector_import_vector(NEFVec,vector) +! + implicit none + class(mqc_nef_vector),intent(inOut)::NEFVec + type(mqc_vector)::vector + type(mqc_vector)::tmp_alpha,tmp_beta + integer::row,el + type(mqc_scalar)::zero +! + zero = 0.0 + do row = 1, NEFVec%NumSpace + tmp_alpha = NEFVec%Map_Matrix(row)%getBlock('alpha') + tmp_beta = NEFVec%Map_Matrix(row)%getBlock('beta') + call NEFVec%Main_Vector(row)%init(size(tmp_alpha),zero,size(tmp_beta)) + do el = 1, size(tmp_alpha) + call NEFVec%Main_Vector(row)%put(vector%at(tmp_alpha%at(el)),el,'alpha') + end do + do el = 1, size(tmp_beta) + call NEFVec%Main_Vector(row)%put(vector%at(tmp_beta%at(el)),el,'beta') + end do + end do +! + end subroutine mqc_nef_vector_import_vector +! PROCEDURE MQC_NEFMatrix_NEFMatrix_Multiply +! +!> \brief MQC_NEFMatrix_NEFMatrix_Multiply is used to multiply two MQC NEF Matrix +!> type variables and returns an MQC NEF Matrix +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEFMatrix_NEFMatrix_Multiply is used to multiply two MQC NEF Matrix type +!> variables and returns an MQC NEF Matrix +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] NEFMatA +!> \verbatim +!> NEFMAtA is type(mqc_nef_matrix) +!> The first MQC NEF Matrix type variable to multiply. +!> \endverbatim +!> +!> \param[in] NEFMatB +!> \verbatim +!> NEFMatB is type(mqc_nef_matrix) +!> The second MQC NEF Matrix variable to multiply. +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_nefmatrix_nefmatrix_multiply(NEFMatrixA,NEFMatrixB) result(NEFMatrixOut) +! + implicit none + type(mqc_nef_matrix),intent(in)::NEFMatrixA,NEFMatrixB + type(mqc_nef_matrix)::NEFMatrixOut + integer(kind=int64)::rowA,colB,colA,final_index +! + if(NEFMatrixA%NumSpace_col.ne.NEFMatrixB%NumSpace_row) & + call mqc_error_i('NEF number of subspaces are & + ¬ conformable in mqc_nefmatrix_nefmatrix_multiply',6,& + 'NEFMatA%NumSpace_col',NEFMatrixA%NumSpace_col,& + 'NEFMatB%NumSpace_row',NEFMatrixB%NumSpace_row) + + do colA = 1, NEFMatrixA%NumSpace_col + if(NEFMatrixA%Size_vector_alpha_col(colA)& + .ne.NEFMatrixB%Size_vector_alpha_row(colA).or. & + NEFMatrixA%Size_vector_beta_col(colA)& + .ne.NEFMatrixB%Size_vector_beta_row(colA)) & + call mqc_error_i('NEF subspace dimensions are & + ¬ conformable in mqc_nefmatrix_nefmatrix_multiply',6,& + 'Sub-space index (colA)', colA,& + 'NEFMatA%Size_vector_alpha_col(colA)',NEFMatrixA%Size_vector_alpha_col(colA),& + 'NEFMatB%Size_vector_alpha_row(colA)',NEFMatrixB%Size_vector_alpha_row(colA),& + 'NEFMatA%Size_vector_beta_col(colA)',NEFMatrixA%Size_vector_beta_col(colA),& + 'NEFMatB%Size_vector_beta_row(colA)',NEFMatrixB%Size_vector_beta_row(colA)) + end do + + call NEFMatrixOut%init(NEFMatrixA%Map_Matrix_Row,& + initial_map_matrix_col=NEFMatrixB%Map_Matrix_Col) + do rowA = 1, NEFMatrixA%NumSpace_row + do colB = 1, NEFMatrixB%NumSpace_col + final_index = NEFMatrixOut%blockIndex([1,rowA],[2,colB]) + do colA = 1, NEFMatrixA%NumSpace_col + if (colA.ne.1) then + NEFMatrixOut%Main_Matrix(final_index) = NEFMatrixOut%Main_Matrix(final_index) + & + matmul(NEFMatrixA%Main_Matrix(NEFMatrixA%blockIndex([1,rowA],[2,colA])),& + NEFMatrixB%Main_Matrix(NEFMatrixB%blockIndex([1,colA],[2,colB]))) + else + NEFMatrixOut%Main_Matrix(final_index) = & + matmul(NEFMatrixA%Main_Matrix(NEFMatrixA%blockIndex([1,rowA],[2,colA])),& + NEFMatrixB%Main_Matrix(NEFMatrixB%blockIndex([1,colA],[2,colB]))) + end if + end do + end do + end do +! + end function mqc_nefmatrix_nefmatrix_multiply +! +! PROCEDURE MQC_NEFMatrix_Integral_Multiply +! +!> \brief MQC_NEFMatrix_Integral_Multiply is used to multiply a MQC NEF Matrix +!> and MQC SCF Integral type variables and returns an MQC NEF Matrix +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEFMatrix_Integral_Multiply is used to multiply a MQC NEF Matrix +!> and MQC SCF Integral type variables and returns an MQC NEF Matrix +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] NEFMatA +!> \verbatim +!> NEFMAt is type(mqc_nef_matrix) +!> The first MQC NEF Matrix type variable to multiply. +!> \endverbatim +!> +!> \param[in] IntegralB +!> \verbatim +!> Integral is type(mqc_scf_integral) +!> The second MQC SCF Integral variable to multiply. +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_nefmatrix_integral_multiply(NEFMatA,IntegralB) result(NEFMatOut) +! + implicit none + type(mqc_nef_matrix),intent(in)::NEFMatA + type(mqc_scf_integral),intent(in)::IntegralB + type(mqc_nef_matrix)::NEFMatOut + integer(kind=int64)::row +! + if(NEFMatA%NumSpace_col.ne.1) & + call mqc_error_i('NEF number of subspaces are & + ¬ conformable in mqc_nefmatrix_integral_multiply',6,& + 'NEFMatA%NumSpace_col',NEFMatA%NumSpace_col) + + if(NEFMatA%Size_vector_alpha_col(1)& + .ne.size(IntegralB,'alpha',1).or. & + NEFMatA%Size_vector_beta_col(1)& + .ne.size(IntegralB,'beta',1)) & + call mqc_error_i('NEF subspace dimensions are & + ¬ conformable in mqc_nefmatrix_integral_multiply',6,& + 'NEFMatA%Size_vector_alpha_col',NEFMatA%Size_vector_alpha_col(1),& + 'size(IntegralB,alpha,1)',size(IntegralB,'alpha',1),& + 'NEFMatA%Size_vector_beta_col',NEFMatA%Size_vector_beta_col(1),& + 'size(IntegralB,beta,1)',size(IntegralB,'beta',1)) + + call NEFMatOut%init(NEFMatA%Map_Matrix_Row,& + initial_map_matrix_col=NEFMatA%Map_Matrix_Col) + do row = 1, NEFMatA%NumSpace_row + NEFMatOut%Main_Matrix(row) = matmul(NEFMatA%Main_Matrix(row),IntegralB) + end do +! + end function mqc_nefmatrix_integral_multiply +! +! PROCEDURE MQC_Integral_NEFMatrix_Multiply +! +!> \brief MQC_Integral_NEFMatrix_Multiply is used to multiply a MQC NEF Matrix +!> and MQC SCF Integral type variables and returns an MQC NEF Matrix +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_Integral_NEFMatrix_Multiply is used to multiply a MQC NEF Matrix +!> and MQC SCF Integral type variables and returns an MQC NEF Matrix +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] IntegralA +!> \verbatim +!> Integral is type(mqc_scf_integral) +!> The second MQC SCF Integral variable to multiply. +!> \endverbatim +!> +!> \param[in] NEFMatB +!> \verbatim +!> NEFMAt is type(mqc_nef_matrix) +!> The first MQC NEF Matrix type variable to multiply. +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_integral_nefmatrix_multiply(IntegralA,NEFMatB) result(NEFMatOut) +! + implicit none + type(mqc_scf_integral),intent(in)::IntegralA + type(mqc_nef_matrix),intent(in)::NEFMatB + type(mqc_nef_matrix)::NEFMatOut + integer(kind=int64)::col +! + if(NEFMatB%NumSpace_row.ne.1) & + call mqc_error_i('NEF number of subspaces are & + ¬ conformable in mqc_integral_nefmatrix_multiply',6,& + 'NEFMatA%NumSpace_row',NEFMatB%NumSpace_row) + + if(NEFMatB%Size_vector_alpha_row(1)& + .ne.size(IntegralA,'alpha',2).or. & + NEFMatB%Size_vector_beta_row(1)& + .ne.size(IntegralA,'beta',2)) & + call mqc_error_i('NEF subspace dimensions are & + ¬ conformable in mqc_integral_nefmatrix_multiply',6,& + 'NEFMatB%Size_vector_alpha_row',NEFMatB%Size_vector_alpha_row(1),& + 'size(IntegralA,alpha,2)',size(IntegralA,'alpha',1),& + 'NEFMatB%Size_vector_beta_row',NEFMatB%Size_vector_beta_row(1),& + 'size(IntegralA,beta,2)',size(IntegralA,'beta',1)) + + call NEFMatOut%init(NEFMatB%Map_Matrix_Row,& + initial_map_matrix_col=NEFMatB%Map_Matrix_Col) + do col = 1, NEFMatB%NumSpace_col + NEFMatOut%Main_Matrix(col) = matmul(IntegralA,NEFMatB%Main_Matrix(col)) + end do +! + end function mqc_integral_nefmatrix_multiply +! +! +! PROCEDURE MQC_NEF_Vector_Sum +! +!> \brief MQC_NEF_Vector_Sum is used to sum two MQC NEF Vector type variables +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEF_Vector_Sum is used to sum two MQC NEF vector type variables +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] NEFVecA +!> \verbatim +!> NEFVecA is type(mqc_nef_vector) +!> The first MQC NEF Vector variable to sum. +!> \endverbatim +!> +!> \param[in] NEFVecB +!> \verbatim +!> NEFVecB is type(mqc_nef_vector) +!> The first MQC NEF Vector variable to sum. +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_nef_vector_sum(NEFVecA,NEFVecB) result(NEFVecOut) +! + implicit none + type(mqc_nef_vector),intent(in)::NEFVecA,NEFVecB + type(mqc_nef_vector)::NEFVecOut + integer::col +! + if(NEFVecA%NumSpace.ne.NEFVecB%NumSpace) & + call mqc_error_i('NEF number of subspaces are & + ¬ conformable in mqc_nef_vector_sum',6,& + 'NEFVecA%NumSpace',NEFVecA%NumSpace,& + 'NEFVecB%NumSpace',NEFVecB%NumSpace) +! + do col = 1, NEFVecA%NumSpace + if (NEFVecA%Size_vector_alpha(col).ne.& + NEFVecB%Size_vector_alpha(col)) & + call mqc_error_i('NEF subspace dimensions are & + ¬ conformable in mqc_nef_vector_sum',6,& + 'Sub-space index (col)', col,& + 'NEFVecA%Size_vector_alpha(col)',NEFVecA%Size_vector_alpha(col),& + 'NEFVecB%Size_vector_alpha(col)',NEFVecB%Size_vector_alpha(col),& + 'NEFVecA%Size_vector_beta(col)',NEFVecA%Size_vector_beta(col),& + 'NEFVecB%Size_vector_beta(col)',NEFVecB%Size_vector_beta(col)) + end do +! + call NEFVecOut%init(NEFVecA%Map_Matrix) + do col = 1, NEFVecB%NumSpace + NEFVecOut%Main_Vector(col) = NEFVecA%Main_Vector(col) + NEFVecB%Main_Vector(col) + end do +! + end function mqc_nef_vector_sum +! +! +! PROCEDURE MQC_NEFMatrix_Sum +! +!> \brief MQC_NEFMatrix_Sum is used to sum two MQC NEF matrix type variables +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEFMatrix_Sum is used to sum two MQC NEF matrix type variables +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] NEFMatA +!> \verbatim +!> NEFMatA is type(mqc_nef_matrix) +!> The first MQC NEF Matrix variable to sum. +!> \endverbatim +!> +!> \param[in] NEFMatB +!> \verbatim +!> NEFMatB is type(mqc_nef_matrix) +!> The second MQC NEF Matrix variable to sum. +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_nefmatrix_sum(NEFMatA,NEFMatB) result(NEFMatOut) +! + implicit none + type(mqc_nef_matrix),intent(in)::NEFMatA,NEFMatB + type(mqc_nef_matrix)::NEFMatOut + integer::col,row,id +! + if(NEFMatA%NumSpace_col.ne.NEFMatB%NumSpace_col.or.& + NEFMatA%NumSpace_row.ne.NEFMatB%NumSpace_row) & + call mqc_error_i('NEF number of subspaces are & + ¬ conformable in mqc_nefmatrix_sum',6,& + 'NEFMatA%NumSpace_col',NEFMatA%NumSpace_col,& + 'NEFMatB%NumSpace_col',NEFMatB%NumSpace_col,& + 'NEFMatA%NumSpace_row',NEFMatA%NumSpace_row,& + 'NEFMatB%NumSpace_row',NEFMatB%NumSpace_row) + + do col = 1, NEFMatA%NumSpace_col + if(NEFMatA%Size_vector_alpha_col(col)& + .ne.NEFMatB%Size_vector_alpha_col(col).or. & + NEFMatA%Size_vector_beta_col(col) & + .ne.NEFMatB%Size_vector_beta_col(col)) & + call mqc_error_i('NEF subspace dimensions are & + ¬ conformable in mqc_nefmatrix_sum',6,& + 'Sub-space index (col)', col,& + 'NEFMatA%Size_vector_alpha_col(col)',NEFMatA%Size_vector_alpha_col(col),& + 'NEFMatB%Size_vector_alpha_col(col)',NEFMatB%Size_vector_alpha_col(col),& + 'NEFMatA%Size_vector_beta_col(col)',NEFMatA%Size_vector_beta_col(col),& + 'NEFMatB%Size_vector_beta_col(col)',NEFMatB%Size_vector_beta_col(col)) + end do + do row = 1, NEFMatA%NumSpace_row + if(NEFMatA%Size_vector_alpha_row(row)& + .ne.NEFMatB%Size_vector_alpha_row(row).or. & + NEFMatA%Size_vector_beta_row(row) & + .ne.NEFMatB%Size_vector_beta_row(row)) & + call mqc_error_i('NEF subspace dimensions are & + ¬ conformable in mqc_nefmatrix_sum',6,& + 'Sub-space index (row)', row,& + 'NEFMatA%Size_vector_alpha_row(row)',NEFMatA%Size_vector_alpha_row(row),& + 'NEFMatB%Size_vector_alpha_row(row)',NEFMatB%Size_vector_alpha_row(row),& + 'NEFMatA%Size_vector_beta_row(row)',NEFMatA%Size_vector_beta_row(row),& + 'NEFMatB%Size_vector_beta_row(row)',NEFMatB%Size_vector_beta_row(row)) + end do + + call NEFMatOut%init(NEFMatA%Map_Matrix_Row,& + initial_map_matrix_col=NEFMatB%Map_Matrix_Col) + do row = 1, NEFMatA%NumSpace_row + do col = 1, NEFMatB%NumSpace_col + id = NEFMatOut%blockIndex([1,row],[2,col]) + NEFMatOut%Main_Matrix(id) = NEFMatA%Main_Matrix(id)+NEFMatB%Main_Matrix(id) + end do + end do +! + end function mqc_nefmatrix_sum +! +! +! PROCEDURE MQC_NEF_R4_Sum +! +!> \brief MQC_NEF_R4_Sum is used to sum two MQC NEF R4 type variables +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEF_R4_Sum is used to sum two MQC NEF R4 type variables +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] NEFR4A +!> \verbatim +!> NEFR4A is type(mqc_nef_r4) +!> The first MQC NEF R4 variable to sum. +!> \endverbatim +!> +!> \param[in] NEFR4B +!> \verbatim +!> NEFR4B is type(mqc_nef_r4) +!> The second MQC NEF R4 variable to sum. +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_nef_r4_sum(NEFR4A,NEFR4B) result(NEFR4Out) +! + implicit none + type(mqc_nef_r4),intent(in)::NEFR4A,NEFR4B + type(mqc_nef_r4)::NEFR4Out + integer::id1,id2,id3,id4,id +! + if(NEFR4A%NumSpace_1.ne.NEFR4B%NumSpace_1)& + call mqc_error_i('NEF number of subspaces are & + ¬ conformable in mqc_nef_r4_sum',6,& + 'NEFR4A%NumSpace_1',NEFR4A%NumSpace_1,& + 'NEFR4B%NumSpace_1',NEFR4B%NumSpace_1) + if(NEFR4A%NumSpace_2.ne.NEFR4B%NumSpace_2)& + call mqc_error_i('NEF number of subspaces are & + ¬ conformable in mqc_nef_r4_sum',6,& + 'NEFR4A%NumSpace_2',NEFR4A%NumSpace_2,& + 'NEFR4B%NumSpace_2',NEFR4B%NumSpace_2) + if(NEFR4A%NumSpace_3.ne.NEFR4B%NumSpace_3)& + call mqc_error_i('NEF number of subspaces are & + ¬ conformable in mqc_nef_r4_sum',6,& + 'NEFR4A%NumSpace_3',NEFR4A%NumSpace_3,& + 'NEFR4B%NumSpace_3',NEFR4B%NumSpace_3) + if(NEFR4A%NumSpace_4.ne.NEFR4B%NumSpace_4)& + call mqc_error_i('NEF number of subspaces are & + ¬ conformable in mqc_nef_r4_sum',6,& + 'NEFR4A%NumSpace_4',NEFR4A%NumSpace_4,& + 'NEFR4B%NumSpace_4',NEFR4B%NumSpace_4) + + do id1 = 1, NEFR4A%NumSpace_1 + if(NEFR4A%Size_vector_alpha_1(id1)& + .ne.NEFR4B%Size_vector_alpha_1(id1).or.& + NEFR4A%Size_vector_beta_1(id1)& + .ne.NEFR4B%Size_vector_beta_1(id1))& + call mqc_error_i('NEF subspace dimensions are & + ¬ conformable in mqc_nef_r4_sum',6,& + 'Sub-space index (id1)', id1,& + 'NEFR4A%Size_vector_alpha_1(id1)',NEFR4A%Size_vector_alpha_1(id1),& + 'NEFR4B%Size_vector_alpha_1(id1)',NEFR4B%Size_vector_alpha_1(id1),& + 'NEFR4A%Size_vector_beta_1(id1)',NEFR4A%Size_vector_beta_1(id1),& + 'NEFR4B%Size_vector_beta_1(id1)',NEFR4B%Size_vector_beta_1(id1)) + end do + do id2 = 1, NEFR4A%NumSpace_2 + if(NEFR4A%Size_vector_alpha_2(id2)& + .ne.NEFR4B%Size_vector_alpha_2(id2).or.& + NEFR4A%Size_vector_beta_2(id2)& + .ne.NEFR4B%Size_vector_beta_2(id2))& + call mqc_error_i('NEF subspace dimensions are & + ¬ conformable in mqc_nef_r4_sum',6,& + 'Sub-space index (id2)', id2,& + 'NEFR4A%Size_vector_alpha_2(id2)',NEFR4A%Size_vector_alpha_2(id2),& + 'NEFR4B%Size_vector_alpha_2(id2)',NEFR4B%Size_vector_alpha_2(id2),& + 'NEFR4A%Size_vector_beta_2(id2)', NEFR4A%Size_vector_beta_2(id2),& + 'NEFR4B%Size_vector_beta_2(id2)', NEFR4B%Size_vector_beta_2(id2)) + end do + do id3 = 1, NEFR4A%NumSpace_3 + if(NEFR4A%Size_vector_alpha_3(id3)& + .ne.NEFR4B%Size_vector_alpha_3(id3).or.& + NEFR4A%Size_vector_beta_3(id3)& + .ne.NEFR4B%Size_vector_beta_3(id3))& + call mqc_error_i('NEF subspace dimensions are & + ¬ conformable in mqc_nef_r4_sum',6,& + 'Sub-space index (id3)', id3,& + 'NEFR4A%Size_vector_alpha_3(id3)',NEFR4A%Size_vector_alpha_3(id3),& + 'NEFR4B%Size_vector_alpha_3(id3)',NEFR4B%Size_vector_alpha_3(id3),& + 'NEFR4A%Size_vector_beta_3(id3)', NEFR4A%Size_vector_beta_3(id3),& + 'NEFR4B%Size_vector_beta_3(id3)', NEFR4B%Size_vector_beta_3(id3)) + end do + do id4 = 1, NEFR4A%NumSpace_4 + if(NEFR4A%Size_vector_alpha_4(id4)& + .ne.NEFR4B%Size_vector_alpha_4(id4).or.& + NEFR4A%Size_vector_beta_4(id4)& + .ne.NEFR4B%Size_vector_beta_4(id4))& + call mqc_error_i('NEF subspace dimensions are & + ¬ conformable in mqc_nef_r4_sum',6,& + 'Sub-space index (id4)', id4,& + 'NEFR4A%Size_vector_alpha_4(id4)',NEFR4A%Size_vector_alpha_4(id4),& + 'NEFR4B%Size_vector_alpha_4(id4)',NEFR4B%Size_vector_alpha_4(id4),& + 'NEFR4A%Size_vector_beta_4(id4)', NEFR4A%Size_vector_beta_4(id4),& + 'NEFR4B%Size_vector_beta_4(id4)', NEFR4B%Size_vector_beta_4(id4)) + end do + + + NEFR4Out = NEFR4A + do id1 = 1, NEFR4Out%NumSpace_1 + do id2 = 1, NEFR4Out%NumSpace_2 + do id3 = 1, NEFR4Out%NumSpace_3 + do id4 = 1, NEFR4Out%NumSpace_4 + id = NEFR4Out%blockIndex([4,id4],[3,id3],[2,id2],[1,id1]) + NEFR4Out%Main_R4(id) = NEFR4A%Main_R4(id) + NEFR4B%Main_R4(id) + end do + end do + end do + end do +! + end function mqc_nef_r4_sum +! +! PROCEDURE MQC_NEFMatrix_Conjugate +! +!> \brief MQC_NEFMatrix_Conjugate is used to compute the conjugate +!> of a MQC NEF Matrix type variable +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEFMatrix_Conjugate is used to compute the conjugate of +!> a MQC NEF Matrix type variable. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] NEFMat +!> \verbatim +!> NEFMat is type(mqc_nef_matrix) +!> The MQC NEF Matrix type variable to conjugate. +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_NEFMatrix_conjugate(NEFMat) result(NEFMatOut) +! + implicit none + type(mqc_nef_matrix),intent(in)::NEFMat + type(mqc_nef_matrix)::NEFMatOut + integer(kind=int64)::row,col +! + call NEFMatOut%init(NEFMat%Map_Matrix_row,& + initial_map_matrix_col=NEFMat%Map_Matrix_col) + do row = 1, NEFMat%NumSpace_row + do col = 1, NEFMat%NumSpace_col + NEFMatOut%Main_Matrix(NEFMatOut%blockIndex([1,row],[2,col])) = & + conjg(NEFMat%Main_Matrix(NEFMat%blockIndex([1,row],[2,col]))) + end do + end do +! + end function mqc_NEFMatrix_conjugate +! +! PROCEDURE MQC_NEFMatrix_Conjugate_Transpose +! +!> \brief MQC_NEFMatrix_Conjugate_Transpose is used to compute the conjugate +!> transpose of a MQC NEF Matrix type variable +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEFMatrix_Conjugate_Transpose is used to compute the conjugate transpose of +!> a MQC NEF Matrix type variable. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] NEFMat +!> \verbatim +!> NEFMat is type(mqc_nef_matrix) +!> The MQC NEF Matrix type variable to conjugate transpose. +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_NEFMatrix_conjugate_transpose(NEFMat) result(NEFMatOut) +! + implicit none + type(mqc_nef_matrix),intent(in)::NEFMat + type(mqc_nef_matrix)::NEFMatOut + integer(kind=int64)::row,col +! + call NEFMatOut%init(NEFMat%Map_Matrix_col,& + initial_map_matrix_col=NEFMat%Map_Matrix_row) + + do row = 1, NEFMat%NumSpace_row + do col = 1, NEFMat%NumSpace_col + NEFMatOut%Main_Matrix(NEFMatOut%blockIndex([2,row],[1,col])) = & + dagger(NEFMat%Main_Matrix(NEFMat%blockIndex([1,row],[2,col]))) + end do + end do +! + end function mqc_NEFMatrix_conjugate_transpose +! +! PROCEDURE MQC_NEFR4_Conjugate_Transpose +! +!> \brief MQC_NEFR4_Conjugate_Transpose is used to compute the conjugate +!> transpose of a MQC NEF R4 type variable +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEFR4_Conjugate_Transpose is used to compute the conjugate transpose of +!> a MQC NEF R4 type variable. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] NEFR4 +!> \verbatim +!> NEFR4 is type(mqc_nef_r4) +!> The MQC NEF R4 type variable to conjugate transpose. +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_NEFR4_conjugate_transpose(NEFR4) result(NEFR4Out) +! + implicit none + type(mqc_nef_r4),intent(in)::NEFR4 + type(mqc_nef_r4)::NEFR4Out + integer(kind=int64)::id1,id2,id3,id4,N1234 +! + NEFR4Out%NumSpace_1 = NEFR4%NumSpace_4 + NEFR4Out%NumSpace_2 = NEFR4%NumSpace_3 + NEFR4Out%NumSpace_3 = NEFR4%NumSpace_2 + NEFR4Out%NumSpace_4 = NEFR4%NumSpace_1 + N1234 = NEFR4Out%NumSpace_1*NEFR4Out%NumSpace_2*NEFR4Out%NumSpace_3*NEFR4Out%NumSpace_4 + allocate(NEFR4Out%Main_R4(N1234)) + NEFR4Out%Map_Matrix_1 = NEFR4%Map_Matrix_4 + NEFR4Out%Map_Matrix_2 = NEFR4%Map_Matrix_3 + NEFR4Out%Map_Matrix_3 = NEFR4%Map_Matrix_2 + NEFR4Out%Map_Matrix_4 = NEFR4%Map_Matrix_1 + NEFR4Out%Size_vector_alpha_1 = NEFR4%Size_vector_alpha_4 + NEFR4Out%Size_vector_alpha_2 = NEFR4%Size_vector_alpha_3 + NEFR4Out%Size_vector_alpha_3 = NEFR4%Size_vector_alpha_2 + NEFR4Out%Size_vector_alpha_4 = NEFR4%Size_vector_alpha_1 + NEFR4Out%Size_vector_beta_1 = NEFR4%Size_vector_beta_4 + NEFR4Out%Size_vector_beta_2 = NEFR4%Size_vector_beta_3 + NEFR4Out%Size_vector_beta_3 = NEFR4%Size_vector_beta_2 + NEFR4Out%Size_vector_beta_4 = NEFR4%Size_vector_beta_1 + + do id1 = 1, NEFR4Out%NumSpace_1 + do id2 = 1, NEFR4Out%NumSpace_2 + do id3 = 1, NEFR4Out%NumSpace_3 + do id4 = 1, NEFR4Out%NumSpace_4 + NEFR4Out%Main_R4(NEFR4Out%blockIndex([4,id4],[3,id3],[2,id2],[1,id1])) = & + dagger(NEFR4%Main_R4(NEFR4%blockIndex([1,id4],[2,id3],[3,id2],[4,id1]))) + end do + end do + end do + end do +! + end function mqc_NEFR4_conjugate_transpose +! +! +! PROCEDURE MQC_NEFMatrix_Transpose +! +!> \brief MQC_NEFMatrix_Transpose is used to compute the +!> transpose of a MQC NEF Matrix type variable +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEFMatrix_Transpose is used to compute the transpose of +!> a MQC NEF Matrix type variable. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] NEFMat +!> \verbatim +!> NEFMat is type(mqc_nef_matrix) +!> The MQC NEF Matrix type variable to transpose. +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_NEFMatrix_transpose(NEFMat) result(NEFMatOut) +! + implicit none + type(mqc_nef_matrix),intent(in)::NEFMat + type(mqc_nef_matrix)::NEFMatOut + integer(kind=int64)::row,col +! + call NEFMatOut%init(NEFMat%Map_Matrix_col,& + initial_map_matrix_col=NEFMat%Map_Matrix_row) + + do row = 1, NEFMat%NumSpace_row + do col = 1, NEFMat%NumSpace_col + NEFMatOut%Main_Matrix(NEFMatOut%blockIndex([2,row],[1,col])) = & + transpose(NEFMat%Main_Matrix(NEFMat%blockIndex([1,row],[2,col]))) + end do + end do +! + end function mqc_NEFMatrix_transpose +! +! +! PROCEDURE MQC_NEF_Scalar_Vector_Multiply +! +!> \brief MQC_NEF_Scalar_Vector_Multiply is used to multiply an MQC scalar with +!> an MQC NEF Vector type variable and returns an MQC NEF Vector +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEF_Scalar_Vector_Multiply is used to multiply an MQC scalar with +!> an MQC NEF Vector type variable and returns an MQC NEF Vector. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] ScalarA +!> \verbatim +!> ScalarB class(*) +!> The variable to multiply. +!> \endverbatim +!> +!> \param[in] NEFVecB +!> \verbatim +!> NEFVecA is type(mqc_nef_vector) +!> The MQC NEF Vector variable to multiply. +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_scalar_nef_vector_multiply(scalarA,NEFVecB) result(NEFVecOut) +! + implicit none + type(mqc_nef_vector),intent(in)::NEFVecB + class(*),intent(in)::scalarA + type(mqc_scalar)::scalar + type(mqc_nef_vector)::NEFVecOut + integer::row +! + select type(scalarA) + type is (integer) + scalar = scalarA + type is (real) + scalar = scalarA + type is (complex) + scalar = scalarA + type is (mqc_scalar) + scalar = scalarA + class default + call mqc_error_I('scalarIn type not defined in mqc_NEF_Vector_scalar_multiply',6) + end select +! + NEFVecOut = NEFVecB + do row = 1, NEFVecB%NumSpace + NEFVecOut%Main_vector(row) = NEFVecB%Main_vector(row)*scalar + end do +! + end function mqc_scalar_nef_vector_multiply +! +! +! PROCEDURE MQC_NEF_Vector_Scalar_Multiply +! +!> \brief MQC_NEF_Vector_Scalar_Multiply is used to multiply an MQC scalar with +!> an MQC NEF Vector type variable and returns an MQC NEF Vector +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEF_Vector_Scalar_Multiply is used to multiply an MQC scalar with +!> an MQC NEF Vector type variable and returns an MQC NEF Vector. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] NEFVecA +!> \verbatim +!> NEFVecA is type(mqc_nef_vector) +!> The MQC NEF Vector variable to multiply. +!> \endverbatim +!> +!> \param[in] ScalarB +!> \verbatim +!> ScalarB class(*) +!> The variable to multiply. +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_nef_vector_scalar_multiply(NEFVecA,scalarB) result(NEFVecOut) +! + implicit none + type(mqc_nef_vector),intent(in)::NEFVecA + class(*),intent(in)::scalarB + type(mqc_scalar)::scalar + type(mqc_nef_vector)::NEFVecOut + integer::row +! + select type(scalarB) + type is (integer) + scalar = scalarB + type is (real) + scalar = scalarB + type is (complex) + scalar = scalarB + type is (mqc_scalar) + scalar = scalarB + class default + call mqc_error_I('scalarIn type not defined in mqc_scalar_NEF_Vector_multiply',6) + end select +! + NEFVecOut = NEFVecA + do row = 1, NEFVecA%NumSpace + NEFVecOut%Main_vector(row) = scalar*NEFVecA%Main_vector(row) + end do +! + end function mqc_nef_vector_scalar_multiply +! +! +! PROCEDURE MQC_Scalar_NEFMatrix_Multiply +! +!> \brief MQC_Scalar_NEFMatrix_Multiply is used to multiply an MQC scalar with +!> an MQC NEF Matrix type variable and returns an MQC NEF Matrix +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_Scalar_NEFMatrix_Multiply is used to multiply an MQC scalar with an MQC +!> NEF Matrix type variable and returns an MQC NEF Matrix +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] ScalarIn +!> \verbatim +!> ScalarIn class(*) +!> The variable to multiply. +!> \endverbatim +!> +!> \param[in] NEFMat +!> \verbatim +!> NEFMat is type(mqc_nef_matrix) +!> The MQC NEF Matrix variable to multiply. +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_scalar_nefmatrix_multiply(scalarIn,NEFMat) result(NEFMatOut) +! + implicit none + type(mqc_nef_matrix),intent(in)::NEFMat + class(*),intent(in)::scalarIn + type(mqc_scalar)::scalar + type(mqc_nef_matrix)::NEFMatOut + integer::col,row,id +! + select type(scalarIn) + type is (integer) + scalar = scalarIn + type is (real) + scalar = scalarIn + type is (complex) + scalar = scalarIn + type is (mqc_scalar) + scalar = scalarIn + class default + call mqc_error_I('scalarIn type not defined in mqc_scalar_NEFMat_multiply',6) + end select +! + NEFMatOut = NEFMat + do row = 1, NEFMat%NumSpace_row + do col = 1, NEFMat%NumSpace_col + id=NEFMat%blockIndex([1,row],[2,col]) + NEFMatOut%Main_matrix(id)=scalar*NEFMat%Main_matrix(id) + end do + end do +! + end function mqc_scalar_nefmatrix_multiply +! +! +! PROCEDURE MQC_NEFMatrix_Scalar_Multiply +! +!> \brief MQC_NEFMatrix_Scalar_Multiply is used to multiply an MQC scalar with +!> an MQC NEF Matrix type variable and returns an MQC NEF Matrix +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEFMatrix_Scalar_Multiply is used to multiply an MQC scalar with an MQC +!> NEF Matrix type variable and returns an MQC NEF Matrix +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] NEFMat +!> \verbatim +!> NEFMat is type(mqc_nef_matrix) +!> The MQC NEF Matrix variable to multiply. +!> \endverbatim +!> +!> \param[in] ScalarB +!> \verbatim +!> ScalarB class(*) +!> The variable to multiply. +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_nefmatrix_scalar_multiply(NEFMat,scalarB) result(NEFMatOut) +! + implicit none + type(mqc_nef_matrix),intent(in)::NEFMat + class(*),intent(in)::scalarB + type(mqc_scalar)::scalar + type(mqc_nef_matrix)::NEFMatOut + integer::col,row,id +! + select type(scalarB) + type is (integer) + scalar = scalarB + type is (real) + scalar = scalarB + type is (complex) + scalar = scalarB + type is (mqc_scalar) + scalar = scalarB + class default + call mqc_error_I('scalarIn type not defined in mqc_scalar_NEFMat_multiply',6) + end select +! + NEFMatOut = NEFMat + do row = 1, NEFMat%NumSpace_row + do col = 1, NEFMat%NumSpace_col + id = NEFMat%blockIndex([1,row],[2,col]) + NEFMatOut%Main_matrix(id)=NEFMat%Main_matrix(id)*scalar + end do + end do +! + end function mqc_nefmatrix_scalar_multiply +! +! +! PROCEDURE MQC_Scalar_NEFR4_Multiply +! +!> \brief MQC_Scalar_NEFR4_Multiply is used to multiply an MQC scalar with +!> an MQC NEF R4 type variable and returns an MQC NEF R4 +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_Scalar_NEFR4_Multiply is used to multiply an MQC scalar with an MQC +!> NEF R4 type variable and returns an MQC NEF R4 +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] ScalarIn +!> \verbatim +!> ScalarIn class(*) +!> The variable to multiply. +!> \endverbatim +!> +!> \param[in] NEFR4 +!> \verbatim +!> NEFR4 is type(mqc_nef_r4) +!> The MQC NEF R4 variable to multiply. +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_scalar_nefr4_multiply(scalarIn,NEFR4) result(NEFR4Out) +! + implicit none + type(mqc_nef_r4),intent(in)::NEFR4 + class(*),intent(in)::scalarIn + type(mqc_scalar)::scalar + type(mqc_nef_r4)::NEFR4Out + integer::id,id1,id2,id3,id4 +! + select type(scalarIn) + type is (integer) + scalar = scalarIn + type is (real) + scalar = scalarIn + type is (complex) + scalar = scalarIn + type is (mqc_scalar) + scalar = scalarIn + class default + call mqc_error_I('scalarIn type not defined in mqc_scalar_NEFR4_multiply',6) + end select +! + NEFR4Out = NEFR4 + do id1 = 1, NEFR4%NumSpace_1 + do id2 = 1, NEFR4%NumSpace_2 + do id3 = 1, NEFR4%NumSpace_3 + do id4 = 1, NEFR4%NumSpace_4 + id = NEFR4Out%blockIndex([1,id1],[2,id2],[3,id3],[4,id4]) + NEFR4Out%Main_R4(id) = scalar*NEFR4Out%Main_R4(id) + end do + end do + end do + end do +! + end function mqc_scalar_nefr4_multiply + function mqc_nefr4_scalar_multiply(NEFR4,scalarB) result(NEFR4Out) +! + implicit none + type(mqc_nef_r4),intent(in)::NEFR4 + class(*),intent(in)::scalarB + type(mqc_scalar)::scalar + type(mqc_nef_r4)::NEFR4Out + integer::id,id1,id2,id3,id4 +! + select type(scalarB) + type is (integer) + scalar = scalarB + type is (real) + scalar = scalarB + type is (complex) + scalar = scalarB + type is (mqc_scalar) + scalar = scalarB + class default + call mqc_error_I('scalarIn type not defined in mqc_NEFR4_scalar_multiply',6) + end select +! + NEFR4Out = NEFR4 + do id1 = 1, NEFR4%NumSpace_1 + do id2 = 1, NEFR4%NumSpace_2 + do id3 = 1, NEFR4%NumSpace_3 + do id4 = 1, NEFR4%NumSpace_4 + id = NEFR4Out%blockIndex([1,id1],[2,id2],[3,id3],[4,id4]) + NEFR4Out%Main_R4(id) = NEFR4Out%Main_R4(id)*scalar + end do + end do + end do + end do +! + end function mqc_nefr4_scalar_multiply +! +! +! PROCEDURE MQC_Print_NEF_R4 +! +!> \brief MQC_Print_NEF_R4 is a subroutine used to print an MQC +!> NEF R4 Tensor object +!> +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_Print_NEF_R4 is a subroutine used to print an MQC NEF R4 Tensor object. +!> Blank_At_Top and Blank_At_Bottom are optional logical arguments to print blank +!> lines before or after output. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] NEFR4 +!> \verbatim +!> Integral is Class(MQC_NEF_R4) +!> The MQC NEF R4 tensor variable to be printed. +!> \endverbatim +!> +!> \param[in] IOut +!> \verbatim +!> IOut is Integer(kind=int64) +!> The Fortran file number to print to. +!> \endverbatim +!> +!> \param[in] Header +!> \verbatim +!> Header is Character(Len=*) +!> The title to print along with Integral. +!> \endverbatim +!> +!> \param[in] Blank_At_Top +!> \verbatim +!> Blank_At_Top is Logical,Optional +!> = .True.: print blank line above output +!> = .False.: do not print blank line above output. +!> \endverbatim +!> +!> \param[in] Blank_At_Bottom +!> \verbatim +!> Blank_At_Bottom is Logical,Optional +!> = .True.: print blank line below output +!> = .False.: do not print blank line below output. +!> \endverbatim +!> +!> \param[in] FormatStr +!> \verbatim +!> FormatStr is Character(Len=*),Optional +!> Formatting statement for printing. +!> \endverbatim +!> +!> \param[in] Short_Print_Threshold +!> \verbatim +!> Short_Print_Threshold is Real,Optional +!> if present: print only elements with absolute value larger than Short_Print_Threshold +!> \endverbatim +! +! Authors: +! ======== +!> \author M.M.F. Moraes +!> \date 2026 +! + subroutine mqc_print_nef_r4(NEFR4,iOut,header, & + blank_at_top,blank_at_bottom,formatStr,short_print_threshold) +! + implicit none + class(mqc_nef_r4)::NEFR4 + integer(kind=int64),intent(in)::iOut + character(len=*),intent(in)::header + character(len=64)::arrayType + logical,intent(In),optional::blank_at_top,blank_at_bottom + character(len=*),intent(in),optional::formatStr + Real(kind=real64),intent(in),optional::short_print_threshold + Real(kind=real64)::print_threshold + integer::id,id1,id2,id3,id4 +! + 1000 Format(1x,A) + 1020 Format( " " ) +! + if(present(blank_at_top)) then + if(blank_at_top) write(iout,1020) + endif + If(Present(short_print_threshold)) then + print_threshold = short_print_threshold + else + print_threshold = -1.0 + EndIf + + write(iout,1000) trim(header) + do id1 = 1, NEFR4%NumSpace_1 + do id2 = 1, NEFR4%NumSpace_2 + do id3 = 1, NEFR4%NumSpace_3 + do id4 = 1, NEFR4%NumSpace_4 + id = NEFR4%blockIndex([1,id1],[2,id2],[3,id3],[4,id4]) + call mqc_print(NEFR4%Main_R4(id),iOut,& + 'Sub-Space ('//trim(num2char(id1))//trim(num2char(id2))//'|'//trim(num2char(id3))//trim(num2char(id4))//') '& + &' '//trim(NEFR4%Main_R4(id)%storType())//' '//trim(NEFR4%Main_R4(id)%type()),& + short_print_threshold=print_threshold) + end do + end do + end do + end do + + end subroutine mqc_print_nef_r4 +! +! +! +! PROCEDURE MQC_NEFMatrix_NEFMatrix_Outer_Product +! +!> \brief MQC_NEFMatrix_NEFMatrix_Outer_Product is used to calculate the +!> outer product between two MQC NEF Matrix type variabel and returns an MQC NEF R4 +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEFMatrix_NEFMatrix_Outer_Product is used to calculate the outer product between +!> two MQC NEF Matrix and returns an MQC NEF R4. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] NEFMatA +!> \verbatim +!> NEFMatA is type(mqc_nef_matrix) +!> \endverbatim +!> +!> \param[in] NEFMatB +!> \verbatim +!> NEFMatB is type(mqc_nef_matrix) +!> \endverbatim +! +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_nefmatrix_nefmatrix_outer_product(NEFMatA,NEFMatB) result(NEFR4Out) +! + implicit none + class(mqc_nef_matrix),intent(in)::NEFMatA + type(mqc_nef_matrix),intent(in)::NEFMatB + type(mqc_nef_r4)::NEFR4Out + + integer::idA,idB,id,id1,id2,id3,id4,N1,N12,N123,N1234 + + NEFR4Out%NumSpace_2 = NEFMatA%NumSpace_col + NEFR4Out%NumSpace_1 = NEFMatA%NumSpace_row + NEFR4Out%NumSpace_4 = NEFMatB%NumSpace_col + NEFR4Out%NumSpace_3 = NEFMatB%NumSpace_row + write(*,'(A,I3,I3,I3,I3)') 'Sizes: ',NEFR4Out%NumSpace_1,NEFR4Out%NumSpace_2,& + NEFR4Out%NumSpace_3,NEFR4Out%NumSpace_4 + N1 = NEFR4Out%NumSpace_4 + N12 = N1*NEFR4Out%NumSpace_3 + N123 = N12*NEFR4Out%NumSpace_2 + N1234 = N123*NEFR4Out%NumSpace_1 + write(*,'(A,I5)') 'Total size: ',N1234 + + allocate(NEFR4Out%Main_R4(N1234)) + NEFR4Out%Map_Matrix_2 = NEFMatA%Map_Matrix_Col + NEFR4Out%Map_Matrix_1 = NEFMatA%Map_Matrix_Row + NEFR4Out%Map_Matrix_4 = NEFMatB%Map_Matrix_Col + NEFR4Out%Map_Matrix_3 = NEFMatB%Map_Matrix_Row + NEFR4Out%Size_vector_alpha_2 = NEFMatA%Size_vector_alpha_Col + NEFR4Out%Size_vector_alpha_1 = NEFMatA%Size_vector_alpha_Row + NEFR4Out%Size_vector_alpha_4 = NEFMatB%Size_vector_alpha_Col + NEFR4Out%Size_vector_alpha_3 = NEFMatB%Size_vector_alpha_Row + NEFR4Out%Size_vector_beta_2 = NEFMatA%Size_vector_beta_Col + NEFR4Out%Size_vector_beta_1 = NEFMatA%Size_vector_beta_Row + NEFR4Out%Size_vector_beta_4 = NEFMatB%Size_vector_beta_Col + NEFR4Out%Size_vector_beta_3 = NEFMatB%Size_vector_beta_Row + + do id1 = 1, NEFR4Out%NumSpace_1 + do id2 = 1, NEFR4Out%NumSpace_2 + idA = NEFMatA%blockIndex([1,id1],[2,id2]) + do id3 = 1, NEFR4Out%NumSpace_3 + do id4 = 1, NEFR4Out%NumSpace_4 + idB = NEFMatB%blockIndex([1,id3],[2,id4]) + NEFR4Out%Main_R4(NEFR4Out%blockIndex([1,id1],[2,id2],[3,id3],[4,id4])) = & + NEFMatA%Main_Matrix(idA)%outer2ERI(NEFMatB%Main_Matrix(idB)) + end do + end do + end do + end do +! + end function mqc_nefmatrix_nefmatrix_outer_product +! +! +! +! PROCEDURE MQC_NEFMatrix_NEFMatrix_Crossouter_Product +! +!> \brief MQC_NEFMatrix_NEFMatrix_crossouter_Product is used to calculate the +!> crossouter product between two MQC NEF Matrix type variabel and returns an MQC NEF R4 +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEFMatrix_NEFMatrix_Crossouter_Product is used to calculate the crossouter product between +!> two MQC NEF Matrix and returns an MQC NEF R4. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] NEFMatA +!> \verbatim +!> NEFMatA is type(mqc_nef_matrix) +!> \endverbatim +!> +!> \param[in] NEFMatB +!> \verbatim +!> NEFMatB is type(mqc_nef_matrix) +!> \endverbatim +! +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_nefmatrix_nefmatrix_crossouter_product(NEFMatA,NEFMatB) result(NEFR4Out) +! + implicit none + class(mqc_nef_matrix),intent(in)::NEFMatA + type(mqc_nef_matrix),intent(in)::NEFMatB + type(mqc_nef_r4)::NEFR4Out + + integer::idA,idB,id,id1,id2,id3,id4,N1,N12,N123,N1234 + + NEFR4Out%NumSpace_1 = NEFMatA%NumSpace_col + NEFR4Out%NumSpace_4 = NEFMatA%NumSpace_row + NEFR4Out%NumSpace_3 = NEFMatB%NumSpace_col + NEFR4Out%NumSpace_2 = NEFMatB%NumSpace_row + N1 = NEFR4Out%NumSpace_4 + N12 = N1*NEFR4Out%NumSpace_3 + N123 = N12*NEFR4Out%NumSpace_2 + N1234 = N123*NEFR4Out%NumSpace_1 + + allocate(NEFR4Out%Main_R4(N1234)) + NEFR4Out%Map_Matrix_1 = NEFMatA%Map_Matrix_Col + NEFR4Out%Map_Matrix_4 = NEFMatA%Map_Matrix_Row + NEFR4Out%Map_Matrix_3 = NEFMatB%Map_Matrix_Col + NEFR4Out%Map_Matrix_2 = NEFMatB%Map_Matrix_Row + NEFR4Out%Size_vector_alpha_1 = NEFMatA%Size_vector_alpha_Col + NEFR4Out%Size_vector_alpha_4 = NEFMatA%Size_vector_alpha_Row + NEFR4Out%Size_vector_alpha_3 = NEFMatB%Size_vector_alpha_Col + NEFR4Out%Size_vector_alpha_2 = NEFMatB%Size_vector_alpha_Row + NEFR4Out%Size_vector_beta_1 = NEFMatA%Size_vector_beta_Col + NEFR4Out%Size_vector_beta_4 = NEFMatA%Size_vector_beta_Row + NEFR4Out%Size_vector_beta_3 = NEFMatB%Size_vector_beta_Col + NEFR4Out%Size_vector_beta_2 = NEFMatB%Size_vector_beta_Row + + do id1 = 1, NEFR4Out%NumSpace_1 + do id4 = 1, NEFR4Out%NumSpace_4 + idA = NEFMatA%blockIndex([1,id1],[2,id4]) + do id3 = 1, NEFR4Out%NumSpace_3 + do id2 = 1, NEFR4Out%NumSpace_2 + idB = NEFMatB%blockIndex([1,id3],[2,id2]) + NEFR4Out%Main_R4(NEFR4Out%blockIndex([1,id1],[2,id2],[3,id3],[4,id4])) = & + NEFMatA%Main_Matrix(idA)%crossouter2ERI(NEFMatB%Main_Matrix(idB)) + end do + end do + end do + end do +! + end function mqc_nefmatrix_nefmatrix_crossouter_product +! +! +! PROCEDURE MQC_NEFMatrix_NEFMatrix_Contraction +! +! +!> \brief MQC_NEFMatrix_NEFMatrix_Contraction is used to return the contraction of two +!> MQC NEF Matrix objects. +!> +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEFMatrix_NEFMatrix_Contraction is used to return the contraction of two +!> MQC NEF Matrix objects. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] NEFMatA +!> \verbatim +!> NEFMatA is type(mqc_nef_matrix) +!> The first MQC NEF Matrix to be contracted. +!> \endverbatim +!> +!> \param[in] NEFMatB +!> \verbatim +!> NEFMatB is type(mqc_nef_matrix) +!> The second MQC NEF Matrix to be contracted. +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_nefmatrix_nefmatrix_contraction(NEFMatA,NEFMatB) result(output) +! + implicit none + type(mqc_nef_matrix),intent(in)::NEFMatA,NEFMatB + type(mqc_scalar)::output + integer::row,col,id +! + if(NEFMatA%NumSpace_col.ne.NEFMatB%NumSpace_col.or.& + NEFMatA%NumSpace_row.ne.NEFMatB%NumSpace_row) & + call mqc_error_i('NEF number of subspaces are & + ¬ conformable in mqc_nefmatrix_sum',6,& + 'NEFMatA%NumSpace_col',NEFMatA%NumSpace_col,& + 'NEFMatB%NumSpace_col',NEFMatB%NumSpace_col,& + 'NEFMatA%NumSpace_row',NEFMatA%NumSpace_row,& + 'NEFMatB%NumSpace_row',NEFMatB%NumSpace_row) + + do col = 1, NEFMatA%NumSpace_col + if(NEFMatA%Size_vector_alpha_col(col)& + .ne.NEFMatB%Size_vector_alpha_col(col).or. & + NEFMatA%Size_vector_beta_col(col) & + .ne.NEFMatB%Size_vector_beta_col(col)) & + call mqc_error_i('NEF subspace dimensions are & + ¬ conformable in mqc_nefmatrix_sum',6,& + 'Sub-space index (col)', col,& + 'NEFMatA%Size_vector_alpha_col(col)',NEFMatA%Size_vector_alpha_col(col),& + 'NEFMatB%Size_vector_alpha_col(col)',NEFMatB%Size_vector_alpha_col(col),& + 'NEFMatA%Size_vector_beta_col(col)',NEFMatA%Size_vector_beta_col(col),& + 'NEFMatB%Size_vector_beta_col(col)',NEFMatB%Size_vector_beta_col(col)) + end do + do row = 1, NEFMatA%NumSpace_row + if(NEFMatA%Size_vector_alpha_row(row)& + .ne.NEFMatB%Size_vector_alpha_row(row).or. & + NEFMatA%Size_vector_beta_row(row) & + .ne.NEFMatB%Size_vector_beta_row(row)) & + call mqc_error_i('NEF subspace dimensions are & + ¬ conformable in mqc_nefmatrix_sum',6,& + 'Sub-space index (row)', row,& + 'NEFMatA%Size_vector_alpha_row(row)',NEFMatA%Size_vector_alpha_row(row),& + 'NEFMatB%Size_vector_alpha_row(row)',NEFMatB%Size_vector_alpha_row(row),& + 'NEFMatA%Size_vector_beta_row(row)',NEFMatA%Size_vector_beta_row(row),& + 'NEFMatB%Size_vector_beta_row(row)',NEFMatB%Size_vector_beta_row(row)) + end do + output = 0.0 + do row = 1, NEFMatA%NumSpace_row + do col = 1, NEFMatA%NumSpace_col + id = NEFMatA%blockIndex([1,row],[2,col]) + output = output + Contraction(NEFMatA%Main_Matrix(id),NEFMatB%Main_Matrix(id)) + end do + end do +! + end function mqc_nefmatrix_nefmatrix_contraction +! +! +! PROCEDURE MQC_NEF_R4_NEF_R4_Contraction +! +! +!> \brief MQC_NEF_R4_NEF_R4_Contraction is used to return the contraction of two +!> MQC NEF R4 objects. +!> +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEF_R4_NEF_R4_Contraction is used to return the contraction of two +!> MQC NEF R4 objects. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] NEFR4A +!> \verbatim +!> NEFR4A is type(mqc_nef_r4) +!> The first MQC NEF R4 to be contracted. +!> \endverbatim +!> +!> \param[in] NEFR4B +!> \verbatim +!> NEFR4B is type(mqc_nef_r4) +!> The second MQC NEF R4 to be contracted. +!> \endverbatim +!> +!> \param[in] Label +!> \verbatim +!> Label is character(len=*),optional +!> = 'coulomb': contracts with coulomb integrals. +!> = 'exchange': contracts with exchange integrals. +!> = 'doublebar': contracts with double bar integrals +!> (default). +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_nef_r4_nef_r4_contraction(NEFR4A,NEFR4B,label) result(output) +! + implicit none + type(mqc_nef_r4),intent(in)::NEFR4A,NEFR4B + character(len=*),optional,intent(in)::label + character(len=64)::myLabel + type(mqc_scalar)::output + integer::id1,id2,id3,id4,id,idex + type(mqc_twoeris):: debbug_ERI +! + if(present(label)) then + call string_change_case(label,'L',myLabel) + else + myLabel = 'doublebar' + endIf +! + if(myLabel.ne.'coulomb'.and.myLabel.ne.'exchange'.and.& + myLabel.ne.'doublebar') & + call mqc_error_a('Unrecognized 2ERI integral interaction specified& + &in mqc_nef_r4_nef_r4_contraction.',& + 6,'myLabel',myLabel) +! + if(NEFR4A%NumSpace_1.ne.NEFR4B%NumSpace_1)& + call mqc_error_i('NEF number of subspaces are & + ¬ conformable in mqc_nef_r4_nef_r4_contraction',6,& + 'NEFR4A%NumSpace_1',NEFR4A%NumSpace_1,& + 'NEFR4B%NumSpace_1',NEFR4B%NumSpace_1) + if(NEFR4A%NumSpace_2.ne.NEFR4B%NumSpace_2)& + call mqc_error_i('NEF number of subspaces are & + ¬ conformable in mqc_nef_r4_nef_r4_contraction',6,& + 'NEFR4A%NumSpace_2',NEFR4A%NumSpace_2,& + 'NEFR4B%NumSpace_2',NEFR4B%NumSpace_2) + if(NEFR4A%NumSpace_3.ne.NEFR4B%NumSpace_3)& + call mqc_error_i('NEF number of subspaces are & + ¬ conformable in mqc_nef_r4_nef_r4_contraction',6,& + 'NEFR4A%NumSpace_3',NEFR4A%NumSpace_3,& + 'NEFR4B%NumSpace_3',NEFR4B%NumSpace_3) + if(NEFR4A%NumSpace_4.ne.NEFR4B%NumSpace_4)& + call mqc_error_i('NEF number of subspaces are & + ¬ conformable in mqc_nef_r4_nef_r4_contraction',6,& + 'NEFR4A%NumSpace_4',NEFR4A%NumSpace_4,& + 'NEFR4B%NumSpace_4',NEFR4B%NumSpace_4) + + do id1 = 1, NEFR4A%NumSpace_1 + if(NEFR4A%Size_vector_alpha_1(id1)& + .ne.NEFR4B%Size_vector_alpha_1(id1).or.& + NEFR4A%Size_vector_beta_1(id1)& + .ne.NEFR4B%Size_vector_beta_1(id1))& + call mqc_error_i('NEF subspace dimensions are & + ¬ conformable in mqc_nef_r4_nef_r4_contraction',6,& + 'Sub-space index (id1)', id1,& + 'NEFR4A%Size_vector_alpha_1(id1)',NEFR4A%Size_vector_alpha_1(id1),& + 'NEFR4B%Size_vector_alpha_1(id1)',NEFR4B%Size_vector_alpha_1(id1),& + 'NEFR4A%Size_vector_beta_1(id1)',NEFR4A%Size_vector_beta_1(id1),& + 'NEFR4B%Size_vector_beta_1(id1)',NEFR4B%Size_vector_beta_1(id1)) + end do + do id2 = 1, NEFR4A%NumSpace_2 + if(NEFR4A%Size_vector_alpha_2(id2)& + .ne.NEFR4B%Size_vector_alpha_2(id2).or.& + NEFR4A%Size_vector_beta_2(id2)& + .ne.NEFR4B%Size_vector_beta_2(id2))& + call mqc_error_i('NEF subspace dimensions are & + ¬ conformable in mqc_nef_r4_nef_r4_contraction',6,& + 'Sub-space index (id2)', id2,& + 'NEFR4A%Size_vector_alpha_2(id2)',NEFR4A%Size_vector_alpha_2(id2),& + 'NEFR4B%Size_vector_alpha_2(id2)',NEFR4B%Size_vector_alpha_2(id2),& + 'NEFR4A%Size_vector_beta_2(id2)', NEFR4A%Size_vector_beta_2(id2),& + 'NEFR4B%Size_vector_beta_2(id2)', NEFR4B%Size_vector_beta_2(id2)) + end do + do id3 = 1, NEFR4A%NumSpace_3 + if(NEFR4A%Size_vector_alpha_3(id3)& + .ne.NEFR4B%Size_vector_alpha_3(id3).or.& + NEFR4A%Size_vector_beta_3(id3)& + .ne.NEFR4B%Size_vector_beta_3(id3))& + call mqc_error_i('NEF subspace dimensions are & + ¬ conformable in mqc_nef_r4_nef_r4_contraction',6,& + 'Sub-space index (id3)', id3,& + 'NEFR4A%Size_vector_alpha_3(id3)',NEFR4A%Size_vector_alpha_3(id3),& + 'NEFR4B%Size_vector_alpha_3(id3)',NEFR4B%Size_vector_alpha_3(id3),& + 'NEFR4A%Size_vector_beta_3(id3)', NEFR4A%Size_vector_beta_3(id3),& + 'NEFR4B%Size_vector_beta_3(id3)', NEFR4B%Size_vector_beta_3(id3)) + end do + do id4 = 1, NEFR4A%NumSpace_4 + if(NEFR4A%Size_vector_alpha_4(id4)& + .ne.NEFR4B%Size_vector_alpha_4(id4).or.& + NEFR4A%Size_vector_beta_4(id4)& + .ne.NEFR4B%Size_vector_beta_4(id4))& + call mqc_error_i('NEF subspace dimensions are & + ¬ conformable in mqc_nef_r4_nef_r4_contraction',6,& + 'Sub-space index (id4)', id4,& + 'NEFR4A%Size_vector_alpha_4(id4)',NEFR4A%Size_vector_alpha_4(id4),& + 'NEFR4B%Size_vector_alpha_4(id4)',NEFR4B%Size_vector_alpha_4(id4),& + 'NEFR4A%Size_vector_beta_4(id4)', NEFR4A%Size_vector_beta_4(id4),& + 'NEFR4B%Size_vector_beta_4(id4)', NEFR4B%Size_vector_beta_4(id4)) + end do +! + output = 0.0 + do id1 = 1, NEFR4A%NumSpace_1 + do id2 = 1, NEFR4A%NumSpace_2 + do id3 = 1, NEFR4A%NumSpace_3 + do id4 = 1, NEFR4A%NumSpace_4 + id = NEFR4A%blockIndex([1,id1],[2,id2],[3,id3],[4,id4]) + if (myLabel.eq.'doublebar'.or.myLabel.eq.'coulomb') then + output = output + contraction(NEFR4A%Main_R4(id),NEFR4B%Main_R4(id),'coulomb') + end if + if (myLabel.eq.'doublebar'.or.myLabel.eq.'exchange') then + idex = NEFR4A%blockIndex([1,id1],[4,id2],[3,id3],[2,id4]) + output = output - & + contraction(NEFR4A%Main_R4(idex),NEFR4B%Main_R4(id)%swap(2,4),'coulomb') + end if + end do + end do + end do + end do +! + end function mqc_nef_r4_nef_r4_contraction +! +! +! PROCEDURE MQC_NEF_R4_NEF_Matrix_Contraction +! +! +!> \brief MQC_NEF_R4_NEF_Matrix_Contraction is used to return the contraction of a +!> MQC NEF R4 and MQC NEF Matrix objects. +!> +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEF_R4_NEF_Matrix_Contraction is used to return the contraction of a +!> MQC NEF R4 and MQC NEF Matrix objects. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] NEFR4A +!> \verbatim +!> NEFR4A is type(mqc_nef_r4) +!> The MQC NEF R4 to be contracted. +!> \endverbatim +!> +!> \param[in] NEFMatB +!> \verbatim +!> NEFMatB is type(mqc_nef_matrix) +!> The MQC NEF Matrix to be contracted. +!> \endverbatim +!> +!> \param[in] Label +!> \verbatim +!> Label is character(len=*),optional +!> = 'coulomb': contracts with coulomb integrals. +!> = 'exchange': contracts with exchange integrals. +!> = 'doublebar': contracts with double bar integrals +!> (default). +!> \endverbatim +!> +!> \param[in] IndexA +!> \verbatim +!> IndexA is integer(kind=int64),dimension(4),optional +!> Contain the indexes of ERIsA to be contracted. +!> The two first integers in the object are the ones to be contracted, +!> while the two last are the one to be multiplied. +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_nef_r4_nef_matrix_contraction(NEFR4A,NEFMatB,label,indexA) result(output) +! + implicit none + type(mqc_nef_r4),intent(in)::NEFR4A + type(mqc_nef_matrix),intent(in)::NEFMatB + character(len=*),optional,intent(in)::label + integer(kind=int64),dimension(4),intent(in),optional::indexA + integer(kind=int64),dimension(4)::my_indexA + character(len=64)::myLabel + type(mqc_nef_matrix)::output + integer::id1,id2,id3,id4,idA,idB,idex,idOut + type(mqc_twoeris):: debbug_ERI + type(MQC_SCF_Eigenvalues),Dimension(:),Allocatable::Map_Matrix_Col,Map_Matrix_Row + Integer(kind=int64)::ia,ja,ka,la +! + if(present(label)) then + call string_change_case(label,'L',myLabel) + else + myLabel = 'doublebar' + endIf +! + if(myLabel.ne.'coulomb'.and.myLabel.ne.'exchange'.and.& + myLabel.ne.'doublebar') & + call mqc_error_a('Unrecognized 2ERI integral interaction specified& + &in mqc_nef_r4_nef_r4_contraction.',& + 6,'myLabel',myLabel) +! + if(present(indexA)) then + ia=indexA(1) + ja=indexA(2) + ka=indexA(3) + la=indexA(4) + if (ia.eq.ja) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_NEF_Matrix_Contraction',& + 6,'ia', ia,'ja',ja) + if (ia.eq.ka) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_NEF_Matrix_Contraction',& + 6,'ia', ia,'ka',ka) + if (ia.eq.la) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_NEF_Matrix_Contraction',& + 6,'ia', ia,'la',la) + if (ja.eq.ka) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_NEF_Matrix_Contraction',& + 6,'ja', ja,'ka',ka) + if (ja.eq.la) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_NEF_Matrix_Contraction',& + 6,'ja', ja,'la',la) + if (ka.eq.la) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_NEF_Matrix_Contraction',& + 6,'ka', ka,'la',la) + my_indexA = indexA + else + ia=1 + ja=2 + ka=3 + la=4 + my_indexA = [1,2,3,4] + endif +! + if(NEFR4A%blockSize(ia).ne.NEFMatB%NumSpace_row)& + call mqc_error_i('NEF number of subspaces are & + ¬ conformable in mqc_nef_r4_nef_Matrix_contraction',6,& + 'NEFR4A%blockSize(ia)',NEFR4A%blockSize(ia),& + 'NEFMatB%NumSpace_row',NEFMatB%NumSpace_row) + if (myLabel.eq.'doublebar'.or.myLabel.eq.'coulomb') then + if(NEFR4A%blockSize(ja).ne.NEFMatB%NumSpace_col)& + call mqc_error_i('NEF number of subspaces are & + ¬ conformable in mqc_nef_r4_nef_Matrix_contraction',6,& + 'NEFR4A%blockSize(ja)',NEFR4A%blockSize(ja),& + 'NEFMatB%NumSpace_col',NEFMatB%NumSpace_col) + end if + if (myLabel.eq.'doublebar'.or.myLabel.eq.'exchange') then + if(NEFR4A%blockSize(la).ne.NEFMatB%NumSpace_col)& + call mqc_error_i('NEF number of subspaces are & + ¬ conformable for exchange in mqc_nef_r4_nef_Matrix_contraction',6,& + 'NEFR4A%blockSize(la)',NEFR4A%blockSize(la),& + 'NEFMatB%NumSpace_col',NEFMatB%NumSpace_col) + end if + + do id1 = 1, NEFR4A%blockSize(ia) + if(NEFR4A%blockSize(ia,id1,'alpha')& + .ne.NEFMatB%Size_vector_alpha_row(id1).or.& + NEFR4A%blockSize(ia,id1,'beta')& + .ne.NEFMatB%Size_vector_beta_row(id1))& + call mqc_error_i('NEF subspace dimensions are & + ¬ conformable in mqc_nef_r4_nef_Matrix_contraction',6,& + 'Sub-space index (id1)', id1,& + 'NEFR4A%blockSize(ia,id1,alpha)',NEFR4A%blockSize(ia,id1,'alpha'),& + 'NEFMatB%Size_vector_alpha_row(id1)',NEFMatB%Size_vector_alpha_row(id1),& + 'NEFR4A%blockSize(ia,id1,beta)',NEFR4A%blockSize(ia,id1,'beta'),& + 'NEFMatB%Size_vector_beta_row(id1)',NEFMatB%Size_vector_beta_row(id1)) + end do + + if (myLabel.eq.'doublebar'.or.myLabel.eq.'coulomb') then + do id1 = 1, NEFR4A%blockSize(ja) + if(NEFR4A%blockSize(ja,id1,'alpha')& + .ne.NEFMatB%Size_vector_alpha_col(id1).or.& + NEFR4A%blockSize(ja,id1,'beta')& + .ne.NEFMatB%Size_vector_beta_col(id1))& + call mqc_error_i('NEF subspace dimensions are & + ¬ conformable in mqc_nef_r4_nef_Matrix_contraction',6,& + 'Sub-space index (id1)', id1,& + 'NEFR4A%blockSize(ja,id1,alpha)',NEFR4A%blockSize(ja,id1,'alpha'),& + 'NEFMatB%Size_vector_alpha_col(id1)',NEFMatB%Size_vector_alpha_col(id1),& + 'NEFR4A%blockSize(ja,id1,beta)',NEFR4A%blockSize(ja,id1,'beta'),& + 'NEFMatB%Size_vector_beta_col(id1)',NEFMatB%Size_vector_beta_col(id1)) + end do + end if + if (myLabel.eq.'doublebar'.or.myLabel.eq.'exchange') then + do id1 = 1, NEFR4A%blockSize(la) + if(NEFR4A%blockSize(la,id1,'alpha')& + .ne.NEFMatB%Size_vector_alpha_col(id1).or.& + NEFR4A%blockSize(la,id1,'beta')& + .ne.NEFMatB%Size_vector_beta_col(id1))& + call mqc_error_i('NEF subspace dimensions are & + ¬ conformable for exchange in mqc_nef_r4_nef_Matrix_contraction',6,& + 'Sub-space index (id1)', id1,& + 'NEFR4A%blockSize(la,id1,alpha)',NEFR4A%blockSize(la,id1,'alpha'),& + 'NEFMatB%Size_vector_alpha_col(id1)',NEFMatB%Size_vector_alpha_col(id1),& + 'NEFR4A%blockSize(la,id1,beta)',NEFR4A%blockSize(la,id1,'beta'),& + 'NEFMatB%Size_vector_beta_col(id1)',NEFMatB%Size_vector_beta_col(id1)) + end do + end if +! + Map_Matrix_Col = NEFR4A%blockMap(la) + Map_Matrix_Row = NEFR4A%blockMap(ka) + call output%init(Map_Matrix_Row,initial_map_matrix_col=Map_Matrix_Col) + do id4 = 1, NEFR4A%blockSize(la) + do id3 = 1, NEFR4A%blockSize(ka) + do id2 = 1, NEFR4A%blockSize(ja) + do id1 = 1, NEFR4A%blockSize(ia) + idA = NEFR4A%blockIndex([ia,id1],[ja,id2],[ka,id3],[la,id4]) + idB = NEFMatB%blockIndex([1,id1],[2,id2]) + idOut = NEFMatB%blockIndex([1,id3],[2,id4]) + if (myLabel.eq.'doublebar'.or.myLabel.eq.'coulomb') then + if ((NEFR4A%blockSize(ia,id1,'alpha')+NEFR4A%blockSize(ia,id1,'beta')).eq.0.or.& + (NEFR4A%blockSize(ja,id2,'alpha')+NEFR4A%blockSize(ja,id2,'beta')).eq.0.or.& + (NEFR4A%blockSize(ka,id3,'alpha')+NEFR4A%blockSize(ka,id3,'beta')).eq.0.or.& + (NEFR4A%blockSize(la,id4,'alpha')+NEFR4A%blockSize(la,id4,'beta')).eq.0) cycle + output%Main_Matrix(idOut) = output%Main_Matrix(idOut) & + + contraction(NEFR4A%Main_R4(idA),& + NEFMatB%Main_Matrix(idB),[ia,ja]) + end if + if (myLabel.eq.'doublebar'.or.myLabel.eq.'exchange') then + if ((NEFR4A%blockSize(ia,id1,'alpha')+NEFR4A%blockSize(ia,id1,'beta')).eq.0.or.& + (NEFR4A%blockSize(la,id2,'alpha')+NEFR4A%blockSize(la,id2,'beta')).eq.0.or.& + (NEFR4A%blockSize(ka,id3,'alpha')+NEFR4A%blockSize(ka,id3,'beta')).eq.0.or.& + (NEFR4A%blockSize(ja,id4,'alpha')+NEFR4A%blockSize(ja,id4,'beta')).eq.0) cycle + idex = NEFR4A%blockIndex([ia,id1],[la,id2],[ka,id3],[ja,id4]) + idB = NEFMatB%blockIndex([1,id1],[2,id2]) + idOut = NEFMatB%blockIndex([1,id3],[2,id4]) + output%Main_Matrix(idOut) = output%Main_Matrix(idOut) & + - contraction(NEFR4A%Main_R4(idex),& + NEFMatB%Main_Matrix(idB),[ia,la]) + end if + end do + end do + end do + end do +! + end function mqc_nef_r4_nef_matrix_contraction +! +! +! PROCEDURE MQC_NEF_Matrix_Dimension_Slice +! +! +!> \brief MQC_NEF_Matrix_Dimension_Slice is used to return a slice of +!> the input NEF Matrix object +!> +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEF_Matrix_Dimension_Slice is used to return a slice of +!> the input NEF Matrix object. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] NEFMat +!> \verbatim +!> NEFMat is type(mqc_nef_matrix) +!> NEF Matrix Object to be Sliced. +!> \endverbatim +!> +!> \param[in] rows +!> \verbatim +!> rows is integer(kind=int64),dimension(:),optional +!> Contains the indexes of the remaining rows after the slicing. +!> Default: all rows +!> \endverbatim +!> +!> \param[in] columns +!> \verbatim +!> columns is integer(kind=int64),dimension(:),optional +!> Contains the indexes of the remaining columns after the slicing. +!> Default: all columns +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_nef_matrix_dimention_slice(NEFMat,rows,columns) result(NEFMatOut) +! + implicit none + class(mqc_nef_matrix),intent(in)::NEFMat + type(mqc_nef_matrix)::NEFMatOut + integer(kind=int64),dimension(:),optional,intent(in)::rows,columns + Type(MQC_SCF_Eigenvalues),Dimension(:),Allocatable::New_Map_Col,New_Map_Row + integer(kind=int64),dimension(:),Allocatable::my_row,my_col + integer(kind=int64)::row,col,id,idOld + logical::full_row,full_col +! + if(present(rows)) then + my_row = rows + full_row=.false. + if(present(columns)) then + my_col = columns + full_col=.false. + else + full_col=.true. + endIf + else + full_row=.true. + if(present(columns)) then + my_col = columns + full_col=.false. + else + NEFMatOut = NEFMat + return + endIf + endIf +! + if(full_col) then + New_Map_Col = NEFMat%Map_Matrix_Col + else + allocate(New_Map_Col(size(my_col))) + do id = 1, size(my_col) + if(my_col(id).gt.NEFMat%NumSpace_col.or.my_col(id).le.0) & + call mqc_error_i('Column index out-of-bound in mqc_nef_matrix_dimention_slice',6,& + 'my_col(id)',my_col(id),'NEFMat%NumSpace_col',NEFMat%NumSpace_col) + New_Map_Col(id) = NEFMat%Map_Matrix_Col(my_col(id)) + end do + end if +! + if(full_row) then + New_Map_Row = NEFMat%Map_Matrix_Row + else + allocate(New_Map_Row(size(my_row))) + do id = 1, size(my_row) + if(my_row(id).gt.NEFMat%NumSpace_row.or.my_row(id).le.0) & + call mqc_error_i('Row index out-of-bound in mqc_nef_matrix_dimention_slice',6,& + 'my_row(id)',my_row(id),'NEFMat%NumSpace_row',NEFMat%NumSpace_row) + New_Map_Row(id) = NEFMat%Map_Matrix_Row(my_row(id)) + end do + end if +! + call NEFMatOut%init(New_Map_Row,& + initial_map_matrix_col=New_Map_Col) + if(full_row) then + do col = 1, size(my_col) + do row = 1, size(NEFMat%Map_Matrix_Row) + id = NEFMatOut%blockIndex([1,row],[2,col]) + idOld = NEFMat%blockIndex([1,row],[2,my_col(col)]) + NEFMatOut%Main_matrix(id) = NEFMat%Main_matrix(idOld) + end do + end do + else if (full_col) then + do row = 1, size(my_row) + do col = 1, size(NEFMat%Map_Matrix_Col) + id = NEFMatOut%blockIndex([1,row],[2,col]) + idOld = NEFMat%blockIndex([1,my_row(row)],[2,col]) + NEFMatOut%Main_matrix(id) = NEFMat%Main_matrix(idOld) + end do + end do + else + do row = 1, size(my_row) + do col = 1, size(my_col) + id = NEFMatOut%blockIndex([1,row],[2,col]) + idOld = NEFMat%blockIndex([1,my_row(row)],[2,my_col(col)]) + NEFMatOut%Main_matrix(id) = NEFMat%Main_matrix(idOld) + end do + end do + end if +! + end function mqc_nef_matrix_dimention_slice +! +! +! PROCEDURE MQC_NEF_R4_NEF_R4_Partial_Contraction_2R4 +! +!> \brief MQC_NEF_R4_NEF_R4_Contraction_2R4 is used to return the contraction of +!> MQC NEF R4 with a MQC NEF R4 +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEF_R4_NEF_R4_Contraction_2R4 is used to return the contraction of +!> MQC NEF R4 with a MQC NEF R4 +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] NEFR4A +!> \verbatim +!> NEFR4A is type(mqc_nef_r4) +!> The first MQC NEF R4 to be contracted. +!> \endverbatim +!> +!> \param[in] NEFR4B +!> \verbatim +!> NEFR4B is type(mqc_nef_r4) +!> The second MQC NEF R4 to be contracted. +!> \endverbatim +!> +!> \param[in] Index1 +!> \verbatim +!> Index1 is integer(kind=int64),dimension(4),optional +!> Contain the indexes of ERIs1 to be contracted. +!> The two first integers in the object are the ones to be contracted, +!> while the two last are the one to be multiplied. +!> Ex: If Index1=[3,2,4,1], the third and second indexes of ERIs1 are contracted. +!> The fourth and first are multiplied to form the first and second indices +!> of the result matrix, respectivelly. +!> \endverbatim +!> +!> \param[in] Index2 +!> \verbatim +!> Index2 is Integer(kind=int64),dimension(4),optional +!> Contain the indexes of ERIs2 to be contracted. +!> The two first integers in the object are the ones to be contracted, +!> while the two last are the one to be multiplied. +!> +!> Ex: index1=[3,2,4,1] and index2=[2,1,4,3] +!> sum_{i,j} R4A_{pjiq} R4B_{jisr} = R4Out_{pqrs} +!> +!> \endverbatim +!> +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_nef_r4_nef_r4_partial_contraction_2nef_r4(NEFR4A,NEFR4B,index1,index2) result(NEFR4Out) +! + implicit none + type(mqc_nef_r4),intent(in)::NEFR4A,NEFR4B + integer(kind=int64),dimension(4),intent(in),optional::index1,index2 + integer(kind=int64),dimension(4)::my_index1,my_index2 + type(mqc_nef_r4)::NEFR4Out + type(MQC_SCF_Eigenvalues),Dimension(:),Allocatable::Map_Matrix_Col,Map_Matrix_Row + Integer(kind=int64)::ia,ja,ka,la,ib,jb,kb,lb,i,j,k,l,id1,id2,id3,id4 + Integer(kind=int64)::idiab,idjab,A_index,B_index,out_index,N1234 + logical::first +! + if(present(index1)) then + ia=index1(1) + ja=index1(2) + ka=index1(3) + la=index1(4) + if (ia.eq.ja) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_NEF_R4_Partial_Contraction_2R4',& + 6,'ia', ia,'ja',ja) + if (ia.eq.ka) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_NEF_R4_Partial_Contraction_2R4',& + 6,'ia', ia,'ka',ka) + if (ia.eq.la) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_NEF_R4_Partial_Contraction_2R4',& + 6,'ia', ia,'la',la) + if (ja.eq.ka) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_NEF_R4_Partial_Contraction_2R4',& + 6,'ja', ja,'ka',ka) + if (ja.eq.la) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_NEF_R4_Partial_Contraction_2R4',& + 6,'ja', ja,'la',la) + if (ka.eq.la) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_NEF_R4_Partial_Contraction_2R4',& + 6,'ka', ka,'la',la) + my_index1 = index1 + else + ia=1 + ja=2 + ka=3 + la=4 + my_index1 = [1,2,3,4] + endif + if(present(index2)) then + ib=index2(1) + jb=index2(2) + kb=index2(3) + lb=index2(4) + if (ib.eq.jb) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_NEF_R4_Partial_Contraction_2R4',& + 6,'ib', ib,'jb',jb) + if (ib.eq.kb) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_NEF_R4_Partial_Contraction_2R4',& + 6,'ib', ib,'kb',kb) + if (ib.eq.lb) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_NEF_R4_Partial_Contraction_2R4',& + 6,'ib', ib,'lb',lb) + if (jb.eq.kb) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_NEF_R4_Partial_Contraction_2R4',& + 6,'jb', jb,'kb',kb) + if (jb.eq.lb) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_NEF_R4_Partial_Contraction_2R4',& + 6,'jb', jb,'lb',lb) + if (kb.eq.lb) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_NEF_R4_Partial_Contraction_2R4',& + 6,'kb', kb,'lb',lb) + my_index2 = index2 + else + ib=1 + jb=2 + kb=3 + lb=4 + my_index2 = [1,2,3,4] + endif + if (ia.gt.4.or.ia.le.0.or.ib.gt.4.or.ib.le.0.or.& + ja.gt.4.or.ja.le.0.or.jb.gt.4.or.jb.le.0.or.& + ka.gt.4.or.ka.le.0.or.kb.gt.4.or.kb.le.0.or.& + la.gt.4.or.la.le.0.or.lb.gt.4.or.lb.le.0.) Call MQC_Error(& + 'Index out of range in MQC_NEF_R4_NEF_R4_Partial_Contraction_2R4', 6) + + if (nefr4A%blockSize(ia).ne.nefr4B%blockSize(ib).or.& + nefr4A%blockSize(ja).ne.nefr4B%blockSize(jb)) & + call mqc_error_i('NEFR4 not correctly dimensioned in mqc_nef_r4_nef_r4_contraction_2R4',6,& + 'dim1',nefr4A%blockSize(ia)-nefr4B%blockSize(ib),& + 'dim2',nefr4A%blockSize(ja)-nefr4B%blockSize(jb)) + + NEFR4Out%NumSpace_1 = NEFR4A%blockSize(ka) + NEFR4Out%NumSpace_2 = NEFR4A%blockSize(la) + NEFR4Out%NumSpace_3 = NEFR4B%blockSize(kb) + NEFR4Out%NumSpace_4 = NEFR4B%blockSize(lb) + N1234 = NEFR4Out%NumSpace_1*NEFR4Out%NumSpace_2*NEFR4Out%NumSpace_3*NEFR4Out%NumSpace_4 + write(*,*) 'Numb of entries = ',N1234 + + allocate(NEFR4Out%Main_R4(N1234)) + NEFR4Out%Map_Matrix_1 = NEFR4A%blockMap(ka) + NEFR4Out%Map_Matrix_2 = NEFR4A%blockMap(la) + NEFR4Out%Map_Matrix_3 = NEFR4B%blockMap(kb) + NEFR4Out%Map_Matrix_4 = NEFR4B%blockMap(lb) + NEFR4Out%Size_vector_alpha_1 = NEFR4A%blockSizeVec(ka,'alpha') + NEFR4Out%Size_vector_alpha_2 = NEFR4A%blockSizeVec(la,'alpha') + NEFR4Out%Size_vector_alpha_3 = NEFR4B%blockSizeVec(kb,'alpha') + NEFR4Out%Size_vector_alpha_4 = NEFR4B%blockSizeVec(lb,'alpha') + NEFR4Out%Size_vector_beta_1 = NEFR4A%blockSizeVec(ka,'beta') + NEFR4Out%Size_vector_beta_2 = NEFR4A%blockSizeVec(la,'beta') + NEFR4Out%Size_vector_beta_3 = NEFR4B%blockSizeVec(kb,'beta') + NEFR4Out%Size_vector_beta_4 = NEFR4B%blockSizeVec(lb,'beta') + + do id1 = 1, nefr4Out%blockSize(1) + do id2 = 1, nefr4Out%blockSize(2) + do id3 = 1, nefr4Out%blockSize(3) + do id4 = 1, nefr4Out%blockSize(4) + out_index = NEFR4Out%blockIndex([1,id1],[2,id2],[3,id3],[4,id4]) + first=.true. + do idiab = 1, nefr4B%blockSize(ib) + do idjab = 1, nefr4B%blockSize(jb) + A_index = NEFR4A%blockIndex([ka,id1],[la,id2],[ia,idiab],[ja,idjab]) + B_index = NEFR4B%blockIndex([kb,id3],[lb,id4],[ib,idiab],[jb,idjab]) + if(first) then + NEFR4Out%Main_R4(out_index) = & + mqc_eri_eri_partial_contraction_2eri(& + NEFR4A%Main_R4(A_index),NEFR4B%Main_R4(B_index),my_index1,my_index2) + first=.false. + else + NEFR4Out%Main_R4(out_index) = NEFR4Out%Main_R4(out_index)+& + mqc_eri_eri_partial_contraction_2eri(& + NEFR4A%Main_R4(A_index),NEFR4B%Main_R4(B_index),my_index1,my_index2) + end if + end do + end do + end do + end do + end do + end do +! + end function mqc_nef_r4_nef_r4_partial_contraction_2nef_r4 +! +! +! PROCEDURE MQC_NEF_R4_ERI_Partial_Contraction_2R4 +! +!> \brief MQC_NEF_R4_ERI_Contraction_2R4 is used to return the contraction of +!> MQC NEF R4 with a MQC 2ERI +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEF_R4_ERI_Contraction_2R4 is used to return the contraction of +!> MQC NEF R4 with a MQC ERI +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] NEFR4A +!> \verbatim +!> NEFR4A is type(mqc_nef_r4) +!> The first MQC NEF R4 to be contracted. +!> \endverbatim +!> +!> \param[in] ERIB +!> \verbatim +!> ERIB is type(mqc_twoeris) +!> The second MQC 2ERI to be contracted. +!> \endverbatim +!> +!> \param[in] Index1 +!> \verbatim +!> Index1 is integer(kind=int64),dimension(4),optional +!> Contain the indexes of ERIs1 to be contracted. +!> The two first integers in the object are the ones to be contracted, +!> while the two last are the one to be multiplied. +!> Ex: If Index1=[3,2,4,1], the third and second indexes of ERIs1 are contracted. +!> The fourth and first are multiplied to form the first and second indices +!> of the result matrix, respectivelly. +!> \endverbatim +!> +!> \param[in] Index2 +!> \verbatim +!> Index2 is Integer(kind=int64),dimension(4),optional +!> Contain the indexes of ERIs2 to be contracted. +!> The two first integers in the object are the ones to be contracted, +!> while the two last are the one to be multiplied. +!> +!> Ex: index1=[3,2,4,1] and index2=[2,1,4,3] +!> sum_{i,j} R4A_{pjiq} ERIB_{jisr} = R4Out_{pqrs} +!> +!> \endverbatim +!> +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_nef_r4_eri_partial_contraction_2nef_r4(NEFR4A,ERIB,index1,index2) result(NEFR4Out) +! + implicit none + type(mqc_nef_r4),intent(in)::NEFR4A + type(mqc_twoeris),intent(in)::ERIB + integer(kind=int64),dimension(4),intent(in),optional::index1,index2 + integer(kind=int64),dimension(4)::my_index1,my_index2 + type(mqc_nef_r4)::NEFR4Out + type(MQC_SCF_Eigenvalues),Dimension(:),Allocatable::Map_Matrix_Col,Map_Matrix_Row + type(mqc_scalar)::val + Integer(kind=int64)::ia,ja,ka,la,ib,jb,kb,lb,i,j,k,l,id1,id2,id3,id4 + Integer(kind=int64)::idiab,idjab,A_index,B_index,out_index,N1234 + logical::first +! + if(present(index1)) then + ia=index1(1) + ja=index1(2) + ka=index1(3) + la=index1(4) + if (ia.eq.ja) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_ERI_Partial_Contraction_2R4',& + 6,'ia', ia,'ja',ja) + if (ia.eq.ka) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_ERI_Partial_Contraction_2R4',& + 6,'ia', ia,'ka',ka) + if (ia.eq.la) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_ERI_Partial_Contraction_2R4',& + 6,'ia', ia,'la',la) + if (ja.eq.ka) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_ERI_Partial_Contraction_2R4',& + 6,'ja', ja,'ka',ka) + if (ja.eq.la) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_ERI_Partial_Contraction_2R4',& + 6,'ja', ja,'la',la) + if (ka.eq.la) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_ERI_Partial_Contraction_2R4',& + 6,'ka', ka,'la',la) + my_index1 = index1 + else + ia=1 + ja=2 + ka=3 + la=4 + my_index1 = [1,2,3,4] + endif + if(present(index2)) then + ib=index2(1) + jb=index2(2) + kb=index2(3) + lb=index2(4) + if (ib.eq.jb) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_ERI_Partial_Contraction_2R4',& + 6,'ib', ib,'jb',jb) + if (ib.eq.kb) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_ERI_Partial_Contraction_2R4',& + 6,'ib', ib,'kb',kb) + if (ib.eq.lb) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_ERI_Partial_Contraction_2R4',& + 6,'ib', ib,'lb',lb) + if (jb.eq.kb) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_ERI_Partial_Contraction_2R4',& + 6,'jb', jb,'kb',kb) + if (jb.eq.lb) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_ERI_Partial_Contraction_2R4',& + 6,'jb', jb,'lb',lb) + if (kb.eq.lb) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_ERI_Partial_Contraction_2R4',& + 6,'kb', kb,'lb',lb) + my_index2 = index2 + else + ib=1 + jb=2 + kb=3 + lb=4 + my_index2 = [1,2,3,4] + endif + if (ia.gt.4.or.ia.le.0.or.ib.gt.4.or.ib.le.0.or.& + ja.gt.4.or.ja.le.0.or.jb.gt.4.or.jb.le.0.or.& + ka.gt.4.or.ka.le.0.or.kb.gt.4.or.kb.le.0.or.& + la.gt.4.or.la.le.0.or.lb.gt.4.or.lb.le.0.) Call MQC_Error(& + 'Index out of range in MQC_NEF_R4_ERI_Partial_Contraction_2R4', 6) + + if (nefr4A%blockSize(ia).ne.1.or.nefr4A%blockSize(ja).ne.1) & + call mqc_error_i('NEFR4 not correctly dimensioned in mqc_nef_r4_eri_contraction_2R4',6,& + 'dim1',nefr4A%blockSize(ia),'dim2',nefr4A%blockSize(ja)) + if(NEFR4A%blockSize(ia,1,'alpha').ne.size(ERIB,'alpha',ib).or. & + NEFR4A%blockSize(ia,1,'beta').ne.size(ERIB,'beta',ib)) & + call mqc_error_i('NEF subspace dimensions are & + ¬ conformable in mqc_nefNEF_R4_ERI_Partial_Contraction_2R4',6,& + 'NEFR4A%blockSize(ia,1,alpha)',NEFR4A%blockSize(ia,1,'alpha'),& + 'size(ERIB,alpha,ib)',size(ERIB,'alpha',ib),& + 'NEFR4A%blockSize(ia,1,beta)',NEFR4A%blockSize(ia,1,'beta'),& + 'size(ERIB,beta,ib)',size(ERIB,'beta',ib)) + if(NEFR4A%blockSize(ja,1,'alpha').ne.size(ERIB,'alpha',jb).or. & + NEFR4A%blockSize(ja,1,'beta').ne.size(ERIB,'beta',jb)) & + call mqc_error_i('NEF subspace dimensions are & + ¬ conformable in mqc_nefNEF_R4_ERI_Partial_Contraction_2R4',6,& + 'NEFR4A%blockSize(ja,1,alpha)',NEFR4A%blockSize(ja,1,'alpha'),& + 'size(ERIB,alpha,jb)',size(ERIB,'alpha',jb),& + 'NEFR4A%blockSize(ja,1,beta)',NEFR4A%blockSize(ja,1,'beta'),& + 'size(ERIB,beta,jb)',size(ERIB,'beta',jb)) + + NEFR4Out%NumSpace_1 = NEFR4A%blockSize(ka) + NEFR4Out%NumSpace_2 = NEFR4A%blockSize(la) + NEFR4Out%NumSpace_3 = 1 + NEFR4Out%NumSpace_4 = 1 + N1234 = NEFR4Out%NumSpace_1*NEFR4Out%NumSpace_2 + + allocate(NEFR4Out%Main_R4(N1234)) + NEFR4Out%Map_Matrix_1 = NEFR4A%blockMap(ka) + NEFR4Out%Map_Matrix_2 = NEFR4A%blockMap(la) + if(allocated(NEFR4Out%Map_Matrix_3)) deallocate(NEFR4Out%Map_Matrix_3) + allocate(NEFR4Out%Map_Matrix_3(1)) + if(allocated(NEFR4Out%Map_Matrix_4)) deallocate(NEFR4Out%Map_Matrix_4) + allocate(NEFR4Out%Map_Matrix_4(1)) + call NEFR4Out%Map_Matrix_3(1)%init(size(ERIB,'alpha',kb),scalar=1,lengthBeta=size(ERIB,'beta',kb)) + call NEFR4Out%Map_Matrix_4(1)%init(size(ERIB,'alpha',lb),scalar=1,lengthBeta=size(ERIB,'beta',lb)) + do id1 = 1, size(ERIB,'alpha',kb) + val = id1 + call NEFR4Out%Map_Matrix_3(1)%put(val,id1,'alpha') + end do + do id1 = 1, size(ERIB,'beta',kb) + val = id1 + call NEFR4Out%Map_Matrix_3(1)%put(val,id1,'beta') + end do + do id1 = 1, size(ERIB,'alpha',lb) + val = id1 + call NEFR4Out%Map_Matrix_4(1)%put(val,id1,'alpha') + end do + do id1 = 1, size(ERIB,'beta',lb) + val = id1 + call NEFR4Out%Map_Matrix_4(1)%put(val,id1,'beta') + end do + + NEFR4Out%Size_vector_alpha_1 = NEFR4A%blockSizeVec(ka,'alpha') + NEFR4Out%Size_vector_alpha_2 = NEFR4A%blockSizeVec(la,'alpha') + NEFR4Out%Size_vector_beta_1 = NEFR4A%blockSizeVec(ka,'beta') + NEFR4Out%Size_vector_beta_2 = NEFR4A%blockSizeVec(la,'beta') + if(allocated(NEFR4Out%Size_vector_alpha_3)) deallocate(NEFR4Out%Size_vector_alpha_3) + allocate(NEFR4Out%Size_vector_alpha_3(1)) + if(allocated(NEFR4Out%Size_vector_alpha_4)) deallocate(NEFR4Out%Size_vector_alpha_4) + allocate(NEFR4Out%Size_vector_alpha_4(1)) + if(allocated(NEFR4Out%Size_vector_beta_3)) deallocate(NEFR4Out%Size_vector_beta_3) + allocate(NEFR4Out%Size_vector_beta_3(1)) + if(allocated(NEFR4Out%Size_vector_beta_4)) deallocate(NEFR4Out%Size_vector_beta_4) + allocate(NEFR4Out%Size_vector_beta_4(1)) + NEFR4Out%Size_vector_alpha_3(1) = size(ERIB,'alpha',kb) + NEFR4Out%Size_vector_alpha_4(1) = size(ERIB,'alpha',lb) + NEFR4Out%Size_vector_beta_3(1) = size(ERIB,'beta',kb) + NEFR4Out%Size_vector_beta_4(1) = size(ERIB,'beta',lb) + + do id1 = 1, nefr4Out%blockSize(1) + do id2 = 1, nefr4Out%blockSize(2) + first=.true. + out_index = NEFR4Out%blockIndex([1,id1],[2,id2],[3,1],[4,1]) + A_index = NEFR4A%blockIndex([ka,id1],[la,id2],[ia,1],[ja,1]) + if(first) then + NEFR4Out%Main_R4(out_index) = & + mqc_eri_eri_partial_contraction_2eri(& + NEFR4A%Main_R4(A_index),ERIB,my_index1,my_index2) + first=.false. + else + NEFR4Out%Main_R4(out_index) = NEFR4Out%Main_R4(out_index)+& + mqc_eri_eri_partial_contraction_2eri(& + NEFR4A%Main_R4(A_index),ERIB,my_index1,my_index2) + end if + end do + end do +! + end function mqc_nef_r4_eri_partial_contraction_2nef_r4 +! +! +! PROCEDURE MQC_ERI_NEF_R4_Partial_Contraction_2R4 +! +!> \brief MQC_ERI_NEF_R4_Contraction_2R4 is used to return the contraction of +!> MQC NEF R4 with a MQC 2ERI +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_ERI_NEF_R4_Contraction_2R4 is used to return the contraction of +!> MQC NEF R4 with a MQC ERI +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] ERIA +!> \verbatim +!> ERIA is type(mqc_twoeris) +!> The second MQC 2ERI to be contracted. +!> \endverbatim +!> +!> \param[in] NEFR4B +!> \verbatim +!> NEFR4B is type(mqc_nef_r4) +!> The first MQC NEF R4 to be contracted. +!> \endverbatim +!> +!> \param[in] Index1 +!> \verbatim +!> Index1 is integer(kind=int64),dimension(4),optional +!> Contain the indexes of ERIs1 to be contracted. +!> The two first integers in the object are the ones to be contracted, +!> while the two last are the one to be multiplied. +!> Ex: If Index1=[3,2,4,1], the third and second indexes of ERIs1 are contracted. +!> The fourth and first are multiplied to form the first and second indices +!> of the result matrix, respectivelly. +!> \endverbatim +!> +!> \param[in] Index2 +!> \verbatim +!> Index2 is Integer(kind=int64),dimension(4),optional +!> Contain the indexes of ERIs2 to be contracted. +!> The two first integers in the object are the ones to be contracted, +!> while the two last are the one to be multiplied. +!> +!> Ex: index1=[3,2,4,1] and index2=[2,1,4,3] +!> sum_{i,j} R4A_{pjiq} ERIB_{jisr} = R4Out_{pqrs} +!> +!> \endverbatim +!> +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_eri_nef_r4_partial_contraction_2nef_r4(ERIA,NEFR4B,index1,index2) result(NEFR4Out) +! + implicit none + type(mqc_nef_r4),intent(in)::NEFR4B + type(mqc_twoeris),intent(in)::ERIA + integer(kind=int64),dimension(4),intent(in),optional::index1,index2 + integer(kind=int64),dimension(4)::my_index1,my_index2 + type(mqc_nef_r4)::NEFR4Out + type(mqc_scalar)::val + type(MQC_SCF_Eigenvalues),Dimension(:),Allocatable::Map_Matrix_Col,Map_Matrix_Row + Integer(kind=int64)::ia,ja,ka,la,ib,jb,kb,lb,i,j,k,l,id1,id2,id3,id4 + Integer(kind=int64)::idiab,idjab,A_index,B_index,out_index,N1234 + logical::first +! + if(present(index1)) then + ia=index1(1) + ja=index1(2) + ka=index1(3) + la=index1(4) + if (ia.eq.ja) Call MQC_Error_I(& + 'Duplicated index in MQC_ERI_NEF_R4_Partial_Contraction_2R4',& + 6,'ia', ia,'ja',ja) + if (ia.eq.ka) Call MQC_Error_I(& + 'Duplicated index in MQC_ERI_NEF_R4_Partial_Contraction_2R4',& + 6,'ia', ia,'ka',ka) + if (ia.eq.la) Call MQC_Error_I(& + 'Duplicated index in MQC_ERI_NEF_R4_Partial_Contraction_2R4',& + 6,'ia', ia,'la',la) + if (ja.eq.ka) Call MQC_Error_I(& + 'Duplicated index in MQC_ERI_NEF_R4_Partial_Contraction_2R4',& + 6,'ja', ja,'ka',ka) + if (ja.eq.la) Call MQC_Error_I(& + 'Duplicated index in MQC_ERI_NEF_R4_Partial_Contraction_2R4',& + 6,'ja', ja,'la',la) + if (ka.eq.la) Call MQC_Error_I(& + 'Duplicated index in MQC_ERI_NEF_R4_Partial_Contraction_2R4',& + 6,'ka', ka,'la',la) + my_index1 = index1 + else + ia=1 + ja=2 + ka=3 + la=4 + my_index1 = [1,2,3,4] + endif + if(present(index2)) then + ib=index2(1) + jb=index2(2) + kb=index2(3) + lb=index2(4) + if (ib.eq.jb) Call MQC_Error_I(& + 'Duplicated index in MQC_ERI_NEF_R4_Partial_Contraction_2R4',& + 6,'ib', ib,'jb',jb) + if (ib.eq.kb) Call MQC_Error_I(& + 'Duplicated index in MQC_ERI_NEF_R4_Partial_Contraction_2R4',& + 6,'ib', ib,'kb',kb) + if (ib.eq.lb) Call MQC_Error_I(& + 'Duplicated index in MQC_ERI_NEF_R4_Partial_Contraction_2R4',& + 6,'ib', ib,'lb',lb) + if (jb.eq.kb) Call MQC_Error_I(& + 'Duplicated index in MQC_ERI_NEF_R4_Partial_Contraction_2R4',& + 6,'jb', jb,'kb',kb) + if (jb.eq.lb) Call MQC_Error_I(& + 'Duplicated index in MQC_ERI_NEF_R4_Partial_Contraction_2R4',& + 6,'jb', jb,'lb',lb) + if (kb.eq.lb) Call MQC_Error_I(& + 'Duplicated index in MQC_ERI_NEF_R4_Partial_Contraction_2R4',& + 6,'kb', kb,'lb',lb) + my_index2 = index2 + else + ib=1 + jb=2 + kb=3 + lb=4 + my_index2 = [1,2,3,4] + endif + if (ia.gt.4.or.ia.le.0.or.ib.gt.4.or.ib.le.0.or.& + ja.gt.4.or.ja.le.0.or.jb.gt.4.or.jb.le.0.or.& + ka.gt.4.or.ka.le.0.or.kb.gt.4.or.kb.le.0.or.& + la.gt.4.or.la.le.0.or.lb.gt.4.or.lb.le.0.) Call MQC_Error(& + 'Index out of range in MQC_ERI_NEF_R4_Partial_Contraction_2R4', 6) + + if (nefr4B%blockSize(ib).ne.1.or.nefr4B%blockSize(jb).ne.1) & + call mqc_error_i('NEFR4 not correctly dimensioned in mqc_eri_nef_r4_contraction_2R4',6,& + 'dim1',nefr4B%blockSize(ib),'dim2',nefr4B%blockSize(jb)) + if(NEFR4B%blockSize(ib,1,'alpha').ne.size(ERIA,'alpha',ia).or. & + NEFR4B%blockSize(ib,1,'beta').ne.size(ERIA,'beta',ia)) & + call mqc_error_i('NEF subspace dimensions are & + ¬ conformable in mqc_ERI_NEF_R4_Partial_Contraction_2R4',6,& + 'NEFR4B%blockSize(ib,1,alpha)',NEFR4B%blockSize(ib,1,'alpha'),& + 'size(ERIA,alpha,ia)',size(ERIA,'alpha',ia),& + 'NEFR4B%blockSize(ib,1,beta)',NEFR4B%blockSize(ib,1,'beta'),& + 'size(ERIA,beta,ia)',size(ERIA,'beta',ia)) + if(NEFR4B%blockSize(jb,1,'alpha').ne.size(ERIA,'alpha',ja).or. & + NEFR4B%blockSize(jb,1,'beta').ne.size(ERIA,'beta',ja)) & + call mqc_error_i('NEF subspace dimensions are & + ¬ conformable in mqc_ERI_NEF_R4_Partial_Contraction_2R4',6,& + 'NEFR4B%blockSize(jb,1,alpha)',NEFR4B%blockSize(jb,1,'alpha'),& + 'size(ERIA,alpha,ja)',size(ERIA,'alpha',ja),& + 'NEFR4B%blockSize(jb,1,beta)',NEFR4B%blockSize(jb,1,'beta'),& + 'size(ERIA,beta,ja)',size(ERIA,'beta',ja)) + + NEFR4Out%NumSpace_1 = 1 + NEFR4Out%NumSpace_2 = 1 + NEFR4Out%NumSpace_3 = NEFR4B%blockSize(kb) + NEFR4Out%NumSpace_4 = NEFR4B%blockSize(lb) + N1234 = NEFR4Out%NumSpace_3*NEFR4Out%NumSpace_4 + + allocate(NEFR4Out%Main_R4(N1234)) + NEFR4Out%Map_Matrix_3 = NEFR4B%blockMap(kb) + NEFR4Out%Map_Matrix_4 = NEFR4B%blockMap(lb) + if(allocated(NEFR4Out%Map_Matrix_1)) deallocate(NEFR4Out%Map_Matrix_1) + allocate(NEFR4Out%Map_Matrix_1(1)) + if(allocated(NEFR4Out%Map_Matrix_2)) deallocate(NEFR4Out%Map_Matrix_2) + allocate(NEFR4Out%Map_Matrix_2(1)) + call NEFR4Out%Map_Matrix_1(1)%init(size(ERIA,'alpha',ka),scalar=1,lengthBeta=size(ERIA,'beta',ka)) + call NEFR4Out%Map_Matrix_2(1)%init(size(ERIA,'alpha',la),scalar=1,lengthBeta=size(ERIA,'beta',la)) + do id1 = 1, size(ERIA,'alpha',ka) + val = id1 + call NEFR4Out%Map_Matrix_1(1)%put(val,id1,'alpha') + end do + do id1 = 1, size(ERIA,'beta',ka) + val = id1 + call NEFR4Out%Map_Matrix_1(1)%put(val,id1,'beta') + end do + do id1 = 1, size(ERIA,'alpha',la) + val = id1 + call NEFR4Out%Map_Matrix_2(1)%put(val,id1,'alpha') + end do + do id1 = 1, size(ERIA,'beta',la) + val = id1 + call NEFR4Out%Map_Matrix_2(1)%put(val,id1,'beta') + end do + + NEFR4Out%Size_vector_alpha_3 = NEFR4B%blockSizeVec(kb,'alpha') + NEFR4Out%Size_vector_alpha_4 = NEFR4B%blockSizeVec(lb,'alpha') + NEFR4Out%Size_vector_beta_3 = NEFR4B%blockSizeVec(kb,'beta') + NEFR4Out%Size_vector_beta_4 = NEFR4B%blockSizeVec(lb,'beta') + if(allocated(NEFR4Out%Size_vector_alpha_1)) deallocate(NEFR4Out%Size_vector_alpha_1) + allocate(NEFR4Out%Size_vector_alpha_1(1)) + if(allocated(NEFR4Out%Size_vector_alpha_2)) deallocate(NEFR4Out%Size_vector_alpha_2) + allocate(NEFR4Out%Size_vector_alpha_2(1)) + if(allocated(NEFR4Out%Size_vector_beta_1)) deallocate(NEFR4Out%Size_vector_beta_1) + allocate(NEFR4Out%Size_vector_beta_1(1)) + if(allocated(NEFR4Out%Size_vector_beta_2)) deallocate(NEFR4Out%Size_vector_beta_2) + allocate(NEFR4Out%Size_vector_beta_2(1)) + NEFR4Out%Size_vector_alpha_1(1) = size(ERIA,'alpha',ka) + NEFR4Out%Size_vector_alpha_2(1) = size(ERIA,'alpha',la) + NEFR4Out%Size_vector_beta_1(1) = size(ERIA,'beta',ka) + NEFR4Out%Size_vector_beta_2(1) = size(ERIA,'beta',la) + + do id1 = 1, nefr4Out%blockSize(3) + do id2 = 1, nefr4Out%blockSize(4) + out_index = NEFR4Out%blockIndex([1,1],[2,1],[3,id1],[4,id2]) + first=.true. + A_index = NEFR4B%blockIndex([kb,id1],[lb,id2],[ib,1],[jb,1]) + if(first) then + NEFR4Out%Main_R4(out_index) = & + mqc_eri_eri_partial_contraction_2eri(& + ERIA,NEFR4B%Main_R4(A_index),my_index1,my_index2) + first=.false. + else + NEFR4Out%Main_R4(out_index) = NEFR4Out%Main_R4(out_index)+& + mqc_eri_eri_partial_contraction_2eri(& + ERIA,NEFR4B%Main_R4(A_index),my_index1,my_index2) + end if + end do + end do +! + end function mqc_eri_nef_r4_partial_contraction_2nef_r4 +! +! +! PROCEDURE MQC_NEF_R4_NEF_R4_Partial_Contraction +! +!> \brief MQC_NEF_R4_NEF_R4_Contraction is used to return the contraction of +!> MQC NEF R4 with a MQC NEF R4 +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEF_R4_NEF_R4_Contraction is used to return the contraction of +!> MQC NEF R4 with a MQC NEF R4 +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] NEFR4A +!> \verbatim +!> NEFR4A is type(mqc_nef_r4) +!> The first MQC NEF R4 to be contracted. +!> \endverbatim +!> +!> \param[in] NEFR4B +!> \verbatim +!> NEFR4B is type(mqc_nef_r4) +!> The second MQC NEF R4 to be contracted. +!> \endverbatim +!> +!> \param[in] Index1 +!> \verbatim +!> Index1 is integer(kind=int64),dimension(4),optional +!> Contain the indexes of ERIs1 to be contracted. +!> The two first integers in the object are the ones to be contracted, +!> while the two last are the one to be multiplied. +!> Ex: If Index1=[3,2,4,1], the third and second indexes of ERIs1 are contracted. +!> The fourth and first are multiplied to form the first and second indices +!> of the result matrix, respectivelly. +!> \endverbatim +!> +!> \param[in] Index2 +!> \verbatim +!> Index2 is Integer(kind=int64),dimension(4),optional +!> Contain the indexes of ERIs2 to be contracted. +!> The two first integers in the object are the ones to be contracted, +!> while the two last are the one to be multiplied. +!> +!> Ex: index1=[3,2,4,1] and index2=[2,1,4,3] +!> sum_{i,j} R4A_{ljik} R4B_{jilk} = MatOut_{kl} +!> +!> \endverbatim +!> +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_nef_r4_nef_r4_partial_contraction(NEFR4A,NEFR4B,index1,index2) result(MatOut) +! + implicit none + type(mqc_nef_r4),intent(in)::NEFR4A,NEFR4B + integer(kind=int64),dimension(4),intent(in),optional::index1,index2 + integer(kind=int64),dimension(4)::my_index1,my_index2 + type(mqc_nef_matrix)::MatOut + type(MQC_SCF_Eigenvalues),Dimension(:),Allocatable::Map_Matrix_Col,Map_Matrix_Row + Integer(kind=int64)::ia,ja,ka,la,ib,jb,kb,lb,i,j,k,l,id1,id2,id3,id4,mat_index +! + if(present(index1)) then + ia=index1(1) + ja=index1(2) + ka=index1(3) + la=index1(4) + if (ia.eq.ja) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_NEF_R4_Partial_Contraction',& + 6,'ia', ia,'ja',ja) + if (ia.eq.ka) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_NEF_R4_Partial_Contraction',& + 6,'ia', ia,'ka',ka) + if (ia.eq.la) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_NEF_R4_Partial_Contraction',& + 6,'ia', ia,'la',la) + if (ja.eq.ka) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_NEF_R4_Partial_Contraction',& + 6,'ja', ja,'ka',ka) + if (ja.eq.la) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_NEF_R4_Partial_Contraction',& + 6,'ja', ja,'la',la) + if (ka.eq.la) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_NEF_R4_Partial_Contraction',& + 6,'ka', ka,'la',la) + my_index1 = index1 + else + ia=1 + ja=2 + ka=3 + la=4 + my_index1 = [1,2,3,4] + endif + if(present(index2)) then + ib=index2(1) + jb=index2(2) + kb=index2(3) + lb=index2(4) + if (ib.eq.jb) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_NEF_R4_Partial_Contraction',& + 6,'ib', ib,'jb',jb) + if (ib.eq.kb) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_NEF_R4_Partial_Contraction',& + 6,'ib', ib,'kb',kb) + if (ib.eq.lb) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_NEF_R4_Partial_Contraction',& + 6,'ib', ib,'lb',lb) + if (jb.eq.kb) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_NEF_R4_Partial_Contraction',& + 6,'jb', jb,'kb',kb) + if (jb.eq.lb) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_NEF_R4_Partial_Contraction',& + 6,'jb', jb,'lb',lb) + if (kb.eq.lb) Call MQC_Error_I(& + 'Duplicated index in MQC_NEF_R4_NEF_R4_Partial_Contraction',& + 6,'kb', kb,'lb',lb) + my_index2 = index2 + else + ib=1 + jb=2 + kb=3 + lb=4 + my_index2 = [1,2,3,4] + endif + if (ia.gt.4.or.ia.le.0.or.ib.gt.4.or.ib.le.0.or.& + ja.gt.4.or.ja.le.0.or.jb.gt.4.or.jb.le.0.or.& + ka.gt.4.or.ka.le.0.or.kb.gt.4.or.kb.le.0.or.& + la.gt.4.or.la.le.0.or.lb.gt.4.or.lb.le.0.) Call MQC_Error(& + 'Index out of range in MQC_NEF_R4_NEF_R4_Partial_Contraction', 6) + + if (nefr4A%blockSize(ia).ne.nefr4B%blockSize(ib).or.& + nefr4A%blockSize(ja).ne.nefr4B%blockSize(jb).or.& + nefr4A%blockSize(ka).ne.nefr4B%blockSize(kb).or.& + nefr4A%blockSize(la).ne.nefr4B%blockSize(lb))& + call mqc_error_i('NEFR4 not correctly dimensioned in mqc_nef_r4_nef_r4_contraction',6,& + 'dim1',nefr4A%blockSize(ia)-nefr4B%blockSize(ib),& + 'dim2',nefr4A%blockSize(ja)-nefr4B%blockSize(jb),& + 'dim3',nefr4A%blockSize(ka)-nefr4B%blockSize(kb),& + 'dim4',nefr4A%blockSize(la)-nefr4B%blockSize(lb)) + + Map_Matrix_Col = NEFR4A%blockMap(la) + Map_Matrix_Row = NEFR4A%blockMap(ka) + call MatOut%init(Map_Matrix_Row,initial_map_matrix_col=Map_Matrix_Col) + do id3 = 1, nefr4A%blockSize(ka) + do id4 = 1, nefr4A%blockSize(la) + mat_index = MatOut%blockIndex([1,id3],[2,id4]) + do id1 = 1, nefr4A%blockSize(ia) + do id2 = 1, nefr4A%blockSize(ja) + MatOut%Main_Matrix(mat_index) = MatOut%Main_Matrix(mat_index) +& + partialcontraction(NEFR4A%Main_R4(NEFR4A%blockIndex([ka,id3],[la,id4],[ia,id1],[ja,id2])),& + NEFR4B%Main_R4(NEFR4B%blockIndex([kb,id3],[lb,id4],[ib,id1],[jb,id2])),my_index1,my_index2) + end do + end do + end do + end do +! + end function mqc_nef_r4_nef_r4_partial_contraction +! +! +! PROCEDURE MQC_NEF_R4_Dimension +! +!> \brief MQC_NEF_R4_Dimension is a function that returns the length of a spin +!> block axis of an MQC NEF R4 object +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEF_R4_Dimension is a function that returns the length of a spin block axis +!> of an MQC NEF R4 object. The required argument label specifies which block is queried. +!> The optional arguments axis, subaxis and spin specifies which dimension is returned. +!> The following options are available: +!> +!> 1. Axis = '1' selects the first dimension (default). +!> 2. Axis = '2' selects the second dimension. +!> 3. Axis = '3' selects the third dimension. +!> 4. Axis = '4' selects the fourth dimension. +!> +!> 1. .not.present(SubAxis) returns the dimension of sub-spaces in (default). +!> 2. SubAxis = 'n' selects the n-th dimension of sub-spaces in . +!> +!> 1. Spin = returns the 'alpha' dimension of the n-th dimension of sub-spaces in (default). +!> 2. Spin = returns the 'beta' dimension of the n-th dimension of sub-spaces in . +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in,out] NEFR4 +!> \verbatim +!> NEFR4 is Class(MQC_NEF_R4) +!> The name of the MQC NEF R4 variable. +!> \endverbatim +!> +!> \param[in] Axis +!> \verbatim +!> Axis is Integer(kind=int64),Optional +!> The spin block axis to return. +!> = 1: number of first dimension (default). +!> = 2: number of second dimension. +!> = 3: number of third dimension. +!> = 4: number of fourth dimension. +!> \endverbatim +!> +!> \param[in] SubAxis +!> \verbatim +!> SubAxis is Integer(kind=int64),Optional +!> .not.present(SubAxis) returns the dimension of sub-spaces in (default). +!> SubAxis = 'n' selects the n-th dimension of sub-spaces in . +!> \endverbatim +!> +!> \param[in] +!> \verbatim Spin +!> Spin is Character(Len=*),optional +!> The spin block to query. +!> = 'alpha','a': alpha axis dimension. +!> = 'beta','b': beta axis dimension. +!> Returns an error if present while subaxis is not present +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_nef_r4_dimension(nefr4,axis,subaxis,spin) result(dimBlock) +! + implicit none + class(mqc_nef_r4),intent(in)::nefr4 + integer(kind=int64)::dimBlock + Character(Len=*),intent(in),optional::spin + integer(kind=int64),intent(in),optional::axis,subaxis + Character(Len=64)::my_spin + integer(kind=int64)::my_axis,my_sub_axis + logical::do_sub +! + if(present(axis)) then + my_axis = axis + else + my_axis = 1 + endIf + if(my_axis.le.0.or.my_axis.gt.4) & + call mqc_error_I('Unknown axis specified in MQC_NEF_R4_Dimension',6,'my_axis',my_axis) + + if(present(subaxis)) then + my_sub_axis = subaxis + do_sub=.true. + else + do_sub=.false. + endIf + if(present(spin)) then + if (.not.do_sub) & + call mqc_error('Spin specified without subaxis in MQC_NEF_R4_Dimension',6) + call string_change_case(spin,'l',my_spin) + end if + + if (do_sub) then + select case(my_spin) + case('alpha','a') + if(my_axis.eq.1) then + if (my_sub_axis.gt.NEFR4%NumSpace_1) & + call mqc_error_I('Subaxis out of bounds in MQC_NEF_R4_Dimension',6,& + 'NEFR4%NumSpace_1',NEFR4%NumSpace_1,'my_sub_axis',my_sub_axis) + dimBlock = NEFR4%Size_vector_alpha_1(my_sub_axis) + else if(my_axis.eq.2) then + if (my_sub_axis.gt.NEFR4%NumSpace_2) & + call mqc_error_I('Subaxis out of bounds in MQC_NEF_R4_Dimension',6,& + 'NEFR4%NumSpace_2',NEFR4%NumSpace_2,'my_sub_axis',my_sub_axis) + dimBlock = NEFR4%Size_vector_alpha_2(my_sub_axis) + else if(my_axis.eq.3) then + if (my_sub_axis.gt.NEFR4%NumSpace_3) & + call mqc_error_I('Subaxis out of bounds in MQC_NEF_R4_Dimension',6,& + 'NEFR4%NumSpace_3',NEFR4%NumSpace_3,'my_sub_axis',my_sub_axis) + dimBlock = NEFR4%Size_vector_alpha_3(my_sub_axis) + else if(my_axis.eq.4) then + if (my_sub_axis.gt.NEFR4%NumSpace_4) & + call mqc_error_I('Subaxis out of bounds in MQC_NEF_R4_Dimension',6,& + 'NEFR4%NumSpace_4',NEFR4%NumSpace_4,'my_sub_axis',my_sub_axis) + dimBlock = NEFR4%Size_vector_alpha_4(my_sub_axis) + end if + case('beta','b') + if(my_axis.eq.1) then + if (my_sub_axis.gt.NEFR4%NumSpace_1) & + call mqc_error_I('Subaxis out of bounds in MQC_NEF_R4_Dimension',6,& + 'NEFR4%NumSpace_1',NEFR4%NumSpace_1,'my_sub_axis',my_sub_axis) + dimBlock = NEFR4%Size_vector_beta_1(my_sub_axis) + else if(my_axis.eq.2) then + if (my_sub_axis.gt.NEFR4%NumSpace_2) & + call mqc_error_I('Subaxis out of bounds in MQC_NEF_R4_Dimension',6,& + 'NEFR4%NumSpace_2',NEFR4%NumSpace_2,'my_sub_axis',my_sub_axis) + dimBlock = NEFR4%Size_vector_beta_2(my_sub_axis) + else if(my_axis.eq.3) then + if (my_sub_axis.gt.NEFR4%NumSpace_3) & + call mqc_error_I('Subaxis out of bounds in MQC_NEF_R4_Dimension',6,& + 'NEFR4%NumSpace_3',NEFR4%NumSpace_3,'my_sub_axis',my_sub_axis) + dimBlock = NEFR4%Size_vector_beta_3(my_sub_axis) + else if(my_axis.eq.4) then + if (my_sub_axis.gt.NEFR4%NumSpace_4) & + call mqc_error_I('Subaxis out of bounds in MQC_NEF_R4_Dimension',6,& + 'NEFR4%NumSpace_4',NEFR4%NumSpace_4,'my_sub_axis',my_sub_axis) + dimBlock = NEFR4%Size_vector_beta_4(my_sub_axis) + end if + case default + call mqc_error_A('Spin label not valid in mqc_nef_r4_dimension', 6, & + 'my_spin', my_spin ) + end select + else + if(my_axis.eq.1) then + dimBlock = NEFR4%NumSpace_1 + else if(my_axis.eq.2) then + dimBlock = NEFR4%NumSpace_2 + else if(my_axis.eq.3) then + dimBlock = NEFR4%NumSpace_3 + else if(my_axis.eq.4) then + dimBlock = NEFR4%NumSpace_4 + end if + end if +! + end function mqc_nef_r4_dimension +! +! +! PROCEDURE MQC_NEF_R4_Dimension_vector +! +!> \brief MQC_NEF_R4_Dimension is a function that returns the size_vector_spin of a +!> block axis of an MQC NEF R4 object +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEF_R4_Dimension is a function that returns the size_vector_spin block axis +!> of an MQC NEF R4 object. The required argument label specifies which block is queried. +!> The optional arguments axis, subaxis and spin specifies which dimension is returned. +!> The following options are available: +!> +!> 1. Axis = '1' selects the first dimension (default). +!> 2. Axis = '2' selects the second dimension. +!> 3. Axis = '3' selects the third dimension. +!> 4. Axis = '4' selects the fourth dimension. +!> +! +! Arguments: +! ========== +!> \param[in,out] NEFR4 +!> \verbatim +!> NEFR4 is Class(MQC_NEF_R4) +!> The name of the MQC NEF R4 variable. +!> \endverbatim +!> +!> \param[in] Axis +!> \verbatim +!> Axis is Integer(kind=int64),Optional +!> The spin block axis to return. +!> = 1: number of first dimension (default). +!> = 2: number of second dimension. +!> = 3: number of third dimension. +!> = 4: number of fourth dimension. +!> \endverbatim +!> +!> \param[in] +!> \verbatim Spin +!> Spin is Character(Len=*),optional +!> The spin block to query. +!> = 'alpha': alpha axis dimension. +!> = 'beta': beta axis dimension. +!> Returns an error if present while subaxis is not present +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_nef_r4_dimension_vector(nefr4,axis,spin) result(dimVec) +! + implicit none + class(mqc_nef_r4),intent(in)::nefr4 + integer,dimension(:),allocatable::dimVec + Character(Len=*),intent(in),optional::spin + integer(kind=int64),intent(in),optional::axis + Character(Len=64)::my_spin + integer(kind=int64)::my_axis,my_sub_axis + logical::do_sub=.false. +! + if(present(axis)) then + my_axis = axis + else + my_axis = 1 + endIf + if(my_axis.le.0.or.my_axis.gt.4) & + call mqc_error_I('Unknown axis specified in MQC_NEF_R4_Dimension',6,'my_axis',my_axis) + if(present(spin)) then + my_spin = spin + else + my_spin = 'alpha' + endIf + + select case(my_spin) + case('alpha') + if(my_axis.eq.1) dimVec = NEFR4%Size_vector_alpha_1 + if(my_axis.eq.2) dimVec = NEFR4%Size_vector_alpha_2 + if(my_axis.eq.3) dimVec = NEFR4%Size_vector_alpha_3 + if(my_axis.eq.4) dimVec = NEFR4%Size_vector_alpha_4 + case('beta') + if(my_axis.eq.1) dimVec = NEFR4%Size_vector_beta_1 + if(my_axis.eq.2) dimVec = NEFR4%Size_vector_beta_2 + if(my_axis.eq.3) dimVec = NEFR4%Size_vector_beta_3 + if(my_axis.eq.4) dimVec = NEFR4%Size_vector_beta_4 + case default + call mqc_error_A('Unknown spin specified in MQC_NEF_R4_Dimension',6,'my_spin',my_spin) + end select +! + end function mqc_nef_r4_dimension_vector +! +! +! PROCEDURE MQC_NEF_R4_Map +! +!> \brief MQC_NEF_R4_Map is a function that returns the Map_Matrix +!> of an MQC NEF R4 object +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEF_R4_Map is a function that returns the Map_Matrix +!> of an MQC NEF R4 object +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in,out] NEFR4 +!> \verbatim +!> NEFR4 is Class(MQC_NEF_R4) +!> The name of the MQC NEF R4 variable. +!> \endverbatim +!> +!> \param[in] Axis +!> \verbatim +!> Axis is Integer(kind=int64),Optional +!> The spin block axis to return. +!> = 1: number of first dimension (default). +!> = 2: number of second dimension. +!> = 3: number of third dimension. +!> = 4: number of fourth dimension. +!> \endverbatim +!> +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_nef_r4_map(nefr4,axis) result(MapOut) +! + implicit none + class(mqc_nef_r4),intent(in)::nefr4 + type(MQC_SCF_Eigenvalues),Dimension(:),Allocatable::MapOut + integer(kind=int64),intent(in),optional::axis + integer(kind=int64)::my_axis +! + if(present(axis)) then + my_axis = axis + else + my_axis = 1 + endIf + if(my_axis.le.0.or.my_axis.gt.4) & + call mqc_error_I('Unknown axis specified in MQC_NEF_R4_Dimension',6,'my_axis',my_axis) + + if(my_axis.eq.1) then + MapOut = NEFR4%Map_Matrix_1 + else if(my_axis.eq.2) then + MapOut = NEFR4%Map_Matrix_2 + else if(my_axis.eq.3) then + MapOut = NEFR4%Map_Matrix_3 + else if(my_axis.eq.4) then + MapOut = NEFR4%Map_Matrix_4 + end if +! + end function mqc_nef_r4_map +! +! +! PROCEDURE MQC_NEF_R4_Index +! +!> \brief MQC_NEF_R4_Index is a function that returns the main index +!> of an MQC NEF R4 object based on sub-indexes +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEF_R4_Index is a function that returns the main index +!> of an MQC NEF R4 object based on sub-indexes. This function is used when +!> the main index is required, but the order of the axis is variable. +!> +!> Example: given the four sets: +!> set1 = [1,4]; set2 = [3,1]; set3 = [4,10] and set4 = [2,3] +!> This function returns the correspondent combined-index for ERI(4,3,1,10) +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in,out] NEFR4 +!> \verbatim +!> NEFR4 is Class(MQC_NEF_R4) +!> The name of the MQC NEF R4 variable. +!> \endverbatim +!> +!> \param[in] set1 +!> \verbatim +!> set1 is Integer(kind=int64),dimension(2) +!> A set containing axis and sub-axis-index. +!> \endverbatim +!> +!> \param[in] set2 +!> \verbatim +!> set2 is Integer(kind=int64),dimension(2) +!> A set containing axis and sub-axis-index. +!> \endverbatim +!> +!> \param[in] set3 +!> \verbatim +!> set3 is Integer(kind=int64),dimension(2) +!> A set containing axis and sub-axis-index. +!> \endverbatim +!> +!> \param[in] set4 +!> \verbatim +!> set4 is Integer(kind=int64),dimension(2) +!> A set containing axis and sub-axis-index. +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_nef_r4_index(nefr4,set1,set2,set3,set4) result(indexOut) +! + implicit none + class(mqc_nef_r4),intent(in)::nefr4 + integer(kind=int64),dimension(2),intent(in)::set1,set2,set3,set4 + integer(kind=int64)::indexOut + integer(kind=int64)::id1,id2,id3,id4 + integer(kind=int64)::N1,N12,N123,N1234 +! + if (set1(1).le.0.or.set1(1).gt.4) call mqc_error_i(& + 'Index out-of-bounds in mqc_nef_r4_index',6,& + 'set1(1)',set1(1)) + if (set2(1).le.0.or.set2(1).gt.4) call mqc_error_i(& + 'Index out-of-bounds in mqc_nef_r4_index',6,& + 'set2(1)',set2(1)) + if (set3(1).le.0.or.set3(1).gt.4) call mqc_error_i(& + 'Index out-of-bounds in mqc_nef_r4_index',6,& + 'set3(1)',set3(1)) + if (set4(1).le.0.or.set4(1).gt.4) call mqc_error_i(& + 'Index out-of-bounds in mqc_nef_r4_index',6,& + 'set4(1)',set4(1)) + + id1=-1 + id2=-1 + id3=-1 + id4=-1 + + if (set1(1).eq.1) id1 = set1(2) + if (set2(1).eq.1) then + if (id1.gt.0) call mqc_error(& + 'Axis 1 index defined more than once in mqc_nef_r4_index',6) + id1 = set2(2) + endIf + if (set3(1).eq.1) then + if (id1.gt.0) call mqc_error(& + 'Axis 1 index defined more than once in mqc_nef_r4_index',6) + id1 = set3(2) + endIf + if (set4(1).eq.1) then + if (id1.gt.0) call mqc_error(& + 'Axis 1 index defined more than once in mqc_nef_r4_index',6) + id1 = set4(2) + endIf + if (set1(1).eq.2) id2 = set1(2) + if (set2(1).eq.2) then + if (id2.gt.0) call mqc_error(& + 'Axis 2 index defined more than once in mqc_nef_r4_index',6) + id2 = set2(2) + endIf + if (set3(1).eq.2) then + if (id2.gt.0) call mqc_error(& + 'Axis 2 index defined more than once in mqc_nef_r4_index',6) + id2 = set3(2) + endIf + if (set4(1).eq.2) then + if (id2.gt.0) call mqc_error(& + 'Axis 2 index defined more than once in mqc_nef_r4_index',6) + id2 = set4(2) + endIf + if (set1(1).eq.3) id3 = set1(2) + if (set2(1).eq.3) then + if (id3.gt.0) call mqc_error(& + 'Axis 3 index defined more than once in mqc_nef_r4_index',6) + id3 = set2(2) + endIf + if (set3(1).eq.3) then + if (id3.gt.0) call mqc_error(& + 'Axis 3 index defined more than once in mqc_nef_r4_index',6) + id3 = set3(2) + endIf + if (set4(1).eq.3) then + if (id3.gt.0) call mqc_error(& + 'Axis 3 index defined more than once in mqc_nef_r4_index',6) + id3 = set4(2) + endIf + if (set1(1).eq.4) id4 = set1(2) + if (set2(1).eq.4) then + if (id4.gt.0) call mqc_error(& + 'Axis 4 index defined more than once in mqc_nef_r4_index',6) + id4 = set2(2) + endIf + if (set3(1).eq.4) then + if (id4.gt.0) call mqc_error(& + 'Axis 4 index defined more than once in mqc_nef_r4_index',6) + id4 = set3(2) + endIf + if (set4(1).eq.4) then + if (id4.gt.0) call mqc_error(& + 'Axis 4 index defined more than once in mqc_nef_r4_index',6) + id4 = set4(2) + endIf + N1 = NEFR4%NumSpace_4 + N12 = N1*NEFR4%NumSpace_3 + N123 = N12*NEFR4%NumSpace_2 + N1234 = N123*NEFR4%NumSpace_1 + indexOut = (id1-1)*N123+(id2-1)*N12+(id3-1)*N1+id4 + !write(*,*) 'Sets = ', set1,set2,set3,set4 + !write(*,*) 'indexIn = ', id1,id2,id3,id4 + !write(*,*) 'indexOut = ', indexOut +! + end function mqc_nef_r4_index +! +! +! PROCEDURE MQC_NEF_Matrix_Index +! +!> \brief MQC_NEF_Matrix_Index is a function that returns the main index +!> of an MQC NEF Matrix object based on sub-indexes +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEF_Matrix_Index is a function that returns the main index +!> of an MQC NEF Matrix object based on sub-indexes. This function is used when +!> the main index is required, but the order of the axis is variable. +!> +!> Example: given the four sets: +!> set1 = [2,4]; set2 = [1,2] +!> This function returns the correspondent combined-index for ERI(2,4) +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in,out] NEFMat +!> \verbatim +!> NEFMat is Class(MQC_NEF_Matrix) +!> The name of the MQC NEF Matrix variable. +!> \endverbatim +!> +!> \param[in] set1 +!> \verbatim +!> set1 is Integer(kind=int64),dimension(2) +!> A set containing axis and sub-axis-index. +!> \endverbatim +!> +!> \param[in] set2 +!> \verbatim +!> set2 is Integer(kind=int64),dimension(2) +!> A set containing axis and sub-axis-index. +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_nef_matrix_index(nefmat,set1,set2) result(indexOut) +! + implicit none + class(mqc_nef_matrix),intent(in)::nefmat + integer(kind=int64),dimension(2),intent(in)::set1,set2 + integer(kind=int64)::indexOut + integer(kind=int64)::id1,id2 +! + if (set1(1).le.0.or.set1(1).gt.4) call mqc_error_i(& + 'Index out-of-bounds in mqc_nefmatrix_index',6,& + 'set1(1)',set1(1)) + if (set2(1).le.0.or.set2(1).gt.4) call mqc_error_i(& + 'Index out-of-bounds in mqc_nefmatrix_index',6,& + 'set2(1)',set2(1)) + + id1=-1 + id2=-1 + + if (set1(1).eq.1) id1 = set1(2) + if (set2(1).eq.1) then + if (id1.gt.0) call mqc_error(& + 'Axis 1 index defined more than once in mqc_nefmatrix_index',6) + id1 = set2(2) + endIf + if (set1(1).eq.2) id2 = set1(2) + if (set2(1).eq.2) then + if (id2.gt.0) call mqc_error(& + 'Axis 2 index defined more than once in mqc_nefmatrix_index',6) + id2 = set2(2) + endIf + indexOut = (id1-1)*NEFMat%NumSpace_col+id2 + !write(*,*) 'Sets = ', set1,set2 + !write(*,*) 'indexIn = ', id1,id2 + !write(*,*) 'indexOut = ', indexOut +! + end function mqc_nef_matrix_index +! +! +! +! PROCEDURE MQC_NEF_Matrix_At +! +!> \brief MQC_NEF_Matrix_At is a function that returns the value of an element +!> of a MQC NEF Matrix variable +!> +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEF_Matrix_At is a function that returns the value of (I,J)th element of a +!> (p,q) block of a MQC NEF Matrix variable as an MQC scalar. +!> Optional argument SpinBlock specifies the spin block of MQC NEF Matrix. +!> are available: +!> +!> 1. SpinBlock = 'alpha' uses the alpha spin block. +!> 2. SpinBlock = 'beta' uses the beta spin block. +!> 3. SpinBlock = 'alphaBeta' uses the alpha-beta spin block. +!> 4. SpinBlock = 'betaAlpha' uses the beta-alpha spin block. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] nefM +!> \verbatim +!> nefM is Class(MQC_NEF_Matrix) +!> The MQC NEF Matrix to return the value of the (I,J)th for block (p,q) +!> element. +!> \endverbatim +!> +!> \param[in] I +!> \verbatim +!> I is Integer(kind=int64) +!> The first dimension of the element in MQC NEF Matrix +!> If I>0 row count is from first index +!> \endverbatim +!> +!> \param[in] J +!> \verbatim +!> J is Integer(kind=int64) +!> The second dimension of the element in MQC NEF Matrix +!> If J>0 col count is from first index +!> \endverbatim +!> +!> \param[in] p +!> \verbatim +!> p is Integer(kind=int64) +!> The first excitation dimension of the element in MQC NEF Matrix +!> If p>0 row count is from first index +!> \endverbatim +!> +!> \param[in] q +!> \verbatim +!> q is Integer(kind=int64) +!> The second excitation dimension of the element in MQC NEF Matrix +!> If q>0 row count is from first index +!> \endverbatim +!> +!> \param[in] spinBlockIn +!> \verbatim +!> spinBlockIn is Character(Len=*),Optional +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_nef_matrix_at(nefM,i,j,p,q,spinBlockIn) result(element) +! + implicit none + class(mqc_nef_matrix)::nefM + class(*),intent(in)::i,j,p,q + integer(kind=int64)::myI,myJ,myp,myq + type(mqc_scalar)::element + character(len=*),optional,intent(in)::spinBlockIn + character(len=64)::spinBlock + real(kind=real64)::zero=0.0d0 +! + element = zero + select type (i) + type is (integer) + myI = i + type is (mqc_scalar) + myI = i + class default + call mqc_error('index type not defined in MQC_NEF_Matrix_at') + end select + select type (j) + type is (integer) + myJ = j + type is (mqc_scalar) + myJ = j + class default + call mqc_error('index type not defined in MQC_NEF_Matrix_at') + end select + select type (p) + type is (integer) + myp = p + type is (mqc_scalar) + myp = p + class default + call mqc_error('index type not defined in MQC_NEF_Matrix_at') + end select + select type (q) + type is (integer) + myq = q + type is (mqc_scalar) + myq = q + class default + call mqc_error('index type not defined in MQC_NEF_Matrix_at') + end select +! + if(myp.gt.nefM%NumSpace_row) & + call mqc_error('Requested p dimension out of bounds in mqc_NEF_Matrix_at') + if(myq.gt.nefM%NumSpace_col) & + call mqc_error('Requested q dimension out of bounds in mqc_NEF_Matrix_at') + if(myI.gt.(nefM%Size_vector_alpha_row(myp)+nefM%Size_vector_beta_row(myp))) & + call mqc_error('Requested I dimension out of bounds in mqc_NEF_Matrix_at') + if(myJ.gt.(nefM%Size_vector_alpha_col(myq)+nefM%Size_vector_beta_col(myq))) & + call mqc_error('Requested J dimension out of bounds in mqc_NEF_Matrix_at') +! + if(present(spinBlockIn)) then + call string_change_case(spinBlockIn,'L',spinBlock) + else + spinBlock = 'alpha' + end if + element = nefM%Main_Matrix(nefM%blockIndex([1,myp],[2,myq]))%at(myI,myJ,spinBlock) +! + end function mqc_nef_matrix_at +! +! +! +! PROCEDURE MQC_NEF_R4_At +! +!> \brief MQC_NEF_R4_At is a function that returns the value of an element +!> of a MQC NEF R4 variable +!> +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEF_R4_At is a function that returns the value of (I,J,K,L)th element of a +!> (p,q,r,s) block of a MQC NEF R4 variable as an MQC scalar. +!> Optional argument SpinBlock specifies the spin block of MQC NEF R4. +!> Each index is represented by a set = [dI,I,p,s], where s is 1 for alpha or -1 for beta +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] nefR4 +!> \verbatim +!> nefR4 is Class(MQC_NEF_R4) +!> The MQC NEF R4 to return the value +!> element. +!> \endverbatim +!> +!> \param[in] Set1 +!> \verbatim +!> set1 is Integer(kind=int64),dimension(4) +!> A set containing axis, sub-axis-index, orbital and spin. +!> \endverbatim +!> +!> \param[in] Set2 +!> \verbatim +!> set2 is Integer(kind=int64),dimension(4) +!> A set containing axis, sub-axis-index, orbital and spin. +!> \endverbatim +!> +!> \param[in] Set3 +!> \verbatim +!> set3 is Integer(kind=int64),dimension(4) +!> A set containing axis, sub-axis-index, orbital and spin. +!> \endverbatim +!> +!> \param[in] Set4 +!> \verbatim +!> set4 is Integer(kind=int64),dimension(4) +!> A set containing axis, sub-axis-index, orbital and spin. +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_nef_r4_at(nefR4,set1,set2,set3,set4) result(element) +! + implicit none + class(mqc_nef_r4)::nefR4 + Integer(kind=int64),dimension(4),intent(in)::set1,set2,set3,set4 + integer(kind=int64)::I,J,K,L,myp,myq,myr,mys,sp,sq,sr,ss,id1,id2,id3,id4 + integer(kind=int64)::dI,dJ,dK,dL,r,s,p,q + type(mqc_scalar)::element + character(len=1)::sI,sJ,sK,sL + character(len=4)::spinBlock + real(kind=real64)::zero=0.0d0 +! + element = zero +! + dI = set1(1) + dJ = set2(1) + dK = set3(1) + dL = set4(1) + I = set1(2) + J = set2(2) + K = set3(2) + L = set4(2) + p = set1(3) + q = set2(3) + r = set3(3) + s = set4(3) + sp = set1(4) + sq = set2(4) + sr = set3(4) + ss = set4(4) +! + if (dI.le.0.or.dI.gt.4) call mqc_error_i(& + 'Index out-of-bounds in mqc_nef_r4_index',6,'dI',dI) + if (dJ.le.0.or.dJ.gt.4) call mqc_error_i(& + 'Index out-of-bounds in mqc_nef_r4_index',6,'dJ',dJ) + if (dK.le.0.or.dK.gt.4) call mqc_error_i(& + 'Index out-of-bounds in mqc_nef_r4_index',6,'dK',dK) + if (dL.le.0.or.dL.gt.4) call mqc_error_i(& + 'Index out-of-bounds in mqc_nef_r4_index',6,'dL',dL) +! + if (dI.eq.dJ) call mqc_error_i(& + 'Duplicated index in mqc_nef_r4_index',6,'dI',dI,'dJ',dJ) + if (dI.eq.dK) call mqc_error_i(& + 'Duplicated index in mqc_nef_r4_index',6,'dI',dI,'dK',dK) + if (dI.eq.dL) call mqc_error_i(& + 'Duplicated index in mqc_nef_r4_index',6,'dI',dI,'dL',dL) + if (dJ.eq.dK) call mqc_error_i(& + 'Duplicated index in mqc_nef_r4_index',6,'dJ',dJ,'dK',dK) + if (dJ.eq.dL) call mqc_error_i(& + 'Duplicated index in mqc_nef_r4_index',6,'dJ',dJ,'dL',dL) + if (dK.eq.dL) call mqc_error_i(& + 'Duplicated index in mqc_nef_r4_index',6,'dK',dK,'dL',dL) +! + if(I.gt.nefR4%blockSize(dI)) & + call mqc_error('Requested I dimension out of bounds in mqc_NEF_R4_at') + if(J.gt.nefR4%blockSize(dJ)) & + call mqc_error('Requested J dimension out of bounds in mqc_NEF_R4_at') + if(K.gt.nefR4%blockSize(dK)) & + call mqc_error('Requested K dimension out of bounds in mqc_NEF_R4_at') + if(L.gt.nefR4%blockSize(dL)) & + call mqc_error('Requested L dimension out of bounds in mqc_NEF_R4_at') +! + if (sp.eq.-1) then + sI = 'b' + else if (sp.eq.1) then + sI = 'a' + else + call mqc_error_i('Requested I spin not recognized in mqc_NEF_R4_at',6,& + 'sp',sp) + end if + if (sq.eq.-1) then + sJ = 'b' + else if (sq.eq.1) then + sJ = 'a' + else + call mqc_error_i('Requested K spin not recognized in mqc_NEF_R4_at',6,& + 'sq',sq) + end if + if (sr.eq.-1) then + sK = 'b' + else if (sr.eq.1) then + sK = 'a' + else + call mqc_error_i('Requested K spin not recognized in mqc_NEF_R4_at',6,& + 'sr',sr) + end if + if (ss.eq.-1) then + sL = 'b' + else if (ss.eq.1) then + sL = 'a' + else + call mqc_error_i('Requested K spin not recognized in mqc_NEF_R4_at',6,& + 'ss',ss) + end if +! + spinBlock='' + if (dI.eq.1) then + id1 = p + spinBlock=trim(spinBlock)//trim(sI) + else if (dJ.eq.1) then + id1 = q + spinBlock=trim(spinBlock)//trim(sJ) + else if (dK.eq.1) then + id1 = r + spinBlock=trim(spinBlock)//trim(sK) + else + id1 = s + spinBlock=trim(spinBlock)//trim(sL) + end if + if (dI.eq.2) then + id2 = p + spinBlock=trim(spinBlock)//trim(sI) + else if (dJ.eq.2) then + id2 = q + spinBlock=trim(spinBlock)//trim(sJ) + else if (dK.eq.2) then + id2 = r + spinBlock=trim(spinBlock)//trim(sK) + else + id2 = s + spinBlock=trim(spinBlock)//trim(sL) + end if + if (dI.eq.3) then + id3 = p + spinBlock=trim(spinBlock)//trim(sI) + else if (dJ.eq.3) then + id3 = q + spinBlock=trim(spinBlock)//trim(sJ) + else if (dK.eq.3) then + id3 = r + spinBlock=trim(spinBlock)//trim(sK) + else + id3 = s + spinBlock=trim(spinBlock)//trim(sL) + end if + if (dI.eq.4) then + id4 = p + spinBlock=trim(spinBlock)//trim(sI) + else if (dJ.eq.4) then + id4 = q + spinBlock=trim(spinBlock)//trim(sJ) + else if (dK.eq.4) then + id4 = r + spinBlock=trim(spinBlock)//trim(sK) + else + id4 = s + spinBlock=trim(spinBlock)//trim(sL) + end if +! + element = nefR4%Main_R4(nefR4%blockIndex(& + [dI,I],[dJ,J],[dK,K],[dL,L]))%at(& + id1,id2,id3,id4,spinBlock) +! + end function mqc_nef_r4_at +! +! +! PROCEDURE MQC_NEF_Vector_Dimension_Expand +! +! +!> \brief MQC_NEF_Vector_Dimension_Expand is used to return an expanded +!> NEF Matrix object based on a NEF Vector object. +!> +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEF_Vector_Dimension_Expand is used to return an expanded +!> NEF Matrix object based on a NEF Vector object. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] NEFV +!> \verbatim +!> NEFV is type(mqc_nef_vector) +!> NEF Vector Object to be expanded. +!> \endverbatim +!> +!> \param[in] spinType +!> \verbatim +!> spinType is Character(Len=*),Optional +!> spinType modiffies the excitations considered +!> Options: +!> 'singlet' => return same spin +!> 'triplet => return opposite spin +!> 'all','full' => return both types (default) +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_nef_vector_dimention_expand(& + NEFV,map_matrix_row,map_matrix_col,spinType) result(NEFMatOut) +! + implicit none + class(mqc_nef_vector),intent(in)::NEFV + Type(MQC_SCF_Eigenvalues),Dimension(:),Allocatable,intent(in)::map_matrix_row,map_matrix_col + character(len=*),intent(in),optional::spinType + character(len=64)::mySpinType + type(mqc_nef_matrix)::NEFMatOut + integer(kind=int64),dimension(:),Allocatable::my_row,my_col + integer(kind=int64)::row,col,i,j,id +! + if(present(spinType)) then + mySpinType = spinType + else + mySpinType = 'all' + end if +! + call NEFMatOut%init(map_matrix_row,initial_map_matrix_col=map_matrix_col) + select case(mySpinType) + case ('singlet') + do row = 1, NEFMatOut%NumSpace_row + do col = 1, NEFMatOut%NumSpace_col + id = NEFMatOut%blockIndex([1,row],[2,col]) + do i = 1, NEFMatOut%Size_vector_alpha_row(row) + do j = 1, NEFMatOut%Size_vector_alpha_col(col) + call NEFMatOut%Main_Matrix(id)%put(& + NEFV%Main_Vector(id)%at(& + int(NEFMatOut%collapseIndex(i,j,'a','a',row,col,'singlet')),'alpha'),& + i,j,'alpha') + end do + end do + do i = 1, nefMatOut%Size_vector_beta_row(row) + do j = 1, nefMatOut%Size_vector_beta_col(col) + call NEFMatOut%Main_Matrix(id)%put(& + NEFV%Main_Vector(id)%at(& + int(NEFMatOut%collapseIndex(i,j,'b','b',row,col,'singlet')),'beta'),& + i,j,'beta') + end do + end do + end do + end do + case ('triplet') + do row = 1, NEFMatOut%NumSpace_row + do col = 1, NEFMatOut%NumSpace_col + id = nefMatOut%blockIndex([1,row],[2,col]) + do i = 1, nefMatOut%Size_vector_alpha_row(row) + do j = 1, nefMatOut%Size_vector_beta_col(col) + call NEFMatOut%Main_Matrix(id)%put(& + NEFV%Main_Vector(id)%at(& + int(NEFMatOut%collapseIndex(i,j,'a','b',row,col,'triplet')),'alpha'),& + i,j,'alphabeta') + end do + end do + do i = 1, nefMatOut%Size_vector_beta_row(row) + do j = 1, nefMatOut%Size_vector_alpha_col(col) + call NEFMatOut%Main_Matrix(id)%put(& + NEFV%Main_Vector(id)%at(& + int(NEFMatOut%collapseIndex(i,j,'b','a',row,col,'triplet')),'beta'),& + i,j,'betaalpha') + end do + end do + end do + end do + case ('all','full') + do row = 1, NEFMatOut%NumSpace_row + do col = 1, NEFMatOut%NumSpace_col + id = nefMatOut%blockIndex([1,row],[2,col]) + do i = 1, nefMatOut%Size_vector_alpha_row(row) + do j = 1, nefMatOut%Size_vector_alpha_col(col) + call NEFMatOut%Main_Matrix(id)%put(& + NEFV%Main_Vector(id)%at(& + int(NEFMatOut%collapseIndex(i,j,'a','a',row,col,'full')),'all'),& + i,j,'alpha') + end do + do j = 1, nefMatOut%Size_vector_beta_col(col) + call NEFMatOut%Main_Matrix(id)%put(& + NEFV%Main_Vector(id)%at(& + int(NEFMatOut%collapseIndex(i,j,'a','b',row,col,'full')),'alpha'),& + i,j,'alphabeta') + end do + end do + do i = 1, nefMatOut%Size_vector_beta_row(row) + do j = 1, nefMatOut%Size_vector_beta_col(col) + call NEFMatOut%Main_Matrix(id)%put(& + NEFV%Main_Vector(id)%at(& + int(NEFMatOut%collapseIndex(i,j,'b','b',row,col,'full')),'beta'),& + i,j,'beta') + end do + do j = 1, nefMatOut%Size_vector_alpha_col(col) + call NEFMatOut%Main_Matrix(id)%put(& + NEFV%Main_Vector(id)%at(& + int(NEFMatOut%collapseIndex(i,j,'b','b',row,col,'full')),'beta'),& + i,j,'beta') + end do + end do + end do + end do + case default + call mqc_error_a('mqc_nef_vector_dimention_excpanded: Unrecognized excitation type',6,& + 'spinType',spinType) + end select +! + end function mqc_nef_vector_dimention_expand +! +! +! PROCEDURE MQC_NEF_Matrix_Dimension_Collapse +! +! +!> \brief MQC_NEF_Matrix_Dimension_Collapse is used to return a collapse +!> two indexes of the input NEF Matrix object into one. +!> +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEF_Matrix_Dimension_Collapse is used to return a collapse two indexes +!> of the input NEF Matrix object into one. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] NEFM +!> \verbatim +!> NEFM is type(mqc_nef_matrix) +!> NEF Matrix Object to be collapsed. +!> \endverbatim +!> +!> \param[in] spinType +!> \verbatim +!> spinType is Character(Len=*),Optional +!> spinType modiffies the excitations considered +!> Options: +!> 'singlet' => return same spin +!> 'triplet => return opposite spin +!> 'all' => return both types (default) +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_nef_matrix_dimention_collapse(NEFM,spinType) result(NEFVecOut) +! + implicit none + class(mqc_nef_matrix),intent(in)::NEFM + character(len=*),intent(in),optional::spinType + character(len=64)::mySpinType + type(mqc_nef_vector)::NEFVecOut + Type(MQC_SCF_Eigenvalues),Dimension(:),Allocatable::New_Map + integer(kind=int64),dimension(:),Allocatable::my_row,my_col + integer(kind=int64)::row,col,i,j,id +! + if(present(spinType)) then + mySpinType = spinType + else + mySpinType = 'all' + end if +! + call NEFVecOut%init(NEFM%collapseMap(mySpinType)) + select case(mySpinType) + case ('singlet') + do row = 1, NEFM%NumSpace_row + do col = 1, NEFM%NumSpace_col + id = nefM%blockIndex([1,row],[2,col]) + do i = 1, nefM%Size_vector_alpha_row(row) + do j = 1, nefM%Size_vector_alpha_col(col) + call NEFVecOut%Main_vector(id)%put(& + NEFM%at(i,j,row,col,'alpha'),& + int(NEFM%collapseIndex(i,j,'a','a',row,col,'singlet')),& + 'alpha') + end do + end do + do i = 1, nefM%Size_vector_beta_row(row) + do j = 1, nefM%Size_vector_beta_col(col) + call NEFVecOut%Main_vector(id)%put(& + NEFM%at(i,j,row,col,'beta'),& + int(NEFM%collapseIndex(i,j,'b','b',row,col,'singlet')),& + 'beta') + end do + end do + end do + end do + case ('triplet') + do row = 1, NEFM%NumSpace_row + do col = 1, NEFM%NumSpace_col + id = nefM%blockIndex([1,row],[2,col]) + do i = 1, nefM%Size_vector_alpha_row(row) + do j = 1, nefM%Size_vector_beta_col(col) + call NEFVecOut%Main_vector(id)%put(& + NEFM%at(i,j,row,col,'alphabeta'),& + int(NEFM%collapseIndex(i,j,'a','b',row,col,'triplet')),& + 'alpha') + end do + end do + do i = 1, nefM%Size_vector_beta_row(row) + do j = 1, nefM%Size_vector_alpha_col(col) + call NEFVecOut%Main_vector(id)%put(& + NEFM%at(i,j,row,col,'betaalpha'),& + int(NEFM%collapseIndex(i,j,'b','a',row,col,'triplet')),& + 'beta') + end do + end do + end do + end do + case ('all') + do row = 1, NEFM%NumSpace_row + do col = 1, NEFM%NumSpace_col + id = nefM%blockIndex([1,row],[2,col]) + do i = 1, nefM%Size_vector_alpha_row(row) + do j = 1, nefM%Size_vector_alpha_col(col) + call NEFVecOut%Main_vector(id)%put(& + NEFM%at(i,j,row,col,'alpha'),& + int(NEFM%collapseIndex(i,j,'a','a',row,col,'all')),& + 'alpha') + end do + do j = 1, nefM%Size_vector_beta_col(col) + call NEFVecOut%Main_vector(id)%put(& + NEFM%at(i,j,row,col,'alphabeta'),& + int(NEFM%collapseIndex(i,j,'a','b',row,col,'all')),& + 'alpha') + end do + end do + do i = 1, nefM%Size_vector_beta_row(row) + do j = 1, nefM%Size_vector_beta_col(col) + call NEFVecOut%Main_vector(id)%put(& + NEFM%at(i,j,row,col,'beta'),& + int(NEFM%collapseIndex(i,j,'b','b',row,col,'all')),& + 'beta') + end do + do j = 1, nefM%Size_vector_alpha_col(col) + call NEFVecOut%Main_vector(id)%put(& + NEFM%at(i,j,row,col,'betaalpha'),& + int(NEFM%collapseIndex(i,j,'b','a',row,col,'all')),& + 'beta') + end do + end do + end do + end do + case default + call mqc_error_a('mqc_nef_matrix_dimention_collapse: Unrecognized excitation type',6,& + 'spinType',spinType) + end select +! + end function mqc_nef_matrix_dimention_collapse +! +! +! PROCEDURE MQC_NEF_R4_Dimension_Collapse +! +! +!> \brief MQC_NEF_R4_Dimension_Collapse is used to return a collapse +!> two indexes of the input NEF R4 object into one. +!> +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEF_R4_Dimension_Collapse is used to return a collapse two indexes +!> of the input NEF R4 object into one. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] NEFR4 +!> \verbatim +!> NEFr4 is type(mqc_nef_r4) +!> NEF R4 Object to be collapsed. +!> \endverbatim +!> +!> \param[in] spinType +!> \verbatim +!> spinType is Character(Len=*),Optional +!> spinType modiffies the excitations considered +!> Options: +!> 'singlet' => return same spin +!> 'triplet => return opposite spin +!> 'all' => return both types (default) +!> \endverbatim +!> +!> \param[in] spinTypeKet +!> \verbatim +!> spinTypeKet is Character(Len=*),Optional +!> spinType modiffies the excitations considered over ket +!> Options: +!> 'singlet' => return same spin +!> 'triplet => return opposite spin +!> 'all' => return both types (default) +!> \endverbatim +!> +!> \param[in] Order +!> \verbatim +!> Order is integer(kind=int64),dimension(4),intent(in),optional +!> Order contains the indexes to be collapsed following: +!> Order = [i,j,k,l] => i->j = p and k->l = q +!> (default [1,2,3,4]) +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_nef_r4_dimention_collapse(NEFr4,spinType,spinTypeKet,Order) result(NEFMatOut) +! + implicit none + class(mqc_nef_r4),intent(in)::NEFr4 + character(len=*),intent(in),optional::spinType,spinTypeKet + integer(kind=int64),dimension(4),intent(in),optional::Order + integer(kind=int64),dimension(4)::my_order + type(mqc_nef_matrix)::NEFMatOut + character(len=64)::mySpinType,mySpinTypeKet + Type(MQC_SCF_Eigenvalues),Dimension(:),Allocatable::New_Map + integer(kind=int64),dimension(:),Allocatable::my_row,my_col + integer(kind=int64)::row,col,i,j,k,l,id,idij,idlk,fullid,finalid + integer(kind=int64)::ia,ja,ka,la + integer(kind=int64)::dimi,dimj,dimk,diml +! + if(present(spinType)) then + mySpinType = spinType + if(present(spinTypeKet)) then + mySpinTypeKet = spinTypeKet + else + mySpinTypeKet = spinType + end if + else + if(present(spinTypeKet)) then + mySpinTypeKet = spinTypeKet + mySpinType = spinTypeKet + else + mySpinTypeKet = 'all' + mySpinType = 'all' + end if + end if +! + if(present(Order)) then + ia=Order(1) + ja=Order(2) + ka=Order(3) + la=Order(4) + if (ia.eq.ja) Call MQC_Error_I(& + 'Duplicated index in MQC_nef_matrix_dimention_collapse',& + 6,'ia', ia,'ja',ja) + if (ia.eq.ka) Call MQC_Error_I(& + 'Duplicated index in MQC_nef_matrix_dimention_collapse',& + 6,'ia', ia,'ka',ka) + if (ia.eq.la) Call MQC_Error_I(& + 'Duplicated index in MQC_nef_matrix_dimention_collapse',& + 6,'ia', ia,'la',la) + if (ja.eq.ka) Call MQC_Error_I(& + 'Duplicated index in MQC_nef_matrix_dimention_collapse',& + 6,'ja', ja,'ka',ka) + if (ja.eq.la) Call MQC_Error_I(& + 'Duplicated index in MQC_nef_matrix_dimention_collapse',& + 6,'ja', ja,'la',la) + if (ka.eq.la) Call MQC_Error_I(& + 'Duplicated index in MQC_nef_matrix_dimention_collapse',& + 6,'ka', ka,'la',la) + my_order = Order + else + ia=1 + ja=2 + ka=3 + la=4 + my_order = [1,2,3,4] + endif +! + call NEFr4%print(6,'initial R4') + call NEFMatOut%init(NEFr4%collapseMap(mySpinType,[ia,ja]),& + initial_map_matrix_col=NEFr4%collapseMap(mySpinTypeKet,[ka,la])) + call NEFMatOut%print(6,'NEFMat Initial') + select case(mySpinType) + case ('singlet') + do dimi = 1, NEFr4%blockSize(ia) + do dimj = 1, NEFr4%blockSize(ja) + idij = NEFr4%blockSize(ja)*(dimi-1) + dimj + do dimk = 1, NEFr4%blockSize(ka) + do diml = 1, NEFr4%blockSize(la) + idlk = NEFr4%blockSize(la)*(dimk-1) + diml + finalid = nefMatOut%blockIndex([1,idij],[2,idlk]) + write(*,*) idij, idlk, finalid + do i = 1, NEFr4%blockSize(ia,dimi,'alpha') + do j = 1, NEFr4%blockSize(ja,dimj,'alpha') + write(*,*) 'a a a a' + do k = 1, NEFr4%blockSize(ka,dimk,'alpha') + do l = 1, NEFr4%blockSize(la,diml,'alpha') + write(*,*) dimi,dimj,dimk,diml,i,j,k,l + call NEFR4%Main_R4(nefr4%blockIndex([ia,dimi],[ja,dimj],[la,diml],[ka,dimk]))%print(& + 6,'MMFM: nefR4 out - aaaa') + call NEFMatOut%Main_Matrix(finalid)%print(6,'MMFM: nef out - aa') + call NEFMatOut%Main_Matrix(finalid)%put(& + NEFR4%at(& + [ia,dimi,i,1],[ja,dimj,j,1],[ka,dimk,k,1],[la,diml,l,1]),& + int(NEFr4%collapseIndex(i,j,'a','a',dimi,dimj,ia,ja,'singlet')),& + int(NEFr4%collapseIndex(k,l,'a','a',dimk,diml,ka,la,'singlet')),& + 'alpha') + end do + end do + write(*,*) 'a a b b' + do k = 1, NEFr4%blockSize(ka,dimk,'beta') + do l = 1, NEFr4%blockSize(la,diml,'beta') + call NEFMatOut%Main_Matrix(finalid)%put(& + NEFR4%at(& + [ia,dimi,i,1],[ja,dimj,j,1],[ka,dimk,k,-1],[la,diml,l,-1]),& + int(NEFr4%collapseIndex(i,j,'a','a',dimi,dimj,ia,ja,'singlet')),& + int(NEFr4%collapseIndex(k,l,'b','b',dimk,diml,ka,la,'singlet')),& + 'alphabeta') + end do + end do + end do + end do + do i = 1, NEFr4%blockSize(ia,dimi,'beta') + do j = 1, NEFr4%blockSize(ja,dimj,'beta') + write(*,*) 'b b a a' + do k = 1, NEFr4%blockSize(ka,dimk,'alpha') + do l = 1, NEFr4%blockSize(la,diml,'alpha') + write(*,*) dimi,dimj,dimk,diml,i,j,k,l + call NEFMatOut%Main_Matrix(finalid)%put(& + NEFR4%at(& + [ia,dimi,i,-1],[ja,dimj,j,-1],[ka,dimk,k,1],[la,diml,l,1]),& + int(NEFr4%collapseIndex(i,j,'b','b',dimi,dimj,ia,ja,'singlet')),& + int(NEFr4%collapseIndex(k,l,'a','a',dimk,diml,ka,la,'singlet')),& + 'betaalpha') + end do + end do + write(*,*) 'b b b b' + do k = 1, NEFr4%blockSize(ka,dimk,'beta') + do l = 1, NEFr4%blockSize(la,diml,'beta') + write(*,*) dimi,dimj,dimk,diml,i,j,k,l + call NEFMatOut%Main_Matrix(finalid)%put(& + NEFR4%at(& + [ia,dimi,i,-1],[ja,dimj,j,-1],[ka,dimk,k,-1],[la,diml,l,-1]),& + int(NEFr4%collapseIndex(i,j,'b','b',dimi,dimj,ia,ja,'singlet')),& + int(NEFr4%collapseIndex(k,l,'b','b',dimk,diml,ka,la,'singlet')),& + 'beta') + end do + end do + end do + end do + end do + end do + end do + end do + case ('triplet') + do dimi = 1, NEFr4%blockSize(ia) + do dimj = 1, NEFr4%blockSize(ja) + idij = nefr4%blockIndex([1,1],[2,1],[3,dimi],[4,dimj]) + do dimk = 1, NEFr4%blockSize(ka) + do diml = 1, NEFr4%blockSize(la) + idlk = nefr4%blockIndex([1,1],[2,1],[3,diml],[4,dimk]) + finalid = nefMatOut%blockIndex([1,idij],[2,idlk]) + do i = 1, NEFr4%blockSize(ia,dimi,'alpha') + do j = 1, NEFr4%blockSize(ja,dimj,'beta') + do k = 1, NEFr4%blockSize(ka,dimk,'alpha') + do l = 1, NEFr4%blockSize(la,diml,'beta') + call NEFMatOut%Main_Matrix(finalid)%put(& + NEFR4%at(& + [ia,dimi,i,1],[ja,dimj,j,-1],[ka,dimk,k,1],[la,diml,l,-1]),& + int(NEFr4%collapseIndex(i,j,'a','b',dimi,dimj,ia,ja,'triplet')),& + int(NEFr4%collapseIndex(k,l,'a','b',dimk,diml,ka,la,'triplet')),& + 'alpha') + end do + end do + do k = 1, NEFr4%blockSize(ka,dimk,'beta') + do l = 1, NEFr4%blockSize(la,diml,'alpha') + call NEFMatOut%Main_Matrix(finalid)%put(& + NEFR4%at(& + [ia,dimi,i,1],[ja,dimj,j,-1],[ka,dimk,k,-1],[la,diml,l,1]),& + int(NEFr4%collapseIndex(i,j,'a','b',dimi,dimj,ia,ja,'triplet')),& + int(NEFr4%collapseIndex(k,l,'b','a',dimk,diml,ka,la,'triplet')),& + 'alphabeta') + end do + end do + end do + end do + do i = 1, NEFr4%blockSize(ia,dimi,'beta') + do j = 1, NEFr4%blockSize(ja,dimj,'alpha') + do k = 1, NEFr4%blockSize(ka,dimk,'alpha') + do l = 1, NEFr4%blockSize(la,diml,'beta') + call NEFMatOut%Main_Matrix(finalid)%put(& + NEFR4%at(& + [ia,dimi,i,-1],[ja,dimj,j,1],[ka,dimk,k,1],[la,diml,l,-1]),& + int(NEFr4%collapseIndex(i,j,'b','a',dimi,dimj,ia,ja,'triplet')),& + int(NEFr4%collapseIndex(k,l,'a','b',dimk,diml,ka,la,'triplet')),& + 'betaalpha') + end do + end do + do k = 1, NEFr4%blockSize(ka,dimk,'beta') + do l = 1, NEFr4%blockSize(la,diml,'alpha') + call NEFMatOut%Main_Matrix(finalid)%put(& + NEFR4%at(& + [ia,dimi,i,-1],[ja,dimj,j,1],[ka,dimk,k,-1],[la,diml,l,1]),& + int(NEFr4%collapseIndex(i,j,'b','a',dimi,dimj,ia,ja,'triplet')),& + int(NEFr4%collapseIndex(k,l,'b','a',dimk,diml,ka,la,'triplet')),& + 'beta') + end do + end do + end do + end do + end do + end do + end do + end do + case ('all') + do dimi = 1, NEFr4%blockSize(ia) + do dimj = 1, NEFr4%blockSize(ja) + idij = nefr4%blockIndex([1,1],[2,1],[3,dimi],[4,dimj]) + do dimk = 1, NEFr4%blockSize(ka) + do diml = 1, NEFr4%blockSize(la) + idlk = nefr4%blockIndex([1,1],[2,1],[3,diml],[4,dimk]) + finalid = nefMatOut%blockIndex([1,idij],[2,idlk]) + do i = 1, NEFr4%blockSize(ia,dimi,'alpha') + do j = 1, NEFr4%blockSize(ja,dimj,'alpha') + do k = 1, NEFr4%blockSize(ka,dimk,'alpha') + do l = 1, NEFr4%blockSize(la,diml,'alpha') + call NEFMatOut%Main_Matrix(finalid)%put(& + NEFR4%at(& + [ia,dimi,i,1],[ja,dimj,j,1],[ka,dimk,k,1],[la,diml,l,1]),& + int(NEFr4%collapseIndex(i,j,'a','a',dimi,dimj,ia,ja,'all')),& + int(NEFr4%collapseIndex(k,l,'a','a',dimk,diml,ka,la,'all')),& + 'alpha') + end do + end do + do k = 1, NEFr4%blockSize(ka,dimk,'beta') + do l = 1, NEFr4%blockSize(la,diml,'beta') + call NEFMatOut%Main_Matrix(finalid)%put(& + NEFR4%at(& + [ia,dimi,i,1],[ja,dimj,j,1],[ka,dimk,k,-1],[la,diml,l,-1]),& + int(NEFr4%collapseIndex(i,j,'a','a',dimi,dimj,ia,ja,'all')),& + int(NEFr4%collapseIndex(k,l,'b','b',dimk,diml,ka,la,'all')),& + 'alphabeta') + end do + end do + end do + end do + do i = 1, NEFr4%blockSize(ia,dimi,'beta') + do j = 1, NEFr4%blockSize(ja,dimj,'beta') + do k = 1, NEFr4%blockSize(ka,dimk,'alpha') + do l = 1, NEFr4%blockSize(la,diml,'alpha') + call NEFMatOut%Main_Matrix(finalid)%put(& + NEFR4%at(& + [ia,dimi,i,-1],[ja,dimj,j,-1],[ka,dimk,k,1],[la,diml,l,1]),& + int(NEFr4%collapseIndex(i,j,'b','b',dimi,dimj,ia,ja,'all')),& + int(NEFr4%collapseIndex(k,l,'a','a',dimk,diml,ka,la,'all')),& + 'betaalpha') + end do + end do + do k = 1, NEFr4%blockSize(ka,dimk,'beta') + do l = 1, NEFr4%blockSize(la,diml,'beta') + call NEFMatOut%Main_Matrix(finalid)%put(& + NEFR4%at(& + [ia,dimi,i,-1],[ja,dimj,j,-1],[ka,dimk,k,-1],[la,diml,l,-1]),& + int(NEFr4%collapseIndex(i,j,'b','b',dimi,dimj,ia,ja,'all')),& + int(NEFr4%collapseIndex(k,l,'b','b',dimk,diml,ka,la,'all')),& + 'beta') + end do + end do + end do + end do + do i = 1, NEFr4%blockSize(ia,dimi,'alpha') + do j = 1, NEFr4%blockSize(ja,dimj,'beta') + do k = 1, NEFr4%blockSize(ka,dimk,'alpha') + do l = 1, NEFr4%blockSize(la,diml,'beta') + call NEFMatOut%Main_Matrix(finalid)%put(& + NEFR4%at(& + [ia,dimi,i,1],[ja,dimj,j,-1],[ka,dimk,k,1],[la,diml,l,-1]),& + int(NEFr4%collapseIndex(i,j,'a','b',dimi,dimj,ia,ja,'all')),& + int(NEFr4%collapseIndex(k,l,'a','b',dimk,diml,ka,la,'all')),& + 'alpha') + end do + end do + do k = 1, NEFr4%blockSize(ka,dimk,'beta') + do l = 1, NEFr4%blockSize(la,diml,'alpha') + call NEFMatOut%Main_Matrix(finalid)%put(& + NEFR4%at(& + [ia,dimi,i,1],[ja,dimj,j,-1],[ka,dimk,k,-1],[la,diml,l,1]),& + int(NEFr4%collapseIndex(i,j,'a','b',dimi,dimj,ia,ja,'all')),& + int(NEFr4%collapseIndex(k,l,'b','a',dimk,diml,ka,la,'all')),& + 'alphabeta') + end do + end do + end do + end do + do i = 1, NEFr4%blockSize(ia,dimi,'beta') + do j = 1, NEFr4%blockSize(ja,dimj,'alpha') + do k = 1, NEFr4%blockSize(ka,dimk,'alpha') + do l = 1, NEFr4%blockSize(la,diml,'beta') + call NEFMatOut%Main_Matrix(finalid)%put(& + NEFR4%at(& + [ia,dimi,i,-1],[ja,dimj,j,1],[ka,dimk,k,1],[la,diml,l,-1]),& + int(NEFr4%collapseIndex(i,j,'b','a',dimi,dimj,ia,ja,'all')),& + int(NEFr4%collapseIndex(k,l,'a','b',dimk,diml,ka,la,'all')),& + 'betaalpha') + end do + end do + do k = 1, NEFr4%blockSize(ka,dimk,'beta') + do l = 1, NEFr4%blockSize(la,diml,'alpha') + call NEFMatOut%Main_Matrix(finalid)%put(& + NEFR4%at(& + [ia,dimi,i,-1],[ja,dimj,j,1],[ka,dimk,k,-1],[la,diml,l,1]),& + int(NEFr4%collapseIndex(i,j,'b','a',dimi,dimj,ia,ja,'all')),& + int(NEFr4%collapseIndex(k,l,'b','a',dimk,diml,ka,la,'all')),& + 'beta') + end do + end do + end do + end do + end do + end do + end do + end do + case default + call mqc_error_a('mqc_nef_r4_dimention_collapse: Unrecognized excitation type',6,& + 'spinType',spinType) + end select + write(*,*) 'MMFM: \brief MQC_NEF_Matrix_Collapse_Index is used to return a collapsed +!> two index excitation. +!> +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEF_Matrix_Collapse_Index is used to return a collapsed two index +!> two index excitation. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] NEFM +!> \verbatim +!> NEFM is type(mqc_nef_matrix) +!> NEF Matrix Object to be collapsed. +!> \endverbatim +!> +!> \param[in] I +!> \verbatim +!> I is Integer(kind=int64) +!> The first dimension of the element in MQC NEF Matrix +!> If I>0 row count is from first index +!> \endverbatim +!> +!> \param[in] J +!> \verbatim +!> J is Integer(kind=int64) +!> The second dimension of the element in MQC NEF Matrix +!> If J>0 col count is from first index +!> \endverbatim +!> +!> \param[in] i_spin +!> \verbatim +!> i_spin is character(len=1) +!> Spin of the annihilation operator natorb. +!> If i_index or a_index is negative, this option does not +!> change the result. +!> Options: +!> a => alpha spin +!> b => beta spin +!> \endverbatim +!> +!> \param[in] j_spin +!> \verbatim +!> j_spin is character(len=1) +!> Spin of the creation operator natorb. +!> If a_index or a_index is negative, this option does not +!> change the result. +!> Options: +!> a => alpha spin +!> b => beta spin +!> \endverbatim +!> +!> \param[in] i_space +!> \verbatim +!> i_space is an integer +!> Index of the annihilation operator natorb subspace. +!> If i_index or a_index is negative, this option does not +!> change the result. +!> \endverbatim +!> +!> \param[in] j_space +!> \verbatim +!> j_space is an integer +!> Index of the creation operator natorb subspace. +!> If i_index or a_index is negative, this option does not +!> change the result. +!> \endverbatim +!> +!> \param[in] excType +!> \verbatim +!> excType is Character(Len=*),Optional +!> excType modiffies the excitations considered +!> Options: +!> 'singlet' => return same spin +!> 'triplet => return opposite spin +!> 'all','full' => return both types (default) +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_nef_matrix_collapse_index(NEFM,i,j,i_spin,j_spin,i_space,j_space,excType) result(idOut) +! + implicit none + class(mqc_nef_matrix),intent(in)::NEFM + integer::idOut + integer(kind=int64)::i,j,i_space,j_space + character(len=1)::i_spin,j_spin + character(len=*),intent(in),optional::excType + character(len=64)::selectedExcType +! + if(i_spin.ne.'a'.and.i_spin.ne.'b') & + call mqc_Error_a('mqc_nef_matrix_collapse_index: Unrecognized spin',& + 6,'i_spin',i_spin) + if(j_spin.ne.'a'.and.j_spin.ne.'b') & + call mqc_Error_a('mqc_nef_matrix_collapse_index: Unrecognized spin',& + 6,'j_spin',j_spin) + if(i_space.gt.nefM%NumSpace_row.or.i_space.lt.1) & + call mqc_Error_i('mqc_nef_matrix_collapse_index: Space index out-of-bound',& + 6,'i_space',i_space) + if(j_space.gt.nefM%NumSpace_col.or.j_space.lt.1)& + call mqc_Error_i('mqc_nef_matrix_collapse_index: Space index out-of-bound',& + 6,'j_space',j_space) +! + idOut = 0 + if ((i_spin.eq.'b'.and.nefM%Size_vector_beta_row(i_space).eq.0).or.& + (i_spin.eq.'a'.and.nefM%Size_vector_alpha_row(i_space).eq.0).or.& + (j_spin.eq.'b'.and.nefM%Size_vector_beta_col(j_space).eq.0).or.& + (j_spin.eq.'a'.and.nefM%Size_vector_alpha_col(j_space).eq.0)) return +! + if (i_spin.eq.'b'.and.i.gt.nefM%Size_vector_beta_row(i_space).or.i.lt.0) & + call mqc_Error_i('mqc_nef_matrix_collapse_index: i beta index out-of-bound',& + 6,'i',i,'nefM%Size_vector_beta_row(i_space)',nefM%Size_vector_beta_row(i_space)) + if (i_spin.eq.'a'.and.i.gt.nefM%Size_vector_alpha_row(i_space).or.i.lt.0) & + call mqc_Error_i('mqc_nef_matrix_collapse_index: i alpha index out-of-bound',& + 6,'i',i,'nefM%Size_vector_alpha_row(i_space)',nefM%Size_vector_alpha_row(i_space)) +! + if (j_spin.eq.'b'.and.j.gt.nefM%Size_vector_beta_col(j_space).or.j.lt.0) & + call mqc_Error_i('mqc_nef_matrix_collapse_index: j beta index out-of-bound',& + 6,'j',j,'nefM%Size_vector_beta_col(j_space)',nefM%Size_vector_beta_col(j_space)) + if (j_spin.eq.'a'.and.j.gt.nefM%Size_vector_alpha_col(j_space).or.j.lt.0) & + call mqc_Error_i('mqc_nef_matrix_collapse_index: j alpha index out-of-bound',& + 6,'j',j,'nefM%Size_vector_alpha_col(j_space)',nefM%Size_vector_alpha_col(j_space)) +! + if(present(excType)) then + selectedExcType = trim(excType) !singlet, triplet, all + else + selectedExcType = 'singlet' + end if + if (selectedExcType.eq.'singlet'.and.i_spin.ne.j_spin) & + call mqc_Error('inter_matrix_get_natural_single_excitation_index: wrong spin for triplet',6) + if (selectedExcType.eq.'triplet'.and.i_spin.eq.j_spin) & + call mqc_Error('inter_matrix_get_natural_single_excitation_index: wrong spin for triplet',6) +! + idOut = 0 + select case(selectedExcType) + case ('singlet') + if (j_spin.eq.'b') then + idOut = (i-1)*nefM%Size_vector_beta_col(j_space) + j + else + idOut = (i-1)*nefM%Size_vector_alpha_col(j_space) + j + end if + case ('triplet') + if (j_spin.eq.'b') then + idOut = (i-1)*nefM%Size_vector_alpha_col(j_space) + j + else + idOut = (i-1)*nefM%Size_vector_beta_col(j_space) + j + end if + case ('all','full') + if (j_spin.eq.'b') then + idOut = (i-1)*nefM%Size_vector_beta_col(j_space) + j + else + idOut = (i-1)*(nefM%Size_vector_beta_col(j_space)+nefM%Size_vector_alpha_col(j_space)) + & + j + nefM%Size_vector_beta_col(j_space) + end if + case default + call mqc_error_a('mqc_nef_matrix_collapse_index: Unrecognized',6,'selectedExcType',& + selectedExcType) + end select +! + end function mqc_nef_matrix_collapse_index +! +! +! PROCEDURE MQC_NEF_R4_Collapse_Index +! +! +!> \brief MQC_NEF_R4_Collapse_Index is used to return a collapsed +!> two index excitation. +!> +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEF_R4_Collapse_Index is used to return a collapsed two index +!> two index excitation. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] NEFR4 +!> \verbatim +!> NEFR4 is type(mqc_nef_r4) +!> NEF R4 Object to be collapsed. +!> \endverbatim +!> +!> \param[in] I +!> \verbatim +!> I is Integer(kind=int64) +!> The dimi of the element in MQC NEF R4 +!> If I>0 row count is from first index +!> \endverbatim +!> +!> \param[in] J +!> \verbatim +!> J is Integer(kind=int64) +!> The dimj of the element in MQC NEF MR4 +!> If J>0 col count is from first index +!> \endverbatim +!> +!> \param[in] i_spin +!> \verbatim +!> i_spin is character(len=1) +!> Spin of the annihilation operator natorb. +!> If i_index or a_index is negative, this option does not +!> change the result. +!> Options: +!> a => alpha spin +!> b => beta spin +!> \endverbatim +!> +!> \param[in] j_spin +!> \verbatim +!> j_spin is character(len=1) +!> Spin of the creation operator natorb. +!> If a_index or a_index is negative, this option does not +!> change the result. +!> Options: +!> a => alpha spin +!> b => beta spin +!> \endverbatim +!> +!> \param[in] i_space +!> \verbatim +!> i_space is an integer +!> Index of the annihilation operator natorb subspace. +!> If i_index or a_index is negative, this option does not +!> change the result. +!> \endverbatim +!> +!> \param[in] j_space +!> \verbatim +!> j_space is an integer +!> Index of the creation operator natorb subspace. +!> If i_index or a_index is negative, this option does not +!> change the result. +!> \endverbatim +!> +!> \param[in] dimi +!> \verbatim +!> dimi is an integer +!> Index of the creation operator natorb subspace. +!> \endverbatim +!> +!> \param[in] dimj +!> \verbatim +!> dimj is an integer +!> Index of the creation operator natorb subspace. +!> \endverbatim +!> +!> \param[in] excType +!> \verbatim +!> excType is Character(Len=*),Optional +!> excType modiffies the excitations considered +!> Options: +!> 'singlet' => return same spin +!> 'triplet => return opposite spin +!> 'all','full' => return both types (default) +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_nef_r4_collapse_index(NEFM,i,j,i_spin,j_spin,& + i_space,j_space,dimi,dimj,excType) result(idOut) +! + implicit none + class(mqc_nef_r4),intent(in)::NEFM + integer::idOut + integer(kind=int64)::i,j,i_space,j_space,dimi,dimj + character(len=1)::i_spin,j_spin + character(len=*),intent(in),optional::excType + character(len=64)::selectedExcType +! + if(dimi.le.0.or.dimi.gt.4) & + call mqc_Error_i('mqc_nef_r4_collapse_index: dimention index out-of-bound',& + 6,'dimi',dimi) + if(dimj.le.0.or.dimj.gt.4) & + call mqc_Error_i('mqc_nef_r4_collapse_index: dimention index out-of-bound',& + 6,'dimj',dimj) +! + if(i_spin.ne.'a'.and.i_spin.ne.'b') & + call mqc_Error_a('mqc_nef_r4_collapse_index: Unrecognized spin',& + 6,'i_spin',i_spin) + if(j_spin.ne.'a'.and.j_spin.ne.'b') & + call mqc_Error_a('mqc_nef_r4_collapse_index: Unrecognized spin',& + 6,'j_spin',j_spin) + if(i_space.gt.nefM%blockSize(dimi).or.i_space.lt.1) & + call mqc_Error_i('mqc_nef_r4_collapse_index: Space index out-of-bound',& + 6,'i_space',i_space) + if(j_space.gt.nefM%blockSize(dimj).or.j_space.lt.1)& + call mqc_Error_i('mqc_nef_r4_collapse_index: Space index out-of-bound',& + 6,'j_space',j_space) +! + idOut = 0 + if ((i_spin.eq.'b'.and.nefM%blockSize(dimi,i_space,'beta').eq.0).or.& + (i_spin.eq.'a'.and.nefM%blockSize(dimi,i_space,'alpha').eq.0).or.& + (j_spin.eq.'b'.and.nefM%blockSize(dimj,j_space,'beta').eq.0).or.& + (j_spin.eq.'a'.and.nefM%blockSize(dimj,j_space,'alpha').eq.0)) return +! + if (i_spin.eq.'b'.and.i.gt.nefM%blockSize(dimi,i_space,'beta').or.i.lt.0) & + call mqc_Error_i('mqc_nef_r4_collapse_index: i beta index out-of-bound',& + 6,'i',i,'nefM%blockSize(dimi,i_space,beta)',nefM%blockSize(dimi,i_space,'beta')) + if (i_spin.eq.'a'.and.i.gt.nefM%blockSize(dimi,i_space,'alpha').or.i.lt.0) & + call mqc_Error_i('mqc_nef_r4_collapse_index: i alpha index out-of-bound',& + 6,'i',i,'nefM%blockSize(dimi,i_space,alpha)',nefM%blockSize(dimi,i_space,'alpha')) +! + if (j_spin.eq.'b'.and.j.gt.nefM%blockSize(dimj,j_space,'beta').or.j.lt.0) & + call mqc_Error_i('mqc_nef_r4_collapse_index: j beta index out-of-bound',& + 6,'j',j,'nefM%blockSize(dimj,j_space,beta)',nefM%blockSize(dimj,j_space,'beta')) + if (j_spin.eq.'a'.and.j.gt.nefM%blockSize(dimj,j_space,'alpha').or.j.lt.0) & + call mqc_Error_i('mqc_nef_r4_collapse_index: j alpha index out-of-bound',& + 6,'j',j,'nefM%blockSize(dimj,j_space,alpha)',nefM%blockSize(dimj,j_space,'alpha')) +! + if(present(excType)) then + selectedExcType = trim(excType) !singlet, triplet, all + else + selectedExcType = 'singlet' + end if + if (selectedExcType.eq.'singlet'.and.i_spin.ne.j_spin) & + call mqc_Error('inter_r4_get_natural_single_excitation_index: wrong spin for triplet',6) + if (selectedExcType.eq.'triplet'.and.i_spin.eq.j_spin) & + call mqc_Error('inter_r4_get_natural_single_excitation_index: wrong spin for triplet',6) +! + idOut = 0 + select case(selectedExcType) + case ('singlet') + if (j_spin.eq.'b') then + idOut = (i-1)*nefM%blockSize(dimj,j_space,'beta') + j + else + idOut = (i-1)*nefM%blockSize(dimj,j_space,'alpha') + j + end if + case ('triplet') + if (j_spin.eq.'b') then + idOut = (i-1)*nefM%blockSize(dimj,j_space,'alpha') + j + else + idOut = (i-1)*nefM%blockSize(dimj,j_space,'beta') + j + end if + case ('all','full') + if (j_spin.eq.'b') then + idOut = (i-1)*nefM%blockSize(dimj,j_space,'beta') + j + else + idOut = (i-1)*(nefM%blockSize(dimj,j_space,'beta') + & + nefM%blockSize(dimj,j_space,'alpha')) + & + j + nefM%blockSize(dimj,j_space,'beta') + end if + case default + call mqc_error_a('mqc_nef_r4_collapse_index: Unrecognized',6,'selectedExcType',& + selectedExcType) + end select +! + end function mqc_nef_r4_collapse_index +! +! +! PROCEDURE MQC_NEF_Matrix_Collapse_Map +! +! +!> \brief MQC_NEF_Matrix_Collapse_Map is used to return a collapsed +!> two Map_Vectors. +!> +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEF_Matrix_Collapse_Map is used to return a collapsed two Map_Vectors. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] NEFM +!> \verbatim +!> NEFM is type(mqc_nef_matrix) +!> NEF Matrix Object to be collapsed. +!> \endverbatim +!> +!> \param[in] excType +!> \verbatim +!> excType is Character(Len=*),Optional +!> excType modiffies the excitations considered +!> Options: +!> 'singlet' => return same spin +!> 'triplet => return opposite spin +!> 'all','full' => return both types (default) +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_nef_matrix_collapse_map(NEFM,excType) result(MapOut) +! + implicit none + class(mqc_nef_matrix),intent(in)::NEFM + character(len=*),intent(in),optional::excType + character(len=64)::selectedExcType + Type(MQC_SCF_Eigenvalues),Dimension(:),Allocatable::MapOut + Type(MQC_SCF_Eigenvalues),Dimension(:),Allocatable::New_Map_Col,New_Map_Row + integer(kind=int64),dimension(:),Allocatable::my_row,my_col + integer(kind=int64)::row,col,id,idOld,r0 + logical::full_row,full_col +! + if(present(excType)) then + selectedExcType = trim(excType) !singlet, triplet, all + else + selectedExcType = 'singlet' + end if +! + if(allocated(MapOut)) deallocate(MapOut) + allocate(MapOut(NEFM%NumSpace_row*NEFM%NumSpace_col)) +! + select case(selectedExcType) + case ('singlet') + do row = 1, NEFM%NumSpace_row + do col = 1, NEFM%NumSpace_col + id = nefM%blockIndex([1,row],[2,col]) + call MapOut(id)%init(& + nefM%Size_vector_alpha_col(col)*nefM%Size_vector_alpha_row(row),0,& + nefM%Size_vector_beta_col(col)*nefM%Size_vector_beta_row(row)) + end do + end do + case ('triplet') + do row = 1, NEFM%NumSpace_row + do col = 1, NEFM%NumSpace_col + id = nefM%blockIndex([1,row],[2,col]) + call MapOut(id)%init(& + nefM%Size_vector_alpha_col(col)*nefM%Size_vector_beta_row(row),0,& + nefM%Size_vector_beta_col(col)*nefM%Size_vector_alpha_row(row)) + end do + end do + case ('all','full') + do row = 1, NEFM%NumSpace_row + do col = 1, NEFM%NumSpace_col + id = nefM%blockIndex([1,row],[2,col]) + call MapOut(id)%init(& + nefM%Size_vector_alpha_col(col)*nefM%Size_vector_alpha_row(row)+& + nefM%Size_vector_alpha_col(col)*nefM%Size_vector_beta_row(row),0,& + nefM%Size_vector_beta_col(col)*nefM%Size_vector_beta_row(row)+& + nefM%Size_vector_beta_col(col)*nefM%Size_vector_alpha_row(row)) + end do + end do + case default + call mqc_error_a('mqc_nef_matrix_collapse_map: Unrecognized excitation type',6,& + 'selectedExcType',selectedExcType) + end select +! + end function mqc_nef_matrix_collapse_map +! +! +! PROCEDURE MQC_NEF_R4_Collapse_Map +! +! +!> \brief MQC_NEF_R4_Collapse_Map is used to return a collapsed +!> two Map_Vectors. +!> +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEF_R4_Collapse_Map is used to return a collapsed two Map_Vectors. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] NEFr4 +!> \verbatim +!> NEFr4 is type(mqc_nef_r4) +!> NEF R4 Object to be collapsed. +!> \endverbatim +!> +!> \param[in] excType +!> \verbatim +!> excType is Character(Len=*),Optional +!> excType modiffies the excitations considered +!> Options: +!> 'singlet' => return same spin +!> 'triplet => return opposite spin +!> 'all','full' => return both types (default) +!> \endverbatim +!> +!> \param[in] Order +!> \verbatim +!> Order is integer(kind=int64),dimension(2),intent(in),optional +!> Order contains the indexes to be collapsed following: +!> Order = [i,j] => i->j = p, where i and j are the dimentions +!> (default [1,2]) +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_nef_r4_collapse_map(NEFr4,excType,Order) result(MapOut) +! + implicit none + class(mqc_nef_r4),intent(in)::NEFr4 + character(len=*),intent(in),optional::excType + character(len=64)::selectedExcType + integer(kind=int64),dimension(2),intent(in),optional::Order + integer(kind=int64),dimension(2)::my_order + Type(MQC_SCF_Eigenvalues),Dimension(:),Allocatable::MapOut + Type(MQC_SCF_Eigenvalues),Dimension(:),Allocatable::New_Map_Col,New_Map_Row + integer(kind=int64),dimension(:),Allocatable::my_row,my_col + integer(kind=int64)::ia,ja,ka,la,row,col,id + logical::full_row,full_col +! + if(present(excType)) then + selectedExcType = trim(excType) !singlet, triplet, all + else + selectedExcType = 'singlet' + end if +! + if(present(Order)) then + ia=Order(1) + ja=Order(2) + if (ia.eq.ja) Call MQC_Error_I(& + 'Duplicated index in MQC_nef_matrix_dimention_collapse',& + 6,'ia', ia,'ja',ja) + my_order = Order + else + ia=1 + ja=2 + my_order = [1,2] + endif +! + if(allocated(MapOut)) deallocate(MapOut) + allocate(MapOut(int(NEFr4%blockSize(ia)*NEFr4%blockSize(ja)))) +! + select case(selectedExcType) + case ('singlet') + do row = 1, NEFr4%blockSize(ia) + do col = 1, NEFr4%blockSize(ja) + id = nefR4%blockIndex([1,1],[2,1],[3,row],[4,col]) + call MapOut(id)%init(& + nefR4%blockSize(ia,row,'alpha')*nefR4%blockSize(ja,col,'alpha'),0,& + nefR4%blockSize(ia,row,'beta')*nefR4%blockSize(ja,col,'beta')) + end do + end do + case ('triplet') + do row = 1, NEFr4%blockSize(ia) + do col = 1, NEFr4%blockSize(ja) + id = nefr4%blockIndex([1,1],[2,1],[3,row],[4,col]) + call MapOut(id)%init(& + nefR4%blockSize(ia,row,'alpha')*nefR4%blockSize(ja,col,'beta'),0,& + nefR4%blockSize(ia,row,'beta')*nefR4%blockSize(ja,col,'alpha')) + end do + end do + case ('all','full') + do row = 1, NEFr4%blockSize(ia) + do col = 1, NEFr4%blockSize(ja) + id = nefr4%blockIndex([1,1],[2,1],[3,row],[4,col]) + call MapOut(id)%init(& + nefR4%blockSize(ia,row,'alpha')*(nefR4%blockSize(ja,col,'beta')+& + nefR4%blockSize(ja,col,'alpha')),0,& + nefR4%blockSize(ia,row,'beta')*(nefR4%blockSize(ja,col,'alpha')+& + nefR4%blockSize(ja,col,'beta'))) + end do + end do + case default + call mqc_error_a('mqc_nef_r4_collapse_map: Unrecognized excitation type',6,& + 'selectedExcType',selectedExcType) + end select +! + end function mqc_nef_r4_collapse_map +! +! +! PROCEDURE mqc_nef_vector_output_block_vector +! +!> \brief mqc_nef_vector_output_block_vector is used to output a MQC Vector of an MQC +!> NEF Vector type variable +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> mqc_nef_vector_output_block_vector is used to output a MQC Vector of an MQC +!> NEF Vector type variable +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in,out] nefV +!> \verbatim +!> nefV is Class(MQC_NEF_Vector) +!> The MQC_NEF_Vecotr variable to output. +!> \endverbatim +!> +!> \param[in] indexes +!> \verbatim +!> indexes is integer(kind=int64),dimension(:),optional +!> Contains the indexes of the blocks to be returned. +!> Default: all indexes +!> \endverbatim +!> +!> \param[in] BlockName +!> \verbatim +!> BlockName is character(len=*),optional +!> = 'full': outputs the full MQC_NEF_Vector.(default) +!> = 'alpha','a': outputs the alpha spin block. +!> = 'beta','b': outputs the beta spin block. +!> \endverbatim +!> +!> \param[in] BlockOrder +!> \verbatim +!> BlockOrder is character(len=*),optional +!> = 'beta': orders the output as b->b, b->a, a->b, a->a (default) +!> = 'alpha':orders the output as a->b, a->a, b->b, b->a +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_nef_vector_output_block_vector(nefV,indexes,blockName,BlockOrder) result(vectorOut) +! + implicit none + class(mqc_nef_vector)::nefV + integer(kind=int64),dimension(:),optional::indexes + character(len=*),optional::blockOrder + character(len=*),optional::blockName + type(mqc_vector)::vectorOut + character(len=64)::myBlockName,myBlockOrder + integer(kind=int64),dimension(:),allocatable::myId + logical::full + integer(kind=int64)::fsize,i,j +! + if(present(blockOrder)) then + call string_change_case(blockOrder,'l',myBlockOrder) + else + myBlockOrder = 'beta' + endIf + if(myBlockOrder.ne.'alpha'.and.myBlockOrder.ne.'beta') & + call mqc_error_A('BlockOrder inrecognized in mqc_nef_vector_output_block_vector',6,& + 'myBlockOrder',myBlockOrder) + if(present(blockName)) then + call string_change_case(blockName,'l',myBlockName) + else + myBlockName = 'full' + endIf + if(myBlockName.ne.'alpha'.and.myBlockName.ne.'beta'.and.myBlockName.ne.'full') & + call mqc_error_A('BlockName inrecognized in mqc_nef_vector_output_block_vector',6,& + 'myBlockName',myBlockName) + if(present(indexes)) then + myid = indexes + full=.false. + else + full=.true. + end if +! + fsize = 0 + if (full) then + do i = 1, nefV%NumSpace + if(myBlockName.eq.'alpha'.or.myBlockName.eq.'full') & + fsize = fsize + nefV%Size_vector_alpha(i) + if(myBlockName.eq.'beta'.or.myBlockName.eq.'full') & + fsize = fsize + nefV%Size_vector_beta(i) + end do + else + do i = 1, size(myid) + if(myBlockName.eq.'alpha'.or.myBlockName.eq.'full') & + fsize = fsize + nefV%Size_vector_alpha(myid(i)) + if(myBlockName.eq.'beta'.or.myBlockName.eq.'full') & + fsize = fsize + nefV%Size_vector_beta(myid(i)) + end do + end if + call vectorOut%init(fsize) + if (full) then + fsize = 1 + do i = 1, nefV%NumSpace + if(myBlockOrder.eq.'alpha'.and.myBlockName.eq.'full') then + if (nefV%Main_vector(i)%blockSize('full').gt.0) & + call vectorOut%vput(nefV%Main_vector(i)%getBlock('full'),fsize) + fsize = fsize + nefV%Main_vector(i)%blockSize('full') + else if (myBlockName.eq.'full') then + if (nefV%Main_vector(i)%blockSize('beta').gt.0) & + call vectorOut%vput(nefV%Main_vector(i)%getBlock('beta'),fsize) + fsize = fsize + nefV%Main_vector(i)%blockSize('beta') + if (nefV%Main_vector(i)%blockSize('alpha').gt.0) & + call vectorOut%vput(nefV%Main_vector(i)%getBlock('alpha'),fsize) + fsize = fsize + nefV%Main_vector(i)%blockSize('alpha') + else if (myBlockName.eq.'alpha') then + if (nefV%Main_vector(i)%blockSize('alpha').gt.0) & + call vectorOut%vput(nefV%Main_vector(i)%getBlock('alpha'),fsize) + fsize = fsize + nefV%Main_vector(i)%blockSize('alpha') + else + if (nefV%Main_vector(i)%blockSize('beta').gt.0) & + call vectorOut%vput(nefV%Main_vector(i)%getBlock('beta'),fsize) + fsize = fsize + nefV%Main_vector(i)%blockSize('beta') + end if + end do + else + do j = 1, size(myid) + i = myid(j) + if(myBlockOrder.eq.'alpha'.and.myBlockName.eq.'full') then + if (nefV%Main_vector(i)%blockSize('full').gt.0) & + call vectorOut%vput(nefV%Main_vector(i)%getBlock('full'),fsize) + fsize = fsize + nefV%Main_vector(i)%blockSize('full') + else if (myBlockName.eq.'full') then + if (nefV%Main_vector(i)%blockSize('beta').gt.0) & + call vectorOut%vput(nefV%Main_vector(i)%getBlock('beta'),fsize) + fsize = fsize + nefV%Main_vector(i)%blockSize('beta') + if (nefV%Main_vector(i)%blockSize('alpha').gt.0) & + call vectorOut%vput(nefV%Main_vector(i)%getBlock('alpha'),fsize) + fsize = fsize + nefV%Main_vector(i)%blockSize('alpha') + else if (myBlockName.eq.'alpha') then + if (nefV%Main_vector(i)%blockSize('alpha').gt.0) & + call vectorOut%vput(nefV%Main_vector(i)%getBlock('alpha'),fsize) + fsize = fsize + nefV%Main_vector(i)%blockSize('alpha') + else + if (nefV%Main_vector(i)%blockSize('beta').gt.0) & + call vectorOut%vput(nefV%Main_vector(i)%getBlock('beta'),fsize) + fsize = fsize + nefV%Main_vector(i)%blockSize('beta') + end if + end do + end if +! + end function mqc_nef_vector_output_block_vector +! +! +! PROCEDURE mqc_nef_matrix_output_block_matrix +! +!> \brief mqc_nef_matrix_output_block_matrix is used to output a MQC Matrix of an MQC +!> NEF Matrix type variable +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> mqc_nef_matrix_output_block_matrix is used to output a MQC Matrix of an MQC +!> NEF Matrix type variable +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in,out] nefMat +!> \verbatim +!> nefMat is Class(MQC_NEF_Matrix) +!> The MQC_NEF_Matrix variable to output. +!> \endverbatim +!> +!> \param[in] indexes +!> \verbatim +!> indexes is integer(kind=int64),dimension(:),optional +!> Contains the indexes of the blocks to be returned. +!> Default: all indexes +!> \endverbatim +!> +!> \param[in] indexesKet +!> \verbatim +!> indexesKet is integer(kind=int64),dimension(:),optional +!> Contains the indexes of the blocks to be returned. +!> Default: all indexes +!> \endverbatim +!> +!> \param[in] BlockName +!> \verbatim +!> BlockName is character(len=*),optional +!> = 'full' : outputs the full MQC_NEF_Vector.(default) +!> = 'alpha','a','aa': outputs the alpha spin block. +!> = 'beta', 'b','bb': outputs the beta spin block. +!> = 'alphabeta','ab': outputs the alphabeta spin block. +!> = 'betaalpha','ba': outputs the betaalpha spin block. +!> \endverbatim +!> +!> \param[in] BlockOrder +!> \verbatim +!> BlockOrder is character(len=*),optional +!> = 'beta': orders the output as b->b, b->a, a->b, a->a (default) +!> = 'alpha':orders the output as a->b, a->a, b->b, b->a +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_nef_matrix_output_block_matrix(nefMat,indexes,indexesKet,blockName,& + BlockOrder) result(MatrixOut) +! + implicit none + class(mqc_nef_matrix)::nefMat + integer(kind=int64),dimension(:),optional::indexes,indexesKet + character(len=*),optional::blockOrder + character(len=*),optional::blockName + type(mqc_Matrix)::MatrixOut + character(len=64)::myBlockName,myBlockOrder + integer(kind=int64),dimension(:),allocatable::myId,myIdKet + logical::full,fullKet + integer(kind=int64)::fsize,fsizeKet,i,j,k,p,size1,size2,size3,size4,id +! + if(present(blockOrder)) then + call string_change_case(blockOrder,'l',myBlockOrder) + else + myBlockOrder = 'beta' + endIf + if(myBlockOrder.ne.'alpha'.and.myBlockOrder.ne.'beta') & + call mqc_error_A('BlockOrder inrecognized in mqc_nef_matrix_output_block_matrix',6,& + 'myBlockOrder',myBlockOrder) + if(present(blockName)) then + call string_change_case(blockName,'l',myBlockName) + else + myBlockName = 'full' + endIf + if(myBlockName.ne.'alpha'.and.myBlockName.ne.'beta'.and.myBlockName.ne.'full') & + call mqc_error_A('BlockName inrecognized in mqc_nef_matrix_output_block_matrix',6,& + 'myBlockName',myBlockName) + if(present(indexes)) then + myid = indexes + full = .false. + else + full = .true. + end if + if(present(indexesKet)) then + myidKet = indexesKet + fullKet = .false. + else + fullKet = .true. + end if +! + fsizeKet = 0 + if (full) then + do i = 1, nefMat%NumSpace_col + if(myBlockName.eq.'alpha'.or.myBlockName.eq.'full') & + fsizeKet = fsizeKet + nefMat%Size_vector_alpha_col(i) + if(myBlockName.eq.'beta'.or.myBlockName.eq.'full') & + fsizeKet = fsizeKet + nefMat%Size_vector_beta_col(i) + end do + else + do i = 1, size(myidKet) + if(myBlockName.eq.'alpha'.or.myBlockName.eq.'full') & + fsizeKet = fsizeKet + nefMat%Size_vector_alpha_col(myidKet(i)) + if(myBlockName.eq.'beta'.or.myBlockName.eq.'full') & + fsizeKet = fsizeKet + nefMat%Size_vector_beta_col(myidKet(i)) + end do + end if + fsize = 0 + if (fullKet) then + do i = 1, nefMat%NumSpace_row + if(myBlockName.eq.'alpha'.or.myBlockName.eq.'full') & + fsize = fsize + nefMat%Size_vector_alpha_row(i) + if(myBlockName.eq.'beta'.or.myBlockName.eq.'full') & + fsize = fsize + nefMat%Size_vector_beta_row(i) + end do + else + do i = 1, size(myid) + if(myBlockName.eq.'alpha'.or.myBlockName.eq.'full') & + fsize = fsize + nefMat%Size_vector_alpha_row(myid(i)) + if(myBlockName.eq.'beta'.or.myBlockName.eq.'full') & + fsize = fsize + nefMat%Size_vector_beta_row(myid(i)) + end do + end if + call matrixOut%init(fsize,fsizeKet) + if (full) then + fsize = 1 + do i = 1, nefMat%NumSpace_col + if (fullKet) then + fsizeKet = 1 + do j = 1, nefMat%NumSpace_row + id = nefMat%blockIndex([1,i],[2,j]) + write(*,*) 'i = ',i,' j = ',j,' id = ',id + if(myBlockOrder.eq.'alpha'.and.myBlockName.eq.'full') then + size1 = nefMat%Main_matrix(id)%blockSize('full',1) + size2 = nefMat%Main_matrix(id)%blockSize('full',2) + if (size1.gt.0.and.size2.gt.0) & + call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('full'),& + [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) + fsizeKet = fsizeKet + size2 + else if (myBlockName.eq.'full') then + size1 = nefMat%Main_matrix(id)%blockSize('beta',1) + size2 = nefMat%Main_matrix(id)%blockSize('beta',2) + size3 = nefMat%Main_matrix(id)%blockSize('alpha',1) + size4 = nefMat%Main_matrix(id)%blockSize('alpha',2) + call mqc_print(nefMat%Main_matrix(id)%getBlock('beta'),6,'test beta') + if (size1.gt.0.and.size2.gt.0) & + call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('beta'),& + [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) + call mqc_print(nefMat%Main_matrix(id)%getBlock('betaalpha'),6,'test betaalpha') + if (size3.gt.0.and.size2.gt.0) & + call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('betaalpha'),& + [fsize+size1,fsize+size1+size3-1],[fsizeKet,fsizeKet+size2-1]) + call mqc_print(nefMat%Main_matrix(id)%getBlock('alphabeta'),6,'test alphabeta') + if (size1.gt.0.and.size4.gt.0) & + call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('alphabeta'),& + [fsize,fsize+size1-1],[fsizeKet+size2,fsizeKet+size2+size4-1]) + call mqc_print(nefMat%Main_matrix(id)%getBlock('alpha'),6,'test alpha') + if (size3.gt.0.and.size4.gt.0) & + call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('alpha'),& + [fsize+size1,fsize+size1+size3-1],[fsizeKet+size2,fsizeKet+size2+size4-1]) + fsizeKet = fsizeKet + size2 + size4 + size1 = size1 + size3 + else if (myBlockName.eq.'alpha') then + size1 = nefMat%Main_matrix(id)%blockSize('alpha',1) + size2 = nefMat%Main_matrix(id)%blockSize('alpha',2) + if (size1.gt.0.and.size2.gt.0) & + call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('alpha'),& + [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) + fsizeKet = fsizeKet + size2 + else if (myBlockName.eq.'beta') then + size1 = nefMat%Main_matrix(id)%blockSize('beta',1) + size2 = nefMat%Main_matrix(id)%blockSize('beta',2) + if (size1.gt.0.and.size2.gt.0) & + call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('beta'),& + [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) + fsizeKet = fsizeKet + size2 + else if (myBlockName.eq.'alphabeta') then + size1 = nefMat%Main_matrix(id)%blockSize('alpha',1) + size2 = nefMat%Main_matrix(id)%blockSize('beta',2) + if (size1.gt.0.and.size2.gt.0) & + call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('alphabeta'),& + [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) + fsizeKet = fsizeKet + size2 + else if (myBlockName.eq.'betaalpha') then + size1 = nefMat%Main_matrix(id)%blockSize('beta',1) + size2 = nefMat%Main_matrix(id)%blockSize('alpha',2) + if (size1.gt.0.and.size2.gt.0) & + call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('betaalpha'),& + [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) + fsizeKet = fsizeKet + size2 + else + call mqc_error_a('block name and order pair unrecognized in& + & mqc_nef_matrix_output_block_matrix',6,& + 'myBlockName',myBlockName,'myBlockOrder',myBlockOrder) + end if + end do + else + fsizeKet = 1 + do k = 1, size(myidKet) + j = myidKet(k) + id = nefMat%blockIndex([1,i],[2,j]) + if(myBlockOrder.eq.'alpha'.and.myBlockName.eq.'full') then + size1 = nefMat%Main_matrix(id)%blockSize('full',1) + size2 = nefMat%Main_matrix(id)%blockSize('full',2) + if (size1.gt.0.and.size2.gt.0) & + call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('full'),& + [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) + fsizeKet = fsizeKet + size2 + else if (myBlockName.eq.'full') then + size1 = nefMat%Main_matrix(id)%blockSize('beta',1) + size2 = nefMat%Main_matrix(id)%blockSize('beta',2) + size3 = nefMat%Main_matrix(id)%blockSize('alpha',1) + size4 = nefMat%Main_matrix(id)%blockSize('alpha',2) + if (size1.gt.0.and.size2.gt.0) & + call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('beta'),& + [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) + if (size3.gt.0.and.size2.gt.0) & + call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('betaalpha'),& + [fsize+size1,fsize+size1+size3-1],[fsizeKet,fsizeKet+size2-1]) + if (size1.gt.0.and.size4.gt.0) & + call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('alphabeta'),& + [fsize,fsize+size1-1],[fsizeKet+size2,fsizeKet+size2+size4-1]) + if (size3.gt.0.and.size4.gt.0) & + call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('alpha'),& + [fsize+size1,fsize+size1+size3-1],[fsizeKet+size2,fsizeKet+size2+size4-1]) + fsizeKet = fsizeKet + size2 + size4 + size1 = size1 + size3 + else if (myBlockName.eq.'alpha') then + size1 = nefMat%Main_matrix(id)%blockSize('alpha',1) + size2 = nefMat%Main_matrix(id)%blockSize('alpha',2) + if (size1.gt.0.and.size2.gt.0) & + call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('alpha'),& + [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) + fsizeKet = fsizeKet + size2 + else if (myBlockName.eq.'beta') then + size1 = nefMat%Main_matrix(id)%blockSize('beta',1) + size2 = nefMat%Main_matrix(id)%blockSize('beta',2) + if (size1.gt.0.and.size2.gt.0) & + call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('beta'),& + [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) + fsizeKet = fsizeKet + size2 + else if (myBlockName.eq.'alphabeta') then + size1 = nefMat%Main_matrix(id)%blockSize('alpha',1) + size2 = nefMat%Main_matrix(id)%blockSize('beta',2) + if (size1.gt.0.and.size2.gt.0) & + call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('alphabeta'),& + [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) + fsizeKet = fsizeKet + size2 + else if (myBlockName.eq.'betaalpha') then + size1 = nefMat%Main_matrix(id)%blockSize('beta',1) + size2 = nefMat%Main_matrix(id)%blockSize('alpha',2) + if (size1.gt.0.and.size2.gt.0) & + call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('betaalpha'),& + [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) + fsizeKet = fsizeKet + size2 + else + call mqc_error_a('block name and order pair unrecognized in& + & mqc_nef_matrix_output_block_matrix',6,& + 'myBlockName',myBlockName,'myBlockOrder',myBlockOrder) + end if + end do + end if + fsize = fsize + size1 + end do + else + fsize = 1 + do k = 1, size(myid) + i = myid(k) + if (fullKet) then + fsizeKet = 1 + do j = 1, nefMat%NumSpace_row + id = nefMat%blockIndex([1,i],[2,j]) + if(myBlockOrder.eq.'alpha'.and.myBlockName.eq.'full') then + size1 = nefMat%Main_matrix(id)%blockSize('full',1) + size2 = nefMat%Main_matrix(id)%blockSize('full',2) + if (size1.gt.0.and.size2.gt.0) & + call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('full'),& + [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) + fsizeKet = fsizeKet + size2 + else if (myBlockName.eq.'full') then + size1 = nefMat%Main_matrix(id)%blockSize('beta',1) + size2 = nefMat%Main_matrix(id)%blockSize('beta',2) + size3 = nefMat%Main_matrix(id)%blockSize('alpha',1) + size4 = nefMat%Main_matrix(id)%blockSize('alpha',2) + if (size1.gt.0.and.size2.gt.0) & + call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('beta'),& + [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) + if (size3.gt.0.and.size2.gt.0) & + call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('betaalpha'),& + [fsize+size1,fsize+size1+size3-1],[fsizeKet,fsizeKet+size2-1]) + if (size1.gt.0.and.size4.gt.0) & + call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('alphabeta'),& + [fsize,fsize+size1-1],[fsizeKet+size2,fsizeKet+size2+size4-1]) + if (size3.gt.0.and.size4.gt.0) & + call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('alpha'),& + [fsize+size1,fsize+size1+size3-1],[fsizeKet+size2,fsizeKet+size2+size4-1]) + fsizeKet = fsizeKet + size2 + size4 + size1 = size1 + size3 + else if (myBlockName.eq.'alpha') then + size1 = nefMat%Main_matrix(id)%blockSize('alpha',1) + size2 = nefMat%Main_matrix(id)%blockSize('alpha',2) + if (size1.gt.0.and.size2.gt.0) & + call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('alpha'),& + [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) + fsizeKet = fsizeKet + size2 + else if (myBlockName.eq.'beta') then + size1 = nefMat%Main_matrix(id)%blockSize('beta',1) + size2 = nefMat%Main_matrix(id)%blockSize('beta',2) + if (size1.gt.0.and.size2.gt.0) & + call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('beta'),& + [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) + fsizeKet = fsizeKet + size2 + else if (myBlockName.eq.'alphabeta') then + size1 = nefMat%Main_matrix(id)%blockSize('alpha',1) + size2 = nefMat%Main_matrix(id)%blockSize('beta',2) + if (size1.gt.0.and.size2.gt.0) & + call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('alphabeta'),& + [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) + fsizeKet = fsizeKet + size2 + else if (myBlockName.eq.'betaalpha') then + size1 = nefMat%Main_matrix(id)%blockSize('beta',1) + size2 = nefMat%Main_matrix(id)%blockSize('alpha',2) + if (size1.gt.0.and.size2.gt.0) & + call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('betaalpha'),& + [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) + fsizeKet = fsizeKet + size2 + else + call mqc_error_a('block name and order pair unrecognized in& + & mqc_nef_matrix_output_block_matrix',6,& + 'myBlockName',myBlockName,'myBlockOrder',myBlockOrder) + end if + end do + else + fsizeKet = 1 + do p = 1, size(myidKet) + j = myidKet(p) + id = nefMat%blockIndex([1,i],[2,j]) + if(myBlockOrder.eq.'alpha'.and.myBlockName.eq.'full') then + size1 = nefMat%Main_matrix(id)%blockSize('full',1) + size2 = nefMat%Main_matrix(id)%blockSize('full',2) + if (size1.gt.0.and.size2.gt.0) & + call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('full'),& + [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) + fsizeKet = fsizeKet + size2 + else if (myBlockName.eq.'full') then + size1 = nefMat%Main_matrix(id)%blockSize('beta',1) + size2 = nefMat%Main_matrix(id)%blockSize('beta',2) + size3 = nefMat%Main_matrix(id)%blockSize('alpha',1) + size4 = nefMat%Main_matrix(id)%blockSize('alpha',2) + if (size1.gt.0.and.size2.gt.0) & + call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('beta'),& + [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) + if (size3.gt.0.and.size2.gt.0) & + call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('betaalpha'),& + [fsize+size1,fsize+size1+size3-1],[fsizeKet,fsizeKet+size2-1]) + if (size1.gt.0.and.size4.gt.0) & + call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('alphabeta'),& + [fsize,fsize+size1-1],[fsizeKet+size2,fsizeKet+size2+size4-1]) + if (size3.gt.0.and.size4.gt.0) & + call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('alpha'),& + [fsize+size1,fsize+size1+size3-1],[fsizeKet+size2,fsizeKet+size2+size4-1]) + fsizeKet = fsizeKet + size2 + size4 + size1 = size1 + size3 + else if (myBlockName.eq.'alpha') then + size1 = nefMat%Main_matrix(id)%blockSize('alpha',1) + size2 = nefMat%Main_matrix(id)%blockSize('alpha',2) + if (size1.gt.0.and.size2.gt.0) & + call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('alpha'),& + [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) + fsizeKet = fsizeKet + size2 + else if (myBlockName.eq.'beta') then + size1 = nefMat%Main_matrix(id)%blockSize('beta',1) + size2 = nefMat%Main_matrix(id)%blockSize('beta',2) + if (size1.gt.0.and.size2.gt.0) & + call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('beta'),& + [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) + fsizeKet = fsizeKet + size2 + else if (myBlockName.eq.'alphabeta') then + size1 = nefMat%Main_matrix(id)%blockSize('alpha',1) + size2 = nefMat%Main_matrix(id)%blockSize('beta',2) + if (size1.gt.0.and.size2.gt.0) & + call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('alphabeta'),& + [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) + fsizeKet = fsizeKet + size2 + else if (myBlockName.eq.'betaalpha') then + size1 = nefMat%Main_matrix(id)%blockSize('beta',1) + size2 = nefMat%Main_matrix(id)%blockSize('alpha',2) + if (size1.gt.0.and.size2.gt.0) & + call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('betaalpha'),& + [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) + fsizeKet = fsizeKet + size2 + else + call mqc_error_a('block name and order pair unrecognized in& + & mqc_nef_matrix_output_block_matrix',6,& + 'myBlockName',myBlockName,'myBlockOrder',myBlockOrder) + end if + end do + end if + fsize = fsize + size1 + end do + end if + write(*,*) 'MMFM: Date: Tue, 9 Jun 2026 13:04:48 -0400 Subject: [PATCH 32/37] Added: Eigenvalues exponential --- src/mqc_est.F03 | 101 +++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 96 insertions(+), 5 deletions(-) diff --git a/src/mqc_est.F03 b/src/mqc_est.F03 index 0b2725f7..ade21d17 100644 --- a/src/mqc_est.F03 +++ b/src/mqc_est.F03 @@ -207,6 +207,8 @@ Module MQC_EST Procedure, Public::maxloc => MQC_Eigenvalues_MaxLoc !> \brief Returns the absolute values of elements in MQC_SCF_Eigenvalues Procedure, Public::abs => MQC_Eigenvalues_Abs +!> \brief Returns the exponential of the MQC_SCF_Eigenvalues + Procedure, Public::exp => MQC_Eigenvalues_Exp !> \brief Returns a mqc_scf_integral with values specified by the mqc_scf_eigenvalues Procedure, Public::diagf => mqc_eigenvalues_to_integral !> \brief Returns the eigenvalues sorted from low to high unless vector specifying @@ -443,6 +445,11 @@ Module MQC_EST Module Procedure MQC_Eigenvalues_MinLoc End Interface ! +!> \brief Returns the exponential + Interface Exp + Module Procedure MQC_Eigenvalues_Exp_Func + End Interface +! !> \brief Returns the absolute values of elements in MQC_SCF_Eigenvalues Interface abs Module Procedure MQC_Eigenvalues_Abs @@ -14233,10 +14240,6 @@ function mqc_eri_eri_contraction(eris1,eris2,label) result(output) ! 6,'myLabel',myLabel) !end select - write(*,*) 'DEBUG: ERI_ERI Contraction' - write(*,*) 'ERIs 1',eris1%Type(),eris1%storType() - write(*,*) 'ERIs 2',eris2%Type(),eris2%storType() - if(myLabel.ne.'coulomb') temp = eris1%swap(2,4) output = 0.0 if(eris1%storType().eq.'empty'.or.eris2%storType().eq.'empty') return @@ -21329,6 +21332,94 @@ function mqc_eigenvalues_maxloc(eigenvalues,label) result(output) end function mqc_eigenvalues_maxloc ! ! +! PROCEDURE MQC_Eigenvalues_Exp_Func +! +!> \brief MQC_Eigenvalues_Exp is a function that returns the exponential of all +!> elements of an MQC_SCF_Eigenvalues +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_Eigenvalues_Exp_Func is a function that returns the exponential of all +!> elements of an MQC_SCF_Eigenvalues +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in,out] Eigenvalues +!> \verbatim +!> Eigenvalues is Class(MQC_scf_Eigenvalues) +!> The name of the MQC_Eigenvalues variable. +!> \endverbatim +! +! Authors: +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_eigenvalues_exp_func(Eigenvalues) result(output) +! + Implicit None + class(mqc_scf_eigenvalues),intent(in)::Eigenvalues + type(mqc_scf_eigenvalues)::output + integer(kind=int64)::i +! + output = Eigenvalues + if(Eigenvalues%hasalpha()) output%alpha = exp(Eigenvalues%alpha) + if(Eigenvalues%hasbeta()) output%beta = exp(Eigenvalues%beta) +! + end function mqc_eigenvalues_exp_func +! +! +! +! PROCEDURE MQC_Eigenvalues_Exp +! +!> \brief MQC_Eigenvalues_Exp is a subroutine that returns the exponential of all +!> elements of an MQC_SCF_Eigenvalues +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_Eigenvalues_Exp is a subroutine that returns the exponential of all +!> elements of an MQC_SCF_Eigenvalues +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in,out] Eigenvalues +!> \verbatim +!> Eigenvalues is Class(MQC_scf_Eigenvalues) +!> The name of the MQC_Eigenvalues variable. +!> \endverbatim +! +! Authors: +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + subroutine mqc_eigenvalues_exp(Eigenvalues) +! + Implicit None + class(mqc_scf_eigenvalues),intent(inOut)::Eigenvalues + integer(kind=int64)::i +! + if(Eigenvalues%hasalpha()) Eigenvalues%alpha = exp(Eigenvalues%alpha) + if(Eigenvalues%hasbeta()) Eigenvalues%beta = exp(Eigenvalues%beta) +! + end subroutine mqc_eigenvalues_exp +! +! +! ! PROCEDURE MQC_Eigenvalues_Abs ! !> \brief MQC_Eigenvalues_Abs is a function that returns the absolute @@ -21348,7 +21439,7 @@ end function mqc_eigenvalues_maxloc ! ========== !> \param[in,out] Eigenvalues !> \verbatim -!> Eigenvalues is Class(MQC_Eigenvalues) +!> Eigenvalues is Class(MQC_scf_Eigenvalues) !> The name of the MQC_Eigenvalues variable. !> \endverbatim ! From ef27e9b3759697cdfb84b202497791aa4d39edfb Mon Sep 17 00:00:00 2001 From: njwool01 Date: Tue, 9 Jun 2026 15:50:06 -0400 Subject: [PATCH 33/37] Added Subtraction for eigenvalues, and exponentials for eigenvalues --- src/mqc_est.F03 | 233 +++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 229 insertions(+), 4 deletions(-) diff --git a/src/mqc_est.F03 b/src/mqc_est.F03 index 76af7e9a..122cbe55 100644 --- a/src/mqc_est.F03 +++ b/src/mqc_est.F03 @@ -207,6 +207,8 @@ Module MQC_EST Procedure, Public::maxloc => MQC_Eigenvalues_MaxLoc !> \brief Returns the absolute values of elements in MQC_SCF_Eigenvalues Procedure, Public::abs => MQC_Eigenvalues_Abs +!> \brief Returns the exponential of MQC_SCF_Eigenvalues + Procedure, Public::exp => MQC_Eigenvalues_exp !> \brief Returns a mqc_scf_integral with values specified by the mqc_scf_eigenvalues Procedure, Public::diagf => mqc_eigenvalues_to_integral !> \brief Returns the eigenvalues sorted from low to high unless vector specifying @@ -494,6 +496,11 @@ Module MQC_EST Module Procedure MQC_Eigenvalues_MinLoc End Interface ! +!> \brief Returns the exponent + Interface exp + Module Procedure MQC_Eigenvalues_exp_func + End Interface +! !> \brief Returns the absolute values of elements in MQC_SCF_Eigenvalues Interface abs Module Procedure MQC_Eigenvalues_Abs @@ -522,8 +529,8 @@ Module MQC_EST ! !> \brief Assigns a variable to the value of another Interface Assignment (=) - Module Procedure MQC_Integral_Output_Array Module Procedure MQC_Eigenvalues_Output_Array + Module Procedure MQC_Integral_Output_Array Module Procedure mqc_2ERIs_output_array Module Procedure mqc_set_integral2integral Module Procedure mqc_set_eigs2eigs @@ -543,9 +550,10 @@ Module MQC_EST ! !> \brief Subtracts two variables Interface Operator (-) + Module Procedure MQC_Eigenvalues_Difference Module Procedure MQC_Integral_Difference Module Procedure MQC_Matrix_Integral_Difference - Module Procedure MQC_ERI_Difference + Module Procedure MQC_ERI_Difference End Interface ! !> \brief Multiplies two variables @@ -7961,6 +7969,144 @@ function mqc_Eigenvalues_sum(EigA,EigB) result(EigOut) end function mqc_eigenvalues_sum ! ! +! PROCEDURE MQC_Eigenvalues_Difference +! +!> \brief MQC_Eigenvalues_Difference is used to subtract two MQC Eigenvalues type variables +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_Eigenvalues_Difference is used to subtract two MQC Eigenvalues type variables. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] EigA +!> \verbatim +!> EigA is type(mqc_scf_Eigenvalues) +!> The first MQC Eigenvalues variable to subtract. +!> \endverbatim +!> +!> \param[in] EigB +!> \verbatim +!> EigB is type(mqc_scf_Eigenvalues) +!> The second MQC Eigenvalues variable to sutract. +!> \endverbatim +! +! Authors: +! ======== +!> \author N. J. Woolery +!> \date 2026 +! + function mqc_Eigenvalues_Difference(EigA,EigB) result(EigOut) +! + implicit none + type(mqc_scf_Eigenvalues),intent(in)::EigA,EigB + type(mqc_scf_Eigenvalues)::EigOut + type(mqc_vector)::tmpVectorAlpha,tmpVectorBeta +! + if(size(EigA,'alpha').ne.size(EigB,'alpha').or.& + size(EigA,'beta').ne.size(EigA,'beta')) call mqc_error_i('Integral blocks are & + ¬ conformable in mqc_Eigenvalues_Difference',6,& + 'size(EigA,alpha)',size(EigA,'alpha'),& + 'size(EigB,alpha)',size(EigB,'alpha'),& + 'size(EigA,beta)',size(EigA,'beta'),& + 'size(EigB,beta)',size(EigB,'beta')) +! + select case(EigA%array_type) + case('space') + select case (EigB%array_type) + case('space') + if(EigA%hasAlpha()) then + if(EigB%hasAlpha()) then + tmpVectorAlpha = EigA%alpha-EigB%alpha + else + tmpVectorAlpha = EigA%alpha + end if + else + if(EigB%hasAlpha()) tmpVectorAlpha = EigB%alpha*(-1) + end if + call mqc_eigenvalues_allocate(EigOut,'','space',tmpVectorAlpha) + case('spin') + if(EigA%hasAlpha()) then + if(EigB%hasAlpha()) then + tmpVectorAlpha = EigA%alpha-EigB%alpha + else + tmpVectorAlpha = EigA%alpha + end if + else + if(EigB%hasAlpha()) tmpVectorAlpha = EigB%alpha*(-1) + end if + if(EigA%hasAlpha()) then + if(EigB%hasBeta()) then + tmpVectorBeta = EigA%alpha-EigB%beta + else + tmpVectorBeta = EigA%alpha + end if + else + if(EigB%hasBeta()) tmpVectorBeta = EigB%beta*(-1) + end if + call mqc_eigenvalues_allocate(EigOut,'','spin',tmpVectorAlpha,tmpVectorBeta) + case default + call mqc_error_A('Unknown integral type in mqc_eigenvalues_Difference', 6, & + 'EigB%array_type', EigB%array_type ) + end select + case('spin') + select case (EigB%array_type) + case('space') + if(EigA%hasAlpha()) then + if(EigB%hasAlpha()) then + tmpVectorAlpha = EigA%alpha-EigB%alpha + else + tmpVectorAlpha = EigA%alpha + end if + else + if(EigB%hasAlpha()) tmpVectorAlpha = EigB%alpha*(-1) + end if + if(EigA%hasBeta()) then + if(EigB%hasAlpha()) then + tmpVectorBeta = EigA%beta-EigB%alpha + else + tmpVectorBeta = EigA%beta + end if + else + if(EigB%hasAlpha()) tmpVectorBeta = EigB%alpha*(-1) + end if + call mqc_eigenvalues_allocate(EigOut,'','spin',tmpVectorAlpha,tmpVectorBeta) + case('spin') + if(EigA%hasAlpha()) then + if(EigB%hasAlpha()) then + tmpVectorAlpha = EigA%alpha-EigB%alpha + else + tmpVectorAlpha = EigA%alpha + end if + else + if(EigB%hasAlpha()) tmpVectorAlpha = EigB%alpha*(-1) + end if + if(EigA%hasBeta()) then + if(EigB%hasBeta()) then + tmpVectorBeta = EigA%beta-EigB%beta + else + tmpVectorBeta = EigA%beta + end if + else + if(EigB%hasBeta()) tmpVectorBeta = EigB%beta*(-1) + end if + call mqc_eigenvalues_allocate(EigOut,'','spin',tmpVectorAlpha,tmpVectorBeta) + case default + call mqc_error_A('Unknown integral type in mqc_eigenvalues_Difference', 6, & + 'EigB%array_type', EigB%array_type ) + end select + case default + call mqc_error_A('Unknown integral type in mqc_eigenvalues_Difference', 6, & + 'EigA%array_type', EigA%array_type ) + end select +! + end function mqc_eigenvalues_Difference +! ! PROCEDURE MQC_Integral_Sum ! !> \brief MQC_Integral_Sum is used to sum two MQC integral type variables @@ -10882,7 +11028,7 @@ end function mqc_scalar_integral_multiply ! ! Authors: ! ======== -!> \author M. M. F. Moras +!> \author M. M. F. Moraes !> \date 2026 ! function mqc_scalar_eigenvalues_multiply(scalarIn,eigB) result(eigOut) @@ -10966,7 +11112,7 @@ end function mqc_scalar_eigenvalues_multiply ! ! Authors: ! ======== -!> \author M. M. F. Moras +!> \author M. M. F. Moraes !> \date 2026 ! function mqc_eigenvalues_scalar_multiply(eig,scalarIn) result(eigOut) @@ -22038,6 +22184,85 @@ function mqc_eigenvalues_maxloc(eigenvalues,label) result(output) ! end function mqc_eigenvalues_maxloc ! +! +! PROCEDURE MQC_Eigenvalues_exp_func +! +!> \brief MQC_Eigenvalues_exp_func is a function that returns the +!> exponential of an MQC_Eigenvalues variable +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_Eigenvalues_exp_func is a function that returns the exponential +!> of an MQC_Eigenvalues variable +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in,out] Eigenvalues +!> \verbatim +!> Eigenvalues is Class(MQC_Eigenvalues) +!> The name of the MQC_Eigenvalues variable. +!> \endverbatim +! +! Authors: +! ======== +!> \author N. J. Woolery +!> \date 2026 +! + function mqc_eigenvalues_exp_func(eigenvalues) result(output) +! + implicit none + class(mqc_scf_eigenvalues),intent(in)::eigenvalues + type(mqc_scf_eigenvalues)::output +! + output = eigenvalues + if(output%hasalpha()) output%alpha = exp(output%alpha) + if(output%hasbeta()) output%beta = exp(output%beta) +! + end function mqc_eigenvalues_exp_func +! +! PROCEDURE MQC_Eigenvalues_exp +! +!> \brief MQC_Eigenvalues_exp is a subroutine that returns the +!> exponential of an MQC_Eigenvalues variable +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_Eigenvalues_exp is a subroutine that returns the exponential +!> of an MQC_Eigenvalues variable +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in,out] Eigenvalues +!> \verbatim +!> Eigenvalues is Class(MQC_Eigenvalues) +!> The name of the MQC_Eigenvalues variable. +!> \endverbatim +! +! Authors: +! ======== +!> \author N. J. Woolery +!> \date 2026 +! + subroutine mqc_eigenvalues_exp(eigenvalues) +! + implicit none + class(mqc_scf_eigenvalues),intent(inOut)::eigenvalues +! + if(eigenvalues%hasalpha()) eigenvalues%alpha = exp(eigenvalues%alpha) + if(eigenvalues%hasbeta()) eigenvalues%beta = exp(eigenvalues%beta) +! + end subroutine mqc_eigenvalues_exp + ! ! PROCEDURE MQC_Eigenvalues_Abs ! From e66737885130d2a36a38cb9db17dbe28593853a3 Mon Sep 17 00:00:00 2001 From: njwool01 Date: Thu, 11 Jun 2026 15:15:23 -0400 Subject: [PATCH 34/37] added NEFVector subtraction :) --- src/mqc_nef.F03 | 92 +++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 77 insertions(+), 15 deletions(-) diff --git a/src/mqc_nef.F03 b/src/mqc_nef.F03 index de0c456e..322f22b2 100644 --- a/src/mqc_nef.F03 +++ b/src/mqc_nef.F03 @@ -154,6 +154,12 @@ Module MQC_NEF Module Procedure MQC_Scalar_NEFR4_Multiply Module Procedure MQC_NEFR4_Scalar_Multiply End Interface + + !> \brief Subtracts two variables + Interface Operator (-) + Module Procedure MQC_NEF_Vector_Difference + End Interface + ! ! ! @@ -1122,8 +1128,8 @@ function mqc_nef_vector_sum(NEFVecA,NEFVecB) result(NEFVecOut) 'NEFVecB%NumSpace',NEFVecB%NumSpace) ! do col = 1, NEFVecA%NumSpace - if (NEFVecA%Size_vector_alpha(col).ne.& - NEFVecB%Size_vector_alpha(col)) & + if (NEFVecA%Size_vector_alpha(col).ne.NEFVecB%Size_vector_alpha(col) .or. & + NEFVecA%Size_vector_beta(col) .ne.NEFVecB%Size_vector_beta(col)) & call mqc_error_i('NEF subspace dimensions are & ¬ conformable in mqc_nef_vector_sum',6,& 'Sub-space index (col)', col,& @@ -1933,6 +1939,74 @@ function mqc_nefr4_scalar_multiply(NEFR4,scalarB) result(NEFR4Out) end function mqc_nefr4_scalar_multiply ! ! +! +! PROCEDURE MQC_NEF_Vector_Difference +! +!> \brief MQC_NEF_Vector_Difference is used to subtract two MQC NEF Vector type variables +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEF_Vector_Difference is used to subtract two MQC NEF vector type variables +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] NEFVecA +!> \verbatim +!> NEFVecA is type(mqc_nef_vector) +!> The first MQC NEF Vector variable to subtract. +!> \endverbatim +!> +!> \param[in] NEFVecB +!> \verbatim +!> NEFVecB is type(mqc_nef_vector) +!> The second MQC NEF Vector variable to subtract. +!> \endverbatim +! +! Authors: +! ======== +!> \author N. J. Woolery +!> \date 2026 +! + function mqc_nef_vector_difference(NEFVecA,NEFVecB) result(NEFVecOut) +! + implicit none + type(mqc_nef_vector),intent(in)::NEFVecA,NEFVecB + type(mqc_nef_vector)::NEFVecOut + type(mqc_nef_vector)::tmpVectorAlpha,tmpVectorBeta + integer::col +! + if(NEFVecA%NumSpace.ne.NEFVecB%NumSpace) & + call mqc_error_i('NEF number of subspaces are & + ¬ conformable in mqc_nef_vector_difference',6,& + 'NEFVecA%NumSpace',NEFVecA%NumSpace,& + 'NEFVecB%NumSpace',NEFVecB%NumSpace) +! + do col = 1, NEFVecA%NumSpace + if (NEFVecA%Size_vector_alpha(col).ne.NEFVecB%Size_vector_alpha(col) .or. & + NEFVecA%Size_vector_beta(col) .ne.NEFVecB%Size_vector_beta(col)) & + call mqc_error_i('NEF subspace dimensions are not conformable & + &in mqc_nef_vector_difference',6,& + 'Sub-space index (col)', col,& + 'NEFVecA%Size_vector_alpha(col)',NEFVecA%Size_vector_alpha(col),& + 'NEFVecB%Size_vector_alpha(col)',NEFVecB%Size_vector_alpha(col),& + 'NEFVecA%Size_vector_beta(col)',NEFVecA%Size_vector_beta(col),& + 'NEFVecB%Size_vector_beta(col)',NEFVecB%Size_vector_beta(col)) + end do +! + call NEFVecOut%init(NEFVecA%Map_Matrix) + do col = 1, NEFVecB%NumSpace + NEFVecOut%Main_Vector(col) = NEFVecA%Main_Vector(col) - NEFVecB%Main_Vector(col) + end do +! +! + end function mqc_nef_vector_difference +! +! ! PROCEDURE MQC_Print_NEF_R4 ! !> \brief MQC_Print_NEF_R4 is a subroutine used to print an MQC @@ -2016,6 +2090,7 @@ subroutine mqc_print_nef_r4(NEFR4,iOut,header, & ! 1000 Format(1x,A) 1020 Format( " " ) +! ! if(present(blank_at_top)) then if(blank_at_top) write(iout,1020) @@ -6324,23 +6399,10 @@ function mqc_nef_matrix_output_block_matrix(nefMat,indexes,indexesKet,blockName, [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) fsizeKet = fsizeKet + size2 else if (myBlockName.eq.'beta') then - size1 = nefMat%Main_matrix(id)%blockSize('beta',1) - size2 = nefMat%Main_matrix(id)%blockSize('beta',2) - if (size1.gt.0.and.size2.gt.0) & - call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('beta'),& - [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) - fsizeKet = fsizeKet + size2 - else if (myBlockName.eq.'alphabeta') then - size1 = nefMat%Main_matrix(id)%blockSize('alpha',1) - size2 = nefMat%Main_matrix(id)%blockSize('beta',2) - if (size1.gt.0.and.size2.gt.0) & - call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('alphabeta'),& - [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) fsizeKet = fsizeKet + size2 else if (myBlockName.eq.'betaalpha') then size1 = nefMat%Main_matrix(id)%blockSize('beta',1) size2 = nefMat%Main_matrix(id)%blockSize('alpha',2) - if (size1.gt.0.and.size2.gt.0) & call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('betaalpha'),& [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) fsizeKet = fsizeKet + size2 From 0f708164fe1628e761d40f0a1e92922cc6ffa11c Mon Sep 17 00:00:00 2001 From: njwool01 Date: Thu, 11 Jun 2026 16:39:57 -0400 Subject: [PATCH 35/37] added matrix and r4 tensor subtraction for NEF --- src/mqc_nef.F03 | 217 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 217 insertions(+) diff --git a/src/mqc_nef.F03 b/src/mqc_nef.F03 index 322f22b2..f68ffcff 100644 --- a/src/mqc_nef.F03 +++ b/src/mqc_nef.F03 @@ -158,6 +158,8 @@ Module MQC_NEF !> \brief Subtracts two variables Interface Operator (-) Module Procedure MQC_NEF_Vector_Difference + Module Procedure MQC_NEFMatrix_Difference + Module Procedure MQC_NEF_R4_Difference End Interface ! @@ -2006,6 +2008,221 @@ function mqc_nef_vector_difference(NEFVecA,NEFVecB) result(NEFVecOut) ! end function mqc_nef_vector_difference ! + +! +! PROCEDURE MQC_NEFMatrix_Difference +! +!> \brief MQC_NEFMatrix_Difference is used to subtract two MQC NEF matrix type variables +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEFMatrix_Difference is used to subtract two MQC NEF matrix type variables +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] NEFMatA +!> \verbatim +!> NEFMatA is type(mqc_nef_matrix) +!> The first MQC NEF Matrix variable to sum. +!> \endverbatim +!> +!> \param[in] NEFMatB +!> \verbatim +!> NEFMatB is type(mqc_nef_matrix) +!> The second MQC NEF Matrix variable to sum. +!> \endverbatim +! +! Authors: +! ======== +!> \author N. J. Woolery +!> \date 2026 +! + function mqc_nefmatrix_difference(NEFMatA,NEFMatB) result(NEFMatOut) +! + implicit none + type(mqc_nef_matrix),intent(in)::NEFMatA,NEFMatB + type(mqc_nef_matrix)::NEFMatOut + integer::col,row,id +! + if(NEFMatA%NumSpace_col.ne.NEFMatB%NumSpace_col.or.& + NEFMatA%NumSpace_row.ne.NEFMatB%NumSpace_row) & + call mqc_error_i('NEF number of subspaces are & + ¬ conformable in mqc_nefmatrix_difference',6,& + 'NEFMatA%NumSpace_col',NEFMatA%NumSpace_col,& + 'NEFMatB%NumSpace_col',NEFMatB%NumSpace_col,& + 'NEFMatA%NumSpace_row',NEFMatA%NumSpace_row,& + 'NEFMatB%NumSpace_row',NEFMatB%NumSpace_row) + + do col = 1, NEFMatA%NumSpace_col + if(NEFMatA%Size_vector_alpha_col(col)& + .ne.NEFMatB%Size_vector_alpha_col(col).or. & + NEFMatA%Size_vector_beta_col(col) & + .ne.NEFMatB%Size_vector_beta_col(col)) & + call mqc_error_i('NEF subspace dimensions are & + ¬ conformable in mqc_nefmatrix_difference',6,& + 'Sub-space index (col)', col,& + 'NEFMatA%Size_vector_alpha_col(col)',NEFMatA%Size_vector_alpha_col(col),& + 'NEFMatB%Size_vector_alpha_col(col)',NEFMatB%Size_vector_alpha_col(col),& + 'NEFMatA%Size_vector_beta_col(col)',NEFMatA%Size_vector_beta_col(col),& + 'NEFMatB%Size_vector_beta_col(col)',NEFMatB%Size_vector_beta_col(col)) + end do + do row = 1, NEFMatA%NumSpace_row + if(NEFMatA%Size_vector_alpha_row(row)& + .ne.NEFMatB%Size_vector_alpha_row(row).or. & + NEFMatA%Size_vector_beta_row(row) & + .ne.NEFMatB%Size_vector_beta_row(row)) & + call mqc_error_i('NEF subspace dimensions are & + ¬ conformable in mqc_nefmatrix_difference',6,& + 'Sub-space index (row)', row,& + 'NEFMatA%Size_vector_alpha_row(row)',NEFMatA%Size_vector_alpha_row(row),& + 'NEFMatB%Size_vector_alpha_row(row)',NEFMatB%Size_vector_alpha_row(row),& + 'NEFMatA%Size_vector_beta_row(row)',NEFMatA%Size_vector_beta_row(row),& + 'NEFMatB%Size_vector_beta_row(row)',NEFMatB%Size_vector_beta_row(row)) + end do + + call NEFMatOut%init(NEFMatA%Map_Matrix_Row,& + initial_map_matrix_col=NEFMatB%Map_Matrix_Col) + do row = 1, NEFMatA%NumSpace_row + do col = 1, NEFMatB%NumSpace_col + id = NEFMatOut%blockIndex([1,row],[2,col]) + NEFMatOut%Main_Matrix(id) = NEFMatA%Main_Matrix(id)-NEFMatB%Main_Matrix(id) + end do + end do + end function mqc_nefmatrix_difference +! +! +! PROCEDURE MQC_NEF_R4_Difference +! +!> \brief MQC_NEF_R4_Difference is used to subtract two MQC NEF R4 type variables +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEF_R4_Difference is used to subtract two MQC NEF R4 type variables +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] NEFR4A +!> \verbatim +!> NEFR4A is type(mqc_nef_r4) +!> The first MQC NEF R4 variable to sum. +!> \endverbatim +!> +!> \param[in] NEFR4B +!> \verbatim +!> NEFR4B is type(mqc_nef_r4) +!> The second MQC NEF R4 variable to sum. +!> \endverbatim +! +! Authors: +! ======== +!> \author N. J. Woolery +!> \date 2026 +! + function mqc_nef_r4_difference(NEFR4A,NEFR4B) result(NEFR4Out) +! + implicit none + type(mqc_nef_r4),intent(in)::NEFR4A,NEFR4B + type(mqc_nef_r4)::NEFR4Out + integer::id1,id2,id3,id4,id +! + if(NEFR4A%NumSpace_1.ne.NEFR4B%NumSpace_1)& + call mqc_error_i('NEF number of subspaces are & + ¬ conformable in mqc_nef_r4_difference',6,& + 'NEFR4A%NumSpace_1',NEFR4A%NumSpace_1,& + 'NEFR4B%NumSpace_1',NEFR4B%NumSpace_1) + if(NEFR4A%NumSpace_2.ne.NEFR4B%NumSpace_2)& + call mqc_error_i('NEF number of subspaces are & + ¬ conformable in mqc_nef_r4_difference',6,& + 'NEFR4A%NumSpace_2',NEFR4A%NumSpace_2,& + 'NEFR4B%NumSpace_2',NEFR4B%NumSpace_2) + if(NEFR4A%NumSpace_3.ne.NEFR4B%NumSpace_3)& + call mqc_error_i('NEF number of subspaces are & + ¬ conformable in mqc_nef_r4_difference',6,& + 'NEFR4A%NumSpace_3',NEFR4A%NumSpace_3,& + 'NEFR4B%NumSpace_3',NEFR4B%NumSpace_3) + if(NEFR4A%NumSpace_4.ne.NEFR4B%NumSpace_4)& + call mqc_error_i('NEF number of subspaces are & + ¬ conformable in mqc_nef_r4_difference',6,& + 'NEFR4A%NumSpace_4',NEFR4A%NumSpace_4,& + 'NEFR4B%NumSpace_4',NEFR4B%NumSpace_4) + + do id1 = 1, NEFR4A%NumSpace_1 + if(NEFR4A%Size_vector_alpha_1(id1)& + .ne.NEFR4B%Size_vector_alpha_1(id1).or.& + NEFR4A%Size_vector_beta_1(id1)& + .ne.NEFR4B%Size_vector_beta_1(id1))& + call mqc_error_i('NEF subspace dimensions are & + ¬ conformable in mqc_nef_r4_difference',6,& + 'Sub-space index (id1)', id1,& + 'NEFR4A%Size_vector_alpha_1(id1)',NEFR4A%Size_vector_alpha_1(id1),& + 'NEFR4B%Size_vector_alpha_1(id1)',NEFR4B%Size_vector_alpha_1(id1),& + 'NEFR4A%Size_vector_beta_1(id1)',NEFR4A%Size_vector_beta_1(id1),& + 'NEFR4B%Size_vector_beta_1(id1)',NEFR4B%Size_vector_beta_1(id1)) + end do + do id2 = 1, NEFR4A%NumSpace_2 + if(NEFR4A%Size_vector_alpha_2(id2)& + .ne.NEFR4B%Size_vector_alpha_2(id2).or.& + NEFR4A%Size_vector_beta_2(id2)& + .ne.NEFR4B%Size_vector_beta_2(id2))& + call mqc_error_i('NEF subspace dimensions are & + ¬ conformable in mqc_nef_r4_difference',6,& + 'Sub-space index (id2)', id2,& + 'NEFR4A%Size_vector_alpha_2(id2)',NEFR4A%Size_vector_alpha_2(id2),& + 'NEFR4B%Size_vector_alpha_2(id2)',NEFR4B%Size_vector_alpha_2(id2),& + 'NEFR4A%Size_vector_beta_2(id2)', NEFR4A%Size_vector_beta_2(id2),& + 'NEFR4B%Size_vector_beta_2(id2)', NEFR4B%Size_vector_beta_2(id2)) + end do + do id3 = 1, NEFR4A%NumSpace_3 + if(NEFR4A%Size_vector_alpha_3(id3)& + .ne.NEFR4B%Size_vector_alpha_3(id3).or.& + NEFR4A%Size_vector_beta_3(id3)& + .ne.NEFR4B%Size_vector_beta_3(id3))& + call mqc_error_i('NEF subspace dimensions are & + ¬ conformable in mqc_nef_r4_difference',6,& + 'Sub-space index (id3)', id3,& + 'NEFR4A%Size_vector_alpha_3(id3)',NEFR4A%Size_vector_alpha_3(id3),& + 'NEFR4B%Size_vector_alpha_3(id3)',NEFR4B%Size_vector_alpha_3(id3),& + 'NEFR4A%Size_vector_beta_3(id3)', NEFR4A%Size_vector_beta_3(id3),& + 'NEFR4B%Size_vector_beta_3(id3)', NEFR4B%Size_vector_beta_3(id3)) + end do + do id4 = 1, NEFR4A%NumSpace_4 + if(NEFR4A%Size_vector_alpha_4(id4)& + .ne.NEFR4B%Size_vector_alpha_4(id4).or.& + NEFR4A%Size_vector_beta_4(id4)& + .ne.NEFR4B%Size_vector_beta_4(id4))& + call mqc_error_i('NEF subspace dimensions are & + ¬ conformable in mqc_nef_r4_difference',6,& + 'Sub-space index (id4)', id4,& + 'NEFR4A%Size_vector_alpha_4(id4)',NEFR4A%Size_vector_alpha_4(id4),& + 'NEFR4B%Size_vector_alpha_4(id4)',NEFR4B%Size_vector_alpha_4(id4),& + 'NEFR4A%Size_vector_beta_4(id4)', NEFR4A%Size_vector_beta_4(id4),& + 'NEFR4B%Size_vector_beta_4(id4)', NEFR4B%Size_vector_beta_4(id4)) + end do + + + NEFR4Out = NEFR4A + do id1 = 1, NEFR4Out%NumSpace_1 + do id2 = 1, NEFR4Out%NumSpace_2 + do id3 = 1, NEFR4Out%NumSpace_3 + do id4 = 1, NEFR4Out%NumSpace_4 + id = NEFR4Out%blockIndex([4,id4],[3,id3],[2,id2],[1,id1]) + NEFR4Out%Main_R4(id) = NEFR4A%Main_R4(id) - NEFR4B%Main_R4(id) + end do + end do + end do + end do + end function mqc_nef_r4_difference +! ! ! PROCEDURE MQC_Print_NEF_R4 ! From 22e7263b5d19eedc65c81117d0e1e8daac886812 Mon Sep 17 00:00:00 2001 From: njwool01 Date: Wed, 22 Jul 2026 16:29:53 -0400 Subject: [PATCH 36/37] Added a function for adding to a nef matrix map function, implemented dimension functions for nef matrices and vectors -N.J. Woolery :D --- src/mqc_est.F03 | 10 +- src/mqc_nef.F03 | 565 ++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 574 insertions(+), 1 deletion(-) diff --git a/src/mqc_est.F03 b/src/mqc_est.F03 index 122cbe55..9d9a4165 100644 --- a/src/mqc_est.F03 +++ b/src/mqc_est.F03 @@ -2578,7 +2578,8 @@ end function mqc_eigenvalues_dimension !> \param[in] length !> \verbatim !> Length is Integer(kind=int64) -!> The length to initialize eigenvalues object +!> The length to initialize eigenvalues object. If length beta is +!> not given, length is the length of both alpha and beta !> \endverbatim !> !> @@ -2589,6 +2590,13 @@ end function mqc_eigenvalues_dimension !> the value is set to 0.0. Can be of type integer, real, !> complex or MQC_Scalar. !> \endverbatim +!> +!> \param[in] lengthBeta +!> \verbatim +!> Length is Integer(kind=int64), Optional +!> The length of the beta block. +!> \endverbatim +!> ! ! Authors: ! ======== diff --git a/src/mqc_nef.F03 b/src/mqc_nef.F03 index f68ffcff..431de0f5 100644 --- a/src/mqc_nef.F03 +++ b/src/mqc_nef.F03 @@ -25,6 +25,8 @@ Module MQC_NEF Procedure, public::getBlockVec => mqc_nef_vector_output_block_vector Procedure, Public::impv => mqc_nef_vector_import_vector Procedure, Public::expand => mqc_nef_vector_dimention_expand + Procedure, Public::ins => mqc_nef_vector_insert + Procedure, Public::dimen => mqc_nef_vector_dimension End Type ! !> \brief @@ -45,6 +47,7 @@ Module MQC_NEF Procedure, Public::export => mqc_nef_matrix_export_integral Procedure, Public::slice => mqc_nef_matrix_dimention_slice Procedure, Public::collapse => mqc_nef_matrix_dimention_collapse + Procedure, Public::dimen => mqc_nef_matrix_dimension !> \brief Outer Product of two variables into a two NEF R4 Procedure, Public::outer2R4 => mqc_NEFMatrix_NEFMatrix_outer_product !> \brief Outer Product of two variables into a NEF R4 @@ -3097,6 +3100,234 @@ function mqc_nef_matrix_dimention_slice(NEFMat,rows,columns) result(NEFMatOut) end function mqc_nef_matrix_dimention_slice ! ! +! PROCEDURE MQC_NEF_VECTOR_DIMENSION +! +!> \brief MQC_NEF_VECTOR_Dimension is a function that returns the size of a dimension +!> MQC NEF VECTOR object +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEF_VECTOR_Dimension is a function that returns the size of a dimension or subdimension +!> of an MQC NEF VECTOR object. The required argument label specifies which block is queried. +!> The optional arguments axis, subaxis and spin specifies which dimension is returned. +!> The following options are available: +!> +!> 1. .not.present(SubAxis) returns the dimension of sub-spaceS (default). +!> 2. SubAxis = 'n' selects the n-th dimension of sub-spaces. +!> +!> 1. Spin = returns the 'alpha' dimension of the n-th dimension of sub-spaces in (default). +!> 2. Spin = returns the 'beta' dimension of the n-th dimension of sub-spaces in . +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in,out] MatIn +!> \verbatim +!> VecIn is Class(MQC_NEF_VECTOR) +!> The name of the MQC NEF VECTOR variable. +!> \endverbatim +!> +!> \param[in] SubAxis +!> \verbatim +!> SubAxis is Integer(kind=int64),Optional +!> .not.present(SubAxis) returns the dimension of sub-spaces(default). +!> SubAxis = 'n' selects the n-th dimension of sub-spaces. +!> \endverbatim +!> +!> \param[in] +!> \verbatim Spin +!> Spin is Character(Len=*),optional +!> The spin block to query. +!> = 'alpha','a': alpha axis dimension. +!> = 'beta','b': beta axis dimension. +!> Returns an error if present while subaxis is not present +!> \endverbatim +! +! Authors: +! ======== +!> \author N. J. Woolery +!> \date 2026 +! + function mqc_nef_vector_dimension(VecIn,subaxis,spin) result(dimBlock) +! + implicit none + class(mqc_nef_vector),intent(in)::VecIn + integer(kind=int64)::dimBlock + Character(Len=*),intent(in),optional::spin + integer(kind=int64),intent(in),optional::subaxis + Character(Len=64)::my_spin + integer(kind=int64)::my_sub_axis + logical::do_sub +! + if(present(subaxis)) then + my_sub_axis = subaxis + do_sub=.true. + else + do_sub=.false. + endIf + if(present(spin)) then + if (.not.do_sub) & + call mqc_error('Spin specified without subaxis in MQC_NEF_Vector_Dimension',6) + call string_change_case(spin,'l',my_spin) + end if +! + if (do_sub) then + select case(my_spin) + case('alpha','a') + if (my_sub_axis.gt.VecIn%NumSpace) & + call mqc_error_I('Subaxis out of bounds in MQC_NEF_Vector_Dimension',6,& + 'VecIn%NumSpace',VecIn%NumSpace,'my_sub_axis',my_sub_axis) + dimBlock = VecIn%Size_vector_alpha(my_sub_axis) + case('beta','b') + if (my_sub_axis.gt.VecIn%NumSpace) & + call mqc_error_I('Subaxis out of bounds in MQC_NEF_Vector_Dimension',6,& + 'VecIn%NumSpace_col',VecIn%NumSpace,'my_sub_axis',my_sub_axis) + dimBlock = VecIn%Size_vector_beta(my_sub_axis) + case default + call mqc_error_A('Spin label not valid in mqc_nef_matrix_dimension', 6, & + 'my_spin', my_spin ) + end select + else + dimBlock = VecIn%NumSpace + end if + end function mqc_nef_vector_dimension +! +! PROCEDURE MQC_NEF_MATRIX_DIMENSION +! +!> \brief MQC_NEF_MATRIX_Dimension is a function that returns the size of a dimension +!> MQC NEF MATRIX object +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEF_MATRIX_Dimension is a function that returns the size of a dimension or subdimension +!> of an MQC NEF MATRIX object. The required argument label specifies which block is queried. +!> The optional arguments axis, subaxis and spin specifies which dimension is returned. +!> The following options are available: +!> +!> 1. Axis = '1' selects the first dimension (column)(default). +!> 2. Axis = '2' selects the second dimension (row). +!> +!> 1. .not.present(SubAxis) returns the dimension of sub-spaces in (default). +!> 2. SubAxis = 'n' selects the n-th dimension of sub-spaces in . +!> +!> 1. Spin = returns the 'alpha' dimension of the n-th dimension of sub-spaces in (default). +!> 2. Spin = returns the 'beta' dimension of the n-th dimension of sub-spaces in . +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in,out] MatIn +!> \verbatim +!> MatIn is Class(MQC_NEF_MATRIX) +!> The name of the MQC NEF MATRIX variable. +!> \endverbatim +!> +!> \param[in] Axis +!> \verbatim +!> Axis is Integer(kind=int64),Optional +!> The spin block axis to return. +!> = 1: number of first dimension (column)(default). +!> = 2: number of second dimension (row). +!> \endverbatim +!> +!> \param[in] SubAxis +!> \verbatim +!> SubAxis is Integer(kind=int64),Optional +!> .not.present(SubAxis) returns the dimension of sub-spaces in (default). +!> SubAxis = 'n' selects the n-th dimension of sub-spaces in . +!> \endverbatim +!> +!> \param[in] +!> \verbatim Spin +!> Spin is Character(Len=*),optional +!> The spin block to query. +!> = 'alpha','a': alpha axis dimension. +!> = 'beta','b': beta axis dimension. +!> Returns an error if present while subaxis is not present +!> \endverbatim +! +! Authors: +! ======== +!> \author N. J. Woolery +!> \date 2026 +! + function mqc_nef_matrix_dimension(MatIn,axis,subaxis,spin) result(dimBlock) +! + implicit none + class(mqc_nef_matrix),intent(in)::MatIn + integer(kind=int64)::dimBlock + Character(Len=*),intent(in),optional::spin + integer(kind=int64),intent(in),optional::axis,subaxis + Character(Len=64)::my_spin + integer(kind=int64)::my_axis,my_sub_axis + logical::do_sub +! + if(present(axis)) then + my_axis = axis + else + my_axis = 1 + endIf + if(my_axis.le.0.or.my_axis.gt.2) & + call mqc_error_I('Unknown axis specified in MQC_NEF_Matrix_Dimension',6,'my_axis',my_axis) + + if(present(subaxis)) then + my_sub_axis = subaxis + do_sub=.true. + else + do_sub=.false. + endIf + if(present(spin)) then + if (.not.do_sub) & + call mqc_error('Spin specified without subaxis in MQC_NEF_Matrix_Dimension',6) + call string_change_case(spin,'l',my_spin) + end if +! + if (do_sub) then + select case(my_spin) + case('alpha','a') + if(my_axis.eq.1) then + if (my_sub_axis.gt.MatIn%NumSpace_col) & + call mqc_error_I('Subaxis out of bounds in MQC_NEF_Matrix_Dimension',6,& + 'MatIn%NumSpace_col',MatIn%NumSpace_col,'my_sub_axis',my_sub_axis) + dimBlock = MatIn%Size_vector_alpha_col(my_sub_axis) + else if(my_axis.eq.2) then + if (my_sub_axis.gt.MatIn%NumSpace_row) & + call mqc_error_I('Subaxis out of bounds in MQC_NEF_Matrix_Dimension',6,& + 'MatIn%NumSpace_row',MatIn%NumSpace_row,'my_sub_axis',my_sub_axis) + dimBlock = MatIn%Size_vector_alpha_row(my_sub_axis) + end if + case('beta','b') + if(my_axis.eq.1) then + if (my_sub_axis.gt.MatIn%NumSpace_col) & + call mqc_error_I('Subaxis out of bounds in MQC_NEF_Matrix_Dimension',6,& + 'MatIn%NumSpace_col',MatIn%NumSpace_col,'my_sub_axis',my_sub_axis) + dimBlock = MatIn%Size_vector_beta_col(my_sub_axis) + else if(my_axis.eq.2) then + if (my_sub_axis.gt.MatIn%NumSpace_row) & + call mqc_error_I('Subaxis out of bounds in MQC_NEF_Matrix_Dimension',6,& + 'MatIn%NumSpace_row',MatIn%NumSpace_row,'my_sub_axis',my_sub_axis) + dimBlock = MatIn%Size_vector_beta_row(my_sub_axis) + end if + case default + call mqc_error_A('Spin label not valid in mqc_nef_matrix_dimension', 6, & + 'my_spin', my_spin ) + end select + else + if(my_axis.eq.1) then + dimBlock = MatIn%NumSpace_col + else if(my_axis.eq.2) then + dimBlock = MatIn%NumSpace_row + end if + end if + end function mqc_nef_matrix_dimension +! +! ! PROCEDURE MQC_NEF_R4_NEF_R4_Partial_Contraction_2R4 ! !> \brief MQC_NEF_R4_NEF_R4_Contraction_2R4 is used to return the contraction of @@ -4974,6 +5205,337 @@ function mqc_nef_vector_dimention_expand(& end select ! end function mqc_nef_vector_dimention_expand +! +! PROCEDURE MQC_NEF_Vector_Insert +! +! +!> \brief MQC_NEF_Vector_Insert is used to insert eigenvalues into a NEF vector +!> +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEF_Vector_Insert is used to insert eigenvalues into a NEF vector +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] VecIn +!> \verbatim +!> VecIn is type(mqc_nef_vector) +!> VecIn is the vector you initially have, and insert the eigenvalues into +!> \endverbatim +!> +!> \param[in] idI +!> \verbatim +!> idI is the index or location that you would like to place the eigenvalues into +!> \endverbatim!> +!> +!> \param[in] ExtMap +!> \verbatim +!> ExtMap is the map matrix of the extra block of eigenvalues being added, it is optional +!> \endverbatim +! +!> \param[in] ExtVec +!> \verbatim +!> ExtVec is the block of extra eigenvalues you want to add, it is optional +!> \endverbatim +! +! +! +! +! Authors: +! ======== +!> \author N. J. Woolery +!> \date 2026 +! + Subroutine MQC_NEF_Vector_Insert(VecIn,idI,ExtMap,ExtVec) +! +! Variable Declarations. + implicit none + class(mqc_nef_vector),intent(inOut)::VecIn + type(mqc_scf_eigenvalues)::ExtI + integer::idI + integer::i + integer::zero + type(mqc_scf_eigenvalues),Optional::ExtMap,ExtVec + type(mqc_scf_eigenvalues)::EmptyBlock + type(mqc_scf_eigenvalues),dimension(:),allocatable::tempMain,tempMap + zero=0 + allocate(tempMain(VecIn%Numspace+1),tempMap(VecIn%Numspace+1)) + if(present(ExtMap)) then + EmptyBlock=ExtMap + if(present(ExtVec)) then + !! Both Vec and Map are given + ExtI=ExtVec + + if ((ExtI%blockSize("alpha")).ne.(EmptyBlock%blockSize("alpha"))) & + call mqc_error_i("Dimensionality between Map and Input Block not conformable in mqc_nef_vector_insert",& + 6,"ExtI%blockSize(alpha)",ExtI%blockSize("alpha"),"EmptyBlock%blockSize(alpha)",EmptyBlock%blockSize("alpha")) + if ((ExtI%blockSize("beta")).ne.(EmptyBlock%blockSize("beta"))) & + call mqc_error_i("Dimensionality between Map and Input Block not conformable in mqc_nef_vector_insert",& + 6,"ExtI%blockSize(beta)",ExtI%blockSize("beta"),"EmptyBlock%blockSize(beta)",EmptyBlock%blockSize("beta")) + else + !! Only Map is given + if(EmptyBlock%type().eq."space") then + call ExtI%init(EmptyBlock%blockSize("alpha"),zero) + else + call ExtI%init(EmptyBlock%blockSize("alpha"),zero,EmptyBlock%blockSize("beta")) + end if + end if + else + if(present(ExtVec)) then + !! Only Vec is given + ExtI=ExtVec + if(ExtI%type().eq."space") then + call EmptyBlock%init(ExtI%blockSize("alpha"),zero) + else + call EmptyBlock%init(ExtI%blockSize("alpha"),zero,ExtI%blockSize("beta")) + end if + else + !! Nothing is given + call mqc_error("No input given to mqc_nef_vector_insert",6) + end if + end if + do i=1,idI-1 + tempMain(i)=VecIn%Main_vector(i) + tempMap(i)=VecIn%Map_matrix(i) + end do + tempMain(idI)=ExtI + tempMap(idI)=EmptyBlock + do i=idI+1,(VecIn%Numspace)+1 + tempMain(i)=VecIn%Main_vector(i-1) + tempMap(i)=VecIn%Map_matrix(i-1) + end do +! + call VecIn%init(tempMap) + VecIn%Main_vector=tempMain +! + end subroutine MQC_NEF_Vector_Insert +! +! PROCEDURE MQC_NEF_Matrix_Insert +! +! +!> \brief MQC_NEF_Matrix_Insert is used to insert eigenvalues or NEF vector into a NEF matrix +!> +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEF_Matrix_Insert is used to insert eigenvalues or NEF vector into a NEF matrix +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] VecIn +!> \verbatim +!> VecIn is type(mqc_nef_vector) +!> VecIn is the vector you initially have, and insert the eigenvalues into +!> \endverbatim +!> +!> \param[in] idI +!> \verbatim +!> idI is the index or location that you would like to place the eigenvalues into +!> \endverbatim!> +!> +!> \param[in] ExtMap +!> \verbatim +!> ExtMap is the map matrix of the extra block of eigenvalues being added, it is optional +!> \endverbatim +! +!> \param[in] ExtVec +!> \verbatim +!> ExtVec is the block of extra eigenvalues you want to add, it is optional +!> \endverbatim +! +! +! +! +! Authors: +! ======== +!> \author N. J. Woolery +!> \date 2026 +! + Subroutine MQC_NEF_Matrix_Insert(MatIn,idIRow,idICol,ExtSCFI,ExtMapC,ExtMapR) +! +! Variable Declarations. + implicit none + class(mqc_nef_matrix),intent(inOut)::MatIn + type(mqc_scf_integral),allocatable::ExtI + integer,optional,intent(in)::idIRow,idICol + integer::myidIRow,myidICol + integer::i,j,zero + integer::newNrow,newNcol,extendRow,extendCol + integer::costRow,costCol + type(mqc_scf_integral)::EmptyBlockIntegral + type(mqc_scf_integral),optional,intent(in)::ExtSCFI + type(mqc_scf_eigenvalues),optional,intent(in)::ExtMapC,ExtMapR + type(mqc_scf_eigenvalues)::EmptyBlockRow,EmptyBlockCol + type(mqc_scf_integral),dimension(:),allocatable::tempMain + type(mqc_scf_eigenvalues),dimension(:),allocatable::tempMapRow,tempMapCol + zero = 0 +write(*,*) 'test3' +! + if (present(ExtMapR) .or. present(ExtMapC)) then + if (present(ExtMapR)) then + EmptyBlockRow = ExtMapR + extendRow = 1 + newNrow = (mqc_nef_matrix_dimension(MatIn,2))+1 + else + extendRow = 0 + newNrow = mqc_nef_matrix_dimension(MatIn,2) + end if + if (present(ExtMapC)) then + EmptyBlockCol = ExtMapC + extendCol = 1 + newNcol = (mqc_nef_matrix_dimension(MatIn,1))+1 + else + extendCol = 0 + newNcol = mqc_nef_matrix_dimension(MatIn,1) + end if +! + allocate(tempMain(newNrow*newNcol)) + allocate(tempMapRow(newNrow)) + allocate(tempMapCol(newNcol)) + allocate(ExtI) +! + write(*,*) 'newtest4' + if (present(ExtSCFI)) then + ExtI = ExtSCFI + write(*,*) 'newtest1' + if ((ExtI%blockSize("alpha")) .ne. (EmptyBlockRow%blockSize("alpha"))) & + call mqc_error_i("Dimensionality between Map and Input Block not conformable" // & + " in mqc_nef_matrix_insert",6, & + "ExtI%blockSize(alpha)",ExtI%blockSize("alpha"), & + "EmptyBlockRow%blockSize(alpha)",EmptyBlockRow%blockSize("alpha")) + if ((ExtI%blockSize("beta")) .ne. (EmptyBlockRow%blockSize("beta"))) & + call mqc_error_i("Dimensionality between Map and Input Block not conformable" // & + " in mqc_nef_matrix_insert",6, & + "ExtI%blockSize(beta)",ExtI%blockSize("beta"), & + "EmptyBlockRow%blockSize(beta)",EmptyBlockRow%blockSize("beta")) + else + write(*,*) 'newtest2' + if (extendRow .eq. 1) then + if (EmptyBlockRow%type() .eq. "space") then + write(*,*) 'codealpha' + call ExtI%init(EmptyBlockRow%blockSize("alpha"),zero) + else + write(*,*) 'codebeta' + call ExtI%init(EmptyBlockRow%blockSize("alpha"),zero, & + EmptyBlockRow%blockSize("beta")) + end if + end if + if (extendCol .eq. 1) then + if (EmptyBlockCol%type() .eq. "space") then + write(*,*) 'codecharlie' + call ExtI%init(EmptyBlockCol%blockSize("alpha"),zero) + else + write(*,*) 'codedelta' + call ExtI%init(EmptyBlockCol%blockSize("alpha"),zero, & + EmptyBlockCol%blockSize("beta")) + + !add a duplicate of this block for columns + end if + end if + end if + else + if (present(ExtSCFI)) then + ExtI = ExtSCFI + write(*,*) 'newtest3' + if (ExtI%type() .eq. "space") then + call EmptyBlockRow%init(ExtI%blockSize("alpha"),zero) + call EmptyBlockCol%init(ExtI%blockSize("alpha"),zero) + else + call EmptyBlockRow%init(ExtI%blockSize("alpha"),zero, & + ExtI%blockSize("beta")) + call EmptyBlockCol%init(ExtI%blockSize("alpha"),zero, & + ExtI%blockSize("beta")) + end if + else + call mqc_error("No input given to mqc_nef_matrix_insert",6) + end if + end if +! + write(*,*) 'test4' + if (extendRow .eq. 1) then + if (idIRow>1) then + do i = 1,idIRow-1 + tempMapRow(i) = MatIn%Map_Matrix_Row(i) + end do + else + tempMapRow(1) = MatIn%Map_Matrix_Row(idIRow) + end if + tempMapRow(idIRow) = EmptyBlockRow + do i = idIRow+1,newNrow + tempMapRow(i) = MatIn%Map_Matrix_Row(i-1) + end do + if (extendCol .eq. 0) then + do j = 1,newNcol + tempMapCol(j) = MatIn%Map_Matrix_Col(j) + end do + end if + end if +! + write(*,*) 'test9' + + if (extendCol .eq. 1) then + if (idICol>1) then + do j = 1,idICol-1 + tempMapCol(j) = MatIn%Map_Matrix_Col(j) + end do + else + tempMapCol(1)=MatIn%Map_Matrix_Col(idICol) + end if + tempMapCol(idICol) = EmptyBlockCol + do j = idICol+1,newNcol + tempMapCol(j) = MatIn%Map_Matrix_Col(j-1) + end do + if (extendRow .eq. 0) then + do i = 1,newNRow + tempMapRow(i) = MatIn%Map_Matrix_Row(i) + end do + end if + end if + + + write(*,*) 'test6' + + +do i=1, newNrow + do j=1,newNcol + if (i==idIRow .or. j==idICol) then + call EmptyBlockIntegral%init(size(tempMapRow(i),'alpha'),size(tempMapRow(i),'beta'),& + 0,'',size(tempMapCol(j),'alpha'), size(tempMapCol(j),'beta')) + tempMain(((i-1)*newNcol)+j) = & + EmptyBlockIntegral + else if (i > idIRow .and. idIRow>0) then + if (j>idICol .and. idICol>0) then + tempMain(((i-1)*newNcol)+j) = & + MatIn%Main_matrix(MatIn%blockIndex([1,i-1],[2,j-1])) + else + tempMain(((i-1)*newNcol)+j) = & + MatIn%Main_matrix(MatIn%blockIndex([1,i-1],[2,j])) + end if + else + if (j>idICol .and. idICol>0) then + tempMain(((i-1)*newNcol)+j) = & + MatIn%Main_matrix(MatIn%blockIndex([1,i],[2,j-1])) + else + tempMain(((i-1)*newNcol)+j) = & + MatIn%Main_matrix(MatIn%blockIndex([1,i],[2,j])) + end if + end if + end do +end do + call MatIn%init(tempMapRow, initial_map_matrix_col=tempMapCol) + MatIn%main_matrix = tempMain +! + end subroutine MQC_NEF_Matrix_Insert +! ! ! ! PROCEDURE MQC_NEF_Matrix_Dimension_Collapse @@ -6623,6 +7185,9 @@ function mqc_nef_matrix_output_block_matrix(nefMat,indexes,indexesKet,blockName, call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('betaalpha'),& [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) fsizeKet = fsizeKet + size2 + call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('betaalpha'),& + [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) + fsizeKet = fsizeKet + size2 else call mqc_error_a('block name and order pair unrecognized in& & mqc_nef_matrix_output_block_matrix',6,& From b7a62b61641e30115d07693aaba267664c6879e6 Mon Sep 17 00:00:00 2001 From: njwool01 Date: Thu, 23 Jul 2026 14:58:52 -0400 Subject: [PATCH 37/37] fixing merge issues -N.J. Woolery :D --- src/mqc_nef.F03 | 316 +++++++++++++++++------------------------------- 1 file changed, 113 insertions(+), 203 deletions(-) diff --git a/src/mqc_nef.F03 b/src/mqc_nef.F03 index 431de0f5..5b4fa31c 100644 --- a/src/mqc_nef.F03 +++ b/src/mqc_nef.F03 @@ -5315,41 +5315,52 @@ Subroutine MQC_NEF_Vector_Insert(VecIn,idI,ExtMap,ExtVec) ! end subroutine MQC_NEF_Vector_Insert ! -! PROCEDURE MQC_NEF_Matrix_Insert +! PROCEDURE MQC_NEF_Matrix_Map_Insert ! ! -!> \brief MQC_NEF_Matrix_Insert is used to insert eigenvalues or NEF vector into a NEF matrix +!> \brief MQC_NEF_Matrix_Map_Insert is used to insert eigenvalues or NEF vector into a NEF map matrix !> !> \par Purpose: ! ============= !> !> \verbatim !> -!> MQC_NEF_Matrix_Insert is used to insert eigenvalues or NEF vector into a NEF matrix +!> MQC_NEF_Matrix_Map_Insert is used to insert eigenvalues or NEF vector into a NEF map matrix !> !> \endverbatim ! ! Arguments: ! ========== -!> \param[in] VecIn +!> \param[in] MatIn !> \verbatim -!> VecIn is type(mqc_nef_vector) -!> VecIn is the vector you initially have, and insert the eigenvalues into +!> MatIn is type(mqc_nef_matrix) +!> MatIn is the map matrix you initially have, and insert the new blocks into !> \endverbatim !> -!> \param[in] idI +!> \param[in] idIRow !> \verbatim -!> idI is the index or location that you would like to place the eigenvalues into -!> \endverbatim!> -!> -!> \param[in] ExtMap +!> idI is the index or location on the row axis that you would like to place the block(s) into +!> \endverbatim!> +!> +!> \param[in] idICol !> \verbatim -!> ExtMap is the map matrix of the extra block of eigenvalues being added, it is optional +!> idI is the index or location on the column axis that you would like to place the block(s) into +!> \endverbatim!> +!> +!> \param[in] ExtMapC +!> \verbatim +!> ExtMapC is a column of a map matrix that you want to be added to MatIn, it is optional !> \endverbatim -! -!> \param[in] ExtVec +!> +!> \param[in] ExtMapR !> \verbatim -!> ExtVec is the block of extra eigenvalues you want to add, it is optional +!> ExtMapR is a row of a map matrix that you want to be added to MatIn, it is optional +!> \endverbatim +!> +!> \param[in] ExtSCFI +!> \verbatim +!> ExtSCFI is a block of SCF integrals, it is used to & +!> determine dimensions of empty blocks, it is optional !> \endverbatim ! ! @@ -5360,7 +5371,7 @@ end subroutine MQC_NEF_Vector_Insert !> \author N. J. Woolery !> \date 2026 ! - Subroutine MQC_NEF_Matrix_Insert(MatIn,idIRow,idICol,ExtSCFI,ExtMapC,ExtMapR) + Subroutine MQC_NEF_Matrix_Map_Insert(MatIn,idIRow,idICol,ExtSCFI,ExtMapC,ExtMapR) ! ! Variable Declarations. implicit none @@ -5378,7 +5389,6 @@ Subroutine MQC_NEF_Matrix_Insert(MatIn,idIRow,idICol,ExtSCFI,ExtMapC,ExtMapR) type(mqc_scf_integral),dimension(:),allocatable::tempMain type(mqc_scf_eigenvalues),dimension(:),allocatable::tempMapRow,tempMapCol zero = 0 -write(*,*) 'test3' ! if (present(ExtMapR) .or. present(ExtMapC)) then if (present(ExtMapR)) then @@ -5403,18 +5413,17 @@ Subroutine MQC_NEF_Matrix_Insert(MatIn,idIRow,idICol,ExtSCFI,ExtMapC,ExtMapR) allocate(tempMapCol(newNcol)) allocate(ExtI) ! - write(*,*) 'newtest4' if (present(ExtSCFI)) then ExtI = ExtSCFI write(*,*) 'newtest1' if ((ExtI%blockSize("alpha")) .ne. (EmptyBlockRow%blockSize("alpha"))) & call mqc_error_i("Dimensionality between Map and Input Block not conformable" // & - " in mqc_nef_matrix_insert",6, & + " in mqc_nef_matrix_map_insert",6, & "ExtI%blockSize(alpha)",ExtI%blockSize("alpha"), & "EmptyBlockRow%blockSize(alpha)",EmptyBlockRow%blockSize("alpha")) if ((ExtI%blockSize("beta")) .ne. (EmptyBlockRow%blockSize("beta"))) & call mqc_error_i("Dimensionality between Map and Input Block not conformable" // & - " in mqc_nef_matrix_insert",6, & + " in mqc_nef_matrix_map_insert",6, & "ExtI%blockSize(beta)",ExtI%blockSize("beta"), & "EmptyBlockRow%blockSize(beta)",EmptyBlockRow%blockSize("beta")) else @@ -5438,14 +5447,12 @@ Subroutine MQC_NEF_Matrix_Insert(MatIn,idIRow,idICol,ExtSCFI,ExtMapC,ExtMapR) call ExtI%init(EmptyBlockCol%blockSize("alpha"),zero, & EmptyBlockCol%blockSize("beta")) - !add a duplicate of this block for columns end if end if end if else if (present(ExtSCFI)) then ExtI = ExtSCFI - write(*,*) 'newtest3' if (ExtI%type() .eq. "space") then call EmptyBlockRow%init(ExtI%blockSize("alpha"),zero) call EmptyBlockCol%init(ExtI%blockSize("alpha"),zero) @@ -5456,11 +5463,10 @@ Subroutine MQC_NEF_Matrix_Insert(MatIn,idIRow,idICol,ExtSCFI,ExtMapC,ExtMapR) ExtI%blockSize("beta")) end if else - call mqc_error("No input given to mqc_nef_matrix_insert",6) + call mqc_error("No input given to mqc_nef_matrix_map_insert",6) end if end if ! - write(*,*) 'test4' if (extendRow .eq. 1) then if (idIRow>1) then do i = 1,idIRow-1 @@ -5480,7 +5486,6 @@ Subroutine MQC_NEF_Matrix_Insert(MatIn,idIRow,idICol,ExtSCFI,ExtMapC,ExtMapR) end if end if ! - write(*,*) 'test9' if (extendCol .eq. 1) then if (idICol>1) then @@ -5502,40 +5507,97 @@ Subroutine MQC_NEF_Matrix_Insert(MatIn,idIRow,idICol,ExtSCFI,ExtMapC,ExtMapR) end if - write(*,*) 'test6' -do i=1, newNrow - do j=1,newNcol - if (i==idIRow .or. j==idICol) then - call EmptyBlockIntegral%init(size(tempMapRow(i),'alpha'),size(tempMapRow(i),'beta'),& - 0,'',size(tempMapCol(j),'alpha'), size(tempMapCol(j),'beta')) - tempMain(((i-1)*newNcol)+j) = & - EmptyBlockIntegral - else if (i > idIRow .and. idIRow>0) then - if (j>idICol .and. idICol>0) then + do i=1, newNrow + do j=1,newNcol + if (i==idIRow .or. j==idICol) then + call EmptyBlockIntegral%init(size(tempMapRow(i),'alpha'),size(tempMapRow(i),'beta'),& + 0,'',size(tempMapCol(j),'alpha'), size(tempMapCol(j),'beta')) tempMain(((i-1)*newNcol)+j) = & - MatIn%Main_matrix(MatIn%blockIndex([1,i-1],[2,j-1])) - else - tempMain(((i-1)*newNcol)+j) = & - MatIn%Main_matrix(MatIn%blockIndex([1,i-1],[2,j])) - end if - else - if (j>idICol .and. idICol>0) then - tempMain(((i-1)*newNcol)+j) = & - MatIn%Main_matrix(MatIn%blockIndex([1,i],[2,j-1])) - else - tempMain(((i-1)*newNcol)+j) = & - MatIn%Main_matrix(MatIn%blockIndex([1,i],[2,j])) + EmptyBlockIntegral + else if (i > idIRow .and. idIRow>0) then + if (j>idICol .and. idICol>0) then + tempMain(((i-1)*newNcol)+j) = & + MatIn%Main_matrix(MatIn%blockIndex([1,i-1],[2,j-1])) + else + tempMain(((i-1)*newNcol)+j) = & + MatIn%Main_matrix(MatIn%blockIndex([1,i-1],[2,j])) + end if + else + if (j>idICol .and. idICol>0) then + tempMain(((i-1)*newNcol)+j) = & + MatIn%Main_matrix(MatIn%blockIndex([1,i],[2,j-1])) + else + tempMain(((i-1)*newNcol)+j) = & + MatIn%Main_matrix(MatIn%blockIndex([1,i],[2,j])) + end if end if - end if - end do -end do + end do + end do call MatIn%init(tempMapRow, initial_map_matrix_col=tempMapCol) MatIn%main_matrix = tempMain ! - end subroutine MQC_NEF_Matrix_Insert + end subroutine MQC_NEF_Matrix_Map_Insert +! +! PROCEDURE MQC_NEF_Matrix_Main_Insert ! +! +!> \brief MQC_NEF_Matrix_Main_Insert is used to insert SCF integral block(s) into a NEF matrix +!> +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_NEF_Matrix_Main_Insert is used to insert SCF integral block(s) into a NEF matrix +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] MatIn +!> \verbatim +!> MatIn is type(mqc_nef_vector) +!> MatIn is the map matrix you initially have, and insert the new blocks into +!> \endverbatim +!> +!> \param[in] idIRow +!> \verbatim +!> idI is the index or location on the row axis that you would like to place the block(s) into +!> \endverbatim!> +!> +!> \param[in] idICol +!> \verbatim +!> idI is the index or location on the column axis that you would like to place the block(s) into +!> \endverbatim!> +!> +!> \param[in] ExtMapC +!> \verbatim +!> ExtMapC is a column of a map matrix that you want to be added to MatIn, it is optional +!> \endverbatim +!> +!> \param[in] ExtMapR +!> \verbatim +!> ExtMapR is a row of a map matrix that you want to be added to MatIn, it is optional +!> \endverbatim +!> +!> \param[in] ExtSCFI +!> \verbatim +!> ExtSCFI is a block of SCF integrals, it is used to & +!> determine dimensions of empty blocks, it is optional +!> \endverbatim +! +! +! +! +! Authors: +! ======== +!> \author N. J. Woolery +!> \date 2026 + +! subroutine MQC_NEF_Matrix_Main_Insert + ! ! ! PROCEDURE MQC_NEF_Matrix_Dimension_Collapse @@ -6996,158 +7058,6 @@ function mqc_nef_matrix_output_block_matrix(nefMat,indexes,indexesKet,blockName, if (size1.gt.0.and.size2.gt.0) & call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('betaalpha'),& [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) - fsizeKet = fsizeKet + size2 - else - call mqc_error_a('block name and order pair unrecognized in& - & mqc_nef_matrix_output_block_matrix',6,& - 'myBlockName',myBlockName,'myBlockOrder',myBlockOrder) - end if - end do - else - fsizeKet = 1 - do k = 1, size(myidKet) - j = myidKet(k) - id = nefMat%blockIndex([1,i],[2,j]) - if(myBlockOrder.eq.'alpha'.and.myBlockName.eq.'full') then - size1 = nefMat%Main_matrix(id)%blockSize('full',1) - size2 = nefMat%Main_matrix(id)%blockSize('full',2) - if (size1.gt.0.and.size2.gt.0) & - call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('full'),& - [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) - fsizeKet = fsizeKet + size2 - else if (myBlockName.eq.'full') then - size1 = nefMat%Main_matrix(id)%blockSize('beta',1) - size2 = nefMat%Main_matrix(id)%blockSize('beta',2) - size3 = nefMat%Main_matrix(id)%blockSize('alpha',1) - size4 = nefMat%Main_matrix(id)%blockSize('alpha',2) - if (size1.gt.0.and.size2.gt.0) & - call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('beta'),& - [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) - if (size3.gt.0.and.size2.gt.0) & - call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('betaalpha'),& - [fsize+size1,fsize+size1+size3-1],[fsizeKet,fsizeKet+size2-1]) - if (size1.gt.0.and.size4.gt.0) & - call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('alphabeta'),& - [fsize,fsize+size1-1],[fsizeKet+size2,fsizeKet+size2+size4-1]) - if (size3.gt.0.and.size4.gt.0) & - call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('alpha'),& - [fsize+size1,fsize+size1+size3-1],[fsizeKet+size2,fsizeKet+size2+size4-1]) - fsizeKet = fsizeKet + size2 + size4 - size1 = size1 + size3 - else if (myBlockName.eq.'alpha') then - size1 = nefMat%Main_matrix(id)%blockSize('alpha',1) - size2 = nefMat%Main_matrix(id)%blockSize('alpha',2) - if (size1.gt.0.and.size2.gt.0) & - call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('alpha'),& - [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) - fsizeKet = fsizeKet + size2 - else if (myBlockName.eq.'beta') then - size1 = nefMat%Main_matrix(id)%blockSize('beta',1) - size2 = nefMat%Main_matrix(id)%blockSize('beta',2) - if (size1.gt.0.and.size2.gt.0) & - call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('beta'),& - [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) - fsizeKet = fsizeKet + size2 - else if (myBlockName.eq.'alphabeta') then - size1 = nefMat%Main_matrix(id)%blockSize('alpha',1) - size2 = nefMat%Main_matrix(id)%blockSize('beta',2) - if (size1.gt.0.and.size2.gt.0) & - call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('alphabeta'),& - [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) - fsizeKet = fsizeKet + size2 - else if (myBlockName.eq.'betaalpha') then - size1 = nefMat%Main_matrix(id)%blockSize('beta',1) - size2 = nefMat%Main_matrix(id)%blockSize('alpha',2) - if (size1.gt.0.and.size2.gt.0) & - call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('betaalpha'),& - [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) - fsizeKet = fsizeKet + size2 - else - call mqc_error_a('block name and order pair unrecognized in& - & mqc_nef_matrix_output_block_matrix',6,& - 'myBlockName',myBlockName,'myBlockOrder',myBlockOrder) - end if - end do - end if - fsize = fsize + size1 - end do - else - fsize = 1 - do k = 1, size(myid) - i = myid(k) - if (fullKet) then - fsizeKet = 1 - do j = 1, nefMat%NumSpace_row - id = nefMat%blockIndex([1,i],[2,j]) - if(myBlockOrder.eq.'alpha'.and.myBlockName.eq.'full') then - size1 = nefMat%Main_matrix(id)%blockSize('full',1) - size2 = nefMat%Main_matrix(id)%blockSize('full',2) - if (size1.gt.0.and.size2.gt.0) & - call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('full'),& - [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) - fsizeKet = fsizeKet + size2 - else if (myBlockName.eq.'full') then - size1 = nefMat%Main_matrix(id)%blockSize('beta',1) - size2 = nefMat%Main_matrix(id)%blockSize('beta',2) - size3 = nefMat%Main_matrix(id)%blockSize('alpha',1) - size4 = nefMat%Main_matrix(id)%blockSize('alpha',2) - if (size1.gt.0.and.size2.gt.0) & - call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('beta'),& - [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) - if (size3.gt.0.and.size2.gt.0) & - call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('betaalpha'),& - [fsize+size1,fsize+size1+size3-1],[fsizeKet,fsizeKet+size2-1]) - if (size1.gt.0.and.size4.gt.0) & - call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('alphabeta'),& - [fsize,fsize+size1-1],[fsizeKet+size2,fsizeKet+size2+size4-1]) - if (size3.gt.0.and.size4.gt.0) & - call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('alpha'),& - [fsize+size1,fsize+size1+size3-1],[fsizeKet+size2,fsizeKet+size2+size4-1]) - fsizeKet = fsizeKet + size2 + size4 - size1 = size1 + size3 - else if (myBlockName.eq.'alpha') then - size1 = nefMat%Main_matrix(id)%blockSize('alpha',1) - size2 = nefMat%Main_matrix(id)%blockSize('alpha',2) - if (size1.gt.0.and.size2.gt.0) & - call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('alpha'),& - [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) - fsizeKet = fsizeKet + size2 - else if (myBlockName.eq.'beta') then - size1 = nefMat%Main_matrix(id)%blockSize('beta',1) - size2 = nefMat%Main_matrix(id)%blockSize('beta',2) - if (size1.gt.0.and.size2.gt.0) & - call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('beta'),& - [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) - fsizeKet = fsizeKet + size2 - else if (myBlockName.eq.'alphabeta') then - size1 = nefMat%Main_matrix(id)%blockSize('alpha',1) - size2 = nefMat%Main_matrix(id)%blockSize('beta',2) - if (size1.gt.0.and.size2.gt.0) & - call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('alphabeta'),& - [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) - fsizeKet = fsizeKet + size2 - else if (myBlockName.eq.'betaalpha') then - size1 = nefMat%Main_matrix(id)%blockSize('beta',1) - size2 = nefMat%Main_matrix(id)%blockSize('alpha',2) - if (size1.gt.0.and.size2.gt.0) & - call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('betaalpha'),& - [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) - fsizeKet = fsizeKet + size2 - else - call mqc_error_a('block name and order pair unrecognized in& - & mqc_nef_matrix_output_block_matrix',6,& - 'myBlockName',myBlockName,'myBlockOrder',myBlockOrder) - end if - end do - else - fsizeKet = 1 - do p = 1, size(myidKet) - j = myidKet(p) - id = nefMat%blockIndex([1,i],[2,j]) - if(myBlockOrder.eq.'alpha'.and.myBlockName.eq.'full') then - size1 = nefMat%Main_matrix(id)%blockSize('full',1) - size2 = nefMat%Main_matrix(id)%blockSize('full',2) - if (size1.gt.0.and.size2.gt.0) & call MatrixOut%mput(nefMat%Main_matrix(id)%getBlock('full'),& [fsize,fsize+size1-1],[fsizeKet,fsizeKet+size2-1]) fsizeKet = fsizeKet + size2