diff --git a/Prog/Global_mod.F90 b/Prog/Global_mod.F90 index b36430f410aa36a1c9acc1197b1918e0229dc151..00a788b3818ba4a15912092cd519eaf4c2b68725 100644 --- a/Prog/Global_mod.F90 +++ b/Prog/Global_mod.F90 @@ -966,7 +966,7 @@ Module Global_mod Character (len=64) :: Filename N = 1 Filename = "Acc_Temp" - Call Obser_Vec_make(Tempering_acceptance,N,Filename) + Call Tempering_acceptance%make(N,Filename) End Subroutine Global_Tempering_setup !-------------------------------------------------------------------- @@ -978,7 +978,7 @@ Module Global_mod !-------------------------------------------------------------------- Subroutine Global_Tempering_init_obs - Call Obser_vec_Init( Tempering_acceptance ) + Call Tempering_acceptance%Init() end Subroutine Global_Tempering_init_obs !-------------------------------------------------------------------- @@ -993,9 +993,11 @@ Module Global_mod Implicit none Logical, intent(in) :: toggle - Tempering_acceptance%N = Tempering_acceptance%N + 1 - Tempering_acceptance%Ave_sign = Tempering_acceptance%Ave_sign + 1.d0 - if (toggle) Tempering_acceptance%Obs_vec(1) = Tempering_acceptance%Obs_vec(1) + cmplx(1.d0,0.d0,kind(0.d0)) + if (toggle) then + call Tempering_acceptance%measure( [cmplx(1.d0,0.d0,kind(0.d0))] ) + else + call Tempering_acceptance%measure( [cmplx(0.d0,0.d0,kind(0.d0))] ) + endif end Subroutine Global_Tempering_obser !-------------------------------------------------------------------- @@ -1007,7 +1009,7 @@ Module Global_mod !-------------------------------------------------------------------- Subroutine Global_Tempering_Pr Implicit none - Call Print_bin_Vec(Tempering_acceptance,Group_Comm) + Call Tempering_acceptance%print_bin(Group_Comm) end Subroutine Global_Tempering_Pr diff --git a/Prog/Hamiltonians/Hamiltonian_Hubbard_include.h b/Prog/Hamiltonians/Hamiltonian_Hubbard_include.h index 5a86b262d06c4e1f6628a47559a7a7036a2f0582..51e1cc492518cd8f4bd00ce84dd7835c2ca4555e 100644 --- a/Prog/Hamiltonians/Hamiltonian_Hubbard_include.h +++ b/Prog/Hamiltonians/Hamiltonian_Hubbard_include.h @@ -1,9 +1,9 @@ - + !-------------------------------------------------------------------- -!> @author +!> @author !> ALF Collaboration !> -!> @brief +!> @brief !> Prints out the bins. No need to change this routine. !------------------------------------------------------------------- Subroutine Pr_obs(LTAU) @@ -11,13 +11,13 @@ Implicit none Integer, Intent(In) :: Ltau - - !Local + + !Local Integer :: I Do I = 1,Size(Obs_scal,1) - Call Print_bin_Vec(Obs_scal(I),Group_Comm) + Call Obs_scal(I)%print_bin(Group_Comm) enddo Do I = 1,Size(Obs_eq,1) Call Print_bin_Latt(Obs_eq(I),Latt,dtau,Group_Comm) @@ -31,23 +31,23 @@ end Subroutine Pr_obs !-------------------------------------------------------------------- -!> @author +!> @author !> ALF Collaboration !> -!> @brief +!> @brief !> Initializes observables to zero before each bins. No need to change !> this routine. !------------------------------------------------------------------- - Subroutine Init_obs(Ltau) + Subroutine Init_obs(Ltau) Implicit none Integer, Intent(In) :: Ltau - - ! Local + + ! Local Integer :: I Do I = 1,Size(Obs_scal,1) - Call Obser_vec_Init(Obs_scal(I)) + Call Obs_scal(I)%init() Enddo Do I = 1,Size(Obs_eq,1) @@ -63,7 +63,7 @@ end Subroutine Init_obs !-------------------------------------------------------------------- -!> @author +!> @author !> ALF Collaboration !> !> @brief @@ -101,8 +101,8 @@ Subroutine Global_move_tau(T0_Proposal_ratio, S0_ratio, & & Flip_list, Flip_length,Flip_value,ntau) - - Implicit none + + Implicit none Real (Kind = Kind(0.d0)),INTENT(OUT) :: T0_Proposal_ratio, S0_ratio Integer , INTENT(OUT) :: Flip_list(:) Real (Kind = Kind(0.d0)),INTENT(OUT) :: Flip_value(:) @@ -115,11 +115,11 @@ Real (Kind=Kind(0.d0)) :: T0_proposal Flip_length = nranf(4) - do n = 1,flip_length + do n = 1,flip_length n_op = nranf(size(OP_V,1)) Flip_list(n) = n_op Flip_value(n) = nsigma%flip(n_op,ntau) - If ( OP_V(n_op,1)%type == 1 ) then + If ( OP_V(n_op,1)%type == 1 ) then S0_ratio = S0(n_op,ntau,Flip_value(n)) T0_Proposal = 1.d0 - 1.d0/(1.d0+S0_ratio) ! No move prob If ( T0_Proposal > Ranf_wrap() ) then @@ -132,11 +132,11 @@ S0_ratio = 1.d0 endif Enddo - + end Subroutine Global_move_tau !-------------------------------------------------------------------- -!> @author +!> @author !> ALF Collaboration !> !> @brief @@ -149,22 +149,22 @@ !> the initial field !> \endverbatim !-------------------------------------------------------------------- - Subroutine Hamiltonian_set_nsigma(Initial_field) + Subroutine Hamiltonian_set_nsigma(Initial_field) Implicit none Real (Kind=Kind(0.d0)), allocatable, dimension(:,:), Intent(OUT) :: Initial_field - + end Subroutine Hamiltonian_set_nsigma !-------------------------------------------------------------------- -!> @author +!> @author !> ALF Collaboration !> !> @brief !> This routine allows to user to determine the global_tau sampling parameters at run time !> It is especially usefull if these parameters are dependent on other parameters. -!> +!> !> @details !> \endverbatim !-------------------------------------------------------------------- @@ -175,7 +175,7 @@ end Subroutine Overide_global_tau_sampling_parameters !-------------------------------------------------------------------- -!> @author +!> @author !> ALF Collaboration !> !> @brief @@ -185,7 +185,7 @@ !> a spin flip of Operator n on time slice nt !> @details !-------------------------------------------------------------------- - Real (Kind=Kind(0.d0)) function S0(n,nt,Hs_new) + Real (Kind=Kind(0.d0)) function S0(n,nt,Hs_new) Implicit none !> Operator index Integer, Intent(IN) :: n @@ -193,22 +193,22 @@ Integer, Intent(IN) :: nt !> New local field on time slice nt and operator index n Real (Kind=Kind(0.d0)), Intent(In) :: Hs_new - + Integer :: nt1,I !Write(6,*) "Hi1" - + S0 = 1.d0 - + end function S0 !-------------------------------------------------------------------- -!> @author +!> @author !> ALF Collaboration !> !> @brief !> Global moves -!> +!> !> @details -!> This routine generates a +!> This routine generates a !> global update and returns the propability T0_Proposal_ratio = T0( sigma_out-> sigma_in ) / T0( sigma_in -> sigma_out) !> @param [IN] nsigma_old, Type(Fields) !> \verbatim @@ -216,7 +216,7 @@ !> \endverbatim !> @param [OUT] T0_Proposal_ratio Real !> \verbatimam -!> T0_Proposal_ratio = T0( sigma_new -> sigma_old ) / T0( sigma_old -> sigma_new) +!> T0_Proposal_ratio = T0( sigma_new -> sigma_old ) / T0( sigma_old -> sigma_new) !> \endverbatim !> @param [OUT] Size_clust Real !> \verbatim @@ -225,7 +225,7 @@ !------------------------------------------------------------------- ! Functions for Global moves. These move are not implemented in this example. Subroutine Global_move(T0_Proposal_ratio,nsigma_old,size_clust) - + Implicit none Real (Kind=Kind(0.d0)), intent(out) :: T0_Proposal_ratio, size_clust Type (Fields), Intent(IN) :: nsigma_old @@ -245,15 +245,15 @@ n2 = nranf(N_tau) nsigma%f(n1,n2) = nsigma_old%flip(n1,n2) enddo - + End Subroutine Global_move !-------------------------------------------------------------------- -!> @author +!> @author !> ALF Collaboration !> !> @brief !> Computes the ratio exp(S0(new))/exp(S0(old)) -!> +!> !> @details !> This function computes the ratio \verbatim e^{-S0(nsigma)}/e^{-S0(nsigma_old)} \endverbatim !> @param [IN] nsigma_old, Type(Fields) @@ -264,17 +264,16 @@ Real (Kind=kind(0.d0)) Function Delta_S0_global(Nsigma_old) ! This function computes the ratio: e^{-S0(nsigma)}/e^{-S0(nsigma_old)} - Implicit none - + Implicit none + ! Arguments Type (Fields), INTENT(IN) :: nsigma_old ! Local Integer :: I,n,n1,n2,n3,n4,nt,nt1, nc_F, nc_J, nc_h_p, nc_h_m - + Delta_S0_global = 1.d0 end Function Delta_S0_global - diff --git a/Prog/Hamiltonians/Hamiltonian_Hubbard_mod.F90 b/Prog/Hamiltonians/Hamiltonian_Hubbard_mod.F90 index a86e19b945a336659780b9d9dff11c0ec6f1087a..e640c23705676b7b08126bfc557b40394bd81455 100644 --- a/Prog/Hamiltonians/Hamiltonian_Hubbard_mod.F90 +++ b/Prog/Hamiltonians/Hamiltonian_Hubbard_mod.F90 @@ -487,15 +487,15 @@ Subroutine Ham_V Use Predefined_Int - Implicit none - - Integer :: nf, I, I1, I2, nc, J, no, N_ops + Implicit none + + Integer :: nf, I, I1, I2, nc, J, no, N_ops Real (Kind=Kind(0.d0)) :: X, Zero = 1.D-10 Real (Kind=Kind(0.d0)), allocatable :: Ham_U_vec(:) Allocate (Ham_U_vec(Latt_unit%Norb)) - + N_ops = 0 if ( Lattice_type == "Bilayer_square" .or. Lattice_type =="Bilayer_honeycomb" ) then Ham_U_vec(1) = Ham_U @@ -571,7 +571,7 @@ case default Write(6,*) ' Error in Alloc_obs ' end select - Call Obser_Vec_make(Obs_scal(I),N,Filename) + Call Obs_scal(I)%make(N,Filename) enddo ! Equal time correlators @@ -708,17 +708,12 @@ Enddo ! GRC(i,j,nf) = < c^{dagger}_{j,nf } c_{j,nf } > - ! Compute scalar observables. - Do I = 1,Size(Obs_scal,1) - Obs_scal(I)%N = Obs_scal(I)%N + 1 - Obs_scal(I)%Ave_sign = Obs_scal(I)%Ave_sign + Real(ZS,kind(0.d0)) - Enddo Zkin = cmplx(0.d0, 0.d0, kind(0.D0)) Call Predefined_Hoppings_Compute_Kin(Hopping_Matrix,List,Invlist, Latt, Latt_unit, GRC, ZKin) Zkin = Zkin* dble(N_SUN) - Obs_scal(1)%Obs_vec(1) = Obs_scal(1)%Obs_vec(1) + Zkin *ZP* ZS + call Obs_scal(1)%measure([Zkin], Phase) ZPot = cmplx(0.d0, 0.d0, kind(0.D0)) @@ -731,8 +726,7 @@ if (no_I == 2) ZPot = ZPot + Grc(i1,i1,1) * Grc(i1,i1, dec)* ham_U2 enddo Enddo - - Obs_scal(2)%Obs_vec(1) = Obs_scal(2)%Obs_vec(1) + Zpot * ZP*ZS + call Obs_scal(2)%measure([Zpot], Phase) Zrho = cmplx(0.d0,0.d0, kind(0.D0)) @@ -742,9 +736,8 @@ enddo enddo Zrho = Zrho* dble(N_SUN) - Obs_scal(3)%Obs_vec(1) = Obs_scal(3)%Obs_vec(1) + Zrho * ZP*ZS - - Obs_scal(4)%Obs_vec(1) = Obs_scal(4)%Obs_vec(1) + (Zkin + Zpot)*ZP*ZS + call Obs_scal(3)%measure([Zrho], Phase) + call Obs_scal(4)%measure([Zkin + Zpot], Phase) ! Standard two-point correlations If ( Mz ) then diff --git a/Prog/observables_mod.F90 b/Prog/observables_mod.F90 index 7f4eeac854afea26d491e956fe1e344fa76b664e..ff2d81ca0684436445275d23618c429bdb8d4910 100644 --- a/Prog/observables_mod.F90 +++ b/Prog/observables_mod.F90 @@ -42,13 +42,20 @@ use iso_fortran_env, only: output_unit, error_unit - Type Obser_Vec + Type :: Obser_Vec !> Data structure for !> < O_n > n : =1, size(Obs,1) - Integer :: N ! Number of measurements - real (Kind=Kind(0.d0)) :: Ave_Sign ! Averarge sign + !private + Integer :: N ! Number of measurements + real (Kind=Kind(0.d0)) :: Ave_Sign ! Averarge sign + Character (len=64) :: name ! Name of file in which the bins will be written out complex (Kind=Kind(0.d0)), pointer :: Obs_vec(:) ! Vector of observables - Character (len=64) :: File_Vec ! Name of file in which the bins will be written out + + contains + procedure :: make => Obser_vec_make + procedure :: init => Obser_vec_init + procedure :: print_bin => print_bin_vec + procedure :: measure => Obser_vec_measure end type Obser_Vec @@ -95,22 +102,48 @@ Subroutine Obser_Vec_make(Obs,N,Filename) Implicit none - Type (Obser_vec), intent(INOUT) :: Obs + class(Obser_vec), intent(INOUT) :: Obs Integer, Intent(IN) :: N Character (len=64), Intent(IN) :: Filename Allocate (Obs%Obs_vec(N)) - Obs%File_Vec = Filename + Obs%name = Filename end subroutine Obser_Vec_make !-------------------------------------------------------------------- Subroutine Obser_Vec_Init(Obs) Implicit none - Type (Obser_vec), intent(INOUT) :: Obs + class(Obser_vec), intent(INOUT) :: Obs Obs%Obs_vec = cmplx(0.d0,0.d0,kind(0.d0)) Obs%N = 0 Obs%Ave_Sign= 0.d0 end subroutine Obser_Vec_Init +!-------------------------------------------------------------------- + + Subroutine Obser_vec_measure(obs, value, Phase) + Implicit none + + class(Obser_vec), Intent(Inout) :: Obs + complex(Kind=Kind(0.d0)), Intent(In) :: value(:) ! Vector of observables + complex(Kind=Kind(0.d0)), Intent(IN), optional :: Phase + !Local + Complex (Kind=Kind(0.d0)) :: ZP, ZS + + obs%N = obs%N + 1 + + if ( present(Phase) ) then + ZP = PHASE/Real(Phase, kind(0.D0)) + ZS = Real(Phase, kind(0.D0))/Abs(Real(Phase, kind(0.D0))) + + obs%Ave_sign = obs%Ave_sign + real(ZS, kind(0.D0)) + obs%obs_vec = obs%obs_vec + value *ZS*ZP + else + obs%Ave_sign = obs%Ave_sign + 1.d0 + obs%obs_vec = obs%obs_vec + value + endif + + end Subroutine Obser_vec_measure + !-------------------------------------------------------------------- Subroutine Print_bin_Latt(Obs,Latt,dtau,Group_Comm) @@ -231,7 +264,7 @@ #endif Implicit none - Type (Obser_vec), intent(Inout) :: Obs + class(Obser_vec), intent(Inout) :: Obs Integer, INTENT(IN) :: Group_Comm ! Local @@ -252,7 +285,7 @@ Obs%Obs_vec = Obs%Obs_vec /dble(Obs%N) Obs%Ave_sign = Obs%Ave_sign/dble(Obs%N) File_suff = "_scal" - write(File_pr, '(A,A)') trim(Obs%File_Vec), Trim(File_suff) + write(File_pr, '(A,A)') trim(Obs%name), Trim(File_suff) #if defined(MPI) No = size(Obs%Obs_vec, 1) @@ -270,7 +303,7 @@ if (Irank_g == 0 ) then #endif #if defined(TEMPERING) - write(File_pr,'(A,I0,A,A,A)') "Temp_",igroup,"/",trim(Obs%File_Vec),trim(File_suff) + write(File_pr,'(A,I0,A,A,A)') "Temp_",igroup,"/",trim(Obs%name),trim(File_suff) #endif Open (Unit=10,File=File_pr, status="unknown", position="append") WRITE(10,*) size(Obs%Obs_vec,1)+1, (Obs%Obs_vec(I), I=1,size(Obs%Obs_vec,1)), Obs%Ave_sign