diff --git a/.github/workflows/linux.yml b/.github/workflows/linux.yml index f9390904..5926c390 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 @@ -26,12 +33,23 @@ jobs: - name: Install GauOpen and create the mqc-install directory run: | - mkdir gauopen + set -e + mkdir -p gauopen cd gauopen - wget http://gaussian.com/g16/gauopen_v2.zip + echo "Downloading GauOpen..." + curl --http1.1 -L -f \ + --retry 5 --retry-delay 3 --retry-all-errors \ + -H "User-Agent: Mozilla/5.0" \ + -H "Accept: */*" \ + -o gauopen_v2.zip \ + https://gaussian.com/g16/gauopen_v2.zip + echo "Verifying zip file..." + file gauopen_v2.zip + unzip -t gauopen_v2.zip > /dev/null + echo "Extracting..." unzip gauopen_v2.zip cd .. - mkdir mqc-install + mkdir -p mqc-install - name: Build mqcPack with gfortran run: echo -e "yG$GITHUB_WORKSPACE/mqc-install\n-lblas\n-llapack\n$GITHUB_WORKSPACE/gauopen\ny\nn\n" | ./mqc_install && doxygen doc/Doxyfile 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/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; } + 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_algebra.F03 b/src/mqc_algebra.F03 index 6d4bbc2b..b8f13c5f 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 @@ -184,6 +188,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(:),Pointer::VoV=>null() + 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 @@ -212,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 @@ -298,6 +310,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 @@ -361,6 +375,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 @@ -423,6 +438,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 @@ -453,6 +469,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 @@ -582,6 +608,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 @@ -609,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 @@ -669,6 +708,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 | @@ -936,6 +980,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... ! @@ -2782,8 +2830,8 @@ END FUNCTION MQC_Scalar_Get_ABS_Value ! ============= !> !> \verbatim -!> -!> MQC_Scalar_Get_Phase is a function that returns the phase angle (p) +!> +!> MQC_Scalar_Get_Phase is a function that returns the phase angle (p) !> in radian of MQC_scalar variable. Such as: !> Scalar=exp(-ip)*abs(Scalar)=abs(Scalar)(cos(p)-i sin(p)) !> @@ -2822,7 +2870,8 @@ Function MQC_Scalar_Get_Phase(Scalar,thresh_inp) Result(Output) else thresh=1.0E-8 end if - if (abs(Scalar).lt.thresh) then + + if (abs(Scalar).lt.thresh) then output = 0.0 else output = acos(Scalar%rval()/abs(Scalar)) @@ -8403,6 +8452,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 @@ -9829,18 +9920,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 @@ -11657,7 +11748,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. @@ -11910,6 +12001,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 @@ -12173,6 +12361,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 @@ -12904,6 +13142,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 @@ -14891,7 +15182,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 @@ -14906,7 +15197,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 @@ -14920,11 +15211,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 @@ -16175,7 +16466,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 @@ -16328,7 +16619,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 @@ -16480,11 +16771,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 @@ -16585,19 +16876,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 ! @@ -21960,8 +22251,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) ! @@ -21985,11 +22276,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))) @@ -22095,9 +22387,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 @@ -22584,8 +22876,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) ! @@ -22594,10 +22886,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 @@ -24096,11 +24390,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) @@ -24274,11 +24572,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') @@ -24828,27 +25130,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 ! @@ -24884,27 +25194,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 ! @@ -26416,22 +26734,22 @@ function mqc_matrix_cofactor(a,i,j) result(cofactor) integer(kind=int64)::iUse,jUse ! 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) @@ -27468,10 +27786,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 @@ -27485,7 +27803,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 @@ -27495,10 +27815,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 @@ -27513,7 +27831,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 ! @@ -27563,8 +27881,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 @@ -29062,20 +29436,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( " " ) @@ -29086,19 +29469,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 @@ -29108,13 +29515,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%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 + 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 @@ -30497,8 +30916,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) ! @@ -30507,6 +30926,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 @@ -30514,15 +30934,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,i) 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 ! @@ -30744,7 +31173,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. !> @@ -31566,8 +31995,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) ! @@ -31624,56 +32053,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 @@ -31857,10 +32286,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 & @@ -31870,10 +32299,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 & @@ -31883,10 +32312,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 & @@ -31896,10 +32325,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 & @@ -32764,6 +33193,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) @@ -32773,8 +33203,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 @@ -32782,10 +33214,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) @@ -32947,8 +33382,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) @@ -32999,7 +33434,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) @@ -33013,7 +33448,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])) @@ -33025,7 +33460,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])) @@ -33037,7 +33472,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)) @@ -33054,8 +33489,416 @@ 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_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 +! +! +! 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,dimAk + do l=1,dimAl + 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])) + !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]) + 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])) + !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) + 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)) + !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,dimBk + do q=1,dimBl + 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])) + !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]) + 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])) + !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) + 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)) + !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) + 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 8c9a053f..c940806e 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. @@ -100,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 @@ -108,6 +111,7 @@ Module MQC_EST Procedure, Public::init => mqc_integral_initialize !> \brief Diagonalizes an MQC_SCF_Integral object Procedure, Public::diag => mqc_scf_integral_diagonalize + !> \brief Performs SVD on an MQC_SCF_Integral object Procedure, Public::svd => mqc_scf_integral_svd !> \brief Solves a generalized eigenvalue problem involving an @@ -134,6 +138,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 @@ -169,9 +174,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 @@ -202,6 +207,13 @@ 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 +!> index order is provided + Procedure, Public::sort => mqc_eigenvalues_sort End Type ! !> \brief EST intermediates of single determinant wavefunctions @@ -273,17 +285,93 @@ Module MQC_EST 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::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 +!> 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 +!> +!> 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 procedure, public::print => mqc_print_twoERIs procedure, public::at => mqc_twoERIs_at +!> \brief Initilizes the MQC_twoERIs object + Procedure, Public::init => mqc_twoERIs_initialize !> \brief Return the spin block dimention of the MQC_TwoERIs object 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::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 + procedure, public::interaction => mqc_eri_interaction end type mqc_twoERIs ! ! Parent Type @@ -319,6 +407,15 @@ 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 @@ -344,12 +441,14 @@ 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 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 @@ -368,6 +467,7 @@ Module MQC_EST !> \brief Returns the complex conjugate Interface Conjg Module Procedure mqc_scf_integral_conjg + Module Procedure mqc_scf_eigenvalues_conjg End Interface ! !> \brief Returns the block length along the specified dimension @@ -397,6 +497,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 @@ -407,6 +512,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 +! ! !---------------------------------------------------------------- ! | @@ -419,14 +530,16 @@ 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 End Interface ! !> \brief Sums two variables Interface Operator (+) + Module Procedure MQC_Eigenvalues_Sum Module Procedure MQC_Integral_Sum Module Procedure MQC_ERI_Sum End Interface @@ -438,20 +551,31 @@ 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 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 + Module Procedure MQC_twoERIs_Scalar_Multiply End Interface ! !> \brief Computes the element-wise product of two objects Interface Operator (.ewp.) Module Procedure MQC_Element_Integral_Multiply + Module Procedure MQC_Element_Eigenvalues_Multiply + End Interface +! +!> \brief Exponentiates a variable to the power of another + Interface Operator (**) + Module Procedure MQC_eigenvalues_Power_func End Interface ! ! @@ -951,21 +1075,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( " " ) @@ -974,42 +1108,101 @@ subroutine mqc_print_twoERIs(twoERIs,iOut,header, & if(blank_at_top) write(iout,1020) endif write(iout,1000) trim(header) - - call string_change_case(twoERIs%integraltype,'L') - if(twoERIs%integralType.eq.'regular') then - call twoERIs%alpha%print(iout,'Regular 2ERIs') - elseIf(twoERIs%integralType.eq.'raffenetti1') then - call twoERIs%alpha%print(iout,'Raffenetti 1 2ERIs') - elseIf(twoERIs%integralType.eq.'raffenetti2') then - call twoERIs%alpha%print(iout,'Raffenetti 2 2ERIs') - elseIf(twoERIs%integralType.eq.'raffenetti3') then - call twoERIs%alpha%print(iout,'Raffenetti 3 2ERIs') - elseIf(twoERIs%integralType.eq.'space') then - call twoERIs%alpha%print(iout,'Restricted MO 2ERIs') - elseIf(twoERIs%integralType.eq.'spin') then + 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(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(trim(twoERIs%integralType).eq.'raffenetti1') then + if(twoERIs%hasSpinBlock('aaaa')) & + call twoERIs%alpha%print(iout,'Raffenetti 1 2ERIs',short_print_threshold=print_threshold) + 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(trim(twoERIs%integralType).eq.'raffenetti3') then + if(twoERIs%hasSpinBlock('aaaa')) & + call twoERIs%alpha%print(iout,'Raffenetti 3 2ERIs',short_print_threshold=print_threshold) + 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(trim(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)') - elseIf(twoERIs%integralType.eq.'general') then + 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%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' - 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%storageType.eq.'full') call twoERIs%babb%print(iout,'(ba|bb)') - call twoERIs%abbb%print(iout,'(ab|bb)') + 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%hasSpinBlock('aabb')) & + 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)',short_print_threshold=print_threshold) + if(twoERIs%hasSpinBlock('abba')) & + 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('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) + 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)',short_print_threshold=print_threshold) else call mqc_error_A('Integral type unrecogised in mqc_print_twoERIs', 6, & 'twoERIs%integralType', twoERIs%integralType ) @@ -1195,6 +1388,104 @@ 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_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 @@ -1513,9 +1804,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. @@ -1667,6 +1958,84 @@ 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 +!> 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 @@ -1890,6 +2259,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 @@ -2142,7 +2580,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 !> !> @@ -2153,6 +2592,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: ! ======== @@ -2196,11 +2642,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 @@ -2376,21 +2819,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 @@ -2403,9 +2860,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, @@ -2413,13 +2872,26 @@ 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]* +!> +!> 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 @@ -2540,43 +3012,153 @@ 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) + 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 -! - 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 + 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 + do i = 1,16 + allocVec(i)=.true. + end do + end if +! + 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 + 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 ! @@ -2682,7 +3264,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, & @@ -2713,23 +3295,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 @@ -2744,23 +3330,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 @@ -2773,7 +3363,7 @@ subroutine mqc_integral_allocate(integral,arrayName,arrayType,alpha, & 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,& @@ -2785,7 +3375,7 @@ subroutine mqc_integral_allocate(integral,arrayName,arrayType,alpha, & 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,& @@ -2999,58 +3589,206 @@ subroutine mqc_eigenvalues_allocate(eigenvalues,arrayName,arrayType,alpha, & end subroutine mqc_eigenvalues_allocate ! ! -! PROCEDURE MQC_TwoERIs_Transform +! PROCEDURE MQC_Eigenvalues_Deallocate ! -!> \brief MQC_TwoERIs_Transform is used to transform two-electron integral -!> type variables between different integral types +!> \brief MQC_Eigenvalues_Deallocate is used to deallocate a MQC eigenvalues type +!> variable of the MQC_SCF_Eigenvalues class ! !> \par Purpose: ! ============= !> !> \verbatim !> -!> MQC_TwoERIs_Transform is used to transform two-electron integral type variables -!> between different integral types. nThe following options are available: -!> -!> 1. IntegralType = 'Regular' declares the MQC_TwoERIs variable contains regular -!> atomic orbital 2ERIs. -!> 2. IntegralType = 'Raffenetti1' declares the MQC_TwoERIs variable contains -!> raffenetti type 1 atomic orbital 2ERIs. -!> 3. IntegralType = 'Raffenetti2 declares the MQC_TwoERIs variable contains -!> raffenetti type 2 atomic orbital 2ERIs. -!> 4. IntegralType = 'Raffenetti3' declares the MQC_TwoERIs variable contains -!> raffenetti type 3 atomic orbital 2ERIs. -!> 5. IntegralType = 'Molecular' declares the MQC_TwoERIs variable -!> contains molecular orbital basis 2ERIs. +!> MQC_Eigenvalues_Deallocate is used to allocate a MQC SCF eigenvalues type +!> variable of the MQC_SCF_Eigenvalues class. !> !> \endverbatim ! ! Arguments: ! ========== -!> \param[in,out] TwoERIs +!> \param[in,out] Eigenvalues !> \verbatim -!> TwoERIs is class(mqc_twoERIs) -!> The MQC_TwoERIs variable to transform. +!> Eigenvalues is class(mqc_scf_eigenvalues) +!> The MQC_SCF_Eigenvalues variable to allocate. !> \endverbatim !> -!> \param[in] IntegralType +! +! 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 -!> IntegralType is Character(len=*) -!> = 'Regular': the MQC_TwoERIs variable contains regular atomic orbital -!> 2ERIs. -!> R(i,j,k,l) = (ij|kl) -!> = 'Raffenetti1': the MQC_TwoERIs variable contains raffenetti type 1 atomic -!> orbital 2ERIs. -!> R(i,j,k,l) = (ij|kl) - 1/4[(ik|jl)+(il|jk)] -!> = 'Raffenetti2': the MQC_TwoERIs variable contains raffenetti type 2 atomic -!> orbital 2ERIs. -!> R(i,j,k,l) = (ik|jl) + (il|jk) -!> = 'Raffenetti3': the MQC_TwoERIs variable contains raffenetti type 3 atomic -!> orbital 2ERIs. -!> R(i,j,k,l) = (ik|jl) - (il|jk) -!> = 'Molecular': the MQC_TwoERIs variable contains molecular orbital basis -!> 2ERIs. -!> \endverbatim +!> +!> 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 +!> type variables between different integral types +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_TwoERIs_Transform is used to transform two-electron integral type variables +!> between different integral types. nThe following options are available: +!> +!> 1. IntegralType = 'Regular' declares the MQC_TwoERIs variable contains regular +!> atomic orbital 2ERIs. +!> 2. IntegralType = 'Raffenetti1' declares the MQC_TwoERIs variable contains +!> raffenetti type 1 atomic orbital 2ERIs. +!> 3. IntegralType = 'Raffenetti2 declares the MQC_TwoERIs variable contains +!> raffenetti type 2 atomic orbital 2ERIs. +!> 4. IntegralType = 'Raffenetti3' declares the MQC_TwoERIs variable contains +!> raffenetti type 3 atomic orbital 2ERIs. +!> 5. IntegralType = 'Molecular' declares the MQC_TwoERIs variable +!> contains molecular orbital basis 2ERIs. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in,out] TwoERIs +!> \verbatim +!> TwoERIs is class(mqc_twoERIs) +!> The MQC_TwoERIs variable to transform. +!> \endverbatim +!> +!> \param[in] IntegralType +!> \verbatim +!> IntegralType is Character(len=*) +!> = 'Regular': the MQC_TwoERIs variable contains regular atomic orbital +!> 2ERIs. +!> R(i,j,k,l) = (ij|kl) +!> = 'Raffenetti1': the MQC_TwoERIs variable contains raffenetti type 1 atomic +!> orbital 2ERIs. +!> R(i,j,k,l) = (ij|kl) - 1/4[(ik|jl)+(il|jk)] +!> = 'Raffenetti2': the MQC_TwoERIs variable contains raffenetti type 2 atomic +!> orbital 2ERIs. +!> R(i,j,k,l) = (ik|jl) + (il|jk) +!> = 'Raffenetti3': the MQC_TwoERIs variable contains raffenetti type 3 atomic +!> orbital 2ERIs. +!> R(i,j,k,l) = (ik|jl) - (il|jk) +!> = 'Molecular': the MQC_TwoERIs variable contains molecular orbital basis +!> 2ERIs. +!> \endverbatim !> !> \param[in] mo_coefficients !> \verbatim @@ -3090,7 +3828,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. @@ -3133,7 +3872,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) @@ -3169,7 +3908,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) @@ -3205,7 +3944,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& @@ -3531,8 +4270,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) ! @@ -3571,7 +4310,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 @@ -3586,7 +4325,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 @@ -3596,6 +4335,120 @@ subroutine mqc_integral_initialize(integral,nAlpha,nBeta,scalar,label,nAlpha2,nB ! end subroutine mqc_integral_initialize ! +! PROCEDURE MQC_twoERIs_Initialize +! +!> \brief MQC_twoERIs_Initialize is used to initialize an MQC twoERIs type +!> variable with each element equal to a chosen value +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_twoERIs_Initialize is used to initialize an MQC twoERIs type +!> variable with each element equal to a chosen value +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in,out] ERI +!> \verbatim +!> ERI is class(mqc_twoERIs) +!> The MQC_twoERIs variable to initialize. +!> \endverbatim +!> +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + subroutine mqc_twoERIs_initialize(ERIOut,nAlpha,nBeta,label,& + nAlpha2,nBeta2,nAlpha3,nBeta3,nAlpha4,nBeta4) +! + implicit none + class(mqc_twoERIs),intent(inOut)::ERIOut + integer,intent(in)::nAlpha,nBeta + character(Len=*),optional,intent(in)::label + integer,intent(in),optional::nAlpha2,nBeta2,nAlpha3,nBeta3,nAlpha4,nBeta4 + type(MQC_R4Tensor)::aaaa,aaab,aaba,abaa,baaa,aabb,abab,baab,abba,baba,bbaa,& + abbb,babb,bbab,bbba,bbbb + Character(Len=64)::myLabel,eriType + integer::my_nAlpha2,my_nBeta2,my_nAlpha3,my_nBeta3,my_nAlpha4,my_nBeta4 +! + if(present(label)) then + call string_change_case(label,'l',myLabel) + else + myLabel = '' + endIf + if(.not.present(nAlpha2)) then + my_nAlpha2 = nAlpha + else + my_nAlpha2 = nAlpha2 + endIf + if(.not.present(nBeta2)) then + my_nBeta2 = nBeta + else + my_nBeta2 = nBeta2 + endIf + if(.not.present(nAlpha3)) then + my_nAlpha3 = nAlpha + else + my_nAlpha3 = nAlpha3 + endIf + if(.not.present(nBeta3)) then + my_nBeta3 = nBeta + else + my_nBeta3 = nBeta3 + endIf + if(.not.present(nAlpha4)) then + my_nAlpha4 = nAlpha + else + my_nAlpha4 = nAlpha4 + endIf + if(.not.present(nBeta4)) then + my_nBeta4 = nBeta + else + my_nBeta4 = nBeta4 + endIf + + call aaaa%init(nAlpha,my_nAlpha2,my_nAlpha3,my_nAlpha4) + if (nAlpha.eq.nBeta.and.my_nAlpha2.eq.my_nBeta2& + .and.my_nAlpha3.eq.my_nBeta3.and.my_nAlpha4.eq.my_nBeta4) then + eriType = 'space' + else + eriType = 'general' + call bbbb%init(nBeta,my_nBeta2,my_nBeta3,my_nBeta4) + call bbba%init(nBeta,my_nBeta2,my_nBeta3,my_nAlpha4) + call bbab%init(nBeta,my_nBeta2,my_nAlpha3,my_nBeta4) + call bbaa%init(nBeta,my_nBeta2,my_nAlpha3,my_nAlpha4) + call babb%init(nBeta,my_nAlpha2,my_nBeta3,my_nBeta4) + call baba%init(nBeta,my_nAlpha2,my_nBeta3,my_nAlpha4) + call baab%init(nBeta,my_nAlpha2,my_nAlpha3,my_nBeta4) + call baaa%init(nBeta,my_nAlpha2,my_nAlpha3,my_nAlpha4) + call abbb%init(nAlpha,my_nBeta2,my_nBeta3,my_nBeta4) + call abba%init(nAlpha,my_nBeta2,my_nBeta3,my_nAlpha4) + call abab%init(nAlpha,my_nBeta2,my_nAlpha3,my_nBeta4) + call abaa%init(nAlpha,my_nBeta2,my_nAlpha3,my_nAlpha4) + call aabb%init(nAlpha,my_nAlpha2,my_nBeta3,my_nBeta4) + call aaba%init(nAlpha,my_nAlpha2,my_nBeta3,my_nAlpha4) + call aaab%init(nAlpha,my_nAlpha2,my_nAlpha3,my_nBeta4) + endIf + if (eriType.eq.'space') then + call mqc_twoeris_allocate(eriOut,'full-coulomb','space',aaaa) + elseif (eriType.eq.'spin') then + call mqc_twoeris_allocate(eriOut,'full-coulomb','spin',aaaa,bbbb,aabb,bbaa) + elseif (eriType.eq.'general') then + 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 + +! +! + end subroutine mqc_twoERIs_initialize +! ! ! PROCEDURE MQC_Integral_Output_Block ! @@ -5220,27 +6073,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],& @@ -5329,9 +6257,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 @@ -5339,12 +6265,22 @@ 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%type().ne.'general'.and.(eris%intType().eq.'exchange'.or.& + eris%intType().eq.'inverted')) then + call r4tOut%init(NDimAlpha1,NDimAlpha2,NDimBeta3,NDimBeta4,zeroR) + 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 + 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 @@ -5353,77 +6289,176 @@ 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%type().ne.'general'.and.(eris%intType().eq.'exchange'.or.& + eris%intType().eq.'inverted')) then + call r4tOut%init(NDimBeta1,NDimBeta2,NDimAlpha3,NDimAlpha4,zeroR) + 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 - 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%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 + 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 - r4tOut = eris%abba - else + 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'.and.eris%inttype().ne.'doublebar')) then + If (eris%hasSpinBlock('aaaa')) then + r4tOut = eris%alpha + else + 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 + else + If (eris%hasSpinBlock('abba')) then + r4tOut = eris%abba + else + call r4tOut%init(NDimAlpha1,NDimBeta2,NDimBeta3,NDimAlpha4,zeroR) + endIf 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%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'.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) + call r4tOut%init(NDimBeta1,NDimAlpha2,NDimAlpha3,NDimBeta4,zeroR) endIf + 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) + 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%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) - else + 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'.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 + 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%storType().eq.'symm') then + If (eris%hasSpinBlock('abab')) then + r4tOut = eris%abab + else + call r4tOut%init(NDimBeta1,NDimAlpha2,NDimBeta3,NDimAlpha4,zeroR) + endIf + else + If (eris%hasSpinBlock('baba')) then + r4tOut = eris%baba else call r4tOut%init(NDimBeta1,NDimAlpha2,NDimBeta3,NDimAlpha4,zeroR) endIf 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 @@ -5437,7 +6472,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 @@ -5451,7 +6486,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 @@ -5465,7 +6500,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 @@ -5479,7 +6514,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 @@ -5493,7 +6528,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 @@ -5507,13 +6542,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 ! @@ -5931,6 +6966,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 @@ -6754,6 +7840,283 @@ 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_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 @@ -6771,7 +8134,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 !> @@ -7009,7 +8372,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 ! ! @@ -7044,7 +8407,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) ! @@ -7054,67 +8417,812 @@ 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(.not.allocated(ERIA)) then + ERIOut = ERIB + return + elseif(.not.allocated(ERIB)) 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%intType()) + case('coulomb') + select case(ERIB%intType()) + case('coulomb') + aaaa = ERIA%getBlock('aaaa')+ERIB%getBlock('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,'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,'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%inttype', ERIB%inttype() ) + end select + case('exchange') + 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,'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,'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,'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%inttype', ERIB%inttype() ) + end select + case('inverted') + 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,'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,'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,'full-inverted','space',aaaa) + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & + 'ERIB%inttype', ERIB%inttype() ) + end select + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & + 'ERIA%inttype', ERIA%inttype() ) + 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%intType()) + case('coulomb') + 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,'full-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,'full-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,'full-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,'full-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,'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%inttype', ERIB%inttype()) + end select + case('exchange') + select case(ERIB%intType()) + 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,'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,'full-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,'full-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,'full-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,'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%inttype', ERIB%inttype() ) + end select + case('inverted') + select case(ERIB%intType()) + 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,'full-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,'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,'full-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,'full-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,'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%inttype', ERIB%inttype() ) + end select + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & + 'ERIA%inttype', ERIA%inttype() ) + 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') - call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& + select case(ERIA%intType()) + 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%inttype', ERIA%inttype() ) + end select + !LMTLMT THINK ABOUT THIS ASSIGNMENT PROPERLY + call mqc_twoeris_allocate(ERIOut,'full-coulomb','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'),& 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') 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%intType()) + case('coulomb') + 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,'full-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,'full-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,'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%inttype', ERIB%inttype() ) + end select + case('exchange') + select case(ERIB%intType()) + 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,'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,'full-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,'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%inttype', ERIB%inttype() ) + end select + case('inverted') + select case(ERIB%intType()) + 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,'full-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,'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,'full-inverted','spin',aaaa,bbbb,& + abab,baba) + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & + 'ERIB%inttype', ERIB%inttype() ) + end select + case('doublebar') + select case(ERIB%intType()) + 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,'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') + 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,'full-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,'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%inttype', ERIB%inttype() ) + end select + case('ms') + select case(ERIB%intType()) + 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,'full-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,'full-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,'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%inttype', ERIB%inttype() ) + end select + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & + 'ERIA%inttype', ERIA%inttype() ) + 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%intType()) + case('coulomb') + 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,'full-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,'full-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,'full-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,'full-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 = ERIB%getBlock('baba') + 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%inttype', ERIB%inttype() ) + end select + case('exchange') + select case(ERIB%intType()) + 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,'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,'full-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,'full-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,'full-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,'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%inttype', ERIB%inttype() ) + end select + case('inverted') + select case(ERIB%intType()) + 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,'full-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,'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,'full-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,'full-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,'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%ointtype', ERIB%inttype() ) + end select + case('doublebar') + select case(ERIB%intType()) + 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,'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') + 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,'full-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,'full-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,'full-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,'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%inttype', ERIB%inttype() ) + end select + case('ms') + select case(ERIB%intType()) + 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,'full-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,'full-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,'full-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,'full-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,'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%inttype', ERIB%inttype() ) + end select + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_sum', 6, & + 'ERIA%inttype', ERIA%inttype() ) + 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,& - 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%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-coulomb','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-exchange','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-inverted','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-doublebar','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-ms','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%inttype', ERIA%inttype() ) + 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, & 'ERIB%integraltype', ERIB%integraltype ) end select case('general') @@ -7122,12 +9230,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') - call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& + select case(ERIB%intType()) + 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%inttype', ERIB%inttype() ) + end select + call mqc_twoeris_allocate(ERIOut,'full-coulomb','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'),& @@ -7135,12 +9267,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') - call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& + select case(ERIB%intType()) + 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_sum', 6, & + 'ERIB%inttype', ERIB%inttype() ) + end select + call mqc_twoeris_allocate(ERIOut,'full-coulomb','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'),& @@ -7162,16 +9332,17 @@ 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_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 ! ! @@ -7584,28 +9755,281 @@ 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 ! + 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(.not.allocated(ERIB)) 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%intType()) + case('coulomb') + select case(ERIB%intType()) + case('coulomb') + aaaa = ERIA%getBlock('aaaa')-ERIB%getBlock('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,'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,'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%inttype', ERIB%inttype() ) + end select + case('exchange') + 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,'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,'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,'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%inttype', ERIB%inttype() ) + end select + case('inverted') + 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,'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,'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,'full-inverted','space',aaaa) + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & + 'ERIB%inttype', ERIB%inttype() ) + end select + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & + 'ERIA%inttype', ERIA%inttype() ) + 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%intType()) + case('coulomb') + 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,'full-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,'full-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,'full-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,'full-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,'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%inttype', ERIB%inttype()) + end select + case('exchange') + select case(ERIB%intType()) + 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,'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,'full-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,'full-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,'full-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,'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%inttype', ERIB%inttype() ) + end select + case('inverted') + select case(ERIB%intType()) + 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,'full-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,'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,'full-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,'full-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,'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%inttype', ERIB%inttype() ) + end select + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & + 'ERIA%inttype', ERIA%inttype() ) + 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') - call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& + select case(ERIA%intType()) + 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%inttype', ERIA%inttype() ) + end select + 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'),& + 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'),& @@ -7617,32 +10041,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%intType()) + case('coulomb') + 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,'full-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,'full-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,'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%inttype', ERIB%inttype() ) + end select + case('exchange') + select case(ERIB%intType()) + 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,'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,'full-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,'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%inttype', ERIB%inttype() ) + end select + case('inverted') + select case(ERIB%intType()) + 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,'full-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,'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,'full-inverted','spin',aaaa,bbbb,& + abab,baba) + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & + 'ERIB%inttype', ERIB%inttype() ) + end select + case('doublebar') + select case(ERIB%intType()) + 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,'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') + 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,'full-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,'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%inttype', ERIB%inttype() ) + end select + case('ms') + select case(ERIB%intType()) + 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,'full-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,'full-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,'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%type() ) + end select + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & + 'ERIA%inttype', ERIA%inttype() ) + 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%intType()) + case('coulomb') + 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,'full-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,'full-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,'full-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,'full-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,'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%inttype', ERIB%inttype() ) + end select + case('exchange') + select case(ERIB%intType()) + 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,'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,'full-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,'full-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,'full-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,'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%inttype', ERIB%inttype() ) + end select + case('inverted') + select case(ERIB%intType()) + 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,'full-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,'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,'full-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,'full-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,'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%inttype', ERIB%inttype() ) + end select + case('doublebar') + select case(ERIB%intType()) + 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,'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') + 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,'full-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,'full-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,'full-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,'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%inttype', ERIB%inttype() ) + end select + case('ms') + select case(ERIB%intType()) + 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,'full-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,'full-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,'full-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,'full-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,'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%inttype', ERIB%inttype() ) + end select + case default + call mqc_error_A('Unknown twoERI storage type in mqc_eri_difference', 6, & + 'ERIA%inttype', ERIA%inttype() ) + 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%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-coulomb','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-exchange','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-coulomb','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-doublebar','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-coulomb','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%inttype', ERIA%inttype() ) + end select case default call mqc_error_A('Unknown twoERI type in mqc_eri_difference', 6, & 'ERIB%integraltype', ERIB%integraltype ) @@ -7652,12 +10571,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') - call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& + select case(ERIB%intType()) + 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%inttype', ERIB%inttype() ) + end select + call mqc_twoeris_allocate(ERIOut,'full-coulomb','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'),& @@ -7665,12 +10608,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') - call mqc_twoeris_allocate(ERIOut,'full','general',aaaa,bbbb,& + select case(ERIB%intType()) + 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%inttype', ERIB%inttype() ) + end select + call mqc_twoeris_allocate(ERIOut,'full-coulomb','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'),& @@ -7692,7 +10673,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, & @@ -7726,7 +10707,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 !> @@ -7932,7 +10913,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 ! @@ -8026,6 +11007,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. Moraes +!> \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. Moraes +!> \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 @@ -8129,35 +11278,35 @@ function mqc_integral_scalar_multiply(integral,scalarIn) result(integralOut) end select ! end function mqc_integral_scalar_multiply - ! -! PROCEDURE MQC_Element_Integral_Multiply ! -!> \brief MQC_Element_Integral_Multiply is used to multiply term-by-term two MQC integral -!> an MQC integral +! 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_Element_Integral_Multiply is used to multiply term-by-term two MQC integral type variable -!> and returns an MQC integral. +!> 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] Integral1 +!> \param[in] eris !> \verbatim -!> Integral is type(mqc_scf_integral) -!> The MQC integral variable to multiply. +!> Integral is type(mqc_twoERIs) +!> The MQC twoERIs variable to multiply. !> \endverbatim !> -!> \param[in] Integral2 +!> \param[in] ScalarIn !> \verbatim -!> Integral is type(mqc_scf_integral) -!> The MQC integral variable to multiply. +!> ScalarIn class(*) +!> The variable to multiply. !> \endverbatim ! ! Authors: @@ -8165,97 +11314,443 @@ end function mqc_integral_scalar_multiply !> \author M. M. F. Moraes !> \date 2025 ! - function mqc_element_integral_multiply(integral1,integral2) result(integralOut) + function mqc_twoERIs_scalar_multiply(eris,scalarIn) result(erisOut) ! implicit none - type(mqc_scf_integral),intent(in)::integral1,integral2 -! Character(Len=*),optional,intent(in)::label - type(mqc_scf_integral)::integralOut - type(mqc_matrix)::tmpMatrixAlpha,tmpMatrixBeta,tmpMatrixAlphaBeta,tmpMatrixBetaAlpha + 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 - integer(kind=int64)::n1A1,n1A2,n1B1,n1B2,n2A1,n2A2,n2B1,n2B2 -! -! if(present(label)) then -! call string_change_case(label,'l',myLabel) -! else - myLabel = '' -! endIf + Character(Len=64)::myLabel,myInt - n1A1 = size(integral1,'alpha',1) - n1A2 = size(integral1,'alpha',2) - n1B1 = size(integral1,'beta',1) - n1B2 = size(integral1,'beta',2) - n2A1 = size(integral2,'alpha',1) - n2A2 = size(integral2,'alpha',2) - n2B1 = size(integral2,'beta',1) - n2B2 = size(integral2,'beta',2) + myLabel = eris%storageType + myInt = eris%interactionType - if(n1A1.ne.n2A1.or.n1A2.ne.n2A2.or.n1B1.ne.n2B1.or.n1B2.ne.n2B2) & - call mqc_error_i('Integral blocks are not conformable in mqc_integral_difference',6,& - 'n1A1-n2A1',n1A1-n2A1,'n1A2-n2A2',n1A2-n2A2,'n1B1-n2B1',n1B1-n2B1,'n1B2-n2B2',n1B2-n2B2) + 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 (integral1%array_type) - case('space') - select case (integral2%array_type) - case('space') - if(integral1%hasAlpha().and.integral2%hasAlpha()) & - tmpMatrixAlpha=MQC_ElementMatrixProduct(integral1%getBlock('alpha'),integral2%getBlock('alpha')) - call mqc_integral_allocate(integralOut,myLabel,'space',tmpMatrixAlpha,nDimA1=n1A1,nDimA2=n1A2,& - nDimB1=n1B1,nDimB2=n1B2) - case('spin','general') - if(integral1%hasAlpha().and.integral2%hasAlpha()) & - tmpMatrixAlpha=MQC_ElementMatrixProduct(integral1%getBlock('alpha'),integral2%getBlock('alpha')) - if(integral1%hasAlpha().and.integral2%hasBeta()) & - tmpMatrixBeta=MQC_ElementMatrixProduct(integral1%getBlock('alpha'),integral2%getBlock('beta')) - call mqc_integral_allocate(integralOut,myLabel,'spin',tmpMatrixAlpha,tmpMatrixBeta,& - nDimA1=n1A1,nDimA2=n1A2,nDimB1=n1B1,nDimB2=n1B2) - case default - call mqc_error_A('Unknown integral type in mqc_element_integral_multiply', 6, & - 'integral2%array_type', integral2%array_type ) - end select + select case (eris%integralType) + case('space','regular','raffenetti1','raffenetti2','raffenetti3') + 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,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,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()) + endIf case('spin') - select case (integral2%array_type) - case('space') - if(integral1%hasAlpha().and.integral2%hasAlpha()) & - tmpMatrixAlpha=MQC_ElementMatrixProduct(integral1%getBlock('alpha'),integral2%getBlock('alpha')) - if(integral1%hasBeta().and.integral2%hasAlpha()) & - tmpMatrixBeta=MQC_ElementMatrixProduct(integral1%getBlock('beta'),integral2%getBlock('alpha')) - call mqc_integral_allocate(integralOut,myLabel,'space',tmpMatrixAlpha,nDimA1=n1A1,nDimA2=n1A2,& - nDimB1=n1B1,nDimB2=n1B2) - case('spin','general') - if(integral1%hasAlpha().and.integral2%hasAlpha()) & - tmpMatrixAlpha=MQC_ElementMatrixProduct(integral1%getBlock('alpha'),integral2%getBlock('alpha')) - if(integral1%hasBeta().and.integral2%hasBeta()) & - tmpMatrixBeta=MQC_ElementMatrixProduct(integral1%getBlock('beta'),integral2%getBlock('beta')) - call mqc_integral_allocate(integralOut,myLabel,'spin',tmpMatrixAlpha,tmpMatrixBeta,& - nDimA1=n1A1,nDimA2=n1A2,nDimB1=n1B1,nDimB2=n1B2) - case default - call mqc_error_A('Unknown integral type in mqc_element_integral_multiply', 6, & - 'integral2%array_type', integral2%array_type ) - end select + 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')) & + baab = scalar*eris%getBlock('baab') + if(eris%intType().eq.'ms') then + if(eris%hasSpinBlock('baba')) & + baba = scalar*eris%getBlock('baba') + call mqc_twoeris_allocate(erisOut,trim(myLabel)//'-'//trim(myInt),'spin',aaaa,bbbb,& + aabb,bbaa,abab,abba,baab,baba) + else + 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,trim(myLabel)//'-'//trim(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,trim(myLabel)//'-'//trim(myInt),'spin',aaaa,bbbb,& + aabb,abab=abab,abba=abba) + elseif(eris%intType().eq.'doublebar') then + 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,trim(myLabel)//'-'//trim(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') - select case (integral2%array_type) - case('space') - if(integral1%hasAlpha().and.integral2%hasAlpha()) & - tmpMatrixAlpha=MQC_ElementMatrixProduct(integral1%getBlock('alpha'),integral2%getBlock('alpha')) - if(integral1%hasBeta().and.integral2%hasAlpha()) & - tmpMatrixBeta=MQC_ElementMatrixProduct(integral1%getBlock('beta'),integral2%getBlock('alpha')) - call mqc_integral_allocate(integralOut,myLabel,'space',tmpMatrixAlpha,nDimA1=n1A1,nDimA2=n1A2,& - nDimB1=n1B1,nDimB2=n1B2) - case('spin') - if(integral1%hasAlpha().and.integral2%hasAlpha()) & - tmpMatrixAlpha=MQC_ElementMatrixProduct(integral1%getBlock('alpha'),integral2%getBlock('alpha')) - if(integral1%hasBeta().and.integral2%hasBeta()) & - tmpMatrixBeta=MQC_ElementMatrixProduct(integral1%getBlock('beta'),integral2%getBlock('beta')) - call mqc_integral_allocate(integralOut,myLabel,'spin',tmpMatrixAlpha,tmpMatrixBeta,& - nDimA1=n1A1,nDimA2=n1A2,nDimB1=n1B1,nDimB2=n1B2) - case('general') - if(integral1%hasAlpha().and.integral2%hasAlpha()) & - tmpMatrixAlpha=MQC_ElementMatrixProduct(integral1%getBlock('alpha'),integral2%getBlock('alpha')) - if(integral1%hasBeta().and.integral2%hasBeta()) & - tmpMatrixBeta=MQC_ElementMatrixProduct(integral1%getBlock('beta'),integral2%getBlock('beta')) - if(integral1%hasAlphaBeta().and.integral2%hasAlphaBeta()) & + 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('baba')) & + baba = scalar*eris%getBlock('baba') + if(eris%hasSpinBlock('baab')) & + baab = scalar*eris%getBlock('baab') + 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') + 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,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, & + 'twoeris%storType()',eris%storType()) + endIf + 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_scalar)::scalar +! + 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 + + erisOut = mqc_twoERIs_scalar_multiply(eris,scalar) +! + end function mqc_scalar_twoERIs_multiply +! +! +! PROCEDURE MQC_Element_Eigenvalues_Multiply +! +!> \brief MQC_Element_Eigenvalues_Multiply is used to multiply term-by-term two MQC +!> Eigenvalues an MQC integral +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_Element_Eigenvalues_Multiply is used to multiply term-by-term two MQC Eigenvalues +!> type variable and returns an MQC integral. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] Eig1 +!> \verbatim +!> Integral is type(mqc_scf_eigenvalues) +!> The MQC eigenvalues variable to multiply. +!> \endverbatim +!> +!> \param[in] Eig2 +!> \verbatim +!> Integral is type(mqc_scf_eigenvalues) +!> The MQC eigenvalues variable to multiply. +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_element_eigenvalues_multiply(eig1,eig2) result(eigOut) +! + implicit none + type(mqc_scf_eigenvalues),intent(in)::eig1,eig2 +! Character(Len=*),optional,intent(in)::label + type(mqc_scf_eigenvalues)::eigOut + type(mqc_vector)::tmpVecAlpha,tmpVecBeta + type(mqc_scalar)::scalar + Character(Len=64)::myLabel + integer(kind=int64)::n1A,n1B,n2A,n2B +! +! if(present(label)) then +! call string_change_case(label,'l',myLabel) +! else + myLabel = '' +! endIf + + n1A = size(eig1,'alpha') + n1B = size(eig1,'beta') + n2A = size(eig2,'alpha') + n2B = size(eig2,'beta') + + if(n1A.ne.n2A.or.n1B.ne.n2B) & + call mqc_error_i('Integral blocks are not conformable in mqc_element_eigenvalues_multiply',6,& + 'n1A',n1A,'n2A',n2A,'n1B',n1B,'n2B',n2B) + + select case (eig1%array_type) + case('space') + select case (eig2%array_type) + case('space') + if(eig1%hasAlpha().and.eig2%hasAlpha()) & + tmpVecAlpha=eig1%getBlock('alpha').ewp.eig2%getBlock('alpha') + call mqc_eigenvalues_allocate(eigOut,myLabel,'space',tmpVecAlpha) + case('spin') + if(eig1%hasAlpha().and.eig2%hasAlpha()) & + tmpVecAlpha=eig1%getBlock('alpha').ewp.eig2%getBlock('alpha') + if(eig1%hasAlpha().and.eig2%hasBeta()) & + tmpVecBeta=eig1%getBlock('alpha').ewp.eig2%getBlock('beta') + call mqc_eigenvalues_allocate(eigOut,myLabel,'space',tmpVecAlpha,tmpVecBeta) + case default + call mqc_error_A('Unknown integral type in mqc_element_eigenvalues_multiply', 6, & + 'eig2%array_type', eig2%array_type ) + end select + case('spin') + select case (eig2%array_type) + case('space') + if(eig1%hasAlpha().and.eig2%hasAlpha()) & + tmpVecAlpha=eig1%getBlock('alpha').ewp.eig2%getBlock('alpha') + if(eig1%hasBeta().and.eig2%hasAlpha()) & + tmpVecBeta=eig1%getBlock('beta').ewp.eig2%getBlock('alpha') + call mqc_eigenvalues_allocate(eigOut,myLabel,'space',tmpVecAlpha,tmpVecBeta) + case('spin') + if(eig1%hasAlpha().and.eig2%hasAlpha()) & + tmpVecAlpha=eig1%getBlock('alpha').ewp.eig2%getBlock('alpha') + if(eig1%hasBeta().and.eig2%hasBeta()) & + tmpVecBeta=eig1%getBlock('beta').ewp.eig2%getBlock('beta') + call mqc_eigenvalues_allocate(eigOut,myLabel,'space',tmpVecAlpha,tmpVecBeta) + case default + call mqc_error_A('Unknown integral type in mqc_element_eigenvalues_multiply', 6, & + 'eig2%array_type', eig2%array_type ) + end select + case default + call mqc_error_A('Unknown integral type in mqc_element_eigenvalues_multiply', 6, & + 'eig1%array_type', eig1%array_type ) + end select + end function mqc_element_eigenvalues_multiply +! +! +! +! PROCEDURE MQC_Element_Integral_Multiply +! +!> \brief MQC_Element_Integral_Multiply is used to multiply term-by-term two MQC integral +!> an MQC integral +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_Element_Integral_Multiply is used to multiply term-by-term two MQC integral type variable +!> and returns an MQC integral. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] Integral1 +!> \verbatim +!> Integral is type(mqc_scf_integral) +!> The MQC integral variable to multiply. +!> \endverbatim +!> +!> \param[in] Integral2 +!> \verbatim +!> Integral is type(mqc_scf_integral) +!> The MQC integral variable to multiply. +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2025 +! + function mqc_element_integral_multiply(integral1,integral2) result(integralOut) +! + implicit none + type(mqc_scf_integral),intent(in)::integral1,integral2 +! Character(Len=*),optional,intent(in)::label + type(mqc_scf_integral)::integralOut + type(mqc_matrix)::tmpMatrixAlpha,tmpMatrixBeta,tmpMatrixAlphaBeta,tmpMatrixBetaAlpha + type(mqc_scalar)::scalar + Character(Len=64)::myLabel + integer(kind=int64)::n1A1,n1A2,n1B1,n1B2,n2A1,n2A2,n2B1,n2B2 +! +! if(present(label)) then +! call string_change_case(label,'l',myLabel) +! else + myLabel = '' +! endIf + + n1A1 = size(integral1,'alpha',1) + n1A2 = size(integral1,'alpha',2) + n1B1 = size(integral1,'beta',1) + n1B2 = size(integral1,'beta',2) + n2A1 = size(integral2,'alpha',1) + n2A2 = size(integral2,'alpha',2) + n2B1 = size(integral2,'beta',1) + n2B2 = size(integral2,'beta',2) + + if(n1A1.ne.n2A1.or.n1A2.ne.n2A2.or.n1B1.ne.n2B1.or.n1B2.ne.n2B2) & + call mqc_error_i('Integral blocks are not conformable in mqc_integral_difference',6,& + 'n1A1-n2A1',n1A1-n2A1,'n1A2-n2A2',n1A2-n2A2,'n1B1-n2B1',n1B1-n2B1,'n1B2-n2B2',n1B2-n2B2) + + select case (integral1%array_type) + case('space') + select case (integral2%array_type) + case('space') + if(integral1%hasAlpha().and.integral2%hasAlpha()) & + tmpMatrixAlpha=MQC_ElementMatrixProduct(integral1%getBlock('alpha'),integral2%getBlock('alpha')) + call mqc_integral_allocate(integralOut,myLabel,'space',tmpMatrixAlpha,nDimA1=n1A1,nDimA2=n1A2,& + nDimB1=n1B1,nDimB2=n1B2) + case('spin','general') + if(integral1%hasAlpha().and.integral2%hasAlpha()) & + tmpMatrixAlpha=MQC_ElementMatrixProduct(integral1%getBlock('alpha'),integral2%getBlock('alpha')) + if(integral1%hasAlpha().and.integral2%hasBeta()) & + tmpMatrixBeta=MQC_ElementMatrixProduct(integral1%getBlock('alpha'),integral2%getBlock('beta')) + call mqc_integral_allocate(integralOut,myLabel,'spin',tmpMatrixAlpha,tmpMatrixBeta,& + nDimA1=n1A1,nDimA2=n1A2,nDimB1=n1B1,nDimB2=n1B2) + case default + call mqc_error_A('Unknown integral type in mqc_element_integral_multiply', 6, & + 'integral2%array_type', integral2%array_type ) + end select + case('spin') + select case (integral2%array_type) + case('space') + if(integral1%hasAlpha().and.integral2%hasAlpha()) & + tmpMatrixAlpha=MQC_ElementMatrixProduct(integral1%getBlock('alpha'),integral2%getBlock('alpha')) + if(integral1%hasBeta().and.integral2%hasAlpha()) & + tmpMatrixBeta=MQC_ElementMatrixProduct(integral1%getBlock('beta'),integral2%getBlock('alpha')) + call mqc_integral_allocate(integralOut,myLabel,'space',tmpMatrixAlpha,nDimA1=n1A1,nDimA2=n1A2,& + nDimB1=n1B1,nDimB2=n1B2) + case('spin','general') + if(integral1%hasAlpha().and.integral2%hasAlpha()) & + tmpMatrixAlpha=MQC_ElementMatrixProduct(integral1%getBlock('alpha'),integral2%getBlock('alpha')) + if(integral1%hasBeta().and.integral2%hasBeta()) & + tmpMatrixBeta=MQC_ElementMatrixProduct(integral1%getBlock('beta'),integral2%getBlock('beta')) + call mqc_integral_allocate(integralOut,myLabel,'spin',tmpMatrixAlpha,tmpMatrixBeta,& + nDimA1=n1A1,nDimA2=n1A2,nDimB1=n1B1,nDimB2=n1B2) + case default + call mqc_error_A('Unknown integral type in mqc_element_integral_multiply', 6, & + 'integral2%array_type', integral2%array_type ) + end select + case('general') + select case (integral2%array_type) + case('space') + if(integral1%hasAlpha().and.integral2%hasAlpha()) & + tmpMatrixAlpha=MQC_ElementMatrixProduct(integral1%getBlock('alpha'),integral2%getBlock('alpha')) + if(integral1%hasBeta().and.integral2%hasAlpha()) & + tmpMatrixBeta=MQC_ElementMatrixProduct(integral1%getBlock('beta'),integral2%getBlock('alpha')) + call mqc_integral_allocate(integralOut,myLabel,'space',tmpMatrixAlpha,nDimA1=n1A1,nDimA2=n1A2,& + nDimB1=n1B1,nDimB2=n1B2) + case('spin') + if(integral1%hasAlpha().and.integral2%hasAlpha()) & + tmpMatrixAlpha=MQC_ElementMatrixProduct(integral1%getBlock('alpha'),integral2%getBlock('alpha')) + if(integral1%hasBeta().and.integral2%hasBeta()) & + tmpMatrixBeta=MQC_ElementMatrixProduct(integral1%getBlock('beta'),integral2%getBlock('beta')) + call mqc_integral_allocate(integralOut,myLabel,'spin',tmpMatrixAlpha,tmpMatrixBeta,& + nDimA1=n1A1,nDimA2=n1A2,nDimB1=n1B1,nDimB2=n1B2) + case('general') + if(integral1%hasAlpha().and.integral2%hasAlpha()) & + tmpMatrixAlpha=MQC_ElementMatrixProduct(integral1%getBlock('alpha'),integral2%getBlock('alpha')) + if(integral1%hasBeta().and.integral2%hasBeta()) & + tmpMatrixBeta=MQC_ElementMatrixProduct(integral1%getBlock('beta'),integral2%getBlock('beta')) + if(integral1%hasAlphaBeta().and.integral2%hasAlphaBeta()) & tmpMatrixAlphaBeta=MQC_ElementMatrixProduct(integral1%getBlock('ab'),integral2%getBlock('ab')) if(integral1%hasBetaAlpha().and.integral2%hasBetaAlpha()) & tmpMatrixBetaAlpha=MQC_ElementMatrixProduct(integral1%getBlock('ba'),integral2%getBlock('ba')) @@ -8310,14 +11805,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 @@ -8329,31 +11824,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') @@ -8376,16 +11881,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 @@ -8399,15 +11904,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,'full-coulomb','space',Alpha) elseif (intType.eq.'spin') then - call mqc_twoeris_allocate(ERIsOut,'full','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) endif +! end function mqc_integral_integral_outer_product - ! ! ! PROCEDURE MQC_Integral_Integral_CrossOuter_Product @@ -8448,13 +11955,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 @@ -8466,28 +11973,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') @@ -8506,20 +12013,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 @@ -8527,10 +12034,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,'full-exchange','space',Alpha) + elseif (intType.eq.'spin') then + call mqc_twoeris_allocate(ERIsOut,'full-exchange','spin',Alpha,Beta,AlphaBeta,BetaAlpha) + elseif (intType.eq.'general') then + 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 +! end function mqc_integral_integral_crossouter_product - ! ! ! PROCEDURE MQC_Eigen_Eigen_Outer_Product @@ -9366,7 +12879,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, & @@ -9378,6 +12891,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 @@ -9385,6 +12900,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... @@ -9415,21 +12935,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 @@ -9568,6 +13092,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 @@ -9811,9 +13409,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: @@ -9821,7 +13419,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: @@ -9836,8 +13434,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 @@ -9867,7 +13465,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 @@ -9898,7 +13496,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 @@ -9909,27 +13507,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') & @@ -9946,7 +13542,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 @@ -10268,7 +13864,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 @@ -10279,7 +13875,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 @@ -10294,7 +13890,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 @@ -10588,7 +14184,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), & @@ -10667,6 +14263,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 ! ! @@ -10867,109 +15162,689 @@ 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(.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') & + 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%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%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%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%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%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%inttype', ERIs1%inttype(), 'ERIs2%inttype', ERIs2%inttype()) + end if + 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%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%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%intType()) + case ('coulomb','symm') + select case(eris2%intType()) + case ('symm') + 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%inttype', ERIs2%inttype()) + end select + case ('exchange') + select case(eris2%intType()) + 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%inttype', ERIs2%inttype()) + end select + case ('inverted') + select case(eris2%intType()) + 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%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%inttype', ERIs1%inttype()) + 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%intType()) + 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%inttype', ERIs1%inttype()) + 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%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')) + 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%inttype', ERIs1%inttype()) + end select + case ('exchange') + select case(eris1%intType()) + 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%inttype', ERIs1%inttype()) + end select + case ('inverted') + select case(eris1%intType()) + case ('coulomb','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%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%inttype', ERIs2%inttype()) + 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%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')) + 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%inttype', ERIs2%inttype()) + end select + case ('exchange') + 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')) + 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%inttype', ERIs2%inttype()) + end select + case ('inverted') + select case(eris2%intType()) + case ('coulomb') + ! 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%inttype', ERIs2%inttype()) + end select + case ('doublebar') + 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')) + 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%inttype', ERIs2%inttype()) + end select + case ('ms') + 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')) + 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%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%inttype', ERIs1%inttype()) + 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%intType()) + case ('coulomb') + 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%inttype', ERIs1%inttype()) + 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%intType()) + case ('coulomb') + 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%inttype', ERIs2%inttype()) + 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%intType()) + case ('coulomb') + 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%inttype', ERIs2%inttype()) + 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 @@ -10978,7 +15853,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: ! ============= @@ -11039,7 +15914,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 @@ -11048,9 +15923,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'] @@ -11139,7 +16013,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) @@ -11199,7 +16073,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) @@ -11360,19 +16234,422 @@ function mqc_eri_eri_partial_contraction(eris1,eris2,index1,index2) result(IntOu end function mqc_eri_eri_partial_contraction ! ! -! PROCEDURE MQC_Index_to_String +! PROCEDURE MQC_ERI_ERI_Partial_Contraction_2ERI ! -!> \brief MQC_Index_to_String is a support function to -!> MQC_ERI_ERI_Partial_Contraction that returns an alpha/beta string -!> representing the ERI block to be contracted. +!> \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_Index_to_String is used to return an alpha/beta string based on a target -!> and a reference set of indexes. +!> 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, 2026 +! + 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,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 + 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 + 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) + 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(.not.allocated(eris1).and..not.allocated(eris2)) then + if(allocated(eriOut)) call deallocate(eriOut) + return + else if(.not.allocated(eris1)) then + eriOut = eris2 + return + else if(.not.allocated(eris2)) then + eriOut = eris1 + 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)) + 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)) + 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)) + + intType='unknown' + eriType='empty' + do i=1,16 + 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 + 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)) + 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' + aaaa = aaaa + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + 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(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(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(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(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(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(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. + case('abbb') + if(eris1%storageType.ne.'general'.and.eris2%storageType.ne.'general') cycle + if(eris1%hasSpinBlock(str1).and.eris2%hasSpinBlock(str2)) then + eriType='general' + intType = 'coulomb' + abbb = abbb + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + allocVec(16)=.true. + end if + case('babb') + if(eris1%storageType.ne.'general'.and.eris2%storageType.ne.'general') cycle + if(eris1%hasSpinBlock(str1).and.eris2%hasSpinBlock(str2)) then + eriType='general' + intType = 'coulomb' + babb = babb + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + allocVec(15)=.true. + end if + case('bbab') + if(eris1%storageType.ne.'general'.and.eris2%storageType.ne.'general') cycle + if(eris1%hasSpinBlock(str1).and.eris2%hasSpinBlock(str2)) then + eriType='general' + intType = 'coulomb' + bbab = bbab + MQC_R4Tensor_R4Tensor_Partial_Contraction_2R4Tensor(& + eris1%getBlock(str1),eris2%getBlock(str2),index1,index2) + allocVec(14)=.true. + end if + case('bbba') + if(eris1%storageType.ne.'general'.and.eris2%storageType.ne.'general') cycle + if(eris1%hasSpinBlock(str1).and.eris2%hasSpinBlock(str2)) then + eriType='general' + intType = 'coulomb' + 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' + intType = 'coulomb' + 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' + intType = 'coulomb' + 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' + intType = 'coulomb' + 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' + intType = 'coulomb' + 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 + + if(intType.eq.'unknown') & + call mqc_error('Final StorageType unknown in mqc_eri_eri_partial_contraction_2eri',6) + if (eriType.eq.'empty') then + if(allocated(eriOut)) call deallocate(eriOut) + else if (eriType.eq.'space') then + call mqc_twoeris_allocate(eriOut,'full-'//intType,'space',aaaa,allocationVector=allocVec) + elseif (eriType.eq.'spin') then + 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,'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,'full-'//intType,'general',aaaa,bbbb,aabb,bbaa,& + abab,abba,baab,baba,aaab,aaba,abaa,baaa,bbba,& + bbab,babb,abbb,allocationVector=allocVec) + endif + +! + end function mqc_eri_eri_partial_contraction_2eri +! +! +! PROCEDURE MQC_Index_to_String +! +!> \brief MQC_Index_to_String is a support function to +!> MQC_ERI_ERI_Partial_Contraction that returns an alpha/beta string +!> representing the ERI block to be contracted. +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_Index_to_String is used to return an alpha/beta string based on a target +!> and a reference set of indexes. !> !> !> Example: @@ -11422,6 +16699,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%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-coulomb','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%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-coulomb','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%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-coulomb','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%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-coulomb','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%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-coulomb','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%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-coulomb','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%interactionType.eq.'exchange') then + call mqc_twoeris_allocate(output,'full-inverted','spin',& + alpha,beta,alphaBeta,betaAlpha) + else if(eris%interactionType.eq.'coulomb') then + call mqc_twoeris_allocate(output,'full-coulomb','spin',& + alpha,beta,alphaBeta,betaAlpha) + 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-coulomb','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%interactionType.eq.'exchange') then + call mqc_twoeris_allocate(output,'full-inverted','spin',& + alpha,beta,alphaBeta,betaAlpha) + else if(eris%interactionType.eq.'coulomb') then + call mqc_twoeris_allocate(output,'full-coulomb','spin',& + alpha,beta,alphaBeta,betaAlpha) + 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-coulomb','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%interactionType.eq.'coulomb') then + call mqc_twoeris_allocate(output,'full-exchange','spin',& + alpha,beta,alphaBeta,betaAlpha) + else if(eris%interactionType.eq.'exchange') then + call mqc_twoeris_allocate(output,'full-inverted','spin',& + alpha,beta,alphaBeta,betaAlpha) + 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-coulomb','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%interactionType.eq.'coulomb') then + call mqc_twoeris_allocate(output,'full-inverted','spin',& + alpha,beta,alphaBeta,betaAlpha) + else if(eris%interactionType.eq.'exchange') then + call mqc_twoeris_allocate(output,'full-exchange','spin',& + alpha,beta,alphaBeta,betaAlpha) + 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-coulomb','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%interactionType.eq.'coulomb') then + call mqc_twoeris_allocate(output,'full-exchange','spin',& + alpha,beta,alphaBeta,betaAlpha) + else if(eris%interactionType.eq.'exchange') then + call mqc_twoeris_allocate(output,'full-coulomb','spin',& + alpha,beta,alphaBeta,betaAlpha) + 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-coulomb','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%interactionType.eq.'coulomb') then + call mqc_twoeris_allocate(output,'full-coulomb','spin',& + alpha,beta,alphaBeta,betaAlpha) + else if(eris%interactionType.eq.'exchange') then + call mqc_twoeris_allocate(output,'full-inverted','spin',& + alpha,beta,alphaBeta,betaAlpha) + 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-coulomb','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 + tbbbb = 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 + tbbaa = eris%getBlock('BetaAlpha') + allocVec(4)=.true. + end if + if(eris%hasSpinBlock('abab')) then + tabab = eris%getBlock('abab') + allocVec(5)=.true. + end if + if(eris%hasSpinBlock('abba')) then + tabba = eris%getBlock('abba') + allocVec(6)=.true. + end if + if(eris%hasSpinBlock('baab')) then + tbaab = eris%getBlock('baab') + allocVec(7)=.true. + end if + if(eris%hasSpinBlock('baba')) then + tbaba = eris%getBlock('baba') + allocVec(8)=.true. + end if + if(eris%hasSpinBlock('aaab')) then + taaab = eris%getBlock('aaab') + allocVec(9)=.true. + end if + if(eris%hasSpinBlock('aaba')) then + taaba = eris%getBlock('aaba') + allocVec(10)=.true. + end if + if(eris%hasSpinBlock('abaa')) then + tabaa = eris%getBlock('abaa') + allocVec(11)=.true. + end if + if(eris%hasSpinBlock('baaa')) then + tbaaa = eris%getBlock('baaa') + allocVec(12)=.true. + end if + if(eris%hasSpinBlock('bbba')) then + tbbba = eris%getBlock('bbba') + allocVec(13)=.true. + end if + if(eris%hasSpinBlock('bbab')) then + tbbab = eris%getBlock('bbab') + allocVec(14)=.true. + end if + if(eris%hasSpinBlock('babb')) then + tbabb = eris%getBlock('babb') + allocVec(15)=.true. + end if + if(eris%hasSpinBlock('abbb')) then + tabbb = 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([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,nB3b,nB2b) + do i = 1, nB2b + do j = 1, nB4b + call beta%tput(tbbbb%tat([0],[i,i],[0],[j,j]),[0],[j,j],[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([0],[i,i],[0],[j,j]),[0],[j,j],[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([0],[i,i],[0],[j,j]),[0],[j,j],[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([0],[i,i],[0],[j,j]),[0],[j,j],[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([0],[i,i],[0],[j,j]),[0],[j,j],[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([0],[i,i],[0],[j,j]),[0],[j,j],[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([0],[i,i],[0],[j,j]),[0],[j,j],[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([0],[i,i],[0],[j,j]),[0],[j,j],[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([0],[i,i],[0],[j,j]),[0],[j,j],[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([0],[i,i],[0],[j,j]),[0],[j,j],[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([0],[i,i],[0],[j,j]),[0],[j,j],[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([0],[i,i],[0],[j,j]),[0],[j,j],[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([0],[i,i],[0],[j,j]),[0],[j,j],[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([0],[i,i],[0],[j,j]),[0],[j,j],[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([0],[i,i],[0],[j,j]),[0],[j,j],[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-coulomb','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 @@ -11459,25 +18087,41 @@ 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) ! 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 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 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,'(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) + 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) @@ -11486,24 +18130,24 @@ 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]) 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 - 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 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) @@ -11515,24 +18159,24 @@ 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]) 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 - 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) + 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) @@ -11555,7 +18199,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 @@ -11571,7 +18215,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]),& @@ -11589,7 +18233,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]),& @@ -11612,7 +18256,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 @@ -11629,7 +18273,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]),& @@ -11647,7 +18291,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]),& @@ -11665,7 +18309,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 @@ -11724,7 +18368,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]),& @@ -11742,7 +18386,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]),& @@ -11752,7 +18396,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 @@ -11812,7 +18456,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]),& @@ -11830,7 +18474,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]),& @@ -12554,6 +19198,67 @@ function mqc_scf_integral_determinant(integral) result(determinant) end function mqc_scf_integral_determinant ! ! +! PROCEDURE MQC_SCF_Eigenvalues_Conjg +! +!> \brief MQC_SCF_Eigenvalues_Conjg is a function that returns the complex conjugate +!> of an MQC SCF Eigenvalues +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_SCF_Eigenvalues_Conjg is a function that returns the complex conjugate of an MQC SCF +!> Eigenvalues. +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] Integral +!> \verbatim +!> Eig is Class(MQC_SCF_Eigenvalues) +!> The MQC Eigenvalues which will be evaluated. +!> \endverbatim +!> +!> \param[in] Label +!> \verbatim +!> Label is Character(Len=*),optional +!> Label for the output SCF Eigenvalues. +!> \endverbatim +! +! Authors: +! ======== +!> \author M. M. F. Moraes +!> \date 2026 +! + function mqc_scf_eigenvalues_conjg(eig,label) result(eigOut) +! + implicit none + class(mqc_scf_eigenvalues),intent(in)::eig + Character(Len=*),optional,intent(in)::label + type(mqc_scf_eigenvalues)::eigOut + type(mqc_vector)::tmpVec1,tmpVec2 + Character(Len=64)::myLabel +! + if(present(label)) then + call string_change_case(label,'l',myLabel) + else + myLabel = '' + endIf + + if(eig%type().eq.'space') then + tmpVec1 = conjg(eig%getblock('alpha')) + call mqc_eigenvalues_allocate(eigOut,myLabel,'space',tmpVec1) + elseIf(eig%type().eq.'spin') then + tmpVec1 = conjg(eig%getblock('alpha')) + tmpVec2 = conjg(eig%getblock('beta')) + call mqc_eigenvalues_allocate(eigOut,myLabel,'space',tmpVec1,tmpVec2) + endIf +! + end function mqc_scf_eigenvalues_conjg +! +! ! PROCEDURE MQC_SCF_Integral_Conjg ! !> \brief MQC_SCF_Integral_Conjg is a function that returns the complex conjugate @@ -12753,6 +19458,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 @@ -13495,6 +20240,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) @@ -14542,7 +21292,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) @@ -14550,7 +21300,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)) & @@ -14567,10 +21317,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 @@ -14579,10 +21329,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 @@ -14715,7 +21465,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) @@ -14723,7 +21473,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) @@ -14731,14 +21481,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 @@ -14805,7 +21555,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 ! ! @@ -14906,7 +21656,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,65 +21668,24 @@ 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 ! ! ! PROCEDURE MQC_Eigenvalues_Put ! -!> \brief MQC_Eigenvalues_Put is a function that updates the value of an element +!> \brief MQC_Eigenvalues_Put is a function that updates the value of an element !> of a MQC integral variable !> !> \par Purpose: ! ============= !> !> \verbatim -!> -!> MQC_Eigenvalues_Put is a function that updates the value of (I)th element of a -!> MQC eigenvalues variable as an MQC scalar. If I is negative, the (N-I+1)th +!> +!> MQC_Eigenvalues_Put is a function that updates the value of (I)th element of a +!> MQC eigenvalues variable as an MQC scalar. If I is negative, the (N-I+1)th !> index is selected. Optional argument SpinBlock specifies the spin block of MQC !> eigenvalues. If I is greater than the dimension of the alpha spin block, the -!> remainder is used as the index of the beta spin block. The following options +!> remainder is used as the index of the beta spin block. The following options !> are available: !> !> 1. SpinBlock = 'alpha' uses the alpha spin block. @@ -14985,24 +21698,24 @@ end function mqc_eigenvalues_at !> \param[in] eigenvalues !> \verbatim !> Integral is Class(MQC_SCF_Eigenvalues) -!> The MQC eigenvalues to return the value of the (I)th +!> The MQC eigenvalues to return the value of the (I)th !> element. !> \endverbatim -!> +!> !> \param[in] Element !> \verbatim !> Element is Type(mqc_scalar) !> The value to put in the integral. !> \endverbatim -!> -!> \param[in] I +!> +!> \param[in] I !> \verbatim !> I is Integer(kind=int64) !> The first dimension of the element in MQC eigenvalues !> If I>0 row count is from first index !> If I<0 row count is from last index. !> \endverbatim -!> +!> !> \param[in,out] SpinBlockIn !> \verbatim !> SpinBlock is character(len=64),optional @@ -15025,14 +21738,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')) & @@ -15040,48 +21753,50 @@ 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) + call mqc_error_A('SpinBlock type not valid in MQC_eigenvalues_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 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 - 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 - ! ! 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: @@ -15481,208 +22196,565 @@ function mqc_eigenvalues_maxval(eigenvalues,label) result(output) 'myLabel', myLabel ) end select ! - end function mqc_eigenvalues_maxval + end function mqc_eigenvalues_maxval +! +! +! PROCEDURE MQC_Eigenvalues_Minloc +! +!> \brief MQC_Eigenvalues_Minloc is a function that returns the index of the +!> smallest value of a spin block of an MQC_Eigenvalues variable +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_Eigenvalues_Minval is a function that returns the index of the smallest value of +!> a spin block of an MQC_Eigenvalues variable. The optional argument label specifies +!> which block is queried. The following options are available: +!> +!> 1. Label = 'alpha' returns the alpha spin block. +!> 2. Label = 'beta' returns the beta spin block. +!> 3. Label = 'full' returns the alpha+beta spin block (default). +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in,out] Eigenvalues +!> \verbatim +!> Eigenvalues is Class(MQC_Eigenvalues) +!> The name of the MQC_Eigenvalues variable. +!> \endverbatim +!> +!> \param[in] Label +!> \verbatim +!> Label is Character(Len=*) +!> The spin block to query. +!> \endverbatim +! +! Authors: +! ======== +!> \author L. M. Thompson +!> \date 2025 +! + function mqc_eigenvalues_minloc(eigenvalues,label) result(output) +! + implicit none + class(mqc_scf_eigenvalues),intent(in)::eigenvalues + integer(kind=int64)::output + Character(Len=*),optional,intent(in)::label + Character(Len=64)::myLabel +! + if(present(label)) then + call string_change_case(label,'l',myLabel) + else + mylabel = 'full' + endIf + + select case (myLabel) + case('alpha') + output = minloc(eigenvalues%alpha) + case('beta') + if(eigenvalues%type().eq.'space') then + output = minloc(eigenvalues%alpha) + else + output = minloc(eigenvalues%beta) + endIf + case('full') + if(eigenvalues%type().ne.'space') then + if(minval(eigenvalues%alpha).lt.minval(eigenvalues%beta)) then + output = minloc(eigenvalues%alpha) + else + output = size(eigenvalues%alpha) + minloc(eigenvalues%beta) + endIf + else + output = minloc(eigenvalues%alpha) + endIf + case default + call mqc_error_A('label not valid in mqc_eigenvalues_dimension', 6, & + 'myLabel', myLabel ) + end select +! + end function mqc_eigenvalues_minloc +! +! +! PROCEDURE MQC_Eigenvalues_Maxloc +! +!> \brief MQC_Eigenvalues_Maxloc is a function that returns the index of the +!> largest value of a spin block of an MQC_Eigenvalues variable +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_Eigenvalues_Maxval is a function that returns the index of the largest value of +!> a spin block of an MQC_Eigenvalues variable. The optional argument label specifies +!> which block is queried. The following options are available: +!> +!> 1. Label = 'alpha' returns the alpha spin block. +!> 2. Label = 'beta' returns the beta spin block. +!> 3. Label = 'full' returns the alpha+beta spin block (default). +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in,out] Eigenvalues +!> \verbatim +!> Eigenvalues is Class(MQC_Eigenvalues) +!> The name of the MQC_Eigenvalues variable. +!> \endverbatim +!> +!> \param[in] Label +!> \verbatim +!> Label is Character(Len=*) +!> The spin block to query. +!> \endverbatim +! +! Authors: +! ======== +!> \author L. M. Thompson +!> \date 2025 +! + function mqc_eigenvalues_maxloc(eigenvalues,label) result(output) +! + implicit none + class(mqc_scf_eigenvalues),intent(in)::eigenvalues + integer(kind=int64)::output + Character(Len=*),optional,intent(in)::label + Character(Len=64)::myLabel +! + if(present(label)) then + call string_change_case(label,'l',myLabel) + else + mylabel = 'full' + endIf + + select case (myLabel) + case('alpha') + output = maxloc(eigenvalues%alpha) + case('beta') + if(eigenvalues%type().eq.'space') then + output = maxloc(eigenvalues%alpha) + else + output = maxloc(eigenvalues%beta) + endIf + case('full') + if(eigenvalues%type().ne.'space') then + if(minval(eigenvalues%alpha).lt.minval(eigenvalues%beta)) then + output = maxloc(eigenvalues%alpha) + else + output = size(eigenvalues%alpha) + maxloc(eigenvalues%beta) + endIf + else + output = maxloc(eigenvalues%alpha) + endIf + case default + call mqc_error_A('label not valid in mqc_eigenvalues_dimension', 6, & + 'myLabel', myLabel ) + end select +! + 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 +! +!> \brief MQC_Eigenvalues_Abs is a function that returns the absolute +!> values of all elements of an MQC_Eigenvalues variable +! +!> \par Purpose: +! ============= +!> +!> \verbatim +!> +!> MQC_Eigenvalues_Abs is a function that returns the absolute values of +!> all elements of an MQC_Eigenvalues variable +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in,out] Eigenvalues +!> \verbatim +!> Eigenvalues is Class(MQC_scf_Eigenvalues) +!> The name of the MQC_Eigenvalues variable. +!> \endverbatim +! +! Authors: +! ======== +!> \author L. M. Thompson +!> \date 2025 +! + function mqc_eigenvalues_abs(eigenvalues) result(output) +! + implicit none + class(mqc_scf_eigenvalues),intent(in)::eigenvalues + type(mqc_scf_eigenvalues)::output +! + output = eigenvalues + if(output%hasalpha()) output%alpha = abs(output%alpha) + if(output%hasbeta()) output%beta = abs(output%beta) ! + end function mqc_eigenvalues_abs ! -! PROCEDURE MQC_Eigenvalues_Minloc ! -!> \brief MQC_Eigenvalues_Minloc is a function that returns the index of the -!> smallest value of a spin block of an MQC_Eigenvalues variable +! 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_Minval is a function that returns the index of the smallest value of -!> a spin block of an MQC_Eigenvalues variable. The optional argument label specifies -!> which block is queried. The following options are available: -!> -!> 1. Label = 'alpha' returns the alpha spin block. -!> 2. Label = 'beta' returns the beta spin block. -!> 3. Label = 'full' returns the alpha+beta spin block (default). +!> 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,out] Eigenvalues +!> \param[in] Eigenvalues !> \verbatim !> Eigenvalues is Class(MQC_Eigenvalues) !> The name of the MQC_Eigenvalues variable. !> \endverbatim -!> -!> \param[in] Label -!> \verbatim -!> Label is Character(Len=*) -!> The spin block to query. -!> \endverbatim ! ! Authors: ! ======== !> \author L. M. Thompson -!> \date 2025 +!> \date 2026 ! - function mqc_eigenvalues_minloc(eigenvalues,label) result(output) + function mqc_eigenvalues_to_integral(eigenvalues) result(output) ! implicit none class(mqc_scf_eigenvalues),intent(in)::eigenvalues - integer(kind=int64)::output - Character(Len=*),optional,intent(in)::label - Character(Len=64)::myLabel + type(mqc_scf_integral)::output ! - if(present(label)) then - call string_change_case(label,'l',myLabel) - else - mylabel = 'full' - endIf - - select case (myLabel) - case('alpha') - output = minloc(eigenvalues%alpha) - case('beta') - if(eigenvalues%type().eq.'space') then - output = minloc(eigenvalues%alpha) - else - output = minloc(eigenvalues%beta) - endIf - case('full') - if(eigenvalues%type().ne.'space') then - if(minval(eigenvalues%alpha).lt.minval(eigenvalues%beta)) then - output = minloc(eigenvalues%alpha) - else - output = size(eigenvalues%alpha) + minloc(eigenvalues%beta) - endIf - else - output = minloc(eigenvalues%alpha) - endIf + 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('label not valid in mqc_eigenvalues_dimension', 6, & - 'myLabel', myLabel ) - end select + 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_minloc + end function mqc_eigenvalues_to_integral ! ! -! PROCEDURE MQC_Eigenvalues_Maxloc +! PROCEDURE MQC_Eigenvalues_Power_Func ! -!> \brief MQC_Eigenvalues_Maxloc is a function that returns the index of the -!> largest value of a spin block of an MQC_Eigenvalues variable +!> \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_Maxval is a function that returns the index of the largest value of -!> a spin block of an MQC_Eigenvalues variable. The optional argument label specifies -!> which block is queried. The following options are available: -!> -!> 1. Label = 'alpha' returns the alpha spin block. -!> 2. Label = 'beta' returns the beta spin block. -!> 3. Label = 'full' returns the alpha+beta spin block (default). +!> 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] Eigenvalues +!> \param[in,out] A !> \verbatim -!> Eigenvalues is Class(MQC_Eigenvalues) -!> The name of the MQC_Eigenvalues variable. +!> A is Class(MQC_SCF_Eigenvalues) +!> The name of the MQC_SCF_Eigenvalues variable. !> \endverbatim !> -!> \param[in] Label +!> \param[in] P !> \verbatim -!> Label is Character(Len=*) -!> The spin block to query. +!> P is Class(*) +!> The power to raise elements of the MQC vector. !> \endverbatim ! ! Authors: ! ======== !> \author L. M. Thompson -!> \date 2025 -! - function mqc_eigenvalues_maxloc(eigenvalues,label) result(output) +!> \date 2026 ! - implicit none - class(mqc_scf_eigenvalues),intent(in)::eigenvalues - integer(kind=int64)::output - Character(Len=*),optional,intent(in)::label - Character(Len=64)::myLabel + function mqc_eigenvalues_power_func(A,P) result(AOut) ! - if(present(label)) then - call string_change_case(label,'l',myLabel) - else - mylabel = 'full' - endIf + Implicit None + class(mqc_scf_eigenvalues),intent(in)::A + class(*),intent(in)::P + type(mqc_scf_eigenvalues)::AOut - select case (myLabel) - case('alpha') - output = maxloc(eigenvalues%alpha) - case('beta') - if(eigenvalues%type().eq.'space') then - output = maxloc(eigenvalues%alpha) - else - output = maxloc(eigenvalues%beta) - endIf - case('full') - if(eigenvalues%type().ne.'space') then - if(minval(eigenvalues%alpha).lt.minval(eigenvalues%beta)) then - output = maxloc(eigenvalues%alpha) - else - output = size(eigenvalues%alpha) + maxloc(eigenvalues%beta) - endIf - else - output = maxloc(eigenvalues%alpha) - endIf - case default - call mqc_error_A('label not valid in mqc_eigenvalues_dimension', 6, & - 'myLabel', myLabel ) - end select + type(mqc_scalar)::scalar ! - end function mqc_eigenvalues_maxloc +! 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 ! -! PROCEDURE MQC_Eigenvalues_Abs + end function mqc_eigenvalues_power_func ! -!> \brief MQC_Eigenvalues_Abs is a function that returns the absolute -!> values of all elements of an MQC_Eigenvalues variable +! +! 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_Abs is a function that returns the absolute values of -!> all elements of an MQC_Eigenvalues variable +!> 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] Eigenvalues +!> \param[in,out] A !> \verbatim -!> Eigenvalues is Class(MQC_Eigenvalues) -!> The name of the MQC_Eigenvalues variable. +!> 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 2025 -! - function mqc_eigenvalues_abs(eigenvalues) result(output) +!> \date 2026 ! - implicit none - class(mqc_scf_eigenvalues),intent(in)::eigenvalues - type(mqc_scf_eigenvalues)::output + subroutine mqc_eigenvalues_sort(Eigs,idxA,idxB) ! - output = eigenvalues - if(output%hasalpha()) output%alpha = abs(output%alpha) - if(output%hasbeta()) output%beta = abs(output%beta) + 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 function mqc_eigenvalues_abs + end subroutine mqc_eigenvalues_sort ! ! !===================================================================== @@ -15985,7 +23057,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) @@ -16154,8 +23226,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 @@ -16201,7 +23273,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 @@ -16215,11 +23287,28 @@ 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 - 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 @@ -16326,15 +23415,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) ! @@ -16386,7 +23475,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 @@ -16679,23 +23768,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 @@ -17000,7 +24120,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 @@ -17731,6 +24851,7 @@ Subroutine TwoERI_Trans(IOut,IPrint,MO_Coeff,ERIs,MO_ERIs,Right_MOs) ! Implicit None Integer(kind=int64)::IOut,IPrint,NBasis,P,Q,R,S,Mu,Nu,Lambda,Sigma,IErr + Integer(kind=int64)::NL1,NL2,NR1,NR2 real(kind=real64)::Zero=0.0d0 Logical::DoON5 Type(MQC_Matrix)::X,Y @@ -17743,8 +24864,10 @@ Subroutine TwoERI_Trans(IOut,IPrint,MO_Coeff,ERIs,MO_ERIs,Right_MOs) Type(MQC_TwoERIs),Intent(InOut)::MO_ERIs Type(MQC_SCF_Integral),Intent(In)::MO_Coeff Type(MQC_SCF_Integral),Optional,Intent(In)::Right_MOs - Type(MQC_SCF_Integral)::MO_Coeff_2 + Type(MQC_SCF_Integral)::MO_Coeff_2,MO_Coeff_3,MO_Coeff_4 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') @@ -17754,14 +24877,28 @@ 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 only implemented for & - & regular stored 2ERIs',6,'ERIs%type()',ERIs%type()) + 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 Else MO_Coeff_2 = MO_Coeff EndIf +! + !If(Present(Right_MO2))then + ! MO_Coeff_3 = Right_MO2 + !Else + ! MO_Coeff_3 = MO_Coeff + !EndIf +! + !If(Present(Left_MO2))then + ! MO_Coeff_4 = Left_MO2 + !Else + ! MO_Coeff_4 = MO_Coeff_2 + !EndIf ! If(MO_Coeff%type().eq.'general'.or.MO_Coeff_2%type().eq.'general') then intType = 'general' @@ -17779,28 +24916,70 @@ Subroutine TwoERI_Trans(IOut,IPrint,MO_Coeff,ERIs,MO_ERIs,Right_MOs) NBasis = MQC_Matrix_Rows(MO_Coeff%Alpha) - call tmpR4TensorAlpha%init(NBasis,NBasis,NBasis,NBasis) + NPAlpha = NBasis + NQAlpha = NBasis + NRAlpha = NBasis + NSAlpha = NBasis + + NPBeta = NBasis + NQBeta = NBasis + NRBeta = NBasis + NSBeta = NBasis + + NMuAlpha = NBasis + NNuAlpha = NBasis + NLambdaAlpha =NBasis + NSigmaAlpha =NBasis + + NMuBeta = NBasis + NNuBeta = NBasis + NLambdaBeta =NBasis + NSigmaBeta = NBasis + + !NPAlpha = MQC_Matrix_Rows(MO_Coeff%Alpha) + !NQAlpha = MQC_Matrix_Rows(MO_Coeff_3%Alpha) + !NRAlpha = MQC_Matrix_Rows(MO_Coeff_2%Alpha) + !NSAlpha = MQC_Matrix_Rows(MO_Coeff_4%Alpha) + + !NPBeta = MQC_Matrix_Rows(MO_Coeff%Beta) + !NQBeta = MQC_Matrix_Rows(MO_Coeff_3%Beta) + !NRBeta = MQC_Matrix_Rows(MO_Coeff_2%Beta) + !NSBeta = MQC_Matrix_Rows(MO_Coeff_4%Beta) + + !NMuAlpha = MQC_Matrix_Cols(MO_Coeff%Alpha) + !NNuAlpha = MQC_Matrix_Cols(MO_Coeff_3%Alpha) + !NLambdaAlpha = MQC_Matrix_Cols(MO_Coeff_2%Alpha) + !NSigmaAlpha = MQC_Matrix_Cols(MO_Coeff_4%Alpha) + + !NMuBeta = MQC_Matrix_Cols(MO_Coeff%Beta) + !NNuBeta = MQC_Matrix_Cols(MO_Coeff_3%Beta) + !NLambdaBeta = MQC_Matrix_Cols(MO_Coeff_2%Beta) + !NSigmaBeta = MQC_Matrix_Cols(MO_Coeff_4%Beta) + + call tmpR4TensorAlpha%init(NPAlpha,NQAlpha,NRAlpha,NSAlpha) If(intType.eq.'spin'.or.intType.eq.'general') then - call tmpR4TensorBeta%init(NBasis,NBasis,NBasis,NBasis) - call tmpR4TensorAlphaBeta%init(NBasis,NBasis,NBasis,NBasis) - If(storage.eq.'full') call tmpR4TensorBetaAlpha%init(NBasis,NBasis,NBasis,NBasis) + call tmpR4TensorBeta%init(NPBeta,NQBeta,NRBeta,NSBeta) + call tmpR4TensorAlphaBeta%init(NPAlpha,NQAlpha,NRBeta,NSBeta) + If(storage.eq.'full') call tmpR4TensorBetaAlpha%init(NPBeta,NQBeta,NRAlpha,NSAlpha) EndIf If(intType.eq.'general') then - call tmpR4TensorABAB%init(NBasis,NBasis,NBasis,NBasis) - If(storage.eq.'full') call tmpR4TensorBABA%init(NBasis,NBasis,NBasis,NBasis) - call tmpR4TensorABBA%init(NBasis,NBasis,NBasis,NBasis) - If(storage.eq.'full') call tmpR4TensorBAAB%init(NBasis,NBasis,NBasis,NBasis) - call tmpR4TensorAAAB%init(NBasis,NBasis,NBasis,NBasis) - If(storage.eq.'full') call tmpR4TensorAABA%init(NBasis,NBasis,NBasis,NBasis) - If(storage.eq.'full') call tmpR4TensorABAA%init(NBasis,NBasis,NBasis,NBasis) - If(storage.eq.'full') call tmpR4TensorBAAA%init(NBasis,NBasis,NBasis,NBasis) - If(storage.eq.'full') call tmpR4TensorBBBA%init(NBasis,NBasis,NBasis,NBasis) - If(storage.eq.'full') call tmpR4TensorBBAB%init(NBasis,NBasis,NBasis,NBasis) - If(storage.eq.'full') call tmpR4TensorBABB%init(NBasis,NBasis,NBasis,NBasis) - call tmpR4TensorABBB%init(NBasis,NBasis,NBasis,NBasis) + call tmpR4TensorABAB%init(NPAlpha,NQBeta,NRAlpha,NSBeta) + If(storage.eq.'full') call tmpR4TensorBABA%init(NPBeta,NQAlpha,NRBeta,NSAlpha) + call tmpR4TensorABBA%init(NPAlpha,NQBeta,NRBeta,NSAlpha) + If(storage.eq.'full') call tmpR4TensorBAAB%init(NPBeta,NQAlpha,NRAlpha,NSBeta) + call tmpR4TensorAAAB%init(NPAlpha,NQAlpha,NRAlpha,NSBeta) + If(storage.eq.'full') call tmpR4TensorAABA%init(NPAlpha,NQAlpha,NRBeta,NSAlpha) + If(storage.eq.'full') call tmpR4TensorABAA%init(NPAlpha,NQBeta,NRAlpha,NSAlpha) + If(storage.eq.'full') call tmpR4TensorBAAA%init(NPBeta,NQAlpha,NRAlpha,NSAlpha) + If(storage.eq.'full') call tmpR4TensorBBBA%init(NPBeta,NQBeta,NRBeta,NSAlpha) + If(storage.eq.'full') call tmpR4TensorBBAB%init(NPBeta,NQBeta,NRAlpha,NSBeta) + If(storage.eq.'full') call tmpR4TensorBABB%init(NPBeta,NQAlpha,NRBeta,NSBeta) + call tmpR4TensorABBB%init(NPAlpha,NQBeta,NRBeta,NSBeta) EndIf ! If(.not.DoON5) then + If(ERIs%type().ne.'regular') call mqc_error_A('TwoERI_trans only implemented for & + & regular stored 2ERIs',6,'ERIs%type()',ERIs%type()) If(IPrint.ge.4) Write(IOut,2000) Do P = 1, NBasis @@ -20542,20 +27721,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,'full','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,'full','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 @@ -20587,6 +27766,107 @@ 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 = ERIs%interactionType + endIf + myLabel = ERIs%storageType//'-'//mylabel + + select case (ERIs%integralType) + 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')) + tmpbbbb = dagger(ERIs%getblock('bbbb')) + if(ERIs%storageType.eq.'full') then + tmpbbaa = dagger(ERIs%getblock('aabb')) + 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')) + 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')) + 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')) + tmpabbb = dagger(ERIs%getblock('bbba')) + tmpbabb = dagger(ERIs%getblock('bbab')) + tmpbbab = dagger(ERIs%getblock('babb')) + call mqc_twoeris_allocate(ERIsOut,myLabel,'general',tmpaaaa,tmpbbbb,tmpaabb,tmpbbaa,& + 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 ) + end select +! + end function mqc_twoeris_conjugate_transpose +! ! ! PROCEDURE MQC_Integral_Outer @@ -20642,12 +27922,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 @@ -23227,7 +30507,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 \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 + Procedure, Public::ins => mqc_nef_vector_insert + Procedure, Public::dimen => mqc_nef_vector_dimension + 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 + 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 + 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 + + !> \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 + +! +! +! +!---------------------------------------------------------------- +! | +! 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) .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,& + '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_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_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 +! +!> \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_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 +!> 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_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_Map_Insert +! +! +!> \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_Map_Insert is used to insert eigenvalues or NEF vector into a NEF map matrix +!> +!> \endverbatim +! +! Arguments: +! ========== +!> \param[in] MatIn +!> \verbatim +!> MatIn is type(mqc_nef_matrix) +!> 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_Map_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 +! + 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) +! + 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_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_map_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")) + + end if + end if + end if + else + if (present(ExtSCFI)) then + ExtI = ExtSCFI + 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_map_insert",6) + end if + end if +! + 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 +! + + 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 + + + + + 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_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 +! +! +!> \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]) + 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 + 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) + 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,& + 'myBlockName',myBlockName,'myBlockOrder',myBlockOrder) + end if + end do + end if + fsize = fsize + size1 + end do + end if + write(*,*) 'MMFM: