From 36017e1fa651aea7558eecc875dc4c0f17ad97f1 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Fri, 6 Mar 2020 15:59:15 +0100 Subject: [PATCH 01/96] first stab at a vector --- Prog/OpTvector_mod.f90 | 108 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 108 insertions(+) create mode 100644 Prog/OpTvector_mod.f90 diff --git a/Prog/OpTvector_mod.f90 b/Prog/OpTvector_mod.f90 new file mode 100644 index 00000000..04ba5092 --- /dev/null +++ b/Prog/OpTvector_mod.f90 @@ -0,0 +1,108 @@ +! Copyright (C) 2020 The ALF project +! +! The ALF project is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! The ALF project is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with ALF. If not, see http://www.gnu.org/licenses/. +! +! Under Section 7 of GPL version 3 we require you to fulfill the following additional terms: +! +! - It is our hope that this program makes a contribution to the scientific community. Being +! part of that community we feel that it is reasonable to require you to give an attribution +! back to the original authors if you have benefitted from this program. +! Guidelines for a proper citation can be found on the project's homepage +! https://alf.physik.uni-wuerzburg.de . +! +! - We require the preservation of the above copyright notice and this license in all original files. +! +! - We prohibit the misrepresentation of the origin of the original source files. To obtain +! the original source files please visit the homepage https://alf.physik.uni-wuerzburg.de . +! +! - If you make substantial changes to the program we require you to either consider contributing +! to the ALF project or to mark your material in a reasonable way as different from the original version. + + +module OpTvector_mod + implicit none + + type OpTbase ! Dummy data for now + double, dimension(5,5) :: data + end type optbase + + type :: OpTvector + integer :: avamem ! amount of available space + integer :: tail ! last index + OpTbase, allocatable, dimension(:) :: data + contains + procedure :: init => OpTvector_init + procedure :: dealloc => OpTvector_dealloc + procedure :: pushback => OpTvector_pushback + procedure :: at => OpTvector_at + procedure :: back => OpTvector_back + procedure :: length => OpTvector_length + ! FIXME: do we need insert? + end type OpTvector + +contains + +subroutine OpTvector_init(this) + class(OpTvector) :: this + OpTbase :: temp + this%tail = 1 + this%avamem = 4096/(STORAGE_SIZE(temp)/8) ! allocate a page of memory ! Note STORAGE_SIZE: F2008, SIZEOF: GCC Extension + allocate(this%data(this%avamem)) +end subroutine OpTvector_init + +subroutine OpTvector_dealloc(this) + class(OpTvector) :: this + deallocate(this%data) +end subroutine + +subroutine OpTvector_pushback(this, itm) + class(OpTvector) :: this + OpTbase, intent(in) :: itm + OpTbase, allocatable, dimension(:) :: temp + integer :: i + if (this%tail == this%avamem) then ! check if this still works the same as for plain ints. + ! reallocate the memory + write (*,*) "not enough space!" + call MOVE_ALLOC(this%data, temp) + allocate(this%data(2*this%avamem)) + do i = 1, this%avamem + this%data(i) = temp(i) + enddo + deallocate(temp) + this%avamem = 2*this%avamem + endif + this%data(this%tail) = itm + this%tail = this%tail + 1 +end subroutine + +subroutine OpTvector_at(this, pos, itm) + class(OpTvector) :: this + integer, intent(in) :: pos + OpTbase, intent(out) :: itm + itm = this%data(pos) +end subroutine + +subroutine OpTvector_back(this, itm) + class(OpTvector) :: this + OpTbase, intent(out) :: itm + itm = this%data(this%tail-1) +end subroutine + +function OpTvector_length(this) result(l) + class(OpTvector) :: this + integer :: l + l = this%tail-1 +end function + +end module OpTvector_mod -- GitLab From 7ad0aa16ca8e6e11f0ab7ea56dfeac0f7a916eab Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Tue, 10 Mar 2020 15:40:46 +0100 Subject: [PATCH 02/96] forgot makefile changes --- Prog/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Prog/Makefile b/Prog/Makefile index 0686cf1a..a141f239 100644 --- a/Prog/Makefile +++ b/Prog/Makefile @@ -5,7 +5,7 @@ OBJS= LRC_mod.o control_mod.o Fields_mod.o Operator_mod.o WaveFunction_mod.o obs Global_mod.o Wrapgr_mod.o tau_m_mod.o tau_p_mod.o main.o wrapul.o cgr1.o wrapur.o cgr2_2.o upgrade.o MODS= control.mod fields_mod.mod global_mod.mod hop_mod.mod lrc_mod.mod observables.mod \ operator_mod.mod predefined_structures.mod qdrp_mod.mod tau_m_mod.mod tau_p_mod.mod \ - udv_state_mod.mod udv_wrap_mod.mod wavefunction_mod.mod wrapgr_mod.mod hamiltonian.mod + udv_state_mod.mod udv_wrap_mod.mod wavefunction_mod.mod wrapgr_mod.mod hamiltonian.mod OpTvector_mod.mod OHAM= Hamiltonian_Examples_mod.o Hamiltonians/Hamiltonian_Z2_slave_spins_mod.o Hamiltonians/Hamiltonian_Z2_Matter_mod.o \ Hamiltonians/Hamiltonian_Hub_Canonical_mod.o Hamiltonians/Hamiltonian_Kondo_Honey_mod.o Hamiltonians/Hamiltonian_KN_Kondo_chain.o BINS= Examples.out Z2_slave_spins.out Z2_Matter.out Hubb_Can.out Kondo_Honey.out KN_Kondo.out -- GitLab From 5842a68cea3fcead4032d980d44d6e42a2a90079 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Tue, 10 Mar 2020 15:41:10 +0100 Subject: [PATCH 03/96] test --- Prog/main.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/Prog/main.F90 b/Prog/main.F90 index 688d29a5..f358174a 100644 --- a/Prog/main.F90 +++ b/Prog/main.F90 @@ -124,6 +124,7 @@ Program Main Use UDV_State_mod Use Wrapgr_mod Use Fields_mod + Use OpTvector_mod #ifdef MPI Use mpi #endif -- GitLab From 8441c3d3298f5077b88c6c10abb6f72f998a9958 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Sun, 26 Apr 2020 21:54:59 +0200 Subject: [PATCH 04/96] Add a wrapper to store polymorphic pointers and set up some class examples --- Prog/OpTvector_mod.f90 | 58 ++++++++++++++++++++++++++++++++++-------- 1 file changed, 48 insertions(+), 10 deletions(-) diff --git a/Prog/OpTvector_mod.f90 b/Prog/OpTvector_mod.f90 index 04ba5092..cffbde19 100644 --- a/Prog/OpTvector_mod.f90 +++ b/Prog/OpTvector_mod.f90 @@ -32,15 +32,41 @@ module OpTvector_mod implicit none - - type OpTbase ! Dummy data for now - double, dimension(5,5) :: data + + ! Base for defining the interface + type, abstract :: OpTbase + contains + procedure(multabs), deferred :: mult end type optbase + abstract interface + subroutine multabs(this, arg) + import OpTbase + class(OpTbase), intent(in) :: this + Complex(kind=kind(0.d0)), intent(inout) :: arg + end subroutine + end interface + + type, extends(OpTbase) :: RealOpT + Real(kind=kind(0.d0)) :: mat + contains + procedure :: mult => RealOpT_mult + end type RealOpT + + type, extends(OpTbase) :: CmplxOpT + Complex(kind=kind(0.d0)) :: mat + contains + procedure :: mult => CmplxOpT_mult + end type CmplxOpT + + type :: OpTBasePtrWrapper + class(optbase), pointer :: dat + end type + type :: OpTvector integer :: avamem ! amount of available space integer :: tail ! last index - OpTbase, allocatable, dimension(:) :: data + type(OpTbasePtrWrapper), allocatable, dimension(:) :: data contains procedure :: init => OpTvector_init procedure :: dealloc => OpTvector_dealloc @@ -50,12 +76,24 @@ module OpTvector_mod procedure :: length => OpTvector_length ! FIXME: do we need insert? end type OpTvector - + contains + subroutine RealOpT_mult(this, arg) + class(RealOpT), intent(in) :: this + Complex(kind=kind(0.d0)), intent(inout) :: arg + arg = arg * this%mat + end subroutine + + subroutine CmplxOpT_mult(this, arg) + class(CmplxOpT), intent(in) :: this + Complex(kind=kind(0.d0)), intent(inout) :: arg + arg = arg * this%mat + end subroutine + subroutine OpTvector_init(this) class(OpTvector) :: this - OpTbase :: temp + type(OpTbasePtrWrapper) :: temp this%tail = 1 this%avamem = 4096/(STORAGE_SIZE(temp)/8) ! allocate a page of memory ! Note STORAGE_SIZE: F2008, SIZEOF: GCC Extension allocate(this%data(this%avamem)) @@ -68,8 +106,8 @@ end subroutine subroutine OpTvector_pushback(this, itm) class(OpTvector) :: this - OpTbase, intent(in) :: itm - OpTbase, allocatable, dimension(:) :: temp + type(OpTbasePtrWrapper), intent(in) :: itm + type(OpTbasePtrWrapper), allocatable, dimension(:) :: temp integer :: i if (this%tail == this%avamem) then ! check if this still works the same as for plain ints. ! reallocate the memory @@ -89,13 +127,13 @@ end subroutine subroutine OpTvector_at(this, pos, itm) class(OpTvector) :: this integer, intent(in) :: pos - OpTbase, intent(out) :: itm + type(OpTbasePtrWrapper), intent(out) :: itm itm = this%data(pos) end subroutine subroutine OpTvector_back(this, itm) class(OpTvector) :: this - OpTbase, intent(out) :: itm + type(OpTbasePtrWrapper), intent(out) :: itm itm = this%data(this%tail-1) end subroutine -- GitLab From 8af741c2c6c9e67f3fc04405539db55c2f28cef1 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Mon, 4 May 2020 03:51:51 +0200 Subject: [PATCH 05/96] some renaming and a proper set up of a class hierarchy. --- Prog/ContainerElementBase_mod.F90 | 51 +++++++++++++ ...tor_mod.F90 => DynamicMatrixArray_mod.F90} | 75 +++++-------------- Prog/Makefile | 4 +- Prog/OpTTypes_mod.F90 | 59 +++++++++++++++ 4 files changed, 131 insertions(+), 58 deletions(-) create mode 100644 Prog/ContainerElementBase_mod.F90 rename Prog/{OpTvector_mod.F90 => DynamicMatrixArray_mod.F90} (68%) create mode 100644 Prog/OpTTypes_mod.F90 diff --git a/Prog/ContainerElementBase_mod.F90 b/Prog/ContainerElementBase_mod.F90 new file mode 100644 index 00000000..da69cfea --- /dev/null +++ b/Prog/ContainerElementBase_mod.F90 @@ -0,0 +1,51 @@ +! Copyright (C) 2020 The ALF project +! +! The ALF project is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! The ALF project is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with ALF. If not, see http://www.gnu.org/licenses/. +! +! Under Section 7 of GPL version 3 we require you to fulfill the following additional terms: +! +! - It is our hope that this program makes a contribution to the scientific community. Being +! part of that community we feel that it is reasonable to require you to give an attribution +! back to the original authors if you have benefitted from this program. +! Guidelines for a proper citation can be found on the project's homepage +! https://alf.physik.uni-wuerzburg.de . +! +! - We require the preservation of the above copyright notice and this license in all original files. +! +! - We prohibit the misrepresentation of the origin of the original source files. To obtain +! the original source files please visit the homepage https://alf.physik.uni-wuerzburg.de . +! +! - If you make substantial changes to the program we require you to either consider contributing +! to the ALF project or to mark your material in a reasonable way as different from the original version. + + +! Declare a common base class for the interface: it multiplies with complex matrices +module ContainerElementBase_mod + implicit none + + ! Base for defining the interface + type, abstract :: ContainerElementBase + contains + procedure(multabs), deferred :: mult + end type ContainerElementBase + + abstract interface + subroutine multabs(this, arg) + import ContainerElementBase + class(ContainerElementBase), intent(in) :: this + Complex(kind=kind(0.d0)), intent(inout), allocatable,dimension(:,:) :: arg + end subroutine + end interface + +end module ContainerElementBase_mod diff --git a/Prog/OpTvector_mod.F90 b/Prog/DynamicMatrixArray_mod.F90 similarity index 68% rename from Prog/OpTvector_mod.F90 rename to Prog/DynamicMatrixArray_mod.F90 index cffbde19..9beecd56 100644 --- a/Prog/OpTvector_mod.F90 +++ b/Prog/DynamicMatrixArray_mod.F90 @@ -30,40 +30,15 @@ ! to the ALF project or to mark your material in a reasonable way as different from the original version. -module OpTvector_mod +module DynamicMatrixArray_mod + Use ContainerElementBase implicit none - ! Base for defining the interface - type, abstract :: OpTbase - contains - procedure(multabs), deferred :: mult - end type optbase - - abstract interface - subroutine multabs(this, arg) - import OpTbase - class(OpTbase), intent(in) :: this - Complex(kind=kind(0.d0)), intent(inout) :: arg - end subroutine - end interface - - type, extends(OpTbase) :: RealOpT - Real(kind=kind(0.d0)) :: mat - contains - procedure :: mult => RealOpT_mult - end type RealOpT - - type, extends(OpTbase) :: CmplxOpT - Complex(kind=kind(0.d0)) :: mat - contains - procedure :: mult => CmplxOpT_mult - end type CmplxOpT - type :: OpTBasePtrWrapper - class(optbase), pointer :: dat + class(ContainerElementBase), pointer :: dat end type - type :: OpTvector + type :: DynamicMatrixArray integer :: avamem ! amount of available space integer :: tail ! last index type(OpTbasePtrWrapper), allocatable, dimension(:) :: data @@ -75,37 +50,25 @@ module OpTvector_mod procedure :: back => OpTvector_back procedure :: length => OpTvector_length ! FIXME: do we need insert? - end type OpTvector + end type DynamicMatrixArray contains - subroutine RealOpT_mult(this, arg) - class(RealOpT), intent(in) :: this - Complex(kind=kind(0.d0)), intent(inout) :: arg - arg = arg * this%mat - end subroutine - - subroutine CmplxOpT_mult(this, arg) - class(CmplxOpT), intent(in) :: this - Complex(kind=kind(0.d0)), intent(inout) :: arg - arg = arg * this%mat - end subroutine - -subroutine OpTvector_init(this) - class(OpTvector) :: this +subroutine DynamicMatrixArray_init(this) + class(DynamicMatrixArray) :: this type(OpTbasePtrWrapper) :: temp this%tail = 1 this%avamem = 4096/(STORAGE_SIZE(temp)/8) ! allocate a page of memory ! Note STORAGE_SIZE: F2008, SIZEOF: GCC Extension allocate(this%data(this%avamem)) -end subroutine OpTvector_init +end subroutine DynamicMatrixArray_init -subroutine OpTvector_dealloc(this) - class(OpTvector) :: this +subroutine DynamicMatrixArray_dealloc(this) + class(DynamicMatrixArray) :: this deallocate(this%data) end subroutine -subroutine OpTvector_pushback(this, itm) - class(OpTvector) :: this +subroutine DynamicMatrixArray_pushback(this, itm) + class(DynamicMatrixArray) :: this type(OpTbasePtrWrapper), intent(in) :: itm type(OpTbasePtrWrapper), allocatable, dimension(:) :: temp integer :: i @@ -124,23 +87,23 @@ subroutine OpTvector_pushback(this, itm) this%tail = this%tail + 1 end subroutine -subroutine OpTvector_at(this, pos, itm) - class(OpTvector) :: this +subroutine DynamicMatrixArray_at(this, pos, itm) + class(DynamicMatrixArray) :: this integer, intent(in) :: pos type(OpTbasePtrWrapper), intent(out) :: itm itm = this%data(pos) end subroutine -subroutine OpTvector_back(this, itm) - class(OpTvector) :: this +subroutine DynamicMatrixArray_back(this, itm) + class(DynamicMatrixArray) :: this type(OpTbasePtrWrapper), intent(out) :: itm itm = this%data(this%tail-1) end subroutine -function OpTvector_length(this) result(l) - class(OpTvector) :: this +function DynamicMatrixArray_length(this) result(l) + class(DynamicMatrixArray) :: this integer :: l l = this%tail-1 end function -end module OpTvector_mod +end module DynamicMatrixArray_mod diff --git a/Prog/Makefile b/Prog/Makefile index 0bf1aea7..6fd56ec9 100644 --- a/Prog/Makefile +++ b/Prog/Makefile @@ -1,13 +1,13 @@ .PHONY : Compile tidy clean Examples Z2_Slave Z2_Matter Hub_Can Kondo_Honey -OBJS= LRC_mod.o control_mod.o Fields_mod.o Operator_mod.o WaveFunction_mod.o observables_mod.o OpTvector_mod.o \ +OBJS= LRC_mod.o control_mod.o Fields_mod.o Operator_mod.o WaveFunction_mod.o observables_mod.o ContainerElementBase_mod.o OpTTypes_mod.o\ Predefined_Int_mod.o Predefined_Obs_mod.o Predefined_Latt_mod.o Predefined_Hop_mod.o Predefined_Trial_mod.o \ $(HAMILTONIAN) QDRP_decompose_mod.o udv_state_mod.o Hop_mod.o UDV_WRAP_mod.o \ Global_mod.o Wrapgr_mod.o tau_m_mod.o tau_p_mod.o main.o wrapul.o cgr1.o wrapur.o cgr2_2.o upgrade.o MODS= control.mod fields_mod.mod global_mod.mod hop_mod.mod lrc_mod.mod observables.mod \ operator_mod.mod predefined_int.mod predefined_lattices.mod predefined_obs.mod \ predefined_hoppings.mod predefined_trial.mod qdrp_mod.mod tau_m_mod.mod tau_p_mod.mod \ - udv_state_mod.mod udv_wrap_mod.mod wavefunction_mod.mod wrapgr_mod.mod hamiltonian.mod OpTvector_mod.mod + udv_state_mod.mod udv_wrap_mod.mod wavefunction_mod.mod wrapgr_mod.mod hamiltonian.mod ContainerElementBase_mod.mod OpTTypes_mod.mod OHAM= Hamiltonian_Examples_mod.o Hamiltonians/Hamiltonian_Z2_slave_spins_mod.o Hamiltonians/Hamiltonian_Z2_Matter_mod.o \ Hamiltonians/Hamiltonian_Hub_Canonical_mod.o Hamiltonians/Hamiltonian_Kondo_Honey_mod.o Hamiltonians/Hamiltonian_KN_Kondo_chain.o BINS= Examples.out Z2_slave_spins.out Z2_Matter.out Hubb_Can.out Kondo_Honey.out KN_Kondo.out diff --git a/Prog/OpTTypes_mod.F90 b/Prog/OpTTypes_mod.F90 new file mode 100644 index 00000000..4725aa51 --- /dev/null +++ b/Prog/OpTTypes_mod.F90 @@ -0,0 +1,59 @@ +! Copyright (C) 2020 The ALF project +! +! The ALF project is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! The ALF project is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with ALF. If not, see http://www.gnu.org/licenses/. +! +! Under Section 7 of GPL version 3 we require you to fulfill the following additional terms: +! +! - It is our hope that this program makes a contribution to the scientific community. Being +! part of that community we feel that it is reasonable to require you to give an attribution +! back to the original authors if you have benefitted from this program. +! Guidelines for a proper citation can be found on the project's homepage +! https://alf.physik.uni-wuerzburg.de . +! +! - We require the preservation of the above copyright notice and this license in all original files. +! +! - We prohibit the misrepresentation of the origin of the original source files. To obtain +! the original source files please visit the homepage https://alf.physik.uni-wuerzburg.de . +! +! - If you make substantial changes to the program we require you to either consider contributing +! to the ALF project or to mark your material in a reasonable way as different from the original version. + + +module OpTTypes_mod + use ContainerElementBase_mod + implicit none + + type, extends(ContainerElementBase) :: RealOpT + Real(kind=kind(0.d0)), allocatable, dimension(:,:) :: mat + contains + procedure :: mult => RealOpT_mult + end type RealOpT + + type, extends(ContainerElementBase) :: CmplxOpT + Complex(kind=kind(0.d0)),allocatable, dimension(:,:):: mat + contains + procedure :: mult => CmplxOpT_mult + end type CmplxOpT + +contains + subroutine RealOpT_mult(this, arg) + class(RealOpT), intent(in) :: this + Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + end subroutine + + subroutine CmplxOpT_mult(this, arg) + class(CmplxOpT), intent(in) :: this + Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + end subroutine +end module OpTTypes_mod -- GitLab From e5433dfda69340a0762252920cfe93072c1a6912 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Thu, 23 Jul 2020 15:42:17 +0200 Subject: [PATCH 06/96] Current state... whatever that means --- Prog/ContainerElementBase_mod.F90 | 6 +++--- Prog/DynamicMatrixArray_mod.F90 | 14 +++++++------- Prog/OpTTypes_mod.F90 | 13 ++++++++----- 3 files changed, 18 insertions(+), 15 deletions(-) diff --git a/Prog/ContainerElementBase_mod.F90 b/Prog/ContainerElementBase_mod.F90 index da69cfea..3606157a 100644 --- a/Prog/ContainerElementBase_mod.F90 +++ b/Prog/ContainerElementBase_mod.F90 @@ -37,14 +37,14 @@ module ContainerElementBase_mod ! Base for defining the interface type, abstract :: ContainerElementBase contains - procedure(multabs), deferred :: mult + procedure(simtinterface), deferred :: simt end type ContainerElementBase abstract interface - subroutine multabs(this, arg) + subroutine simtinterface(this, arg) import ContainerElementBase class(ContainerElementBase), intent(in) :: this - Complex(kind=kind(0.d0)), intent(inout), allocatable,dimension(:,:) :: arg + Complex(kind=kind(0.d0)), intent(inout), allocatable, dimension(:,:) :: arg end subroutine end interface diff --git a/Prog/DynamicMatrixArray_mod.F90 b/Prog/DynamicMatrixArray_mod.F90 index 9beecd56..5781a53e 100644 --- a/Prog/DynamicMatrixArray_mod.F90 +++ b/Prog/DynamicMatrixArray_mod.F90 @@ -31,7 +31,7 @@ module DynamicMatrixArray_mod - Use ContainerElementBase + Use ContainerElementBase_mod implicit none type :: OpTBasePtrWrapper @@ -43,12 +43,12 @@ module DynamicMatrixArray_mod integer :: tail ! last index type(OpTbasePtrWrapper), allocatable, dimension(:) :: data contains - procedure :: init => OpTvector_init - procedure :: dealloc => OpTvector_dealloc - procedure :: pushback => OpTvector_pushback - procedure :: at => OpTvector_at - procedure :: back => OpTvector_back - procedure :: length => OpTvector_length + procedure :: init => DynamicMatrixArray_init + procedure :: dealloc => DynamicMatrixArray_dealloc + procedure :: pushback => DynamicMatrixArray_pushback + procedure :: at => DynamicMatrixArray_at + procedure :: back => DynamicMatrixArray_back + procedure :: length => DynamicMatrixArray_length ! FIXME: do we need insert? end type DynamicMatrixArray diff --git a/Prog/OpTTypes_mod.F90 b/Prog/OpTTypes_mod.F90 index 4725aa51..de59e53f 100644 --- a/Prog/OpTTypes_mod.F90 +++ b/Prog/OpTTypes_mod.F90 @@ -37,23 +37,26 @@ module OpTTypes_mod type, extends(ContainerElementBase) :: RealOpT Real(kind=kind(0.d0)), allocatable, dimension(:,:) :: mat contains - procedure :: mult => RealOpT_mult + procedure :: simt => RealOpT_simt end type RealOpT type, extends(ContainerElementBase) :: CmplxOpT Complex(kind=kind(0.d0)),allocatable, dimension(:,:):: mat contains - procedure :: mult => CmplxOpT_mult + procedure :: simt => CmplxOpT_simt end type CmplxOpT contains - subroutine RealOpT_mult(this, arg) + subroutine RealOpT_simt(this, arg) class(RealOpT), intent(in) :: this Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: temp + end subroutine - - subroutine CmplxOpT_mult(this, arg) + + subroutine CmplxOpT_simt(this, arg) class(CmplxOpT), intent(in) :: this Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg end subroutine + end module OpTTypes_mod -- GitLab From 9a3ab57c0c30d76db312c2ff5e96baa88241287f Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Mon, 21 Sep 2020 12:49:54 +0200 Subject: [PATCH 07/96] fix compilation --- Prog/main.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/Prog/main.F90 b/Prog/main.F90 index 3921a160..4b59ebc0 100644 --- a/Prog/main.F90 +++ b/Prog/main.F90 @@ -124,7 +124,6 @@ Program Main Use UDV_State_mod Use Wrapgr_mod Use Fields_mod - Use OpTvector_mod Use iso_fortran_env, only: output_unit, error_unit #ifdef MPI Use mpi -- GitLab From 6de319de23b02070a4beb41348ea182181233f70 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Mon, 21 Sep 2020 12:57:48 +0200 Subject: [PATCH 08/96] add some interfaces --- Prog/OpTTypes_mod.F90 | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/Prog/OpTTypes_mod.F90 b/Prog/OpTTypes_mod.F90 index de59e53f..02d94cbb 100644 --- a/Prog/OpTTypes_mod.F90 +++ b/Prog/OpTTypes_mod.F90 @@ -38,12 +38,14 @@ module OpTTypes_mod Real(kind=kind(0.d0)), allocatable, dimension(:,:) :: mat contains procedure :: simt => RealOpT_simt + procedure :: mult => RealOpT_mult end type RealOpT type, extends(ContainerElementBase) :: CmplxOpT Complex(kind=kind(0.d0)),allocatable, dimension(:,:):: mat contains procedure :: simt => CmplxOpT_simt + procedure :: mult => CmplxOpT_mult end type CmplxOpT contains @@ -53,10 +55,22 @@ contains Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: temp end subroutine + + subroutine RealOpT_mult(this, arg) + class(RealOpT), intent(in) :: this + Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: temp + + end subroutine subroutine CmplxOpT_simt(this, arg) class(CmplxOpT), intent(in) :: this Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg end subroutine + + subroutine CmplxOpT_mult(this, arg) + class(CmplxOpT), intent(in) :: this + Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + end subroutine end module OpTTypes_mod -- GitLab From 1f711bc6f1bdfaa7a2244a07f2c5a05ca1aacf64 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Mon, 21 Sep 2020 12:57:58 +0200 Subject: [PATCH 09/96] update files --- Prog/main.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/Prog/main.F90 b/Prog/main.F90 index 4b59ebc0..74ff3c17 100644 --- a/Prog/main.F90 +++ b/Prog/main.F90 @@ -124,6 +124,7 @@ Program Main Use UDV_State_mod Use Wrapgr_mod Use Fields_mod + Use OpTTypes_mod Use iso_fortran_env, only: output_unit, error_unit #ifdef MPI Use mpi -- GitLab From 8c5e108a30ee12e79dcc621df87d8bcb34fb8055 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Mon, 21 Sep 2020 14:17:40 +0200 Subject: [PATCH 10/96] current state --- Prog/ContainerElementBase_mod.F90 | 14 ++++++++++++++ Prog/OpTTypes_mod.F90 | 22 ++++++++++++++++++---- 2 files changed, 32 insertions(+), 4 deletions(-) diff --git a/Prog/ContainerElementBase_mod.F90 b/Prog/ContainerElementBase_mod.F90 index 3606157a..e0cbb8a2 100644 --- a/Prog/ContainerElementBase_mod.F90 +++ b/Prog/ContainerElementBase_mod.F90 @@ -38,6 +38,8 @@ module ContainerElementBase_mod type, abstract :: ContainerElementBase contains procedure(simtinterface), deferred :: simt + procedure(rmultinterface), deferred :: rmult + procedure(lmultinterface), deferred :: lmult end type ContainerElementBase abstract interface @@ -46,6 +48,18 @@ module ContainerElementBase_mod class(ContainerElementBase), intent(in) :: this Complex(kind=kind(0.d0)), intent(inout), allocatable, dimension(:,:) :: arg end subroutine + + subroutine rmultinterface(this, arg) + import ContainerElementBase + class(ContainerElementBase), intent(in) :: this + Complex(kind=kind(0.d0)), intent(inout), allocatable, dimension(:,:) :: arg + end subroutine + + subroutine lmultinterface(this, arg) + import ContainerElementBase + class(ContainerElementBase), intent(in) :: this + Complex(kind=kind(0.d0)), intent(inout), allocatable, dimension(:,:) :: arg + end subroutine end interface end module ContainerElementBase_mod diff --git a/Prog/OpTTypes_mod.F90 b/Prog/OpTTypes_mod.F90 index 02d94cbb..bb6cede9 100644 --- a/Prog/OpTTypes_mod.F90 +++ b/Prog/OpTTypes_mod.F90 @@ -38,14 +38,16 @@ module OpTTypes_mod Real(kind=kind(0.d0)), allocatable, dimension(:,:) :: mat contains procedure :: simt => RealOpT_simt - procedure :: mult => RealOpT_mult + procedure :: rmult => RealOpT_rmult + procedure :: lmult => RealOpT_lmult end type RealOpT type, extends(ContainerElementBase) :: CmplxOpT Complex(kind=kind(0.d0)),allocatable, dimension(:,:):: mat contains procedure :: simt => CmplxOpT_simt - procedure :: mult => CmplxOpT_mult + procedure :: rmult => CmplxOpT_rmult + procedure :: lmult => CmplxOpT_lmult end type CmplxOpT contains @@ -56,7 +58,14 @@ contains end subroutine - subroutine RealOpT_mult(this, arg) + subroutine RealOpT_rmult(this, arg) + class(RealOpT), intent(in) :: this + Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: temp + + end subroutine + + subroutine RealOpT_lmult(this, arg) class(RealOpT), intent(in) :: this Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: temp @@ -68,7 +77,12 @@ contains Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg end subroutine - subroutine CmplxOpT_mult(this, arg) + subroutine CmplxOpT_rmult(this, arg) + class(CmplxOpT), intent(in) :: this + Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + end subroutine + + subroutine CmplxOpT_lmult(this, arg) class(CmplxOpT), intent(in) :: this Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg end subroutine -- GitLab From 6a5adbb5c88794e2b0eb1d7152e208b2480438b2 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Mon, 21 Sep 2020 16:31:03 +0200 Subject: [PATCH 11/96] fix build --- Prog/Makefile | 2 +- Prog/OpTTypes_mod.F90 | 17 +++++++++++++++++ 2 files changed, 18 insertions(+), 1 deletion(-) diff --git a/Prog/Makefile b/Prog/Makefile index 9042be4d..da5d50f0 100644 --- a/Prog/Makefile +++ b/Prog/Makefile @@ -1,6 +1,6 @@ .PHONY : Compile tidy clean Examples Z2_Slave Z2_Matter Hub_Can Kondo Hubbard tV Hubbard_Plain_Vanilla LRC -OBJS= Hamiltonians/LRC_mod.o Set_random.o control_mod.o Fields_mod.o Operator_mod.o WaveFunction_mod.o observables_mod.o ContainerElementBase_mod.o OpTTypes_mod.o\ +OBJS= Hamiltonians/LRC_mod.o Set_random.o control_mod.o Fields_mod.o Operator_mod.o WaveFunction_mod.o observables_mod.o DynamicMatrixArray_mod.o ContainerElementBase_mod.o OpTTypes_mod.o\ Predefined_Int_mod.o Predefined_Obs_mod.o Predefined_Latt_mod.o Predefined_Hop_mod.o Predefined_Trial_mod.o \ $(HAMILTONIAN) QDRP_decompose_mod.o udv_state_mod.o Hop_mod.o UDV_WRAP_mod.o \ Global_mod.o Wrapgr_mod.o tau_m_mod.o tau_p_mod.o main.o wrapul.o cgr1.o wrapur.o cgr2_2.o upgrade.o diff --git a/Prog/OpTTypes_mod.F90 b/Prog/OpTTypes_mod.F90 index bb6cede9..5cc1a3ae 100644 --- a/Prog/OpTTypes_mod.F90 +++ b/Prog/OpTTypes_mod.F90 @@ -37,6 +37,7 @@ module OpTTypes_mod type, extends(ContainerElementBase) :: RealOpT Real(kind=kind(0.d0)), allocatable, dimension(:,:) :: mat contains + procedure :: init => RealOpT_init procedure :: simt => RealOpT_simt procedure :: rmult => RealOpT_rmult procedure :: lmult => RealOpT_lmult @@ -45,12 +46,21 @@ module OpTTypes_mod type, extends(ContainerElementBase) :: CmplxOpT Complex(kind=kind(0.d0)),allocatable, dimension(:,:):: mat contains + procedure :: init => CmplxOpT_init procedure :: simt => CmplxOpT_simt procedure :: rmult => CmplxOpT_rmult procedure :: lmult => CmplxOpT_lmult end type CmplxOpT contains + + subroutine RealOpT_init(this, arg) + class(RealOpT), intent(in) :: this + Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: temp + + end subroutine + subroutine RealOpT_simt(this, arg) class(RealOpT), intent(in) :: this Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg @@ -71,6 +81,13 @@ contains Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: temp end subroutine + + subroutine CmplxOpT_init(this, arg) + class(CmplxOpT), intent(in) :: this + Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: temp + + end subroutine subroutine CmplxOpT_simt(this, arg) class(CmplxOpT), intent(in) :: this -- GitLab From e2767e897b1ec33576485d4fe6b2027123fdf054 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Tue, 22 Sep 2020 09:02:56 +0200 Subject: [PATCH 12/96] Another attempt at proper polymorphic behaviour --- Prog/DynamicMatrixArray_mod.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Prog/DynamicMatrixArray_mod.F90 b/Prog/DynamicMatrixArray_mod.F90 index 5781a53e..477cb7a6 100644 --- a/Prog/DynamicMatrixArray_mod.F90 +++ b/Prog/DynamicMatrixArray_mod.F90 @@ -35,7 +35,7 @@ module DynamicMatrixArray_mod implicit none type :: OpTBasePtrWrapper - class(ContainerElementBase), pointer :: dat + class(ContainerElementBase), allocatable :: dat end type type :: DynamicMatrixArray @@ -69,7 +69,7 @@ end subroutine subroutine DynamicMatrixArray_pushback(this, itm) class(DynamicMatrixArray) :: this - type(OpTbasePtrWrapper), intent(in) :: itm + class(ContainerElementBase), intent(in) :: itm ! Type(...) always has to match exactly, class(...) allows for polymorphism type(OpTbasePtrWrapper), allocatable, dimension(:) :: temp integer :: i if (this%tail == this%avamem) then ! check if this still works the same as for plain ints. @@ -83,7 +83,7 @@ subroutine DynamicMatrixArray_pushback(this, itm) deallocate(temp) this%avamem = 2*this%avamem endif - this%data(this%tail) = itm + this%data(this%tail)%dat = itm this%tail = this%tail + 1 end subroutine -- GitLab From 554d801283e43683db0460a4ebe8740f90aa8443 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Tue, 22 Sep 2020 19:13:07 +0200 Subject: [PATCH 13/96] further progress --- Prog/ContainerElementBase_mod.F90 | 2 +- Prog/DynamicMatrixArray_mod.F90 | 10 +++++----- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/Prog/ContainerElementBase_mod.F90 b/Prog/ContainerElementBase_mod.F90 index e0cbb8a2..14570232 100644 --- a/Prog/ContainerElementBase_mod.F90 +++ b/Prog/ContainerElementBase_mod.F90 @@ -37,7 +37,7 @@ module ContainerElementBase_mod ! Base for defining the interface type, abstract :: ContainerElementBase contains - procedure(simtinterface), deferred :: simt + procedure(simtinterface), deferred :: simt procedure(rmultinterface), deferred :: rmult procedure(lmultinterface), deferred :: lmult end type ContainerElementBase diff --git a/Prog/DynamicMatrixArray_mod.F90 b/Prog/DynamicMatrixArray_mod.F90 index 477cb7a6..90c24fbe 100644 --- a/Prog/DynamicMatrixArray_mod.F90 +++ b/Prog/DynamicMatrixArray_mod.F90 @@ -41,7 +41,7 @@ module DynamicMatrixArray_mod type :: DynamicMatrixArray integer :: avamem ! amount of available space integer :: tail ! last index - type(OpTbasePtrWrapper), allocatable, dimension(:) :: data + Type(OpTbasePtrWrapper), allocatable, dimension(:) :: data contains procedure :: init => DynamicMatrixArray_init procedure :: dealloc => DynamicMatrixArray_dealloc @@ -90,14 +90,14 @@ end subroutine subroutine DynamicMatrixArray_at(this, pos, itm) class(DynamicMatrixArray) :: this integer, intent(in) :: pos - type(OpTbasePtrWrapper), intent(out) :: itm - itm = this%data(pos) + class(ContainerElementBase), intent(out), allocatable :: itm + itm = this%data(pos)%dat end subroutine subroutine DynamicMatrixArray_back(this, itm) class(DynamicMatrixArray) :: this - type(OpTbasePtrWrapper), intent(out) :: itm - itm = this%data(this%tail-1) + class(ContainerElementBase), intent(out), allocatable :: itm + itm = this%data(this%tail-1)%dat end subroutine function DynamicMatrixArray_length(this) result(l) -- GitLab From b1bde08e93bc8588a0fe61d1c480e39b73c8fdde Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Tue, 22 Sep 2020 21:30:34 +0200 Subject: [PATCH 14/96] first multiplication code --- Prog/DynamicMatrixArray_mod.F90 | 3 ++- Prog/OpTTypes_mod.F90 | 46 ++++++++++++++++++++++++++++----- 2 files changed, 41 insertions(+), 8 deletions(-) diff --git a/Prog/DynamicMatrixArray_mod.F90 b/Prog/DynamicMatrixArray_mod.F90 index 90c24fbe..66a59367 100644 --- a/Prog/DynamicMatrixArray_mod.F90 +++ b/Prog/DynamicMatrixArray_mod.F90 @@ -72,9 +72,10 @@ subroutine DynamicMatrixArray_pushback(this, itm) class(ContainerElementBase), intent(in) :: itm ! Type(...) always has to match exactly, class(...) allows for polymorphism type(OpTbasePtrWrapper), allocatable, dimension(:) :: temp integer :: i + if (this%tail == this%avamem) then ! check if this still works the same as for plain ints. ! reallocate the memory - write (*,*) "not enough space!" + write (*,*) "not enough space -> growing." call MOVE_ALLOC(this%data, temp) allocate(this%data(2*this%avamem)) do i = 1, this%avamem diff --git a/Prog/OpTTypes_mod.F90 b/Prog/OpTTypes_mod.F90 index 5cc1a3ae..3cf7ca1d 100644 --- a/Prog/OpTTypes_mod.F90 +++ b/Prog/OpTTypes_mod.F90 @@ -36,6 +36,7 @@ module OpTTypes_mod type, extends(ContainerElementBase) :: RealOpT Real(kind=kind(0.d0)), allocatable, dimension(:,:) :: mat + Integer :: m, n contains procedure :: init => RealOpT_init procedure :: simt => RealOpT_simt @@ -45,6 +46,7 @@ module OpTTypes_mod type, extends(ContainerElementBase) :: CmplxOpT Complex(kind=kind(0.d0)),allocatable, dimension(:,:):: mat + Integer :: m, n contains procedure :: init => CmplxOpT_init procedure :: simt => CmplxOpT_simt @@ -55,10 +57,16 @@ module OpTTypes_mod contains subroutine RealOpT_init(this, arg) - class(RealOpT), intent(in) :: this - Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg - Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: temp + class(RealOpT) :: this + Real(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + Integer :: i,j + this%mat = arg !copy argument to local storage + this%m = size(arg, 1) + this%n = size(arg, 2) +! do i = 1, size(arg,1) +! write (*,*) (this%mat(i,j), j = 1, size(arg,2) ) +! enddo end subroutine subroutine RealOpT_simt(this, arg) @@ -71,8 +79,15 @@ contains subroutine RealOpT_rmult(this, arg) class(RealOpT), intent(in) :: this Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg - Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: temp - + Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: out + Real(kind=kind(0.D0)), allocatable, dimension(:) :: rwork + Integer :: i, j, sz1, sz2 + + sz1 = size(arg, 1) + sz2 = size(arg, 2) + allocate(out(sz1, sz2), rwork(2*sz1*sz2)) + call zlacrm(sz1, sz2, arg, sz1, this%mat, this%m, out, this%m, rwork) ! zlarcm assumes mat to be square + arg = out end subroutine subroutine RealOpT_lmult(this, arg) @@ -83,9 +98,15 @@ contains end subroutine subroutine CmplxOpT_init(this, arg) - class(CmplxOpT), intent(in) :: this + class(CmplxOpT) :: this Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg - Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: temp + Integer :: i,j + this%mat = arg !copy argument to local storage +! do i = 1, size(arg,1) +! write (*,*) (this%mat(i,j), j = 1, size(arg,2) ) +! enddo + this%m = size(arg, 1) + this%n = size(arg, 2) end subroutine @@ -97,6 +118,17 @@ contains subroutine CmplxOpT_rmult(this, arg) class(CmplxOpT), intent(in) :: this Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: out + Complex(kind=kind(0.d0)) :: alpha, zero + Integer :: i, j, sz1, sz2 + + alpha = 1.0 + zero = 0 + sz1 = size(arg, 1) + sz2 = size(arg, 2) + allocate(out(sz1, sz2)) + call zhemm('R', 'U', sz1, sz2, alpha, arg, sz1, this%mat, this%m, zero, out, sz1) + arg = out end subroutine subroutine CmplxOpT_lmult(this, arg) -- GitLab From d8d9023dfd3228b6a74a4ae6a7253c24bea8c2ea Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Tue, 22 Sep 2020 21:32:07 +0200 Subject: [PATCH 15/96] current stage of test program. hopefully I don't lose it this time around... --- Prog/test.f90 | 56 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 56 insertions(+) create mode 100644 Prog/test.f90 diff --git a/Prog/test.f90 b/Prog/test.f90 new file mode 100644 index 00000000..5b754974 --- /dev/null +++ b/Prog/test.f90 @@ -0,0 +1,56 @@ +program test +Use DynamicMatrixArray_mod +Use ContainerElementBase_mod +Use OpTTypes_mod +implicit none + +Type(DynamicMatrixArray) :: vec +Type(RealOpT), allocatable, dimension(:) :: remat +Type(CmplxOpT), allocatable, dimension(:) :: cmplxmat +class(ContainerElementBase), allocatable :: dummy +Complex(kind=kind(0.d0)), allocatable, dimension(:,:) :: res, ctmp +Real(kind=kind(0.d0)), allocatable, dimension(:,:) :: rtmp +Complex(kind=kind(0.d0)) :: alpha, zero +Integer :: i,j,k,l, nmax + +nmax = 5 +allocate (res(nmax, nmax), remat(16), cmplxmat(16), ctmp(nmax, nmax), rtmp(nmax, nmax)) +call vec%init() + +alpha = 1.0 +zero = 0.0 +call zlaset('A', nmax, nmax, zero, alpha, res, nmax) + +do i = 1, 16 + call zlaset('A', nmax, nmax, zero, alpha, ctmp, nmax) + do j = 1, nmax + ctmp(j,j) = j + enddo + + call cmplxmat(i)%init(ctmp) + call vec%pushback(cmplxmat(i)) + + call dlaset('A', nmax, nmax, zero, alpha, rtmp, nmax) + do j = 1, nmax + rtmp(j,j) = j + enddo + call remat(i)%init(rtmp) + call vec%pushback(remat(i)) +enddo + +do i= 1, 16 +call vec%at(i, dummy) +call dummy%rmult(res) +do k = 1, nmax +write (*,*) (res(k,l), l = 1,nmax ) +enddo +write (*,*) "============" +enddo + +do i = 1, nmax +write (*,*) (res(i,j), j = 1,nmax ) +enddo + + +call vec%dealloc() +end program -- GitLab From fa71f42410a8b9cea3abf26035e0baa14c988f6a Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Tue, 22 Sep 2020 21:44:20 +0200 Subject: [PATCH 16/96] plug mem-leaks --- Prog/OpTTypes_mod.F90 | 2 ++ Prog/test.f90 | 29 +++++++++++++++++++---------- 2 files changed, 21 insertions(+), 10 deletions(-) diff --git a/Prog/OpTTypes_mod.F90 b/Prog/OpTTypes_mod.F90 index 3cf7ca1d..1e23799c 100644 --- a/Prog/OpTTypes_mod.F90 +++ b/Prog/OpTTypes_mod.F90 @@ -88,6 +88,7 @@ contains allocate(out(sz1, sz2), rwork(2*sz1*sz2)) call zlacrm(sz1, sz2, arg, sz1, this%mat, this%m, out, this%m, rwork) ! zlarcm assumes mat to be square arg = out + deallocate(out, rwork) end subroutine subroutine RealOpT_lmult(this, arg) @@ -129,6 +130,7 @@ contains allocate(out(sz1, sz2)) call zhemm('R', 'U', sz1, sz2, alpha, arg, sz1, this%mat, this%m, zero, out, sz1) arg = out + deallocate(out) end subroutine subroutine CmplxOpT_lmult(this, arg) diff --git a/Prog/test.f90 b/Prog/test.f90 index 5b754974..af880d95 100644 --- a/Prog/test.f90 +++ b/Prog/test.f90 @@ -5,8 +5,8 @@ Use OpTTypes_mod implicit none Type(DynamicMatrixArray) :: vec -Type(RealOpT), allocatable, dimension(:) :: remat -Type(CmplxOpT), allocatable, dimension(:) :: cmplxmat +Type(RealOpT), allocatable :: remat +Type(CmplxOpT), allocatable:: cmplxmat class(ContainerElementBase), allocatable :: dummy Complex(kind=kind(0.d0)), allocatable, dimension(:,:) :: res, ctmp Real(kind=kind(0.d0)), allocatable, dimension(:,:) :: rtmp @@ -14,31 +14,35 @@ Complex(kind=kind(0.d0)) :: alpha, zero Integer :: i,j,k,l, nmax nmax = 5 -allocate (res(nmax, nmax), remat(16), cmplxmat(16), ctmp(nmax, nmax), rtmp(nmax, nmax)) +allocate (res(nmax, nmax), ctmp(nmax, nmax), rtmp(nmax, nmax)) call vec%init() alpha = 1.0 zero = 0.0 call zlaset('A', nmax, nmax, zero, alpha, res, nmax) -do i = 1, 16 +allocate(remat, cmplxmat) + +do i = 1, 5 call zlaset('A', nmax, nmax, zero, alpha, ctmp, nmax) do j = 1, nmax ctmp(j,j) = j enddo - call cmplxmat(i)%init(ctmp) - call vec%pushback(cmplxmat(i)) + call cmplxmat%init(ctmp) + call vec%pushback(cmplxmat) call dlaset('A', nmax, nmax, zero, alpha, rtmp, nmax) do j = 1, nmax rtmp(j,j) = j enddo - call remat(i)%init(rtmp) - call vec%pushback(remat(i)) + call remat%init(rtmp) + call vec%pushback(remat) enddo +deallocate(remat, cmplxmat) +deallocate(ctmp, rtmp) -do i= 1, 16 +do i= 1, 5 call vec%at(i, dummy) call dummy%rmult(res) do k = 1, nmax @@ -51,6 +55,11 @@ do i = 1, nmax write (*,*) (res(i,j), j = 1,nmax ) enddo - +! tidy up +do i = 1, vec%length() +call vec%at(i, dummy) +deallocate(dummy) +enddo call vec%dealloc() +deallocate(res) end program -- GitLab From 3be9d385c6b5655c017dda2943e8a1a371091a25 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Tue, 22 Sep 2020 21:46:25 +0200 Subject: [PATCH 17/96] some comments --- Prog/test.f90 | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/Prog/test.f90 b/Prog/test.f90 index af880d95..9ffcb795 100644 --- a/Prog/test.f90 +++ b/Prog/test.f90 @@ -24,31 +24,37 @@ call zlaset('A', nmax, nmax, zero, alpha, res, nmax) allocate(remat, cmplxmat) do i = 1, 5 + ! create some complex dummy data call zlaset('A', nmax, nmax, zero, alpha, ctmp, nmax) do j = 1, nmax ctmp(j,j) = j enddo + !pushback call cmplxmat%init(ctmp) call vec%pushback(cmplxmat) + ! create some real dummy data call dlaset('A', nmax, nmax, zero, alpha, rtmp, nmax) do j = 1, nmax rtmp(j,j) = j enddo + ! push_back call remat%init(rtmp) call vec%pushback(remat) enddo +! tidy up auxiliary structures deallocate(remat, cmplxmat) deallocate(ctmp, rtmp) +! execute a loop over all stores objects do i= 1, 5 -call vec%at(i, dummy) -call dummy%rmult(res) -do k = 1, nmax -write (*,*) (res(k,l), l = 1,nmax ) -enddo -write (*,*) "============" + call vec%at(i, dummy) ! get object + call dummy%rmult(res) ! polymorphic dispatch to rmult + do k = 1, nmax + write (*,*) (res(k,l), l = 1,nmax ) + enddo + write (*,*) "============" enddo do i = 1, nmax -- GitLab From c36062337e130f7c22a8ef856a58425915e6daba Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Tue, 22 Sep 2020 21:50:43 +0200 Subject: [PATCH 18/96] docs --- Prog/DynamicMatrixArray_mod.F90 | 3 +++ Prog/test.f90 | 2 +- 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/Prog/DynamicMatrixArray_mod.F90 b/Prog/DynamicMatrixArray_mod.F90 index 66a59367..34ca1e00 100644 --- a/Prog/DynamicMatrixArray_mod.F90 +++ b/Prog/DynamicMatrixArray_mod.F90 @@ -29,6 +29,9 @@ ! - If you make substantial changes to the program we require you to either consider contributing ! to the ALF project or to mark your material in a reasonable way as different from the original version. +! helpful Fortran docs: +! https://materials.prace-ri.eu/400/1/advFortranIntro.pdf +! http://www.chem.helsinki.fi/~manninen/fortran2014/7_Object_oriented_features.pdf module DynamicMatrixArray_mod Use ContainerElementBase_mod diff --git a/Prog/test.f90 b/Prog/test.f90 index 9ffcb795..84fcfdaf 100644 --- a/Prog/test.f90 +++ b/Prog/test.f90 @@ -47,7 +47,7 @@ enddo deallocate(remat, cmplxmat) deallocate(ctmp, rtmp) -! execute a loop over all stores objects +! execute a loop over all stored objects do i= 1, 5 call vec%at(i, dummy) ! get object call dummy%rmult(res) ! polymorphic dispatch to rmult -- GitLab From c34368b4cfaf92e0ba4510c1e4b2bd3f3d800e5c Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Wed, 23 Sep 2020 02:49:40 +0200 Subject: [PATCH 19/96] some syntactic sugar --- Prog/DynamicMatrixArray_mod.F90 | 17 ++++++++++++++--- Prog/test.f90 | 4 ++-- 2 files changed, 16 insertions(+), 5 deletions(-) diff --git a/Prog/DynamicMatrixArray_mod.F90 b/Prog/DynamicMatrixArray_mod.F90 index 34ca1e00..128470a8 100644 --- a/Prog/DynamicMatrixArray_mod.F90 +++ b/Prog/DynamicMatrixArray_mod.F90 @@ -91,12 +91,23 @@ subroutine DynamicMatrixArray_pushback(this, itm) this%tail = this%tail + 1 end subroutine -subroutine DynamicMatrixArray_at(this, pos, itm) +!-------------------------------------------------------------------- +!> @author +!> The ALF Project contributors +! +!> @brief +!> return a pointer to the object stored at position i +!> +!> @param[in] i the index +!> @param[out] the content stored at the position i +! +!-------------------------------------------------------------------- +function DynamicMatrixArray_at(this, pos) result(itm) class(DynamicMatrixArray) :: this integer, intent(in) :: pos - class(ContainerElementBase), intent(out), allocatable :: itm + class(ContainerElementBase), allocatable :: itm itm = this%data(pos)%dat -end subroutine +end function subroutine DynamicMatrixArray_back(this, itm) class(DynamicMatrixArray) :: this diff --git a/Prog/test.f90 b/Prog/test.f90 index 84fcfdaf..c1d27dfc 100644 --- a/Prog/test.f90 +++ b/Prog/test.f90 @@ -49,7 +49,7 @@ deallocate(ctmp, rtmp) ! execute a loop over all stored objects do i= 1, 5 - call vec%at(i, dummy) ! get object + dummy = vec%at(i) ! get object call dummy%rmult(res) ! polymorphic dispatch to rmult do k = 1, nmax write (*,*) (res(k,l), l = 1,nmax ) @@ -63,7 +63,7 @@ enddo ! tidy up do i = 1, vec%length() -call vec%at(i, dummy) +dummy = vec%at(i) ! Fortran doesn't want chaining here deallocate(dummy) enddo call vec%dealloc() -- GitLab From 81121e23ff01fa0a38bddf61c527e18d88c7c563 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Wed, 23 Sep 2020 20:33:50 +0200 Subject: [PATCH 20/96] add Container to Examples --- Prog/Hamiltonian_Examples_mod.F90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/Prog/Hamiltonian_Examples_mod.F90 b/Prog/Hamiltonian_Examples_mod.F90 index 2fdf1829..8fffd83c 100644 --- a/Prog/Hamiltonian_Examples_mod.F90 +++ b/Prog/Hamiltonian_Examples_mod.F90 @@ -128,6 +128,9 @@ Use Fields_mod Use Predefined_Hoppings Use LRC_Mod + Use DynamicMatrixArray_mod + Use ContainerElementBase_mod + Use OpTTypes_mod use iso_fortran_env, only: output_unit, error_unit -- GitLab From eb6e4221e14b53b2227e903231221cb2ea97b9b7 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Fri, 25 Sep 2020 04:21:08 +0200 Subject: [PATCH 21/96] fix proper Position of the vector --- Prog/Hamiltonian_Examples_mod.F90 | 3 --- Prog/Hop_mod.F90 | 4 ++++ 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/Prog/Hamiltonian_Examples_mod.F90 b/Prog/Hamiltonian_Examples_mod.F90 index 8fffd83c..2fdf1829 100644 --- a/Prog/Hamiltonian_Examples_mod.F90 +++ b/Prog/Hamiltonian_Examples_mod.F90 @@ -128,9 +128,6 @@ Use Fields_mod Use Predefined_Hoppings Use LRC_Mod - Use DynamicMatrixArray_mod - Use ContainerElementBase_mod - Use OpTTypes_mod use iso_fortran_env, only: output_unit, error_unit diff --git a/Prog/Hop_mod.F90 b/Prog/Hop_mod.F90 index 4ab1b75e..a4b75cd2 100644 --- a/Prog/Hop_mod.F90 +++ b/Prog/Hop_mod.F90 @@ -48,9 +48,13 @@ Use Hamiltonian Use Random_wrap + Use DynamicMatrixArray_mod + Use ContainerElementBase_mod + Use OpTTypes_mod use iso_fortran_env, only: output_unit, error_unit ! Private variables + Type(DynamicMatrixArray), private :: vec Complex (Kind=Kind(0.d0)), allocatable, private :: Exp_T(:,:,:,:), Exp_T_M1(:,:,:,:) Complex (Kind=Kind(0.d0)), allocatable, private :: Exp_T_1D2(:,:,:,:), Exp_T_M1_1D2(:,:,:,:) Complex (Kind=Kind(0.d0)), allocatable, private :: U_HLP(:,:), U_HLP1(:,:), V_HLP(:,:), V_HLP1(:,:) -- GitLab From 03cb0e2253a375fc424105c7e88b3492eb089afb Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Mon, 28 Sep 2020 02:17:37 +0200 Subject: [PATCH 22/96] current stage --- Prog/Hop_mod.F90 | 5 +- Prog/OpTTypes_mod.F90 | 37 ++++++++--- Prog/matTypes_mod.F90 | 140 ++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 171 insertions(+), 11 deletions(-) create mode 100644 Prog/matTypes_mod.F90 diff --git a/Prog/Hop_mod.F90 b/Prog/Hop_mod.F90 index a4b75cd2..7d24a821 100644 --- a/Prog/Hop_mod.F90 +++ b/Prog/Hop_mod.F90 @@ -54,7 +54,7 @@ use iso_fortran_env, only: output_unit, error_unit ! Private variables - Type(DynamicMatrixArray), private :: vec + Type(DynamicMatrixArray), private, allocatable :: vec(:) ! for now we have for simplicity for each flavour a vector Complex (Kind=Kind(0.d0)), allocatable, private :: Exp_T(:,:,:,:), Exp_T_M1(:,:,:,:) Complex (Kind=Kind(0.d0)), allocatable, private :: Exp_T_1D2(:,:,:,:), Exp_T_M1_1D2(:,:,:,:) Complex (Kind=Kind(0.d0)), allocatable, private :: U_HLP(:,:), U_HLP1(:,:), V_HLP(:,:), V_HLP1(:,:) @@ -98,6 +98,8 @@ Allocate ( Exp_T_M1 (Ndim_hop,Ndim_hop,Ncheck,N_FL) ) Allocate ( Exp_T_1D2 (Ndim_hop,Ndim_hop,Ncheck,N_FL) ) Allocate ( Exp_T_M1_1D2(Ndim_hop,Ndim_hop,Ncheck,N_FL) ) + + allocate(vec(N_FL)) Allocate ( V_Hlp(Ndim_hop,Ndim) ) Allocate ( V_Hlp1(Ndim_hop,Ndim) ) @@ -107,6 +109,7 @@ Exp_T = cmplx(0.d0, 0.d0, kind(0.D0)) Exp_T_M1 = cmplx(0.d0, 0.d0, kind(0.D0)) do nf = 1,N_FL + call vec(nf)%init() do nc = 1,Ncheck g = Op_T(nc,nf)%g Call Op_exp(g,Op_T(nc,nf),Exp_T(:,:,nc,nf)) diff --git a/Prog/OpTTypes_mod.F90 b/Prog/OpTTypes_mod.F90 index 1e23799c..ac3ec701 100644 --- a/Prog/OpTTypes_mod.F90 +++ b/Prog/OpTTypes_mod.F90 @@ -32,10 +32,13 @@ module OpTTypes_mod use ContainerElementBase_mod + use Operator_mod implicit none - + type, extends(ContainerElementBase) :: RealOpT Real(kind=kind(0.d0)), allocatable, dimension(:,:) :: mat + Real(kind=kind(0.d0)) :: g + integer, pointer :: P Integer :: m, n contains procedure :: init => RealOpT_init @@ -45,7 +48,9 @@ module OpTTypes_mod end type RealOpT type, extends(ContainerElementBase) :: CmplxOpT - Complex(kind=kind(0.d0)),allocatable, dimension(:,:):: mat + Complex(kind=kind(0.d0)),allocatable, dimension(:,:):: mat, invmat + Complex(kind=kind(0.d0)) :: g + integer, pointer :: P Integer :: m, n contains procedure :: init => CmplxOpT_init @@ -55,10 +60,9 @@ module OpTTypes_mod end type CmplxOpT contains - - subroutine RealOpT_init(this, arg) + subroutine RealOpT_init(this, OpT) class(RealOpT) :: this - Real(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + Type(Operator), intent(in) :: OpT Integer :: i,j this%mat = arg !copy argument to local storage this%m = size(arg, 1) @@ -98,16 +102,29 @@ contains end subroutine - subroutine CmplxOpT_init(this, arg) + subroutine CmplxOpT_init(this, OpT) class(CmplxOpT) :: this - Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg - Integer :: i,j - this%mat = arg !copy argument to local storage + Type(Operator), intent(in) :: OpT + Complex(kind=kind(0.D0)) :: g + Integer :: i, j, ndimhop ! do i = 1, size(arg,1) ! write (*,*) (this%mat(i,j), j = 1, size(arg,2) ) ! enddo this%m = size(arg, 1) this%n = size(arg, 2) + + ndimhop = Op_T%N + this%g = -Op_T%g + Call Op_exp(this%g, Op_T, this%invmat) + this%g = Op_T%g + Call Op_exp(this%g, Op_T, this%mat ) + DO i = 1, Ndimhop + DO j = i, Ndimhop + this%mat(i, j) = (this%mat(i, j) + Conjg(this%mat(j, i)))/2.D0 + this%invmat(i, j) = (this%invmat(i, j) + Conjg(this%invmat(j, i)))/2.D0 + ENDDO + ENDDO + this%P = Op_T%P end subroutine @@ -137,5 +154,5 @@ contains class(CmplxOpT), intent(in) :: this Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg end subroutine - + end module OpTTypes_mod diff --git a/Prog/matTypes_mod.F90 b/Prog/matTypes_mod.F90 new file mode 100644 index 00000000..2cfa77ee --- /dev/null +++ b/Prog/matTypes_mod.F90 @@ -0,0 +1,140 @@ +! Copyright (C) 2020 The ALF project +! +! The ALF project is free software: you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation, either version 3 of the License, or +! (at your option) any later version. +! +! The ALF project is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with ALF. If not, see http://www.gnu.org/licenses/. +! +! Under Section 7 of GPL version 3 we require you to fulfill the following additional terms: +! +! - It is our hope that this program makes a contribution to the scientific community. Being +! part of that community we feel that it is reasonable to require you to give an attribution +! back to the original authors if you have benefitted from this program. +! Guidelines for a proper citation can be found on the project's homepage +! https://alf.physik.uni-wuerzburg.de . +! +! - We require the preservation of the above copyright notice and this license in all original files. +! +! - We prohibit the misrepresentation of the origin of the original source files. To obtain +! the original source files please visit the homepage https://alf.physik.uni-wuerzburg.de . +! +! - If you make substantial changes to the program we require you to either consider contributing +! to the ALF project or to mark your material in a reasonable way as different from the original version. + + +module matTypes_mod + use ContainerElementBase_mod + implicit none + + type, extends(ContainerElementBase) :: RealMat + Real(kind=kind(0.d0)), allocatable, dimension(:,:) :: mat + Integer :: m, n + contains + procedure :: init => RealMat_init + procedure :: simt => RealMat_simt + procedure :: rmult => RealMat_rmult + procedure :: lmult => RealMat_lmult + end type RealMat + + type, extends(ContainerElementBase) :: CmplxMat + Complex(kind=kind(0.d0)),allocatable, dimension(:,:):: mat + Integer :: m, n + contains + procedure :: init => CmplxMat_init + procedure :: simt => CmplxMat_simt + procedure :: rmult => CmplxMat_rmult + procedure :: lmult => CmplxMat_lmult + end type CmplxMat + +contains + subroutine RealMat_init(this, arg) + class(RealMat) :: this + Real(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + Integer :: i,j + this%mat = arg !copy argument to local storage + this%m = size(arg, 1) + this%n = size(arg, 2) + +! do i = 1, size(arg,1) +! write (*,*) (this%mat(i,j), j = 1, size(arg,2) ) +! enddo + end subroutine + + subroutine RealMat_simt(this, arg) + class(RealMat), intent(in) :: this + Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: temp + + end subroutine + + subroutine RealMat_rmult(this, arg) + class(RealMat), intent(in) :: this + Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: out + Real(kind=kind(0.D0)), allocatable, dimension(:) :: rwork + Integer :: i, j, sz1, sz2 + + sz1 = size(arg, 1) + sz2 = size(arg, 2) + allocate(out(sz1, sz2), rwork(2*sz1*sz2)) + call zlacrm(sz1, sz2, arg, sz1, this%mat, this%m, out, this%m, rwork) ! zlarcm assumes mat to be square + arg = out + deallocate(out, rwork) + end subroutine + + subroutine RealMat_lmult(this, arg) + class(RealMat), intent(in) :: this + Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: temp + + end subroutine + + subroutine CmplxMat_init(this, arg) + class(CmplxMat) :: this + Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + Integer :: i,j + this%mat = arg !copy argument to local storage +! do i = 1, size(arg,1) +! write (*,*) (this%mat(i,j), j = 1, size(arg,2) ) +! enddo + this%m = size(arg, 1) + this%n = size(arg, 2) + + end subroutine + + subroutine CmplxMat_simt(this, arg) + class(CmplxMat), intent(in) :: this + Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + end subroutine + + subroutine CmplxMat_rmult(this, arg) + class(CmplxMat), intent(in) :: this + Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: out + Complex(kind=kind(0.d0)) :: alpha, zero + Integer :: i, j, sz1, sz2 + + alpha = 1.0 + zero = 0 + sz1 = size(arg, 1) + sz2 = size(arg, 2) + allocate(out(sz1, sz2)) + call zhemm('R', 'U', sz1, sz2, alpha, arg, sz1, this%mat, this%m, zero, out, sz1) + arg = out + deallocate(out) + end subroutine + + subroutine CmplxMat_lmult(this, arg) + class(CmplxMat), intent(in) :: this + Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + end subroutine + +end module matTypes_mod -- GitLab From 6bc60f5f75ecae159342f701781467ba6649779b Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Mon, 28 Sep 2020 09:55:26 +0200 Subject: [PATCH 23/96] extend interface --- Prog/ContainerElementBase_mod.F90 | 14 ++++++++++++++ Prog/OpTTypes_mod.F90 | 26 ++++++++++++++++++++++++++ 2 files changed, 40 insertions(+) diff --git a/Prog/ContainerElementBase_mod.F90 b/Prog/ContainerElementBase_mod.F90 index 14570232..13eef884 100644 --- a/Prog/ContainerElementBase_mod.F90 +++ b/Prog/ContainerElementBase_mod.F90 @@ -40,6 +40,8 @@ module ContainerElementBase_mod procedure(simtinterface), deferred :: simt procedure(rmultinterface), deferred :: rmult procedure(lmultinterface), deferred :: lmult + procedure(rmultinvinterface), deferred :: rmultinv + procedure(lmultinvinterface), deferred :: lmultinv end type ContainerElementBase abstract interface @@ -60,6 +62,18 @@ module ContainerElementBase_mod class(ContainerElementBase), intent(in) :: this Complex(kind=kind(0.d0)), intent(inout), allocatable, dimension(:,:) :: arg end subroutine + + subroutine rmultinvinterface(this, arg) + import ContainerElementBase + class(ContainerElementBase), intent(in) :: this + Complex(kind=kind(0.d0)), intent(inout), allocatable, dimension(:,:) :: arg + end subroutine + + subroutine lmultinvinterface(this, arg) + import ContainerElementBase + class(ContainerElementBase), intent(in) :: this + Complex(kind=kind(0.d0)), intent(inout), allocatable, dimension(:,:) :: arg + end subroutine end interface end module ContainerElementBase_mod diff --git a/Prog/OpTTypes_mod.F90 b/Prog/OpTTypes_mod.F90 index ac3ec701..53cd8ed5 100644 --- a/Prog/OpTTypes_mod.F90 +++ b/Prog/OpTTypes_mod.F90 @@ -45,6 +45,8 @@ module OpTTypes_mod procedure :: simt => RealOpT_simt procedure :: rmult => RealOpT_rmult procedure :: lmult => RealOpT_lmult + procedure :: rmultinv => RealOpT_rmultinv + procedure :: lmultinv => RealOpT_lmultinv end type RealOpT type, extends(ContainerElementBase) :: CmplxOpT @@ -57,6 +59,8 @@ module OpTTypes_mod procedure :: simt => CmplxOpT_simt procedure :: rmult => CmplxOpT_rmult procedure :: lmult => CmplxOpT_lmult + procedure :: rmultinv => CmplxOpT_rmultinv + procedure :: lmultinv => CmplxOpT_lmultinv end type CmplxOpT contains @@ -150,9 +154,31 @@ contains deallocate(out) end subroutine + subroutine CmplxOpT_rmultinv(this, arg) + class(CmplxOpT), intent(in) :: this + Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: out + Complex(kind=kind(0.d0)) :: alpha, zero + Integer :: i, j, sz1, sz2 + + alpha = 1.0 + zero = 0 + sz1 = size(arg, 1) + sz2 = size(arg, 2) + allocate(out(sz1, sz2)) + call zhemm('R', 'U', sz1, sz2, alpha, arg, sz1, this%mat, this%m, zero, out, sz1) + arg = out + deallocate(out) + end subroutine + subroutine CmplxOpT_lmult(this, arg) class(CmplxOpT), intent(in) :: this Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg end subroutine + + subroutine CmplxOpT_lmultinv(this, arg) + class(CmplxOpT), intent(in) :: this + Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + end subroutine end module OpTTypes_mod -- GitLab From 20a972a43f8f1431b30dad3fa58961d9df43a75d Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Mon, 28 Sep 2020 13:41:14 +0200 Subject: [PATCH 24/96] some work --- Prog/OpTTypes_mod.F90 | 39 +++++++++++++++++++++------------------ 1 file changed, 21 insertions(+), 18 deletions(-) diff --git a/Prog/OpTTypes_mod.F90 b/Prog/OpTTypes_mod.F90 index 53cd8ed5..3bc692d7 100644 --- a/Prog/OpTTypes_mod.F90 +++ b/Prog/OpTTypes_mod.F90 @@ -39,7 +39,7 @@ module OpTTypes_mod Real(kind=kind(0.d0)), allocatable, dimension(:,:) :: mat Real(kind=kind(0.d0)) :: g integer, pointer :: P - Integer :: m, n + Integer :: m, n, Ndim_hop contains procedure :: init => RealOpT_init procedure :: simt => RealOpT_simt @@ -53,7 +53,7 @@ module OpTTypes_mod Complex(kind=kind(0.d0)),allocatable, dimension(:,:):: mat, invmat Complex(kind=kind(0.d0)) :: g integer, pointer :: P - Integer :: m, n + Integer :: m, n, Ndim_hop contains procedure :: init => CmplxOpT_init procedure :: simt => CmplxOpT_simt @@ -110,20 +110,20 @@ contains class(CmplxOpT) :: this Type(Operator), intent(in) :: OpT Complex(kind=kind(0.D0)) :: g - Integer :: i, j, ndimhop + Integer :: i, j ! do i = 1, size(arg,1) ! write (*,*) (this%mat(i,j), j = 1, size(arg,2) ) ! enddo this%m = size(arg, 1) this%n = size(arg, 2) - ndimhop = Op_T%N + this%Ndim_hop = Op_T%N this%g = -Op_T%g Call Op_exp(this%g, Op_T, this%invmat) this%g = Op_T%g Call Op_exp(this%g, Op_T, this%mat ) - DO i = 1, Ndimhop - DO j = i, Ndimhop + DO i = 1, this%Ndim_hop + DO j = i, this%Ndim_hop this%mat(i, j) = (this%mat(i, j) + Conjg(this%mat(j, i)))/2.D0 this%invmat(i, j) = (this%invmat(i, j) + Conjg(this%invmat(j, i)))/2.D0 ENDDO @@ -141,25 +141,21 @@ contains class(CmplxOpT), intent(in) :: this Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: out - Complex(kind=kind(0.d0)) :: alpha, zero - Integer :: i, j, sz1, sz2 + Integer :: i, j, n1, n2 - alpha = 1.0 - zero = 0 - sz1 = size(arg, 1) - sz2 = size(arg, 2) - allocate(out(sz1, sz2)) - call zhemm('R', 'U', sz1, sz2, alpha, arg, sz1, this%mat, this%m, zero, out, sz1) - arg = out - deallocate(out) + ! taken from mmthl + n1 = size(arg,1) + n2 = size(arg,2) + If ( this%g*conjg(this%g) ) > Zero ) then + call ZSLHEMM('R', 'U', this%Ndim_hop, n1, n2, mat, this%P, arg) + Endif end subroutine subroutine CmplxOpT_rmultinv(this, arg) class(CmplxOpT), intent(in) :: this Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: out - Complex(kind=kind(0.d0)) :: alpha, zero - Integer :: i, j, sz1, sz2 + Integer :: i, j, n1, n2 alpha = 1.0 zero = 0 @@ -174,6 +170,13 @@ contains subroutine CmplxOpT_lmult(this, arg) class(CmplxOpT), intent(in) :: this Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + integer :: n1, n2 + + n1 = size(arg,1) + n2 = size(arg,2) + If ( this%g*conjg(this%g) ) > Zero ) then + call ZSLHEMM('L', 'U', this%Ndim_hop, n1, n2, mat, this%P, arg) + Endif end subroutine subroutine CmplxOpT_lmultinv(this, arg) -- GitLab From 979f368f1c53d44fc614ea212fb10819799d945d Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Mon, 28 Sep 2020 18:17:02 +0200 Subject: [PATCH 25/96] Finish implementation of Complex branch --- Prog/OpTTypes_mod.F90 | 82 ++++++++++++++++++++++++++----------------- 1 file changed, 50 insertions(+), 32 deletions(-) diff --git a/Prog/OpTTypes_mod.F90 b/Prog/OpTTypes_mod.F90 index 3bc692d7..8ac065c3 100644 --- a/Prog/OpTTypes_mod.F90 +++ b/Prog/OpTTypes_mod.F90 @@ -37,9 +37,10 @@ module OpTTypes_mod type, extends(ContainerElementBase) :: RealOpT Real(kind=kind(0.d0)), allocatable, dimension(:,:) :: mat - Real(kind=kind(0.d0)) :: g - integer, pointer :: P + Real(kind=kind(0.d0)) :: g, Zero + integer, pointer :: P(:) Integer :: m, n, Ndim_hop + contains procedure :: init => RealOpT_init procedure :: simt => RealOpT_simt @@ -52,7 +53,8 @@ module OpTTypes_mod type, extends(ContainerElementBase) :: CmplxOpT Complex(kind=kind(0.d0)),allocatable, dimension(:,:):: mat, invmat Complex(kind=kind(0.d0)) :: g - integer, pointer :: P + Real(kind=kind(0.d0)) :: Zero + integer, pointer :: P(:) Integer :: m, n, Ndim_hop contains procedure :: init => CmplxOpT_init @@ -68,13 +70,8 @@ contains class(RealOpT) :: this Type(Operator), intent(in) :: OpT Integer :: i,j - this%mat = arg !copy argument to local storage - this%m = size(arg, 1) - this%n = size(arg, 2) - -! do i = 1, size(arg,1) -! write (*,*) (this%mat(i,j), j = 1, size(arg,2) ) -! enddo + + this%Zero = 1.E-12 end subroutine subroutine RealOpT_simt(this, arg) @@ -99,6 +96,21 @@ contains deallocate(out, rwork) end subroutine + subroutine RealOpT_rmultinv(this, arg) + class(RealOpT), intent(in) :: this + Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: out + Real(kind=kind(0.D0)), allocatable, dimension(:) :: rwork + Integer :: i, j, sz1, sz2 + + sz1 = size(arg, 1) + sz2 = size(arg, 2) + allocate(out(sz1, sz2), rwork(2*sz1*sz2)) + call zlacrm(sz1, sz2, arg, sz1, this%mat, this%m, out, this%m, rwork) ! zlarcm assumes mat to be square + arg = out + deallocate(out, rwork) + end subroutine + subroutine RealOpT_lmult(this, arg) class(RealOpT), intent(in) :: this Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg @@ -106,17 +118,20 @@ contains end subroutine - subroutine CmplxOpT_init(this, OpT) + subroutine RealOpT_lmultinv(this, arg) + class(RealOpT), intent(in) :: this + Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: temp + + end subroutine + + subroutine CmplxOpT_init(this, Op_T) class(CmplxOpT) :: this - Type(Operator), intent(in) :: OpT + Type(Operator), intent(in) :: Op_T Complex(kind=kind(0.D0)) :: g Integer :: i, j -! do i = 1, size(arg,1) -! write (*,*) (this%mat(i,j), j = 1, size(arg,2) ) -! enddo - this%m = size(arg, 1) - this%n = size(arg, 2) + this%Zero = 1.E-12 this%Ndim_hop = Op_T%N this%g = -Op_T%g Call Op_exp(this%g, Op_T, this%invmat) @@ -140,31 +155,27 @@ contains subroutine CmplxOpT_rmult(this, arg) class(CmplxOpT), intent(in) :: this Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg - Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: out Integer :: i, j, n1, n2 ! taken from mmthl n1 = size(arg,1) n2 = size(arg,2) - If ( this%g*conjg(this%g) ) > Zero ) then - call ZSLHEMM('R', 'U', this%Ndim_hop, n1, n2, mat, this%P, arg) + If ( dble(this%g*conjg(this%g)) > this%Zero ) then + call ZSLHEMM('R', 'U', this%Ndim_hop, n1, n2, this%mat, this%P, arg) Endif end subroutine subroutine CmplxOpT_rmultinv(this, arg) class(CmplxOpT), intent(in) :: this Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg - Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: out - Integer :: i, j, n1, n2 + Integer :: n1, n2 - alpha = 1.0 - zero = 0 - sz1 = size(arg, 1) - sz2 = size(arg, 2) - allocate(out(sz1, sz2)) - call zhemm('R', 'U', sz1, sz2, alpha, arg, sz1, this%mat, this%m, zero, out, sz1) - arg = out - deallocate(out) + ! taken from mmthl_m1 + n1 = size(arg,1) + n2 = size(arg,2) + If ( dble(this%g*conjg(this%g)) > this%Zero ) then + call ZSLHEMM('R', 'U', this%Ndim_hop, n1, n2, this%invmat, this%P, arg) + Endif end subroutine subroutine CmplxOpT_lmult(this, arg) @@ -172,16 +183,23 @@ contains Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg integer :: n1, n2 + ! taken from mmthr n1 = size(arg,1) n2 = size(arg,2) - If ( this%g*conjg(this%g) ) > Zero ) then - call ZSLHEMM('L', 'U', this%Ndim_hop, n1, n2, mat, this%P, arg) + If ( dble(this%g*conjg(this%g)) > this%Zero ) then + call ZSLHEMM('L', 'U', this%Ndim_hop, n1, n2, this%mat, this%P, arg) Endif end subroutine subroutine CmplxOpT_lmultinv(this, arg) class(CmplxOpT), intent(in) :: this Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + integer :: n1, n2 + n1 = size(arg,1) + n2 = size(arg,2) + If ( dble(this%g*conjg(this%g)) > this%Zero ) then + call ZSLHEMM('L', 'U', this%Ndim_hop, n1, n2, this%invmat, this%P, arg) + Endif end subroutine end module OpTTypes_mod -- GitLab From 0a97d3454cedb0c309fbb109ee426ed1ea15b53c Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Mon, 28 Sep 2020 19:15:34 +0200 Subject: [PATCH 26/96] something that compiles --- Prog/ContainerElementBase_mod.F90 | 8 +-- Prog/Hop_mod.F90 | 81 +++++++++++++++++++------------ Prog/OpTTypes_mod.F90 | 16 +++--- 3 files changed, 62 insertions(+), 43 deletions(-) diff --git a/Prog/ContainerElementBase_mod.F90 b/Prog/ContainerElementBase_mod.F90 index 13eef884..c86e4e4a 100644 --- a/Prog/ContainerElementBase_mod.F90 +++ b/Prog/ContainerElementBase_mod.F90 @@ -54,25 +54,25 @@ module ContainerElementBase_mod subroutine rmultinterface(this, arg) import ContainerElementBase class(ContainerElementBase), intent(in) :: this - Complex(kind=kind(0.d0)), intent(inout), allocatable, dimension(:,:) :: arg + Complex(kind=kind(0.d0)), intent(inout), dimension(:,:) :: arg end subroutine subroutine lmultinterface(this, arg) import ContainerElementBase class(ContainerElementBase), intent(in) :: this - Complex(kind=kind(0.d0)), intent(inout), allocatable, dimension(:,:) :: arg + Complex(kind=kind(0.d0)), intent(inout), dimension(:,:) :: arg end subroutine subroutine rmultinvinterface(this, arg) import ContainerElementBase class(ContainerElementBase), intent(in) :: this - Complex(kind=kind(0.d0)), intent(inout), allocatable, dimension(:,:) :: arg + Complex(kind=kind(0.d0)), intent(inout), dimension(:,:) :: arg end subroutine subroutine lmultinvinterface(this, arg) import ContainerElementBase class(ContainerElementBase), intent(in) :: this - Complex(kind=kind(0.d0)), intent(inout), allocatable, dimension(:,:) :: arg + Complex(kind=kind(0.d0)), intent(inout), dimension(:,:) :: arg end subroutine end interface diff --git a/Prog/Hop_mod.F90 b/Prog/Hop_mod.F90 index 7d24a821..4cd7aeda 100644 --- a/Prog/Hop_mod.F90 +++ b/Prog/Hop_mod.F90 @@ -77,6 +77,9 @@ Integer :: nc, nf, i,j Complex (Kind=Kind(0.d0)) :: g + Type(CmplxOpT), allocatable:: cmplxexp + Type(RealOpT), allocatable:: realexp + Ncheck = size(Op_T,1) If ( size(Op_T,2) /= N_FL ) then @@ -108,29 +111,33 @@ Exp_T = cmplx(0.d0, 0.d0, kind(0.D0)) Exp_T_M1 = cmplx(0.d0, 0.d0, kind(0.D0)) + allocate(cmplxexp, realexp) do nf = 1,N_FL call vec(nf)%init() do nc = 1,Ncheck - g = Op_T(nc,nf)%g - Call Op_exp(g,Op_T(nc,nf),Exp_T(:,:,nc,nf)) - g = -Op_T(nc,nf)%g - Call Op_exp(g,Op_T(nc,nf),Exp_T_M1(:,:,nc,nf)) + call cmplxexp%init(Op_T(nc,nf)) + call vec(nf)%pushback(cmplxexp) + +! g = Op_T(nc,nf)%g +! Call Op_exp(g,Op_T(nc,nf),Exp_T(:,:,nc,nf)) +! g = -Op_T(nc,nf)%g +! Call Op_exp(g,Op_T(nc,nf),Exp_T_M1(:,:,nc,nf)) g = Op_T(nc,nf)%g/2.d0 Call Op_exp(g,Op_T(nc,nf),Exp_T_1D2(:,:,nc,nf)) g = -Op_T(nc,nf)%g/2.d0 Call Op_exp(g,Op_T(nc,nf),Exp_T_M1_1D2(:,:,nc,nf)) ! symmetrize the upper part of Exp_T and Exp_T_M1 - DO i = 1, Ndim_hop - DO j = i, Ndim_hop - Exp_T(i, j, nc, nf) = (Exp_T(i, j, nc, nf) + Conjg(Exp_T(j, i, nc, nf)))/2.D0 - Exp_T_M1(i, j, nc, nf) = (Exp_T_M1(i, j, nc, nf) + Conjg(Exp_T_M1(j, i, nc, nf)))/2.D0 - ENDDO - ENDDO +! DO i = 1, Ndim_hop +! DO j = i, Ndim_hop +! Exp_T(i, j, nc, nf) = (Exp_T(i, j, nc, nf) + Conjg(Exp_T(j, i, nc, nf)))/2.D0 +! Exp_T_M1(i, j, nc, nf) = (Exp_T_M1(i, j, nc, nf) + Conjg(Exp_T_M1(j, i, nc, nf)))/2.D0 +! ENDDO +! ENDDO enddo enddo Zero = 1.E-12 - + deallocate(cmplxexp, realexp) end subroutine Hop_mod_init !-------------------------------------------------------------------- @@ -146,14 +153,17 @@ !Local Integer :: nc, N1, N2 + class(ContainerElementBase), allocatable :: dummy - N1=size(In,1) - N2=size(In,2) +! N1=size(In,1) +! N2=size(In,2) do nc = Ncheck,1,-1 - If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then - call ZSLHEMM('L','U',Ndim_hop,N1,N2,Exp_T(:,:,nc,nf),Op_T(nc,nf)%P,In) - Endif + dummy = vec(nf)%at(nc) + call dummy%lmult(In) +! If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then +! call ZSLHEMM('L','U',Ndim_hop,N1,N2,Exp_T(:,:,nc,nf),Op_T(nc,nf)%P,In) +! Endif Enddo end Subroutine Hop_mod_mmthr @@ -193,14 +203,17 @@ !Local Integer :: nc , N1, N2 + class(ContainerElementBase), allocatable :: dummy - N1=size(In,1) - N2=size(In,2) +! N1=size(In,1) +! N2=size(In,2) do nc = 1,Ncheck - If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then - call ZSLHEMM('L','U',Ndim_hop,N1,N2,Exp_T_m1(:,:,nc,nf),Op_T(nc,nf)%P,In) - Endif + dummy = vec(nf)%at(nc) + call dummy%lmultinv(In) +! If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then +! call ZSLHEMM('L','U',Ndim_hop,N1,N2,Exp_T_m1(:,:,nc,nf),Op_T(nc,nf)%P,In) +! Endif Enddo end Subroutine Hop_mod_mmthr_m1 @@ -218,14 +231,17 @@ !Local Integer :: nc, N1, N2 + class(ContainerElementBase), allocatable :: dummy - N1=size(In,1) - N2=size(In,2) +! N1=size(In,1) +! N2=size(In,2) do nc = 1, Ncheck - If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then - call ZSLHEMM('R','U',Ndim_hop,N1,N2,Exp_T(:,:,nc,nf),Op_T(nc,nf)%P,In) - Endif + dummy = vec(nf)%at(nc) + call dummy%rmult(In) +! If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then +! call ZSLHEMM('R','U',Ndim_hop,N1,N2,Exp_T(:,:,nc,nf),Op_T(nc,nf)%P,In) +! Endif Enddo end Subroutine Hop_mod_mmthl @@ -268,14 +284,17 @@ !Local Integer :: nc, N1, N2 + class(ContainerElementBase), allocatable :: dummy - N1=size(In,1) - N2=size(In,2) +! N1=size(In,1) +! N2=size(In,2) do nc = Ncheck,1,-1 - If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then - call ZSLHEMM('R','U',Ndim_hop,N1,N2,Exp_T_m1(:,:,nc,nf),Op_T(nc,nf)%P,In) - Endif + dummy = vec(nf)%at(nc) + call dummy%rmultinv(In) +! If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then +! call ZSLHEMM('R','U',Ndim_hop,N1,N2,Exp_T_m1(:,:,nc,nf),Op_T(nc,nf)%P,In) +! Endif Enddo end Subroutine Hop_mod_mmthl_m1 diff --git a/Prog/OpTTypes_mod.F90 b/Prog/OpTTypes_mod.F90 index 8ac065c3..99fffc33 100644 --- a/Prog/OpTTypes_mod.F90 +++ b/Prog/OpTTypes_mod.F90 @@ -83,7 +83,7 @@ contains subroutine RealOpT_rmult(this, arg) class(RealOpT), intent(in) :: this - Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + Complex(kind=kind(0.D0)), intent(inout), dimension(:,:) :: arg Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: out Real(kind=kind(0.D0)), allocatable, dimension(:) :: rwork Integer :: i, j, sz1, sz2 @@ -98,7 +98,7 @@ contains subroutine RealOpT_rmultinv(this, arg) class(RealOpT), intent(in) :: this - Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + Complex(kind=kind(0.D0)), intent(inout), dimension(:,:) :: arg Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: out Real(kind=kind(0.D0)), allocatable, dimension(:) :: rwork Integer :: i, j, sz1, sz2 @@ -113,14 +113,14 @@ contains subroutine RealOpT_lmult(this, arg) class(RealOpT), intent(in) :: this - Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + Complex(kind=kind(0.D0)), intent(inout), dimension(:,:) :: arg Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: temp end subroutine subroutine RealOpT_lmultinv(this, arg) class(RealOpT), intent(in) :: this - Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + Complex(kind=kind(0.D0)), intent(inout), dimension(:,:) :: arg Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: temp end subroutine @@ -154,7 +154,7 @@ contains subroutine CmplxOpT_rmult(this, arg) class(CmplxOpT), intent(in) :: this - Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + Complex(kind=kind(0.D0)), intent(inout), dimension(:,:) :: arg Integer :: i, j, n1, n2 ! taken from mmthl @@ -167,7 +167,7 @@ contains subroutine CmplxOpT_rmultinv(this, arg) class(CmplxOpT), intent(in) :: this - Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + Complex(kind=kind(0.D0)), intent(inout), dimension(:,:) :: arg Integer :: n1, n2 ! taken from mmthl_m1 @@ -180,7 +180,7 @@ contains subroutine CmplxOpT_lmult(this, arg) class(CmplxOpT), intent(in) :: this - Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + Complex(kind=kind(0.D0)), intent(inout), dimension(:,:) :: arg integer :: n1, n2 ! taken from mmthr @@ -193,7 +193,7 @@ contains subroutine CmplxOpT_lmultinv(this, arg) class(CmplxOpT), intent(in) :: this - Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + Complex(kind=kind(0.D0)), intent(inout), dimension(:,:) :: arg integer :: n1, n2 n1 = size(arg,1) n2 = size(arg,2) -- GitLab From 458daa44f7fbdb897fb0a97ba3d9e18c98557068 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Tue, 29 Sep 2020 01:41:55 +0200 Subject: [PATCH 27/96] fix the test --- Prog/matTypes_mod.F90 | 41 +++++++++++++++++++++++++++++++++++++---- Prog/test.f90 | 16 ++++++++-------- 2 files changed, 45 insertions(+), 12 deletions(-) diff --git a/Prog/matTypes_mod.F90 b/Prog/matTypes_mod.F90 index 2cfa77ee..ea9ba307 100644 --- a/Prog/matTypes_mod.F90 +++ b/Prog/matTypes_mod.F90 @@ -42,6 +42,8 @@ module matTypes_mod procedure :: simt => RealMat_simt procedure :: rmult => RealMat_rmult procedure :: lmult => RealMat_lmult + procedure :: rmultinv => RealMat_rmultinv + procedure :: lmultinv => RealMat_lmultinv end type RealMat type, extends(ContainerElementBase) :: CmplxMat @@ -52,6 +54,8 @@ module matTypes_mod procedure :: simt => CmplxMat_simt procedure :: rmult => CmplxMat_rmult procedure :: lmult => CmplxMat_lmult + procedure :: rmultinv => CmplxMat_rmultinv + procedure :: lmultinv => CmplxMat_lmultinv end type CmplxMat contains @@ -77,7 +81,7 @@ contains subroutine RealMat_rmult(this, arg) class(RealMat), intent(in) :: this - Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + Complex(kind=kind(0.D0)), intent(inout), dimension(:,:) :: arg Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: out Real(kind=kind(0.D0)), allocatable, dimension(:) :: rwork Integer :: i, j, sz1, sz2 @@ -90,9 +94,25 @@ contains deallocate(out, rwork) end subroutine + subroutine RealMat_rmultinv(this, arg) + class(RealMat), intent(in) :: this + Complex(kind=kind(0.D0)), intent(inout), dimension(:,:) :: arg + Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: out + Real(kind=kind(0.D0)), allocatable, dimension(:) :: rwork + Integer :: i, j, sz1, sz2 + + end subroutine + subroutine RealMat_lmult(this, arg) class(RealMat), intent(in) :: this - Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + Complex(kind=kind(0.D0)), intent(inout), dimension(:,:) :: arg + Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: temp + + end subroutine + + subroutine RealMat_lmultinv(this, arg) + class(RealMat), intent(in) :: this + Complex(kind=kind(0.D0)), intent(inout), dimension(:,:) :: arg Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: temp end subroutine @@ -117,7 +137,7 @@ contains subroutine CmplxMat_rmult(this, arg) class(CmplxMat), intent(in) :: this - Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + Complex(kind=kind(0.D0)), intent(inout), dimension(:,:) :: arg Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: out Complex(kind=kind(0.d0)) :: alpha, zero Integer :: i, j, sz1, sz2 @@ -132,9 +152,22 @@ contains deallocate(out) end subroutine + subroutine CmplxMat_rmultinv(this, arg) + class(CmplxMat), intent(in) :: this + Complex(kind=kind(0.D0)), intent(inout), dimension(:,:) :: arg + Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: out + Complex(kind=kind(0.d0)) :: alpha, zero + Integer :: i, j, sz1, sz2 + + end subroutine + subroutine CmplxMat_lmult(this, arg) class(CmplxMat), intent(in) :: this - Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + Complex(kind=kind(0.D0)), intent(inout), dimension(:,:) :: arg end subroutine + subroutine CmplxMat_lmultinv(this, arg) + class(CmplxMat), intent(in) :: this + Complex(kind=kind(0.D0)), intent(inout), dimension(:,:) :: arg + end subroutine end module matTypes_mod diff --git a/Prog/test.f90 b/Prog/test.f90 index c1d27dfc..a3e725b8 100644 --- a/Prog/test.f90 +++ b/Prog/test.f90 @@ -1,12 +1,12 @@ program test Use DynamicMatrixArray_mod Use ContainerElementBase_mod -Use OpTTypes_mod +Use matTypes_mod implicit none Type(DynamicMatrixArray) :: vec -Type(RealOpT), allocatable :: remat -Type(CmplxOpT), allocatable:: cmplxmat +Type(RealMat), allocatable :: remat +Type(CmplxMat), allocatable:: complexmat class(ContainerElementBase), allocatable :: dummy Complex(kind=kind(0.d0)), allocatable, dimension(:,:) :: res, ctmp Real(kind=kind(0.d0)), allocatable, dimension(:,:) :: rtmp @@ -21,7 +21,7 @@ alpha = 1.0 zero = 0.0 call zlaset('A', nmax, nmax, zero, alpha, res, nmax) -allocate(remat, cmplxmat) +allocate(remat, complexmat) do i = 1, 5 ! create some complex dummy data @@ -31,8 +31,8 @@ do i = 1, 5 enddo !pushback - call cmplxmat%init(ctmp) - call vec%pushback(cmplxmat) + call complexmat%init(ctmp) + call vec%pushback(complexmat) ! create some real dummy data call dlaset('A', nmax, nmax, zero, alpha, rtmp, nmax) @@ -44,11 +44,11 @@ do i = 1, 5 call vec%pushback(remat) enddo ! tidy up auxiliary structures -deallocate(remat, cmplxmat) +deallocate(remat, complexmat) deallocate(ctmp, rtmp) ! execute a loop over all stored objects -do i= 1, 5 +do i= 1, 3 dummy = vec%at(i) ! get object call dummy%rmult(res) ! polymorphic dispatch to rmult do k = 1, nmax -- GitLab From 5f1260199a906050ff1d122282b8434187e3d2b4 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Tue, 29 Sep 2020 15:53:40 +0200 Subject: [PATCH 28/96] quick fix(?) for matTypes --- Prog/matTypes_mod.F90 | 11 +++++++++-- Prog/test.f90 | 8 ++++---- 2 files changed, 13 insertions(+), 6 deletions(-) diff --git a/Prog/matTypes_mod.F90 b/Prog/matTypes_mod.F90 index ea9ba307..7c5ad0e9 100644 --- a/Prog/matTypes_mod.F90 +++ b/Prog/matTypes_mod.F90 @@ -121,13 +121,20 @@ contains class(CmplxMat) :: this Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg Integer :: i,j - this%mat = arg !copy argument to local storage ! do i = 1, size(arg,1) ! write (*,*) (this%mat(i,j), j = 1, size(arg,2) ) ! enddo this%m = size(arg, 1) this%n = size(arg, 2) - + if (allocated(this%mat)) deallocate(this%mat) + allocate(this%mat(this%m, this%n)) + do i = 1, this%m + do j = 1, this%n + this%mat(i, j) = arg(i, j) + enddo + enddo +! this%mat = arg !copy argument to local storage + end subroutine subroutine CmplxMat_simt(this, arg) diff --git a/Prog/test.f90 b/Prog/test.f90 index a3e725b8..d49ebe2e 100644 --- a/Prog/test.f90 +++ b/Prog/test.f90 @@ -27,7 +27,7 @@ do i = 1, 5 ! create some complex dummy data call zlaset('A', nmax, nmax, zero, alpha, ctmp, nmax) do j = 1, nmax - ctmp(j,j) = j + ctmp(j,j) = i enddo !pushback @@ -37,7 +37,7 @@ do i = 1, 5 ! create some real dummy data call dlaset('A', nmax, nmax, zero, alpha, rtmp, nmax) do j = 1, nmax - rtmp(j,j) = j + rtmp(j,j) = i+j enddo ! push_back call remat%init(rtmp) @@ -48,11 +48,11 @@ deallocate(remat, complexmat) deallocate(ctmp, rtmp) ! execute a loop over all stored objects -do i= 1, 3 +do i= 1, vec%length() dummy = vec%at(i) ! get object call dummy%rmult(res) ! polymorphic dispatch to rmult do k = 1, nmax - write (*,*) (res(k,l), l = 1,nmax ) + write (*,*) (dble(res(k,l)), l = 1,nmax ) enddo write (*,*) "============" enddo -- GitLab From 5e5df53836adef7f6d7e4f7babcf9371776fcf02 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Tue, 29 Sep 2020 16:56:17 +0200 Subject: [PATCH 29/96] fix build order --- Prog/Makefile | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Prog/Makefile b/Prog/Makefile index da5d50f0..e90e6e05 100644 --- a/Prog/Makefile +++ b/Prog/Makefile @@ -1,6 +1,6 @@ .PHONY : Compile tidy clean Examples Z2_Slave Z2_Matter Hub_Can Kondo Hubbard tV Hubbard_Plain_Vanilla LRC -OBJS= Hamiltonians/LRC_mod.o Set_random.o control_mod.o Fields_mod.o Operator_mod.o WaveFunction_mod.o observables_mod.o DynamicMatrixArray_mod.o ContainerElementBase_mod.o OpTTypes_mod.o\ +OBJS= Hamiltonians/LRC_mod.o Set_random.o control_mod.o Fields_mod.o Operator_mod.o WaveFunction_mod.o observables_mod.o ContainerElementBase_mod.o DynamicMatrixArray_mod.o OpTTypes_mod.o\ Predefined_Int_mod.o Predefined_Obs_mod.o Predefined_Latt_mod.o Predefined_Hop_mod.o Predefined_Trial_mod.o \ $(HAMILTONIAN) QDRP_decompose_mod.o udv_state_mod.o Hop_mod.o UDV_WRAP_mod.o \ Global_mod.o Wrapgr_mod.o tau_m_mod.o tau_p_mod.o main.o wrapul.o cgr1.o wrapur.o cgr2_2.o upgrade.o @@ -74,7 +74,7 @@ Compile: $(OBJS) .SUFFIXES: .F90 .f .f.o .F90.o: - $(ALF_FC) -c -o $@ $(ALF_FLAGS_PROG) $< + $(ALF_FC) -c -o $@ $(ALF_FLAGS_PROG) -O0 -g $< tidy: rm -f $(OBJS) $(MODS) $(OHAM) -- GitLab From ec40c3399a12c5821aa517f63949ab010f724839 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Tue, 29 Sep 2020 19:31:28 +0200 Subject: [PATCH 30/96] Complex path seems to work --- Prog/ContainerElementBase_mod.F90 | 7 +++++- Prog/DynamicMatrixArray_mod.F90 | 6 +++-- Prog/Hop_mod.F90 | 32 ++++++++++++++++---------- Prog/OpTTypes_mod.F90 | 38 ++++++++++++++++++++++++++++--- 4 files changed, 65 insertions(+), 18 deletions(-) diff --git a/Prog/ContainerElementBase_mod.F90 b/Prog/ContainerElementBase_mod.F90 index c86e4e4a..95373f98 100644 --- a/Prog/ContainerElementBase_mod.F90 +++ b/Prog/ContainerElementBase_mod.F90 @@ -42,6 +42,7 @@ module ContainerElementBase_mod procedure(lmultinterface), deferred :: lmult procedure(rmultinvinterface), deferred :: rmultinv procedure(lmultinvinterface), deferred :: lmultinv + procedure(dump), deferred :: dump end type ContainerElementBase abstract interface @@ -74,6 +75,10 @@ module ContainerElementBase_mod class(ContainerElementBase), intent(in) :: this Complex(kind=kind(0.d0)), intent(inout), dimension(:,:) :: arg end subroutine + + subroutine dump(this) + import ContainerElementBase + class(ContainerElementBase), intent(in) :: this + end subroutine end interface - end module ContainerElementBase_mod diff --git a/Prog/DynamicMatrixArray_mod.F90 b/Prog/DynamicMatrixArray_mod.F90 index 128470a8..57f5d407 100644 --- a/Prog/DynamicMatrixArray_mod.F90 +++ b/Prog/DynamicMatrixArray_mod.F90 @@ -70,9 +70,10 @@ subroutine DynamicMatrixArray_dealloc(this) deallocate(this%data) end subroutine +!itm gets deallocated in the process subroutine DynamicMatrixArray_pushback(this, itm) class(DynamicMatrixArray) :: this - class(ContainerElementBase), intent(in) :: itm ! Type(...) always has to match exactly, class(...) allows for polymorphism + class(ContainerElementBase), intent(inout), allocatable :: itm ! Type(...) always has to match exactly, class(...) allows for polymorphism type(OpTbasePtrWrapper), allocatable, dimension(:) :: temp integer :: i @@ -87,7 +88,8 @@ subroutine DynamicMatrixArray_pushback(this, itm) deallocate(temp) this%avamem = 2*this%avamem endif - this%data(this%tail)%dat = itm + call move_alloc(itm, this%data(this%tail)%dat) +! this%data(this%tail)%dat = itm this%tail = this%tail + 1 end subroutine diff --git a/Prog/Hop_mod.F90 b/Prog/Hop_mod.F90 index 4cd7aeda..40381732 100644 --- a/Prog/Hop_mod.F90 +++ b/Prog/Hop_mod.F90 @@ -77,8 +77,9 @@ Integer :: nc, nf, i,j Complex (Kind=Kind(0.d0)) :: g - Type(CmplxOpT), allocatable:: cmplxexp - Type(RealOpT), allocatable:: realexp + class(CmplxOpT), allocatable:: cmplxexp + class(RealOpT), allocatable:: realexp + class(ContainerElementBase), allocatable :: Dummy Ncheck = size(Op_T,1) @@ -111,12 +112,14 @@ Exp_T = cmplx(0.d0, 0.d0, kind(0.D0)) Exp_T_M1 = cmplx(0.d0, 0.d0, kind(0.D0)) - allocate(cmplxexp, realexp) do nf = 1,N_FL call vec(nf)%init() do nc = 1,Ncheck + write (*,*) nf, nc + allocate(cmplxexp)!, realexp) call cmplxexp%init(Op_T(nc,nf)) - call vec(nf)%pushback(cmplxexp) + call Move_alloc(cmplxexp, dummy) + call vec(nf)%pushback(dummy) ! g = Op_T(nc,nf)%g ! Call Op_exp(g,Op_T(nc,nf),Exp_T(:,:,nc,nf)) @@ -134,10 +137,15 @@ ! ENDDO ! ENDDO enddo +! do i = 1, vec(nf)%length() +! dummy = vec(nf)%at(i) ! get object +! call dummy%dump() +! write (*,*) "==========" +! enddo enddo Zero = 1.E-12 - deallocate(cmplxexp, realexp) +! deallocate(cmplxexp, realexp) end subroutine Hop_mod_init !-------------------------------------------------------------------- @@ -157,7 +165,6 @@ ! N1=size(In,1) ! N2=size(In,2) - do nc = Ncheck,1,-1 dummy = vec(nf)%at(nc) call dummy%lmult(In) @@ -207,9 +214,8 @@ ! N1=size(In,1) ! N2=size(In,2) - do nc = 1,Ncheck - dummy = vec(nf)%at(nc) + dummy = vec(nf)%at(nc) call dummy%lmultinv(In) ! If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then ! call ZSLHEMM('L','U',Ndim_hop,N1,N2,Exp_T_m1(:,:,nc,nf),Op_T(nc,nf)%P,In) @@ -259,14 +265,16 @@ !Local Integer :: nc, N1, N2 + class(ContainerElementBase), allocatable :: dummy N1=size(In,1) N2=size(In,2) - do nc = 1, Ncheck - If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then - call ZSLHEMM('L','U',Ndim_hop,N1,N2,Exp_T(:,:,nc,nf),Op_T(nc,nf)%P,In) - Endif + dummy = vec(nf)%at(nc) + call dummy%lmult(In) +! If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then +! call ZSLHEMM('L','U',Ndim_hop,N1,N2,Exp_T(:,:,nc,nf),Op_T(nc,nf)%P,In) +! Endif Enddo end Subroutine Hop_mod_mmthlc diff --git a/Prog/OpTTypes_mod.F90 b/Prog/OpTTypes_mod.F90 index 99fffc33..08e5c546 100644 --- a/Prog/OpTTypes_mod.F90 +++ b/Prog/OpTTypes_mod.F90 @@ -36,7 +36,7 @@ module OpTTypes_mod implicit none type, extends(ContainerElementBase) :: RealOpT - Real(kind=kind(0.d0)), allocatable, dimension(:,:) :: mat + Real(kind=kind(0.d0)), allocatable, dimension(:,:) :: mat, invmat Real(kind=kind(0.d0)) :: g, Zero integer, pointer :: P(:) Integer :: m, n, Ndim_hop @@ -48,6 +48,7 @@ module OpTTypes_mod procedure :: lmult => RealOpT_lmult procedure :: rmultinv => RealOpT_rmultinv procedure :: lmultinv => RealOpT_lmultinv + procedure :: dump => RealOpT_dump end type RealOpT type, extends(ContainerElementBase) :: CmplxOpT @@ -63,6 +64,7 @@ module OpTTypes_mod procedure :: lmult => CmplxOpT_lmult procedure :: rmultinv => CmplxOpT_rmultinv procedure :: lmultinv => CmplxOpT_lmultinv + procedure :: dump => CmplxOpT_dump end type CmplxOpT contains @@ -128,12 +130,14 @@ contains subroutine CmplxOpT_init(this, Op_T) class(CmplxOpT) :: this Type(Operator), intent(in) :: Op_T - Complex(kind=kind(0.D0)) :: g Integer :: i, j this%Zero = 1.E-12 this%Ndim_hop = Op_T%N this%g = -Op_T%g +! if (allocated(this%mat) .and. allocated(this%invmat) ) then + allocate (this%mat(this%Ndim_hop, this%Ndim_hop), this%invmat(this%Ndim_hop, this%Ndim_hop)) +! endif Call Op_exp(this%g, Op_T, this%invmat) this%g = Op_T%g Call Op_exp(this%g, Op_T, this%mat ) @@ -143,7 +147,7 @@ contains this%invmat(i, j) = (this%invmat(i, j) + Conjg(this%invmat(j, i)))/2.D0 ENDDO ENDDO - this%P = Op_T%P + this%P => Op_T%P end subroutine @@ -191,6 +195,34 @@ contains Endif end subroutine + subroutine CmplxOpT_dump(this) + class(CmplxOpT), intent(in) :: this + integer :: i,j + + do i = 1, size(this%mat, 1) +write (*,*) (dble(this%mat(i,j)), j = 1,size(this%mat,2) ) +enddo +write (*,*) "---------------" + do i = 1, size(this%mat, 1) +write (*,*) (dble(this%invmat(i,j)), j = 1,size(this%mat,2) ) +enddo + + end subroutine + + subroutine RealOpT_dump(this) + class(RealOpT), intent(in) :: this + integer :: i,j + + do i = 1, size(this%mat, 1) +write (*,*) (dble(this%mat(i,j)), j = 1,size(this%mat,2) ) +enddo +write (*,*) "---------------" + do i = 1, size(this%mat, 1) +write (*,*) (dble(this%invmat(i,j)), j = 1,size(this%mat,2) ) +enddo + + end subroutine + subroutine CmplxOpT_lmultinv(this, arg) class(CmplxOpT), intent(in) :: this Complex(kind=kind(0.D0)), intent(inout), dimension(:,:) :: arg -- GitLab From 60e03be07abcacf03b2481da8128e5dfa25a3e5e Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Tue, 29 Sep 2020 20:07:41 +0200 Subject: [PATCH 31/96] provide a function to check wether an Operator is real --- Prog/Operator_mod.F90 | 22 ++++++++++++++++++++-- 1 file changed, 20 insertions(+), 2 deletions(-) diff --git a/Prog/Operator_mod.F90 b/Prog/Operator_mod.F90 index d0373cf9..fc90ce40 100644 --- a/Prog/Operator_mod.F90 +++ b/Prog/Operator_mod.F90 @@ -654,7 +654,7 @@ Contains Implicit none Integer :: Ndim - Type (Operator) , INTENT(IN ) :: Op + Type (Operator) , INTENT(IN) :: Op Complex (Kind = Kind(0.D0)), INTENT(INOUT) :: Mat (Ndim,Ndim) Real (Kind=Kind(0.d0)), INTENT(IN ) :: spin Integer, INTENT(IN) :: N_Type @@ -712,5 +712,23 @@ Contains endif endif end Subroutine Op_Wrapdo - + + function Op_is_real(Op) result(retval) + Implicit None + + Type (Operator) , INTENT(IN) :: Op + Logical ::retval + Real (Kind=Kind(0.d0)) :: myzero + integer :: i,j + + retval = (Abs(aimag(Op%g)) < Abs(Op%g)*epsilon(1.D0)) + ! calculate a matrix scale + myzero = maxval(abs(Op%E))*epsilon(Op%E) + + do i = 1, Op%N + do j = 1, Op%N + retval = retval .and. (Abs(aimag(Op%O(i,j))) < myzero) + enddo + enddo + end function Op_is_real end Module Operator_mod -- GitLab From f6e33252978b88e4d769176521db01ded4cbc541 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Tue, 29 Sep 2020 20:07:56 +0200 Subject: [PATCH 32/96] Do the branching --- Prog/Hop_mod.F90 | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/Prog/Hop_mod.F90 b/Prog/Hop_mod.F90 index 40381732..6aff0915 100644 --- a/Prog/Hop_mod.F90 +++ b/Prog/Hop_mod.F90 @@ -115,10 +115,18 @@ do nf = 1,N_FL call vec(nf)%init() do nc = 1,Ncheck - write (*,*) nf, nc - allocate(cmplxexp)!, realexp) - call cmplxexp%init(Op_T(nc,nf)) - call Move_alloc(cmplxexp, dummy) + + if (Op_is_real(Op_T(nc,nf))) then + ! branch for real operators + allocate(realexp) + call realexp%init(Op_T(nc,nf)) + call Move_alloc(realexp, dummy) ! To satisfy fortran's type checking + else + ! branch for complex operators + allocate(cmplxexp) + call cmplxexp%init(Op_T(nc,nf)) + call Move_alloc(cmplxexp, dummy) ! To satisfy fortran's type checking + endif call vec(nf)%pushback(dummy) ! g = Op_T(nc,nf)%g -- GitLab From 8911c3f49ec154e5b437d7c4ec0a7e5dd6b3763e Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Tue, 29 Sep 2020 21:21:06 +0200 Subject: [PATCH 33/96] Add ZDSLSYMM. A function for mixed multiplications of real and complex matrices. --- Libraries/Modules/Mat_subroutines.F90 | 462 +++++++++++++++++++++++++- 1 file changed, 461 insertions(+), 1 deletion(-) diff --git a/Libraries/Modules/Mat_subroutines.F90 b/Libraries/Modules/Mat_subroutines.F90 index 609bf558..64b5b143 100644 --- a/Libraries/Modules/Mat_subroutines.F90 +++ b/Libraries/Modules/Mat_subroutines.F90 @@ -1,4 +1,4 @@ -! Copyright (C) 2016 - 2018 The ALF project +! Copyright (C) 2016 - 2020 The ALF project ! ! This file is part of the ALF project. ! @@ -957,3 +957,463 @@ subroutine ZSLHEMM(side, uplo, N, M1, M2, A, P, Mat) ENDIF end subroutine ZSLHEMM + + +subroutine ZDSLSYMM(side, uplo, N, M1, M2, A, P, Mat) +! Small Large symmetric matrix multiplication + +!-------------------------------------------------------------------- +!> @author +!> ALF-project +! +!> @brief +!> P^T A P is symmetric +!> !!!!! Side = L +!> M = op( P^T A P) * M +!> Side = R +!> M = M * op( P^T A P) +!> On input: P = Op%P and A = Op%O +!> !!!!! type +!> op = N --> None +!> op = T --> Transposed +!> op = C --> Transposed + Complex conjugation. Same as N. +!> !!!!! Mat has dimensions M1,M2 +!> +!-------------------------------------------------------------------- + use iso_fortran_env, only: output_unit, error_unit + +!FIXME: UPLO is in the general cases ignored! (sufficient for the current use in Hop_mod) + + IMPLICIT NONE + CHARACTER (1) , INTENT(IN) :: side, uplo + INTEGER , INTENT(IN) :: N, M1, M2 + REAL (KIND=KIND(0.D0)), INTENT(IN) , DIMENSION(N,N) :: A + COMPLEX (KIND=KIND(0.D0)), INTENT(INOUT), DIMENSION(M1,M2) :: Mat + INTEGER , INTENT(IN) , DIMENSION(N) :: P + + REAL (KIND=KIND(0.D0)), DIMENSION(:,:), ALLOCATABLE :: WORK + REAL (KIND=KIND(0.D0)), DIMENSION(:), ALLOCATABLE :: RWORK ! required for the ZLACRM calls + COMPLEX (KIND=KIND(0.D0)), DIMENSION(:,:), ALLOCATABLE :: WORK2, WORKCMPLX + Complex (Kind = Kind(0.D0)) :: alpha, beta, Z(8) + INTEGER :: I,L,IDX, NUMBLOCKS + INTEGER, DIMENSION(:), ALLOCATABLE :: IDXLIST, DIMLIST + LOGICAL :: COMPACT, ALLOC + + alpha = 1.D0 + beta = 0.D0 + + !identify possible block structure + !only used in default case for n>4 + IF(N > 8) THEN + COMPACT = .TRUE. + L = 1 + IDX = 1 + ALLOCATE(IDXLIST(N),DIMLIST(N)) + ALLOC = .TRUE. + NUMBLOCKS=0 + DO I=1,N-1 + IF ( P(I)+1 .ne. P(I+1) ) THEN + COMPACT = .FALSE. + NUMBLOCKS=NUMBLOCKS+1 + IDXLIST(NUMBLOCKS)=IDX + DIMLIST(NUMBLOCKS)=L + IDX=IDX+L + L=1 + ELSE + L=L+1 + ENDIF + ENDDO + IF(IDX1) THEN + ALLOCATE(WORK(N,N)) + CALL DLACPY(uplo, N, N, A(1,1), N, WORK(1,1), N) + ! Fill the rest of WORK (thereby ignoring uplo) + IF(uplo=='U' .or. uplo=='u') THEN + DO L=1,N + DO I=1,L-1 + WORK(L,I)=WORK(I,L) + ENDDO + ENDDO + ELSE + DO L=1,N + DO I=L+1,N + WORK(L,I)=WORK(I,L) + ENDDO + ENDDO + ENDIF + ENDIF + + IF ( side == 'L' .or. side == 'l' ) THEN + ! multiply op(A) from the left [ Mat = op(A)*Mat ] + + SELECT CASE(N) + CASE (1) + ! Here only one row is rescaled + ! uplo and transpositions have no effect for 1x1 herm. Matrices + CALL ZDSCAL(M2,A(1,1),Mat(P(1),1),M1) + CASE (2) + ! perform inplace matmult +! L=M2/4 +! DO I=1,4*L-1,4 +! Z(1)=Mat(P(1),I) +! Z(2)=Mat(P(2),I) +! Z(3)=Mat(P(1),I+1) +! Z(4)=Mat(P(2),I+1) +! Z(5)=Mat(P(1),I+2) +! Z(6)=Mat(P(2),I+2) +! Z(7)=Mat(P(1),I+3) +! Z(8)=Mat(P(2),I+3) +! Mat(P(1),I)=WORK(1,1)*Z(1)+WORK(1,2)*Z(2) +! Mat(P(2),I)=WORK(2,1)*Z(1)+WORK(2,2)*Z(2) +! Mat(P(1),I+1)=WORK(1,1)*Z(3)+WORK(1,2)*Z(4) +! Mat(P(2),I+1)=WORK(2,1)*Z(3)+WORK(2,2)*Z(4) +! Mat(P(1),I+2)=WORK(1,1)*Z(5)+WORK(1,2)*Z(6) +! Mat(P(2),I+2)=WORK(2,1)*Z(5)+WORK(2,2)*Z(6) +! Mat(P(1),I+3)=WORK(1,1)*Z(7)+WORK(1,2)*Z(8) +! Mat(P(2),I+3)=WORK(2,1)*Z(7)+WORK(2,2)*Z(8) +! ENDDO + DO I=1,M2!4*L,M2 + Z(1)=Mat(P(1),I) + Z(2)=Mat(P(2),I) + Mat(P(1),I)=WORK(1,1)*Z(1)+WORK(1,2)*Z(2) + Mat(P(2),I)=WORK(2,1)*Z(1)+WORK(2,2)*Z(2) + ENDDO + DEALLOCATE(WORK) + CASE (3) + ! perform inplace matmult +! L=M2/2 +! DO I=1,2*L-1,2 +! Z(1)=Mat(P(1),I) +! Z(2)=Mat(P(2),I) +! Z(3)=Mat(P(3),I) +! Z(4)=Mat(P(1),I+1) +! Z(5)=Mat(P(2),I+1) +! Z(6)=Mat(P(3),I+1) +! Mat(P(1),I)=WORK(1,1)*Z(1)+WORK(1,2)*Z(2)+WORK(1,3)*Z(3) +! Mat(P(2),I)=WORK(2,1)*Z(1)+WORK(2,2)*Z(2)+WORK(2,3)*Z(3) +! Mat(P(3),I)=WORK(3,1)*Z(1)+WORK(3,2)*Z(2)+WORK(3,3)*Z(3) +! Mat(P(1),I+1)=WORK(1,1)*Z(4)+WORK(1,2)*Z(5)+WORK(1,3)*Z(6) +! Mat(P(2),I+1)=WORK(2,1)*Z(4)+WORK(2,2)*Z(5)+WORK(2,3)*Z(6) +! Mat(P(3),I+1)=WORK(3,1)*Z(4)+WORK(3,2)*Z(5)+WORK(3,3)*Z(6) +! ENDDO + DO I=1,M2!2*L,M2 + Z(1)=Mat(P(1),I) + Z(2)=Mat(P(2),I) + Z(3)=Mat(P(3),I) + Mat(P(1),I)=WORK(1,1)*Z(1)+WORK(1,2)*Z(2)+WORK(1,3)*Z(3) + Mat(P(2),I)=WORK(2,1)*Z(1)+WORK(2,2)*Z(2)+WORK(2,3)*Z(3) + Mat(P(3),I)=WORK(3,1)*Z(1)+WORK(3,2)*Z(2)+WORK(3,3)*Z(3) + ENDDO + DEALLOCATE(WORK) + CASE (4) + ! perform inplace matmult + DO I=1,M2 + Z(1)=Mat(P(1),I) + Z(2)=Mat(P(2),I) + Z(3)=Mat(P(3),I) + Z(4)=Mat(P(4),I) + Mat(P(1),I)=WORK(1,1)*Z(1)+WORK(1,2)*Z(2)+WORK(1,3)*Z(3)+WORK(1,4)*Z(4) + Mat(P(2),I)=WORK(2,1)*Z(1)+WORK(2,2)*Z(2)+WORK(2,3)*Z(3)+WORK(2,4)*Z(4) + Mat(P(3),I)=WORK(3,1)*Z(1)+WORK(3,2)*Z(2)+WORK(3,3)*Z(3)+WORK(3,4)*Z(4) + Mat(P(4),I)=WORK(4,1)*Z(1)+WORK(4,2)*Z(2)+WORK(4,3)*Z(3)+WORK(4,4)*Z(4) + ENDDO + DEALLOCATE(WORK) + CASE (5) + ! perform inplace matmult + DO I=1,M2 + Z(1)=Mat(P(1),I) + Z(2)=Mat(P(2),I) + Z(3)=Mat(P(3),I) + Z(4)=Mat(P(4),I) + Z(5)=Mat(P(5),I) + Mat(P(1),I)=WORK(1,1)*Z(1)+WORK(1,2)*Z(2)+WORK(1,3)*Z(3)+WORK(1,4)*Z(4)+WORK(1,5)*Z(5) + Mat(P(2),I)=WORK(2,1)*Z(1)+WORK(2,2)*Z(2)+WORK(2,3)*Z(3)+WORK(2,4)*Z(4)+WORK(2,5)*Z(5) + Mat(P(3),I)=WORK(3,1)*Z(1)+WORK(3,2)*Z(2)+WORK(3,3)*Z(3)+WORK(3,4)*Z(4)+WORK(3,5)*Z(5) + Mat(P(4),I)=WORK(4,1)*Z(1)+WORK(4,2)*Z(2)+WORK(4,3)*Z(3)+WORK(4,4)*Z(4)+WORK(4,5)*Z(5) + Mat(P(5),I)=WORK(5,1)*Z(1)+WORK(5,2)*Z(2)+WORK(5,3)*Z(3)+WORK(5,4)*Z(4)+WORK(5,5)*Z(5) + ENDDO + DEALLOCATE(WORK) + CASE (6) + ! perform inplace matmult + DO I=1,M2 + Z(1)=Mat(P(1),I) + Z(2)=Mat(P(2),I) + Z(3)=Mat(P(3),I) + Z(4)=Mat(P(4),I) + Z(5)=Mat(P(5),I) + Z(6)=Mat(P(6),I) + Mat(P(1),I)=WORK(1,1)*Z(1)+WORK(1,2)*Z(2)+WORK(1,3)*Z(3)& + &+WORK(1,4)*Z(4)+WORK(1,5)*Z(5)+WORK(1,6)*Z(6) + Mat(P(2),I)=WORK(2,1)*Z(1)+WORK(2,2)*Z(2)+WORK(2,3)*Z(3)& + &+WORK(2,4)*Z(4)+WORK(2,5)*Z(5)+WORK(2,6)*Z(6) + Mat(P(3),I)=WORK(3,1)*Z(1)+WORK(3,2)*Z(2)+WORK(3,3)*Z(3)& + &+WORK(3,4)*Z(4)+WORK(3,5)*Z(5)+WORK(3,6)*Z(6) + Mat(P(4),I)=WORK(4,1)*Z(1)+WORK(4,2)*Z(2)+WORK(4,3)*Z(3)& + &+WORK(4,4)*Z(4)+WORK(4,5)*Z(5)+WORK(4,6)*Z(6) + Mat(P(5),I)=WORK(5,1)*Z(1)+WORK(5,2)*Z(2)+WORK(5,3)*Z(3)& + &+WORK(5,4)*Z(4)+WORK(5,5)*Z(5)+WORK(5,6)*Z(6) + Mat(P(6),I)=WORK(6,1)*Z(1)+WORK(6,2)*Z(2)+WORK(6,3)*Z(3)& + &+WORK(6,4)*Z(4)+WORK(6,5)*Z(5)+WORK(6,6)*Z(6) + ENDDO + DEALLOCATE(WORK) + CASE (7) + ! perform inplace matmult + DO I=1,M2 + Z(1)=Mat(P(1),I) + Z(2)=Mat(P(2),I) + Z(3)=Mat(P(3),I) + Z(4)=Mat(P(4),I) + Z(5)=Mat(P(5),I) + Z(6)=Mat(P(6),I) + Z(7)=Mat(P(7),I) + Mat(P(1),I)=WORK(1,1)*Z(1)+WORK(1,2)*Z(2)+WORK(1,3)*Z(3)& + &+WORK(1,4)*Z(4)+WORK(1,5)*Z(5)+WORK(1,6)*Z(6)+WORK(1,7)*Z(7) + Mat(P(2),I)=WORK(2,1)*Z(1)+WORK(2,2)*Z(2)+WORK(2,3)*Z(3)& + &+WORK(2,4)*Z(4)+WORK(2,5)*Z(5)+WORK(2,6)*Z(6)+WORK(2,7)*Z(7) + Mat(P(3),I)=WORK(3,1)*Z(1)+WORK(3,2)*Z(2)+WORK(3,3)*Z(3)& + &+WORK(3,4)*Z(4)+WORK(3,5)*Z(5)+WORK(3,6)*Z(6)+WORK(3,7)*Z(7) + Mat(P(4),I)=WORK(4,1)*Z(1)+WORK(4,2)*Z(2)+WORK(4,3)*Z(3)& + &+WORK(4,4)*Z(4)+WORK(4,5)*Z(5)+WORK(4,6)*Z(6)+WORK(4,7)*Z(7) + Mat(P(5),I)=WORK(5,1)*Z(1)+WORK(5,2)*Z(2)+WORK(5,3)*Z(3)& + &+WORK(5,4)*Z(4)+WORK(5,5)*Z(5)+WORK(5,6)*Z(6)+WORK(5,7)*Z(7) + Mat(P(6),I)=WORK(6,1)*Z(1)+WORK(6,2)*Z(2)+WORK(6,3)*Z(3)& + &+WORK(6,4)*Z(4)+WORK(6,5)*Z(5)+WORK(6,6)*Z(6)+WORK(6,7)*Z(7) + Mat(P(7),I)=WORK(7,1)*Z(1)+WORK(7,2)*Z(2)+WORK(7,3)*Z(3)& + &+WORK(7,4)*Z(4)+WORK(7,5)*Z(5)+WORK(7,6)*Z(6)+WORK(7,7)*Z(7) + ENDDO + DEALLOCATE(WORK) + CASE (8) + ! perform inplace matmult + DO I=1,M2 + Z(1)=Mat(P(1),I) + Z(2)=Mat(P(2),I) + Z(3)=Mat(P(3),I) + Z(4)=Mat(P(4),I) + Z(5)=Mat(P(5),I) + Z(6)=Mat(P(6),I) + Z(7)=Mat(P(7),I) + Z(8)=Mat(P(8),I) + Mat(P(1),I)=WORK(1,1)*Z(1)+WORK(1,2)*Z(2)+WORK(1,3)*Z(3)+WORK(1,4)*Z(4)& + &+WORK(1,5)*Z(5)+WORK(1,6)*Z(6)+WORK(1,7)*Z(7)+WORK(1,8)*Z(8) + Mat(P(2),I)=WORK(2,1)*Z(1)+WORK(2,2)*Z(2)+WORK(2,3)*Z(3)+WORK(2,4)*Z(4)& + &+WORK(2,5)*Z(5)+WORK(2,6)*Z(6)+WORK(2,7)*Z(7)+WORK(2,8)*Z(8) + Mat(P(3),I)=WORK(3,1)*Z(1)+WORK(3,2)*Z(2)+WORK(3,3)*Z(3)+WORK(3,4)*Z(4)& + &+WORK(3,5)*Z(5)+WORK(3,6)*Z(6)+WORK(3,7)*Z(7)+WORK(3,8)*Z(8) + Mat(P(4),I)=WORK(4,1)*Z(1)+WORK(4,2)*Z(2)+WORK(4,3)*Z(3)+WORK(4,4)*Z(4)& + &+WORK(4,5)*Z(5)+WORK(4,6)*Z(6)+WORK(4,7)*Z(7)+WORK(4,8)*Z(8) + Mat(P(5),I)=WORK(5,1)*Z(1)+WORK(5,2)*Z(2)+WORK(5,3)*Z(3)+WORK(5,4)*Z(4)& + &+WORK(5,5)*Z(5)+WORK(5,6)*Z(6)+WORK(5,7)*Z(7)+WORK(5,8)*Z(8) + Mat(P(6),I)=WORK(6,1)*Z(1)+WORK(6,2)*Z(2)+WORK(6,3)*Z(3)+WORK(6,4)*Z(4)& + &+WORK(6,5)*Z(5)+WORK(6,6)*Z(6)+WORK(6,7)*Z(7)+WORK(6,8)*Z(8) + Mat(P(7),I)=WORK(7,1)*Z(1)+WORK(7,2)*Z(2)+WORK(7,3)*Z(3)+WORK(7,4)*Z(4)& + &+WORK(7,5)*Z(5)+WORK(7,6)*Z(6)+WORK(7,7)*Z(7)+WORK(7,8)*Z(8) + Mat(P(8),I)=WORK(8,1)*Z(1)+WORK(8,2)*Z(2)+WORK(8,3)*Z(3)+WORK(8,4)*Z(4)& + &+WORK(8,5)*Z(5)+WORK(8,6)*Z(6)+WORK(8,7)*Z(7)+WORK(8,8)*Z(8) + ENDDO + DEALLOCATE(WORK) + CASE DEFAULT + ! allocate memory and copy blocks of Mat to work + ALLOCATE(WORKCMPLX(N,M2)) + DO I=1,NUMBLOCKS + CALL ZLACPY('A', DIMLIST(I), M2, Mat(P(IDXLIST(I)),1), M1, WORKCMPLX(IDXLIST(I),1), N) + ENDDO + + ! Perform Mat multiplication + IF(COMPACT) THEN + !write result directly into mat + allocate (RWORK(2*N*M2)) + call ZLARCM(N, M2, A(1, 1), N, WORKCMPLX(1,1), N, Mat(P(1), 1), M1, RWORK) + +! CALL ZHEMM(side, uplo, N, M2, alpha, A(1, 1), N, WORKCMPLX(1, 1), N, beta, Mat(P(1), 1), M1) + DEALLOCATE(RWORK) + ELSE + !additional space for result + ALLOCATE(WORK2(N,M2), RWORK(2*N*M2)) + call ZLARCM(N, M2, A(1, 1), N, WORKCMPLX(1,1), N, WORK2(1,1), N, RWORK) +! CALL ZHEMM(side, uplo, N, M2, alpha, A(1, 1), N, WORKCMPLX(1, 1), N, beta, WORK2(1, 1), N) + !distribute result back into mat using blocks + DO I=1,NUMBLOCKS + CALL ZLACPY('A', DIMLIST(I), M2, WORK2(IDXLIST(I),1), N, Mat(P(IDXLIST(I)),1), M1) + ENDDO + !free result memory + DEALLOCATE(WORK2, RWORK) + ENDIF + !free memory of first mat copy + DEALLOCATE(WORKCMPLX,IDXLIST,DIMLIST) + END SELECT + + ELSEIF ( side == 'R' .or. side == 'r' ) THEN + ! multiply op(A) from the right [ Mat = Mat*op(A) ] + + SELECT CASE(N) + CASE (1) + ! Here only one column is rescaled + ! uplo and transpositions have no effect for 1x1 matrices + CALL ZDSCAL(M1,A(1,1),Mat(1,P(1)),1) + CASE (2) + ! perform inplace matmult + DO I=1,M1 + Z(1)=Mat(I,P(1)) + Z(2)=Mat(I,P(2)) + Mat(I,P(1))=WORK(1,1)*Z(1)+WORK(2,1)*Z(2) + Mat(I,P(2))=WORK(1,2)*Z(1)+WORK(2,2)*Z(2) + ENDDO + DEALLOCATE(WORK) + CASE (3) + ! perform inplace matmult + DO I=1,M1 + Z(1)=Mat(I,P(1)) + Z(2)=Mat(I,P(2)) + Z(3)=Mat(I,P(3)) + Mat(I,P(1))=WORK(1,1)*Z(1)+WORK(2,1)*Z(2)+WORK(3,1)*Z(3) + Mat(I,P(2))=WORK(1,2)*Z(1)+WORK(2,2)*Z(2)+WORK(3,2)*Z(3) + Mat(I,P(3))=WORK(1,3)*Z(1)+WORK(2,3)*Z(2)+WORK(3,3)*Z(3) + ENDDO + DEALLOCATE(WORK) + CASE (4) + ! perform inplace matmult + DO I=1,M1 + Z(1)=Mat(I,P(1)) + Z(2)=Mat(I,P(2)) + Z(3)=Mat(I,P(3)) + Z(4)=Mat(I,P(4)) + Mat(I,P(1))=WORK(1,1)*Z(1)+WORK(2,1)*Z(2)+WORK(3,1)*Z(3)+WORK(4,1)*Z(4) + Mat(I,P(2))=WORK(1,2)*Z(1)+WORK(2,2)*Z(2)+WORK(3,2)*Z(3)+WORK(4,2)*Z(4) + Mat(I,P(3))=WORK(1,3)*Z(1)+WORK(2,3)*Z(2)+WORK(3,3)*Z(3)+WORK(4,3)*Z(4) + Mat(I,P(4))=WORK(1,4)*Z(1)+WORK(2,4)*Z(2)+WORK(3,4)*Z(3)+WORK(4,4)*Z(4) + ENDDO + DEALLOCATE(WORK) + CASE (5) + ! perform inplace matmult + DO I=1,M1 + Z(1)=Mat(I,P(1)) + Z(2)=Mat(I,P(2)) + Z(3)=Mat(I,P(3)) + Z(4)=Mat(I,P(4)) + Z(5)=Mat(I,P(5)) + Mat(I,P(1))=WORK(1,1)*Z(1)+WORK(2,1)*Z(2)+WORK(3,1)*Z(3)+WORK(4,1)*Z(4)+WORK(5,1)*Z(5) + Mat(I,P(2))=WORK(1,2)*Z(1)+WORK(2,2)*Z(2)+WORK(3,2)*Z(3)+WORK(4,2)*Z(4)+WORK(5,2)*Z(5) + Mat(I,P(3))=WORK(1,3)*Z(1)+WORK(2,3)*Z(2)+WORK(3,3)*Z(3)+WORK(4,3)*Z(4)+WORK(5,3)*Z(5) + Mat(I,P(4))=WORK(1,4)*Z(1)+WORK(2,4)*Z(2)+WORK(3,4)*Z(3)+WORK(4,4)*Z(4)+WORK(5,4)*Z(5) + Mat(I,P(5))=WORK(1,5)*Z(1)+WORK(2,5)*Z(2)+WORK(3,5)*Z(3)+WORK(4,5)*Z(4)+WORK(5,5)*Z(5) + ENDDO + DEALLOCATE(WORK) + CASE (6) + ! perform inplace matmult + DO I=1,M1 + Z(1)=Mat(I,P(1)) + Z(2)=Mat(I,P(2)) + Z(3)=Mat(I,P(3)) + Z(4)=Mat(I,P(4)) + Z(5)=Mat(I,P(5)) + Z(6)=Mat(I,P(6)) + Mat(I,P(1))=WORK(1,1)*Z(1)+WORK(2,1)*Z(2)+WORK(3,1)*Z(3)& + &+WORK(4,1)*Z(4)+WORK(5,1)*Z(5)+WORK(6,1)*Z(6) + Mat(I,P(2))=WORK(1,2)*Z(1)+WORK(2,2)*Z(2)+WORK(3,2)*Z(3)& + &+WORK(4,2)*Z(4)+WORK(5,2)*Z(5)+WORK(6,2)*Z(6) + Mat(I,P(3))=WORK(1,3)*Z(1)+WORK(2,3)*Z(2)+WORK(3,3)*Z(3)& + &+WORK(4,3)*Z(4)+WORK(5,3)*Z(5)+WORK(6,3)*Z(6) + Mat(I,P(4))=WORK(1,4)*Z(1)+WORK(2,4)*Z(2)+WORK(3,4)*Z(3)& + &+WORK(4,4)*Z(4)+WORK(5,4)*Z(5)+WORK(6,4)*Z(6) + Mat(I,P(5))=WORK(1,5)*Z(1)+WORK(2,5)*Z(2)+WORK(3,5)*Z(3)& + &+WORK(4,5)*Z(4)+WORK(5,5)*Z(5)+WORK(6,5)*Z(6) + Mat(I,P(6))=WORK(1,6)*Z(1)+WORK(2,6)*Z(2)+WORK(3,6)*Z(3)& + &+WORK(4,6)*Z(4)+WORK(5,6)*Z(5)+WORK(6,6)*Z(6) + ENDDO + DEALLOCATE(WORK) + CASE (7) + ! perform inplace matmult + DO I=1,M1 + Z(1)=Mat(I,P(1)) + Z(2)=Mat(I,P(2)) + Z(3)=Mat(I,P(3)) + Z(4)=Mat(I,P(4)) + Z(5)=Mat(I,P(5)) + Z(6)=Mat(I,P(6)) + Z(7)=Mat(I,P(7)) + Mat(I,P(1))=WORK(1,1)*Z(1)+WORK(2,1)*Z(2)+WORK(3,1)*Z(3)& + &+WORK(4,1)*Z(4)+WORK(5,1)*Z(5)+WORK(6,1)*Z(6)+WORK(7,1)*Z(7) + Mat(I,P(2))=WORK(1,2)*Z(1)+WORK(2,2)*Z(2)+WORK(3,2)*Z(3)& + &+WORK(4,2)*Z(4)+WORK(5,2)*Z(5)+WORK(6,2)*Z(6)+WORK(7,2)*Z(7) + Mat(I,P(3))=WORK(1,3)*Z(1)+WORK(2,3)*Z(2)+WORK(3,3)*Z(3)& + &+WORK(4,3)*Z(4)+WORK(5,3)*Z(5)+WORK(6,3)*Z(6)+WORK(7,3)*Z(7) + Mat(I,P(4))=WORK(1,4)*Z(1)+WORK(2,4)*Z(2)+WORK(3,4)*Z(3)& + &+WORK(4,4)*Z(4)+WORK(5,4)*Z(5)+WORK(6,4)*Z(6)+WORK(7,4)*Z(7) + Mat(I,P(5))=WORK(1,5)*Z(1)+WORK(2,5)*Z(2)+WORK(3,5)*Z(3)& + &+WORK(4,5)*Z(4)+WORK(5,5)*Z(5)+WORK(6,5)*Z(6)+WORK(7,5)*Z(7) + Mat(I,P(6))=WORK(1,6)*Z(1)+WORK(2,6)*Z(2)+WORK(3,6)*Z(3)& + &+WORK(4,6)*Z(4)+WORK(5,6)*Z(5)+WORK(6,6)*Z(6)+WORK(7,6)*Z(7) + Mat(I,P(7))=WORK(1,7)*Z(1)+WORK(2,7)*Z(2)+WORK(3,7)*Z(3)& + &+WORK(4,7)*Z(4)+WORK(5,7)*Z(5)+WORK(6,7)*Z(6)+WORK(7,7)*Z(7) + ENDDO + DEALLOCATE(WORK) + CASE (8) + ! perform inplace matmult + DO I=1,M1 + Z(1)=Mat(I,P(1)) + Z(2)=Mat(I,P(2)) + Z(3)=Mat(I,P(3)) + Z(4)=Mat(I,P(4)) + Z(5)=Mat(I,P(5)) + Z(6)=Mat(I,P(6)) + Z(7)=Mat(I,P(7)) + Z(8)=Mat(I,P(8)) + Mat(I,P(1))=WORK(1,1)*Z(1)+WORK(2,1)*Z(2)+WORK(3,1)*Z(3)+WORK(4,1)*Z(4)& + &+WORK(5,1)*Z(5)+WORK(6,1)*Z(6)+WORK(7,1)*Z(7)+WORK(8,1)*Z(8) + Mat(I,P(2))=WORK(1,2)*Z(1)+WORK(2,2)*Z(2)+WORK(3,2)*Z(3)+WORK(4,2)*Z(4)& + &+WORK(5,2)*Z(5)+WORK(6,2)*Z(6)+WORK(7,2)*Z(7)+WORK(8,2)*Z(8) + Mat(I,P(3))=WORK(1,3)*Z(1)+WORK(2,3)*Z(2)+WORK(3,3)*Z(3)+WORK(4,3)*Z(4)& + &+WORK(5,3)*Z(5)+WORK(6,3)*Z(6)+WORK(7,3)*Z(7)+WORK(8,3)*Z(8) + Mat(I,P(4))=WORK(1,4)*Z(1)+WORK(2,4)*Z(2)+WORK(3,4)*Z(3)+WORK(4,4)*Z(4)& + &+WORK(5,4)*Z(5)+WORK(6,4)*Z(6)+WORK(7,4)*Z(7)+WORK(8,4)*Z(8) + Mat(I,P(5))=WORK(1,5)*Z(1)+WORK(2,5)*Z(2)+WORK(3,5)*Z(3)+WORK(4,5)*Z(4)& + &+WORK(5,5)*Z(5)+WORK(6,5)*Z(6)+WORK(7,5)*Z(7)+WORK(8,5)*Z(8) + Mat(I,P(6))=WORK(1,6)*Z(1)+WORK(2,6)*Z(2)+WORK(3,6)*Z(3)+WORK(4,6)*Z(4)& + &+WORK(5,6)*Z(5)+WORK(6,6)*Z(6)+WORK(7,6)*Z(7)+WORK(8,6)*Z(8) + Mat(I,P(7))=WORK(1,7)*Z(1)+WORK(2,7)*Z(2)+WORK(3,7)*Z(3)+WORK(4,7)*Z(4)& + &+WORK(5,7)*Z(5)+WORK(6,7)*Z(6)+WORK(7,7)*Z(7)+WORK(8,7)*Z(8) + Mat(I,P(8))=WORK(1,8)*Z(1)+WORK(2,8)*Z(2)+WORK(3,8)*Z(3)+WORK(4,8)*Z(4)& + &+WORK(5,8)*Z(5)+WORK(6,8)*Z(6)+WORK(7,8)*Z(7)+WORK(8,8)*Z(8) + ENDDO + DEALLOCATE(WORK) + CASE DEFAULT + ! allocate memory and copy blocks of Mat to work + ALLOCATE(WORKCMPLX(M1,N)) + DO I=1,NUMBLOCKS + CALL ZLACPY('A', M1, DIMLIST(I), Mat(1,P(IDXLIST(I))), M1, WORKCMPLX(1,IDXLIST(I)), M1) + ENDDO + + ! Perform Mat multiplication + IF(COMPACT) THEN ! B*A + C + ALLOCATE(RWORK(2*M1*N)) + !write result directly into mat + call ZLACRM(M1, N, WORKCMPLX(1,1), M1, A(1, 1), N, Mat(1, P(1)), M1, RWORK) +! CALL ZHEMM(side, uplo, M1, N, alpha, A(1, 1), N, WORKCMPLX(1, 1), M1, beta, Mat(1, P(1)), M1) + DEALLOCATE(RWORK) + ELSE + !additional space for result + ALLOCATE(WORK2(M1,N), RWORK(2*M1*N)) + call ZLACRM(M1, N, WORKCMPLX(1,1), M1, A(1, 1), N, WORK2(1, 1), M1, RWORK) +! CALL ZHEMM(side, uplo, M1, N, alpha, A(1, 1), N, WORKCMPLX(1, 1), M1, beta, WORK2(1, 1), M1) + !distribute result back into mat using blocks + DO I=1,NUMBLOCKS + CALL ZLACPY('A', M1, DIMLIST(I), WORK2(1,IDXLIST(I)), M1, Mat(1,P(IDXLIST(I))), M1) + ENDDO + !free result memory + DEALLOCATE(WORK2, RWORK) + ENDIF + !free memory of first mat copy + DEALLOCATE(WORKCMPLX,IDXLIST,DIMLIST) + END SELECT + + ELSE + write(error_unit,*) 'ZSLHEMM: Illegal argument for side: It is not one of [R,r,L,l] !' + error stop 1 + ENDIF + +end subroutine ZDSLSYMM -- GitLab From 3c834453b4a518d919b9cdf18c81d9aa9a1d90ed Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Tue, 29 Sep 2020 21:21:47 +0200 Subject: [PATCH 34/96] implement logic for real operators. --- Prog/OpTTypes_mod.F90 | 124 ++++++++++++++++++++++++++---------------- 1 file changed, 76 insertions(+), 48 deletions(-) diff --git a/Prog/OpTTypes_mod.F90 b/Prog/OpTTypes_mod.F90 index 08e5c546..c9477439 100644 --- a/Prog/OpTTypes_mod.F90 +++ b/Prog/OpTTypes_mod.F90 @@ -35,6 +35,7 @@ module OpTTypes_mod use Operator_mod implicit none + ! Encapsulates Operations for real OpTs type, extends(ContainerElementBase) :: RealOpT Real(kind=kind(0.d0)), allocatable, dimension(:,:) :: mat, invmat Real(kind=kind(0.d0)) :: g, Zero @@ -51,8 +52,9 @@ module OpTTypes_mod procedure :: dump => RealOpT_dump end type RealOpT + ! Encapsulates Operations for complex OpTs type, extends(ContainerElementBase) :: CmplxOpT - Complex(kind=kind(0.d0)),allocatable, dimension(:,:):: mat, invmat + Complex(kind=kind(0.d0)),allocatable, dimension(:,:) :: mat, invmat Complex(kind=kind(0.d0)) :: g Real(kind=kind(0.d0)) :: Zero integer, pointer :: P(:) @@ -68,12 +70,33 @@ module OpTTypes_mod end type CmplxOpT contains - subroutine RealOpT_init(this, OpT) + subroutine RealOpT_init(this, Op_T) class(RealOpT) :: this - Type(Operator), intent(in) :: OpT - Integer :: i,j + Type(Operator), intent(in) :: Op_T + Complex(kind=kind(0.d0)),allocatable, dimension(:,:) :: cmat, cinvmat + Complex(kind=kind(0.d0)) :: cg + Integer :: i, j this%Zero = 1.E-12 + this%Ndim_hop = Op_T%N + cg = -Op_T%g + allocate (this%mat(this%Ndim_hop, this%Ndim_hop), this%invmat(this%Ndim_hop, this%Ndim_hop), cmat(this%Ndim_hop, this%Ndim_hop), cinvmat(this%Ndim_hop, this%Ndim_hop)) + + Call Op_exp(cg, Op_T, cinvmat) + cg = Op_T%g + Call Op_exp(cg, Op_T, cmat ) + ! copy over the data to the real storage + this%mat = DBLE(cmat) + this%invmat = DBLE(cinvmat) + + DO i = 1, this%Ndim_hop + DO j = i, this%Ndim_hop + this%mat(i, j) = (this%mat(i, j) + this%mat(j, i))/2.D0 + this%invmat(i, j) = (this%invmat(i, j) + this%invmat(j, i))/2.D0 + ENDDO + ENDDO + this%P => Op_T%P + this%g = DBLE(Op_T%g) end subroutine subroutine RealOpT_simt(this, arg) @@ -88,43 +111,50 @@ contains Complex(kind=kind(0.D0)), intent(inout), dimension(:,:) :: arg Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: out Real(kind=kind(0.D0)), allocatable, dimension(:) :: rwork - Integer :: i, j, sz1, sz2 + Integer :: n1, n2 - sz1 = size(arg, 1) - sz2 = size(arg, 2) - allocate(out(sz1, sz2), rwork(2*sz1*sz2)) - call zlacrm(sz1, sz2, arg, sz1, this%mat, this%m, out, this%m, rwork) ! zlarcm assumes mat to be square - arg = out - deallocate(out, rwork) + n1 = size(arg,1) + n2 = size(arg,2) + If ( this%g*this%g > this%Zero ) then + call ZDSLSYMM('R', 'U', this%Ndim_hop, n1, n2, this%mat, this%P, arg) + Endif end subroutine subroutine RealOpT_rmultinv(this, arg) class(RealOpT), intent(in) :: this Complex(kind=kind(0.D0)), intent(inout), dimension(:,:) :: arg - Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: out - Real(kind=kind(0.D0)), allocatable, dimension(:) :: rwork - Integer :: i, j, sz1, sz2 + Integer :: n1, n2 - sz1 = size(arg, 1) - sz2 = size(arg, 2) - allocate(out(sz1, sz2), rwork(2*sz1*sz2)) - call zlacrm(sz1, sz2, arg, sz1, this%mat, this%m, out, this%m, rwork) ! zlarcm assumes mat to be square - arg = out - deallocate(out, rwork) + n1 = size(arg,1) + n2 = size(arg,2) + If ( this%g*this%g > this%Zero ) then + call ZDSLSYMM('R', 'U', this%Ndim_hop, n1, n2, this%invmat, this%P, arg) + Endif end subroutine subroutine RealOpT_lmult(this, arg) class(RealOpT), intent(in) :: this Complex(kind=kind(0.D0)), intent(inout), dimension(:,:) :: arg - Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: temp - + integer :: n1, n2 + + ! taken from mmthr + n1 = size(arg,1) + n2 = size(arg,2) + If ( this%g*this%g > this%Zero ) then + call ZDSLSYMM('L', 'U', this%Ndim_hop, n1, n2, this%mat, this%P, arg) + Endif end subroutine subroutine RealOpT_lmultinv(this, arg) class(RealOpT), intent(in) :: this Complex(kind=kind(0.D0)), intent(inout), dimension(:,:) :: arg - Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: temp - + integer :: n1, n2 + + n1 = size(arg,1) + n2 = size(arg,2) + If ( this%g*this%g > this%Zero ) then + call ZDSLSYMM('L', 'U', this%Ndim_hop, n1, n2, this%invmat, this%P, arg) + Endif end subroutine subroutine CmplxOpT_init(this, Op_T) @@ -159,7 +189,7 @@ contains subroutine CmplxOpT_rmult(this, arg) class(CmplxOpT), intent(in) :: this Complex(kind=kind(0.D0)), intent(inout), dimension(:,:) :: arg - Integer :: i, j, n1, n2 + Integer :: n1, n2 ! taken from mmthl n1 = size(arg,1) @@ -194,19 +224,29 @@ contains call ZSLHEMM('L', 'U', this%Ndim_hop, n1, n2, this%mat, this%P, arg) Endif end subroutine + + subroutine CmplxOpT_lmultinv(this, arg) + class(CmplxOpT), intent(in) :: this + Complex(kind=kind(0.D0)), intent(inout), dimension(:,:) :: arg + integer :: n1, n2 + n1 = size(arg,1) + n2 = size(arg,2) + If ( dble(this%g*conjg(this%g)) > this%Zero ) then + call ZSLHEMM('L', 'U', this%Ndim_hop, n1, n2, this%invmat, this%P, arg) + Endif + end subroutine subroutine CmplxOpT_dump(this) class(CmplxOpT), intent(in) :: this integer :: i,j do i = 1, size(this%mat, 1) -write (*,*) (dble(this%mat(i,j)), j = 1,size(this%mat,2) ) -enddo -write (*,*) "---------------" + write (*,*) (dble(this%mat(i,j)), j = 1,size(this%mat,2) ) + enddo + write (*,*) "---------------" do i = 1, size(this%mat, 1) -write (*,*) (dble(this%invmat(i,j)), j = 1,size(this%mat,2) ) -enddo - + write (*,*) (dble(this%invmat(i,j)), j = 1,size(this%mat,2) ) + enddo end subroutine subroutine RealOpT_dump(this) @@ -214,24 +254,12 @@ enddo integer :: i,j do i = 1, size(this%mat, 1) -write (*,*) (dble(this%mat(i,j)), j = 1,size(this%mat,2) ) -enddo -write (*,*) "---------------" + write (*,*) (dble(this%mat(i,j)), j = 1,size(this%mat,2) ) + enddo + write (*,*) "---------------" do i = 1, size(this%mat, 1) -write (*,*) (dble(this%invmat(i,j)), j = 1,size(this%mat,2) ) -enddo - - end subroutine - - subroutine CmplxOpT_lmultinv(this, arg) - class(CmplxOpT), intent(in) :: this - Complex(kind=kind(0.D0)), intent(inout), dimension(:,:) :: arg - integer :: n1, n2 - n1 = size(arg,1) - n2 = size(arg,2) - If ( dble(this%g*conjg(this%g)) > this%Zero ) then - call ZSLHEMM('L', 'U', this%Ndim_hop, n1, n2, this%invmat, this%P, arg) - Endif + write (*,*) (dble(this%invmat(i,j)), j = 1,size(this%mat,2) ) + enddo end subroutine end module OpTTypes_mod -- GitLab From 8fb075d26eef6ba302ee061effbbc3e529de708b Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Tue, 29 Sep 2020 21:41:28 +0200 Subject: [PATCH 35/96] leak less memory --- Prog/ContainerElementBase_mod.F90 | 6 ++++++ Prog/OpTTypes_mod.F90 | 17 ++++++++++++++++- 2 files changed, 22 insertions(+), 1 deletion(-) diff --git a/Prog/ContainerElementBase_mod.F90 b/Prog/ContainerElementBase_mod.F90 index 95373f98..1fceaa53 100644 --- a/Prog/ContainerElementBase_mod.F90 +++ b/Prog/ContainerElementBase_mod.F90 @@ -43,6 +43,7 @@ module ContainerElementBase_mod procedure(rmultinvinterface), deferred :: rmultinv procedure(lmultinvinterface), deferred :: lmultinv procedure(dump), deferred :: dump + procedure(dealloc), deferred :: dealloc end type ContainerElementBase abstract interface @@ -80,5 +81,10 @@ module ContainerElementBase_mod import ContainerElementBase class(ContainerElementBase), intent(in) :: this end subroutine + + subroutine dealloc(this) + import ContainerElementBase + class(ContainerElementBase), intent(inout) :: this + end subroutine end interface end module ContainerElementBase_mod diff --git a/Prog/OpTTypes_mod.F90 b/Prog/OpTTypes_mod.F90 index c9477439..3677bfdd 100644 --- a/Prog/OpTTypes_mod.F90 +++ b/Prog/OpTTypes_mod.F90 @@ -44,6 +44,7 @@ module OpTTypes_mod contains procedure :: init => RealOpT_init + procedure :: dealloc => RealOpT_dealloc procedure :: simt => RealOpT_simt procedure :: rmult => RealOpT_rmult procedure :: lmult => RealOpT_lmult @@ -61,6 +62,7 @@ module OpTTypes_mod Integer :: m, n, Ndim_hop contains procedure :: init => CmplxOpT_init + procedure :: dealloc => CmplxOpT_dealloc procedure :: simt => CmplxOpT_simt procedure :: rmult => CmplxOpT_rmult procedure :: lmult => CmplxOpT_lmult @@ -84,7 +86,7 @@ contains Call Op_exp(cg, Op_T, cinvmat) cg = Op_T%g - Call Op_exp(cg, Op_T, cmat ) + Call Op_exp(cg, Op_T, cmat) ! copy over the data to the real storage this%mat = DBLE(cmat) this%invmat = DBLE(cinvmat) @@ -97,6 +99,7 @@ contains ENDDO this%P => Op_T%P this%g = DBLE(Op_T%g) + deallocate(cmat, cinvmat) end subroutine subroutine RealOpT_simt(this, arg) @@ -262,4 +265,16 @@ contains enddo end subroutine + subroutine CmplxOpT_dealloc(this) + class(CmplxOpT), intent(inout) :: this + + deallocate(this%mat, this%invmat) + end subroutine + + subroutine RealOpT_dealloc(this) + class(RealOpT), intent(inout) :: this + + deallocate(this%mat, this%invmat) + end subroutine + end module OpTTypes_mod -- GitLab From 77c6deef122fdd9ffea656e95e09bbdf559c855a Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Tue, 29 Sep 2020 21:50:04 +0200 Subject: [PATCH 36/96] improve backwards compatibility --- Prog/DynamicMatrixArray_mod.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/Prog/DynamicMatrixArray_mod.F90 b/Prog/DynamicMatrixArray_mod.F90 index 57f5d407..5874e2ab 100644 --- a/Prog/DynamicMatrixArray_mod.F90 +++ b/Prog/DynamicMatrixArray_mod.F90 @@ -105,16 +105,16 @@ end subroutine ! !-------------------------------------------------------------------- function DynamicMatrixArray_at(this, pos) result(itm) - class(DynamicMatrixArray) :: this + class(DynamicMatrixArray), intent(in) :: this integer, intent(in) :: pos class(ContainerElementBase), allocatable :: itm - itm = this%data(pos)%dat + allocate(itm, source=this%data(pos)%dat) ! improved backwards compatibility with this construct end function subroutine DynamicMatrixArray_back(this, itm) - class(DynamicMatrixArray) :: this + class(DynamicMatrixArray), intent(in) :: this class(ContainerElementBase), intent(out), allocatable :: itm - itm = this%data(this%tail-1)%dat + allocate(itm, source=this%data(this%tail-1)%dat) ! improved backwards compatibility with this construct end subroutine function DynamicMatrixArray_length(this) result(l) -- GitLab From 6840ae5e5023fb69b3f96fd1a56fc0ca30cc8a8d Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Wed, 30 Sep 2020 01:34:38 +0200 Subject: [PATCH 37/96] try some more compatibility --- Prog/Hop_mod.F90 | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/Prog/Hop_mod.F90 b/Prog/Hop_mod.F90 index 6aff0915..7869a336 100644 --- a/Prog/Hop_mod.F90 +++ b/Prog/Hop_mod.F90 @@ -174,7 +174,8 @@ ! N1=size(In,1) ! N2=size(In,2) do nc = Ncheck,1,-1 - dummy = vec(nf)%at(nc) +! dummy = vec(nf)%at(nc) +allocate(dummy, source = vec(nf)%at(nc)) call dummy%lmult(In) ! If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then ! call ZSLHEMM('L','U',Ndim_hop,N1,N2,Exp_T(:,:,nc,nf),Op_T(nc,nf)%P,In) @@ -223,7 +224,8 @@ ! N1=size(In,1) ! N2=size(In,2) do nc = 1,Ncheck - dummy = vec(nf)%at(nc) + allocate(dummy, source = vec(nf)%at(nc)) +! dummy = vec(nf)%at(nc) call dummy%lmultinv(In) ! If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then ! call ZSLHEMM('L','U',Ndim_hop,N1,N2,Exp_T_m1(:,:,nc,nf),Op_T(nc,nf)%P,In) @@ -251,7 +253,8 @@ ! N2=size(In,2) do nc = 1, Ncheck - dummy = vec(nf)%at(nc) + allocate(dummy, source = vec(nf)%at(nc)) +! dummy = vec(nf)%at(nc) call dummy%rmult(In) ! If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then ! call ZSLHEMM('R','U',Ndim_hop,N1,N2,Exp_T(:,:,nc,nf),Op_T(nc,nf)%P,In) @@ -278,7 +281,8 @@ N1=size(In,1) N2=size(In,2) do nc = 1, Ncheck - dummy = vec(nf)%at(nc) + allocate(dummy, source = vec(nf)%at(nc)) +! dummy = vec(nf)%at(nc) call dummy%lmult(In) ! If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then ! call ZSLHEMM('L','U',Ndim_hop,N1,N2,Exp_T(:,:,nc,nf),Op_T(nc,nf)%P,In) @@ -306,7 +310,8 @@ ! N2=size(In,2) do nc = Ncheck,1,-1 - dummy = vec(nf)%at(nc) + allocate(dummy, source = vec(nf)%at(nc)) +! dummy = vec(nf)%at(nc) call dummy%rmultinv(In) ! If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then ! call ZSLHEMM('R','U',Ndim_hop,N1,N2,Exp_T_m1(:,:,nc,nf),Op_T(nc,nf)%P,In) -- GitLab From 77f81e371fb1c963c03d9c148270f8d326c9b48e Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Wed, 30 Sep 2020 19:14:39 +0200 Subject: [PATCH 38/96] change classs of Neal1993 such that at least we have the title of that thing in the refs. --- Documentation/fassaad.bib | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Documentation/fassaad.bib b/Documentation/fassaad.bib index ac06a561..1d8484d8 100644 --- a/Documentation/fassaad.bib +++ b/Documentation/fassaad.bib @@ -3260,7 +3260,7 @@ Title = {Statistical Mechanics: Algorithms and Computations}, Year = {2006}} -@article{neal1993, +@book{neal1993, Author = {Neal, Radford M}, Date-Added = {2018-05-14 18:37:55 +0000}, Date-Modified = {2018-05-14 18:37:55 +0000}, -- GitLab From fbd98e5e82de69a094e5bc28a7f5af6d0a65774a Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Wed, 30 Sep 2020 19:29:19 +0200 Subject: [PATCH 39/96] typos --- Documentation/hopping.tex | 21 +++++++++++++-------- 1 file changed, 13 insertions(+), 8 deletions(-) diff --git a/Documentation/hopping.tex b/Documentation/hopping.tex index e9929e08..5889c1ce 100644 --- a/Documentation/hopping.tex +++ b/Documentation/hopping.tex @@ -11,12 +11,13 @@ \subsubsection{Setting up the hopping matrix: the \texttt{Hopping\_Matrix\_type}}\label{sec:hopping_type} %-------------------------------------------------------------------------------------------- -The module \texttt{Predefined\_Hopping} provides a generic way to specify a hopping matrix on a multi-orbital Bravais lattice. The only assumption that we make is translation symmetry. We allow for twisted boundary conditions in the $\vec{L}_1$ and $\vec{L}_2$ lattice directions. The twist is given by \texttt{Phi\_X} and \texttt{Phi\_Y} respectively. If the flag \texttt{bulk=.true.}, then the twist is implemented with a vector potential. Otherwise, if \texttt{bulk=.false.}, the twist is imposed at the boundary. The routine also accounts for the inclusion of a total number of \texttt{N\_Phi} flux quanta traversing the lattice. All phase factors mentioned above can be flavor dependent. The checkerboard decomposition can also be specified in this module. All information, including the checkerboard decomposition is specified in the \path{Hopping_Matrix_type} type (see below) from which the array of operator type \path{OP_T}, accounting for the single particle propagation in one time step, as well as the Kinetic energy can be derived. +The module \texttt{Predefined\_Hopping} provides a generic way to specify a hopping matrix on a multi-orbital Bravais lattice. The only assumption that we make is translation symmetry. We allow for twisted boundary conditions in the $\vec{L}_1$ and $\vec{L}_2$ lattice directions. The twist is given by \texttt{Phi\_X} and \texttt{Phi\_Y} respectively. If the flag \texttt{bulk=.true.}, then the twist is implemented with a vector potential. Otherwise, if \texttt{bulk=.false.}, the twist is imposed at the boundary. The routine also accounts for the inclusion of a total number of \texttt{N\_Phi} flux quanta traversing the lattice. All phase factors mentioned above can be flavor dependent. The checkerboard decomposition can also be specified in this module. +All information, including the checkerboard decomposition is specified in the \path{Hopping_Matrix_type} type (see below) from which the array of operator type \path{OP_T}, accounting for the single particle propagation in one time step, as well as the kinetic energy can be derived. \paragraph*{Generic hopping matrices}\label{sec:generic_hopping} %----------------------------------------------------------------------------------- -The generic Hopping Hamiltonian reads: +The generic hopping Hamiltonian reads: \begin{equation} \hat{H}_T = \sum_{(i,\delta), (j,\delta'), s, \sigma} T_{(i,\delta), (j,\delta')}^{(s)} \hat{c}^{\dagger}_{(i,\delta),s,\sigma } e^{\frac{2 \pi i}{\Phi_0} \int_{i + \delta}^{j + \delta'} \vec{A}^{(s)}(\vec{l}) d \vec{l}} \hat{c}^{}_{(j,\delta'),s,\sigma } \label{generic_hopping.eq} @@ -26,16 +27,17 @@ with boundary conditions \hat{c}^{\dagger}_{(i + L_i,\delta) ,s,\sigma } = e^{- 2 \pi i\frac{\Phi_i^{(s)}}{\Phi_0}} \, e^{\frac{2 \pi i }{\Phi_0} \chi^{(s)}_{L_i} ( i + \delta ) } \, \hat{c}^{\dagger}_{(i,\delta) ,s,\sigma }. \label{generic_boundary.eq} \end{equation} -Both the twist and vector potential can have a flavor dependency. For now onwards we will mostly omit the flavor index ${s}$.\\ +Both the twist and vector potential can have a flavor dependency. +From now onwards we will mostly omit the flavor index ${s}$.\\ \noindent \textbf{Phase factors}. -The vector potential accounts for an orbital magnetic field that is implemented in the Landau gauge: $\vec{A}(\vec{x}) = -B(y,0,0) $ with $ \vec{x} = (x,y,z)$. $\Phi_0$ corresponds to the flux quanta and the scalar function $\chi$ is defined through as: +The vector potential accounts for an orbital magnetic field that is implemented in the Landau gauge: $\vec{A}(\vec{x}) = -B(y,0,0) $ with $ \vec{x} = (x,y,z)$. $\Phi_0$ corresponds to the flux quanta and the scalar function $\chi$ is defined through: \begin{equation} \vec{A}( \vec{x} + \vec{L}_{i} ) = \vec{A}( \vec{x} ) + \vec{\nabla} \chi_{L_{i}}(\vec{x}). \end{equation} -Provided that the bare hopping Hamiltonian, $T$, is invariant under lattice translations, $\hat{H}_T$ commutes with magnetic translations that satisfy the Algebra: +Provided that the bare hopping Hamiltonian, $T$, is invariant under lattice translations, $\hat{H}_T$ commutes with magnetic translations that satisfy the algebra: \begin{equation} \hat{T}_{\vec{a}} \hat{T}_{\vec{b}} = e^{ \frac{2 \pi i}{\Phi_0} \vec{B} \cdot \left( \vec{a} \times \vec{b} \right) } \hat{T}_{\vec{b}} \hat{T}_{\vec{a}}. \end{equation} @@ -44,7 +46,9 @@ that \begin{equation} \frac{\vec{B} \cdot \left( \vec{a} \times \vec{b} \right) }{\Phi_0 } = N_{\Phi} \end{equation} -with $N_\Phi $ an integer. The variable \texttt{N\_Phi}, specified in the parameter file, denotes the number of flux quanta piercing the lattice. The variables \texttt{Phi\_X} and \texttt{Phi\_Y} also in the parameter file denote the twists -- in units of the flux quanta -- along the $\vec{L}_1$ and $\vec{L}_2$ directions. There are gauge equivalent ways to insert the twist in the boundary conditions. In the above we have inserted twist as a boundary condition such that for example setting \texttt{Phi\_1=0.5} corresponds to anti-periodic boundary conditions along the $L_1$ axis. Alternatively we can consider the +with $N_\Phi $ an integer. The variable \texttt{N\_Phi}, specified in the parameter file, denotes the number of flux quanta piercing the lattice. The variables \texttt{Phi\_X} and \texttt{Phi\_Y} also in the parameter file denote the twists -- in units of the flux quanta -- along the $\vec{L}_1$ and $\vec{L}_2$ directions. +There are gauge equivalent ways to insert the twist in the boundary conditions. +In the above we have inserted the twist as a boundary condition such that for example setting \texttt{Phi\_1=0.5} corresponds to anti-periodic boundary conditions along the $L_1$ axis. Alternatively we can consider the Hamiltonian: \begin{equation} \hat{H}_T = \sum_{(i,\delta), (j,\delta'), s, \sigma} T_{(i,\delta), (j,\delta')}^{(s)} \tilde{c}^{\dagger}_{(i,\delta),s,\sigma } e^{\frac{2 \pi i}{\Phi_0} \int_{i + \delta}^{j + \delta'} \left( \vec{A}(\vec{l}) + \vec{A}_{\phi} \right) d \vec{l}} \tilde{c}^{}_{(j,\delta'),s,\sigma } @@ -57,7 +61,7 @@ Here \begin{equation} \vec{A}_{\phi} =\frac{ \phi_1 |\vec{a}_1|} { 2 \pi |\vec{L}_1| } \vec{b}_1 + \frac{ \phi_2 |\vec{a}_2|}{2 \pi |\vec{L}_2| } \vec{b}_2 \end{equation} -and $\vec{b}_i$ correspond to the reciprocal lattice vectors satisfying $ \vec{a}_i \cdot \vec{b}_j = 2 \pi \delta_{i,j} $. The logical variable $\texttt{bulk} $ chooses between these two gauge equivalent ways of inserting the twist angle. If \texttt{bulk=\.true\.} then we use periodic boundary conditions -- in the absence of an orbital field -- otherwise twisted boundaries are used. +and $\vec{b}_i$ correspond to the reciprocal lattice vectors satisfying $ \vec{a}_i \cdot \vec{b}_j = 2 \pi \delta_{i,j} $. The logical variable $\texttt{bulk} $ chooses between these two gauge equivalent ways of inserting the twist angle. If \texttt{bulk=.true.} then we use periodic boundary conditions -- in the absence of an orbital field -- otherwise twisted boundaries are used. The above phase factors are computed in the module function: \begin{lstlisting}[style=fortran] complex function Generic_hopping(i,no_i, n_1, n_2, no_j, N_Phi, Phi_1,Phi_2, Bulk, @@ -125,7 +129,8 @@ There are \path{N_bonds} hopping matrix elements emanating from a give \end{center} \end{table} -The data in the \texttt{Hopping\_matrix\_type} type suffices to uniquely define the unit step propagation for the kinetic energy, and for any combinations of the \texttt{Checkerboard} and \texttt{Symm} options (see Sec.~\ref{sec:trotter}). This is carried by the call: +The data in the \texttt{Hopping\_matrix\_type} type suffices to uniquely define the unit step propagation for the kinetic energy, and for any combinations of the \texttt{Checkerboard} and \texttt{Symm} options (see Sec.~\ref{sec:trotter}). +This is carried out by the call: \begin{lstlisting}[style=fortran] Call Predefined_Hoppings_set_OPT(Hopping_Matrix, List, Invlist, Latt, Latt_unit, Dtau, Checkerboard, Symm, OP_T) -- GitLab From 6d381667456d70b6186c98d60bd00b54901444cd Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Thu, 1 Oct 2020 01:12:35 +0200 Subject: [PATCH 40/96] typos --- Documentation/interaction_vertices.tex | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/Documentation/interaction_vertices.tex b/Documentation/interaction_vertices.tex index 6baa5a0e..4379dc33 100644 --- a/Documentation/interaction_vertices.tex +++ b/Documentation/interaction_vertices.tex @@ -181,7 +181,8 @@ Another predefined vertex is: - \frac{|J_z|}{2} \left( S^{z}_i - \sgn|J_z| S^{z}_j \right)^2 = J_z S^{z}_i S^{z}_j - \frac{|J_z|}{2} (S^{z}_i)^2 - \frac{|J_z|}{2}(S^{z}_j)^2 \end{align} -which, if particle fluctuations are frozen on the $i$ and $j$ sites, then $(S^{z}_i)^2 = 1/4$ and the interactions corresponds to a $J_z$-$J_z$ ferro or antiferro coupling. +which, if particle fluctuations are frozen on the $i$ and $j$ sites, then $(S^{z}_i)^2 = 1/4$ and the interactions corresponds to a +$J_z$-$J_z$ ferromagnetic or antiferromagnetic coupling. The implementation of the interaction in \texttt{Predefined\_Int\_Jz} defines two operators: \begin{lstlisting}[style=fortran] -- GitLab From 4207cefb7f543867926841e45228c89b262c4056 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Thu, 1 Oct 2020 14:46:09 +0200 Subject: [PATCH 41/96] add some docs --- Prog/OpTTypes_mod.F90 | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/Prog/OpTTypes_mod.F90 b/Prog/OpTTypes_mod.F90 index 3677bfdd..a4a610bc 100644 --- a/Prog/OpTTypes_mod.F90 +++ b/Prog/OpTTypes_mod.F90 @@ -37,38 +37,38 @@ module OpTTypes_mod ! Encapsulates Operations for real OpTs type, extends(ContainerElementBase) :: RealOpT - Real(kind=kind(0.d0)), allocatable, dimension(:,:) :: mat, invmat + Real(kind=kind(0.d0)), allocatable, dimension(:,:) :: mat, invmat !> We store the matrix here in the class Real(kind=kind(0.d0)) :: g, Zero integer, pointer :: P(:) Integer :: m, n, Ndim_hop contains - procedure :: init => RealOpT_init - procedure :: dealloc => RealOpT_dealloc - procedure :: simt => RealOpT_simt - procedure :: rmult => RealOpT_rmult + procedure :: init => RealOpT_init ! initialize and allocate matrices + procedure :: dealloc => RealOpT_dealloc ! dealloc matrices + procedure :: simt => RealOpT_simt ! similarity transform (not implemented) + procedure :: rmult => RealOpT_rmult ! right multiplication with Op_T procedure :: lmult => RealOpT_lmult - procedure :: rmultinv => RealOpT_rmultinv + procedure :: rmultinv => RealOpT_rmultinv ! right multiplication with Op_T inverse procedure :: lmultinv => RealOpT_lmultinv - procedure :: dump => RealOpT_dump + procedure :: dump => RealOpT_dump ! dump matrices for debugging to screen end type RealOpT ! Encapsulates Operations for complex OpTs type, extends(ContainerElementBase) :: CmplxOpT - Complex(kind=kind(0.d0)),allocatable, dimension(:,:) :: mat, invmat + Complex(kind=kind(0.d0)),allocatable, dimension(:,:) :: mat, invmat !> We store the matrix here in the class Complex(kind=kind(0.d0)) :: g Real(kind=kind(0.d0)) :: Zero integer, pointer :: P(:) Integer :: m, n, Ndim_hop contains - procedure :: init => CmplxOpT_init - procedure :: dealloc => CmplxOpT_dealloc - procedure :: simt => CmplxOpT_simt - procedure :: rmult => CmplxOpT_rmult + procedure :: init => CmplxOpT_init ! initialize and allocate matrices + procedure :: dealloc => CmplxOpT_dealloc ! dealloc matrices + procedure :: simt => CmplxOpT_simt ! similarity transform (not implemented) + procedure :: rmult => CmplxOpT_rmult ! right multiplication with Op_T procedure :: lmult => CmplxOpT_lmult - procedure :: rmultinv => CmplxOpT_rmultinv + procedure :: rmultinv => CmplxOpT_rmultinv ! right multiplication with Op_T inverse procedure :: lmultinv => CmplxOpT_lmultinv - procedure :: dump => CmplxOpT_dump + procedure :: dump => CmplxOpT_dump ! dump matrices for debugging to screen end type CmplxOpT contains -- GitLab From 189944e52345a272fee26460b928d13507e0fb42 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Thu, 1 Oct 2020 14:55:27 +0200 Subject: [PATCH 42/96] formatting --- Prog/Hop_mod.F90 | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/Prog/Hop_mod.F90 b/Prog/Hop_mod.F90 index 7869a336..1faf0948 100644 --- a/Prog/Hop_mod.F90 +++ b/Prog/Hop_mod.F90 @@ -175,8 +175,8 @@ ! N2=size(In,2) do nc = Ncheck,1,-1 ! dummy = vec(nf)%at(nc) -allocate(dummy, source = vec(nf)%at(nc)) - call dummy%lmult(In) + allocate(dummy, source = vec(nf)%at(nc)) + call dummy%lmult(In) ! If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then ! call ZSLHEMM('L','U',Ndim_hop,N1,N2,Exp_T(:,:,nc,nf),Op_T(nc,nf)%P,In) ! Endif @@ -224,9 +224,9 @@ allocate(dummy, source = vec(nf)%at(nc)) ! N1=size(In,1) ! N2=size(In,2) do nc = 1,Ncheck - allocate(dummy, source = vec(nf)%at(nc)) + allocate(dummy, source = vec(nf)%at(nc)) ! dummy = vec(nf)%at(nc) - call dummy%lmultinv(In) + call dummy%lmultinv(In) ! If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then ! call ZSLHEMM('L','U',Ndim_hop,N1,N2,Exp_T_m1(:,:,nc,nf),Op_T(nc,nf)%P,In) ! Endif @@ -253,9 +253,9 @@ allocate(dummy, source = vec(nf)%at(nc)) ! N2=size(In,2) do nc = 1, Ncheck - allocate(dummy, source = vec(nf)%at(nc)) + allocate(dummy, source = vec(nf)%at(nc)) ! dummy = vec(nf)%at(nc) - call dummy%rmult(In) + call dummy%rmult(In) ! If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then ! call ZSLHEMM('R','U',Ndim_hop,N1,N2,Exp_T(:,:,nc,nf),Op_T(nc,nf)%P,In) ! Endif @@ -281,9 +281,9 @@ allocate(dummy, source = vec(nf)%at(nc)) N1=size(In,1) N2=size(In,2) do nc = 1, Ncheck - allocate(dummy, source = vec(nf)%at(nc)) + allocate(dummy, source = vec(nf)%at(nc)) ! dummy = vec(nf)%at(nc) - call dummy%lmult(In) + call dummy%lmult(In) ! If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then ! call ZSLHEMM('L','U',Ndim_hop,N1,N2,Exp_T(:,:,nc,nf),Op_T(nc,nf)%P,In) ! Endif @@ -310,9 +310,9 @@ allocate(dummy, source = vec(nf)%at(nc)) ! N2=size(In,2) do nc = Ncheck,1,-1 - allocate(dummy, source = vec(nf)%at(nc)) + allocate(dummy, source = vec(nf)%at(nc)) ! dummy = vec(nf)%at(nc) - call dummy%rmultinv(In) + call dummy%rmultinv(In) ! If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then ! call ZSLHEMM('R','U',Ndim_hop,N1,N2,Exp_T_m1(:,:,nc,nf),Op_T(nc,nf)%P,In) ! Endif -- GitLab From e9d04b70e3e39971d9d85aa67a1e93592f7b7494 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Tue, 13 Oct 2020 14:41:09 +0200 Subject: [PATCH 43/96] fix broken link --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index e6cf0b60..6b564704 100644 --- a/README.md +++ b/README.md @@ -2,7 +2,7 @@ [![pipeline status](https://git.physik.uni-wuerzburg.de/fassaad/General_QMCT_code/badges/master/pipeline.svg)](https://git.physik.uni-wuerzburg.de/fassaad/General_QMCT_code/commits/master) [![coverage report](https://git.physik.uni-wuerzburg.de/fassaad/General_QMCT_code/badges/master/coverage.svg)](https://git.physik.uni-wuerzburg.de/fassaad/General_QMCT_code/commits/master) ## General information ## -This version of the **A**lgorithms for **L**attice **F**ermions package provides a general code for the finite temperature and projective auxiliary field Quantum Monte Carlo algorithm. The code is engineered to be able simulate any model that can be written in terms of sums of single body operators, of squares of single body operators and single body operators coupled to an Ising field with given dynamics. We provide predefined types that allow the user to specify the model, the Bravais lattice as well as equal time and time displaced observables. The code supports an MPI implementation. Examples such as the Hubbard model, the SU(N) Kondo lattice model, tV models, models with long ranged interactions as well as Z2 lattice gauge theories coupled to fermions adn Z2 matter are discussed in the [documentation](https://git.physik.uni-wuerzburg.de/ALF/ALF/-/jobs/artifacts/master/raw/Documentation/doc.pdf?job=create_doc). Slides on the auxiliary field QMC can be found [here.](https://git.physik.uni-wuerzburg.de/ALF/ALF_Presentations/-/blob/master/ALF_2020_Assaad.pdf) +This version of the **A**lgorithms for **L**attice **F**ermions package provides a general code for the finite temperature and projective auxiliary field Quantum Monte Carlo algorithm. The code is engineered to be able simulate any model that can be written in terms of sums of single body operators, of squares of single body operators and single body operators coupled to an Ising field with given dynamics. We provide predefined types that allow the user to specify the model, the Bravais lattice as well as equal time and time displaced observables. The code supports an MPI implementation. Examples such as the Hubbard model, the SU(N) Kondo lattice model, tV models, models with long ranged interactions as well as Z2 lattice gauge theories coupled to fermions adn Z2 matter are discussed in the [documentation](https://git.physik.uni-wuerzburg.de/ALF/ALF/-/jobs/artifacts/master/raw/Documentation/doc.pdf?job=create_doc). Slides on the auxiliary field QMC can be found [here.](https://git.physik.uni-wuerzburg.de/ALF/ALF_Tutorial/-/blob/master/Presentations/ALF_2020_Assaad.pdf) The Hamiltonians we can consider reads: ![The Hamiltonian0](Images/Hamiltonian0.png "The Hamiltonian") -- GitLab From aeff4c68a59a43ebedc98ef83192e9f757c48b5f Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Tue, 13 Oct 2020 14:45:11 +0200 Subject: [PATCH 44/96] typo --- Documentation/Model_classes.tex | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/Documentation/Model_classes.tex b/Documentation/Model_classes.tex index d5111cd5..d1c2ffbb 100644 --- a/Documentation/Model_classes.tex +++ b/Documentation/Model_classes.tex @@ -52,7 +52,9 @@ If the variable \texttt{Mz} is set to \texttt{.True.}, then the code will req \end{align} In this case, the flavor index \texttt{N\_FL} takes the value 2. Cleary at $N=2$, both modes correspond to the Hubbard model. For $N$ even and $N > 2$ the models differ. In particular in the latter Hamiltonian the U(N) symmetry is broken down to U(N/2) $\otimes $U(N/2). -Since this model class works for all predefined lattices (see Fig.~\ref{fig_predefined_lattices}) is includes the SU(N) periodic Anderson model on the square and Honeycomb lattices. Finally, we note that the executable for this class is given by \texttt{Hubbard.out}. +Since this model class works for all predefined lattices (see Fig.~\ref{fig_predefined_lattices}) +it includes the SU(N) periodic Anderson model on the square and Honeycomb lattices. +Finally, we note that the executable for this class is given by \texttt{Hubbard.out}. As an example, we can consider the periodic Anderson model. Here we choose the \texttt{Bilayer\_square} lattice \texttt{Ham\_U} = \texttt{Ham\_T2} $= 0$, \texttt{Ham\_U2}$=U_f$, \texttt{Ham\_tperp}$=V$ and \texttt{Ham\_T}$=1$. The pyALF based python script \href{https://git.physik.uni-wuerzburg.de/ALF/pyALF/-/blob/master/Scripts/Hubbard_PAM.py}{\texttt{Hubbard\_PAM.py}} produces the data shown in Fig.~\ref{Fig:PAM} for the L=8 lattice. -- GitLab From 7f99ffbc4570aaabdf223e97a47fda6a084f3a8a Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Tue, 13 Oct 2020 14:46:17 +0200 Subject: [PATCH 45/96] remove vector symbol --- Documentation/Kondo_SUN.tex | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Documentation/Kondo_SUN.tex b/Documentation/Kondo_SUN.tex index 06449162..acde82e4 100644 --- a/Documentation/Kondo_SUN.tex +++ b/Documentation/Kondo_SUN.tex @@ -19,9 +19,9 @@ For the SU(2) case $T^{a}$ corresponds to the $T = \frac{1}{2} \ve{\sigma}$ wi + \frac{2 J}{N} \sum_{i, a=1 }^{N^2 -1} \hat{T}^{a,c}_{i} \hat{T}^{a,f}_{i}. \label{Kondo_SUN_Ham.eq} \end{equation} -In the above, $i$ is a super-index accounting for the unit cell and orbital, +In the above, $i$ is a super-index accounting for the unit cell and orbital, \begin{equation} - \hat{T}^{a,c}_{i} = \sum_{\sigma,\sigma'=1}^{N} \hat{c}^{\dagger}_{i,\sigma}T^{a}_{\sigma,\sigma'} \hat{\ve{c}}^{\phantom\dagger}_{i,\sigma'}, \; \; + \hat{T}^{a,c}_{i} = \sum_{\sigma,\sigma'=1}^{N} \hat{c}^{\dagger}_{i,\sigma}T^{a}_{\sigma,\sigma'} \hat{c}^{\phantom\dagger}_{i,\sigma'}, \; \; \hat{T}^{a,f}_{i} = \sum_{\sigma,\sigma'=1}^{N} \hat{f}^{\dagger}_{i,\sigma} T^{a}_{\sigma,\sigma'} \hat{f}^{\phantom\dagger}_{i,\sigma'}, \text{ and } \hat{n}^c_i = \sum_{\sigma=1}^{N} \hat{c}_{i,\sigma}^{\dagger} \hat{c}_{i,\sigma}^{\phantom\dagger} \end{equation} -- GitLab From ccf1c9a7d00e3bca58aeb54421495cce6bfbfb97 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Mon, 19 Oct 2020 14:04:26 +0200 Subject: [PATCH 46/96] fix backward compatibility? --- Prog/Hop_mod.F90 | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/Prog/Hop_mod.F90 b/Prog/Hop_mod.F90 index 1faf0948..c4388dda 100644 --- a/Prog/Hop_mod.F90 +++ b/Prog/Hop_mod.F90 @@ -180,6 +180,7 @@ ! If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then ! call ZSLHEMM('L','U',Ndim_hop,N1,N2,Exp_T(:,:,nc,nf),Op_T(nc,nf)%P,In) ! Endif + deallocate(dummy) Enddo end Subroutine Hop_mod_mmthr @@ -230,6 +231,7 @@ ! If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then ! call ZSLHEMM('L','U',Ndim_hop,N1,N2,Exp_T_m1(:,:,nc,nf),Op_T(nc,nf)%P,In) ! Endif + deallocate(dummy) Enddo end Subroutine Hop_mod_mmthr_m1 @@ -259,6 +261,7 @@ ! If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then ! call ZSLHEMM('R','U',Ndim_hop,N1,N2,Exp_T(:,:,nc,nf),Op_T(nc,nf)%P,In) ! Endif + deallocate(dummy) Enddo end Subroutine Hop_mod_mmthl @@ -282,11 +285,12 @@ N2=size(In,2) do nc = 1, Ncheck allocate(dummy, source = vec(nf)%at(nc)) -! dummy = vec(nf)%at(nc) + dummy = vec(nf)%at(nc) call dummy%lmult(In) ! If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then ! call ZSLHEMM('L','U',Ndim_hop,N1,N2,Exp_T(:,:,nc,nf),Op_T(nc,nf)%P,In) ! Endif + deallocate(dummy) Enddo end Subroutine Hop_mod_mmthlc @@ -316,6 +320,7 @@ ! If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then ! call ZSLHEMM('R','U',Ndim_hop,N1,N2,Exp_T_m1(:,:,nc,nf),Op_T(nc,nf)%P,In) ! Endif + deallocate(dummy) Enddo end Subroutine Hop_mod_mmthl_m1 -- GitLab From bbc3001b3de8fb1a675c86e154be3da538ea68f6 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Mon, 19 Oct 2020 14:10:08 +0200 Subject: [PATCH 47/96] bugfix... --- Prog/Hop_mod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Prog/Hop_mod.F90 b/Prog/Hop_mod.F90 index c4388dda..3fcf9b7e 100644 --- a/Prog/Hop_mod.F90 +++ b/Prog/Hop_mod.F90 @@ -285,7 +285,7 @@ N2=size(In,2) do nc = 1, Ncheck allocate(dummy, source = vec(nf)%at(nc)) - dummy = vec(nf)%at(nc) +! dummy = vec(nf)%at(nc) call dummy%lmult(In) ! If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then ! call ZSLHEMM('L','U',Ndim_hop,N1,N2,Exp_T(:,:,nc,nf),Op_T(nc,nf)%P,In) -- GitLab From 349408ffcf625da23e01fa02dd2448137608390e Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Mon, 19 Oct 2020 18:13:48 +0200 Subject: [PATCH 48/96] current state. looks like most memleaks are plugged --- Prog/DynamicMatrixArray_mod.F90 | 18 ++++++----- Prog/Hop_mod.F90 | 57 ++++++++++++++++----------------- 2 files changed, 38 insertions(+), 37 deletions(-) diff --git a/Prog/DynamicMatrixArray_mod.F90 b/Prog/DynamicMatrixArray_mod.F90 index 5874e2ab..695802f3 100644 --- a/Prog/DynamicMatrixArray_mod.F90 +++ b/Prog/DynamicMatrixArray_mod.F90 @@ -38,7 +38,7 @@ module DynamicMatrixArray_mod implicit none type :: OpTBasePtrWrapper - class(ContainerElementBase), allocatable :: dat + class(ContainerElementBase), pointer :: dat => null() end type type :: DynamicMatrixArray @@ -73,7 +73,7 @@ end subroutine !itm gets deallocated in the process subroutine DynamicMatrixArray_pushback(this, itm) class(DynamicMatrixArray) :: this - class(ContainerElementBase), intent(inout), allocatable :: itm ! Type(...) always has to match exactly, class(...) allows for polymorphism + class(ContainerElementBase), intent(in), target :: itm ! Type(...) always has to match exactly, class(...) allows for polymorphism type(OpTbasePtrWrapper), allocatable, dimension(:) :: temp integer :: i @@ -88,8 +88,8 @@ subroutine DynamicMatrixArray_pushback(this, itm) deallocate(temp) this%avamem = 2*this%avamem endif - call move_alloc(itm, this%data(this%tail)%dat) -! this%data(this%tail)%dat = itm +! call move_alloc(itm, this%data(this%tail)%dat) + this%data(this%tail)%dat => itm ! let the pointer point to the object this%tail = this%tail + 1 end subroutine @@ -107,14 +107,16 @@ end subroutine function DynamicMatrixArray_at(this, pos) result(itm) class(DynamicMatrixArray), intent(in) :: this integer, intent(in) :: pos - class(ContainerElementBase), allocatable :: itm - allocate(itm, source=this%data(pos)%dat) ! improved backwards compatibility with this construct + class(ContainerElementBase), pointer :: itm +! allocate(itm, source=this%data(pos)%dat) ! improved backwards compatibility with this construct + itm => this%data(pos)%dat end function subroutine DynamicMatrixArray_back(this, itm) class(DynamicMatrixArray), intent(in) :: this - class(ContainerElementBase), intent(out), allocatable :: itm - allocate(itm, source=this%data(this%tail-1)%dat) ! improved backwards compatibility with this construct + class(ContainerElementBase), intent(out), pointer :: itm +! allocate(itm, source=this%data(this%tail-1)%dat) ! improved backwards compatibility with this construct + itm => this%data(this%tail-1)%dat end subroutine function DynamicMatrixArray_length(this) result(l) diff --git a/Prog/Hop_mod.F90 b/Prog/Hop_mod.F90 index 3fcf9b7e..a74dcb8e 100644 --- a/Prog/Hop_mod.F90 +++ b/Prog/Hop_mod.F90 @@ -77,9 +77,8 @@ Integer :: nc, nf, i,j Complex (Kind=Kind(0.d0)) :: g - class(CmplxOpT), allocatable:: cmplxexp - class(RealOpT), allocatable:: realexp - class(ContainerElementBase), allocatable :: Dummy + class(CmplxOpT), pointer :: cmplxexp + class(RealOpT), pointer :: realexp Ncheck = size(Op_T,1) @@ -118,16 +117,15 @@ if (Op_is_real(Op_T(nc,nf))) then ! branch for real operators - allocate(realexp) + allocate(realexp) ! Yep, this is a manifest memory leak. Using the ptr we can allocate onto the same variable call realexp%init(Op_T(nc,nf)) - call Move_alloc(realexp, dummy) ! To satisfy fortran's type checking + call vec(nf)%pushback(realexp) else ! branch for complex operators allocate(cmplxexp) call cmplxexp%init(Op_T(nc,nf)) - call Move_alloc(cmplxexp, dummy) ! To satisfy fortran's type checking + call vec(nf)%pushback(cmplxexp) endif - call vec(nf)%pushback(dummy) ! g = Op_T(nc,nf)%g ! Call Op_exp(g,Op_T(nc,nf),Exp_T(:,:,nc,nf)) @@ -146,8 +144,9 @@ ! ENDDO enddo ! do i = 1, vec(nf)%length() -! dummy = vec(nf)%at(i) ! get object -! call dummy%dump() +! dummyptr => vec(nf)%at(i) ! get object +! call dummyptr%dump() +! call dummyptr%lmult(test) ! write (*,*) "==========" ! enddo enddo @@ -169,18 +168,18 @@ !Local Integer :: nc, N1, N2 - class(ContainerElementBase), allocatable :: dummy + class(ContainerElementBase), pointer :: dummy ! N1=size(In,1) ! N2=size(In,2) do nc = Ncheck,1,-1 -! dummy = vec(nf)%at(nc) - allocate(dummy, source = vec(nf)%at(nc)) + dummy => vec(nf)%at(nc) +! allocate(dummy, source = vec(nf)%at(nc)) call dummy%lmult(In) ! If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then ! call ZSLHEMM('L','U',Ndim_hop,N1,N2,Exp_T(:,:,nc,nf),Op_T(nc,nf)%P,In) ! Endif - deallocate(dummy) +! deallocate(dummy) Enddo end Subroutine Hop_mod_mmthr @@ -220,18 +219,18 @@ !Local Integer :: nc , N1, N2 - class(ContainerElementBase), allocatable :: dummy + class(ContainerElementBase), pointer :: dummy ! N1=size(In,1) ! N2=size(In,2) do nc = 1,Ncheck - allocate(dummy, source = vec(nf)%at(nc)) -! dummy = vec(nf)%at(nc) +! allocate(dummy, source = vec(nf)%at(nc)) + dummy => vec(nf)%at(nc) call dummy%lmultinv(In) ! If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then ! call ZSLHEMM('L','U',Ndim_hop,N1,N2,Exp_T_m1(:,:,nc,nf),Op_T(nc,nf)%P,In) ! Endif - deallocate(dummy) +! deallocate(dummy) Enddo end Subroutine Hop_mod_mmthr_m1 @@ -249,19 +248,19 @@ !Local Integer :: nc, N1, N2 - class(ContainerElementBase), allocatable :: dummy + class(ContainerElementBase), pointer :: dummy ! N1=size(In,1) ! N2=size(In,2) do nc = 1, Ncheck - allocate(dummy, source = vec(nf)%at(nc)) -! dummy = vec(nf)%at(nc) +! allocate(dummy, source = vec(nf)%at(nc)) + dummy => vec(nf)%at(nc) call dummy%rmult(In) ! If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then ! call ZSLHEMM('R','U',Ndim_hop,N1,N2,Exp_T(:,:,nc,nf),Op_T(nc,nf)%P,In) ! Endif - deallocate(dummy) +! deallocate(dummy) Enddo end Subroutine Hop_mod_mmthl @@ -279,18 +278,18 @@ !Local Integer :: nc, N1, N2 - class(ContainerElementBase), allocatable :: dummy + class(ContainerElementBase), pointer :: dummy N1=size(In,1) N2=size(In,2) do nc = 1, Ncheck - allocate(dummy, source = vec(nf)%at(nc)) -! dummy = vec(nf)%at(nc) +! allocate(dummy, source = vec(nf)%at(nc)) + dummy => vec(nf)%at(nc) call dummy%lmult(In) ! If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then ! call ZSLHEMM('L','U',Ndim_hop,N1,N2,Exp_T(:,:,nc,nf),Op_T(nc,nf)%P,In) ! Endif - deallocate(dummy) +! deallocate(dummy) Enddo end Subroutine Hop_mod_mmthlc @@ -308,19 +307,19 @@ !Local Integer :: nc, N1, N2 - class(ContainerElementBase), allocatable :: dummy + class(ContainerElementBase), pointer :: dummy ! N1=size(In,1) ! N2=size(In,2) do nc = Ncheck,1,-1 - allocate(dummy, source = vec(nf)%at(nc)) -! dummy = vec(nf)%at(nc) +! allocate(dummy, source = vec(nf)%at(nc)) + dummy => vec(nf)%at(nc) call dummy%rmultinv(In) ! If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then ! call ZSLHEMM('R','U',Ndim_hop,N1,N2,Exp_T_m1(:,:,nc,nf),Op_T(nc,nf)%P,In) ! Endif - deallocate(dummy) +! deallocate(dummy) Enddo end Subroutine Hop_mod_mmthl_m1 -- GitLab From 156cf731b635f3833880f2c87e9981579dcb3e73 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Mon, 19 Oct 2020 18:52:53 +0200 Subject: [PATCH 49/96] remove old comments --- Prog/DynamicMatrixArray_mod.F90 | 3 -- Prog/Hop_mod.F90 | 52 +++++---------------------------- 2 files changed, 7 insertions(+), 48 deletions(-) diff --git a/Prog/DynamicMatrixArray_mod.F90 b/Prog/DynamicMatrixArray_mod.F90 index 695802f3..575bc048 100644 --- a/Prog/DynamicMatrixArray_mod.F90 +++ b/Prog/DynamicMatrixArray_mod.F90 @@ -88,7 +88,6 @@ subroutine DynamicMatrixArray_pushback(this, itm) deallocate(temp) this%avamem = 2*this%avamem endif -! call move_alloc(itm, this%data(this%tail)%dat) this%data(this%tail)%dat => itm ! let the pointer point to the object this%tail = this%tail + 1 end subroutine @@ -108,14 +107,12 @@ function DynamicMatrixArray_at(this, pos) result(itm) class(DynamicMatrixArray), intent(in) :: this integer, intent(in) :: pos class(ContainerElementBase), pointer :: itm -! allocate(itm, source=this%data(pos)%dat) ! improved backwards compatibility with this construct itm => this%data(pos)%dat end function subroutine DynamicMatrixArray_back(this, itm) class(DynamicMatrixArray), intent(in) :: this class(ContainerElementBase), intent(out), pointer :: itm -! allocate(itm, source=this%data(this%tail-1)%dat) ! improved backwards compatibility with this construct itm => this%data(this%tail-1)%dat end subroutine diff --git a/Prog/Hop_mod.F90 b/Prog/Hop_mod.F90 index a74dcb8e..1422e995 100644 --- a/Prog/Hop_mod.F90 +++ b/Prog/Hop_mod.F90 @@ -152,7 +152,6 @@ enddo Zero = 1.E-12 -! deallocate(cmplxexp, realexp) end subroutine Hop_mod_init !-------------------------------------------------------------------- @@ -167,19 +166,12 @@ Integer, intent(IN) :: nf !Local - Integer :: nc, N1, N2 + Integer :: nc class(ContainerElementBase), pointer :: dummy -! N1=size(In,1) -! N2=size(In,2) do nc = Ncheck,1,-1 - dummy => vec(nf)%at(nc) -! allocate(dummy, source = vec(nf)%at(nc)) + dummy => vec(nf)%at(nc) call dummy%lmult(In) -! If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then -! call ZSLHEMM('L','U',Ndim_hop,N1,N2,Exp_T(:,:,nc,nf),Op_T(nc,nf)%P,In) -! Endif -! deallocate(dummy) Enddo end Subroutine Hop_mod_mmthr @@ -218,19 +210,12 @@ Integer :: nf !Local - Integer :: nc , N1, N2 + Integer :: nc class(ContainerElementBase), pointer :: dummy -! N1=size(In,1) -! N2=size(In,2) do nc = 1,Ncheck -! allocate(dummy, source = vec(nf)%at(nc)) - dummy => vec(nf)%at(nc) + dummy => vec(nf)%at(nc) call dummy%lmultinv(In) -! If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then -! call ZSLHEMM('L','U',Ndim_hop,N1,N2,Exp_T_m1(:,:,nc,nf),Op_T(nc,nf)%P,In) -! Endif -! deallocate(dummy) Enddo end Subroutine Hop_mod_mmthr_m1 @@ -247,20 +232,12 @@ Integer :: nf !Local - Integer :: nc, N1, N2 + Integer :: nc class(ContainerElementBase), pointer :: dummy -! N1=size(In,1) -! N2=size(In,2) - do nc = 1, Ncheck -! allocate(dummy, source = vec(nf)%at(nc)) dummy => vec(nf)%at(nc) call dummy%rmult(In) -! If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then -! call ZSLHEMM('R','U',Ndim_hop,N1,N2,Exp_T(:,:,nc,nf),Op_T(nc,nf)%P,In) -! Endif -! deallocate(dummy) Enddo end Subroutine Hop_mod_mmthl @@ -277,19 +254,12 @@ Integer :: nf !Local - Integer :: nc, N1, N2 + Integer :: nc class(ContainerElementBase), pointer :: dummy - N1=size(In,1) - N2=size(In,2) do nc = 1, Ncheck -! allocate(dummy, source = vec(nf)%at(nc)) dummy => vec(nf)%at(nc) call dummy%lmult(In) -! If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then -! call ZSLHEMM('L','U',Ndim_hop,N1,N2,Exp_T(:,:,nc,nf),Op_T(nc,nf)%P,In) -! Endif -! deallocate(dummy) Enddo end Subroutine Hop_mod_mmthlc @@ -306,20 +276,12 @@ Integer :: nf !Local - Integer :: nc, N1, N2 + Integer :: nc class(ContainerElementBase), pointer :: dummy -! N1=size(In,1) -! N2=size(In,2) - do nc = Ncheck,1,-1 -! allocate(dummy, source = vec(nf)%at(nc)) dummy => vec(nf)%at(nc) call dummy%rmultinv(In) -! If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then -! call ZSLHEMM('R','U',Ndim_hop,N1,N2,Exp_T_m1(:,:,nc,nf),Op_T(nc,nf)%P,In) -! Endif -! deallocate(dummy) Enddo end Subroutine Hop_mod_mmthl_m1 -- GitLab From 125eefcf92e84a773bcd320824513304bf784f40 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Mon, 19 Oct 2020 19:00:20 +0200 Subject: [PATCH 50/96] proper error messages --- Libraries/Modules/Mat_subroutines.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Libraries/Modules/Mat_subroutines.F90 b/Libraries/Modules/Mat_subroutines.F90 index e69f8c87..167877b0 100644 --- a/Libraries/Modules/Mat_subroutines.F90 +++ b/Libraries/Modules/Mat_subroutines.F90 @@ -1412,7 +1412,7 @@ subroutine ZDSLSYMM(side, uplo, N, M1, M2, A, P, Mat) END SELECT ELSE - write(error_unit,*) 'ZSLHEMM: Illegal argument for side: It is not one of [R,r,L,l] !' + write(error_unit,*) 'ZDSLSYMM: Illegal argument for side: It is not one of [R,r,L,l] !' error stop 1 ENDIF -- GitLab From 221844c708891a048a7106d569729acbe99b5be2 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Mon, 19 Oct 2020 20:14:58 +0200 Subject: [PATCH 51/96] fix Makefile --- Prog/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Prog/Makefile b/Prog/Makefile index 04388cb8..d5a41d0c 100644 --- a/Prog/Makefile +++ b/Prog/Makefile @@ -63,7 +63,7 @@ Compile: $(OBJS) .SUFFIXES: .F90 .f .f.o .F90.o: - $(ALF_FC) -c -o $@ $(ALF_FLAGS_PROG) -O0 -g $< + $(ALF_FC) -c -o $@ $(ALF_FLAGS_PROG) $< tidy: rm -f $(OBJS) $(MODS) $(OHAM) -- GitLab From a49b69b2f415b9f7b56755d934bce3335e5a474e Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Mon, 26 Oct 2020 18:20:35 +0100 Subject: [PATCH 52/96] prepare an adjointaction function for use in the symm() functions --- Prog/ContainerElementBase_mod.F90 | 16 ++++++++-------- Prog/OpTTypes_mod.F90 | 12 ++++++------ 2 files changed, 14 insertions(+), 14 deletions(-) diff --git a/Prog/ContainerElementBase_mod.F90 b/Prog/ContainerElementBase_mod.F90 index 1fceaa53..0fa708a3 100644 --- a/Prog/ContainerElementBase_mod.F90 +++ b/Prog/ContainerElementBase_mod.F90 @@ -37,22 +37,16 @@ module ContainerElementBase_mod ! Base for defining the interface type, abstract :: ContainerElementBase contains - procedure(simtinterface), deferred :: simt procedure(rmultinterface), deferred :: rmult procedure(lmultinterface), deferred :: lmult procedure(rmultinvinterface), deferred :: rmultinv procedure(lmultinvinterface), deferred :: lmultinv + procedure(adjointactioninterface), deferred :: adjointaction procedure(dump), deferred :: dump procedure(dealloc), deferred :: dealloc end type ContainerElementBase abstract interface - subroutine simtinterface(this, arg) - import ContainerElementBase - class(ContainerElementBase), intent(in) :: this - Complex(kind=kind(0.d0)), intent(inout), allocatable, dimension(:,:) :: arg - end subroutine - subroutine rmultinterface(this, arg) import ContainerElementBase class(ContainerElementBase), intent(in) :: this @@ -82,9 +76,15 @@ module ContainerElementBase_mod class(ContainerElementBase), intent(in) :: this end subroutine - subroutine dealloc(this) + subroutine dealloc(this) import ContainerElementBase class(ContainerElementBase), intent(inout) :: this end subroutine + + subroutine adjointactioninterface(this, arg) + import ContainerElementBase + class(ContainerElementBase), intent(in) :: this + Complex(kind=kind(0.d0)), intent(inout), allocatable, dimension(:,:) :: arg + end subroutine end interface end module ContainerElementBase_mod diff --git a/Prog/OpTTypes_mod.F90 b/Prog/OpTTypes_mod.F90 index a4a610bc..8089a49f 100644 --- a/Prog/OpTTypes_mod.F90 +++ b/Prog/OpTTypes_mod.F90 @@ -37,7 +37,7 @@ module OpTTypes_mod ! Encapsulates Operations for real OpTs type, extends(ContainerElementBase) :: RealOpT - Real(kind=kind(0.d0)), allocatable, dimension(:,:) :: mat, invmat !> We store the matrix here in the class + Real(kind=kind(0.d0)), allocatable, dimension(:,:) :: mat, invmat, mat_1D2 !> We store the matrix here in the class Real(kind=kind(0.d0)) :: g, Zero integer, pointer :: P(:) Integer :: m, n, Ndim_hop @@ -45,17 +45,17 @@ module OpTTypes_mod contains procedure :: init => RealOpT_init ! initialize and allocate matrices procedure :: dealloc => RealOpT_dealloc ! dealloc matrices - procedure :: simt => RealOpT_simt ! similarity transform (not implemented) procedure :: rmult => RealOpT_rmult ! right multiplication with Op_T procedure :: lmult => RealOpT_lmult procedure :: rmultinv => RealOpT_rmultinv ! right multiplication with Op_T inverse procedure :: lmultinv => RealOpT_lmultinv + procedure :: adjointaction => RealOpT_adjointaction procedure :: dump => RealOpT_dump ! dump matrices for debugging to screen end type RealOpT ! Encapsulates Operations for complex OpTs type, extends(ContainerElementBase) :: CmplxOpT - Complex(kind=kind(0.d0)),allocatable, dimension(:,:) :: mat, invmat !> We store the matrix here in the class + Complex(kind=kind(0.d0)),allocatable, dimension(:,:) :: mat, invmat, mat_1D2 !> We store the matrix here in the class Complex(kind=kind(0.d0)) :: g Real(kind=kind(0.d0)) :: Zero integer, pointer :: P(:) @@ -63,11 +63,11 @@ module OpTTypes_mod contains procedure :: init => CmplxOpT_init ! initialize and allocate matrices procedure :: dealloc => CmplxOpT_dealloc ! dealloc matrices - procedure :: simt => CmplxOpT_simt ! similarity transform (not implemented) procedure :: rmult => CmplxOpT_rmult ! right multiplication with Op_T procedure :: lmult => CmplxOpT_lmult procedure :: rmultinv => CmplxOpT_rmultinv ! right multiplication with Op_T inverse procedure :: lmultinv => CmplxOpT_lmultinv + procedure :: adjointaction => CmplxOpT_adjointaction procedure :: dump => CmplxOpT_dump ! dump matrices for debugging to screen end type CmplxOpT @@ -102,7 +102,7 @@ contains deallocate(cmat, cinvmat) end subroutine - subroutine RealOpT_simt(this, arg) + subroutine RealOpT_adjointaction(this, arg) class(RealOpT), intent(in) :: this Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: temp @@ -184,7 +184,7 @@ contains end subroutine - subroutine CmplxOpT_simt(this, arg) + subroutine CmplxOpT_adjointaction(this, arg) class(CmplxOpT), intent(in) :: this Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg end subroutine -- GitLab From 5b243d078f01bc3ab31116c3e2a432c7394fdc6a Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Mon, 26 Oct 2020 18:41:48 +0100 Subject: [PATCH 53/96] implement the functions --- Prog/OpTTypes_mod.F90 | 36 +++++++++++++++++++++++++++++++----- 1 file changed, 31 insertions(+), 5 deletions(-) diff --git a/Prog/OpTTypes_mod.F90 b/Prog/OpTTypes_mod.F90 index 8089a49f..ca6f40d0 100644 --- a/Prog/OpTTypes_mod.F90 +++ b/Prog/OpTTypes_mod.F90 @@ -37,7 +37,7 @@ module OpTTypes_mod ! Encapsulates Operations for real OpTs type, extends(ContainerElementBase) :: RealOpT - Real(kind=kind(0.d0)), allocatable, dimension(:,:) :: mat, invmat, mat_1D2 !> We store the matrix here in the class + Real(kind=kind(0.d0)), allocatable, dimension(:,:) :: mat, invmat, mat_1D2, invmat_1D2 !> We store the matrix here in the class Real(kind=kind(0.d0)) :: g, Zero integer, pointer :: P(:) Integer :: m, n, Ndim_hop @@ -55,7 +55,7 @@ module OpTTypes_mod ! Encapsulates Operations for complex OpTs type, extends(ContainerElementBase) :: CmplxOpT - Complex(kind=kind(0.d0)),allocatable, dimension(:,:) :: mat, invmat, mat_1D2 !> We store the matrix here in the class + Complex(kind=kind(0.d0)),allocatable, dimension(:,:) :: mat, invmat, mat_1D2, invmat_1D2 !> We store the matrix here in the class Complex(kind=kind(0.d0)) :: g Real(kind=kind(0.d0)) :: Zero integer, pointer :: P(:) @@ -81,9 +81,9 @@ contains this%Zero = 1.E-12 this%Ndim_hop = Op_T%N - cg = -Op_T%g allocate (this%mat(this%Ndim_hop, this%Ndim_hop), this%invmat(this%Ndim_hop, this%Ndim_hop), cmat(this%Ndim_hop, this%Ndim_hop), cinvmat(this%Ndim_hop, this%Ndim_hop)) + cg = -Op_T%g Call Op_exp(cg, Op_T, cinvmat) cg = Op_T%g Call Op_exp(cg, Op_T, cmat) @@ -91,10 +91,21 @@ contains this%mat = DBLE(cmat) this%invmat = DBLE(cinvmat) + cg = -Op_T%g/2.0 + Call Op_exp(cg, Op_T, cinvmat) + cg = Op_T%g/2.0 + Call Op_exp(cg, Op_T, cmat) + ! copy over the data to the real storage + this%mat_1D2 = DBLE(cmat) + this%invmat_1D2 = DBLE(cinvmat) + DO i = 1, this%Ndim_hop DO j = i, this%Ndim_hop this%mat(i, j) = (this%mat(i, j) + this%mat(j, i))/2.D0 this%invmat(i, j) = (this%invmat(i, j) + this%invmat(j, i))/2.D0 + + this%mat_1D2(i, j) = (this%mat_1D2(i, j) + this%mat_1D2(j, i))/2.D0 + this%invmat_1D2(i, j) = (this%invmat_1D2(i, j) + this%invmat_1D2(j, i))/2.D0 ENDDO ENDDO this%P => Op_T%P @@ -105,8 +116,14 @@ contains subroutine RealOpT_adjointaction(this, arg) class(RealOpT), intent(in) :: this Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg - Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: temp - + Integer :: n1, n2 + + n1 = size(arg,1) + n2 = size(arg,2) + If ( dble(this%g*conjg(this%g)) > this%Zero ) then + call ZDSLSYMM('L', 'U', this%Ndim_hop, n1, n2, this%mat_1D2, this%P, arg) + call ZDSLSYMM('R', 'U', this%Ndim_hop, n1, n2, this%invmat_1D2, this%P, arg) + Endif end subroutine subroutine RealOpT_rmult(this, arg) @@ -187,6 +204,15 @@ contains subroutine CmplxOpT_adjointaction(this, arg) class(CmplxOpT), intent(in) :: this Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + Integer :: n1, n2 + + n1 = size(arg,1) + n2 = size(arg,2) + If ( dble(this%g*conjg(this%g)) > this%Zero ) then + call ZSLHEMM('L', 'U', this%Ndim_hop, n1, n2, this%mat_1D2, this%P, arg) + call ZSLHEMM('R', 'U', this%Ndim_hop, n1, n2, this%invmat_1D2, this%P, arg) + Endif + end subroutine subroutine CmplxOpT_rmult(this, arg) -- GitLab From 1c432ed4854d850c63a675a70e70b935891af880 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Mon, 26 Oct 2020 19:09:55 +0100 Subject: [PATCH 54/96] fix compilation --- Prog/ContainerElementBase_mod.F90 | 2 +- Prog/Hop_mod.F90 | 121 ++++++++++++++++-------------- Prog/OpTTypes_mod.F90 | 6 +- 3 files changed, 67 insertions(+), 62 deletions(-) diff --git a/Prog/ContainerElementBase_mod.F90 b/Prog/ContainerElementBase_mod.F90 index 0fa708a3..af642fc9 100644 --- a/Prog/ContainerElementBase_mod.F90 +++ b/Prog/ContainerElementBase_mod.F90 @@ -84,7 +84,7 @@ module ContainerElementBase_mod subroutine adjointactioninterface(this, arg) import ContainerElementBase class(ContainerElementBase), intent(in) :: this - Complex(kind=kind(0.d0)), intent(inout), allocatable, dimension(:,:) :: arg + Complex(kind=kind(0.d0)), intent(inout), dimension(:,:) :: arg end subroutine end interface end module ContainerElementBase_mod diff --git a/Prog/Hop_mod.F90 b/Prog/Hop_mod.F90 index 1422e995..98fd0498 100644 --- a/Prog/Hop_mod.F90 +++ b/Prog/Hop_mod.F90 @@ -55,8 +55,8 @@ ! Private variables Type(DynamicMatrixArray), private, allocatable :: vec(:) ! for now we have for simplicity for each flavour a vector - Complex (Kind=Kind(0.d0)), allocatable, private :: Exp_T(:,:,:,:), Exp_T_M1(:,:,:,:) - Complex (Kind=Kind(0.d0)), allocatable, private :: Exp_T_1D2(:,:,:,:), Exp_T_M1_1D2(:,:,:,:) +! Complex (Kind=Kind(0.d0)), allocatable, private :: Exp_T(:,:,:,:), Exp_T_M1(:,:,:,:) +! Complex (Kind=Kind(0.d0)), allocatable, private :: Exp_T_1D2(:,:,:,:), Exp_T_M1_1D2(:,:,:,:) Complex (Kind=Kind(0.d0)), allocatable, private :: U_HLP(:,:), U_HLP1(:,:), V_HLP(:,:), V_HLP1(:,:) Integer, private, save :: Ncheck, Ndim_hop Real (Kind=Kind(0.d0)), private, save :: Zero @@ -97,10 +97,10 @@ enddo enddo - Allocate ( Exp_T (Ndim_hop,Ndim_hop,Ncheck,N_FL) ) - Allocate ( Exp_T_M1 (Ndim_hop,Ndim_hop,Ncheck,N_FL) ) - Allocate ( Exp_T_1D2 (Ndim_hop,Ndim_hop,Ncheck,N_FL) ) - Allocate ( Exp_T_M1_1D2(Ndim_hop,Ndim_hop,Ncheck,N_FL) ) +! Allocate ( Exp_T (Ndim_hop,Ndim_hop,Ncheck,N_FL) ) +! Allocate ( Exp_T_M1 (Ndim_hop,Ndim_hop,Ncheck,N_FL) ) +! Allocate ( Exp_T_1D2 (Ndim_hop,Ndim_hop,Ncheck,N_FL) ) +! Allocate ( Exp_T_M1_1D2(Ndim_hop,Ndim_hop,Ncheck,N_FL) ) allocate(vec(N_FL)) @@ -109,8 +109,8 @@ Allocate ( U_Hlp (Ndim, Ndim_hop) ) Allocate ( U_Hlp1(Ndim, Ndim_hop) ) - Exp_T = cmplx(0.d0, 0.d0, kind(0.D0)) - Exp_T_M1 = cmplx(0.d0, 0.d0, kind(0.D0)) +! Exp_T = cmplx(0.d0, 0.d0, kind(0.D0)) +! Exp_T_M1 = cmplx(0.d0, 0.d0, kind(0.D0)) do nf = 1,N_FL call vec(nf)%init() do nc = 1,Ncheck @@ -131,10 +131,10 @@ ! Call Op_exp(g,Op_T(nc,nf),Exp_T(:,:,nc,nf)) ! g = -Op_T(nc,nf)%g ! Call Op_exp(g,Op_T(nc,nf),Exp_T_M1(:,:,nc,nf)) - g = Op_T(nc,nf)%g/2.d0 - Call Op_exp(g,Op_T(nc,nf),Exp_T_1D2(:,:,nc,nf)) - g = -Op_T(nc,nf)%g/2.d0 - Call Op_exp(g,Op_T(nc,nf),Exp_T_M1_1D2(:,:,nc,nf)) +! g = Op_T(nc,nf)%g/2.d0 +! Call Op_exp(g,Op_T(nc,nf),Exp_T_1D2(:,:,nc,nf)) +! g = -Op_T(nc,nf)%g/2.d0 +! Call Op_exp(g,Op_T(nc,nf),Exp_T_M1_1D2(:,:,nc,nf)) ! symmetrize the upper part of Exp_T and Exp_T_M1 ! DO i = 1, Ndim_hop ! DO j = i, Ndim_hop @@ -176,27 +176,27 @@ end Subroutine Hop_mod_mmthr !-------------------------------------------------------------------- - Subroutine Hop_mod_mmthr_1D2(In,nf) - - - ! InOut: In = e^{ -dtau T /2 }.IN - Implicit none - - Complex (Kind=Kind(0.d0)), intent(INOUT) :: IN(:,:) - Integer, intent(IN) :: nf - - !Local - Integer :: nc, N1, N2 - - N1=size(In,1) - N2=size(In,2) - - do nc = Ncheck,1,-1 - If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then - call ZSLHEMM('L','U',Ndim_hop,N1,N2,Exp_T_1D2(:,:,nc,nf),Op_T(nc,nf)%P,In) - Endif - Enddo - end Subroutine Hop_mod_mmthr_1D2 +! Subroutine Hop_mod_mmthr_1D2(In,nf) +! +! +! ! InOut: In = e^{ -dtau T /2 }.IN +! Implicit none +! +! Complex (Kind=Kind(0.d0)), intent(INOUT) :: IN(:,:) +! Integer, intent(IN) :: nf +! +! !Local +! Integer :: nc, N1, N2 +! +! N1=size(In,1) +! N2=size(In,2) +! +! do nc = Ncheck,1,-1 +! If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then +! call ZSLHEMM('L','U',Ndim_hop,N1,N2,Exp_T_1D2(:,:,nc,nf),Op_T(nc,nf)%P,In) +! Endif +! Enddo +! end Subroutine Hop_mod_mmthr_1D2 !-------------------------------------------------------------------- @@ -289,28 +289,28 @@ !-------------------------------------------------------------------- - Subroutine Hop_mod_mmthl_m1_1D2(In, nf) - - - ! InOut: In = IN * e^{ dtau T/2 } - Implicit none - - Complex (Kind=Kind(0.d0)), intent(INOUT) :: IN(:,:) - Integer :: nf - - !Local - Integer :: nc, N1, N2 - - N1=size(In,1) - N2=size(In,2) - - do nc = Ncheck,1,-1 - If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then - call ZSLHEMM('R','U',Ndim_hop,N1,N2,Exp_T_m1_1D2(:,:,nc,nf),Op_T(nc,nf)%P,In) - Endif - Enddo - - end Subroutine Hop_mod_mmthl_m1_1D2 +! Subroutine Hop_mod_mmthl_m1_1D2(In, nf) +! +! +! ! InOut: In = IN * e^{ dtau T/2 } +! Implicit none +! +! Complex (Kind=Kind(0.d0)), intent(INOUT) :: IN(:,:) +! Integer :: nf +! +! !Local +! Integer :: nc, N1, N2 +! +! N1=size(In,1) +! N2=size(In,2) +! +! do nc = Ncheck,1,-1 +! If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then +! call ZSLHEMM('R','U',Ndim_hop,N1,N2,Exp_T_m1_1D2(:,:,nc,nf),Op_T(nc,nf)%P,In) +! Endif +! Enddo +! +! end Subroutine Hop_mod_mmthl_m1_1D2 !!$ Subroutine Hop_mod_test @@ -346,12 +346,17 @@ COMPLEX (Kind=Kind(0.d0)), Dimension(:,:,:), Intent(Out):: Out COMPLEX (Kind=Kind(0.d0)), Dimension(:,:,:), Intent(IN):: In - Integer :: nf + Integer :: nf, nc + class(ContainerElementBase), pointer :: dummy Out = In Do nf = 1, size(In,3) - Call Hop_mod_mmthr_1D2 (Out(:,:,nf), nf ) - Call Hop_mod_mmthl_m1_1D2(Out(:,:,nf), nf ) + do nc = Ncheck,1,-1 + dummy => vec(nf)%at(nc) + call dummy%adjointaction(Out(:, :, nf)) +! Call Hop_mod_mmthr_1D2 (Out(:,:,nf), nf ) +! Call Hop_mod_mmthl_m1_1D2(Out(:,:,nf), nf ) + enddo enddo End Subroutine Hop_mod_Symm diff --git a/Prog/OpTTypes_mod.F90 b/Prog/OpTTypes_mod.F90 index ca6f40d0..63a2133d 100644 --- a/Prog/OpTTypes_mod.F90 +++ b/Prog/OpTTypes_mod.F90 @@ -115,12 +115,12 @@ contains subroutine RealOpT_adjointaction(this, arg) class(RealOpT), intent(in) :: this - Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + Complex(kind=kind(0.D0)), intent(inout), dimension(:,:) :: arg Integer :: n1, n2 n1 = size(arg,1) n2 = size(arg,2) - If ( dble(this%g*conjg(this%g)) > this%Zero ) then + If ( this%g*this%g > this%Zero ) then call ZDSLSYMM('L', 'U', this%Ndim_hop, n1, n2, this%mat_1D2, this%P, arg) call ZDSLSYMM('R', 'U', this%Ndim_hop, n1, n2, this%invmat_1D2, this%P, arg) Endif @@ -203,7 +203,7 @@ contains subroutine CmplxOpT_adjointaction(this, arg) class(CmplxOpT), intent(in) :: this - Complex(kind=kind(0.D0)), intent(inout), allocatable, dimension(:,:) :: arg + Complex(kind=kind(0.D0)), intent(inout), dimension(:,:) :: arg Integer :: n1, n2 n1 = size(arg,1) -- GitLab From 423fab317d45d454cb4e5f9b6b06e8f383cc7c96 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Mon, 26 Oct 2020 20:34:20 +0100 Subject: [PATCH 55/96] remaining fixes and delete old comments --- Prog/Hop_mod.F90 | 132 +++++++++++------------------------------- Prog/OpTTypes_mod.F90 | 50 +++++++++++----- 2 files changed, 72 insertions(+), 110 deletions(-) diff --git a/Prog/Hop_mod.F90 b/Prog/Hop_mod.F90 index 98fd0498..d1c0162f 100644 --- a/Prog/Hop_mod.F90 +++ b/Prog/Hop_mod.F90 @@ -55,13 +55,45 @@ ! Private variables Type(DynamicMatrixArray), private, allocatable :: vec(:) ! for now we have for simplicity for each flavour a vector -! Complex (Kind=Kind(0.d0)), allocatable, private :: Exp_T(:,:,:,:), Exp_T_M1(:,:,:,:) -! Complex (Kind=Kind(0.d0)), allocatable, private :: Exp_T_1D2(:,:,:,:), Exp_T_M1_1D2(:,:,:,:) Complex (Kind=Kind(0.d0)), allocatable, private :: U_HLP(:,:), U_HLP1(:,:), V_HLP(:,:), V_HLP1(:,:) Integer, private, save :: Ncheck, Ndim_hop Real (Kind=Kind(0.d0)), private, save :: Zero Contains + +!-------------------------------------------------------------------- +!> @author +!> ALF-project +! +!> @brief +!> This function serves as a central entry point to collect all +!> post-processing. +! +!-------------------------------------------------------------------- + subroutine OpT_postprocess(vec, op) + use Operator_mod + implicit none + + Type(DynamicMatrixArray), intent(inout) :: vec + Type(Operator), intent(in) :: op + + class(CmplxOpT), pointer :: cmplxexp + class(RealOpT), pointer :: realexp + + if (Op_is_real(op)) then + ! branch for real operators + allocate(realexp) ! Yep, this is a manifest memory leak. Using the ptr we can allocate onto the same variable + call realexp%init(op) + call vec%pushback(realexp) + else + ! branch for complex operators + allocate(cmplxexp) + call cmplxexp%init(op) + call vec%pushback(cmplxexp) + endif + end subroutine + + !-------------------------------------------------------------------- !> @author !> ALF-project @@ -96,11 +128,6 @@ endif enddo enddo - -! Allocate ( Exp_T (Ndim_hop,Ndim_hop,Ncheck,N_FL) ) -! Allocate ( Exp_T_M1 (Ndim_hop,Ndim_hop,Ncheck,N_FL) ) -! Allocate ( Exp_T_1D2 (Ndim_hop,Ndim_hop,Ncheck,N_FL) ) -! Allocate ( Exp_T_M1_1D2(Ndim_hop,Ndim_hop,Ncheck,N_FL) ) allocate(vec(N_FL)) @@ -109,46 +136,11 @@ Allocate ( U_Hlp (Ndim, Ndim_hop) ) Allocate ( U_Hlp1(Ndim, Ndim_hop) ) -! Exp_T = cmplx(0.d0, 0.d0, kind(0.D0)) -! Exp_T_M1 = cmplx(0.d0, 0.d0, kind(0.D0)) do nf = 1,N_FL call vec(nf)%init() do nc = 1,Ncheck - - if (Op_is_real(Op_T(nc,nf))) then - ! branch for real operators - allocate(realexp) ! Yep, this is a manifest memory leak. Using the ptr we can allocate onto the same variable - call realexp%init(Op_T(nc,nf)) - call vec(nf)%pushback(realexp) - else - ! branch for complex operators - allocate(cmplxexp) - call cmplxexp%init(Op_T(nc,nf)) - call vec(nf)%pushback(cmplxexp) - endif - -! g = Op_T(nc,nf)%g -! Call Op_exp(g,Op_T(nc,nf),Exp_T(:,:,nc,nf)) -! g = -Op_T(nc,nf)%g -! Call Op_exp(g,Op_T(nc,nf),Exp_T_M1(:,:,nc,nf)) -! g = Op_T(nc,nf)%g/2.d0 -! Call Op_exp(g,Op_T(nc,nf),Exp_T_1D2(:,:,nc,nf)) -! g = -Op_T(nc,nf)%g/2.d0 -! Call Op_exp(g,Op_T(nc,nf),Exp_T_M1_1D2(:,:,nc,nf)) - ! symmetrize the upper part of Exp_T and Exp_T_M1 -! DO i = 1, Ndim_hop -! DO j = i, Ndim_hop -! Exp_T(i, j, nc, nf) = (Exp_T(i, j, nc, nf) + Conjg(Exp_T(j, i, nc, nf)))/2.D0 -! Exp_T_M1(i, j, nc, nf) = (Exp_T_M1(i, j, nc, nf) + Conjg(Exp_T_M1(j, i, nc, nf)))/2.D0 -! ENDDO -! ENDDO + call OpT_postprocess(vec(nf), Op_T(nc, nf)) enddo -! do i = 1, vec(nf)%length() -! dummyptr => vec(nf)%at(i) ! get object -! call dummyptr%dump() -! call dummyptr%lmult(test) -! write (*,*) "==========" -! enddo enddo Zero = 1.E-12 @@ -175,31 +167,6 @@ Enddo end Subroutine Hop_mod_mmthr -!-------------------------------------------------------------------- -! Subroutine Hop_mod_mmthr_1D2(In,nf) -! -! -! ! InOut: In = e^{ -dtau T /2 }.IN -! Implicit none -! -! Complex (Kind=Kind(0.d0)), intent(INOUT) :: IN(:,:) -! Integer, intent(IN) :: nf -! -! !Local -! Integer :: nc, N1, N2 -! -! N1=size(In,1) -! N2=size(In,2) -! -! do nc = Ncheck,1,-1 -! If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then -! call ZSLHEMM('L','U',Ndim_hop,N1,N2,Exp_T_1D2(:,:,nc,nf),Op_T(nc,nf)%P,In) -! Endif -! Enddo -! end Subroutine Hop_mod_mmthr_1D2 - -!-------------------------------------------------------------------- - Subroutine Hop_mod_mmthr_m1(In,nf) @@ -286,33 +253,6 @@ end Subroutine Hop_mod_mmthl_m1 - -!-------------------------------------------------------------------- - -! Subroutine Hop_mod_mmthl_m1_1D2(In, nf) -! -! -! ! InOut: In = IN * e^{ dtau T/2 } -! Implicit none -! -! Complex (Kind=Kind(0.d0)), intent(INOUT) :: IN(:,:) -! Integer :: nf -! -! !Local -! Integer :: nc, N1, N2 -! -! N1=size(In,1) -! N2=size(In,2) -! -! do nc = Ncheck,1,-1 -! If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then -! call ZSLHEMM('R','U',Ndim_hop,N1,N2,Exp_T_m1_1D2(:,:,nc,nf),Op_T(nc,nf)%P,In) -! Endif -! Enddo -! -! end Subroutine Hop_mod_mmthl_m1_1D2 - - !!$ Subroutine Hop_mod_test !!$ !!$ Implicit none @@ -354,8 +294,6 @@ do nc = Ncheck,1,-1 dummy => vec(nf)%at(nc) call dummy%adjointaction(Out(:, :, nf)) -! Call Hop_mod_mmthr_1D2 (Out(:,:,nf), nf ) -! Call Hop_mod_mmthl_m1_1D2(Out(:,:,nf), nf ) enddo enddo diff --git a/Prog/OpTTypes_mod.F90 b/Prog/OpTTypes_mod.F90 index 63a2133d..93cdc2cd 100644 --- a/Prog/OpTTypes_mod.F90 +++ b/Prog/OpTTypes_mod.F90 @@ -35,7 +35,13 @@ module OpTTypes_mod use Operator_mod implicit none - ! Encapsulates Operations for real OpTs + !-------------------------------------------------------------------- + !> @author + !> ALF-project + !> @brief + !> Encapsulates Operations for real OpTs + !> + !-------------------------------------------------------------------- type, extends(ContainerElementBase) :: RealOpT Real(kind=kind(0.d0)), allocatable, dimension(:,:) :: mat, invmat, mat_1D2, invmat_1D2 !> We store the matrix here in the class Real(kind=kind(0.d0)) :: g, Zero @@ -53,7 +59,13 @@ module OpTTypes_mod procedure :: dump => RealOpT_dump ! dump matrices for debugging to screen end type RealOpT - ! Encapsulates Operations for complex OpTs + !-------------------------------------------------------------------- + !> @author + !> ALF-project + !> @brief + !> Encapsulates Operations for Complex OpTs + !> + !-------------------------------------------------------------------- type, extends(ContainerElementBase) :: CmplxOpT Complex(kind=kind(0.d0)),allocatable, dimension(:,:) :: mat, invmat, mat_1D2, invmat_1D2 !> We store the matrix here in the class Complex(kind=kind(0.d0)) :: g @@ -81,7 +93,9 @@ contains this%Zero = 1.E-12 this%Ndim_hop = Op_T%N - allocate (this%mat(this%Ndim_hop, this%Ndim_hop), this%invmat(this%Ndim_hop, this%Ndim_hop), cmat(this%Ndim_hop, this%Ndim_hop), cinvmat(this%Ndim_hop, this%Ndim_hop)) + allocate(this%mat(this%Ndim_hop, this%Ndim_hop), this%invmat(this%Ndim_hop, this%Ndim_hop)) + allocate(this%mat_1D2(this%Ndim_hop, this%Ndim_hop), this%invmat_1D2(this%Ndim_hop, this%Ndim_hop)) + allocate(cmat(this%Ndim_hop, this%Ndim_hop), cinvmat(this%Ndim_hop, this%Ndim_hop)) cg = -Op_T%g Call Op_exp(cg, Op_T, cinvmat) @@ -184,17 +198,27 @@ contains this%Zero = 1.E-12 this%Ndim_hop = Op_T%N + + allocate(this%mat(this%Ndim_hop, this%Ndim_hop), this%invmat(this%Ndim_hop, this%Ndim_hop)) + allocate(this%mat_1D2(this%Ndim_hop, this%Ndim_hop), this%invmat_1D2(this%Ndim_hop, this%Ndim_hop)) + + this%g = -Op_T%g/2.0 + Call Op_exp(this%g, Op_T, this%invmat_1D2) + this%g = Op_T%g/2.0 + Call Op_exp(this%g, Op_T, this%mat_1D2) + this%g = -Op_T%g -! if (allocated(this%mat) .and. allocated(this%invmat) ) then - allocate (this%mat(this%Ndim_hop, this%Ndim_hop), this%invmat(this%Ndim_hop, this%Ndim_hop)) -! endif Call Op_exp(this%g, Op_T, this%invmat) this%g = Op_T%g - Call Op_exp(this%g, Op_T, this%mat ) + Call Op_exp(this%g, Op_T, this%mat) + DO i = 1, this%Ndim_hop DO j = i, this%Ndim_hop this%mat(i, j) = (this%mat(i, j) + Conjg(this%mat(j, i)))/2.D0 this%invmat(i, j) = (this%invmat(i, j) + Conjg(this%invmat(j, i)))/2.D0 + + this%mat_1D2(i, j) = (this%mat_1D2(i, j) + Conjg(this%mat_1D2(j, i)))/2.D0 + this%invmat_1D2(i, j) = (this%invmat_1D2(i, j) + Conjg(this%invmat_1D2(j, i)))/2.D0 ENDDO ENDDO this%P => Op_T%P @@ -270,11 +294,11 @@ contains integer :: i,j do i = 1, size(this%mat, 1) - write (*,*) (dble(this%mat(i,j)), j = 1,size(this%mat,2) ) + write (*,*) (dble(this%mat(i,j)), j = 1,size(this%mat,2) ) enddo write (*,*) "---------------" do i = 1, size(this%mat, 1) - write (*,*) (dble(this%invmat(i,j)), j = 1,size(this%mat,2) ) + write (*,*) (dble(this%invmat(i,j)), j = 1,size(this%mat,2) ) enddo end subroutine @@ -283,24 +307,24 @@ contains integer :: i,j do i = 1, size(this%mat, 1) - write (*,*) (dble(this%mat(i,j)), j = 1,size(this%mat,2) ) + write (*,*) (dble(this%mat(i,j)), j = 1,size(this%mat,2) ) enddo write (*,*) "---------------" do i = 1, size(this%mat, 1) - write (*,*) (dble(this%invmat(i,j)), j = 1,size(this%mat,2) ) + write (*,*) (dble(this%invmat(i,j)), j = 1,size(this%mat,2) ) enddo end subroutine subroutine CmplxOpT_dealloc(this) class(CmplxOpT), intent(inout) :: this - deallocate(this%mat, this%invmat) + deallocate(this%mat, this%invmat, this%mat_1D2, this%invmat_1D2) end subroutine subroutine RealOpT_dealloc(this) class(RealOpT), intent(inout) :: this - deallocate(this%mat, this%invmat) + deallocate(this%mat, this%invmat, this%mat_1D2, this%invmat_1D2) end subroutine end module OpTTypes_mod -- GitLab From f27784243694b90cd85eea5384321d1cac7d3ac8 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Mon, 2 Nov 2020 11:34:14 +0100 Subject: [PATCH 56/96] surrent try --- Prog/OpTTypes_mod.F90 | 33 +++++++++++++++++++++++++++++++-- 1 file changed, 31 insertions(+), 2 deletions(-) diff --git a/Prog/OpTTypes_mod.F90 b/Prog/OpTTypes_mod.F90 index 93cdc2cd..4a20bc40 100644 --- a/Prog/OpTTypes_mod.F90 +++ b/Prog/OpTTypes_mod.F90 @@ -228,13 +228,42 @@ contains subroutine CmplxOpT_adjointaction(this, arg) class(CmplxOpT), intent(in) :: this Complex(kind=kind(0.D0)), intent(inout), dimension(:,:) :: arg - Integer :: n1, n2 + Integer :: n1, n2, t + + Integer :: info, lwork + Integer, allocatable, dimension(:) :: ipiv + Complex(kind=kind(0.D0)), allocatable, dimension(:) :: work2 + Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: work n1 = size(arg,1) n2 = size(arg,2) If ( dble(this%g*conjg(this%g)) > this%Zero ) then - call ZSLHEMM('L', 'U', this%Ndim_hop, n1, n2, this%mat_1D2, this%P, arg) + ! this%Ndim_hop + ! n1 : arg = n1 x n2 matrix + ! n2 : + ! mat and invmat: ndimhop x ndimhop matrices + + ! subroutine ZSLHEMM(side, uplo, N, M1, M2, A, P, Mat) + ! NUMBLOCKS = 1 + ! IDXLIST(1) = 1 + ! DIMLIST(1) = 1 + + ALLOCATE (WORK(this%Ndim_hop, n2)) + t = 1 + CALL ZLACPY('A', t, n2, arg(this%P(1), 1), n1, work(1,1), this%Ndim_hop ) + ! mat * work = X <=> mat * X = work + ! call zhemm('L', 'U', ndimhop, n2, alpha, mat_1D2(1,1), ndimhop, work(1, 1), ndimhop, beta, arg(P(1,1), n1)) + ! deallocate (work) + + ! the following should be equivalent. + allocate (ipiv(n1), work2(this%Ndim_hop*8) ) + call zhesv('U', this%Ndim_hop, n2, this%invmat_1D2(1,1), this%Ndim_hop, ipiv, work(1,1), this%Ndim_hop, work2, lwork, info) + call zlacpy('A', t, n2, work(1,1), this%Ndim_hop, arg(this%P(1), 1), n1) + + +! call ZSLHEMM('L', 'U', this%Ndim_hop, n1, n2, this%mat_1D2, this%P, arg) call ZSLHEMM('R', 'U', this%Ndim_hop, n1, n2, this%invmat_1D2, this%P, arg) + deallocate(work, work2, ipiv) Endif end subroutine -- GitLab From 12bca5653b4c4fb352dc7915b7a81c8b2f83097d Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Mon, 2 Nov 2020 11:48:43 +0100 Subject: [PATCH 57/96] comment out current work --- Prog/OpTTypes_mod.F90 | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/Prog/OpTTypes_mod.F90 b/Prog/OpTTypes_mod.F90 index 4a20bc40..11df17c3 100644 --- a/Prog/OpTTypes_mod.F90 +++ b/Prog/OpTTypes_mod.F90 @@ -230,10 +230,10 @@ contains Complex(kind=kind(0.D0)), intent(inout), dimension(:,:) :: arg Integer :: n1, n2, t - Integer :: info, lwork - Integer, allocatable, dimension(:) :: ipiv - Complex(kind=kind(0.D0)), allocatable, dimension(:) :: work2 - Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: work +! Integer :: info, lwork +! Integer, allocatable, dimension(:) :: ipiv +! Complex(kind=kind(0.D0)), allocatable, dimension(:) :: work2 +! Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: work n1 = size(arg,1) n2 = size(arg,2) @@ -248,22 +248,22 @@ contains ! IDXLIST(1) = 1 ! DIMLIST(1) = 1 - ALLOCATE (WORK(this%Ndim_hop, n2)) - t = 1 - CALL ZLACPY('A', t, n2, arg(this%P(1), 1), n1, work(1,1), this%Ndim_hop ) + !! ALLOCATE (WORK(this%Ndim_hop, n2)) + !! t = 1 + !! CALL ZLACPY('A', t, n2, arg(this%P(1), 1), n1, work(1,1), this%Ndim_hop ) ! mat * work = X <=> mat * X = work ! call zhemm('L', 'U', ndimhop, n2, alpha, mat_1D2(1,1), ndimhop, work(1, 1), ndimhop, beta, arg(P(1,1), n1)) ! deallocate (work) ! the following should be equivalent. - allocate (ipiv(n1), work2(this%Ndim_hop*8) ) - call zhesv('U', this%Ndim_hop, n2, this%invmat_1D2(1,1), this%Ndim_hop, ipiv, work(1,1), this%Ndim_hop, work2, lwork, info) - call zlacpy('A', t, n2, work(1,1), this%Ndim_hop, arg(this%P(1), 1), n1) + !! allocate (ipiv(n1), work2(this%Ndim_hop*8) ) + !! call zhesv('U', this%Ndim_hop, n2, this%invmat_1D2(1,1), this%Ndim_hop, ipiv, work(1,1), this%Ndim_hop, work2, lwork, info) + !! call zlacpy('A', t, n2, work(1,1), this%Ndim_hop, arg(this%P(1), 1), n1) -! call ZSLHEMM('L', 'U', this%Ndim_hop, n1, n2, this%mat_1D2, this%P, arg) + call ZSLHEMM('L', 'U', this%Ndim_hop, n1, n2, this%mat_1D2, this%P, arg) call ZSLHEMM('R', 'U', this%Ndim_hop, n1, n2, this%invmat_1D2, this%P, arg) - deallocate(work, work2, ipiv) +! deallocate(work, work2, ipiv) Endif end subroutine -- GitLab From 83e83f0022c8044c9c5d9d79ba1439c981d5466e Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Mon, 2 Nov 2020 20:29:03 +0100 Subject: [PATCH 58/96] remove debug things --- Prog/OpTTypes_mod.F90 | 39 +++++---------------------------------- 1 file changed, 5 insertions(+), 34 deletions(-) diff --git a/Prog/OpTTypes_mod.F90 b/Prog/OpTTypes_mod.F90 index 11df17c3..68463ee1 100644 --- a/Prog/OpTTypes_mod.F90 +++ b/Prog/OpTTypes_mod.F90 @@ -63,7 +63,7 @@ module OpTTypes_mod !> @author !> ALF-project !> @brief - !> Encapsulates Operations for Complex OpTs + !> Encapsulates Operations for complex OpTs !> !-------------------------------------------------------------------- type, extends(ContainerElementBase) :: CmplxOpT @@ -228,42 +228,13 @@ contains subroutine CmplxOpT_adjointaction(this, arg) class(CmplxOpT), intent(in) :: this Complex(kind=kind(0.D0)), intent(inout), dimension(:,:) :: arg - Integer :: n1, n2, t - -! Integer :: info, lwork -! Integer, allocatable, dimension(:) :: ipiv -! Complex(kind=kind(0.D0)), allocatable, dimension(:) :: work2 -! Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: work - + Integer :: n1, n2 + n1 = size(arg,1) n2 = size(arg,2) - If ( dble(this%g*conjg(this%g)) > this%Zero ) then - ! this%Ndim_hop - ! n1 : arg = n1 x n2 matrix - ! n2 : - ! mat and invmat: ndimhop x ndimhop matrices - - ! subroutine ZSLHEMM(side, uplo, N, M1, M2, A, P, Mat) - ! NUMBLOCKS = 1 - ! IDXLIST(1) = 1 - ! DIMLIST(1) = 1 - - !! ALLOCATE (WORK(this%Ndim_hop, n2)) - !! t = 1 - !! CALL ZLACPY('A', t, n2, arg(this%P(1), 1), n1, work(1,1), this%Ndim_hop ) - ! mat * work = X <=> mat * X = work - ! call zhemm('L', 'U', ndimhop, n2, alpha, mat_1D2(1,1), ndimhop, work(1, 1), ndimhop, beta, arg(P(1,1), n1)) - ! deallocate (work) - - ! the following should be equivalent. - !! allocate (ipiv(n1), work2(this%Ndim_hop*8) ) - !! call zhesv('U', this%Ndim_hop, n2, this%invmat_1D2(1,1), this%Ndim_hop, ipiv, work(1,1), this%Ndim_hop, work2, lwork, info) - !! call zlacpy('A', t, n2, work(1,1), this%Ndim_hop, arg(this%P(1), 1), n1) - - - call ZSLHEMM('L', 'U', this%Ndim_hop, n1, n2, this%mat_1D2, this%P, arg) + If ( dble(this%g*conjg(this%g)) > this%Zero ) then + call ZSLHEMM('L', 'U', this%Ndim_hop, n1, n2, this%mat_1D2, this%P, arg) call ZSLHEMM('R', 'U', this%Ndim_hop, n1, n2, this%invmat_1D2, this%P, arg) -! deallocate(work, work2, ipiv) Endif end subroutine -- GitLab From 01f67dd8901615a6400b2d347948641f64326d2d Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Mon, 2 Nov 2020 20:37:04 +0100 Subject: [PATCH 59/96] some generic docs --- Prog/ContainerElementBase_mod.F90 | 53 ++++++++++++++++++++++++++++--- 1 file changed, 49 insertions(+), 4 deletions(-) diff --git a/Prog/ContainerElementBase_mod.F90 b/Prog/ContainerElementBase_mod.F90 index af642fc9..3099ee5a 100644 --- a/Prog/ContainerElementBase_mod.F90 +++ b/Prog/ContainerElementBase_mod.F90 @@ -47,40 +47,85 @@ module ContainerElementBase_mod end type ContainerElementBase abstract interface + + + !-------------------------------------------------------------------- + !> @brief + !> multiplies this with arg from the right. + ! + !> @param[in] this + !-------------------------------------------------------------------- subroutine rmultinterface(this, arg) import ContainerElementBase class(ContainerElementBase), intent(in) :: this Complex(kind=kind(0.d0)), intent(inout), dimension(:,:) :: arg end subroutine - + + !-------------------------------------------------------------------- + !> @brief + !> multiplies this with arg from the left. + ! + !> @param[in] this + !-------------------------------------------------------------------- subroutine lmultinterface(this, arg) import ContainerElementBase class(ContainerElementBase), intent(in) :: this Complex(kind=kind(0.d0)), intent(inout), dimension(:,:) :: arg end subroutine - + + !-------------------------------------------------------------------- + !> @brief + !> multiplies this^-1 with arg from the right. + ! + !> @param[in] this + !-------------------------------------------------------------------- subroutine rmultinvinterface(this, arg) import ContainerElementBase class(ContainerElementBase), intent(in) :: this Complex(kind=kind(0.d0)), intent(inout), dimension(:,:) :: arg end subroutine - + + !-------------------------------------------------------------------- + !> @brief + !> multiplies this^-1 with arg from the left. + ! + !> @param[in] this + !-------------------------------------------------------------------- subroutine lmultinvinterface(this, arg) import ContainerElementBase class(ContainerElementBase), intent(in) :: this Complex(kind=kind(0.d0)), intent(inout), dimension(:,:) :: arg end subroutine - + + !-------------------------------------------------------------------- + !> @brief + !> This dumps the content to the screen. + ! + !> @param[in] this + !-------------------------------------------------------------------- subroutine dump(this) import ContainerElementBase class(ContainerElementBase), intent(in) :: this end subroutine + !-------------------------------------------------------------------- + !> @brief + !> Free the used memory + ! + !> @param[in] this + !-------------------------------------------------------------------- subroutine dealloc(this) import ContainerElementBase class(ContainerElementBase), intent(inout) :: this end subroutine + !-------------------------------------------------------------------- + !> @brief + !> Perform the similarity transform e^{-T/2} arg e^{T/2} + ! + !> @param[in] this + !> @param[inout] the matrix that we intend to transform. + !-------------------------------------------------------------------- subroutine adjointactioninterface(this, arg) import ContainerElementBase class(ContainerElementBase), intent(in) :: this -- GitLab From 9d3afb445c61ea786eb7b586bca51052afa0ddf2 Mon Sep 17 00:00:00 2001 From: Jonas Schwab Date: Fri, 20 Nov 2020 00:19:03 +0100 Subject: [PATCH 60/96] Fix module names in Prog/Makefile --- Prog/Makefile | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/Prog/Makefile b/Prog/Makefile index d5a41d0c..36d8aad0 100644 --- a/Prog/Makefile +++ b/Prog/Makefile @@ -7,7 +7,8 @@ OBJS= Hamiltonians/LRC_mod.o Set_random.o control_mod.o Fields_mod.o Operator_m MODS= control.mod fields_mod.mod global_mod.mod hop_mod.mod lrc_mod.mod observables.mod \ operator_mod.mod predefined_int.mod predefined_lattices.mod predefined_obs.mod \ predefined_hoppings.mod predefined_trial.mod qdrp_mod.mod tau_m_mod.mod tau_p_mod.mod \ - udv_state_mod.mod udv_wrap_mod.mod wavefunction_mod.mod wrapgr_mod.mod hamiltonian.mod ContainerElementBase_mod.mod OpTTypes_mod.mod + udv_state_mod.mod udv_wrap_mod.mod wavefunction_mod.mod wrapgr_mod.mod hamiltonian.mod \ + containerelementbase_mod.mod opttypes_mod.mod dynamicmatrixarray_mod.mod OHAM= Hamiltonians/Hamiltonian_Z2_Matter_mod.o \ Hamiltonians/Hamiltonian_Kondo_mod.o \ Hamiltonians/Hamiltonian_Hubbard_mod.o \ -- GitLab From adca83b6474e9bd1c620417333973cdb025c04ab Mon Sep 17 00:00:00 2001 From: Jonas Schwab Date: Sun, 22 Nov 2020 00:18:04 +0100 Subject: [PATCH 61/96] Minor indentation formatting --- Prog/Hop_mod.F90 | 2 +- Prog/Operator_mod.F90 | 30 +++++++++++++++--------------- 2 files changed, 16 insertions(+), 16 deletions(-) diff --git a/Prog/Hop_mod.F90 b/Prog/Hop_mod.F90 index d1c0162f..49d44f27 100644 --- a/Prog/Hop_mod.F90 +++ b/Prog/Hop_mod.F90 @@ -203,7 +203,7 @@ class(ContainerElementBase), pointer :: dummy do nc = 1, Ncheck - dummy => vec(nf)%at(nc) + dummy => vec(nf)%at(nc) call dummy%rmult(In) Enddo diff --git a/Prog/Operator_mod.F90 b/Prog/Operator_mod.F90 index ec4a9bd5..7e730697 100644 --- a/Prog/Operator_mod.F90 +++ b/Prog/Operator_mod.F90 @@ -714,21 +714,21 @@ Contains end Subroutine Op_Wrapdo function Op_is_real(Op) result(retval) - Implicit None - - Type (Operator) , INTENT(IN) :: Op - Logical ::retval - Real (Kind=Kind(0.d0)) :: myzero - integer :: i,j - - retval = (Abs(aimag(Op%g)) < Abs(Op%g)*epsilon(1.D0)) - ! calculate a matrix scale - myzero = maxval(abs(Op%E))*epsilon(Op%E) - - do i = 1, Op%N - do j = 1, Op%N - retval = retval .and. (Abs(aimag(Op%O(i,j))) < myzero) + Implicit None + + Type (Operator) , INTENT(IN) :: Op + Logical ::retval + Real (Kind=Kind(0.d0)) :: myzero + integer :: i,j + + retval = (Abs(aimag(Op%g)) < Abs(Op%g)*epsilon(1.D0)) + ! calculate a matrix scale + myzero = maxval(abs(Op%E))*epsilon(Op%E) + + do i = 1, Op%N + do j = 1, Op%N + retval = retval .and. (Abs(aimag(Op%O(i,j))) < myzero) + enddo enddo - enddo end function Op_is_real end Module Operator_mod -- GitLab From d96ef6f5e97e14f2ef60cac40bc545743e98f2d2 Mon Sep 17 00:00:00 2001 From: Jonas Schwab Date: Sun, 22 Nov 2020 01:22:10 +0100 Subject: [PATCH 62/96] Make all contents of modules ContainerElementBase_mod and ContainerElementBase_mod private, except for type definitions ContainerElementBase, RealMat, CmplxMat --- Prog/ContainerElementBase_mod.F90 | 3 +++ Prog/matTypes_mod.F90 | 3 +++ 2 files changed, 6 insertions(+) diff --git a/Prog/ContainerElementBase_mod.F90 b/Prog/ContainerElementBase_mod.F90 index 3099ee5a..decd5b21 100644 --- a/Prog/ContainerElementBase_mod.F90 +++ b/Prog/ContainerElementBase_mod.F90 @@ -34,6 +34,9 @@ module ContainerElementBase_mod implicit none + private + public :: ContainerElementBase + ! Base for defining the interface type, abstract :: ContainerElementBase contains diff --git a/Prog/matTypes_mod.F90 b/Prog/matTypes_mod.F90 index 7c5ad0e9..3c1ae70e 100644 --- a/Prog/matTypes_mod.F90 +++ b/Prog/matTypes_mod.F90 @@ -34,6 +34,9 @@ module matTypes_mod use ContainerElementBase_mod implicit none + private + public :: RealMat, CmplxMat + type, extends(ContainerElementBase) :: RealMat Real(kind=kind(0.d0)), allocatable, dimension(:,:) :: mat Integer :: m, n -- GitLab From 4c6ac3827a718f6e5182b7c4a1249660df2b5388 Mon Sep 17 00:00:00 2001 From: Jonas Schwab Date: Sun, 22 Nov 2020 02:00:37 +0100 Subject: [PATCH 63/96] Make all elements in ContainerElementBase_mod private, except for type definition DynamicMatrixArray --- Prog/DynamicMatrixArray_mod.F90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/Prog/DynamicMatrixArray_mod.F90 b/Prog/DynamicMatrixArray_mod.F90 index 575bc048..e831772b 100644 --- a/Prog/DynamicMatrixArray_mod.F90 +++ b/Prog/DynamicMatrixArray_mod.F90 @@ -37,6 +37,9 @@ module DynamicMatrixArray_mod Use ContainerElementBase_mod implicit none + private + public :: DynamicMatrixArray + type :: OpTBasePtrWrapper class(ContainerElementBase), pointer :: dat => null() end type -- GitLab From 819c9ff681088e13c1996f0a8e684c40d3a19fcf Mon Sep 17 00:00:00 2001 From: Jonas Schwab Date: Sun, 22 Nov 2020 21:43:07 +0100 Subject: [PATCH 64/96] Make all elements in OpTTypes_mod private, except for type definitions RealOpT, CmplxOpT --- Prog/OpTTypes_mod.F90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/Prog/OpTTypes_mod.F90 b/Prog/OpTTypes_mod.F90 index 68463ee1..efe741b4 100644 --- a/Prog/OpTTypes_mod.F90 +++ b/Prog/OpTTypes_mod.F90 @@ -34,6 +34,9 @@ module OpTTypes_mod use ContainerElementBase_mod use Operator_mod implicit none + + private + public :: RealOpT, CmplxOpT !-------------------------------------------------------------------- !> @author -- GitLab From 1243a1bcd5ec0725879008adb6d961b91066c639 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Tue, 24 Nov 2020 01:37:19 +0100 Subject: [PATCH 65/96] rename derived classes. --- Prog/Hop_mod.F90 | 7 +-- Prog/OpTTypes_mod.F90 | 122 +++++++++++++++++++++--------------------- 2 files changed, 63 insertions(+), 66 deletions(-) diff --git a/Prog/Hop_mod.F90 b/Prog/Hop_mod.F90 index 49d44f27..7d48c5f3 100644 --- a/Prog/Hop_mod.F90 +++ b/Prog/Hop_mod.F90 @@ -77,8 +77,8 @@ Type(DynamicMatrixArray), intent(inout) :: vec Type(Operator), intent(in) :: op - class(CmplxOpT), pointer :: cmplxexp - class(RealOpT), pointer :: realexp + class(CmplxExpOpT), pointer :: cmplxexp + class(RealExpOpT), pointer :: realexp if (Op_is_real(op)) then ! branch for real operators @@ -109,9 +109,6 @@ Integer :: nc, nf, i,j Complex (Kind=Kind(0.d0)) :: g - class(CmplxOpT), pointer :: cmplxexp - class(RealOpT), pointer :: realexp - Ncheck = size(Op_T,1) If ( size(Op_T,2) /= N_FL ) then diff --git a/Prog/OpTTypes_mod.F90 b/Prog/OpTTypes_mod.F90 index efe741b4..d93b7268 100644 --- a/Prog/OpTTypes_mod.F90 +++ b/Prog/OpTTypes_mod.F90 @@ -36,61 +36,61 @@ module OpTTypes_mod implicit none private - public :: RealOpT, CmplxOpT + public :: RealExpOpT, CmplxExpOpT !-------------------------------------------------------------------- !> @author !> ALF-project !> @brief - !> Encapsulates Operations for real OpTs + !> Encapsulates operations for real OpTs. !> !-------------------------------------------------------------------- - type, extends(ContainerElementBase) :: RealOpT + type, extends(ContainerElementBase) :: RealExpOpT Real(kind=kind(0.d0)), allocatable, dimension(:,:) :: mat, invmat, mat_1D2, invmat_1D2 !> We store the matrix here in the class Real(kind=kind(0.d0)) :: g, Zero integer, pointer :: P(:) Integer :: m, n, Ndim_hop contains - procedure :: init => RealOpT_init ! initialize and allocate matrices - procedure :: dealloc => RealOpT_dealloc ! dealloc matrices - procedure :: rmult => RealOpT_rmult ! right multiplication with Op_T - procedure :: lmult => RealOpT_lmult - procedure :: rmultinv => RealOpT_rmultinv ! right multiplication with Op_T inverse - procedure :: lmultinv => RealOpT_lmultinv - procedure :: adjointaction => RealOpT_adjointaction - procedure :: dump => RealOpT_dump ! dump matrices for debugging to screen - end type RealOpT + procedure :: init => RealExpOpT_init ! initialize and allocate matrices + procedure :: dealloc => RealExpOpT_dealloc ! dealloc matrices + procedure :: rmult => RealExpOpT_rmult ! right multiplication with Op_T + procedure :: lmult => RealExpOpT_lmult + procedure :: rmultinv => RealExpOpT_rmultinv ! right multiplication with Op_T inverse + procedure :: lmultinv => RealExpOpT_lmultinv + procedure :: adjointaction => RealExpOpT_adjointaction + procedure :: dump => RealExpOpT_dump ! dump matrices for debugging to screen + end type RealExpOpT !-------------------------------------------------------------------- !> @author !> ALF-project !> @brief - !> Encapsulates Operations for complex OpTs + !> Encapsulates operations for complex OpTs. !> !-------------------------------------------------------------------- - type, extends(ContainerElementBase) :: CmplxOpT - Complex(kind=kind(0.d0)),allocatable, dimension(:,:) :: mat, invmat, mat_1D2, invmat_1D2 !> We store the matrix here in the class + type, extends(ContainerElementBase) :: CmplxExpOpT + Complex(kind=kind(0.d0)), allocatable, dimension(:,:) :: mat, invmat, mat_1D2, invmat_1D2 !> We store the matrix here in the class Complex(kind=kind(0.d0)) :: g Real(kind=kind(0.d0)) :: Zero integer, pointer :: P(:) Integer :: m, n, Ndim_hop contains - procedure :: init => CmplxOpT_init ! initialize and allocate matrices - procedure :: dealloc => CmplxOpT_dealloc ! dealloc matrices - procedure :: rmult => CmplxOpT_rmult ! right multiplication with Op_T - procedure :: lmult => CmplxOpT_lmult - procedure :: rmultinv => CmplxOpT_rmultinv ! right multiplication with Op_T inverse - procedure :: lmultinv => CmplxOpT_lmultinv - procedure :: adjointaction => CmplxOpT_adjointaction - procedure :: dump => CmplxOpT_dump ! dump matrices for debugging to screen - end type CmplxOpT + procedure :: init => CmplxExpOpT_init ! initialize and allocate matrices + procedure :: dealloc => CmplxExpOpT_dealloc ! dealloc matrices + procedure :: rmult => CmplxExpOpT_rmult ! right multiplication with Op_T + procedure :: lmult => CmplxExpOpT_lmult + procedure :: rmultinv => CmplxExpOpT_rmultinv ! right multiplication with Op_T inverse + procedure :: lmultinv => CmplxExpOpT_lmultinv + procedure :: adjointaction => CmplxExpOpT_adjointaction + procedure :: dump => CmplxExpOpT_dump ! dump matrices for debugging to screen + end type CmplxExpOpT contains - subroutine RealOpT_init(this, Op_T) - class(RealOpT) :: this + subroutine RealExpOpT_init(this, Op_T) + class(RealExpOpT) :: this Type(Operator), intent(in) :: Op_T - Complex(kind=kind(0.d0)),allocatable, dimension(:,:) :: cmat, cinvmat + Complex(kind=kind(0.d0)), allocatable, dimension(:,:) :: cmat, cinvmat Complex(kind=kind(0.d0)) :: cg Integer :: i, j @@ -101,17 +101,17 @@ contains allocate(cmat(this%Ndim_hop, this%Ndim_hop), cinvmat(this%Ndim_hop, this%Ndim_hop)) cg = -Op_T%g - Call Op_exp(cg, Op_T, cinvmat) + Call Op_exp(cg, Op_T, cinvmat) cg = Op_T%g - Call Op_exp(cg, Op_T, cmat) + Call Op_exp(cg, Op_T, cmat) ! copy over the data to the real storage this%mat = DBLE(cmat) this%invmat = DBLE(cinvmat) cg = -Op_T%g/2.0 - Call Op_exp(cg, Op_T, cinvmat) + Call Op_exp(cg, Op_T, cinvmat) cg = Op_T%g/2.0 - Call Op_exp(cg, Op_T, cmat) + Call Op_exp(cg, Op_T, cmat) ! copy over the data to the real storage this%mat_1D2 = DBLE(cmat) this%invmat_1D2 = DBLE(cinvmat) @@ -130,8 +130,8 @@ contains deallocate(cmat, cinvmat) end subroutine - subroutine RealOpT_adjointaction(this, arg) - class(RealOpT), intent(in) :: this + subroutine RealExpOpT_adjointaction(this, arg) + class(RealExpOpT), intent(in) :: this Complex(kind=kind(0.D0)), intent(inout), dimension(:,:) :: arg Integer :: n1, n2 @@ -143,8 +143,8 @@ contains Endif end subroutine - subroutine RealOpT_rmult(this, arg) - class(RealOpT), intent(in) :: this + subroutine RealExpOpT_rmult(this, arg) + class(RealExpOpT), intent(in) :: this Complex(kind=kind(0.D0)), intent(inout), dimension(:,:) :: arg Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: out Real(kind=kind(0.D0)), allocatable, dimension(:) :: rwork @@ -157,8 +157,8 @@ contains Endif end subroutine - subroutine RealOpT_rmultinv(this, arg) - class(RealOpT), intent(in) :: this + subroutine RealExpOpT_rmultinv(this, arg) + class(RealExpOpT), intent(in) :: this Complex(kind=kind(0.D0)), intent(inout), dimension(:,:) :: arg Integer :: n1, n2 @@ -169,8 +169,8 @@ contains Endif end subroutine - subroutine RealOpT_lmult(this, arg) - class(RealOpT), intent(in) :: this + subroutine RealExpOpT_lmult(this, arg) + class(RealExpOpT), intent(in) :: this Complex(kind=kind(0.D0)), intent(inout), dimension(:,:) :: arg integer :: n1, n2 @@ -182,8 +182,8 @@ contains Endif end subroutine - subroutine RealOpT_lmultinv(this, arg) - class(RealOpT), intent(in) :: this + subroutine RealExpOpT_lmultinv(this, arg) + class(RealExpOpT), intent(in) :: this Complex(kind=kind(0.D0)), intent(inout), dimension(:,:) :: arg integer :: n1, n2 @@ -194,8 +194,8 @@ contains Endif end subroutine - subroutine CmplxOpT_init(this, Op_T) - class(CmplxOpT) :: this + subroutine CmplxExpOpT_init(this, Op_T) + class(CmplxExpOpT) :: this Type(Operator), intent(in) :: Op_T Integer :: i, j @@ -228,8 +228,8 @@ contains end subroutine - subroutine CmplxOpT_adjointaction(this, arg) - class(CmplxOpT), intent(in) :: this + subroutine CmplxExpOpT_adjointaction(this, arg) + class(CmplxExpOpT), intent(in) :: this Complex(kind=kind(0.D0)), intent(inout), dimension(:,:) :: arg Integer :: n1, n2 @@ -242,8 +242,8 @@ contains end subroutine - subroutine CmplxOpT_rmult(this, arg) - class(CmplxOpT), intent(in) :: this + subroutine CmplxExpOpT_rmult(this, arg) + class(CmplxExpOpT), intent(in) :: this Complex(kind=kind(0.D0)), intent(inout), dimension(:,:) :: arg Integer :: n1, n2 @@ -255,8 +255,8 @@ contains Endif end subroutine - subroutine CmplxOpT_rmultinv(this, arg) - class(CmplxOpT), intent(in) :: this + subroutine CmplxExpOpT_rmultinv(this, arg) + class(CmplxExpOpT), intent(in) :: this Complex(kind=kind(0.D0)), intent(inout), dimension(:,:) :: arg Integer :: n1, n2 @@ -268,8 +268,8 @@ contains Endif end subroutine - subroutine CmplxOpT_lmult(this, arg) - class(CmplxOpT), intent(in) :: this + subroutine CmplxExpOpT_lmult(this, arg) + class(CmplxExpOpT), intent(in) :: this Complex(kind=kind(0.D0)), intent(inout), dimension(:,:) :: arg integer :: n1, n2 @@ -281,8 +281,8 @@ contains Endif end subroutine - subroutine CmplxOpT_lmultinv(this, arg) - class(CmplxOpT), intent(in) :: this + subroutine CmplxExpOpT_lmultinv(this, arg) + class(CmplxExpOpT), intent(in) :: this Complex(kind=kind(0.D0)), intent(inout), dimension(:,:) :: arg integer :: n1, n2 n1 = size(arg,1) @@ -292,8 +292,8 @@ contains Endif end subroutine - subroutine CmplxOpT_dump(this) - class(CmplxOpT), intent(in) :: this + subroutine CmplxExpOpT_dump(this) + class(CmplxExpOpT), intent(in) :: this integer :: i,j do i = 1, size(this%mat, 1) @@ -305,8 +305,8 @@ contains enddo end subroutine - subroutine RealOpT_dump(this) - class(RealOpT), intent(in) :: this + subroutine RealExpOpT_dump(this) + class(RealExpOpT), intent(in) :: this integer :: i,j do i = 1, size(this%mat, 1) @@ -318,14 +318,14 @@ contains enddo end subroutine - subroutine CmplxOpT_dealloc(this) - class(CmplxOpT), intent(inout) :: this + subroutine CmplxExpOpT_dealloc(this) + class(CmplxExpOpT), intent(inout) :: this deallocate(this%mat, this%invmat, this%mat_1D2, this%invmat_1D2) end subroutine - subroutine RealOpT_dealloc(this) - class(RealOpT), intent(inout) :: this + subroutine RealExpOpT_dealloc(this) + class(RealExpOpT), intent(inout) :: this deallocate(this%mat, this%invmat, this%mat_1D2, this%invmat_1D2) end subroutine -- GitLab From 1b952a02c7f883acfb91f00ebbd9f1ca1e1ae8ae Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Tue, 24 Nov 2020 01:40:48 +0100 Subject: [PATCH 66/96] cleanup --- Prog/OpTTypes_mod.F90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/Prog/OpTTypes_mod.F90 b/Prog/OpTTypes_mod.F90 index d93b7268..9fda734f 100644 --- a/Prog/OpTTypes_mod.F90 +++ b/Prog/OpTTypes_mod.F90 @@ -146,8 +146,6 @@ contains subroutine RealExpOpT_rmult(this, arg) class(RealExpOpT), intent(in) :: this Complex(kind=kind(0.D0)), intent(inout), dimension(:,:) :: arg - Complex(kind=kind(0.D0)), allocatable, dimension(:,:) :: out - Real(kind=kind(0.D0)), allocatable, dimension(:) :: rwork Integer :: n1, n2 n1 = size(arg,1) -- GitLab From c5fbd44f1d648b49c4226ad5dfc7718aa23401e9 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Tue, 24 Nov 2020 01:53:52 +0100 Subject: [PATCH 67/96] attempt docs. --- Prog/Hop_mod.F90 | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/Prog/Hop_mod.F90 b/Prog/Hop_mod.F90 index 7d48c5f3..a3533acf 100644 --- a/Prog/Hop_mod.F90 +++ b/Prog/Hop_mod.F90 @@ -66,8 +66,12 @@ !> ALF-project ! !> @brief -!> This function serves as a central entry point to collect all -!> post-processing. +!> This function serves as a central entry point to collect the +!> processing that occurs in mapping an OpT input matrix to internal +!> matrix-like data structure. +! +!> @param vec[inout] a DynamicMatrixArray structure to which we append new elements. +!> @param op[in] an Operator that describes an OpT hopping matrix. ! !-------------------------------------------------------------------- subroutine OpT_postprocess(vec, op) -- GitLab From 8d4ddd277f42bbcf0c3030d97c3343cc8d3ad3d0 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Tue, 24 Nov 2020 03:08:18 +0100 Subject: [PATCH 68/96] use the error stop. --- Libraries/Modules/Mat_subroutines.F90 | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/Libraries/Modules/Mat_subroutines.F90 b/Libraries/Modules/Mat_subroutines.F90 index 167877b0..177051ad 100644 --- a/Libraries/Modules/Mat_subroutines.F90 +++ b/Libraries/Modules/Mat_subroutines.F90 @@ -960,7 +960,7 @@ end subroutine ZSLHEMM subroutine ZDSLSYMM(side, uplo, N, M1, M2, A, P, Mat) -! Small Large symmetric matrix multiplication +! Mixed Complex-Real Small Large symmetric matrix multiplication !-------------------------------------------------------------------- !> @author @@ -982,8 +982,6 @@ subroutine ZDSLSYMM(side, uplo, N, M1, M2, A, P, Mat) !-------------------------------------------------------------------- use iso_fortran_env, only: output_unit, error_unit -!FIXME: UPLO is in the general cases ignored! (sufficient for the current use in Hop_mod) - IMPLICIT NONE CHARACTER (1) , INTENT(IN) :: side, uplo INTEGER , INTENT(IN) :: N, M1, M2 @@ -1005,6 +1003,9 @@ subroutine ZDSLSYMM(side, uplo, N, M1, M2, A, P, Mat) !identify possible block structure !only used in default case for n>4 IF(N > 8) THEN + IF(uplo=='L' .or. uplo=='l') THEN ! uplo == l unimplemented and never used in this case + ERROR STOP + ENDIF COMPACT = .TRUE. L = 1 IDX = 1 -- GitLab From a1cc3487e42531fb945b77c8c5424078443d6e19 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Tue, 24 Nov 2020 14:03:33 +0100 Subject: [PATCH 69/96] Apply 1 suggestion(s) to 1 file(s) --- Prog/OpTTypes_mod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Prog/OpTTypes_mod.F90 b/Prog/OpTTypes_mod.F90 index 9fda734f..c7d50e73 100644 --- a/Prog/OpTTypes_mod.F90 +++ b/Prog/OpTTypes_mod.F90 @@ -66,7 +66,7 @@ module OpTTypes_mod !> @author !> ALF-project !> @brief - !> Encapsulates operations for complex OpTs. + !> Encapsulates operations for complex exponentiated OpTs. !> !-------------------------------------------------------------------- type, extends(ContainerElementBase) :: CmplxExpOpT -- GitLab From abfd01cb794db7a1c0af0b1dd441bca9e998252d Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Tue, 24 Nov 2020 14:03:46 +0100 Subject: [PATCH 70/96] Apply 1 suggestion(s) to 1 file(s) --- Prog/OpTTypes_mod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Prog/OpTTypes_mod.F90 b/Prog/OpTTypes_mod.F90 index c7d50e73..6bc638b4 100644 --- a/Prog/OpTTypes_mod.F90 +++ b/Prog/OpTTypes_mod.F90 @@ -42,7 +42,7 @@ module OpTTypes_mod !> @author !> ALF-project !> @brief - !> Encapsulates operations for real OpTs. + !> Encapsulates operations for real exponentiated OpTs. !> !-------------------------------------------------------------------- type, extends(ContainerElementBase) :: RealExpOpT -- GitLab From f501d5c84d58ff4296f570150256df8e927c67ab Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Tue, 24 Nov 2020 14:09:11 +0100 Subject: [PATCH 71/96] replace stale comment with proper doc. --- Prog/DynamicMatrixArray_mod.F90 | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/Prog/DynamicMatrixArray_mod.F90 b/Prog/DynamicMatrixArray_mod.F90 index e831772b..5e22d1f1 100644 --- a/Prog/DynamicMatrixArray_mod.F90 +++ b/Prog/DynamicMatrixArray_mod.F90 @@ -73,7 +73,18 @@ subroutine DynamicMatrixArray_dealloc(this) deallocate(this%data) end subroutine -!itm gets deallocated in the process +!-------------------------------------------------------------------- +!> @author +!> The ALF Project contributors +! +!> @brief +!> Attach a pointer to the object givenby itm at the end of the vector. +!> If out of space the vector grows. +!> +!> @param[inout] this the vector +!> @param[in] itm the object that we like to store a pointer to. +! +!-------------------------------------------------------------------- subroutine DynamicMatrixArray_pushback(this, itm) class(DynamicMatrixArray) :: this class(ContainerElementBase), intent(in), target :: itm ! Type(...) always has to match exactly, class(...) allows for polymorphism -- GitLab From 0e5269ca102bddcf20be7f07ca0f3658625de1e3 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Tue, 24 Nov 2020 14:11:38 +0100 Subject: [PATCH 72/96] add docs --- Prog/DynamicMatrixArray_mod.F90 | 28 +++++++++++++++++++++++++--- 1 file changed, 25 insertions(+), 3 deletions(-) diff --git a/Prog/DynamicMatrixArray_mod.F90 b/Prog/DynamicMatrixArray_mod.F90 index 5e22d1f1..fca90e7d 100644 --- a/Prog/DynamicMatrixArray_mod.F90 +++ b/Prog/DynamicMatrixArray_mod.F90 @@ -111,10 +111,10 @@ end subroutine !> The ALF Project contributors ! !> @brief -!> return a pointer to the object stored at position i +!> return a pointer to the object stored at position i. !> -!> @param[in] i the index -!> @param[out] the content stored at the position i +!> @param[in] i the index. +!> @param[out] the content stored at the position i. ! !-------------------------------------------------------------------- function DynamicMatrixArray_at(this, pos) result(itm) @@ -124,12 +124,34 @@ function DynamicMatrixArray_at(this, pos) result(itm) itm => this%data(pos)%dat end function +!-------------------------------------------------------------------- +!> @author +!> The ALF Project contributors +! +!> @brief +!> returns the pointer to the last element +!> +!> @param[inout] this the vector. +!> @param[out] itm the element at the end of the vector. +! +!-------------------------------------------------------------------- subroutine DynamicMatrixArray_back(this, itm) class(DynamicMatrixArray), intent(in) :: this class(ContainerElementBase), intent(out), pointer :: itm itm => this%data(this%tail-1)%dat end subroutine +!-------------------------------------------------------------------- +!> @author +!> The ALF Project contributors +! +!> @brief +!> Inquire the length of the vector. +!> +!> @param[inout] this the vector +!> @return the current length of the vector +! +!-------------------------------------------------------------------- function DynamicMatrixArray_length(this) result(l) class(DynamicMatrixArray) :: this integer :: l -- GitLab From 03f802238d6d1615cf2f3fd0711431aca7e15a30 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Tue, 24 Nov 2020 17:10:55 +0100 Subject: [PATCH 73/96] more doxygen docs --- Prog/DynamicMatrixArray_mod.F90 | 20 +++++++++++++++++++- 1 file changed, 19 insertions(+), 1 deletion(-) diff --git a/Prog/DynamicMatrixArray_mod.F90 b/Prog/DynamicMatrixArray_mod.F90 index fca90e7d..cea44fd1 100644 --- a/Prog/DynamicMatrixArray_mod.F90 +++ b/Prog/DynamicMatrixArray_mod.F90 @@ -47,7 +47,7 @@ module DynamicMatrixArray_mod type :: DynamicMatrixArray integer :: avamem ! amount of available space integer :: tail ! last index - Type(OpTbasePtrWrapper), allocatable, dimension(:) :: data + Type(OpTbasePtrWrapper), allocatable, dimension(:) :: data ! actual effective array of the pointers contains procedure :: init => DynamicMatrixArray_init procedure :: dealloc => DynamicMatrixArray_dealloc @@ -60,6 +60,15 @@ module DynamicMatrixArray_mod contains +!-------------------------------------------------------------------- +!> @author +!> The ALF Project contributors +! +!> @brief +!> set up initial state of the vector. +!> +!> @param[inout] this the vector +!-------------------------------------------------------------------- subroutine DynamicMatrixArray_init(this) class(DynamicMatrixArray) :: this type(OpTbasePtrWrapper) :: temp @@ -68,6 +77,15 @@ subroutine DynamicMatrixArray_init(this) allocate(this%data(this%avamem)) end subroutine DynamicMatrixArray_init +!-------------------------------------------------------------------- +!> @author +!> The ALF Project contributors +! +!> @brief +!> Deallocates internal storage. Pointees are not deleted! +!> +!> @param[inout] this the vector +!-------------------------------------------------------------------- subroutine DynamicMatrixArray_dealloc(this) class(DynamicMatrixArray) :: this deallocate(this%data) -- GitLab From 35cadc0dfb57aa39868424437312517aa526a456 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Tue, 24 Nov 2020 17:14:48 +0100 Subject: [PATCH 74/96] remove old things. --- Prog/main.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/Prog/main.F90 b/Prog/main.F90 index 8bdec863..f79af06b 100644 --- a/Prog/main.F90 +++ b/Prog/main.F90 @@ -124,7 +124,6 @@ Program Main Use UDV_State_mod Use Wrapgr_mod Use Fields_mod - Use OpTTypes_mod use iso_fortran_env, only: output_unit, error_unit Use Langevin_HMC_mod -- GitLab From 263f96631f2dac5a309991cea322fcb68b48cd50 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Tue, 24 Nov 2020 17:15:17 +0100 Subject: [PATCH 75/96] nullify pointers on init. --- Prog/Hop_mod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Prog/Hop_mod.F90 b/Prog/Hop_mod.F90 index a3533acf..0dc2c922 100644 --- a/Prog/Hop_mod.F90 +++ b/Prog/Hop_mod.F90 @@ -81,8 +81,8 @@ Type(DynamicMatrixArray), intent(inout) :: vec Type(Operator), intent(in) :: op - class(CmplxExpOpT), pointer :: cmplxexp - class(RealExpOpT), pointer :: realexp + class(CmplxExpOpT), pointer :: cmplxexp => null() + class(RealExpOpT), pointer :: realexp => null() if (Op_is_real(op)) then ! branch for real operators -- GitLab From 49224a00dfaf37b775fe29c7bbc9327b4b92a8cf Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Wed, 25 Nov 2020 01:10:54 +0100 Subject: [PATCH 76/96] minor things --- Prog/test.f90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Prog/test.f90 b/Prog/test.f90 index d49ebe2e..451ebc2d 100644 --- a/Prog/test.f90 +++ b/Prog/test.f90 @@ -1,12 +1,12 @@ program test Use DynamicMatrixArray_mod Use ContainerElementBase_mod -Use matTypes_mod +Use OpTTypes_mod implicit none Type(DynamicMatrixArray) :: vec -Type(RealMat), allocatable :: remat -Type(CmplxMat), allocatable:: complexmat +Type(RealExpOpT), allocatable :: remat +Type(CmplxExpOpT), allocatable:: complexmat class(ContainerElementBase), allocatable :: dummy Complex(kind=kind(0.d0)), allocatable, dimension(:,:) :: res, ctmp Real(kind=kind(0.d0)), allocatable, dimension(:,:) :: rtmp -- GitLab From c674882985235ec0393f372bfac755aa504aa630 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Fri, 27 Nov 2020 03:46:34 +0100 Subject: [PATCH 77/96] rework test program --- Prog/test.f90 | 68 +++++++++++++++++++++++++++++---------------------- 1 file changed, 39 insertions(+), 29 deletions(-) diff --git a/Prog/test.f90 b/Prog/test.f90 index 451ebc2d..cf8ac80b 100644 --- a/Prog/test.f90 +++ b/Prog/test.f90 @@ -2,50 +2,60 @@ program test Use DynamicMatrixArray_mod Use ContainerElementBase_mod Use OpTTypes_mod +Use Operator_mod implicit none Type(DynamicMatrixArray) :: vec -Type(RealExpOpT), allocatable :: remat -Type(CmplxExpOpT), allocatable:: complexmat -class(ContainerElementBase), allocatable :: dummy +Type(Operator), dimension(:), allocatable :: Op_T +Class(RealExpOpT), pointer :: reopt => null() +Class(CmplxExpOpT), pointer :: cmplxopt => null() +Class(ContainerElementBase), allocatable :: dummy Complex(kind=kind(0.d0)), allocatable, dimension(:,:) :: res, ctmp Real(kind=kind(0.d0)), allocatable, dimension(:,:) :: rtmp Complex(kind=kind(0.d0)) :: alpha, zero -Integer :: i,j,k,l, nmax +Integer :: i,j,k,l, nmax, ndimmax nmax = 5 -allocate (res(nmax, nmax), ctmp(nmax, nmax), rtmp(nmax, nmax)) +ndimmax = 5 +allocate (res(ndimmax, ndimmax), ctmp(ndimmax, ndimmax), rtmp(ndimmax, ndimmax)) call vec%init() alpha = 1.0 zero = 0.0 -call zlaset('A', nmax, nmax, zero, alpha, res, nmax) +! initialize res as unit matrix +call zlaset('A', ndimmax, ndimmax, zero, alpha, res, ndimmax) -allocate(remat, complexmat) +allocate(Op_T(2*nmax)) -do i = 1, 5 - ! create some complex dummy data - call zlaset('A', nmax, nmax, zero, alpha, ctmp, nmax) - do j = 1, nmax - ctmp(j,j) = i - enddo - - !pushback - call complexmat%init(ctmp) - call vec%pushback(complexmat) - - ! create some real dummy data - call dlaset('A', nmax, nmax, zero, alpha, rtmp, nmax) - do j = 1, nmax - rtmp(j,j) = i+j - enddo - ! push_back - call remat%init(rtmp) - call vec%pushback(remat) +do i = 1, nmax + Call Op_make(Op_T(i), Ndimmax) + Call Op_make(Op_T(nmax + i), Ndimmax) + Op_T(i)%O = 0 + Op_T(nmax + i)%O = 0 + Do j = 1, ndimmax + Op_T(i)%P(j) = j + Op_T(nmax + i)%P(j) = j + Enddo + Op_T(i)%g = 1 + Op_T(i)%alpha = cmplx(0.d0,0.d0, kind(0.D0)) + Op_T(nmax + i)%g = 1 + Op_T(nmax + i)%alpha = cmplx(0.d0,0.d0, kind(0.D0)) + ! fill with some data + do j = 1, ndimmax + Op_T(i)%O(j,j) = j + Op_T(nmax + i)%O(j,j) = cmplx(j, j, kind(0.D0)) + enddo + + Call Op_set(Op_T(i)) + Call Op_set(Op_T(nmax + i)) + + allocate(reopt, cmplxopt) + call reopt%init(Op_T(i)) + call cmplxopt%init(Op_T(nmax + i)) + call vec%pushback(reopt) + call vec%pushback(cmplxopt) enddo -! tidy up auxiliary structures -deallocate(remat, complexmat) -deallocate(ctmp, rtmp) + ! execute a loop over all stored objects do i= 1, vec%length() -- GitLab From 143c5b4d9b6ec6be2cd2016f23ec8ca391e5253d Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Fri, 27 Nov 2020 03:47:07 +0100 Subject: [PATCH 78/96] typos --- Prog/Hop_mod.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Prog/Hop_mod.F90 b/Prog/Hop_mod.F90 index 0dc2c922..1481f405 100644 --- a/Prog/Hop_mod.F90 +++ b/Prog/Hop_mod.F90 @@ -67,7 +67,7 @@ ! !> @brief !> This function serves as a central entry point to collect the -!> processing that occurs in mapping an OpT input matrix to internal +!> processing that occurs in mapping an OpT input matrix to the internal !> matrix-like data structure. ! !> @param vec[inout] a DynamicMatrixArray structure to which we append new elements. @@ -81,8 +81,8 @@ Type(DynamicMatrixArray), intent(inout) :: vec Type(Operator), intent(in) :: op - class(CmplxExpOpT), pointer :: cmplxexp => null() - class(RealExpOpT), pointer :: realexp => null() + Class(CmplxExpOpT), pointer :: cmplxexp => null() + Class(RealExpOpT), pointer :: realexp => null() if (Op_is_real(op)) then ! branch for real operators -- GitLab From b7d9273dba790893f39ece1577c6716ba409a72d Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Fri, 27 Nov 2020 04:06:45 +0100 Subject: [PATCH 79/96] typos --- Prog/Operator_mod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Prog/Operator_mod.F90 b/Prog/Operator_mod.F90 index 7e730697..f17a1ba1 100644 --- a/Prog/Operator_mod.F90 +++ b/Prog/Operator_mod.F90 @@ -717,7 +717,7 @@ Contains Implicit None Type (Operator) , INTENT(IN) :: Op - Logical ::retval + Logical :: retval Real (Kind=Kind(0.d0)) :: myzero integer :: i,j -- GitLab From 5ba0d405fb264afed8d2261dcecaa2a24b4ca540 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Fri, 27 Nov 2020 04:06:58 +0100 Subject: [PATCH 80/96] plug mem leaks --- Prog/test.f90 | 138 +++++++++++++++++++++++++------------------------- 1 file changed, 70 insertions(+), 68 deletions(-) diff --git a/Prog/test.f90 b/Prog/test.f90 index cf8ac80b..10b6b6b4 100644 --- a/Prog/test.f90 +++ b/Prog/test.f90 @@ -1,81 +1,83 @@ program test -Use DynamicMatrixArray_mod -Use ContainerElementBase_mod -Use OpTTypes_mod -Use Operator_mod -implicit none + Use DynamicMatrixArray_mod + Use ContainerElementBase_mod + Use OpTTypes_mod + Use Operator_mod + implicit none -Type(DynamicMatrixArray) :: vec -Type(Operator), dimension(:), allocatable :: Op_T -Class(RealExpOpT), pointer :: reopt => null() -Class(CmplxExpOpT), pointer :: cmplxopt => null() -Class(ContainerElementBase), allocatable :: dummy -Complex(kind=kind(0.d0)), allocatable, dimension(:,:) :: res, ctmp -Real(kind=kind(0.d0)), allocatable, dimension(:,:) :: rtmp -Complex(kind=kind(0.d0)) :: alpha, zero -Integer :: i,j,k,l, nmax, ndimmax + Type(DynamicMatrixArray) :: vec + Type(Operator), dimension(:), allocatable :: Op_T + Class(RealExpOpT), pointer :: reopt => null() + Class(CmplxExpOpT), pointer :: cmplxopt => null() + Class(ContainerElementBase), pointer :: dummy + Complex(kind=kind(0.d0)), allocatable, dimension(:,:) :: res + Complex(kind=kind(0.d0)) :: alpha, zero + Integer :: i, j, k, l, nmax, ndimmax -nmax = 5 -ndimmax = 5 -allocate (res(ndimmax, ndimmax), ctmp(ndimmax, ndimmax), rtmp(ndimmax, ndimmax)) -call vec%init() + nmax = 5 + ndimmax = 5 + allocate (res(ndimmax, ndimmax)) + call vec%init() -alpha = 1.0 -zero = 0.0 -! initialize res as unit matrix -call zlaset('A', ndimmax, ndimmax, zero, alpha, res, ndimmax) + alpha = 1.0 + zero = 0.0 + ! initialize res as unit matrix + call zlaset('A', ndimmax, ndimmax, zero, alpha, res, ndimmax) -allocate(Op_T(2*nmax)) + allocate(Op_T(2*nmax)) -do i = 1, nmax - Call Op_make(Op_T(i), Ndimmax) - Call Op_make(Op_T(nmax + i), Ndimmax) - Op_T(i)%O = 0 - Op_T(nmax + i)%O = 0 - Do j = 1, ndimmax - Op_T(i)%P(j) = j - Op_T(nmax + i)%P(j) = j - Enddo - Op_T(i)%g = 1 - Op_T(i)%alpha = cmplx(0.d0,0.d0, kind(0.D0)) - Op_T(nmax + i)%g = 1 - Op_T(nmax + i)%alpha = cmplx(0.d0,0.d0, kind(0.D0)) - ! fill with some data - do j = 1, ndimmax - Op_T(i)%O(j,j) = j - Op_T(nmax + i)%O(j,j) = cmplx(j, j, kind(0.D0)) - enddo - - Call Op_set(Op_T(i)) - Call Op_set(Op_T(nmax + i)) - - allocate(reopt, cmplxopt) - call reopt%init(Op_T(i)) - call cmplxopt%init(Op_T(nmax + i)) - call vec%pushback(reopt) - call vec%pushback(cmplxopt) -enddo + do i = 1, nmax + Call Op_make(Op_T(i), Ndimmax) + Call Op_make(Op_T(nmax + i), Ndimmax) + Op_T(i)%O = 0 + Op_T(nmax + i)%O = 0 + Do j = 1, ndimmax + Op_T(i)%P(j) = j + Op_T(nmax + i)%P(j) = j + Enddo + Op_T(i)%g = 1 + Op_T(i)%type = 2 + Op_T(i)%alpha = cmplx(0.d0,0.d0, kind(0.D0)) + Op_T(nmax + i)%g = 1 + Op_T(nmax + i)%type = 2 + Op_T(nmax + i)%alpha = cmplx(0.d0,0.d0, kind(0.D0)) + ! fill with some data + do j = 1, ndimmax + Op_T(i)%O(j,j) = j + Op_T(nmax + i)%O(j,j) = cmplx(j, j, kind(0.D0)) + enddo + + Call Op_set(Op_T(i)) + Call Op_set(Op_T(nmax + i)) + + allocate(reopt, cmplxopt) + call reopt%init(Op_T(i)) + call cmplxopt%init(Op_T(nmax + i)) + call vec%pushback(reopt) + call vec%pushback(cmplxopt) + enddo -! execute a loop over all stored objects -do i= 1, vec%length() - dummy = vec%at(i) ! get object + ! execute a loop over all stored objects + do i= 1, vec%length() + dummy => vec%at(i) ! get object call dummy%rmult(res) ! polymorphic dispatch to rmult - do k = 1, nmax - write (*,*) (dble(res(k,l)), l = 1,nmax ) +! do k = 1, nmax +! write (*,*) (dble(res(k,l)), l = 1,nmax ) +! enddo +! write (*,*) "============" enddo - write (*,*) "============" -enddo -do i = 1, nmax -write (*,*) (res(i,j), j = 1,nmax ) -enddo + do i = 1, nmax + write (*,*) (res(i,j), j = 1,nmax ) + enddo -! tidy up -do i = 1, vec%length() -dummy = vec%at(i) ! Fortran doesn't want chaining here -deallocate(dummy) -enddo -call vec%dealloc() -deallocate(res) + ! tidy up + do i = 1, vec%length() + dummy => vec%at(i) ! Fortran doesn't want chaining here + deallocate(dummy) + call Op_clear(Op_T(i), ndimmax) + enddo + call vec%dealloc() + deallocate(res, Op_T) end program -- GitLab From 67ff5855909f41bd7182aa80966dcf51cf754efa Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Fri, 27 Nov 2020 04:33:10 +0100 Subject: [PATCH 81/96] make it a test --- Prog/test.f90 | 88 +++++++++++++++++++++++++++++---------------------- 1 file changed, 51 insertions(+), 37 deletions(-) diff --git a/Prog/test.f90 b/Prog/test.f90 index 10b6b6b4..d0ccb01b 100644 --- a/Prog/test.f90 +++ b/Prog/test.f90 @@ -12,7 +12,7 @@ program test Class(ContainerElementBase), pointer :: dummy Complex(kind=kind(0.d0)), allocatable, dimension(:,:) :: res Complex(kind=kind(0.d0)) :: alpha, zero - Integer :: i, j, k, l, nmax, ndimmax + Integer :: i, j, nmax, ndimmax nmax = 5 ndimmax = 5 @@ -27,56 +27,70 @@ program test allocate(Op_T(2*nmax)) do i = 1, nmax - Call Op_make(Op_T(i), Ndimmax) - Call Op_make(Op_T(nmax + i), Ndimmax) - Op_T(i)%O = 0 - Op_T(nmax + i)%O = 0 - Do j = 1, ndimmax - Op_T(i)%P(j) = j - Op_T(nmax + i)%P(j) = j - Enddo - Op_T(i)%g = 1 - Op_T(i)%type = 2 - Op_T(i)%alpha = cmplx(0.d0,0.d0, kind(0.D0)) - Op_T(nmax + i)%g = 1 - Op_T(nmax + i)%type = 2 - Op_T(nmax + i)%alpha = cmplx(0.d0,0.d0, kind(0.D0)) - ! fill with some data - do j = 1, ndimmax - Op_T(i)%O(j,j) = j - Op_T(nmax + i)%O(j,j) = cmplx(j, j, kind(0.D0)) - enddo + Call Op_make(Op_T(i), Ndimmax) + Call Op_make(Op_T(nmax + i), Ndimmax) + Op_T(i)%O = 0 + Op_T(nmax + i)%O = 0 + Do j = 1, ndimmax + Op_T(i)%P(j) = j + Op_T(nmax + i)%P(j) = j + Enddo + Op_T(i)%g = 0.2 + Op_T(i)%type = 2 + Op_T(i)%alpha = cmplx(0.d0, 0.d0, kind(0.D0)) + Op_T(nmax + i)%g = 0.2 + Op_T(nmax + i)%type = 2 + Op_T(nmax + i)%alpha = cmplx(0.d0, 0.d0, kind(0.D0)) + ! fill with some data + do j = 1, ndimmax + Op_T(i)%O(j, j) = 0!j + if (j+1 <= ndimmax) then + Op_T(nmax + i)%O(j, j+1) = cmplx(j, j, kind(0.D0)) + Op_T(nmax + i)%O(j+1, j) = cmplx(j, -j, kind(0.D0)) + endif + enddo - Call Op_set(Op_T(i)) - Call Op_set(Op_T(nmax + i)) + Call Op_set(Op_T(i)) + Call Op_set(Op_T(nmax + i)) - allocate(reopt, cmplxopt) - call reopt%init(Op_T(i)) - call cmplxopt%init(Op_T(nmax + i)) - call vec%pushback(reopt) - call vec%pushback(cmplxopt) + allocate(reopt, cmplxopt) + call reopt%init(Op_T(i)) + call cmplxopt%init(Op_T(nmax + i)) + call vec%pushback(reopt) + call vec%pushback(cmplxopt) enddo ! execute a loop over all stored objects do i= 1, vec%length() - dummy => vec%at(i) ! get object - call dummy%rmult(res) ! polymorphic dispatch to rmult -! do k = 1, nmax -! write (*,*) (dble(res(k,l)), l = 1,nmax ) + dummy => vec%at(i) ! get object + call dummy%rmult(res) ! polymorphic dispatch to rmult + call dummy%lmult(res) ! polymorphic dispatch to lmult +! do k = 1, ndimmax +! write (*,*) (aimag(res(k,l)), l = 1,ndimmax ) ! enddo ! write (*,*) "============" enddo - do i = 1, nmax - write (*,*) (res(i,j), j = 1,nmax ) - enddo +! do i = 1, ndimmax +! write (*,*) (res(i,j), j = 1,ndimmax ) +! enddo + if (abs(dble(res(ndimmax,ndimmax)) - 613518.68777767487D00) > 613518.68777767487D00*1D-15) then + write (*,*) "error in OpT multiplication",abs(dble(res(ndimmax,ndimmax))-613518.68777767487D00), 613518.68777767487D00*1D-15 + stop 1 + endif + + if (abs(aimag(res(ndimmax,ndimmax)) + 1.70899898780322057D-011 ) > 1.70899898780322057D-011 * 1D-15) then ! ref is negative + write (*,*) "error in OpT multiplication",abs(aimag(res(ndimmax,ndimmax)) + 1.70899898780322057D-011 ) + stop 2 + endif +! write (*,*) res(ndimmax, ndimmax) ! tidy up do i = 1, vec%length() - dummy => vec%at(i) ! Fortran doesn't want chaining here - deallocate(dummy) - call Op_clear(Op_T(i), ndimmax) + dummy => vec%at(i) ! Fortran doesn't want chaining + deallocate(dummy) + call Op_clear(Op_T(i), ndimmax) enddo call vec%dealloc() deallocate(res, Op_T) -- GitLab From a9dfcbf55cb26225dd2d3a4143697aac4fe5fbb7 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Fri, 27 Nov 2020 04:39:01 +0100 Subject: [PATCH 82/96] move testsuite forward to silence CMake warnings. --- testsuite/CMakeLists.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/testsuite/CMakeLists.txt b/testsuite/CMakeLists.txt index c245fcc4..7343824d 100644 --- a/testsuite/CMakeLists.txt +++ b/testsuite/CMakeLists.txt @@ -1,4 +1,4 @@ -cmake_minimum_required(VERSION 2.8.5) +cmake_minimum_required(VERSION 3.0.0) Project(matmod.tests C Fortran) add_subdirectory(matmod.tests) -- GitLab From f8552fafa908c0404035bf2f138f105257b45757 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Fri, 27 Nov 2020 04:46:59 +0100 Subject: [PATCH 83/96] Add test to testsuite --- .../26-Test-Polymorphic-Fortran.F90 | 97 +++++++++++++++++++ testsuite/Prog.tests/CMakeLists.txt | 6 +- 2 files changed, 102 insertions(+), 1 deletion(-) create mode 100644 testsuite/Prog.tests/26-Test-Polymorphic-Fortran.F90 diff --git a/testsuite/Prog.tests/26-Test-Polymorphic-Fortran.F90 b/testsuite/Prog.tests/26-Test-Polymorphic-Fortran.F90 new file mode 100644 index 00000000..d0ccb01b --- /dev/null +++ b/testsuite/Prog.tests/26-Test-Polymorphic-Fortran.F90 @@ -0,0 +1,97 @@ +program test + Use DynamicMatrixArray_mod + Use ContainerElementBase_mod + Use OpTTypes_mod + Use Operator_mod + implicit none + + Type(DynamicMatrixArray) :: vec + Type(Operator), dimension(:), allocatable :: Op_T + Class(RealExpOpT), pointer :: reopt => null() + Class(CmplxExpOpT), pointer :: cmplxopt => null() + Class(ContainerElementBase), pointer :: dummy + Complex(kind=kind(0.d0)), allocatable, dimension(:,:) :: res + Complex(kind=kind(0.d0)) :: alpha, zero + Integer :: i, j, nmax, ndimmax + + nmax = 5 + ndimmax = 5 + allocate (res(ndimmax, ndimmax)) + call vec%init() + + alpha = 1.0 + zero = 0.0 + ! initialize res as unit matrix + call zlaset('A', ndimmax, ndimmax, zero, alpha, res, ndimmax) + + allocate(Op_T(2*nmax)) + + do i = 1, nmax + Call Op_make(Op_T(i), Ndimmax) + Call Op_make(Op_T(nmax + i), Ndimmax) + Op_T(i)%O = 0 + Op_T(nmax + i)%O = 0 + Do j = 1, ndimmax + Op_T(i)%P(j) = j + Op_T(nmax + i)%P(j) = j + Enddo + Op_T(i)%g = 0.2 + Op_T(i)%type = 2 + Op_T(i)%alpha = cmplx(0.d0, 0.d0, kind(0.D0)) + Op_T(nmax + i)%g = 0.2 + Op_T(nmax + i)%type = 2 + Op_T(nmax + i)%alpha = cmplx(0.d0, 0.d0, kind(0.D0)) + ! fill with some data + do j = 1, ndimmax + Op_T(i)%O(j, j) = 0!j + if (j+1 <= ndimmax) then + Op_T(nmax + i)%O(j, j+1) = cmplx(j, j, kind(0.D0)) + Op_T(nmax + i)%O(j+1, j) = cmplx(j, -j, kind(0.D0)) + endif + enddo + + Call Op_set(Op_T(i)) + Call Op_set(Op_T(nmax + i)) + + allocate(reopt, cmplxopt) + call reopt%init(Op_T(i)) + call cmplxopt%init(Op_T(nmax + i)) + call vec%pushback(reopt) + call vec%pushback(cmplxopt) + enddo + + + ! execute a loop over all stored objects + do i= 1, vec%length() + dummy => vec%at(i) ! get object + call dummy%rmult(res) ! polymorphic dispatch to rmult + call dummy%lmult(res) ! polymorphic dispatch to lmult +! do k = 1, ndimmax +! write (*,*) (aimag(res(k,l)), l = 1,ndimmax ) +! enddo +! write (*,*) "============" + enddo + +! do i = 1, ndimmax +! write (*,*) (res(i,j), j = 1,ndimmax ) +! enddo + if (abs(dble(res(ndimmax,ndimmax)) - 613518.68777767487D00) > 613518.68777767487D00*1D-15) then + write (*,*) "error in OpT multiplication",abs(dble(res(ndimmax,ndimmax))-613518.68777767487D00), 613518.68777767487D00*1D-15 + stop 1 + endif + + if (abs(aimag(res(ndimmax,ndimmax)) + 1.70899898780322057D-011 ) > 1.70899898780322057D-011 * 1D-15) then ! ref is negative + write (*,*) "error in OpT multiplication",abs(aimag(res(ndimmax,ndimmax)) + 1.70899898780322057D-011 ) + stop 2 + endif +! write (*,*) res(ndimmax, ndimmax) + + ! tidy up + do i = 1, vec%length() + dummy => vec%at(i) ! Fortran doesn't want chaining + deallocate(dummy) + call Op_clear(Op_T(i), ndimmax) + enddo + call vec%dealloc() + deallocate(res, Op_T) +end program diff --git a/testsuite/Prog.tests/CMakeLists.txt b/testsuite/Prog.tests/CMakeLists.txt index f44604ff..6064ebc0 100644 --- a/testsuite/Prog.tests/CMakeLists.txt +++ b/testsuite/Prog.tests/CMakeLists.txt @@ -28,8 +28,9 @@ add_executable(22-sl-mat-mults 21-sl-mat-mults.F90) add_executable(23-cgrp 23-cgrp.F90) add_executable(24-udv 24-udv.F90) add_executable(25-assign-UDV-state 25-assign-UDV-state.F90) +add_executable(26-Test-Polymorphic-Fortran 26-Test-Polymorphic-Fortran.F90) # set(operatorparts 1-copy-sel-rows 2-copy-sel-columns 3-opmult 4-opmultct 5-FillExpOps 6-opexpmult-1 6-opexpmult-2 7-opexpmultct-1 7-opexpmultct-2 9-Op-Phase 10-Op-mmultL 11-Op-mmultR 13-Op-Wrapup 14-Op-Wrapdo 21-Op-make 22-sl-mat-mults) -set(operatorparts 9-Op-Phase 10-Op-mmultL 11-Op-mmultR 13-Op-Wrapup 14-Op-Wrapdo 21-Op-make 22-sl-mat-mults) +set(operatorparts 9-Op-Phase 10-Op-mmultL 11-Op-mmultR 13-Op-Wrapup 14-Op-Wrapdo 21-Op-make 22-sl-mat-mults 26-Test-Polymorphic-Fortran) set(cgr2_2tests 16-get-blocks 17-solve-extended-system) #set(cgr2_1tests 8-scalematrix-1 8-scalematrix-2) set(cgr1tests 15-cgr 20-qdrp 23-cgrp) @@ -75,6 +76,8 @@ target_link_libraries(${iter} ${CMAKE_CURRENT_SOURCE_DIR}/../../Libraries/libqrr target_link_libraries(${iter} ${LAPACK_LIBRARIES}) endforeach(iter) +target_link_libraries(26-Test-Polymorphic-Fortran ${CMAKE_CURRENT_SOURCE_DIR}/../../Prog/OpTTypes_mod.o ${CMAKE_CURRENT_SOURCE_DIR}/../../Prog/DynamicMatrixArray_mod.o ${CMAKE_CURRENT_SOURCE_DIR}/../../Prog/ContainerElementBase_mod.o) + enable_testing() # add_test(1-copy-sel-rows 1-copy-sel-rows) # add_test(2-copy-sel-columns 2-copy-sel-columns) @@ -103,3 +106,4 @@ add_test(22-sl-mat-mults 22-sl-mat-mults) add_test(23-cgrp 23-cgrp) add_test(24-udv 24-udv) add_test(25-assign-UDV-state 25-assign-UDV-state) +add_test(26-Test-Polymorphic-Fortran 26-Test-Polymorphic-Fortran) -- GitLab From 75d2686a80cdab446751b56f47812f993f7b8448 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Fri, 27 Nov 2020 04:51:18 +0100 Subject: [PATCH 84/96] silence cmake warnings --- testsuite/Prog.tests/CMakeLists.txt | 2 +- testsuite/matmod.tests/CMakeLists.txt | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/testsuite/Prog.tests/CMakeLists.txt b/testsuite/Prog.tests/CMakeLists.txt index 6064ebc0..565fa6d9 100644 --- a/testsuite/Prog.tests/CMakeLists.txt +++ b/testsuite/Prog.tests/CMakeLists.txt @@ -1,4 +1,4 @@ -cmake_minimum_required(VERSION 2.8.5) +cmake_minimum_required(VERSION 3.0) Project(matmod.tests C Fortran) find_package(LAPACK) diff --git a/testsuite/matmod.tests/CMakeLists.txt b/testsuite/matmod.tests/CMakeLists.txt index 1a249602..fd7aaba4 100644 --- a/testsuite/matmod.tests/CMakeLists.txt +++ b/testsuite/matmod.tests/CMakeLists.txt @@ -1,4 +1,4 @@ -cmake_minimum_required(VERSION 2.8.5) +cmake_minimum_required(VERSION 3.0) Project(matmod.tests C Fortran) find_package(LAPACK) -- GitLab From c4f2b5ffaf5a79a6d7555d9a9bbba03ca2c787a3 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Fri, 27 Nov 2020 04:52:03 +0100 Subject: [PATCH 85/96] silence cmake warnings --- testsuite/CMakeLists.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/testsuite/CMakeLists.txt b/testsuite/CMakeLists.txt index 7343824d..0ca1c89a 100644 --- a/testsuite/CMakeLists.txt +++ b/testsuite/CMakeLists.txt @@ -1,4 +1,4 @@ -cmake_minimum_required(VERSION 3.0.0) +cmake_minimum_required(VERSION 3.0) Project(matmod.tests C Fortran) add_subdirectory(matmod.tests) -- GitLab From ce142906d415a20bca5e9e90f73e37181fe3b7ba Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Fri, 27 Nov 2020 04:52:23 +0100 Subject: [PATCH 86/96] tidy up repo --- Prog/test.f90 | 97 --------------------------------------------------- 1 file changed, 97 deletions(-) delete mode 100644 Prog/test.f90 diff --git a/Prog/test.f90 b/Prog/test.f90 deleted file mode 100644 index d0ccb01b..00000000 --- a/Prog/test.f90 +++ /dev/null @@ -1,97 +0,0 @@ -program test - Use DynamicMatrixArray_mod - Use ContainerElementBase_mod - Use OpTTypes_mod - Use Operator_mod - implicit none - - Type(DynamicMatrixArray) :: vec - Type(Operator), dimension(:), allocatable :: Op_T - Class(RealExpOpT), pointer :: reopt => null() - Class(CmplxExpOpT), pointer :: cmplxopt => null() - Class(ContainerElementBase), pointer :: dummy - Complex(kind=kind(0.d0)), allocatable, dimension(:,:) :: res - Complex(kind=kind(0.d0)) :: alpha, zero - Integer :: i, j, nmax, ndimmax - - nmax = 5 - ndimmax = 5 - allocate (res(ndimmax, ndimmax)) - call vec%init() - - alpha = 1.0 - zero = 0.0 - ! initialize res as unit matrix - call zlaset('A', ndimmax, ndimmax, zero, alpha, res, ndimmax) - - allocate(Op_T(2*nmax)) - - do i = 1, nmax - Call Op_make(Op_T(i), Ndimmax) - Call Op_make(Op_T(nmax + i), Ndimmax) - Op_T(i)%O = 0 - Op_T(nmax + i)%O = 0 - Do j = 1, ndimmax - Op_T(i)%P(j) = j - Op_T(nmax + i)%P(j) = j - Enddo - Op_T(i)%g = 0.2 - Op_T(i)%type = 2 - Op_T(i)%alpha = cmplx(0.d0, 0.d0, kind(0.D0)) - Op_T(nmax + i)%g = 0.2 - Op_T(nmax + i)%type = 2 - Op_T(nmax + i)%alpha = cmplx(0.d0, 0.d0, kind(0.D0)) - ! fill with some data - do j = 1, ndimmax - Op_T(i)%O(j, j) = 0!j - if (j+1 <= ndimmax) then - Op_T(nmax + i)%O(j, j+1) = cmplx(j, j, kind(0.D0)) - Op_T(nmax + i)%O(j+1, j) = cmplx(j, -j, kind(0.D0)) - endif - enddo - - Call Op_set(Op_T(i)) - Call Op_set(Op_T(nmax + i)) - - allocate(reopt, cmplxopt) - call reopt%init(Op_T(i)) - call cmplxopt%init(Op_T(nmax + i)) - call vec%pushback(reopt) - call vec%pushback(cmplxopt) - enddo - - - ! execute a loop over all stored objects - do i= 1, vec%length() - dummy => vec%at(i) ! get object - call dummy%rmult(res) ! polymorphic dispatch to rmult - call dummy%lmult(res) ! polymorphic dispatch to lmult -! do k = 1, ndimmax -! write (*,*) (aimag(res(k,l)), l = 1,ndimmax ) -! enddo -! write (*,*) "============" - enddo - -! do i = 1, ndimmax -! write (*,*) (res(i,j), j = 1,ndimmax ) -! enddo - if (abs(dble(res(ndimmax,ndimmax)) - 613518.68777767487D00) > 613518.68777767487D00*1D-15) then - write (*,*) "error in OpT multiplication",abs(dble(res(ndimmax,ndimmax))-613518.68777767487D00), 613518.68777767487D00*1D-15 - stop 1 - endif - - if (abs(aimag(res(ndimmax,ndimmax)) + 1.70899898780322057D-011 ) > 1.70899898780322057D-011 * 1D-15) then ! ref is negative - write (*,*) "error in OpT multiplication",abs(aimag(res(ndimmax,ndimmax)) + 1.70899898780322057D-011 ) - stop 2 - endif -! write (*,*) res(ndimmax, ndimmax) - - ! tidy up - do i = 1, vec%length() - dummy => vec%at(i) ! Fortran doesn't want chaining - deallocate(dummy) - call Op_clear(Op_T(i), ndimmax) - enddo - call vec%dealloc() - deallocate(res, Op_T) -end program -- GitLab From fa2ffa3dd854aa5c5ff461cc79931890f192a6bc Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Fri, 27 Nov 2020 14:48:40 +0100 Subject: [PATCH 87/96] We are not yet there... --- testsuite/CMakeLists.txt | 2 +- testsuite/Prog.tests/CMakeLists.txt | 2 +- testsuite/matmod.tests/CMakeLists.txt | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/testsuite/CMakeLists.txt b/testsuite/CMakeLists.txt index 0ca1c89a..88c8381b 100644 --- a/testsuite/CMakeLists.txt +++ b/testsuite/CMakeLists.txt @@ -1,4 +1,4 @@ -cmake_minimum_required(VERSION 3.0) +cmake_minimum_required(VERSION 2.8.11) Project(matmod.tests C Fortran) add_subdirectory(matmod.tests) diff --git a/testsuite/Prog.tests/CMakeLists.txt b/testsuite/Prog.tests/CMakeLists.txt index 565fa6d9..20c69386 100644 --- a/testsuite/Prog.tests/CMakeLists.txt +++ b/testsuite/Prog.tests/CMakeLists.txt @@ -1,4 +1,4 @@ -cmake_minimum_required(VERSION 3.0) +cmake_minimum_required(VERSION 2.8.11) Project(matmod.tests C Fortran) find_package(LAPACK) diff --git a/testsuite/matmod.tests/CMakeLists.txt b/testsuite/matmod.tests/CMakeLists.txt index fd7aaba4..928ff4ca 100644 --- a/testsuite/matmod.tests/CMakeLists.txt +++ b/testsuite/matmod.tests/CMakeLists.txt @@ -1,4 +1,4 @@ -cmake_minimum_required(VERSION 3.0) +cmake_minimum_required(VERSION 2.8.11) Project(matmod.tests C Fortran) find_package(LAPACK) -- GitLab From 684cbd64972f729564fd9f36ec1465b57799ea35 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Fri, 27 Nov 2020 15:00:00 +0100 Subject: [PATCH 88/96] use a different checkpoint. The other seems to be dominated by exponentiation noise... --- .../Prog.tests/26-Test-Polymorphic-Fortran.F90 | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/testsuite/Prog.tests/26-Test-Polymorphic-Fortran.F90 b/testsuite/Prog.tests/26-Test-Polymorphic-Fortran.F90 index d0ccb01b..e7071a7d 100644 --- a/testsuite/Prog.tests/26-Test-Polymorphic-Fortran.F90 +++ b/testsuite/Prog.tests/26-Test-Polymorphic-Fortran.F90 @@ -72,16 +72,16 @@ program test ! write (*,*) "============" enddo -! do i = 1, ndimmax -! write (*,*) (res(i,j), j = 1,ndimmax ) -! enddo - if (abs(dble(res(ndimmax,ndimmax)) - 613518.68777767487D00) > 613518.68777767487D00*1D-15) then - write (*,*) "error in OpT multiplication",abs(dble(res(ndimmax,ndimmax))-613518.68777767487D00), 613518.68777767487D00*1D-15 + do i = 1, ndimmax + write (*,*) (res(i,j), j = 1,ndimmax ) + enddo + if (abs(dble(res(ndimmax,ndimmax-1)) - 559995.58637168515D00) > 559995.58637168515D00*1D-15) then + write (*,*) "error in OpT mult.", abs(dble(res(ndimmax,ndimmax-1))-559995.58637168515D00), 559995.58637168515D00*1D-15 stop 1 endif - if (abs(aimag(res(ndimmax,ndimmax)) + 1.70899898780322057D-011 ) > 1.70899898780322057D-011 * 1D-15) then ! ref is negative - write (*,*) "error in OpT multiplication",abs(aimag(res(ndimmax,ndimmax)) + 1.70899898780322057D-011 ) + if (abs(aimag(res(ndimmax,ndimmax-1)) + 559995.58637168526D00 ) > 559995.58637168526D00 * 1D-15) then ! ref is negative + write (*,*) "error in OpT multiplication",abs(aimag(res(ndimmax, ndimmax-1)) + 559995.58637168526D00 ) stop 2 endif ! write (*,*) res(ndimmax, ndimmax) -- GitLab From 260499cc63b8f39e4c31170b037bfbc0fc902d5c Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Fri, 27 Nov 2020 15:19:09 +0100 Subject: [PATCH 89/96] forgot sth... --- testsuite/Prog.tests/26-Test-Polymorphic-Fortran.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/testsuite/Prog.tests/26-Test-Polymorphic-Fortran.F90 b/testsuite/Prog.tests/26-Test-Polymorphic-Fortran.F90 index e7071a7d..d7b29e1e 100644 --- a/testsuite/Prog.tests/26-Test-Polymorphic-Fortran.F90 +++ b/testsuite/Prog.tests/26-Test-Polymorphic-Fortran.F90 @@ -72,9 +72,9 @@ program test ! write (*,*) "============" enddo - do i = 1, ndimmax - write (*,*) (res(i,j), j = 1,ndimmax ) - enddo +! do i = 1, ndimmax +! write (*,*) (res(i,j), j = 1,ndimmax ) +! enddo if (abs(dble(res(ndimmax,ndimmax-1)) - 559995.58637168515D00) > 559995.58637168515D00*1D-15) then write (*,*) "error in OpT mult.", abs(dble(res(ndimmax,ndimmax-1))-559995.58637168515D00), 559995.58637168515D00*1D-15 stop 1 -- GitLab From 77be603a0bc52f47df8bb6f99bcf9e1b7d3c284e Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Fri, 27 Nov 2020 15:22:45 +0100 Subject: [PATCH 90/96] remove outdated comment --- Prog/DynamicMatrixArray_mod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Prog/DynamicMatrixArray_mod.F90 b/Prog/DynamicMatrixArray_mod.F90 index cea44fd1..8981a22f 100644 --- a/Prog/DynamicMatrixArray_mod.F90 +++ b/Prog/DynamicMatrixArray_mod.F90 @@ -109,7 +109,7 @@ subroutine DynamicMatrixArray_pushback(this, itm) type(OpTbasePtrWrapper), allocatable, dimension(:) :: temp integer :: i - if (this%tail == this%avamem) then ! check if this still works the same as for plain ints. + if (this%tail == this%avamem) then ! reallocate the memory write (*,*) "not enough space -> growing." call MOVE_ALLOC(this%data, temp) -- GitLab From 67b409c1036e9202f64d647e0e0ca6e4e5cf60c3 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Fri, 27 Nov 2020 16:02:49 +0100 Subject: [PATCH 91/96] sort out tail counting --- Prog/DynamicMatrixArray_mod.F90 | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/Prog/DynamicMatrixArray_mod.F90 b/Prog/DynamicMatrixArray_mod.F90 index 8981a22f..c822c922 100644 --- a/Prog/DynamicMatrixArray_mod.F90 +++ b/Prog/DynamicMatrixArray_mod.F90 @@ -46,7 +46,7 @@ module DynamicMatrixArray_mod type :: DynamicMatrixArray integer :: avamem ! amount of available space - integer :: tail ! last index + integer :: tail ! last valid Fortran index Type(OpTbasePtrWrapper), allocatable, dimension(:) :: data ! actual effective array of the pointers contains procedure :: init => DynamicMatrixArray_init @@ -72,7 +72,7 @@ contains subroutine DynamicMatrixArray_init(this) class(DynamicMatrixArray) :: this type(OpTbasePtrWrapper) :: temp - this%tail = 1 + this%tail = 0 !when the vector has no content this is invalid memory this%avamem = 4096/(STORAGE_SIZE(temp)/8) ! allocate a page of memory ! Note STORAGE_SIZE: F2008, SIZEOF: GCC Extension allocate(this%data(this%avamem)) end subroutine DynamicMatrixArray_init @@ -96,7 +96,7 @@ end subroutine !> The ALF Project contributors ! !> @brief -!> Attach a pointer to the object givenby itm at the end of the vector. +!> Attach a pointer to the object given by itm at the end of the vector. !> If out of space the vector grows. !> !> @param[inout] this the vector @@ -120,8 +120,8 @@ subroutine DynamicMatrixArray_pushback(this, itm) deallocate(temp) this%avamem = 2*this%avamem endif - this%data(this%tail)%dat => itm ! let the pointer point to the object this%tail = this%tail + 1 + this%data(this%tail)%dat => itm ! let the pointer point to the object end subroutine !-------------------------------------------------------------------- @@ -150,14 +150,14 @@ end function !> returns the pointer to the last element !> !> @param[inout] this the vector. -!> @param[out] itm the element at the end of the vector. +!> @return itm the element at the end of the vector. ! !-------------------------------------------------------------------- -subroutine DynamicMatrixArray_back(this, itm) +function DynamicMatrixArray_back(this) result(itm) class(DynamicMatrixArray), intent(in) :: this - class(ContainerElementBase), intent(out), pointer :: itm - itm => this%data(this%tail-1)%dat -end subroutine + class(ContainerElementBase), pointer :: itm + itm => this%data(this%tail)%dat +end function !-------------------------------------------------------------------- !> @author @@ -173,7 +173,7 @@ end subroutine function DynamicMatrixArray_length(this) result(l) class(DynamicMatrixArray) :: this integer :: l - l = this%tail-1 + l = this%tail end function end module DynamicMatrixArray_mod -- GitLab From a86aa095b09586031d75e3b9aea0bfb63f0624c3 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Fri, 27 Nov 2020 16:09:56 +0100 Subject: [PATCH 92/96] Use Jonas' suggestion for a better name. --- Prog/Hop_mod.F90 | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/Prog/Hop_mod.F90 b/Prog/Hop_mod.F90 index 1481f405..54f3eec7 100644 --- a/Prog/Hop_mod.F90 +++ b/Prog/Hop_mod.F90 @@ -54,7 +54,7 @@ use iso_fortran_env, only: output_unit, error_unit ! Private variables - Type(DynamicMatrixArray), private, allocatable :: vec(:) ! for now we have for simplicity for each flavour a vector + Type(DynamicMatrixArray), private, allocatable :: ExpOpT_vec(:) ! for now we have for simplicity for each flavour a vector Complex (Kind=Kind(0.d0)), allocatable, private :: U_HLP(:,:), U_HLP1(:,:), V_HLP(:,:), V_HLP1(:,:) Integer, private, save :: Ncheck, Ndim_hop Real (Kind=Kind(0.d0)), private, save :: Zero @@ -70,15 +70,15 @@ !> processing that occurs in mapping an OpT input matrix to the internal !> matrix-like data structure. ! -!> @param vec[inout] a DynamicMatrixArray structure to which we append new elements. +!> @param ExpOpT_vec[inout] a DynamicMatrixArray structure to which we append new elements. !> @param op[in] an Operator that describes an OpT hopping matrix. ! !-------------------------------------------------------------------- - subroutine OpT_postprocess(vec, op) + subroutine OpT_postprocess(ExpOpT_vec, op) use Operator_mod implicit none - Type(DynamicMatrixArray), intent(inout) :: vec + Type(DynamicMatrixArray), intent(inout) :: ExpOpT_vec Type(Operator), intent(in) :: op Class(CmplxExpOpT), pointer :: cmplxexp => null() @@ -88,12 +88,12 @@ ! branch for real operators allocate(realexp) ! Yep, this is a manifest memory leak. Using the ptr we can allocate onto the same variable call realexp%init(op) - call vec%pushback(realexp) + call ExpOpT_vec%pushback(realexp) else ! branch for complex operators allocate(cmplxexp) call cmplxexp%init(op) - call vec%pushback(cmplxexp) + call ExpOpT_vec%pushback(cmplxexp) endif end subroutine @@ -130,7 +130,7 @@ enddo enddo - allocate(vec(N_FL)) + allocate(ExpOpT_vec(N_FL)) Allocate ( V_Hlp(Ndim_hop,Ndim) ) Allocate ( V_Hlp1(Ndim_hop,Ndim) ) @@ -138,9 +138,9 @@ Allocate ( U_Hlp1(Ndim, Ndim_hop) ) do nf = 1,N_FL - call vec(nf)%init() + call ExpOpT_vec(nf)%init() do nc = 1,Ncheck - call OpT_postprocess(vec(nf), Op_T(nc, nf)) + call OpT_postprocess(ExpOpT_vec(nf), Op_T(nc, nf)) enddo enddo @@ -163,7 +163,7 @@ class(ContainerElementBase), pointer :: dummy do nc = Ncheck,1,-1 - dummy => vec(nf)%at(nc) + dummy => ExpOpT_vec(nf)%at(nc) call dummy%lmult(In) Enddo end Subroutine Hop_mod_mmthr @@ -182,7 +182,7 @@ class(ContainerElementBase), pointer :: dummy do nc = 1,Ncheck - dummy => vec(nf)%at(nc) + dummy => ExpOpT_vec(nf)%at(nc) call dummy%lmultinv(In) Enddo @@ -204,7 +204,7 @@ class(ContainerElementBase), pointer :: dummy do nc = 1, Ncheck - dummy => vec(nf)%at(nc) + dummy => ExpOpT_vec(nf)%at(nc) call dummy%rmult(In) Enddo @@ -226,7 +226,7 @@ class(ContainerElementBase), pointer :: dummy do nc = 1, Ncheck - dummy => vec(nf)%at(nc) + dummy => ExpOpT_vec(nf)%at(nc) call dummy%lmult(In) Enddo @@ -248,7 +248,7 @@ class(ContainerElementBase), pointer :: dummy do nc = Ncheck,1,-1 - dummy => vec(nf)%at(nc) + dummy => ExpOpT_vec(nf)%at(nc) call dummy%rmultinv(In) Enddo @@ -293,7 +293,7 @@ Out = In Do nf = 1, size(In,3) do nc = Ncheck,1,-1 - dummy => vec(nf)%at(nc) + dummy => ExpOpT_vec(nf)%at(nc) call dummy%adjointaction(Out(:, :, nf)) enddo enddo -- GitLab From 1a73d5f704fdaf8ed50fd849719c212514db4475 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Fri, 27 Nov 2020 16:36:22 +0100 Subject: [PATCH 93/96] fix some NAG warnings --- Prog/DynamicMatrixArray_mod.F90 | 2 +- Prog/OpTTypes_mod.F90 | 4 ++-- Prog/Operator_mod.F90 | 1 - 3 files changed, 3 insertions(+), 4 deletions(-) diff --git a/Prog/DynamicMatrixArray_mod.F90 b/Prog/DynamicMatrixArray_mod.F90 index c822c922..577f20b8 100644 --- a/Prog/DynamicMatrixArray_mod.F90 +++ b/Prog/DynamicMatrixArray_mod.F90 @@ -105,7 +105,7 @@ end subroutine !-------------------------------------------------------------------- subroutine DynamicMatrixArray_pushback(this, itm) class(DynamicMatrixArray) :: this - class(ContainerElementBase), intent(in), target :: itm ! Type(...) always has to match exactly, class(...) allows for polymorphism + class(ContainerElementBase), intent(in), target :: itm !Type(...) has to match exactly, class(...) allows for polymorphism type(OpTbasePtrWrapper), allocatable, dimension(:) :: temp integer :: i diff --git a/Prog/OpTTypes_mod.F90 b/Prog/OpTTypes_mod.F90 index 6bc638b4..0d661034 100644 --- a/Prog/OpTTypes_mod.F90 +++ b/Prog/OpTTypes_mod.F90 @@ -46,7 +46,7 @@ module OpTTypes_mod !> !-------------------------------------------------------------------- type, extends(ContainerElementBase) :: RealExpOpT - Real(kind=kind(0.d0)), allocatable, dimension(:,:) :: mat, invmat, mat_1D2, invmat_1D2 !> We store the matrix here in the class + Real(kind=kind(0.d0)), allocatable, dimension(:,:) :: mat, invmat, mat_1D2, invmat_1D2 !>We store the matrix in the class Real(kind=kind(0.d0)) :: g, Zero integer, pointer :: P(:) Integer :: m, n, Ndim_hop @@ -70,7 +70,7 @@ module OpTTypes_mod !> !-------------------------------------------------------------------- type, extends(ContainerElementBase) :: CmplxExpOpT - Complex(kind=kind(0.d0)), allocatable, dimension(:,:) :: mat, invmat, mat_1D2, invmat_1D2 !> We store the matrix here in the class + Complex(kind=kind(0.d0)), allocatable, dimension(:,:) :: mat, invmat, mat_1D2, invmat_1D2 !>We store the matrix inclass Complex(kind=kind(0.d0)) :: g Real(kind=kind(0.d0)) :: Zero integer, pointer :: P(:) diff --git a/Prog/Operator_mod.F90 b/Prog/Operator_mod.F90 index f17a1ba1..c8b86a96 100644 --- a/Prog/Operator_mod.F90 +++ b/Prog/Operator_mod.F90 @@ -420,7 +420,6 @@ Contains !-------------------------------------------------------------------- subroutine Op_mmultL(Mat,Op,spin,cop) Implicit none - Integer :: Ndim Type (Operator) , INTENT(IN) :: Op Complex (Kind=Kind(0.d0)), INTENT(INOUT) :: Mat (:,:) Real (Kind=Kind(0.d0)), INTENT(IN) :: spin -- GitLab From 159837117bf3980c0b93e0ea58a0109949b2b6f7 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Sun, 29 Nov 2020 21:40:58 +0100 Subject: [PATCH 94/96] Fakher says the _HLP arrays are not needed anymore... --- Prog/Hop_mod.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/Prog/Hop_mod.F90 b/Prog/Hop_mod.F90 index 54f3eec7..b9e6a067 100644 --- a/Prog/Hop_mod.F90 +++ b/Prog/Hop_mod.F90 @@ -55,7 +55,6 @@ ! Private variables Type(DynamicMatrixArray), private, allocatable :: ExpOpT_vec(:) ! for now we have for simplicity for each flavour a vector - Complex (Kind=Kind(0.d0)), allocatable, private :: U_HLP(:,:), U_HLP1(:,:), V_HLP(:,:), V_HLP1(:,:) Integer, private, save :: Ncheck, Ndim_hop Real (Kind=Kind(0.d0)), private, save :: Zero -- GitLab From 96d94f98825fd2e970959774c1057a1eb8da22e6 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Sun, 29 Nov 2020 21:42:53 +0100 Subject: [PATCH 95/96] Fakher says the _HLP arrays are not needed anymore... --- Prog/Hop_mod.F90 | 5 ----- 1 file changed, 5 deletions(-) diff --git a/Prog/Hop_mod.F90 b/Prog/Hop_mod.F90 index b9e6a067..0e1a8723 100644 --- a/Prog/Hop_mod.F90 +++ b/Prog/Hop_mod.F90 @@ -131,11 +131,6 @@ allocate(ExpOpT_vec(N_FL)) - Allocate ( V_Hlp(Ndim_hop,Ndim) ) - Allocate ( V_Hlp1(Ndim_hop,Ndim) ) - Allocate ( U_Hlp (Ndim, Ndim_hop) ) - Allocate ( U_Hlp1(Ndim, Ndim_hop) ) - do nf = 1,N_FL call ExpOpT_vec(nf)%init() do nc = 1,Ncheck -- GitLab From 9128f2cde9de630646cfa26d55327103a3333cd2 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Sun, 29 Nov 2020 21:46:35 +0100 Subject: [PATCH 96/96] remove the array restrictions on different Op_Ts --- Prog/Hop_mod.F90 | 18 +++--------------- 1 file changed, 3 insertions(+), 15 deletions(-) diff --git a/Prog/Hop_mod.F90 b/Prog/Hop_mod.F90 index 0e1a8723..3da8911b 100644 --- a/Prog/Hop_mod.F90 +++ b/Prog/Hop_mod.F90 @@ -55,7 +55,7 @@ ! Private variables Type(DynamicMatrixArray), private, allocatable :: ExpOpT_vec(:) ! for now we have for simplicity for each flavour a vector - Integer, private, save :: Ncheck, Ndim_hop + Integer, private, save :: Ncheck Real (Kind=Kind(0.d0)), private, save :: Zero Contains @@ -107,28 +107,16 @@ ! !-------------------------------------------------------------------- subroutine Hop_mod_init - Implicit none - Integer :: nc, nf, i,j - Complex (Kind=Kind(0.d0)) :: g + Integer :: nc, nf Ncheck = size(Op_T,1) If ( size(Op_T,2) /= N_FL ) then Write(error_unit,*) 'Hop_mod_init: Error in the number of flavors.' error stop 1 Endif - Ndim_hop = Op_T(1,1)%N - !Write(6,*) 'In Hop_mod: ', Ndim, Ndim_hop, Ncheck - Do nc = 1, Ncheck - do nf = 1,N_FL - if ( Ndim_hop /= Op_T(nc,nf)%N ) Then - Write(error_unit,*) 'Hop_mod_init: Different size of Hoppings not implemented ' - error stop 1 - endif - enddo - enddo - + allocate(ExpOpT_vec(N_FL)) do nf = 1,N_FL -- GitLab