From 76fc0370fa8f5d1871af5a549841ab64b8821198 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Wed, 1 Jun 2016 20:03:21 +0200 Subject: [PATCH 01/11] rearrange the source code to have a common root under src --- Analysis_7/Compile_cov | 14 - Analysis_7/Compile_en | 14 - Analysis_7/Compile_eq | 14 - Analysis_7/Makefile | 19 - Analysis_7/cov_eq.f90 | 238 ---- Analysis_7/cov_tau.f90 | 150 --- Analysis_7/jackv5.f90 | 98 -- Libraries/Makefile | 16 - Libraries/Modules/BIDON | 846 ------------ Libraries/Modules/Compile | 13 - Libraries/Modules/Files_mod.f90 | 15 - Libraries/Modules/Histogram.f90 | 109 -- Libraries/Modules/Histogram_v2.f90 | 123 -- Libraries/Modules/Makefile | 15 - Libraries/Modules/Makefile_Juropa | 15 - Libraries/Modules/Makefile_cl | 14 - Libraries/Modules/Natural_constants.f90 | 16 - Libraries/Modules/Random_Wrap.f90 | 99 -- Libraries/Modules/errors.f90 | 856 ------------ Libraries/Modules/fourier.f90 | 1592 ----------------------- Libraries/Modules/lattices_v3.f90 | 748 ----------- Libraries/Modules/log_mesh.f90 | 318 ----- Libraries/Modules/machine | 1 - Libraries/Modules/mat_mod.f90 | 1265 ------------------ Libraries/Modules/matrix.f90 | 80 -- Libraries/Modules/maxent.f90 | 807 ------------ Libraries/Modules/maxent_stoch.G90 | 964 -------------- Libraries/Modules/maxent_stoch.f90 | 748 ----------- Libraries/Modules/maxent_stoch_w.f90 | 836 ------------ Libraries/Modules/pre1 | 12 - Libraries/Modules/precdef.mod.f90 | 23 - Libraries/Modules/smooth_stoch.f90 | 40 - Libraries/Modules/tmp.f90 | 735 ----------- Libraries/MyEis/Makefile | 11 - Libraries/MyEis/balanc.f | 166 --- Libraries/MyEis/balbak.f | 75 -- Libraries/MyEis/cbabk2.f | 83 -- Libraries/MyEis/cbal.f | 181 --- Libraries/MyEis/cdiv.f | 16 - Libraries/MyEis/cg.f | 63 - Libraries/MyEis/ch.f | 70 - Libraries/MyEis/comp | 1 - Libraries/MyEis/comqr.f | 222 ---- Libraries/MyEis/comqr2.f | 409 ------ Libraries/MyEis/corth.f | 134 -- Libraries/MyEis/csroot.f | 17 - Libraries/MyEis/elmhes.f | 98 -- Libraries/MyEis/eltran.f | 78 -- Libraries/MyEis/epslon.f | 36 - Libraries/MyEis/hqr.f | 234 ---- Libraries/MyEis/hqr2.f | 449 ------- Libraries/MyEis/htribk.f | 91 -- Libraries/MyEis/htridi.f | 154 --- Libraries/MyEis/pythag.f | 20 - Libraries/MyEis/rg.f | 70 - Libraries/MyEis/rs.f | 57 - Libraries/MyEis/tql2.f | 170 --- Libraries/MyEis/tqlrat.f | 130 -- Libraries/MyEis/tred1.f | 135 -- Libraries/MyEis/tred2.f | 164 --- Libraries/MyLin/Makefile | 8 - Libraries/MyLin/bidon | 6 - Libraries/MyLin/cgedi.f | 131 -- Libraries/MyLin/cgefa.f | 107 -- Libraries/MyLin/dgedi.f | 128 -- Libraries/MyLin/dgefa.f | 103 -- Libraries/MyLin/work.pc | Bin 1016 -> 0 bytes Libraries/MyLin/work.pcl | 1 - Libraries/MyLin/zgedi.f | 135 -- Libraries/MyLin/zgefa.f | 111 -- Libraries/MyLin/zqrdc.f | 218 ---- Libraries/MyLin/zqrsl.f | 280 ---- Libraries/MyNag/F01QCF.f | 258 ---- Libraries/MyNag/F01QDF.f | 290 ----- Libraries/MyNag/F01QEF.f | 259 ---- Libraries/MyNag/F01RCF.f | 282 ---- Libraries/MyNag/F01REF.f | 283 ---- Libraries/MyNag/F06AAZ.f | 61 - Libraries/MyNag/F06FBF.f | 44 - Libraries/MyNag/F06FJF.f | 62 - Libraries/MyNag/F06FRF.f | 139 -- Libraries/MyNag/F06FRF.f~ | 139 -- Libraries/MyNag/F06HBF.f | 44 - Libraries/MyNag/F06HRF.f | 164 --- Libraries/MyNag/F06KJF.f | 74 -- Libraries/MyNag/F06QHF.f | 77 -- Libraries/MyNag/F06THF.f | 77 -- Libraries/MyNag/Makefile | 11 - Libraries/MyNag/P01ABF.f | 82 -- Libraries/MyNag/P01ABW.f | 54 - Libraries/MyNag/P01ABY.f | 50 - Libraries/MyNag/P01ABZ.f | 15 - Libraries/MyNag/P01ACF.f | 96 -- Libraries/MyNag/X02AJF.f | 13 - Libraries/MyNag/X04AAF.f | 23 - Libraries/MyNag/X04BAF.f | 30 - Libraries/MyNag/comp | 1 - Libraries/MyNag/work.pc | Bin 2673 -> 0 bytes Libraries/MyNag/work.pcl | 1 - Prog_7/Compile_Hub | 16 - Prog_7/Compile_SPT | 20 - Prog_7/Ham_hop | 0 Prog_7/Ham_obser.f90 | 9 - Prog_7/Hamiltonian_Hub.f90 | 539 -------- Prog_7/Hamiltonian_SPT.f90 | 538 -------- Prog_7/Hop_mod.f90 | 217 --- Prog_7/Makefile | 22 - Prog_7/Operator.f90 | 420 ------ Prog_7/UDV_WRAP.f90 | 135 -- Prog_7/cgr1.f90 | 110 -- Prog_7/cgr2.f90 | 122 -- Prog_7/cgr2_1.f90 | 539 -------- Prog_7/cgr2_2.f90 | 176 --- Prog_7/control_mod.f90 | 142 -- Prog_7/gperp.f90 | 98 -- Prog_7/inconfc.f90 | 126 -- Prog_7/machine | 1 - Prog_7/main.f90 | 449 ------- Prog_7/nranf.f90 | 12 - Prog_7/outconfc.f90 | 57 - Prog_7/print_bin_mod.f90 | 296 ----- Prog_7/tau_m.f90 | 236 ---- Prog_7/upgrade.f90 | 151 --- Prog_7/wrapgrdo.f90 | 82 -- Prog_7/wrapgrup.f90 | 53 - Prog_7/wrapul.f90 | 77 -- Prog_7/wrapur.f90 | 48 - Prog_8/Compile_Hub | 16 - Prog_8/Compile_Ising | 15 - Prog_8/Compile_SPT | 20 - Prog_8/Hamiltonian_Hub.f90 | 539 -------- Prog_8/Hamiltonian_Ising.f90 | 579 --------- Prog_8/Hamiltonian_SPT.f90 | 548 -------- Prog_8/Hop_mod.f90 | 217 --- Prog_8/Makefile | 27 - Prog_8/Operator.f90 | 459 ------- Prog_8/UDV_WRAP.f90 | 135 -- Prog_8/cgr1.f90 | 110 -- Prog_8/cgr2.f90 | 122 -- Prog_8/cgr2_1.f90 | 539 -------- Prog_8/cgr2_2.f90 | 176 --- Prog_8/control_mod.f90 | 142 -- Prog_8/gperp.f90 | 98 -- Prog_8/inconfc.f90 | 126 -- Prog_8/machine | 1 - Prog_8/main.f90 | 449 ------- Prog_8/nranf.f90 | 12 - Prog_8/outconfc.f90 | 57 - Prog_8/print_bin_mod.f90 | 300 ----- Prog_8/tau_m.f90 | 236 ---- Prog_8/upgrade.f90 | 149 --- Prog_8/wrapgrdo.f90 | 82 -- Prog_8/wrapgrup.f90 | 53 - Prog_8/wrapul.f90 | 77 -- Prog_8/wrapur.f90 | 48 - 155 files changed, 28067 deletions(-) delete mode 100644 Analysis_7/Compile_cov delete mode 100644 Analysis_7/Compile_en delete mode 100644 Analysis_7/Compile_eq delete mode 100644 Analysis_7/Makefile delete mode 100644 Analysis_7/cov_eq.f90 delete mode 100644 Analysis_7/cov_tau.f90 delete mode 100644 Analysis_7/jackv5.f90 delete mode 100644 Libraries/Makefile delete mode 100644 Libraries/Modules/BIDON delete mode 100644 Libraries/Modules/Compile delete mode 100644 Libraries/Modules/Files_mod.f90 delete mode 100644 Libraries/Modules/Histogram.f90 delete mode 100644 Libraries/Modules/Histogram_v2.f90 delete mode 100644 Libraries/Modules/Makefile delete mode 100644 Libraries/Modules/Makefile_Juropa delete mode 100644 Libraries/Modules/Makefile_cl delete mode 100644 Libraries/Modules/Natural_constants.f90 delete mode 100644 Libraries/Modules/Random_Wrap.f90 delete mode 100644 Libraries/Modules/errors.f90 delete mode 100644 Libraries/Modules/fourier.f90 delete mode 100644 Libraries/Modules/lattices_v3.f90 delete mode 100644 Libraries/Modules/log_mesh.f90 delete mode 100644 Libraries/Modules/machine delete mode 100644 Libraries/Modules/mat_mod.f90 delete mode 100644 Libraries/Modules/matrix.f90 delete mode 100644 Libraries/Modules/maxent.f90 delete mode 100644 Libraries/Modules/maxent_stoch.G90 delete mode 100644 Libraries/Modules/maxent_stoch.f90 delete mode 100644 Libraries/Modules/maxent_stoch_w.f90 delete mode 100644 Libraries/Modules/pre1 delete mode 100644 Libraries/Modules/precdef.mod.f90 delete mode 100644 Libraries/Modules/smooth_stoch.f90 delete mode 100644 Libraries/Modules/tmp.f90 delete mode 100644 Libraries/MyEis/Makefile delete mode 100644 Libraries/MyEis/balanc.f delete mode 100644 Libraries/MyEis/balbak.f delete mode 100644 Libraries/MyEis/cbabk2.f delete mode 100644 Libraries/MyEis/cbal.f delete mode 100644 Libraries/MyEis/cdiv.f delete mode 100644 Libraries/MyEis/cg.f delete mode 100644 Libraries/MyEis/ch.f delete mode 100644 Libraries/MyEis/comp delete mode 100644 Libraries/MyEis/comqr.f delete mode 100644 Libraries/MyEis/comqr2.f delete mode 100644 Libraries/MyEis/corth.f delete mode 100644 Libraries/MyEis/csroot.f delete mode 100644 Libraries/MyEis/elmhes.f delete mode 100644 Libraries/MyEis/eltran.f delete mode 100644 Libraries/MyEis/epslon.f delete mode 100644 Libraries/MyEis/hqr.f delete mode 100644 Libraries/MyEis/hqr2.f delete mode 100644 Libraries/MyEis/htribk.f delete mode 100644 Libraries/MyEis/htridi.f delete mode 100644 Libraries/MyEis/pythag.f delete mode 100644 Libraries/MyEis/rg.f delete mode 100644 Libraries/MyEis/rs.f delete mode 100644 Libraries/MyEis/tql2.f delete mode 100644 Libraries/MyEis/tqlrat.f delete mode 100644 Libraries/MyEis/tred1.f delete mode 100644 Libraries/MyEis/tred2.f delete mode 100644 Libraries/MyLin/Makefile delete mode 100644 Libraries/MyLin/bidon delete mode 100644 Libraries/MyLin/cgedi.f delete mode 100644 Libraries/MyLin/cgefa.f delete mode 100644 Libraries/MyLin/dgedi.f delete mode 100644 Libraries/MyLin/dgefa.f delete mode 100644 Libraries/MyLin/work.pc delete mode 100644 Libraries/MyLin/work.pcl delete mode 100644 Libraries/MyLin/zgedi.f delete mode 100644 Libraries/MyLin/zgefa.f delete mode 100644 Libraries/MyLin/zqrdc.f delete mode 100644 Libraries/MyLin/zqrsl.f delete mode 100644 Libraries/MyNag/F01QCF.f delete mode 100644 Libraries/MyNag/F01QDF.f delete mode 100644 Libraries/MyNag/F01QEF.f delete mode 100644 Libraries/MyNag/F01RCF.f delete mode 100644 Libraries/MyNag/F01REF.f delete mode 100644 Libraries/MyNag/F06AAZ.f delete mode 100644 Libraries/MyNag/F06FBF.f delete mode 100644 Libraries/MyNag/F06FJF.f delete mode 100644 Libraries/MyNag/F06FRF.f delete mode 100644 Libraries/MyNag/F06FRF.f~ delete mode 100644 Libraries/MyNag/F06HBF.f delete mode 100644 Libraries/MyNag/F06HRF.f delete mode 100644 Libraries/MyNag/F06KJF.f delete mode 100644 Libraries/MyNag/F06QHF.f delete mode 100644 Libraries/MyNag/F06THF.f delete mode 100644 Libraries/MyNag/Makefile delete mode 100644 Libraries/MyNag/P01ABF.f delete mode 100644 Libraries/MyNag/P01ABW.f delete mode 100644 Libraries/MyNag/P01ABY.f delete mode 100644 Libraries/MyNag/P01ABZ.f delete mode 100644 Libraries/MyNag/P01ACF.f delete mode 100644 Libraries/MyNag/X02AJF.f delete mode 100644 Libraries/MyNag/X04AAF.f delete mode 100644 Libraries/MyNag/X04BAF.f delete mode 100644 Libraries/MyNag/comp delete mode 100644 Libraries/MyNag/work.pc delete mode 100644 Libraries/MyNag/work.pcl delete mode 100644 Prog_7/Compile_Hub delete mode 100644 Prog_7/Compile_SPT delete mode 100644 Prog_7/Ham_hop delete mode 100644 Prog_7/Ham_obser.f90 delete mode 100644 Prog_7/Hamiltonian_Hub.f90 delete mode 100644 Prog_7/Hamiltonian_SPT.f90 delete mode 100644 Prog_7/Hop_mod.f90 delete mode 100644 Prog_7/Makefile delete mode 100644 Prog_7/Operator.f90 delete mode 100644 Prog_7/UDV_WRAP.f90 delete mode 100644 Prog_7/cgr1.f90 delete mode 100644 Prog_7/cgr2.f90 delete mode 100644 Prog_7/cgr2_1.f90 delete mode 100644 Prog_7/cgr2_2.f90 delete mode 100644 Prog_7/control_mod.f90 delete mode 100644 Prog_7/gperp.f90 delete mode 100644 Prog_7/inconfc.f90 delete mode 100644 Prog_7/machine delete mode 100644 Prog_7/main.f90 delete mode 100644 Prog_7/nranf.f90 delete mode 100644 Prog_7/outconfc.f90 delete mode 100644 Prog_7/print_bin_mod.f90 delete mode 100644 Prog_7/tau_m.f90 delete mode 100644 Prog_7/upgrade.f90 delete mode 100644 Prog_7/wrapgrdo.f90 delete mode 100644 Prog_7/wrapgrup.f90 delete mode 100644 Prog_7/wrapul.f90 delete mode 100644 Prog_7/wrapur.f90 delete mode 100644 Prog_8/Compile_Hub delete mode 100644 Prog_8/Compile_Ising delete mode 100644 Prog_8/Compile_SPT delete mode 100644 Prog_8/Hamiltonian_Hub.f90 delete mode 100644 Prog_8/Hamiltonian_Ising.f90 delete mode 100644 Prog_8/Hamiltonian_SPT.f90 delete mode 100644 Prog_8/Hop_mod.f90 delete mode 100644 Prog_8/Makefile delete mode 100644 Prog_8/Operator.f90 delete mode 100644 Prog_8/UDV_WRAP.f90 delete mode 100644 Prog_8/cgr1.f90 delete mode 100644 Prog_8/cgr2.f90 delete mode 100644 Prog_8/cgr2_1.f90 delete mode 100644 Prog_8/cgr2_2.f90 delete mode 100644 Prog_8/control_mod.f90 delete mode 100644 Prog_8/gperp.f90 delete mode 100644 Prog_8/inconfc.f90 delete mode 100644 Prog_8/machine delete mode 100644 Prog_8/main.f90 delete mode 100644 Prog_8/nranf.f90 delete mode 100644 Prog_8/outconfc.f90 delete mode 100644 Prog_8/print_bin_mod.f90 delete mode 100644 Prog_8/tau_m.f90 delete mode 100644 Prog_8/upgrade.f90 delete mode 100644 Prog_8/wrapgrdo.f90 delete mode 100644 Prog_8/wrapgrup.f90 delete mode 100644 Prog_8/wrapul.f90 delete mode 100644 Prog_8/wrapur.f90 diff --git a/Analysis_7/Compile_cov b/Analysis_7/Compile_cov deleted file mode 100644 index d3643a78f..000000000 --- a/Analysis_7/Compile_cov +++ /dev/null @@ -1,14 +0,0 @@ -TARGET= cov_tau.out -OBJS= cov_tau.o - - -.SUFFIXES: .f90 .f -.f.o .f90.o: - $(FC) -c -cpp -o $@ $(FLAGS) $< - -$(TARGET): $(OBJS) - $(FC) $(LF) -o $(TARGET) $(OBJS) $(LIBS) - -clean: - rm $(OBJS) - diff --git a/Analysis_7/Compile_en b/Analysis_7/Compile_en deleted file mode 100644 index 8767339d4..000000000 --- a/Analysis_7/Compile_en +++ /dev/null @@ -1,14 +0,0 @@ -TARGET= jackv5.out -OBJS= jackv5.o - - -.SUFFIXES: .f90 .f -.f.o .f90.o: - $(FC) -c -cpp -o $@ $(FLAGS) $< - -$(TARGET): $(OBJS) - $(FC) $(LF) -o $(TARGET) $(OBJS) $(LIBS) - -clean: - rm $(OBJS) - diff --git a/Analysis_7/Compile_eq b/Analysis_7/Compile_eq deleted file mode 100644 index 9613a2271..000000000 --- a/Analysis_7/Compile_eq +++ /dev/null @@ -1,14 +0,0 @@ -TARGET= cov_eq.out -OBJS= cov_eq.o - - -.SUFFIXES: .f90 .f -.f.o .f90.o: - $(FC) -c -cpp -o $@ $(FLAGS) $< - -$(TARGET): $(OBJS) - $(FC) $(LF) -o $(TARGET) $(OBJS) $(LIBS) - -clean: - rm $(OBJS) - diff --git a/Analysis_7/Makefile b/Analysis_7/Makefile deleted file mode 100644 index c92c401c8..000000000 --- a/Analysis_7/Makefile +++ /dev/null @@ -1,19 +0,0 @@ -FC= $(mpif90) -FC= $(f90) -FLAGS= $(FL) -LIBS= $(Libs)/Modules/modules_90.a \ - $(Libs)/MyEis/libeis.a \ - $(Libs)/MyNag/libnag.a \ - $(Libs)/MyLin/liblin.a \ - $(LIB_BLAS_LAPACK) - -all: - cp $(Libs)/Modules/*.mod . ;\ - (make -f Compile_en FC="$(FC)" FLAGS="$(FLAGS)" LIBS="$(LIBS)" ) ;\ - (make -f Compile_cov FC="$(FC)" FLAGS="$(FLAGS)" LIBS="$(LIBS)" ) ;\ - (make -f Compile_eq FC="$(FC)" FLAGS="$(FLAGS)" LIBS="$(LIBS)" ) -clean: - (make -f Compile_eq clean );\ - (make -f Compile_cov clean );\ - (make -f Compile_en clean );\ - rm *.mod *~ \#* *.out diff --git a/Analysis_7/cov_eq.f90 b/Analysis_7/cov_eq.f90 deleted file mode 100644 index 3c3b1d2b8..000000000 --- a/Analysis_7/cov_eq.f90 +++ /dev/null @@ -1,238 +0,0 @@ - Program Cov_eq - - Use Errors - Use MyMats - Use Matrix - Use Lattices_v3 - ! This version of the analysis program requires the information of the lattice, for fourier transforms - ! and for rotations. - - Implicit none - - - - Interface - Integer function Rot90(n, Xk_p, Ndim) - Implicit none - Integer, INTENT(IN) :: Ndim,n - Real (Kind=8), INTENT(IN) :: Xk_p(2,Ndim) - end function Rot90 - end Interface - - Integer :: Ndim, Norb, nr, nx, ny,nk, ierr - Integer :: no, no1, n, n1,m, nbins, n_skip, nb, N_rebin - real (Kind=8):: X, Y - Real (Kind=8), allocatable :: Phase(:) - Type (Mat_C), allocatable :: Bins(:,:), Bins_R(:,:) - Complex (Kind=8), allocatable :: Bins0(:,:) - Complex (Kind=8) :: Z, Xmean,Xerr, Xmean_r,Xerr_r - Real (Kind=8) :: Xk_p(2), XR_p(2) , XR1_p(2) - Complex (Kind=8), allocatable :: V_help(:), V_help_R(:) - Real (Kind=8) :: Pi, a1_p(2), a2_p(2), L1_p(2), L2_p(2), del_p(2) - - Integer :: L1, L2, I - Character (len=64) :: Model, Lattice_type - Type (Lattice) :: Latt - - NAMELIST /VAR_lattice/ L1, L2, Lattice_type, Model - - - OPEN(UNIT=5,FILE='parameters',STATUS='old',ACTION='read',IOSTAT=ierr) - IF (ierr /= 0) THEN - WRITE(*,*) 'unable to open ',ierr - STOP - END IF - READ(5,NML=VAR_lattice) - CLOSE(5) - - If ( Lattice_type =="Square" ) then - a1_p(1) = 1.0 ; a1_p(2) = 0.d0 - a2_p(1) = 0.0 ; a2_p(2) = 1.d0 - L1_p = dble(L1)*a1_p - L2_p = dble(L2)*a2_p - Call Make_Lattice( L1_p, L2_p, a1_p, a2_p, Latt ) - elseif ( Lattice_type=="Honeycomb" ) then - a1_p(1) = 1.0 ; a1_p(2) = 0.d0 - a2_p(1) = 0.5 ; a2_p(2) = sqrt(3.0)/2.0 - del_p = (a2_p - 0.5*a1_p ) * 2.0/3.0 - L1_p = dble(L1) * a1_p - L2_p = dble(L2) * a2_p - Call Make_Lattice( L1_p, L2_p, a1_p, a2_p, Latt ) - Open (Unit=10,File="Lattice", status="unknown") - do I = 1,Latt%N - Xr_p = dble(Latt%list (I,1))*Latt%a1_p + dble(Latt%list (I,2))*Latt%a2_p - Do n = 1,3 - if (n==1) Xr1_p = Xr_p - del_p - if (n==2) Xr1_p = Xr_p - del_p - a1_p + a2_p - if (n==3) Xr1_p = Xr_p + a2_p - del_p - Write(10,"(F14.7,2x,F14.7)") Xr_p (1), Xr_p (2) - Write(10,"(F14.7,2x,F14.7)") Xr1_p(1), Xr1_p(2) - Write(10,*) - enddo - enddo - close(10) - else - Write(6,*) "Lattice not yet implemented!" - Stop - endif - - ! Determine the number of bins. - Pi = acos(-1.d0) - Open ( Unit=10, File="ineq", status="unknown" ) - nbins = 0 - do - Read(10,*,End=10) X,Norb,Ndim - do n = 1,Norb - Read(10,*) Z - enddo - do n = 1,Ndim - Read(10,*) X,Y - do no = 1,Norb - do no1 = 1,Norb - read(10,*) Z - enddo - enddo - enddo - nbins = nbins + 1 - enddo -10 continue - Close(10) - Write(6,*) "# of bins: ", Nbins - n_skip = 1 - nbins = Nbins - n_skip - Write(6,*) "Effective # of bins: ", Nbins - - - ! Allocate space - Allocate ( bins(Ndim,Nbins), bins_r(Ndim,Nbins), Phase(Nbins), V_help(Nbins), V_help_R(Nbins), Bins0(Nbins,Norb)) - Do n = 1,Ndim - do nb = 1,nbins - Call Make_Mat(bins (n,nb),Norb) - Call Make_Mat(bins_r(n,nb),Norb) - bins_r(n,nb)%el = 0.d0 - Enddo - Enddo - Open ( Unit=10, File="ineq", status="unknown" ) - do nb = 1, nbins + n_skip - if (nb > n_skip ) then - Read(10,*,End=10) Phase(nb-n_skip),no,no1 - Do no = 1,Norb - Read(10,*) Bins0(nb-n_skip,no) - enddo - do n = 1,Ndim - Read(10,*) Xk_p(1), Xk_p(2) - m = Inv_K(Xk_p,Latt) - !Write(6,*) m - do no = 1,norb - do no1 = 1,Norb - read(10,*) bins(m,nb-n_skip)%el(no,no1) - enddo - enddo - if ( sqrt(Xk_p(1)**2 + Xk_p(2)**2) < 1.D-6 ) then - do no = 1,norb - do no1 = 1,Norb - bins(m,nb-n_skip)%el(no,no1) = bins(m,nb-n_skip)%el(no,no1) - & - & cmplx(dble(Latt%N),0.d0)*Bins0(nb-n_skip,no)*Bins0(nb-n_skip,no1) - enddo - enddo - endif - enddo - else - Read(10,*,End=10) X,no,no1 - Do no = 1,Norb - Read(10,*) Z - enddo - do n = 1,Ndim - Read(10,*) X,Y - do no = 1,Norb - do no1 = 1,Norb - read(10,*) Z - enddo - enddo - enddo - endif - enddo - close(10) - - - Call Fourier_K_to_R(bins,bins_r,Latt) - - ! Setup symmetries for C4v lattice -#ifdef test - do n = 1,Ndim - n1 = n - Write(6,*) Xk_p(1,n1), Xk_p(2,n1) - do m = 1,4 - n1 = Rot90(n1, Xk_p, Ndim) - Write(6,*) n1, Xk_p(1,n1), Xk_p(2,n1) - enddo - Write(6,*) - enddo -#endif - Open (Unit=33,File="equalJ" ,status="unknown") - N_rebin = 1 - Do n1 = 1,Ndim - n = n1 - do m = 1,1 - V_help = 0.d0 - !n = Rot90(n, Xk_p, Ndim) - do nb = 1,Nbins - do no = 1,Norb - V_help (nb) = V_help (nb) + bins(n,nb)%el(no,no) - enddo - enddo - V_help = V_help/dble(Norb) - call ERRCALCJ(V_help, XMean, XERR, N_rebin ) - Xk_p = dble(Latt%listk(n1,1))*Latt%b1_p + dble(Latt%listk(n1,2))*Latt%b2_p - Write(33,"(F12.6,2x,F12.6,2x,F12.6,2x,F12.6)") & - & Xk_p(1), Xk_p(2), dble(Xmean ), dble(Xerr ) - enddo - enddo - If (Norb > 1 ) then - !Compute susecptibility - Xk_p = 0.d0 - n = Inv_K(Xk_p,Latt) - V_help = 0.d0 - do nb = 1,Nbins - do no = 1,Norb - Do no1 = 1,Norb - V_help (nb) = V_help (nb) + bins(n,nb)%el(no,no1) - enddo - enddo - enddo - call ERRCALCJ(V_help, XMean, XERR, N_rebin ) - Write(33,"('# Suscpetibility: ', F12.6,2x,F12.6)") dble(Xmean ), dble(Xerr ) - endif - Close(33) - - - - end Program Cov_eq - - Integer function Rot90(n, Xk_p, Ndim) - - Implicit none - Integer, INTENT(IN) :: Ndim,n - Real (Kind=8), INTENT(IN) :: Xk_p(2,Ndim) - - !Local - real (Kind=8) :: X1_p(2), Zero, pi, X - Integer :: m - - Zero = 1.D-4 - pi = acos(-1.d0) - X1_p(1) = Xk_p(2,n) - X1_p(2) = -Xk_p(1,n) - if (X1_p(1) < -pi + Zero ) X1_p(1) = X1_p(1) + 2.0*pi - if (X1_p(2) < -pi + Zero ) X1_p(2) = X1_p(2) + 2.0*pi - - Rot90 = 0 - Do m = 1,Ndim - X = sqrt( (X1_p(1) -Xk_p(1,m))**2 + (X1_p(2) -Xk_p(2,m))**2 ) - If ( X < Zero) then - Rot90 = m - exit - endif - Enddo - - end function Rot90 diff --git a/Analysis_7/cov_tau.f90 b/Analysis_7/cov_tau.f90 deleted file mode 100644 index d02f27bed..000000000 --- a/Analysis_7/cov_tau.f90 +++ /dev/null @@ -1,150 +0,0 @@ - Program Cov_tau - - Use Errors - Use MyMats - Use Matrix - Use Precdef - - Implicit none - - Interface - Integer function Rot90(n, Xk_p, Ndim) - Implicit none - Integer, INTENT(IN) :: Ndim,n - Real (Kind=8), INTENT(IN) :: Xk_p(2,Ndim) - end function Rot90 - end Interface - - Integer :: Ndim, Norb - Integer :: no, no1, n, nbins, n_skip, nb, N_rebin, nT, Lt,m,n1 - real (Kind=8):: X, Y, dtau - real (Kind=8), allocatable :: Xmean(:), Xcov(:,:) - Complex (Kind=8) :: Z - Real (Kind=8) :: Zero=1.D-8 - Real (Kind=8), allocatable :: Phase(:) - Real (Kind=8), allocatable :: Bins(:,:,:) - Real (Kind=8), allocatable :: Xk_p(:,:) - Real (Kind=8), allocatable :: V_help(:,:) - Character (len=64) :: File_out - - - ! Determine the number of bins. - Open ( Unit=10, File="intau", status="unknown" ) - nbins = 0 - do - Read(10,*,End=10) X,Norb,Ndim, LT, dtau - do n = 1,Ndim - Read(10,*) X,Y - do nt = 1,LT - do no = 1,Norb - do no1 = 1,Norb - read(10,*) Z - enddo - enddo - enddo - enddo - Write(6,*) nbins - nbins = nbins + 1 - enddo -10 continue - Close(10) - Write(6,*) "# of bins: ", Nbins - n_skip = 1 - nbins = Nbins - n_skip - Write(6,*) "Effective # of bins: ", Nbins - - - - - ! Allocate space - Allocate ( bins(Ndim,Lt,Nbins), Phase(Nbins), Xk_p(2,ndim), V_help(lt,Nbins)) - Allocate (Xmean(Lt), Xcov(Lt,Lt)) - bins = 0.d0 - Open ( Unit=10, File="intau", status="unknown" ) - do nb = 1, nbins + n_skip - if (nb > n_skip ) then - Read(10,*,End=10) Phase(nb-n_skip),no,no1,n, X - do n = 1,Ndim - Read(10,*) Xk_p(1,n), Xk_p(2,n) - do nt = 1,Lt - do no = 1,norb - do no1 = 1,Norb - read(10,*) Z - if (no == no1) bins(n,nt,nb-n_skip) = bins(n,nt,nb-n_skip) + real(Z,Kind=8) - enddo - enddo - enddo - enddo - else - Read(10,*,End=10) X,no,no1,n,Y - do n = 1,Ndim - Read(10,*) X,Y - do nt = 1,LT - do no = 1,Norb - do no1 = 1,Norb - read(10,*) Z - enddo - enddo - enddo - enddo - endif - enddo - close(10) - - - do n = 1,Nbins - Write(6,*) Phase(n) - Enddo - do n = 1,Ndim - V_help = 0.d0 - n1 = n - if ( Xk_p(1,n) >= -zero .and. XK_p(2,n) >= -zero ) then - do m = 1,4 - n1 = Rot90(n1, Xk_p, Ndim) - do nt = 1,LT - do nb = 1,nbins - V_help(nt,nb) = V_help(nt,nb) + bins (n1,nt,nb) - enddo - enddo - enddo - V_help = V_help/4.d0 - call COV(V_help, phase, Xcov, Xmean ) - write(File_out,'("g_",F4.2,"_"F4.2)') Xk_p(1,n), Xk_p(2,n) - Open (Unit=10,File=File_out,status="unknown") - do nt = 1, LT - Write(10,"(F14.7,2x,F16.8,2x,F16.8)") & - & dble(nt-1)*dtau, Xmean(nt), sqrt(abs(dble(Xcov(nt,nt)))) - enddo - close(10) - endif - enddo - - end Program Cov_tau - - Integer function Rot90(n, Xk_p, Ndim) - - Implicit none - Integer, INTENT(IN) :: Ndim,n - Real (Kind=8), INTENT(IN) :: Xk_p(2,Ndim) - - !Local - real (Kind=8) :: X1_p(2), Zero, pi, X - Integer :: m - - Zero = 1.D-4 - pi = acos(-1.d0) - X1_p(1) = Xk_p(2,n) - X1_p(2) = -Xk_p(1,n) - if (X1_p(1) < -pi + Zero ) X1_p(1) = X1_p(1) + 2.0*pi - if (X1_p(2) < -pi + Zero ) X1_p(2) = X1_p(2) + 2.0*pi - - Rot90 = 0 - Do m = 1,Ndim - X = sqrt( (X1_p(1) -Xk_p(1,m))**2 + (X1_p(2) -Xk_p(2,m))**2 ) - If ( X < Zero) then - Rot90 = m - exit - endif - Enddo - - end function Rot90 diff --git a/Analysis_7/jackv5.f90 b/Analysis_7/jackv5.f90 deleted file mode 100644 index 4f97e5abb..000000000 --- a/Analysis_7/jackv5.f90 +++ /dev/null @@ -1,98 +0,0 @@ - Program enerJ - - - Use ERRORS - Implicit none - - REAL (KIND=8), DIMENSION(:,:), ALLOCATABLE :: OBS - REAL (KIND=8), DIMENSION(:), ALLOCATABLE :: EN, SIGN - REAL (KIND=8) :: XM, XERR - - Complex (Kind=8) Z1,Z2,Z3,Z4,Z5 - Integer :: NST, NS, NS1, NS2, NSTEP, NC, NP, NOBS, Nbins, NP_EFF, ISEED, I, IOBS - Integer :: N, NBIN - - ! Count the number of bins - Open (Unit=10, File="ener", status="unknown") - !Open (Unit=12, File="ener_hist", status="unknown") - nbins = 0 - do - read(10,*,End=10) Z1, Z2, Z3, Z4, Z5 - nbins = nbins + 1 - enddo -10 continue - Write(6,*) "# of bins: ", Nbins - Close(10) - !Close(12) - - NP = NBINS - NOBS = 5 - - ALLOCATE(OBS(NP,NOBS)) - ! Error on energy - - !Open (Unit=25, File="statdat1", status="unknown") - !read(25,*) NST, NS1, NS2, NSTEP - !Close(25) - NST = 1; NS1 = 1; NS2 = 2; NSTEP = 1 - !If ( L == 15 ) NST = 10 - !If ( L == 12 ) NST = 8 - !If ( L == 9 ) NST = 3 - !If ( L == 6 ) NST = 2 - !If ( L == 3 ) NST = 2 - OPEN (UNIT=20, FILE='ener', STATUS='old') - NC = 0 - DO N = 1,NP - IF (N.GE.NST) THEN - NC = NC + 1 - READ(20,*) Z1,Z2,Z3, Z4, Z5 - OBS(NC,1) = dble(Z1) - OBS(NC,2) = dble(Z2) - OBS(NC,3) = dble(Z3) - OBS(NC,4) = dble(Z4) - OBS(NC,5) = dble(Z5) - ELSE - READ(20,*) Z1,Z2,Z3, Z4, Z5 - ENDIF - ENDDO - CLOSE(20) -2100 FORMAT(I6,2X,F16.8) - - OPEN (UNIT=21, FILE='enerJ', STATUS='unknown') - WRITE(21,*) 'Effective number of bins, and bins: ', NC, NP - NP_EFF = NC - ALLOCATE (EN(NP_EFF), SIGN(NP_EFF)) - DO IOBS = 1,NOBS - WRITE(21,*) - DO I = 1,NP_EFF - EN (I) = OBS(I,IOBS) - SIGN(I) = OBS(I,NOBS) - ENDDO - IF (IOBS.EQ.1) WRITE(21,*) ' rho ' - IF (IOBS.EQ.2) WRITE(21,*) ' kin ' - IF (IOBS.EQ.3) WRITE(21,*) ' double ' - IF (IOBS.EQ.4) WRITE(21,*) ' Energy ' - IF (IOBS.EQ.5) WRITE(21,*) ' phase ' - DO NBIN = NS1, NS2, NSTEP - if (NBIN.gt.0) then - IF (IOBS.EQ.NOBS .or. Iobs.eq.1 ) then - CALL ERRCALCJ(EN,XM,XERR,NBIN) - else - CALL ERRCALCJ(EN,SIGN,XM,XERR,NBIN) - endif - WRITE(21,2001) IOBS, XM, XERR - ! Test - ! NBOOT = 40 - ! CALL BOOTSTRAP( EN,XM_BS,XERR_BS,NBOOT,ISEED) - ! WRITE(21,2001) IOBS, XM_BS, XERR_BS - ! IF (IOBS == 4) Write(22,"(F14.7,2x,F14.7)") XM/dble(L*L), XERR/dble(L*L) - endif - ENDDO - ENDDO - CLOSE(21) -2001 FORMAT('OBS : ', I4,4x,F12.6,2X, F12.6) - - DEALLOCATE (EN,SIGN,OBS) - - END Program enerJ - diff --git a/Libraries/Makefile b/Libraries/Makefile deleted file mode 100644 index 4f76ba2c8..000000000 --- a/Libraries/Makefile +++ /dev/null @@ -1,16 +0,0 @@ -FC=$(f90) -FLAGS=$(FL) - -all: - (cd Modules;make FC=$(FC) FLAGS="$(FLAGS)") ;\ - (cd MyEis;make FC=$(FC) FLAGS="$(FLAGS)") ;\ - (cd MyEis;make FC=$(FC) FLAGS="$(FLAGS)") ;\ - (cd MyNag;make FC=$(FC) FLAGS="$(FLAGS)") ;\ - (cd MyLin;make FC=$(FC) FLAGS="$(FLAGS)") - -clean: - (cd Modules;make clean);\ - (cd MyEis;make clean);\ - (cd MyNag;make clean);\ - (cd MyLin;make clean) - diff --git a/Libraries/Modules/BIDON b/Libraries/Modules/BIDON deleted file mode 100644 index 4a69cf8be..000000000 --- a/Libraries/Modules/BIDON +++ /dev/null @@ -1,846 +0,0 @@ -0a1,6 -> -> -> -> -> -> -1a8,9 -> -> -3,9c11,20 -< Use Files_mod -< Integer, private :: NTAU, nt, Ngamma, ng, Ndis, nd, Iseed -< Real (Kind=8), private :: Delta, Delta2, OM_st_1, Om_en_1, DeltaXMAX, Beta, Pi, Dom -< Real (Kind=8), allocatable, private :: XQMC1(:) -< ! You can still optimize a bit for by redefining the Kernel table to: -< ! xker_table(nt,nw) -> xker_table(nt,nw) / sigma(nt) -< ! This will save quite a lot of divisions in the ---- -> Use Files_mod -> -> -> Integer, private :: NTAU, nt, Ngamma, ng, Ndis, nd, Iseed -> Real (Kind=8), private :: Delta, Delta2, OM_st_1, Om_en_1, DeltaXMAX, Beta, Pi, Dom -> Real (Kind=8), allocatable, private :: XQMC1(:) -> -> ! You can still optimize a bit for by redefining the Kernel table to: -> ! xker_table(nt,nw) -> xker_table(nt,nw) / sigma(nt) -> ! This will save quite a lot of divisions in the -10a22 -> -11a24 -> -13c26,27 -< & Ngamma_1, OM_ST, OM_EN, Ndis_1, Nsweeps, NBins, NWarm, L_cov ) ---- -> & Ngamma_1, OM_ST, OM_EN, Ndis_1, Nsweeps, NBins, NWarm, L_cov ) -> -15c29,34 -< Real (Kind=8), Dimension(:) :: XQMC, Xtau, Alpha_tot ---- -> -> -> -> -> -> Real (Kind=8), Dimension(:) :: XQMC, Xtau, Alpha_tot -17c36 -< Real (Kind=8), External :: XKER, Back_trans_Aom ---- -> Real (Kind=8), External :: XKER, Back_trans_Aom -19,23c38,43 -< Integer :: Nsweeps, NBins, Ngamma_1, Ndis_1, nw, nt1 -< Integer, optional :: L_cov -< ! Local -< Integer lp, NSims, ns, nb, nc, Nwarm, nalp1, nalp2, Nex, p_star, Ndis_table, & -< & io_error, io_error1, i ---- -> Integer :: Nsweeps, NBins, Ngamma_1, Ndis_1, nw, nt1 -> Integer, optional :: L_cov -> -> ! Local -> Integer lp, NSims, ns, nb, nc, Nwarm, nalp1, nalp2, Nex, p_star, Ndis_table, & -> & io_error, io_error1, i -25c45 -< & Xn_tot(:,:,:), En_tot(:) ---- -> & Xn_tot(:,:,:), En_tot(:) -27,29c47,49 -< Real (Kind=8) :: Ranf, En_M, Res, X, Alpha, Acc_1, Acc_2, En, DeltaE, Ratio, D -< Real (Kind=8) :: Aom, om, XMAX, tau -< Real (Kind=8) :: CPUT, CPUTM ---- -> Real (Kind=8) :: Ranf, En_M, Res, X, Alpha, Acc_1, Acc_2, En, DeltaE, Ratio, D -> Real (Kind=8) :: Aom, om, XMAX, tau -> Real (Kind=8) :: CPUT, CPUTM -32c52,62 -< Real (Kind=8), allocatable :: Xker_table(:,:), U(:,:), sigma(:) ---- -> Real (Kind=8), allocatable :: Xker_table(:,:), U(:,:), sigma(:) -> -> -> -> -> -> -> -> -> -> -34c64 -< NDis = Ndis_1 ---- -> NDis = Ndis_1 -36,41c66,72 -< delta = 0.001 -< delta2 = delta*delta -< Ngamma = Ngamma_1 -< Beta = Beta_1 ! Physical temperature for calculation of the kernel. -< Ntau = Size(xqmc,1) -< NSims = Size(Alpha_tot,1) ---- -> delta = 0.001 -> delta2 = delta*delta -> Ngamma = Ngamma_1 -> Beta = Beta_1 ! Physical temperature for calculation of the kernel. -> -> Ntau = Size(xqmc,1) -> NSims = Size(Alpha_tot,1) -43c74 -< Allocate (En_m_tot(NSims), En_e_tot(NSims), En_tot(NSims) ) ---- -> Allocate (En_m_tot(NSims), En_e_tot(NSims), En_tot(NSims) ) -44a76 -> -46a79 -> -48,49c81,83 -< ! Setup table for the Kernel -< Ndis_table = 50000 ---- -> -> ! Setup table for the Kernel -> Ndis_table = 50000 -59,61c93,95 -< ! Normalize data to have zeroth moment of unity. -< xqmc = xqmc / XMOM1 -< cov = cov / ((XMOM1)**2) ---- -> ! Normalize data to have zeroth moment of unity. -> xqmc = xqmc / XMOM1 -> cov = cov / ((XMOM1)**2) -62a97 -> -64c99 -< If ( Present(L_cov) ) then ---- -> If ( Present(L_cov) ) then -76c111 -< sigma(nt) = sqrt(sigma(nt)) ---- -> sigma(nt) = sqrt(sigma(nt)) -81c116 -< xqmc1(nt1) = xqmc1(nt1) + xqmc(nt)*U(nt,nt1) ---- -> xqmc1(nt1) = xqmc1(nt1) + xqmc(nt)*U(nt,nt1) -83c118 -< xqmc1(nt1) = xqmc1(nt1)/sigma(nt1) ---- -> xqmc1(nt1) = xqmc1(nt1)/sigma(nt1) -91c126 -< Vhelp(nt1) = Vhelp(nt1) + Xker_table(nt,nw)*U(nt,nt1) ---- -> Vhelp(nt1) = Vhelp(nt1) + Xker_table(nt,nw)*U(nt,nt1) -95c130 -< Xker_table(nt1,nw) = Vhelp(nt1)/sigma(nt1) !! This has changed !! ---- -> Xker_table(nt1,nw) = Vhelp(nt1)/sigma(nt1) !! This has changed !! -98,99c133,134 -< deallocate( U, Sigma ) -< Allocate ( G_Mean(Ntau) ) ---- -> deallocate( U, Sigma ) -> Allocate ( G_Mean(Ntau) ) -101,102c136,138 -< ! write(6,*) ' There are ', Ngamma,' delta-functions for a spectrum' -< ! Write(6,*) ' Initializing' ---- -> -> ! write(6,*) ' There are ', Ngamma,' delta-functions for a spectrum' -> ! Write(6,*) ' Initializing' -104,105c140,143 -< D = 1.d0 / (Om_en_1 - Om_st_1) -< Iseed = 8752143 ---- -> D = 1.d0 / (Om_en_1 - Om_st_1) -> -> Iseed = 8752143 -> -107c145,146 -< File_Aom = "dump_Aom" ---- -> File_Aom = "dump_Aom" -> -115c154 -< read(41,*) Xn_tot(ng,1,ns), Xn_tot(ng,2,ns) ---- -> read(41,*) Xn_tot(ng,1,ns), Xn_tot(ng,2,ns) -122c161 -< read(42,*) Xn_m_tot(nd,ns), Xn_e_tot(nd,ns) ---- -> read(42,*) Xn_m_tot(nd,ns), Xn_e_tot(nd,ns) -125c164 -< Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") ---- -> Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") -132,133c171,172 -< Xn_tot(ng,1,ns) = ranf(iseed) -< Xn_tot(ng,2,ns) = 1.d0/dble(Ngamma) ---- -> Xn_tot(ng,1,ns) = ranf(iseed) -> Xn_tot(ng,2,ns) = 1.d0/dble(Ngamma) -140,141c179,180 -< nc = 0 -< Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") ---- -> nc = 0 -> Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") -147c186,187 -< CALL SYSTEM_CLOCK(COUNT_RATE=N_P_SEC) ---- -> -> CALL SYSTEM_CLOCK(COUNT_RATE=N_P_SEC) -157,158c197,198 -< Call MC(Xtau, Xker_table, Xn, Alpha, NSweeps, Xn_m, En, En_m, & -< & Acc_1, Acc_2 ) ! Just one bin ---- -> Call MC(Xtau, Xker_table, Xn, Alpha, NSweeps, Xn_m, En, En_m, & -> & Acc_1, Acc_2 ) ! Just one bin -163,165c203,205 -< En_tot(ns) = En ! this is the energy of the configuration Xn_tot for simulation ns -< Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") -< Write(44,2003) 1.d0/Alpha, En_m, Acc_1, Acc_2 ---- -> En_tot(ns) = En ! this is the energy of the configuration Xn_tot for simulation ns -> Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") -> Write(44,2003) 1.d0/Alpha, En_m, Acc_1, Acc_2 -166a207 -> -170c211 -< Xn_m(nd) = Xn_m(nd) * D * dble(Ndis) ---- -> Xn_m(nd) = Xn_m(nd) * D * dble(Ndis) -178c219 -< ! Exchange ---- -> ! Exchange -181c222 -< nalp1= nint( ranf(iseed)*dble(NSims-1) + 0.5 ) ! 1..(NSims-1) ---- -> nalp1= nint( ranf(iseed)*dble(NSims-1) + 0.5 ) ! 1..(NSims-1) -183,184c224,225 -< DeltaE = (Alpha_tot(nalp1)*En_tot(nalp2) + Alpha_tot(nalp2)*En_tot(nalp1))& -< & -(Alpha_tot(nalp1)*En_tot(nalp1) + Alpha_tot(nalp2)*En_tot(nalp2)) ---- -> DeltaE = (Alpha_tot(nalp1)*En_tot(nalp2) + Alpha_tot(nalp2)*En_tot(nalp1))& -> & -(Alpha_tot(nalp1)*En_tot(nalp1) + Alpha_tot(nalp2)*En_tot(nalp2)) -186c227 -< if (Ratio.gt.ranf(iseed)) Then ---- -> if (Ratio.gt.ranf(iseed)) Then -190,191c231,232 -< Xn(ng,1) = Xn_tot(ng,1,nalp1) -< Xn(ng,2) = Xn_tot(ng,2,nalp1) ---- -> Xn(ng,1) = Xn_tot(ng,1,nalp1) -> Xn(ng,2) = Xn_tot(ng,2,nalp1) -194,197c235,238 -< Xn_tot(ng,1,nalp1) = Xn_tot(ng,1,nalp2) -< Xn_tot(ng,2,nalp1) = Xn_tot(ng,2,nalp2) -< Xn_tot(ng,1,nalp2) = Xn(ng,1) -< Xn_tot(ng,2,nalp2) = Xn(ng,2) ---- -> Xn_tot(ng,1,nalp1) = Xn_tot(ng,1,nalp2) -> Xn_tot(ng,2,nalp1) = Xn_tot(ng,2,nalp2) -> Xn_tot(ng,1,nalp2) = Xn(ng,1) -> Xn_tot(ng,2,nalp2) = Xn(ng,2) -205c246,247 -< Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") ---- -> -> Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") -208a251 -> -212c255 -< Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") ---- -> Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") -215c258 -< ! dump so as to restart. ---- -> ! dump so as to restart. -221c264 -< write(41,*) Xn_tot(ng,1,ns), Xn_tot(ng,2,ns) ---- -> write(41,*) Xn_tot(ng,1,ns), Xn_tot(ng,2,ns) -228c271 -< write(42,*) Xn_m_tot(nd,ns), Xn_e_tot(nd,ns) ---- -> write(42,*) Xn_m_tot(nd,ns), Xn_e_tot(nd,ns) -233a277,280 -> -> -> -> -236,237c283,284 -< En_m_tot(ns) = En_m_tot(ns) / dble(nc) -< En_e_tot(ns) = En_e_tot(ns) / dble(nc) ---- -> En_m_tot(ns) = En_m_tot(ns) / dble(nc) -> En_e_tot(ns) = En_e_tot(ns) / dble(nc) -246a294 -> -252,253c300,301 -< Xn_m_tot(nd,ns) = Xn_m_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) -< Xn_e_tot(nd,ns) = Xn_e_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) ---- -> Xn_m_tot(nd,ns) = Xn_m_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) -> Xn_e_tot(nd,ns) = Xn_e_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) -255c303 -< if (Xn_e_tot(nd,ns).gt.0.d0) then ---- -> if (Xn_e_tot(nd,ns).gt.0.d0) then -264c312 -< ! PhiM1(dble(nd)/dble(NDis)), Xn_m_tot(nd,ns) ---- -> ! PhiM1(dble(nd)/dble(NDis)), Xn_m_tot(nd,ns) -267a316 -> -269c318 -< File_root ="Aom_ps" ---- -> File_root ="Aom_ps" -275,276c324,325 -< Xn_m(nd) = Xn_m(nd) + (En_m_tot(ns) - En_m_tot(ns+1))*Xn_m_tot(nd,ns) -< Xn_e(nd) = Xn_e(nd) + (En_m_tot(ns) - En_m_tot(ns+1))*Xn_e_tot(nd,ns) ---- -> Xn_m(nd) = Xn_m(nd) + (En_m_tot(ns) - En_m_tot(ns+1))*Xn_m_tot(nd,ns) -> Xn_e(nd) = Xn_e(nd) + (En_m_tot(ns) - En_m_tot(ns+1))*Xn_e_tot(nd,ns) -290,291c339,340 -< Xn_m(nd) = Back_Trans_Aom(Aom,Beta,om) -< Xn_e(nd) = Back_Trans_Aom(Err,Beta,om) ---- -> Xn_m(nd) = Back_Trans_Aom(Aom,Beta,om) -> Xn_e(nd) = Back_Trans_Aom(Err,Beta,om) -299c348 -< close(66) ---- -> close(66) -300a350 -> -303c353 -< Write(41,*) Phim1(Xn_tot(ng,1,Nsims)) , Xn_tot(ng,2,Nsims) ---- -> Write(41,*) Phim1(Xn_tot(ng,1,Nsims)) , Xn_tot(ng,2,Nsims) -305a356 -> -307c358 -< DeAllocate (En_m_tot, En_e_tot, En_tot ) ---- -> DeAllocate (En_m_tot, En_e_tot, En_tot ) -314,317c365,370 -< 2001 format(F14.7,2x,F14.7,2x,F14.7) -< 2004 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7) -< 2005 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7,2x,F14.7) -< 2003 format('Alpha, En_m, Acc ', F14.7,2x,F24.12,2x,F14.7,2x,F14.7,2x,F14.7) ---- -> -> -> 2001 format(F14.7,2x,F14.7,2x,F14.7) -> 2004 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7) -> 2005 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7,2x,F14.7) -> 2003 format('Alpha, En_m, Acc ', F14.7,2x,F24.12,2x,F14.7,2x,F14.7,2x,F14.7) -318a372,373 -> -> -321,322c376,378 -< & Ngamma_1, OM_ST, OM_EN, Nsweeps, NBins, NWarm, Aom_res,& -< & xom_res, Chisq ) ---- -> & Ngamma_1, OM_ST, OM_EN, Nsweeps, NBins, NWarm, Aom_res,& -> & xom_res, Chisq ) -> -324c380 -< Real (Kind=8), Dimension(:) :: XQMC, Xtau, Alpha_tot, Aom_res, Xom_res ---- -> Real (Kind=8), Dimension(:) :: XQMC, Xtau, Alpha_tot, Aom_res, Xom_res -326c382 -< Real (Kind=8), external :: XKER ---- -> Real (Kind=8), external :: XKER -328,330c384,387 -< Integer :: Nsweeps, NBins, Ngamma_1, Ndis_1, nw, nt1, Lcov -< ! Local -< Integer lp, NSims, ns, nb, nc, Nwarm, nalp1, nalp2, Nex, p_star ---- -> Integer :: Nsweeps, NBins, Ngamma_1, Ndis_1, nw, nt1, Lcov -> -> ! Local -> Integer lp, NSims, ns, nb, nc, Nwarm, nalp1, nalp2, Nex, p_star -332c389 -< & Xn_tot(:,:,:), En_tot(:), Xker_table(:,:) ---- -> & Xn_tot(:,:,:), En_tot(:), Xker_table(:,:) -336c393,395 -< Real (Kind=8), allocatable :: U(:,:), sigma(:) ---- -> Real (Kind=8), allocatable :: U(:,:), sigma(:) -> -> -338,339c397,398 -< Iseed = 8752143 -< NDis = Size(Aom_res,1) ---- -> Iseed = 8752143 -> NDis = Size(Aom_res,1) -341,346c400,406 -< delta = 0.001 -< delta2 = delta*delta -< Ngamma = Ngamma_1 -< Beta = Beta_1 ! Physical temperature for calculation of the kernel. -< Ntau = Size(xqmc,1) -< NSims = Size(Alpha_tot,1) ---- -> delta = 0.001 -> delta2 = delta*delta -> Ngamma = Ngamma_1 -> Beta = Beta_1 ! Physical temperature for calculation of the kernel. -> -> Ntau = Size(xqmc,1) -> NSims = Size(Alpha_tot,1) -348c408 -< Allocate (En_m_tot(NSims), En_e_tot(NSims), En_tot(NSims) ) ---- -> Allocate (En_m_tot(NSims), En_e_tot(NSims), En_tot(NSims) ) -349a410 -> -351a413 -> -353,354c415,417 -< ! Setup table for the Kernel -< Ndis = Size(Aom_res) ---- -> -> ! Setup table for the Kernel -> Ndis = Size(Aom_res) -365,367c428,431 -< ! Normalize data to have zeroth moment of unity. -< xqmc = xqmc / XMOM1 -< cov = cov / ((XMOM1)**2) ---- -> -> ! Normalize data to have zeroth moment of unity. -> xqmc = xqmc / XMOM1 -> cov = cov / ((XMOM1)**2) -368a433 -> -373c438 -< sigma(nt) = sqrt(sigma(nt)) ---- -> sigma(nt) = sqrt(sigma(nt)) -378c443 -< xqmc1(nt1) = xqmc1(nt1) + xqmc(nt)*U(nt,nt1) ---- -> xqmc1(nt1) = xqmc1(nt1) + xqmc(nt)*U(nt,nt1) -380c445 -< xqmc1(nt1) = xqmc1(nt1)/sigma(nt1) ---- -> xqmc1(nt1) = xqmc1(nt1)/sigma(nt1) -388c453 -< Vhelp(nt1) = Vhelp(nt1) + Xker_table(nt,nw)*U(nt,nt1) ---- -> Vhelp(nt1) = Vhelp(nt1) + Xker_table(nt,nw)*U(nt,nt1) -392c457 -< Xker_table(nt1,nw) = Vhelp(nt1)/sigma(nt1) !! This has changed !! ---- -> Xker_table(nt1,nw) = Vhelp(nt1)/sigma(nt1) !! This has changed !! -400c465 -< sigma(nt) = 1.d0/sqrt(cov(nt,nt)) ---- -> sigma(nt) = 1.d0/sqrt(cov(nt,nt)) -404c469 -< xqmc1(nt1) = xqmc(nt1)*sigma(nt1) ---- -> xqmc1(nt1) = xqmc(nt1)*sigma(nt1) -410c475 -< Xker_table(nt1,nw) = Xker_table(nt1,nw)*sigma(nt1) !! This has changed !! ---- -> Xker_table(nt1,nw) = Xker_table(nt1,nw)*sigma(nt1) !! This has changed !! -417,418c482,484 -< ! write(6,*) ' There are ', Ngamma,' delta-functions for a spectrum' -< ! Write(6,*) ' Initializing' ---- -> -> ! write(6,*) ' There are ', Ngamma,' delta-functions for a spectrum' -> ! Write(6,*) ' Initializing' -421,422c487,488 -< Xn_tot(ng,1,ns) = ranf(iseed) -< Xn_tot(ng,2,ns) = 1.d0/dble(Ngamma) ---- -> Xn_tot(ng,1,ns) = ranf(iseed) -> Xn_tot(ng,2,ns) = 1.d0/dble(Ngamma) -431c497,498 -< Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") ---- -> -> Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") -433c500 -< nc = 0 ---- -> nc = 0 -441,442c508,509 -< Call MC(Xtau, Xker_table, Xn, Alpha, NSweeps, Xn_m, En, En_m, & -< & Acc_1, Acc_2 ) ! Just one bin ---- -> Call MC(Xtau, Xker_table, Xn, Alpha, NSweeps, Xn_m, En, En_m, & -> & Acc_1, Acc_2 ) ! Just one bin -447,448c514,515 -< En_tot(ns) = En ! this is the energy of the configuration Xn_tot for simulation ns -< Write(44,2003) 1.d0/Alpha, En_m, Acc_1, Acc_2 ---- -> En_tot(ns) = En ! this is the energy of the configuration Xn_tot for simulation ns -> Write(44,2003) 1.d0/Alpha, En_m, Acc_1, Acc_2 -452c519 -< Xn_m(nd) = Xn_m(nd) * D * dble(Ndis) ---- -> Xn_m(nd) = Xn_m(nd) * D * dble(Ndis) -460c527 -< ! Exchange ---- -> ! Exchange -463c530 -< nalp1= nint( ranf(iseed)*dble(NSims-1) + 0.5 ) ! 1..(NSims-1) ---- -> nalp1= nint( ranf(iseed)*dble(NSims-1) + 0.5 ) ! 1..(NSims-1) -465,466c532,533 -< DeltaE = (Alpha_tot(nalp1)*En_tot(nalp2) + Alpha_tot(nalp2)*En_tot(nalp1))& -< & -(Alpha_tot(nalp1)*En_tot(nalp1) + Alpha_tot(nalp2)*En_tot(nalp2)) ---- -> DeltaE = (Alpha_tot(nalp1)*En_tot(nalp2) + Alpha_tot(nalp2)*En_tot(nalp1))& -> & -(Alpha_tot(nalp1)*En_tot(nalp1) + Alpha_tot(nalp2)*En_tot(nalp2)) -468c535 -< if (Ratio.gt.ranf(iseed)) Then ---- -> if (Ratio.gt.ranf(iseed)) Then -472,473c539,540 -< Xn(ng,1) = Xn_tot(ng,1,nalp1) -< Xn(ng,2) = Xn_tot(ng,2,nalp1) ---- -> Xn(ng,1) = Xn_tot(ng,1,nalp1) -> Xn(ng,2) = Xn_tot(ng,2,nalp1) -476,479c543,546 -< Xn_tot(ng,1,nalp1) = Xn_tot(ng,1,nalp2) -< Xn_tot(ng,2,nalp1) = Xn_tot(ng,2,nalp2) -< Xn_tot(ng,1,nalp2) = Xn(ng,1) -< Xn_tot(ng,2,nalp2) = Xn(ng,2) ---- -> Xn_tot(ng,1,nalp1) = Xn_tot(ng,1,nalp2) -> Xn_tot(ng,2,nalp1) = Xn_tot(ng,2,nalp2) -> Xn_tot(ng,1,nalp2) = Xn(ng,1) -> Xn_tot(ng,2,nalp2) = Xn(ng,2) -486c553 -< Acc_1 = Acc_1/dble(Nex) ---- -> Acc_1 = Acc_1/dble(Nex) -488a556 -> -491,492c559,560 -< En_m_tot(ns) = En_m_tot(ns) / dble(nc) -< En_e_tot(ns) = En_e_tot(ns) / dble(nc) ---- -> En_m_tot(ns) = En_m_tot(ns) / dble(nc) -> En_e_tot(ns) = En_e_tot(ns) / dble(nc) -503a572 -> -506,507c575,576 -< Xn_m_tot(nd,ns) = Xn_m_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) -< Xn_e_tot(nd,ns) = Xn_e_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) ---- -> Xn_m_tot(nd,ns) = Xn_m_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) -> Xn_e_tot(nd,ns) = Xn_e_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) -509c578 -< if (Xn_e_tot(nd,ns).gt.0.d0) then ---- -> if (Xn_e_tot(nd,ns).gt.0.d0) then -518c587 -< if (ns.eq.Nsims) then ---- -> if (ns.eq.Nsims) then -524a594 -> -526,527c596,599 -< xqmc = XMOM1* xqmc -< cov = ((XMOM1)**2)* cov ---- -> xqmc = XMOM1* xqmc -> cov = ((XMOM1)**2)* cov -> -> -529c601 -< DeAllocate (En_m_tot, En_e_tot, En_tot ) ---- -> DeAllocate (En_m_tot, En_e_tot, En_tot ) -536,539c608,612 -< 2001 format(F14.7,2x,F14.7,2x,F14.7) -< 2004 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7) -< 2005 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7,2x,F14.7) -< 2003 format('Alpha, En_m, Acc ', F14.7,2x,F14.7,2x,F14.7,2x,F14.7,2x,F14.7) ---- -> -> 2001 format(F14.7,2x,F14.7,2x,F14.7) -> 2004 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7) -> 2005 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7,2x,F14.7) -> 2003 format('Alpha, En_m, Acc ', F14.7,2x,F14.7,2x,F14.7,2x,F14.7,2x,F14.7) -541,542c614,615 -< !*********** -< Real (Kind=8) Function Phim1(x) ---- -> !*********** -> Real (Kind=8) Function Phim1(x) -549c622,624 -< Integer Function NPhim1(x) ---- -> -> -> Integer Function NPhim1(x) -550a626 -> -552a629 -> -554,555c631,633 -< om = x*(Om_en_1 - Om_st_1) + Om_st_1 -< NPhiM1 = Nint ( (om - Om_st_1)/Dom + 0.75 ) ---- -> om = x*(Om_en_1 - Om_st_1) + Om_st_1 -> NPhiM1 = Nint ( (om - Om_st_1)/Dom + 0.75 ) -> -556a635,636 -> -> -558a639 -> -561c642 -< Real (Kind=8), Dimension(:) :: Xn_m ---- -> Real (Kind=8), Dimension(:) :: Xn_m -562a644,645 -> -> -569a653 -> -570a655 -> -572a658 -> -575c661 -< Real (Kind=8), Dimension(:) :: Xn_m ---- -> Real (Kind=8), Dimension(:) :: Xn_m -576a663,664 -> -> -581a670 -> -582a672,673 -> -> -584c675,676 -< Subroutine MC(Xtau, Xker_table, Xn, Alpha, NSweeps, Xn_m, En, En_m, Acc_1,Acc_2) ---- -> Subroutine MC(Xtau, Xker_table, Xn, Alpha, NSweeps, Xn_m, En, En_m, Acc_1,Acc_2) -> -587a680 -> -589c682 -< Real (Kind=8), Dimension(:) :: Xtau, Xn_m ---- -> Real (Kind=8), Dimension(:) :: Xtau, Xn_m -591,592c684,686 -< Integer :: NSweeps, nl, Lambda_max, ng1, ng2 -< !Local ---- -> Integer :: NSweeps, nl, Lambda_max, ng1, ng2 -> -> !Local -594,597c688,693 -< & A_gamma_o(:), Z_gamma_o(:) -< Real (Kind=8), Allocatable :: XKER_stor(:,:), XKER_new(:) -< Real (Kind=8) :: X, En, En1, DeltaE, XP, XM, om -< Integer, Allocatable :: Lambda(:) ---- -> & A_gamma_o(:), Z_gamma_o(:) -> -> Real (Kind=8), Allocatable :: XKER_stor(:,:), XKER_new(:) -> -> Real (Kind=8) :: X, En, En1, DeltaE, XP, XM, om -> Integer, Allocatable :: Lambda(:) -598a695 -> -601c698,699 -< & Z_gamma_o(2), A_gamma_o(2) ) ! Max of moves of two walkers. ---- -> & Z_gamma_o(2), A_gamma_o(2) ) ! Max of moves of two walkers. -> -603,604c701,705 -< Xn_m = 0.d0 -< En_m = 0.d0 ---- -> -> Xn_m = 0.d0 -> En_m = 0.d0 -> -> -610,611c711,712 -< Z_gamma = xn(ng,2) -< XKer_stor( nt, ng ) = XKER_table(nt, NPhiM1(A_gamma) ) ---- -> Z_gamma = xn(ng,2) -> XKer_stor( nt, ng ) = XKER_table(nt, NPhiM1(A_gamma) ) -615c716 -< h(nt) = X - xqmc1(nt) ---- -> h(nt) = X - xqmc1(nt) -616a718,719 -> -> -619c722 -< ! Weight sharing moves. ---- -> ! Weight sharing moves. -621,623c724,726 -< x = ranf(iseed) -< if (x.gt.0.5) then -< ! Weight sharing moves. ---- -> x = ranf(iseed) -> if (x.gt.0.5) then -> ! Weight sharing moves. -626,627c729,730 -< do -< Lambda(2) = nint(ranf(iseed)*dble(Ngamma) + 0.5) ---- -> do -> Lambda(2) = nint(ranf(iseed)*dble(Ngamma) + 0.5) -632c735,736 -< A_gamma_o(1) = Xn(ng1,1) ---- -> -> A_gamma_o(1) = Xn(ng1,1) -635,636c739,741 -< Z_gamma_o(2) = Xn(ng2,2) -< A_gamma_p(1) = Xn(ng1,1) ---- -> Z_gamma_o(2) = Xn(ng2,2) -> -> A_gamma_p(1) = Xn(ng1,1) -638,640c743,747 -< s = (Z_gamma_o(1) + Z_gamma_o(2))*ranf(iseed) - Z_gamma_o(1) -< Z_gamma_p(1) = Z_gamma_o(1) + s -< Z_gamma_p(2) = Z_gamma_o(2) - s ---- -> -> s = (Z_gamma_o(1) + Z_gamma_o(2))*ranf(iseed) - Z_gamma_o(1) -> Z_gamma_p(1) = Z_gamma_o(1) + s -> Z_gamma_p(2) = Z_gamma_o(2) - s -> -641a749 -> -644,646c752,754 -< X = Xker_stor(nt,ng1)*( Z_gamma_p(1) - Z_gamma_o(1) ) + & -< & Xker_stor(nt,ng2)*( Z_gamma_p(2) - Z_gamma_o(2) ) -< Deltah(nt) = X ---- -> X = Xker_stor(nt,ng1)*( Z_gamma_p(1) - Z_gamma_o(1) ) + & -> & Xker_stor(nt,ng2)*( Z_gamma_p(2) - Z_gamma_o(2) ) -> Deltah(nt) = X -653a762 -> -655c764,765 -< A_gamma_p(1) = xpbc( Xn(ng1,1) + (ranf(iseed) - 0.5)*DeltaXMAX, 1.d0 ) ---- -> A_gamma_p(1) = xpbc( Xn(ng1,1) + (ranf(iseed) - 0.5)*DeltaXMAX, 1.d0 ) -> -657c767 -< nw = NPhiM1(A_gamma_p(1)) ---- -> nw = NPhiM1(A_gamma_p(1)) -660a771 -> -662,663c773,774 -< X = ( Xker_new(nt) - Xker_stor(nt,ng1) ) * Z_gamma_o(1) -< Deltah(nt) = X ---- -> X = ( Xker_new(nt) - Xker_stor(nt,ng1) ) * Z_gamma_o(1) -> Deltah(nt) = X -666c777,779 -< DeltaE = 0.d0 ---- -> -> -> DeltaE = 0.d0 -668c781 -< DeltaE = DeltaE + (Deltah(nt) + 2.0 * h(nt) ) *Deltah(nt) ---- -> DeltaE = DeltaE + (Deltah(nt) + 2.0 * h(nt) ) *Deltah(nt) -670c783 -< Ratio = exp( -alpha * DeltaE ) ---- -> Ratio = exp( -alpha * DeltaE ) -672,674c785,787 -< if (Ratio .gt. ranf(iseed)) Then -< ! write(6,*) 'Accepted' -< if (Lambda_max.eq.1) then ---- -> if (Ratio .gt. ranf(iseed)) Then -> ! write(6,*) 'Accepted' -> if (Lambda_max.eq.1) then -678c791 -< Xker_stor(nt,ng1) = Xker_new(nt) ---- -> Xker_stor(nt,ng1) = Xker_new(nt) -687c800 -< h(nt) = h(nt) + Deltah(nt) ---- -> h(nt) = h(nt) + Deltah(nt) -696c809 -< Call Sum_Xn_Boxes( Xn_m, Xn ) ---- -> Call Sum_Xn_Boxes( Xn_m, Xn ) -701a815,816 -> -> -703c818 -< Deallocate ( Lambda, Z_gamma_p, A_gamma_p, Z_gamma_o, A_gamma_o ) ---- -> Deallocate ( Lambda, Z_gamma_p, A_gamma_p, Z_gamma_o, A_gamma_o ) -705,706c820,822 -< 2005 format(I4,2x,I4,2x,F14.7,2x,F14.7,' --> ',F14.7,2x,F14.7) -< 2006 format(I4,2x,F14.7, ' --> ',F14.7) ---- -> -> 2005 format(I4,2x,I4,2x,F14.7,2x,F14.7,' --> ',F14.7,2x,F14.7) -> 2006 format(I4,2x,F14.7, ' --> ',F14.7) -707a824,826 -> -> -> -709,710c828,829 -< real (Kind=8) function xpbc(X,XL) -< real (kind=8) :: X, XL ---- -> real (Kind=8) function xpbc(X,XL) -> real (kind=8) :: X, XL -714a834,835 -> -> diff --git a/Libraries/Modules/Compile b/Libraries/Modules/Compile deleted file mode 100644 index b602a560e..000000000 --- a/Libraries/Modules/Compile +++ /dev/null @@ -1,13 +0,0 @@ -OBJS=mat_mod.o Random_Wrap.o errors.o Files_mod.o maxent.o matrix.o maxent_stoch.o fourier.o \ - Histogram.o lattices_v3.o Natural_constants.o log_mesh.o precdef.mod.o \ - Histogram_v2.o - -$(LIB): $(OBJS) - ar -r $(LIB) $(OBJS) - -.SUFFIXES: .f90 -.f90.o: - $(FC) $(SUFFIX) $(FLAGS) $< - -clean: - rm $(OBJS) diff --git a/Libraries/Modules/Files_mod.f90 b/Libraries/Modules/Files_mod.f90 deleted file mode 100644 index 922a8d9f6..000000000 --- a/Libraries/Modules/Files_mod.f90 +++ /dev/null @@ -1,15 +0,0 @@ -Module Files_mod - contains - - Character (len=64) function File_i( file, I) - character (len=64) :: file - integer :: i - write(File_i,'(A,"_",I0)') trim(file),i - end function File_i - - Character (len=64) function File_add( file, file1) - character (len=64) :: file, file1 - write(File_add,'(A,A)') trim(file),Trim(file1) - end function File_add - -end Module Files_mod diff --git a/Libraries/Modules/Histogram.f90 b/Libraries/Modules/Histogram.f90 deleted file mode 100644 index 6086cd5ca..000000000 --- a/Libraries/Modules/Histogram.f90 +++ /dev/null @@ -1,109 +0,0 @@ - Module Histograms - - Type Histogram - Real (Kind=8), pointer :: el(:) - Real (Kind=8) :: range_st, range_en, dis - Real (Kind=8) :: count - Character (16) :: File - - end Type Histogram - - Interface Make_Hist - module procedure Construct_Hist - end Interface Make_Hist - Interface Clear_Hist - module procedure Destroy_Hist - end Interface Clear_Hist - - contains - - subroutine Construct_Hist(Hist, file, range_st, range_en, dis) - Implicit none - type (Histogram) :: Hist - Real (Kind=8) :: range_st, range_en, dis - Character (16) :: File - - Integer :: n - n = nint( ( range_en - range_st)/dis ) - allocate ( Hist%el(n) ) - Hist%el = 0.d0 - Hist%range_st = range_st - Hist%range_en = range_en - Hist%dis = dis - Hist%file = file - Hist%count = 0.d0 - - end subroutine Construct_Hist - - subroutine Destroy_Hist(Hist) - Implicit none - type (Histogram) :: Hist - - deallocate ( Hist%el ) - Hist%el = 0.d0 - Hist%range_st = 0.d0 - Hist%range_en = 0.d0 - Hist%dis = 0.d0 - Hist%file = "" - Hist%count = 0.d0 - - end subroutine Destroy_Hist - - - subroutine Read_Hist(Hist) - Implicit none - type (Histogram) :: Hist - - integer :: io_error, nv - Real (Kind=8) :: X,Y - - - Open ( unit=20,file=Hist%file,status='old',action='read', iostat=io_error) - If (io_error.eq.0) then - read(20,*) Hist%count - do nv = 1,size(Hist%el,1) - read(20,*) X, Y - Hist%el(nv) = Y * Hist%count * Hist%dis - enddo - else - Hist%count = 0.d0 - Hist%el = 0.d0 - endif - close(20) - end subroutine Read_Hist - - - subroutine Write_Hist(Hist) - Implicit none - type (Histogram) :: Hist - Integer :: nv - - Open ( unit=20,file=Hist%file,status='unknown') - write(20,*) Hist%count - do nv = 1,size(Hist%el,1) - write(20,*) dble(nv)*Hist%dis + Hist%range_st, Hist%el(nv)/(Hist%count * Hist%dis) - enddo - close(20) - - end subroutine Write_Hist - - - subroutine Add_Hist(Hist,value) - Implicit none - type (Histogram) :: Hist - Real (Kind=8) :: value - Integer :: nv - - if ( value .gt. Hist%range_en .or. value .lt. Hist%range_st ) then - write(6,*) 'Error in Add_Hist: ', Hist%file, value - else - nv = int((value - Hist%range_st )/Hist%dis) - if (nv < 1) nv =1 - if (nv > size(Hist%el,1) ) nv = size(Hist%el,1) - Hist%el(nv) = Hist%el(nv) + 1.0 - Hist%count = Hist%count + 1.0 - endif - end subroutine Add_Hist - - - end Module Histograms diff --git a/Libraries/Modules/Histogram_v2.f90 b/Libraries/Modules/Histogram_v2.f90 deleted file mode 100644 index 9a8db24da..000000000 --- a/Libraries/Modules/Histogram_v2.f90 +++ /dev/null @@ -1,123 +0,0 @@ - Module Histograms_v2 - - Use Log_Mesh - - Type Histogram - Type (logmesh) :: mesh - Real (Kind=8), pointer :: el(:) - Real (Kind=8) :: range_st, range_en, dis - Real (Kind=8) :: count - Character (16) :: File - - end Type Histogram - - Interface Make_Hist - module procedure Construct_Hist - end Interface Make_Hist - Interface Clear_Hist - module procedure Destroy_Hist - end Interface Clear_Hist - - contains - - subroutine Construct_Hist(Hist, file, range, center, dis, Type, Lambda) - Implicit none - type (Histogram) :: Hist - Real (Kind=8) :: Range, Center, dis, Lambda - Character (16) :: File - Character(len=10) :: Type - Integer :: n, Nw_1 - - !Local - - - Nw_1 = range*2.d0/dis - - call Make_log_mesh(Hist%Mesh, Lambda, Center, Range, Type, Nw_1) - write(6,*) 'In Construct_hist: ', Size(Hist%Mesh%Xom,1) - n = Size(Hist%Mesh%Xom,1) - allocate ( Hist%el(n) ) - Hist%el = 0.d0 - Hist%file = file - Hist%count = 0.d0 - - end subroutine Construct_Hist - - subroutine Destroy_Hist(Hist) - Implicit none - type (Histogram) :: Hist - - deallocate ( Hist%el ) - Hist%el = 0.d0 - Hist%file = "" - Hist%count = 0.d0 - Call Clear_log_mesh ( Hist%Mesh ) - - end subroutine Destroy_Hist - - -!!$ subroutine Read_Hist(Hist) -!!$ Implicit none -!!$ type (Histogram) :: Hist -!!$ -!!$ integer :: io_error, nv -!!$ Real (Kind=8) :: X,Y -!!$ -!!$ -!!$ Open ( unit=20,file=Hist%file,status='old',action='read', iostat=io_error) -!!$ If (io_error.eq.0) then -!!$ read(20,*) Hist%count -!!$ do nv = 1,size(Hist%el,1) -!!$ read(20,*) X, Y -!!$ Hist%el(nv) = Y * Hist%count * Hist%dis -!!$ enddo -!!$ else -!!$ Hist%count = 0.d0 -!!$ Hist%el = 0.d0 -!!$ endif -!!$ close(20) -!!$ end subroutine Read_Hist - - - subroutine Write_Hist(Hist) - Implicit none - type (Histogram) :: Hist - Integer :: nv - - Open ( unit=20,file=Hist%file,status='unknown') - write(20,*) Hist%count - do nv = 1,size(Hist%el,1) -1 - write(20,*) Hist%Mesh%Xom(nv), Hist%el(nv)/(Hist%count * Hist%Mesh%DXom(nv)) - enddo - close(20) - - end subroutine Write_Hist - - Real (Kind=8) function Inter_Hist(Hist) - Implicit none - type (Histogram) :: Hist - Integer :: nv - Real (Kind=8) :: X - - X = 0.d0 - do nv = 1,size(Hist%el,1) -1 - X = X + Hist%el(nv) !* Hist%Mesh%DXom(nv) - enddo - Inter_Hist = X - end function Inter_Hist - - - - subroutine Add_Hist(Hist,value) - Implicit none - type (Histogram) :: Hist - Real (Kind=8) :: value - Integer :: nv - - nv = m_find(Value,Hist%Mesh) - Hist%el(nv) = Hist%el(nv) + 1.0 - Hist%count = Hist%count + 1.0 - end subroutine Add_Hist - - - end Module Histograms_v2 diff --git a/Libraries/Modules/Makefile b/Libraries/Modules/Makefile deleted file mode 100644 index da09025d1..000000000 --- a/Libraries/Modules/Makefile +++ /dev/null @@ -1,15 +0,0 @@ -#FC= $(f90) -#FC= mpxlf90 -#FLAGS= -c -q64 -O4 -#FLAGS= -c -O3 -fbounds-check -FLAGS= -c -O3 -SUFFIX= -qsuffix=f=f90 -LF= -LIB=modules_90.a - -all: - (make -f Compile FC="$(FC)" FLAGS="$(FLAGS)" LIB="$(LIB)" ) - -clean: - (make -f Compile clean ) ;\ - rm *.mod *~ \#* diff --git a/Libraries/Modules/Makefile_Juropa b/Libraries/Modules/Makefile_Juropa deleted file mode 100644 index fb198fdf5..000000000 --- a/Libraries/Modules/Makefile_Juropa +++ /dev/null @@ -1,15 +0,0 @@ -FC= ifort -#FC= mpxlf90 -#FLAGS= -c -q64 -O4 -#FLAGS= -c -O1 -pg -FLAGS= -c -O3 -SUFFIX= -qsuffix=f=f90 -LF= -warn all -LIB=modules_90.a - -all: - (make -f Compile FC="$(FC)" FLAGS="$(FLAGS)" LIB="$(LIB)" ) - -clean: - (make -f Compile clean ) ;\ - rm *.mod diff --git a/Libraries/Modules/Makefile_cl b/Libraries/Modules/Makefile_cl deleted file mode 100644 index 624f8fd2e..000000000 --- a/Libraries/Modules/Makefile_cl +++ /dev/null @@ -1,14 +0,0 @@ -FC= ifort -#FC= mpxlf90 -#FLAGS= -c -q64 -O4 -FLAGS= -c -O3 -SUFFIX= -qsuffix=f=f90 -LF= -LIB=modules_90.a - -all: - (make -f Compile FC="$(FC)" FLAGS="$(FLAGS)" LIB="$(LIB)" ) - -clean: - (make -f Compile clean ) ;\ - rm *.mod *~ \#* diff --git a/Libraries/Modules/Natural_constants.f90 b/Libraries/Modules/Natural_constants.f90 deleted file mode 100644 index bd17ff276..000000000 --- a/Libraries/Modules/Natural_constants.f90 +++ /dev/null @@ -1,16 +0,0 @@ - Module Natural_Constants - - Real (Kind =8) :: eV, amu, Ang, hbar, pi - - contains - - subroutine Set_NC - - pi = acos(-1.d0) - eV = (1.0/6.24150974) *( 10.0**(-18) ) - amu = 1.66053886 * (10.0**(-27)) - Ang = 10.0**(-10) - hbar = 6.6260755*(10.0**(-34))/(2.0*pi) - - end subroutine Set_NC - end Module Natural_Constants diff --git a/Libraries/Modules/Random_Wrap.f90 b/Libraries/Modules/Random_Wrap.f90 deleted file mode 100644 index 83eae9d34..000000000 --- a/Libraries/Modules/Random_Wrap.f90 +++ /dev/null @@ -1,99 +0,0 @@ -Module Random_Wrap - - contains - - Subroutine Get_seed_Len(K) - Implicit none - Integer :: K - CALL RANDOM_SEED (SIZE=K) - end Subroutine Get_seed_Len - - Subroutine Ranset(Iseed_vec) - Implicit none - Integer, Dimension(:) :: Iseed_vec - - Integer :: K, N, i, Iseed - Integer, allocatable :: Seed_start(:) - Real (Kind=8) :: X - - N = size(Iseed_vec) - CALL RANDOM_SEED (SIZE=K) - Allocate (SEED_start(K) ) - ! Setup SEED_start - Iseed = Iseed_vec(1) - do i = 1,K - if (i <= N) then - SEED_Start(i) = Iseed_vec(i) - else - X = Ranf_Imada(Iseed) - SEED_Start(i) = Iseed - endif - enddo - CALL RANDOM_SEED (PUT = SEED_start(1:K)) - Write(6,*) 'Starting seeds ', SEED_Start - - end Subroutine Ranset - - Subroutine Ranget(Iseed_vec) - Implicit none - Integer, Dimension(:) :: Iseed_vec - - Integer :: K, N, i, Iseed - Integer, allocatable :: Seed_end(:) - Real (Kind=8) :: X - - N = size(Iseed_vec) - CALL RANDOM_SEED (SIZE=K) - Allocate (SEED_end(K) ) - CALL RANDOM_SEED (GET = SEED_end(1:K)) - ! Setup SEED_start - Iseed = Iseed_vec(1) - do i = 1,N - if (i <= K) then - Iseed_vec(i) = SEED_end(i) - else - X = Ranf_Imada(Iseed) - Iseed_vec(i) = Iseed - endif - enddo - Write(6,*) 'End seeds ', SEED_end - - end Subroutine Ranget - - real (Kind=8) function ranf_imada(iq) - implicit none - integer iq - integer IP,IR - parameter (IP = 48828125, IR = 2147483647) - - iq=iq* IP - ! print *,'iq = ',iq - if(iq) 10,20,20 -10 iq=(iq+IR)+1 -20 ranf_imada = dble(iq)/2.0D0**31 - end function ranf_imada - - real (Kind=8) function ranf(iq) - implicit none - integer, optional :: iq - Real (Kind=8) :: X - Call Random_Number(X) - ranf = X - end function ranf - - - real (kind=8) function rang(iq) - - ! Random variable according to the distribution: exp(-x**2/2)/(sqrt(2*3.1415927)) - - integer iq - real (Kind=8) :: pi, ranmod, theta - - PI = 3.1415926536D0 - RANMOD = SQRT(-2.D0 * LOG(RANF(iq))) - THETA = 2.D0 * PI * RANF(iq) - rang = RANMOD * COS(THETA) - - end function rang - - end Module Random_Wrap diff --git a/Libraries/Modules/errors.f90 b/Libraries/Modules/errors.f90 deleted file mode 100644 index 0e4e860c1..000000000 --- a/Libraries/Modules/errors.f90 +++ /dev/null @@ -1,856 +0,0 @@ - MODULE ERRORS - - Use MyMats - Use Random_Wrap - - INTERFACE ERRCALC - MODULE PROCEDURE ERRCALC, ERRCALC_C - END INTERFACE - INTERFACE ERRCALCJ - MODULE PROCEDURE ERRCALC_J, ERRCALC_J_REBIN, ERRCALC_JS, ERRCALC_JS_REBIN, & - & ERRCALC_J_C, ERRCALC_J_C_REBIN, ERRCALC_JS_C - END INTERFACE - INTERFACE COV - MODULE PROCEDURE COVJ, COVJS, COVJS_C - END INTERFACE - INTERFACE COV_ERR - MODULE PROCEDURE COV_ERR - END INTERFACE - INTERFACE INTERGRATE_F - MODULE PROCEDURE INTER_F - END INTERFACE - INTERFACE INTERGRATE - MODULE PROCEDURE INTER_QMC - END INTERFACE - INTERFACE FIT - MODULE PROCEDURE FIT - END INTERFACE - INTERFACE AUTO_COR - MODULE PROCEDURE AUTO_COR - END INTERFACE - INTERFACE Bootstrap - MODULE PROCEDURE Bootstrap - END INTERFACE - INTERFACE Bootstrap_fluc - MODULE PROCEDURE BootstrapC_fluc - END INTERFACE - - - - CONTAINS -!*********** - SUBROUTINE ERRCALC(EN,XM,XERR) -! Calculates error on the input vector EN. Just the standard deviation. - - IMPLICIT NONE - REAL (KIND=8), DIMENSION(:) :: EN - REAL (KIND=8) :: XM, XERR, XSQ - INTEGER :: NP, NT - - NP = SIZE(EN) - - XM = 0.D0 - XSQ = 0.D0 - DO NT = 1,NP - XM = XM + EN(NT) - XSQ = XSQ + EN(NT)**2 - ENDDO - XM = XM /DBLE(NP) - XSQ = XSQ/DBLE(NP) - XERR = (XSQ - XM**2)/DBLE(NP) - IF (XERR.GT.0.D0) THEN - XERR = SQRT(XERR) - ELSE - XERR = 0.D0 - ENDIF - - RETURN - END SUBROUTINE ERRCALC - - - SUBROUTINE ERRCALC_C(EN,ZM,ZERR) -! Calculates error on the input vector EN. Just the standard deviation. - - IMPLICIT NONE - Complex (KIND=8), DIMENSION(:) :: EN - Complex (KIND=8) :: ZM, ZERR - INTEGER :: NP, NT - - ! Local - Real (Kind=8), dimension(:), allocatable :: Rhelp - real (Kind=8) :: XM, XERR - - NP = SIZE(EN) - Allocate (Rhelp(NP)) - - do nt = 1,np - Rhelp(nt) = dble(en(nt)) - enddo - call errcalc(Rhelp, xm, xerr) - zm = cmplx(xm , 0.d0) - Zerr = cmplx(xerr, 0.d0) - - do nt = 1,np - Rhelp(nt) = aimag(en(nt)) - enddo - call errcalc(Rhelp, xm, xerr) - zm = zm + cmplx( 0.d0, xm ) - Zerr = Zerr + cmplx( 0.d0, xerr ) - - RETURN - END SUBROUTINE ERRCALC_C - - SUBROUTINE ERRCALC_J(EN,XM,XERR) -! Calculates jacknife error on the input vector EN. Mean and variance. -! The input are the bins. - - IMPLICIT NONE - - REAL (KIND=8), DIMENSION(:) :: EN - REAL (KIND=8) :: XM, XERR, X - REAL (KIND=8), DIMENSION(:), ALLOCATABLE :: EN1 - INTEGER :: NP, N, N1 - - NP = SIZE(EN) - ALLOCATE (EN1(NP)) - - ! Build the jackknife averages and send to errcalc. - - DO N = 1,NP - X = 0.D0 - DO N1 = 1,NP - IF (N1.NE.N) X = X + EN(N1) - ENDDO - EN1(N) = X / DBLE(NP -1) - ENDDO - CALL ERRCALC(EN1,XM,XERR) - XERR = XERR*DBLE(NP) - DEALLOCATE ( EN1 ) - - RETURN - END SUBROUTINE ERRCALC_J - - - SUBROUTINE ERRCALC_J_C(EN,ZM,ZERR) -! Calculates jacknife error on the input vector EN. Mean and variance. -! The input are the bins. - - IMPLICIT NONE - - COMPLEX (KIND=8), DIMENSION(:) :: EN - COMPLEX (KIND=8) :: ZM, ZERR, Z - COMPLEX (KIND=8), DIMENSION(:), ALLOCATABLE :: EN1 - INTEGER :: NP, N, N1 - - NP = SIZE(EN) - ALLOCATE (EN1(NP)) - - ! Build the jackknife averages and send to errcalc. - - DO N = 1,NP - Z = CMPLX(0.D0, 0.D0) - DO N1 = 1,NP - IF (N1.NE.N) Z = Z + EN(N1) - ENDDO - EN1(N) = Z / CMPLX(DBLE(NP -1) , 0.d0) - ENDDO - CALL ERRCALC(EN1,ZM,ZERR) - ZERR = ZERR*CMPLX(DBLE(NP),0.d0) - DEALLOCATE ( EN1 ) - - RETURN - END SUBROUTINE ERRCALC_J_C - -!************ - SUBROUTINE ERRCALC_J_C_REBIN(EN,ZM,ZERR,NREBIN) -! Calculates jacknife error on the input vector EN. Mean and variance. -! The input are the bins. - - IMPLICIT NONE - - COMPLEX (KIND=8), DIMENSION(:) :: EN - COMPLEX (KIND=8) :: ZM, ZERR, Z - COMPLEX (KIND=8), DIMENSION(:), ALLOCATABLE :: EN1 - INTEGER :: NP, N, N1, NP1, NREBIN, NC, NB - - NP = SIZE(EN) - NP1 = NP/NREBIN - ALLOCATE (EN1(NP1)) - ! Rebin - NC = 0 - DO N = 1,NP1 - Z = CMPLX(0.D0,0.D0) - DO NB = 1,NREBIN - NC = NC + 1 - Z = Z + EN(NC) - ENDDO - Z = Z/CMPLX(DBLE(NREBIN),0.d0) - EN1(N) = Z - ENDDO - CALL ERRCALC_J_C(EN1,ZM,ZERR) - - DEALLOCATE(EN1) - - END SUBROUTINE ERRCALC_J_C_REBIN - -!****************** - SUBROUTINE ERRCALC_J_REBIN(EN,XM,XERR,NREBIN) -! Calculates jacknife error on the input vector EN with rebinning. Mean and variance. -! The input are the bins. - - IMPLICIT NONE - - REAL (KIND=8), DIMENSION(:) :: EN - REAL (KIND=8) :: XM, XERR, X - REAL (KIND=8), DIMENSION(:), ALLOCATABLE :: EN1 - INTEGER :: NREBIN, NC, N, NB, NP1, NP - - NP = SIZE(EN) - NP1 = NP/NREBIN - ALLOCATE (EN1(NP1)) - - ! Rebin - NC = 0 - DO N = 1,NP1 - X = 0.D0 - DO NB = 1,NREBIN - NC = NC + 1 - X = X + EN(NC) - ENDDO - X = X/DBLE(NREBIN) - EN1(N) = X - ENDDO - CALL ERRCALC_J(EN1,XM,XERR) - - DEALLOCATE(EN1) - RETURN - END SUBROUTINE ERRCALC_J_REBIN - -!********** - SUBROUTINE ERRCALC_JS(EN,SI,XM,XERR) -! Calculates error on the input vector EN. Just the variance. -! The input are the bins - - IMPLICIT NONE - - REAL (KIND=8), DIMENSION(:) :: EN, SI - REAL (KIND=8) :: XM, XERR, X,XS - REAL (KIND=8), DIMENSION(:), ALLOCATABLE :: EN1 - INTEGER :: N, N1, NP, NP1 - - NP = SIZE(EN) - NP1= SIZE(SI) - IF (NP1.NE.NP) THEN - WRITE(6,*) 'Error in Errcalc_JS' - STOP - ENDIF - ALLOCATE (EN1(NP)) - - ! Build the jackknife averages and send to errcalc - - DO N = 1,NP - X = 0.D0 - XS = 0.D0 - DO N1 = 1,NP - IF (N1.NE.N) X = X + EN(N1) - IF (N1.NE.N) XS = XS + SI(N1) - ENDDO - EN1(N) = X / XS - ENDDO - CALL ERRCALC(EN1,XM,XERR) - XERR = XERR*DBLE(NP) - DEALLOCATE ( EN1 ) - - RETURN - END SUBROUTINE ERRCALC_JS - -!********** - SUBROUTINE ERRCALC_JS_C(EN,SI,XM,XERR) -! Calculates error on the input vector EN. Just the variance. -! The input are the bins - - IMPLICIT NONE - - COMPLEX (KIND=8), DIMENSION(:) :: EN, SI - COMPLEX (KIND=8) :: XM, XERR, X,XS - COMPLEX (KIND=8), DIMENSION(:), ALLOCATABLE :: EN1 - INTEGER :: N, N1, NP, NP1 - - NP = SIZE(EN) - NP1= SIZE(SI) - IF (NP1.NE.NP) THEN - WRITE(6,*) 'Error in Errcalc_JS' - STOP - ENDIF - ALLOCATE (EN1(NP)) - - ! Build the jackknife averages and send to errcalc - - DO N = 1,NP - X = CMPLX(0.D0,0.D0) - XS = CMPLX(0.D0,0.D0) - DO N1 = 1,NP - IF (N1.NE.N) X = X + EN(N1) - IF (N1.NE.N) XS = XS + SI(N1) - ENDDO - EN1(N) = X / XS - ENDDO - CALL ERRCALC(EN1,XM,XERR) - XERR = XERR*CMPLX(DBLE(NP),0.d0) - DEALLOCATE ( EN1 ) - - RETURN - END SUBROUTINE ERRCALC_JS_C - - - -!******** - SUBROUTINE ERRCALC_JS_REBIN(EN,SI,XM,XERR,NREBIN) -! Calculates jacknife error on the input vector EN with rebinning. Mean and variance. -! The input are the bins. - - IMPLICIT NONE - - REAL (KIND=8), DIMENSION(:) :: EN, SI - REAL (KIND=8) :: XM, XERR, X, Y - REAL (KIND=8), DIMENSION(:), ALLOCATABLE :: EN1, SI1 - INTEGER :: NREBIN, NC, N, NB, NP, NP1 - - NP = SIZE(EN) - NP1 = NP/NREBIN - ALLOCATE (EN1(NP1)) - ALLOCATE (SI1(NP1)) - - ! Rebin - NC = 0 - DO N = 1,NP1 - X = 0.D0; Y = 0.D0 - DO NB = 1,NREBIN - NC = NC + 1 - X = X + EN(NC) - Y = Y + SI(NC) - ENDDO - X = X/DBLE(NREBIN) - Y = Y/DBLE(NREBIN) - EN1(N) = X - SI1(N) = Y - ENDDO - CALL ERRCALC_JS(EN1,SI1,XM,XERR) - - DEALLOCATE (EN1,SI1) - - RETURN - END SUBROUTINE ERRCALC_JS_REBIN - -!****************** - SUBROUTINE INTER_QMC(GR, SIGN1, DTAU, RES, ERR) - - IMPLICIT NONE - ! Given GR(Times, Bins) and Sign1(Bins) calculates the integral and error - ! The sign is the same for all Times. - REAL (KIND=8), DIMENSION(:,:) :: GR - REAL (KIND=8), DIMENSION(:) :: SIGN1 - - !Local - REAL (KIND=8), DIMENSION(: ), ALLOCATABLE :: HLP - REAL (KIND=8), DIMENSION(:,:), ALLOCATABLE :: HLP1 - REAL (KIND=8) :: X, XM, XERR, Y, Err, Res, DTAU - INTEGER :: NT, NT1, NB, NB1, NTDM, NDATA - - NTDM = SIZE(GR,1) - NDATA = SIZE(GR,2) - - - ALLOCATE( HLP(NDATA), HLP1(NTDM,NDATA) ) - DO NT = 1,NTDM - DO NB= 1, NDATA - X = 0.D0 - Y = 0.D0 - DO NB1 = 1,NDATA - IF (NB1.NE.NB) THEN - X = X + GR(NT,NB1) - Y = Y + SIGN1(NB1) - ENDIF - ENDDO - HLP1(NT,NB) = X/Y - ENDDO - ENDDO - - DO NB = 1,NDATA - X = 0.D0 - DO NT = 1,NTDM-1 - X = X + (HLP1(NT,NB) + HLP1(NT+1,NB))*0.5D0 - ENDDO - HLP (NB ) = X * DTAU - ENDDO - - CALL ERRCALC(HLP, RES, ERR) - ERR = ERR*DBLE(NDATA) - - DEALLOCATE( HLP, HLP1 ) - - RETURN - END SUBROUTINE INTER_QMC - -!****************** - REAL (KIND=8) FUNCTION INTER_F(A,B,N,F) - ! integrates the function F from A to B using N points. - - IMPLICIT NONE - - INTEGER :: N, I - REAL (KIND=8) :: A, B, RES, X, X1 - REAL (KIND=8), EXTERNAL :: F - - REAL (KIND=8) :: DEL - - DEL = (B-A)/DBLE(N) - INTER_F = 0.D0 - DO I = 0, N-1 - X = A + DBLE(I )*DEL - X1 = A + DBLE(I+1)*DEL - INTER_F = INTER_F + ( F(X) + F(X1) )*0.5D0 - ENDDO - INTER_F = INTER_F*DEL - END FUNCTION INTER_F - -!****************** Least square fits: - SUBROUTINE FIT(XDATA,FDATA,ERROR,ARES,CHSQ,F) - - IMPLICIT NONE - - REAL (KIND=8), DIMENSION(:) :: XDATA, FDATA, ERROR, ARES - REAL (KIND=8) :: CHSQ, X - REAL (KIND=8), DIMENSION(:,:), ALLOCATABLE :: A, U,V,VINV,V1 - REAL (KIND=8), DIMENSION(: ), ALLOCATABLE :: B,D - REAL (KIND=8), EXTERNAL :: F - INTEGER :: NDATA, NBASIS, I, M, M1, NCON, N - - NDATA = SIZE(XDATA) - NBASIS= SIZE(ARES) - - !WRITE(6,*) 'NDATA, NBASIS: ',NDATA, NBASIS - ALLOCATE (A(NDATA,NBASIS)) - ALLOCATE (U(NDATA,NBASIS)) - ALLOCATE (D(NBASIS)) - ALLOCATE (V (NBASIS,NBASIS)) - ALLOCATE (V1 (NBASIS,NBASIS)) - ALLOCATE (VINV(NBASIS,NBASIS)) - ALLOCATE (B(NDATA)) - - A = 0.D0 - U = 0.D0 - D = 0.D0 - V = 0.D0 - VINV = 0.D0 - V1 = 0.D0 - B = 0.D0 - NCON = 1 - DO M = 1,NBASIS - DO I = 1,NDATA - A(I,M) = F(M,XDATA(I))/ERROR(I) - ENDDO - ENDDO - DO I = 1,NDATA - B(I) = FDATA(I)/ERROR(I) - ENDDO - !write(6,*) A - CALL UDV(A,U,D,V,NCON) - DO M = 1,NBASIS - DO I = 1,NBASIS - V1(I,M) = V(M,I) - ENDDO - ENDDO - X = 0.D0 - CALL INV(V1,VINV,X) - - DO M1 = 1,NBASIS - X = 0.D0 - DO M = 1,NBASIS - DO I = 1,NDATA - X = X + B(I)*U(I,M)*VINV(M,M1)/D(M) - ENDDO - ENDDO - ARES(M1) = X - ENDDO - - CHSQ = 0.D0 - DO N = 1,NDATA - X = 0.D0 - DO M = 1,NBASIS - X = X + ARES(M)*F(M,XDATA(N)) - ENDDO - CHSQ = CHSQ + (FDATA(N) - X)**2/ERROR(N)**2 - ENDDO - CHSQ = CHSQ/DBLE(NDATA) - - DEALLOCATE (A) - DEALLOCATE (U) - DEALLOCATE (D) - DEALLOCATE (V) - DEALLOCATE (V1) - DEALLOCATE (VINV) - DEALLOCATE (B) - - END SUBROUTINE FIT - - SUBROUTINE COVJ(GR, XCOV, XMEAN) - - IMPLICIT NONE - !Given GR(Times, Bins) calculates the mean and the covariance. - REAL (KIND=8), DIMENSION(:,:) :: GR, XCOV - REAL (KIND=8), DIMENSION(:) :: XMEAN - - !Local - REAL (KIND=8), DIMENSION(: ), ALLOCATABLE :: HLP - REAL (KIND=8), DIMENSION(:,:), ALLOCATABLE :: HLP1 - REAL (KIND=8) :: X, XM, XERR - INTEGER :: NT, NT1, NB, NB1, NTDM, NDATA - - NTDM = SIZE(GR,1) - NDATA = SIZE(GR,2) - - IF ( (SIZE(XCOV,1).NE.SIZE(XCOV,2) ) .OR. (SIZE(XCOV,1).NE.NTDM) ) THEN - WRITE(6,*) 'Error in COV' - STOP - ENDIF - - ALLOCATE( HLP(NDATA), HLP1(NTDM,NDATA) ) - DO NT = 1,NTDM - DO NB= 1, NDATA - X = 0.0 - DO NB1 = 1,NDATA - IF (NB1.NE.NB) THEN - X = X + GR(NT,NB1) - ENDIF - ENDDO - HLP1(NT,NB) = X/DBLE(NDATA-1) - HLP (NB ) = X/DBLE(NDATA-1) - ENDDO - CALL ERRCALC(HLP,XM ,XERR) - XMEAN(NT) = XM - ENDDO - - - DO NT = 1,NTDM - DO NT1= 1,NTDM - X = 0.0 - DO NB = 1,NDATA - X = X + HLP1(NT,NB)*HLP1(NT1,NB) - ENDDO - X = X/DBLE(NDATA) - XCOV(NT,NT1) = ( X - XMEAN(NT)*XMEAN(NT1) )*DBLE(NDATA) - ENDDO - ENDDO - - - DEALLOCATE( HLP, HLP1 ) - - RETURN - END SUBROUTINE COVJ - - - SUBROUTINE COVJS(GR, SIGN1, XCOV, XMEAN) - - IMPLICIT NONE - ! Given GR(Times, Bins) and Sign1(Bins) calculates the mean and the covariance. - ! The sign is the same for all Times. - REAL (KIND=8), DIMENSION(:,:) :: GR, XCOV - REAL (KIND=8), DIMENSION(:) :: XMEAN, SIGN1 - - !Local - REAL (KIND=8), DIMENSION(: ), ALLOCATABLE :: HLP - REAL (KIND=8), DIMENSION(:,:), ALLOCATABLE :: HLP1 - REAL (KIND=8) :: X, XM, XERR, Y - INTEGER :: NT, NT1, NB, NB1, NTDM, NDATA - - NTDM = SIZE(GR,1) - NDATA = SIZE(GR,2) - - IF ( (SIZE(XCOV,1).NE.SIZE(XCOV,2) ) .OR. (SIZE(XCOV,1).NE.NTDM) ) THEN - WRITE(6,*) 'Error in COV' - STOP - ENDIF - - ALLOCATE( HLP(NDATA), HLP1(NTDM,NDATA) ) - DO NT = 1,NTDM - DO NB= 1, NDATA - X = 0.D0 - Y = 0.D0 - DO NB1 = 1,NDATA - IF (NB1.NE.NB) THEN - X = X + GR(NT,NB1) - Y = Y + SIGN1(NB1) - ENDIF - ENDDO - HLP1(NT,NB) = X/Y - HLP (NB ) = X/Y - ENDDO - CALL ERRCALC(HLP,XM ,XERR) - XMEAN(NT) = XM - ENDDO - - - DO NT = 1,NTDM - DO NT1= 1,NTDM - X = 0.0 - DO NB = 1,NDATA - X = X + HLP1(NT,NB)*HLP1(NT1,NB) - ENDDO - X = X/DBLE(NDATA) - XCOV(NT,NT1) = ( X - XMEAN(NT)*XMEAN(NT1) )*DBLE(NDATA) - ENDDO - ENDDO - - - DEALLOCATE( HLP, HLP1 ) - - RETURN - END SUBROUTINE COVJS - - - - - SUBROUTINE COVJS_C(GR, SIGN1, XCOV, XMEAN) - - IMPLICIT NONE - ! Given GR(Times, Bins) and Sign1(Bins) calculates the mean and the covariance. - ! The sign is the same for all Times. - Complex (KIND=8), DIMENSION(:,:) :: GR, XCOV - Complex (KIND=8), DIMENSION(:) :: XMEAN - Real (Kind=8), DIMENSION(:) :: SIGN1 - - - !Local - REAL (KIND=8), DIMENSION(: ), ALLOCATABLE :: HLP, XMEAN_R - REAL (KIND=8), DIMENSION(:,:), ALLOCATABLE :: HLP1 - REAL (KIND=8) :: X, XM, XERR, Y - INTEGER :: NT, NT1, NB, NB1, NTDM, NDATA, Nth - COMPLEX (KIND=8) :: Z - - NTDM = SIZE(GR,1) - NDATA = SIZE(GR,2) - - - !Write(6,*) 'Errors.f90 ', NTDM, NDATA - IF ( (SIZE(XCOV,1).NE.SIZE(XCOV,2) ) .OR. (SIZE(XCOV,1).NE.NTDM) ) THEN - WRITE(6,*) 'Error in COV' - STOP - ENDIF - - - - ALLOCATE( HLP(NDATA), HLP1(NTDM,NDATA), XMEAN_R(NTDM) ) - XMEAN = CMPLX(0.d0,0.d0) - XCOV = CMPLX(0.d0,0.d0) - - DO NTH = 1,2 - Z = CMPLX(1.0, 0.0) - IF (NTH .EQ. 2 ) Z = CMPLX( 0.0, -1.0 ) - DO NT = 1,NTDM - DO NB= 1, NDATA - X = 0.D0 - Y = 0.D0 - DO NB1 = 1,NDATA - IF (NB1.NE.NB) THEN - X = X + DBLE ( Z*GR(NT,NB1) ) - Y = Y + SIGN1(NB1) - ENDIF - ENDDO - HLP1(NT,NB) = X/Y - HLP (NB ) = X/Y - ENDDO - CALL ERRCALC(HLP,XM ,XERR) - XMEAN(NT) = XMEAN(NT) + CONJG(Z)*CMPLX(XM,0.d0) - XMEAN_R(NT) = XM - !if (Nth.eq.2) write(6,*) XM - ENDDO - - - DO NT = 1,NTDM - DO NT1= 1,NTDM - X = 0.0 - DO NB = 1,NDATA - X = X + HLP1(NT,NB)*HLP1(NT1,NB) - ENDDO - X = X/DBLE(NDATA) - XCOV(NT,NT1) = XCOV(NT,NT1) + CONJG(Z)* & - & CMPLX( ( X - XMEAN_R(NT)*XMEAN_R(NT1) )*DBLE(NDATA) , 0.d0 ) - ENDDO - ENDDO - ENDDO - - DEALLOCATE( HLP, HLP1, XMEAN_R ) - - RETURN - END SUBROUTINE COVJS_C - - - - - Subroutine COV_ERR(XMEAN, XCOV, ISEED) - ! Given Mean and Cov, diagonalizes the COV and produces a new data set within - ! the errorbars - - Implicit None - ! Parameters - REAL (KIND=8), DIMENSION(:,:) :: XCOV - REAL (KIND=8), DIMENSION(:) :: XMEAN - - Integer :: ntau, I, M, ISeed - Real (Kind = 8) :: X - - Real (Kind=8), Dimension(:,:), allocatable :: UC - Real (Kind=8), Dimension(:), allocatable :: XMEAN_1, SIG_1 - - ntau = size(Xmean,1) - Allocate (UC(ntau,ntau), XMEAN_1(ntau), SIG_1(ntau) ) - - CALL DIAG(XCOV,UC,SIG_1) - - DO I = 1,NTAU - X = 0.D0 - DO M = 1,NTAU - X = X + UC(M,I)* XMEAN(M) - ENDDO - XMEAN_1(I) = X - ENDDO - DO I = 1,NTAU - IF (SIG_1(I).LT.0.d0) Then - write(6,*) 'Error in Cov_err', SIG_1(I) - Endif - XMEAN_1(I) = XMEAN_1(I) + SQRT(ABS(SIG_1(I)))*RANG(ISEED) - ENDDO - DO I = 1,NTAU - X = 0.D0 - DO M = 1,NTAU - X = X + UC(I,M)*XMEAN_1(M) - ENDDO - XMEAN(I) = X - ENDDO - - Deallocate (UC, XMEAN_1, SIG_1) - - - END Subroutine COV_ERR - - SUBROUTINE AUTO_COR(DATA,RES) - - Implicit none - - REAL (Kind=8), DIMENSION(:) :: DATA,RES - - !Local - Integer :: nb, nt, ntau, nt1 - Real (Kind=8) :: X1, X2, X3 - - nb = SIZE(DATA) - nt = SIZE(RES) - if (nb.lt.nt) then - write(6,*) 'Error in autocor' - stop - end if - - DO ntau = 1, nt - X1 = 0.0 - X2 = 0.0 - X3 = 0.0 - DO nt1 = 1, nb - ntau - X1 = X1 + DATA(nt1)*DATA(nt1 + ntau) - X2 = X2 + DATA(nt1)*DATA(nt1) - X3 = X3 + DATA(nt1) - ENDDO - X1 = X1 / dble(nb - ntau) - X2 = X2 / dble(nb - ntau) - X3 = X3 / dble(nb - ntau) - - Res(ntau) = ( X1 - X3**2)/(X2 - X3**2) - - ENDDO - - END SUBROUTINE AUTO_COR - - SUBROUTINE BOOTSTRAPC_FLUC(A,B,AB,NBOOT,ISEED,ZM,ZERR) - !!! COMPUTES - - IMPLICIT NONE - COMPLEX (KIND=8), DIMENSION(:), INTENT(IN) :: A,B,AB - INTEGER, INTENT(IN) :: NBOOT - INTEGER, INTENT(INOUT) :: ISEED - COMPLEX (KIND=8), INTENT(OUT) :: ZM,ZERR - - !Local - INTEGER :: NP, NB, I, J - COMPLEX (KIND=8) :: Z, Z1,Z2,Z12 - !REAL (KIND=8), EXTERNAL :: RANF - - NP = SIZE(A,1) - ZM = CMPLX(0.d0,0.d0,Kind=8) - ZERR = CMPLX(0.d0,0.d0,Kind=8) - DO NB = 1, NBOOT - Z1 = cmplx(0.d0,0.d0,Kind=8) - Z2 = cmplx(0.d0,0.d0,Kind=8) - Z12 = cmplx(0.d0,0.d0,Kind=8) - DO I = 1,NP - J = NINT( DBLE(NP)* RANF(ISEED) + 0.5 ) - IF (J == 0) J = 1 - IF (J > NP) J = NP - Z1 = Z1 + A(J) - Z2 = Z2 + B(J) - Z12 =Z12 + AB(J) - ENDDO - Z1 = Z1 /CMPLX(DBLE(NP),0.d0,Kind=8) - Z2 = Z2 /CMPLX(DBLE(NP),0.d0,Kind=8) - Z12 =Z12/CMPLX(DBLE(NP),0.d0,Kind=8) - - Z = Z12 - Z1*Z2 - ZM = ZM + Z - ZERR = ZERR + Z*Z - ENDDO - ZM = ZM /CMPLX(DBLE(NBOOT),0.d0,Kind=8) - ZERR = ZERR/CMPLX(DBLE(NBOOT),0.d0,Kind=8) - - Z = ZERR - ZM*ZM - ZERR = SQRT(Z) - - END SUBROUTINE BOOTSTRAPC_FLUC - - SUBROUTINE BOOTSTRAP(EN,XM,XERR,NBOOT,ISEED) - - IMPLICIT NONE - REAL (KIND=8), DIMENSION(:) :: EN - REAL (KIND=8) :: XM, XERR, X - INTEGER :: NP, NT, NBOOT, NB, I, ISEED - - NP = SIZE(EN) - - ! Build the Bootstrap samples - - XM = 0.D0 - XERR = 0.D0 - DO NB = 1,NBOOT - X = 0.D0 - DO NT = 1, NP - I = NINT( DBLE(NP)* RANF(ISEED) + 0.5 ) - IF (I.EQ.0 .OR. I.GT.NP ) THEN - WRITE(6,*) 'ERROR IN BOOTSTRAP' - STOP - ENDIF - X = X + EN(I) - ENDDO - X = X/DBLE(NP) - XM = XM + X - XERR = XERR + X*X - ENDDO - - XM = XM /DBLE(NBOOT) - XERR = XERR/DBLE(NBOOT) - - X = XERR - XM*XM - XERR = 0.d0 - IF (X.GT.0.d0) XERR = SQRT(X) - - END SUBROUTINE BOOTSTRAP - - END MODULE ERRORS - - diff --git a/Libraries/Modules/fourier.f90 b/Libraries/Modules/fourier.f90 deleted file mode 100644 index 1e92d9710..000000000 --- a/Libraries/Modules/fourier.f90 +++ /dev/null @@ -1,1592 +0,0 @@ -Module Fourier - Use MaxEnt_mod - Use MaxEnt_stoch_mod - Use Matrix - - interface Matz_tau - module procedure Matz_tau_T, Matz_tau_T0, Matz_tau_T0_all, Matz_tau_T_all, Matz_tau_T_all_C, & - & Matz_tau_T_cdmft - end interface - - interface Matz_tau_Bose - module procedure Matz_tau_T_Bose - end interface - - interface Tau_Matz - module procedure Tau_Matz_T, Tau_Matz_T0, Tau_Matz_T0_all, Tau_Matz_T_all,& - & tau_matz_spline, tau_matz_spline_all, Tau_Matz_T_stoch, Tau_Matz_T_all_stoch, & - & Tau_Matz_T_all_stoch_C, Tau_Matz_T0_stoch , Tau_Matz_T_all_stoch_cdmft - end interface - - interface Tau_Matz_Bose - module procedure Tau_Matz_T_Bose - end interface - - contains - -!******** - subroutine Matz_tau_T(griom, xiom, grtau, xtau, beta) - implicit none - ! Given the G(i omega) calculates G(tau). - real (Kind=8), Dimension(:) :: xiom, xtau - real (Kind=8) :: beta - complex (Kind=8), Dimension(:) :: griom - real (Kind=8), Dimension(:) :: grtau - - - Integer :: Niom, Ntau, nt, niw, Ntail - Real (Kind=8) :: a,b, x - complex (Kind=8) :: z, z1 - complex (Kind=8), Dimension(:), allocatable :: griom1 - - Niom = size( xiom ,1 ) - Ntau = size( xtau, 1 ) - - allocate ( griom1(Niom) ) - - a = 0.d0 - b = 0.d0 - Ntail = 10 - do niw = Niom - Ntail, Niom - a = a + dble( griom(niw) * cmplx(0.d0,xiom(niw) ) ) - b = b + dble( griom(niw) * ( cmplx(0.d0,xiom(niw)) *cmplx(0.d0,xiom(niw)) ) ) - enddo - a = a/dble(Ntail + 1) - b = b/dble(Ntail + 1) - write(6,*) 'Fourier: a, b ', a, b - a = 1.d0 - do niw = 1,Niom - griom1(niw) = griom(niw)-cmplx(a,0.d0)/cmplx(0.d0,xiom(niw)) & - & -cmplx(b,0.d0)/ ( cmplx(0.d0,xiom(niw))*cmplx(0.d0,xiom(niw)) ) - enddo - - do nt = 1,Ntau - x = 0.d0 - do niw = 1,Niom - x = x + dble(exp( cmplx(0.d0,-xiom(niw)*xtau(nt)) ) *griom1(niw))*2.d0 - enddo - grtau(nt) = x/beta - a/2.d0 + b*xtau(nt)/2.d0 - beta * b/4.d0 - enddo - - deallocate ( griom1 ) - - end subroutine Matz_tau_T - -!------------------ - subroutine Matz_Tau_T_Bose(griom, xiom, grtau, xtau, beta) - !Working on this - implicit none - ! Given the G(i omega) calculates G(tau) ! for bosons. - real (Kind=8), Dimension(:) :: xiom, xtau - real (Kind=8) :: beta - real (Kind=8), Dimension(:) :: griom - real (Kind=8), Dimension(:) :: grtau - - - Integer :: Niom, Ntau, nt, niw, Ntail - Real (Kind=8) :: a,b, x - complex (Kind=8) :: z, z1 - complex (Kind=8), Dimension(:), allocatable :: griom1 - - Niom = size( xiom ,1 ) - Ntau = size( xtau, 1 ) - - allocate ( griom1(Niom) ) - - ! No tail really necessary since decays as 1/Om**2 - !a = 0.d0 - !b = 0.d0 - !Ntail = 10 - !do niw = Niom - Ntail, Niom - ! a = a + dble( griom(niw) * cmplx(0.d0,xiom(niw) ) ) - ! b = b + dble( griom(niw) * ( cmplx(0.d0,xiom(niw)) *cmplx(0.d0,xiom(niw)) ) ) - !enddo - !a = a/dble(Ntail + 1) - !b = b/dble(Ntail + 1) - !!write(6,*) 'Fourier: a, b ', a, b - !!a = 1.d0 - !do niw = 1,Niom - ! griom1(niw) = griom(niw) - cmplx(a,0.d0)/ cmplx( 0.d0,xiom(niw) ) & - ! & - cmplx(b,0.d0)/ ( cmplx( 0.d0,xiom(niw) ) * cmplx(0.d0,xiom(niw)) ) - !enddo - - do nt = 1,Ntau - x = 0.d0 - do niw = 1,Niom - if ( xiom(niw).gt.0.d0) then - x = x + dble(exp( cmplx(0.d0,-xiom(niw)*xtau(nt)) ) * griom(niw))*2.d0 - else - x = x + dble(exp( cmplx(0.d0,-xiom(niw)*xtau(nt)) ) * griom(niw)) - endif - enddo - grtau(nt) = x/beta ! - a/2.d0 + b*xtau(nt)/2.d0 - beta * b/4.d0 - enddo - - deallocate ( griom1 ) - - end subroutine Matz_Tau_T_Bose - - - -!******** - subroutine Matz_tau_T0(griom, xiom, grt0, gr0t, xtau, beta) - implicit none - ! Given the G(i omega) calculates G(tau). - real (Kind=8), Dimension(:) :: xiom, xtau - real (Kind=8) :: beta - complex (Kind=8), Dimension(:) :: griom - real (Kind=8), Dimension(:) :: grt0, gr0t - - - - Integer :: Niom, Ntau, nt, niw, Ntail - Real (Kind=8) :: a,b, xp, xm - complex (Kind=8) :: z, z1 - complex (Kind=8), Dimension(:), allocatable :: griom1 - - Niom = size( xiom ,1 ) - Ntau = size( xtau, 1 ) - - allocate ( griom1(Niom) ) - - a = 0.d0 - b = 0.d0 - Ntail = 10 - do niw = Niom - Ntail, Niom - a = a + dble( griom(niw) * cmplx(0.d0,xiom(niw) ) ) - b = b + dble( griom(niw) * ( cmplx(0.d0,xiom(niw)) *cmplx(0.d0,xiom(niw)) ) ) - enddo - a = a/dble(Ntail + 1) - b = b/dble(Ntail + 1) - write(6,*) 'Fourier: a, b ', a, b - a = 1.d0 - do niw = 1,Niom - griom1(niw) = griom(niw) - cmplx(a,0.d0)/ cmplx(0.d0,xiom(niw)) & - & - cmplx(b,0.d0)/( cmplx(0.d0,xiom(niw)) * cmplx(0.d0,xiom(niw)) ) - enddo - - do nt = 1,Ntau - xp = 0.d0 - xm = 0.d0 - do niw = 1,Niom - xp = xp + dble(exp( cmplx(0.d0,-xiom(niw)*xtau(nt)) ) *griom1(niw))*2.d0 - xm = xm + dble(exp( cmplx(0.d0, xiom(niw)*xtau(nt)) ) *griom1(niw))*2.d0 - enddo - grt0(nt) = xp/beta - a/2.d0 + b*xtau(nt) /2.d0 - beta * b/4.d0 - gr0t(nt) = xm/beta + a/2.d0 - b*(-xtau(nt))/2.d0 - beta * b/4.d0 - enddo - - deallocate ( griom1 ) - - end subroutine Matz_tau_T0 - -!********** - subroutine Matz_tau_T0_all(g_iom, xiom, g_t0, g_0t, xtau, beta) - implicit none - ! Given the G(i omega) calculates G(tau). - real (Kind=8), Dimension(:) :: xiom, xtau - real (Kind=8) :: beta - Type (Mat_C), Dimension(:,:) :: g_iom - Type (Mat_R), Dimension(:,:) :: g_t0, g_0t - - Complex (Kind=8), Dimension(:), allocatable :: giom - Real (Kind=8), Dimension(:), allocatable :: gt0, g0t - - Integer :: Niom, Ntau, nt, niw, Norb, LQ_C - Integer :: nk, no1, no2 - Complex (Kind=8) :: Z1, Z2 - - Write (6,*) "Size of griom: ", size(g_iom,1), size(g_iom,2) - Write (6,*) "Size of grt0 : ", size(g_t0,1), size(g_t0,2) - Write (6,*) "# of orbitals: ", Size(g_t0(1,1)%el,1), Size(g_t0(1,1)%el,2) - Ntau = size(g_t0,2) - If ( Ntau.ne.size(g_0t,2) .OR. Ntau.ne.size(xtau,1) ) Then - write(6,*) 'Error in ntau! (Fourier, Matz_tau_T0_all) ' - endif - LQ_c = size(g_t0,1) - If ( LQ_c.ne.size(g_0t,1) .OR. LQ_C.ne.size(g_iom,1) ) Then - write(6,*) 'Error in LQ_C! (Fourier, Matz_tau_T0_all) ' - endif - Niom = size(g_iom,2) - If ( Niom.ne.size(xiom,1) ) Then - write(6,*) 'Error in Niom! (Fourier, Matz_tau_T0_all) ' - endif - - Norb = Size(g_t0(1,1)%el,1) - Allocate (giom(Niom), gt0(Ntau), g0t(Ntau) ) - - - Do nk = 1,LQ_C - Do no1 = 1,Norb - Do no2 = 1,Norb - If (no1.eq.no2) then - do niw = 1,Niom - giom(niw) = g_iom(nk,niw)%el(no1,no1) - enddo - elseif (no2.gt.no1) then - ! Build Gamma - do niw = 1,Niom - giom(niw) = ( g_iom(nk,niw)%el(no1,no1) + & - & g_iom(nk,niw)%el(no2,no2) + & - & g_iom(nk,niw)%el(no1,no2) + & - & g_iom(nk,niw)%el(no2,no1) ) / cmplx(2.0,0.d0) - enddo - else - ! Build eta - do niw = 1,Niom - giom(niw) = ( g_iom(nk,niw)%el(no1,no1) + & - & g_iom(nk,niw)%el(no2,no2) - & - & g_iom(nk,niw)%el(no1,no2) - & - & g_iom(nk,niw)%el(no2,no1) ) / cmplx(2.0,0.d0) - enddo - endif - Call Matz_tau_T0(giom, xiom, gt0, g0t, xtau, beta) - do nt = 1,ntau - g_0t(nk,nt)%el(no1,no2) = g0t(nt) - g_t0(nk,nt)%el(no1,no2) = gt0(nt) - enddo - enddo - enddo - do nt = 1,ntau - do no1 = 1,Norb - do no2 = no1+1, Norb - Z1 = g_0t(nk,nt)%el(no1,no2) - Z2 = g_0t(nk,nt)%el(no2,no1) - g_0t(nk,nt)%el(no1,no2) = (Z1 - Z2 )/cmplx(2.0,0.0) - g_0t(nk,nt)%el(no2,no1) = (Z1 - Z2 )/cmplx(2.0,0.0) - - Z1 = g_t0(nk,nt)%el(no1,no2) - Z2 = g_t0(nk,nt)%el(no2,no1) - g_t0(nk,nt)%el(no1,no2) = (Z1 - Z2 )/cmplx(2.0,0.0) - g_t0(nk,nt)%el(no2,no1) = (Z1 - Z2 )/cmplx(2.0,0.0) - enddo - enddo - enddo - - enddo - - Deallocate (giom, gt0, g0t ) - - end subroutine Matz_tau_T0_all - -!********** - subroutine Matz_tau_T_all(g_iom, xiom, g_t0, xtau, beta) - implicit none - ! Given the G(i omega) calculates G(tau). - real (Kind=8), Dimension(:) :: xiom, xtau - real (Kind=8) :: beta - Type (Mat_C), Dimension(:,:) :: g_iom - Type (Mat_R), Dimension(:,:) :: g_t0 - - Complex (Kind=8), Dimension(:), allocatable :: giom - Real (Kind=8), Dimension(:), allocatable :: gt0 - - Integer :: Niom, Ntau, nt, niw, Norb, LQ_C - Integer :: nk, no1, no2 - Complex (Kind=8) :: Z1, Z2 - - Write (6,*) "Size of griom: ", size(g_iom,1), size(g_iom,2) - Write (6,*) "Size of grt0 : ", size(g_t0,1), size(g_t0,2) - Write (6,*) "# of orbitals: ", Size(g_t0(1,1)%el,1), Size(g_t0(1,1)%el,2) - Ntau = size(g_t0,2) - If ( Ntau.ne.size(xtau,1) ) Then - write(6,*) 'Error in ntau! (Fourier, Matz_tau_T0_all) ' - endif - LQ_c = size(g_t0,1) - If ( LQ_C.ne.size(g_iom,1) ) Then - write(6,*) 'Error in LQ_C! (Fourier, Matz_tau_T0_all) ' - endif - Niom = size(g_iom,2) - If ( Niom.ne.size(xiom,1) ) Then - write(6,*) 'Error in Niom! (Fourier, Matz_tau_T0_all) ' - endif - - Norb = Size(g_t0(1,1)%el,1) - Allocate (giom(Niom), gt0(Ntau) ) - - - Do nk = 1,LQ_C - Do no1 = 1,Norb - Do no2 = 1,Norb - If (no1.eq.no2) then - do niw = 1,Niom - giom(niw) = g_iom(nk,niw)%el(no1,no1) - enddo - elseif (no2.gt.no1) then - ! Build Gamma - do niw = 1,Niom - giom(niw) = ( g_iom(nk,niw)%el(no1,no1) + & - & g_iom(nk,niw)%el(no2,no2) + & - & g_iom(nk,niw)%el(no1,no2) + & - & g_iom(nk,niw)%el(no2,no1) ) / cmplx(2.0,0.d0) - enddo - else - ! Build eta - do niw = 1,Niom - giom(niw) = ( g_iom(nk,niw)%el(no1,no1) + & - & g_iom(nk,niw)%el(no2,no2) - & - & g_iom(nk,niw)%el(no1,no2) - & - & g_iom(nk,niw)%el(no2,no1) ) / cmplx(2.0,0.d0) - enddo - endif - Call Matz_tau_T(giom, xiom, gt0, xtau, beta) - !write(6,*) 'Back in Matz_tau_T_all' - do nt = 1,ntau - g_t0(nk,nt)%el(no1,no2) = gt0(nt) - enddo - enddo - enddo - do nt = 1,ntau - do no1 = 1,Norb - do no2 = no1+1, Norb - Z1 = g_t0(nk,nt)%el(no1,no2) - Z2 = g_t0(nk,nt)%el(no2,no1) - g_t0(nk,nt)%el(no1,no2) = (Z1 - Z2 )/cmplx(2.0,0.0) - g_t0(nk,nt)%el(no2,no1) = (Z1 - Z2 )/cmplx(2.0,0.0) - enddo - enddo - enddo - - enddo - - Deallocate (giom, gt0 ) - - end subroutine Matz_tau_T_all -!********** - -!********** - subroutine Matz_tau_T_cdmft(g_iom, xiom, g_t0, xtau, beta) - implicit none - ! Given the G(i omega) calculates G(tau). - real (Kind=8), Dimension(:) :: xiom, xtau - real (Kind=8) :: beta - Type (Mat_C), Dimension(:) :: g_iom - Type (Mat_R), Dimension(:) :: g_t0 - - Complex (Kind=8), Dimension(:), allocatable :: giom - Real (Kind=8), Dimension(:), allocatable :: gt0 - - Integer :: Niom, Ntau, nt, niw, Norb - Integer :: nk, no1, no2 - Complex (Kind=8) :: Z1, Z2 - - Write (6,*) "Size of griom: ", size(g_iom,1) - Write (6,*) "Size of grt0 : ", size(g_t0,1) - Write (6,*) "# of orbitals: ", Size(g_t0(1)%el,1) - Ntau = size(g_t0,1) - If ( Ntau.ne.size(xtau,1) ) Then - write(6,*) 'Error in ntau! (Fourier, Matz_tau_T0_all) ' - endif - Niom = size(g_iom,1) - If ( Niom.ne.size(xiom,1) ) Then - write(6,*) 'Error in Niom! (Fourier, Matz_tau_T0_all) ' - endif - - Norb = Size(g_t0(1)%el,1) - Allocate ( giom(Niom), gt0(Ntau) ) - - - Do no1 = 1,Norb - Do no2 = 1,Norb - If (no1.eq.no2) then - do niw = 1,Niom - giom(niw) = g_iom(niw)%el(no1,no1) - enddo - elseif (no2.gt.no1) then - ! Build Gamma - do niw = 1,Niom - giom(niw) = ( g_iom(niw)%el(no1,no1) + & - & g_iom(niw)%el(no2,no2) + & - & g_iom(niw)%el(no1,no2) + & - & g_iom(niw)%el(no2,no1) ) / cmplx(2.0,0.d0) - enddo - else - ! Build eta - do niw = 1,Niom - giom(niw) = ( g_iom(niw)%el(no1,no1) + & - & g_iom(niw)%el(no2,no2) - & - & g_iom(niw)%el(no1,no2) - & - & g_iom(niw)%el(no2,no1) ) / cmplx(2.0,0.d0) - enddo - endif - Call Matz_tau_T(giom, xiom, gt0, xtau, beta) - !write(6,*) 'Back in Matz_tau_T_all' - do nt = 1,ntau - g_t0(nt)%el(no1,no2) = gt0(nt) - enddo - enddo - enddo - do nt = 1,ntau - do no1 = 1,Norb - do no2 = no1+1, Norb - Z1 = g_t0(nt)%el(no1,no2) - Z2 = g_t0(nt)%el(no2,no1) - g_t0(nt)%el(no1,no2) = (Z1 - Z2 )/cmplx(2.0,0.0) - g_t0(nt)%el(no2,no1) = (Z1 - Z2 )/cmplx(2.0,0.0) - enddo - enddo - enddo - - Deallocate (giom, gt0 ) - - end subroutine Matz_tau_T_cdmft -!********** - - -!---------- - subroutine Matz_tau_T_all_C(g_iom, xiom, g_t0, xtau, beta) - implicit none - ! Given the G(i omega) calculates G(tau). - real (Kind=8), Dimension(:) :: xiom, xtau - real (Kind=8) :: beta - Type (Mat_C), Dimension(:,:) :: g_iom - Type (Mat_C), Dimension(:,:) :: g_t0 - - Complex (Kind=8), Dimension(:), allocatable :: giom - Real (Kind=8), Dimension(:), allocatable :: gt0 - - Integer :: Niom, Ntau, nt, niw, Norb, LQ_C - Integer :: nk, no1, no2 - Complex (Kind=8) :: Z1, Z2 - - Write (6,*) "In Matz_tau_T_all_C" - Write (6,*) "Size of griom: ", size(g_iom,1), size(g_iom,2) - Write (6,*) "Size of grt0 : ", size(g_t0,1), size(g_t0,2) - Write (6,*) "# of orbitals: ", Size(g_t0(1,1)%el,1), Size(g_t0(1,1)%el,2) - Ntau = size(g_t0,2) - If ( Ntau.ne.size(xtau,1) ) Then - write(6,*) 'Error in ntau! (Fourier, Matz_tau_T0_all) ' - endif - LQ_c = size(g_t0,1) - If ( LQ_C.ne.size(g_iom,1) ) Then - write(6,*) 'Error in LQ_C! (Fourier, Matz_tau_T0_all) ' - endif - Niom = size(g_iom,2) - If ( Niom.ne.size(xiom,1) ) Then - write(6,*) 'Error in Niom! (Fourier, Matz_tau_T0_all) ' - endif - - Norb = Size(g_t0(1,1)%el,1) - Allocate (giom(Niom), gt0(Ntau) ) - - - Do nk = 1,LQ_C - Do no1 = 1,Norb - Do no2 = 1,Norb - If (no1.eq.no2) then - do niw = 1,Niom - giom(niw) = g_iom(nk,niw)%el(no1,no1) - enddo - elseif (no2.gt.no1) then - ! Build Gamma - do niw = 1,Niom - giom(niw) = ( g_iom(nk,niw)%el(no1,no1) + & - & g_iom(nk,niw)%el(no2,no2) + & - & g_iom(nk,niw)%el(no1,no2) + & - & g_iom(nk,niw)%el(no2,no1) ) / cmplx(2.0,0.d0) - enddo - else - ! Build eta - do niw = 1,Niom - giom(niw) = ( g_iom(nk,niw)%el(no1,no1) + & - & g_iom(nk,niw)%el(no2,no2) + cmplx(0.d0,1.d0) * ( & - & g_iom(nk,niw)%el(no2,no1) - g_iom(nk,niw)%el(no1,no2) ) ) /& - & cmplx(2.d0,0.d0) - enddo - endif - Call Matz_tau_T(giom, xiom, gt0, xtau, beta) - !write(6,*) 'Back in Matz_tau_T_all' - do nt = 1,ntau - g_t0(nk,nt)%el(no1,no2) = cmplx(gt0(nt), 0.d0) - enddo - enddo - enddo - do nt = 1,ntau - do no1 = 1,Norb - do no2 = no1+1, Norb - Z1 = g_t0(nk,nt)%el(no1,no2) - & - & (g_t0(nk,nt)%el(no1,no1) + g_t0(nk,nt)%el(no2,no2) )/cmplx(2.d0,0.d0) - Z2 = g_t0(nk,nt)%el(no2,no1) - & - & (g_t0(nk,nt)%el(no1,no1) + g_t0(nk,nt)%el(no2,no2) )/cmplx(2.d0,0.d0) - g_t0(nk,nt)%el(no1,no2) = Z1 + cmplx(0.0,1.d0) * Z2 - g_t0(nk,nt)%el(no2,no1) = Z1 - cmplx(0.0,1.d0) * Z2 - enddo - enddo - enddo - - enddo - - Deallocate (giom, gt0 ) - - end subroutine Matz_tau_T_all_C - -!------------ - - - - subroutine Tau_Matz_T(griom, xiom, grtau, xtau, beta, A, xom, cov) - Implicit none - - !Arguments - Complex (Kind=8), Dimension(:) :: griom - Real (Kind=8), Dimension(:) :: xiom, xom, grtau, xtau, A - Real (Kind=8), Dimension(:,:) :: cov - Real (Kind=8) :: Beta - - ! Local - Real (Kind=8), Dimension(:), allocatable :: xqmc - Real (Kind=8), Dimension(:,:), allocatable :: xker - - Integer :: Nom, Ntau, Niom, Niw, Nt, Nw - Real (Kind=8) :: Alpha_st, Chisq, x - - Complex (Kind=8) :: z - - Nom = Size(Xom ,1) - Niom = Size(Xiom,1) - Ntau = Size(Xtau,1) - Allocate (Xqmc(Ntau), Xker(Ntau,Nom) ) - xqmc = -grtau - ! Setup data for MaxEnt. - do nt = 1,ntau - do nw = 1,Nom - XKer(nt,nw) = EXP(-xtau(nt)*xom(nw) ) / ( 1.d0 + EXP( -BETA*xom(nw) ) ) - Enddo - Enddo - - - Alpha_st = 1000000.0 - Chisq = 0.d0 - Call MaxEnt(XQMC, COV, A, XKER, ALPHA_ST, CHISQ ) - - do niw = 1,niom - z = cmplx(0.d0,0.d0) - do nw = 1,nom - z = z + cmplx(A(nw),0.d0)/cmplx(-xom(nw), xiom(niw)) - enddo - griom(niw) = z - enddo - - open (unit=60,file='data_out', status='unknown', position='append') - do nt = 1,ntau - x = 0.d0 - do nw = 1,nom - x = x + xker(nt,nw)*a(nw) - enddo - write(60,2004) xtau(nt), xqmc(nt), sqrt(cov(nt,nt)), x - enddo - close(60) -2004 format(f16.8,2x,f16.8,2x,f16.8,2x,f16.8) - - - deallocate (Xqmc, Xker) - - end subroutine Tau_Matz_T - -!-------------------- - - subroutine Tau_Matz_T_stoch(griom, xiom, grtau, xtau, beta, cov, & - & Alpha_tot, OM_ST, OM_EN, Nsweeps, NBins, NWarm, Xker_func ) - Implicit none - - !Arguments - Complex (Kind=8), Dimension(:) :: griom - Real (Kind=8), Dimension(:) :: xiom, grtau, xtau - Real (Kind=8), Dimension(:,:) :: cov - Real (Kind=8) :: Beta, OM_ST, OM_EN - Real (Kind=8), Dimension(:) :: Alpha_tot - Real (Kind=8), external :: xker_func - Integer :: Nsweeps, NBins, NWarm - - ! Local - Real (Kind=8), Dimension(: ), allocatable :: xqmc, A, xom - - Integer :: Ntau, Niom, Niw, Nt, Nw, Ndis, Ngamma, Lcov - Real (Kind=8) :: Chisq, x, dom, xmom1 - Complex (Kind=8) :: z - - Ndis = 5000 - Allocate ( A(ndis),xom(ndis) ) - Niom = Size(Xiom,1) - Ntau = Size(Xtau,1) - Allocate ( Xqmc(Ntau) ) - Ngamma = Nint(dble(Ntau)*1.5) - If (Ngamma.lt. 200 ) Ngamma = 200 - Lcov = 0 - xqmc = -grtau - xmom1 = 1.d0 - Call MaxEnt_stoch_fit(xqmc, xtau, cov, Lcov, xker_func, Xmom1, Beta, Alpha_tot,& - & Ngamma, OM_ST, OM_EN, Nsweeps, NBins, NWarm, A, & - & xom , Chisq ) - - - dom = xom(2) - xom(1) - do niw = 1,niom - z = cmplx(0.d0,0.d0) - do nw = 1,ndis - z = z + cmplx(A(nw),0.d0)/cmplx(-xom(nw), xiom(niw)) - enddo - griom(niw) = z * dom - enddo - - open (unit=60,file='data_out', status='unknown', position='append') - do nt = 1,ntau - x = 0.d0 - do nw = 1,ndis - x = x + Xker_func(Xtau(nt),xom(nw), beta)*a(nw) - enddo - x = x*dom - write(60,2004) xtau(nt), xqmc(nt), sqrt(cov(nt,nt)), x - enddo - close(60) -2004 format(f16.8,2x,f16.8,2x,f16.8,2x,f16.8) - - - deallocate (Xqmc) - deallocate (A,xom ) - - end subroutine Tau_Matz_T_stoch - -!-------------------- - - subroutine Tau_Matz_T_Bose(griom, xiom, grtau, xtau, beta, A, xom, cov) - ! Working on this. - implicit none - ! Arguments - Real ( Kind=8 ) , Dimension(:) :: griom - Real ( Kind=8 ) , Dimension(:) :: xiom, xom, grtau, xtau, A - Real ( Kind=8 ) , Dimension(:,:) :: cov - Real ( Kind=8 ) :: Beta - - ! Local - Real (Kind=8), Dimension(: ), allocatable :: xqmc - Real (Kind=8), Dimension(:,:), allocatable :: xker - - Integer :: Nom, Ntau, Niom, Niw, Nt, Nw - Real (Kind=8) :: Alpha_st, Chisq, x, Zero - - Complex (Kind=8) :: z - - Nom = Size(Xom ,1) - Zero = 1.D-10 - Do Nw = 1,Nom - if ( xom(Nw) .lt. -Zero ) then - Write(6,*) 'Frequencies should be larger than zero' - stop - endif - enddo - Niom = Size(Xiom,1) - Ntau = Size(Xtau,1) - Allocate ( Xqmc(Ntau), Xker(Ntau,Nom) ) - ! Setup data for MaxEnt. - - xqmc = grtau - do nt = 1,ntau - !write(6,*) xtau(nt), xqmc(nt), sqrt(cov(nt,nt)), Beta - do nw = 1,Nom - if (Xom(nw).gt.Zero) then - XKer(nt,nw) = xom(nw)*(EXP(-xtau(nt)*xom(nw))/(1.d0-EXP( -BETA*xom(nw) ) ) - & - & EXP( xtau(nt)*xom(nw))/(1.d0-EXP( BETA*xom(nw) ) ) ) - else - Xker(nt,nw) = 2.d0/Beta - endif - Enddo - Enddo - - - Alpha_st = 1000000.0 - Chisq = 0.d0 - Call MaxEnt(XQMC, COV, A, XKER, ALPHA_ST, CHISQ ) - - do niw = 1,niom - x = 0.d0 - If ( abs(xiom(niw)).gt.Zero) then - do nw = 1,nom - x = x + 2.d0*A(nw) * xom(nw)* xom(nw)/( xom(nw)**2 + xiom(niw)**2) - enddo - else - do nw = 1,nom - x = x + 2.d0*A(nw) - enddo - endif - griom(niw) = x - enddo - - ! A( nw ) = A(w)*Dom - ! A(w) = (1/pi)*chi''(w)/w - open (unit=60,file='data_out', status='unknown', position='append') - do nt = 1,ntau - x = 0.d0 - do nw = 1,nom - x = x + xker(nt,nw)*a(nw) - enddo - write(60,2004) xtau(nt), xqmc(nt), sqrt(cov(nt,nt)), x - enddo - close(60) -2004 format(f16.8,2x,f16.8,2x,f16.8,2x,f16.8) - - - deallocate (Xqmc, Xker) - - end subroutine Tau_Matz_T_Bose - - -!-------------------- -!!!!!! To be tested !!!!! - subroutine Tau_Matz_T0_stoch(griom, xiom, g_t0, cov_t0, g_0t, cov_0t, xtau, beta, Rel_Err, & - & Alpha_tot, OM_ST, OM_EN, Nsweeps, NBins, NWarm, Xker_func ) - Implicit none - - !Arguments - Complex (Kind=8), Dimension(:) :: griom - Real (Kind=8), Dimension(:) :: xiom,g_t0, g_0t, xtau - Real (Kind=8), Dimension(:,:) :: cov_t0, cov_0t - Real (Kind=8) :: Beta, OM_ST, OM_EN, Rel_Err - Real (Kind=8), Dimension(:) :: Alpha_tot - Real (Kind=8), external :: xker_func - Integer :: Nsweeps, NBins, NWarm - - ! Local - Real (Kind=8), Dimension(: ), allocatable :: xqmc, A_t0, A_0t, xom - - Integer :: Ntau, Niom, Niw, Nt, Nw, Ndis, Ngamma, Lcov - Real (Kind=8) :: Chisq, x, dom, xmom1 - Complex (Kind=8) :: z - - Ndis = 5000 - Allocate ( A_0t(ndis),A_t0(ndis), xom(ndis) ) - Niom = Size(Xiom,1) - Ntau = Size(Xtau,1) - Allocate ( Xqmc(Ntau) ) - Ngamma = Nint(dble(Ntau)*1.5) - If (Ngamma.lt. 200 ) Ngamma = 200 - Lcov = 0 - xqmc = -g_t0 - xmom1 = xqmc(1) - Call MaxEnt_stoch_fit(xqmc, xtau, cov_t0, Lcov, xker_func, Xmom1, Beta, Alpha_tot,& - & Ngamma, OM_ST, OM_EN, Nsweeps, NBins, NWarm, A_t0, & - & xom , Chisq ) - - Lcov = 0 - xqmc = g_0t - xmom1 = xqmc(1) - Call MaxEnt_stoch_fit(xqmc, xtau, cov_0t, Lcov, xker_func, Xmom1, Beta, Alpha_tot,& - & Ngamma, OM_ST, OM_EN, Nsweeps, NBins, NWarm, A_0t, & - & xom , Chisq ) - - dom = xom(2) - xom(1) - do niw = 1,niom - z = cmplx(0.d0,0.d0) - do nw = 1, ndis - z = z + cmplx(A_t0(nw),0.d0)/cmplx(-xom(nw), xiom(niw)) + & - & cmplx(A_0t(nw),0.d0)/cmplx( xom(nw), xiom(niw)) - enddo - griom(niw) = z*dom - enddo - - - open (unit=60,file='data_out', status='unknown', position='append') - do nt = ntau,1,-1 - x = 0.d0 - do nw = 1,ndis - x = x + Xker_func(Xtau(nt),xom(nw), beta)*A_0t(nw) - enddo - x = x*dom - write(60,2004) -xtau(nt), g_0t(nt), sqrt(cov_0t(nt,nt)), x - enddo - do nt = 1,ntau - x = 0.d0 - do nw = 1,ndis - x = x + Xker_func(Xtau(nt),xom(nw), beta)*A_t0(nw) - enddo - x = x*dom - write(60,2004) xtau(nt), -g_t0(nt), sqrt(cov_t0(nt,nt)), x - enddo - close(60) -2004 format(f16.8,2x,f16.8,2x,f16.8,2x,f16.8) - - deallocate (Xqmc) - deallocate (A_0t,A_t0,xom ) - - end subroutine Tau_Matz_T0_stoch - -!-------------------- - - subroutine Tau_Matz_T0(griom, xiom, g_t0, cov_t0, g_0t, cov_0t, xtau, A_0t, A_t0, xom, & - & Rel_Err, Beta) - - Implicit none - - !Arguments - Complex (Kind=8), Dimension(:) :: griom - Real (Kind=8), Dimension(:) :: xiom, g_t0, g_0t, xtau, A_0t, A_t0, xom - Real (Kind=8), Dimension(:,:) :: cov_t0, cov_0t - Real (Kind=8) :: Rel_Err - Real (Kind=8), optional :: Beta - - ! Local - Real (Kind=8), Dimension(:), allocatable :: xqmc - Real (Kind=8), Dimension(:,:), allocatable :: xker, xcov - - Integer :: Nom, Ntau, Niom, Niw, Nt, Nw, Ntau_eff - Real (Kind=8) :: Alpha_st, Chisq, x - - Complex (Kind=8) :: z - - Nom = Size(Xom ,1) - Niom = Size(Xiom,1) - Ntau = Size(Xtau,1) - - Allocate (Xqmc(Ntau), Xker(Ntau,Nom)) - Write(6,*) ' Calling Max_Ent from T=0 routine. ' - ! t > 0 - ! Setup data for MaxEnt. - If (Present(Beta)) Then - do nt = 1,ntau - do nw = 1,Nom - XKer(nt,nw) = EXP(-xtau(nt)*xom(nw) )/ ( 1.d0 + EXP( -BETA*xom(nw)) ) - Enddo - Enddo - else - do nt = 1,ntau - do nw = 1,Nom - XKer(nt,nw) = EXP(-xtau(nt)*xom(nw) ) - Enddo - Enddo - endif - Alpha_st = 100000.0 - Chisq = 0.d0 - xqmc = -g_t0 - Open (Unit=13,file='In_MaxEnt_T0', status='unknown', position='append') - do nt = 1,ntau - write(13,2001) xtau(nt), xqmc(nt), sqrt(cov_t0(nt,nt)) - enddo - write(13,*) - close(13) - Call MaxEnt(XQMC, COV_t0, A_t0, XKER, ALPHA_ST, CHISQ, Rel_err ) - - Alpha_st = 100000.0 - Chisq = 0.d0 - xqmc = g_0t - Open (Unit=13,file='In_MaxEnt_T0', status='unknown', position='append') - do nt = 1,ntau - write(13,2001) xtau(nt), xqmc(nt), sqrt(cov_0t(nt,nt)) - enddo - write(13,*) - close(13) - Call MaxEnt(XQMC, COV_0t, A_0t, XKER, ALPHA_ST, CHISQ, Rel_err) - -! do niw = 1,niom -! z = cmplx(0.d0,0.d0) -! do nw = 1,nom -! z = z + cmplx(A(nw),0.d0)/cmplx(-xom(nw), xiom(niw)) -! enddo -! griom(niw) = z -! enddo - - - do niw = 1,niom - z = cmplx(0.d0,0.d0) - do nw = 1,nom - z = z + cmplx(A_t0(nw),0.d0)/cmplx(-xom(nw), xiom(niw)) + & - & cmplx(A_0t(nw),0.d0)/cmplx( xom(nw), xiom(niw)) - enddo - griom(niw) = z - enddo - - - open (unit=60,file='data_out', status='unknown', position='append') - do nt = 1,ntau - x = 0.d0 - do nw = 1,nom - x = x + xker(nt,nw)*a_t0(nw) - enddo - write(60,2004) xtau(nt), -g_t0(nt), sqrt(cov_t0(nt,nt)), x - enddo - write(60,*) - do nt = 1,ntau - x = 0.d0 - do nw = 1,nom - x = x + xker(nt,nw)*a_0t(nw) - enddo - write(60,2004) xtau(nt), g_0t(nt), sqrt(cov_0t (nt,nt)), x - enddo - write(60,*) - - close(60) -2004 format(f16.8,2x,f16.8,2x,f16.8,2x,f16.8) - -2001 format(F16.8,2x,F16.8,2x,F16.8) - - deallocate (Xqmc, Xker) - - - - end subroutine Tau_Matz_T0 - -!************ - subroutine Tau_Matz_T0_all( g_iom_mat, xiom, g_t0_mat, error_t0_mat, g_0t_mat, error_0t_mat, & - & xtau, xom, Rel_err ) - - Implicit none - - !Arguments - Type (Mat_C), Dimension(:,:) :: g_iom_mat - Type (Mat_R), Dimension(:,:) :: g_t0_mat, g_0t_mat - Type (Mat_R), Dimension(:,:) :: error_t0_mat, error_0t_mat - Real (Kind=8), Dimension(:) :: xiom, xtau, xom - Real (Kind=8) :: Rel_err - - Complex (Kind=8), Dimension(:), allocatable :: giom - Real (Kind=8), Dimension(:), allocatable :: gt0, g0t, A0t, At0 - Real (Kind=8), Dimension(:,:), allocatable :: covt0, cov0t - - Integer :: Nom, Ntau, Niom, Niw, Nt, Nw - - ! ******* Input is | g_11 , (g_11 + g_22 + g_12 + g_21)/2.0 | - ! |(g_11 + g_22 - g_12 - g_21)/2.0, g_22 | - ! As a function of tau. - ! - ! ******* Output is | g_11 , g_12 | - ! | g_21 , g_22 | - ! As a funtion of omega_m - - ! Local - Integer :: LQ_c, Norb - Integer :: nt1, nk, no1,no2 - Complex (Kind=8) :: Zp - - Ntau = size(g_t0_mat,2) - If ( Ntau.ne.size(g_0t_mat,2) .OR. Ntau.ne.size(xtau,1) ) Then - write(6,*) 'Error in ntau! (Fourier, Tau_Matz_T0_all) ' - endif - LQ_c = size(g_t0_mat,1) - If ( LQ_c.ne.size(g_0t_mat,1) .OR. LQ_C.ne.size(g_iom_mat,1) ) Then - write(6,*) 'Error in LQ_C! (Fourier, Tau_Matz_T0_all) ' - endif - Niom = size(g_iom_mat,2) - If ( Niom.ne.size(xiom,1) ) Then - write(6,*) 'Error in Niom! (Fourier, Tau_Matz_T0_all) ' - endif - - Norb = Size(g_t0_mat(1,1)%el,1) - Nom = Size(xom,1) - - allocate(giom(Niom), gt0(Ntau), g0t(Ntau), A0t(Nom), At0(Nom), & - & covt0(Ntau,Ntau), cov0t(Ntau,Ntau) ) - - - do nk = 1,LQ_C - do no1 = 1,Norb - do no2 = 1,Norb - do nt = 1,Ntau - gt0(nt) = g_t0_mat(nk,nt)%el(no1,no2) - g0t(nt) = g_0t_mat(nk,nt)%el(no1,no2) - enddo - covt0 = 0.0; cov0t = 0.0 - do nt = 1,Ntau - covt0(nt,nt) = (error_t0_mat(nk,nt)%el(no1,no2))**2 - cov0t(nt,nt) = (error_0t_mat(nk,nt)%el(no1,no2))**2 - enddo - Write(6,* ) ' Nk is : ', nk - call Tau_Matz_T0(giom, xiom, gt0, covt0, g0t, cov0t, xtau, A0t, At0, xom, Rel_err) - do nw = 1,Niom - g_iom_mat(nk,nw)%el(no1,no2) = giom(nw) - enddo - enddo - enddo - do no1 = 1,Norb - do no2 = no1 + 1, Norb - do nw = 1,Niom - Zp = g_iom_mat(nk,nw)%el(no1,no2) - g_iom_mat(nk,nw)%el(no2,no1) - g_iom_mat(nk,nw)%el(no1,no2) = Zp/cmplx(2.0,0.0) - g_iom_mat(nk,nw)%el(no2,no1) = Zp/cmplx(2.0,0.0) - enddo - enddo - enddo - enddo - deallocate( giom, gt0, g0t, A0t, At0, covt0, cov0t ) - - end subroutine Tau_Matz_T0_all - - -!----------------- - subroutine Tau_Matz_T_all_stoch_C(g_iom_mat, xiom, g_t0_mat, error_t0_mat, xtau, Beta,& - & Alpha_tot, OM_ST, OM_EN, Nsweeps, NBins, NWarm, Xker_func ) - - Implicit none - - !Arguments - Type (Mat_C), Dimension(:,:) :: g_iom_mat - Type (Mat_C), Dimension(:,:) :: g_t0_mat - Type (Mat_R), Dimension(:,:) :: error_t0_mat - Real (Kind=8), Dimension(:) :: xiom, xtau - Real (Kind=8) :: Beta, OM_St, OM_EN - Real (Kind=8), external :: Xker_func - Real (Kind=8), Dimension(:) :: Alpha_tot - Integer :: Nsweeps, NBins, NWarm - - Complex (Kind=8), Dimension(:), allocatable :: giom - Real (Kind=8), Dimension(:), allocatable :: gt0 - Real (Kind=8), Dimension(:,:), allocatable :: covt0 - - Integer :: Nom, Ntau, Niom, Niw, Nt, Nw - - ! ******* Input is | g_11 , (g_11 + g_22 + g_12 + g_21)/2.0 | - ! |(g_11 + g_22 - i[g_12 - g_21]) /2.0, g_22 | - ! As a function of tau. Note that input is real since. - ! With gamma = (c + d)/sqrt(2) and eta = (c + i d)/sqrt(2) - ! ******* Input is | cc* , gamma gamma* | - ! | eta eta* , dd* | - - ! - ! ******* Output is | g_11 , g_12 | - ! | g_21 , g_22 | - ! As a funtion of omega_m - - ! Local - Integer :: LQ_c, Norb - Integer :: nt1, nk, no1,no2 - Complex (Kind=8) :: Z1, Z2 - - Ntau = size(g_t0_mat,2) - If ( Ntau.ne.size(xtau,1) ) Then - write(6,*) 'Error in ntau! (Fourier, Tau_Matz_T_all) ' - endif - LQ_c = size(g_t0_mat,1) - If ( LQ_C.ne.size(g_iom_mat,1) ) Then - write(6,*) 'Error in LQ_C! (Fourier, Tau_Matz_T_all) ' - endif - Niom = size(g_iom_mat,2) - If ( Niom.ne.size(xiom,1) ) Then - write(6,*) 'Error in Niom! (Fourier, Tau_Matz_T_all) ' - endif - - Norb = Size(g_t0_mat(1,1)%el,1) - - allocate(giom(Niom), gt0(Ntau), covt0(Ntau,Ntau) ) - - - do nk = 1,LQ_C - do no1 = 1,Norb - do no2 = 1,Norb - do nt = 1,Ntau - gt0(nt) = dble(g_t0_mat(nk,nt)%el(no1,no2)) - enddo - covt0 = 0.0 - do nt = 1,Ntau - covt0(nt,nt) = (error_t0_mat(nk,nt)%el(no1,no2))**2 - enddo - Write(6,* ) ' Nk is : ', nk - Call Tau_Matz_T_stoch(giom, xiom, gt0, xtau, beta, covt0, & - & Alpha_tot, OM_ST, OM_EN, Nsweeps, NBins, NWarm, Xker_func ) - do nw = 1,Niom - g_iom_mat(nk,nw)%el(no1,no2) = giom(nw) - enddo - enddo - enddo - do no1 = 1,Norb - do no2 = no1 + 1, Norb - do nw = 1,Niom - Z1 = g_iom_mat(nk,nw)%el(no1,no2) - & - & (g_iom_mat(nk,nw)%el(no1,no1)+g_iom_mat(nk,nw)%el(no2,no2))/cmplx(2.d0,0.d0) - Z2 = g_iom_mat(nk,nw)%el(no2,no1) - & - & (g_iom_mat(nk,nw)%el(no1,no1)+g_iom_mat(nk,nw)%el(no2,no2))/cmplx(2.d0,0.d0) - g_iom_mat(nk,nw)%el(no1,no2) = Z1 + cmplx(0.0,1.d0)*Z2 - g_iom_mat(nk,nw)%el(no2,no1) = Z1 - cmplx(0.0,1.d0)*Z2 - enddo - enddo - enddo - enddo - deallocate( giom, gt0, covt0) - end subroutine Tau_Matz_T_all_stoch_C - - -!----------------- - subroutine Tau_Matz_T_all_stoch(g_iom_mat, xiom, g_t0_mat, error_t0_mat, xtau, Beta,& - & Alpha_tot, OM_ST, OM_EN, Nsweeps, NBins, NWarm, Xker_func ) - - Implicit none - - !Arguments - Type (Mat_C), Dimension(:,:) :: g_iom_mat - Type (Mat_R), Dimension(:,:) :: g_t0_mat - Type (Mat_R), Dimension(:,:) :: error_t0_mat - Real (Kind=8), Dimension(:) :: xiom, xtau - Real (Kind=8) :: Beta, OM_St, OM_EN - Real (Kind=8), external :: Xker_func - Real (Kind=8), Dimension(:) :: Alpha_tot - Integer :: Nsweeps, NBins, NWarm - - Complex (Kind=8), Dimension(:), allocatable :: giom - Real (Kind=8), Dimension(:), allocatable :: gt0 - Real (Kind=8), Dimension(:,:), allocatable :: covt0 - - Integer :: Nom, Ntau, Niom, Niw, Nt, Nw - - ! ******* Input is | g_11 , (g_11 + g_22 + g_12 + g_21)/2.0 | - ! |(g_11 + g_22 - g_12 - g_21)/2.0, g_22 | - ! As a function of tau. - ! - ! ******* Output is | g_11 , g_12 | - ! | g_21 , g_22 | - ! As a funtion of omega_m - - ! Local - Integer :: LQ_c, Norb - Integer :: nt1, nk, no1,no2 - Complex (Kind=8) :: Zp - - Ntau = size(g_t0_mat,2) - If ( Ntau.ne.size(xtau,1) ) Then - write(6,*) 'Error in ntau! (Fourier, Tau_Matz_T_all) ' - endif - LQ_c = size(g_t0_mat,1) - If ( LQ_C.ne.size(g_iom_mat,1) ) Then - write(6,*) 'Error in LQ_C! (Fourier, Tau_Matz_T_all) ' - endif - Niom = size(g_iom_mat,2) - If ( Niom.ne.size(xiom,1) ) Then - write(6,*) 'Error in Niom! (Fourier, Tau_Matz_T_all) ' - endif - - Norb = Size(g_t0_mat(1,1)%el,1) - - allocate(giom(Niom), gt0(Ntau), covt0(Ntau,Ntau) ) - - - do nk = 1,LQ_C - do no1 = 1,Norb - do no2 = 1,Norb - do nt = 1,Ntau - gt0(nt) = g_t0_mat(nk,nt)%el(no1,no2) - enddo - covt0 = 0.0 - do nt = 1,Ntau - covt0(nt,nt) = (error_t0_mat(nk,nt)%el(no1,no2))**2 - enddo - Write(6,* ) ' Nk is : ', nk - Call Tau_Matz_T_stoch(giom, xiom, gt0, xtau, beta, covt0, & - & Alpha_tot, OM_ST, OM_EN, Nsweeps, NBins, NWarm, Xker_func ) - do nw = 1,Niom - g_iom_mat(nk,nw)%el(no1,no2) = giom(nw) - enddo - enddo - enddo - do no1 = 1,Norb - do no2 = no1 + 1, Norb - do nw = 1,Niom - Zp = g_iom_mat(nk,nw)%el(no1,no2) - g_iom_mat(nk,nw)%el(no2,no1) - g_iom_mat(nk,nw)%el(no1,no2) = Zp/cmplx(2.0,0.0) - g_iom_mat(nk,nw)%el(no2,no1) = Zp/cmplx(2.0,0.0) - enddo - enddo - enddo - enddo - deallocate( giom, gt0, covt0) - end subroutine Tau_Matz_T_all_stoch - -!----------------------- - subroutine Tau_Matz_T_all_stoch_cdmft(g_iom_mat, xiom, g_t0_mat, error_t0_mat, xtau, Beta,& - & Alpha_tot, OM_ST, OM_EN, Nsweeps, NBins, NWarm, Xker_func ) - - Implicit none - - !Arguments - Type (Mat_C), Dimension(:) :: g_iom_mat - Type (Mat_R), Dimension(:) :: g_t0_mat - Type (Mat_R), Dimension(:) :: error_t0_mat - Real (Kind=8), Dimension(:) :: xiom, xtau - Real (Kind=8) :: Beta, OM_St, OM_EN - Real (Kind=8), external :: Xker_func - Real (Kind=8), Dimension(:) :: Alpha_tot - Integer :: Nsweeps, NBins, NWarm - - Complex (Kind=8), Dimension(:), allocatable :: giom - Real (Kind=8), Dimension(:), allocatable :: gt0 - Real (Kind=8), Dimension(:,:), allocatable :: covt0 - - Integer :: Nom, Ntau, Niom, Niw, Nt, Nw - - ! ******* Input is | g_11 , (g_11 + g_22 + g_12 + g_21)/2.0 | - ! |(g_11 + g_22 - g_12 - g_21)/2.0, g_22 | - ! As a function of tau. and generalization thereof for larger matrices. - ! - ! ******* Output is | g_11 , g_12 | - ! | g_21 , g_22 | - ! As a funtion of omega_m - - ! Local - Integer :: LQ_c, Norb - Integer :: nt1, nk, no1,no2 - Complex (Kind=8) :: Zp - - Ntau = size(g_t0_mat,1) - If ( Ntau.ne.size(xtau,1) ) Then - write(6,*) 'Error in ntau! (Fourier, Tau_Matz_T_all) ' - endif - Niom = size(g_iom_mat,1) - If ( Niom.ne.size(xiom,1) ) Then - write(6,*) 'Error in Niom! (Fourier, Tau_Matz_T_all) ' - endif - - Norb = Size(g_t0_mat(1)%el,1) - - allocate(giom(Niom), gt0(Ntau), covt0(Ntau,Ntau) ) - - - do no1 = 1,Norb - do no2 = 1,Norb - - do nt = 1,Ntau - gt0(nt) = g_t0_mat(nt)%el(no1,no2) - enddo - covt0 = 0.0 - do nt = 1,Ntau - covt0(nt,nt) = (error_t0_mat(nt)%el(no1,no2))**2 - enddo - Call Tau_Matz_T_stoch(giom, xiom, gt0, xtau, beta, covt0, & - & Alpha_tot, OM_ST, OM_EN, Nsweeps, NBins, NWarm, Xker_func ) - do nw = 1,Niom - g_iom_mat(nw)%el(no1,no2) = giom(nw) - enddo - enddo - enddo - do no1 = 1,Norb - do no2 = no1 + 1, Norb - do nw = 1,Niom - Zp = g_iom_mat(nw)%el(no1,no2) - g_iom_mat(nw)%el(no2,no1) - g_iom_mat(nw)%el(no1,no2) = Zp/cmplx(2.0,0.0) - g_iom_mat(nw)%el(no2,no1) = Zp/cmplx(2.0,0.0) - enddo - enddo - enddo - deallocate( giom, gt0, covt0) - end subroutine Tau_Matz_T_all_stoch_cdmft - -!----------------- - subroutine Tau_Matz_T_all(g_iom_mat, xiom, g_t0_mat, error_t0_mat, xtau, xom, Beta ) - - Implicit none - - !Arguments - Type (Mat_C), Dimension(:,:) :: g_iom_mat - Type (Mat_R), Dimension(:,:) :: g_t0_mat - Type (Mat_R), Dimension(:,:) :: error_t0_mat - Real (Kind=8), Dimension(:) :: xiom, xtau, xom - Real (Kind=8) :: Beta - - Complex (Kind=8), Dimension(:), allocatable :: giom - Real (Kind=8), Dimension(:), allocatable :: gt0, At0 - Real (Kind=8), Dimension(:,:), allocatable :: covt0 - - Integer :: Nom, Ntau, Niom, Niw, Nt, Nw - - ! ******* Input is | g_11 , (g_11 + g_22 + g_12 + g_21)/2.0 | - ! |(g_11 + g_22 - g_12 - g_21)/2.0, g_22 | - ! As a function of tau. - ! - ! ******* Output is | g_11 , g_12 | - ! | g_21 , g_22 | - ! As a funtion of omega_m - - ! Local - Integer :: LQ_c, Norb - Integer :: nt1, nk, no1,no2 - Complex (Kind=8) :: Zp - - Ntau = size(g_t0_mat,2) - If ( Ntau.ne.size(xtau,1) ) Then - write(6,*) 'Error in ntau! (Fourier, Tau_Matz_T_all) ' - endif - LQ_c = size(g_t0_mat,1) - If ( LQ_C.ne.size(g_iom_mat,1) ) Then - write(6,*) 'Error in LQ_C! (Fourier, Tau_Matz_T_all) ' - endif - Niom = size(g_iom_mat,2) - If ( Niom.ne.size(xiom,1) ) Then - write(6,*) 'Error in Niom! (Fourier, Tau_Matz_T_all) ' - endif - - Norb = Size(g_t0_mat(1,1)%el,1) - Nom = Size(xom,1) - - allocate(giom(Niom), gt0(Ntau), At0(Nom), covt0(Ntau,Ntau) ) - - - do nk = 1,LQ_C - do no1 = 1,Norb - do no2 = 1,Norb - do nt = 1,Ntau - gt0(nt) = g_t0_mat(nk,nt)%el(no1,no2) - enddo - covt0 = 0.0 - do nt = 1,Ntau - covt0(nt,nt) = (error_t0_mat(nk,nt)%el(no1,no2))**2 - enddo - Write(6,* ) ' Nk is : ', nk - Call Tau_Matz_T(giom, xiom, gt0, xtau, beta, At0, xom, covt0) - do nw = 1,Niom - g_iom_mat(nk,nw)%el(no1,no2) = giom(nw) - enddo - enddo - enddo - do no1 = 1,Norb - do no2 = no1 + 1, Norb - do nw = 1,Niom - Zp = g_iom_mat(nk,nw)%el(no1,no2) - g_iom_mat(nk,nw)%el(no2,no1) - g_iom_mat(nk,nw)%el(no1,no2) = Zp/cmplx(2.0,0.0) - g_iom_mat(nk,nw)%el(no2,no1) = Zp/cmplx(2.0,0.0) - enddo - enddo - enddo - enddo - deallocate( giom, gt0, At0, covt0) - - end subroutine Tau_Matz_T_all - - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!---------------------------------------------------------------------- - subroutine tau_matz_spline(nspl,griom, xiom, grtau, xtau) - implicit none - - integer, intent(in) :: nspl - real(kind=8), dimension(:), intent(in) :: xiom,xtau,grtau - complex(kind=8), dimension(size(xiom)), intent(out) :: griom - - integer :: itau,iom,ntau,niom - real(kind=8) :: dx - real(kind=8), dimension(:), allocatable :: xtau_spl,grtau_spl - - ntau = size(xtau) - niom = size(xiom) - - allocate(xtau_spl(0:nspl),grtau_spl(0:nspl)) - - dx = xtau(ntau) / dble(nspl) - do itau = 0,nspl - xtau_spl(itau) = dx * dble(itau) - enddo - - call aspline(xtau,grtau,xtau_spl,grtau_spl) - -!!$ open(10,file='spline.dat',position='append') -!!$ do itau = 0,nspl -!!$ write(10,*) xtau_spl(itau),grtau_spl(itau) -!!$ enddo -!!$ write(10,*) -!!$ write(10,*) -!!$ close(10) - - griom = (0.d0,0.d0) - do iom = 1,niom - do itau = 0,nspl - griom(iom) = griom(iom) & - + exp(cmplx(0.d0,xiom(iom)*xtau_spl(itau))) * cmplx(grtau_spl(itau) * dx,0.d0) - enddo - enddo - - deallocate(xtau_spl,grtau_spl) - - end subroutine tau_matz_spline - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!---------------------------------------------------------------------- - subroutine tau_matz_spline_all(nspl, g_iom_mat, xiom, g_t0_mat, xtau) - - Implicit none - - !Arguments - integer :: nspl - Type (Mat_C), Dimension(:,:) :: g_iom_mat - Type (Mat_R), Dimension(:,:) :: g_t0_mat - Real (Kind=8), Dimension(:) :: xiom, xtau - - Complex (Kind=8), Dimension(:), allocatable :: giom - Real (Kind=8), Dimension(:), allocatable :: gt0 - - Integer :: Ntau, Niom, Niw, Nt, Nw - - ! ******* Input is | g_11 , (g_11 + g_22 + g_12 + g_21)/2.0 | - ! |(g_11 + g_22 - g_12 - g_21)/2.0, g_22 | - ! As a function of tau. - ! - ! ******* Output is | g_11 , g_12 | - ! | g_21 , g_22 | - ! As a funtion of omega_m - - ! Local - Integer :: LQ_c, Norb - Integer :: nt1, nk, no1,no2 - Complex (Kind=8) :: Zp - - Ntau = size(g_t0_mat,2) - If ( Ntau.ne.size(xtau,1) ) Then - write(6,*) 'Error in ntau! (Fourier, Tau_Matz_T_all) ' - endif - LQ_c = size(g_t0_mat,1) - If ( LQ_C.ne.size(g_iom_mat,1) ) Then - write(6,*) 'Error in LQ_C! (Fourier, Tau_Matz_T_all) ' - endif - Niom = size(g_iom_mat,2) - If ( Niom.ne.size(xiom,1) ) Then - write(6,*) 'Error in Niom! (Fourier, Tau_Matz_T_all) ' - endif - - Norb = Size(g_t0_mat(1,1)%el,1) - - allocate(giom(Niom), gt0(Ntau)) - - - do nk = 1,LQ_C - do no1 = 1,Norb - do no2 = 1,Norb - do nt = 1,Ntau - gt0(nt) = g_t0_mat(nk,nt)%el(no1,no2) - enddo - Write(6,* ) ' Nk is : ', nk - Call tau_matz_spline(nspl, giom, xiom, gt0, xtau) - do nw = 1,Niom - g_iom_mat(nk,nw)%el(no1,no2) = giom(nw) - enddo - enddo - enddo - do no1 = 1,Norb - do no2 = no1 + 1, Norb - do nw = 1,Niom - Zp = g_iom_mat(nk,nw)%el(no1,no2) - g_iom_mat(nk,nw)%el(no2,no1) - g_iom_mat(nk,nw)%el(no1,no2) = Zp/cmplx(2.0,0.0) - g_iom_mat(nk,nw)%el(no2,no1) = Zp/cmplx(2.0,0.0) - enddo - enddo - enddo - enddo - deallocate( giom, gt0) - - end subroutine Tau_matz_spline_all - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!---------------------------------------------------------------------- -! equidistant x-axis values - subroutine aspline(x,y,x_new,y_new) - implicit none - - real(kind=8), dimension(:), intent(in) :: x,y,x_new - real(kind=8), dimension(:), intent(out) :: y_new - - integer :: i,j,n1,n2 - real(kind=8), dimension(:), allocatable:: x_tmp,y_tmp,t - real(kind=8) :: dx,a,b,m1,m2,m3,m4 - - n1 = size(x) - n2 = size(x_new) - - allocate(x_tmp(n1+4),y_tmp(n1+4)) ! add two points at both sides - - dx = x(2)-x(1) - x_tmp = 0.d0 - y_tmp = 0.d0 - x_tmp(3:n1+2) = x(:) - y_tmp(3:n1+2) = y(:) - -!Corner points - x_tmp(1) = x(1) - 2.d0 * dx - x_tmp(2) = x(1) - dx - x_tmp(n1+3) = x(n1) + dx - x_tmp(n1+4) = x(n1) + 2.d0 * dx - - y_tmp(n1+3) = yup(n1+3,x_tmp,y_tmp) - y_tmp(n1+4) = yup(n1+4,x_tmp,y_tmp) - y_tmp(2) = ydn(2,x_tmp,y_tmp) - y_tmp(1) = ydn(1,x_tmp,y_tmp) - -! Slopes - allocate(t(n1)) - do i = 1,n1 - j = i + 2 - m1 = slope(dx,y_tmp(j-2),y_tmp(j-1)) - m2 = slope(dx,y_tmp(j-1),y_tmp(j)) - m3 = slope(dx,y_tmp(j),y_tmp(j+1)) - m4 = slope(dx,y_tmp(j+1),y_tmp(j+2)) - a = dabs(m4-m3) * m2 + dabs(m2-m1) * m3 - b = dabs(m4-m3) + dabs(m2-m1) - if (b /= 0.d0) then - t(i) = a / b - else - t(i) = 0.5d0 * (m2+m3) - end if - enddo - -! Interpolate - do i = 1,n2 - do j = 1,n1-1 - if (x_new(i) >= x(j) .and. x_new(i) <= x(j+1) ) & - y_new(i) = poly(x(j),x(j+1),y(j),y(j+1),t(j),t(j+1),x_new(i)) - enddo - enddo - - deallocate(x_tmp,y_tmp,t) - - end subroutine aspline - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!---------------------------------------------------------------------- - real(kind=8) function yup(n,x,y) - implicit none - - integer, intent(in) :: n - real(kind=8), dimension(:), intent(in) :: x,y - - yup = (2.d0 & - * (y(n-1)-y(n-2))/(x(n-1)-x(n-2)) - (y(n-2)-y(n-3))/(x(n-2)-x(n-3))) & - * (x(n)-x(n-1)) + y(n-1) - - end function yup - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!---------------------------------------------------------------------- - real(kind=8) function ydn(n,x,y) - implicit none - - integer, intent(in) :: n - real(kind=8), dimension(:), intent(in) :: x,y - - ydn = (-2.d0 & - * (y(n+2)-y(n+1))/(x(n+2)-x(n+1)) + (y(n+3)-y(n+2))/(x(n+3)-x(n+2))) & - * (x(n+1)-x(n)) + y(n+1) - - end function ydn - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!---------------------------------------------------------------------- - real(kind=8) function slope(dx,y_dn,y_up) - implicit none - - real(kind=8), intent(in) :: dx,y_dn,y_up - - slope = (y_up - y_dn) / dx - - end function slope - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!---------------------------------------------------------------------- - real(kind=8) function poly(x1,x2,y1,y2,t1,t2,x) - implicit none - - real(kind=8), intent(in) :: x1,x2,y1,y2,t1,t2,x - real(kind=8) :: p0,p1,p2,p3 - - p0 = y1 - p1 = t1 - p2 = (3.d0*(y2-y1)/(x2-x1)-2.d0*t1-t2)/(x2-x1) - p3 = (t1+t2-2.d0*(y2-y1)/(x2-x1))/(x2-x1)**2 - - poly = p0 + p1 * (x-x1) + p2 * (x-x1)**2 + p3 * (x-x1)**3 - - end function poly - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!---------------------------------------------------------------------- - -end Module Fourier diff --git a/Libraries/Modules/lattices_v3.f90 b/Libraries/Modules/lattices_v3.f90 deleted file mode 100644 index 7e4ad8bd3..000000000 --- a/Libraries/Modules/lattices_v3.f90 +++ /dev/null @@ -1,748 +0,0 @@ - Module Lattices_v3 - - Use Matrix - Type Lattice - Integer :: N, Ns - Integer, pointer :: list(:,:), invlist(:,:), nnlist(:,:,:), listk(:,:), & - & invlistk(:,:), imj(:,:) - Real (Kind=8), pointer :: a1_p(:), a2_p(:), b1_p(:), b2_p(:), BZ1_p(:), BZ2_p(:), & - & L1_p(:), L2_p(:), b1_perp_p(:), b2_perp_p(:) - end Type Lattice - - Interface Iscalar - module procedure Iscalar_II, Iscalar_IR, Iscalar_RR - end Interface - Interface npbc - module procedure npbc_I, npbc_R - end Interface - Interface Xnorm - module procedure Xnorm_I, Xnorm_R - end Interface - Interface Fourier_K_to_R - module procedure FT_K_to_R, FT_K_to_R_Mat, FT_K_to_R_C, FT_K_to_R_Mat_C - end Interface - Interface Fourier_R_to_K - module procedure FT_R_to_K, FT_R_to_K_mat, FT_R_to_K_C - end Interface - - Contains - - subroutine Make_lattice(L1_p, L2_p, a1_p, a2_p, Latt) - - ! This is for a general tilted square lattice defined by the vector a1, a2 - ! L1_p, L2_p define cluster topology. ( Tilted etc.) - ! L1_p = n*a1_p + m *a2_p - - - Implicit none - - Real (Kind=8), dimension(:) :: L1_p, L2_p, a1_p, a2_p - Type (Lattice) :: Latt - - Real (Kind=8), dimension(:), allocatable :: xk_p, b1_p, b2_p, BZ1_p, BZ2_p, b_p - Real (Kind=8), dimension(:), allocatable :: x_p, x1_p, a_p,d_p - Real (Kind=8), allocatable :: Mat(:,:), Mat_inv(:,:) - - Integer :: ndim, L, L1, nc, i, i1,i2, L_f, LQ, n,m, nd1,nd2,nr, nnr1, nnr2, nnr, nr1, imj_1, imj_2 - Integer :: imj - Real (Kind=8) :: Zero,pi, X - - ndim = size(L1_p) - allocate (Latt%L2_p(ndim), Latt%L1_p(ndim), Latt%a1_p(ndim) , Latt%a2_p(ndim), & - & Latt%b1_p(ndim), Latt%b2_p(ndim), Latt%BZ1_p(ndim), Latt%BZ2_p(ndim) ) - allocate (Latt%b1_perp_p(ndim), Latt%b2_perp_p(ndim) ) - Zero = 1.E-5 - Latt%L1_p = L1_p - Latt%L2_p = L2_p - Latt%a1_p = a1_p - Latt%a2_p = a2_p - - - !Compute the Reciprocal lattice vectors. - Allocate ( b1_p(ndim), b2_p(ndim), xk_p(ndim), b_p(ndim) ) - Allocate ( BZ1_p(ndim), BZ2_p(ndim) ) - Allocate ( x_p(ndim), x1_p(ndim), d_p(ndim), a_p(ndim) ) - - - pi = acos(-1.d0) - - ! Setup the 2X2 matrix to determine BZ1_p, BZ2_p - Allocate ( Mat(2 , 2), Mat_inv( 2 , 2 ) ) - Mat(1,1) = dble(a1_p(1)) - Mat(1,2) = dble(a1_p(2)) - Mat(2,1) = dble(a2_p(1)) - Mat(2,2) = dble(a2_p(2)) - X = Mat(1,1)*Mat(2,2) - Mat(2,1)*Mat(1,2) - Mat_inv(1,1) = Mat(2,2)/X - Mat_inv(2,2) = Mat(1,1)/X - Mat_inv(1,2) = -Mat(1,2)/X - Mat_inv(2,1) = -Mat(2,1)/X - BZ1_p(1) = 2.d0*pi*Mat_inv(1,1) - BZ1_p(2) = 2.d0*pi*Mat_inv(2,1) - BZ2_p(1) = 2.d0*pi*Mat_inv(1,2) - BZ2_p(2) = 2.d0*pi*Mat_inv(2,2) - Latt%BZ1_p = BZ1_p - Latt%BZ2_p = BZ2_p - - - - - ! K-space Quantization from periodicity in L1_p and L2_p - X = 2.d0*pi / ( Iscalar(BZ1_p,L1_p) * Iscalar(BZ2_p,L2_p) - & - & Iscalar(BZ2_p,L1_p) * Iscalar(BZ1_p,L2_p) ) - X = abs(X) - b1_p = X*( Iscalar(BZ2_p,L2_p) * BZ1_p - Iscalar(BZ1_p,L2_p) * BZ2_p ) - b2_p = X*( Iscalar(BZ1_p,L1_p) * BZ2_p - Iscalar(BZ2_p,L1_p) * BZ1_p ) - Latt%b1_p = b1_p - Latt%b2_p = b2_p - - - ! Setup the 2X2 matrix to determine b1_perp_p, b2_perp_p - Mat(1,1) = dble(b1_p(1)) - Mat(1,2) = dble(b1_p(2)) - Mat(2,1) = dble(b2_p(1)) - Mat(2,2) = dble(b2_p(2)) - X = Mat(1,1)*Mat(2,2) - Mat(2,1)*Mat(1,2) - Mat_inv(1,1) = Mat(2,2)/X - Mat_inv(2,2) = Mat(1,1)/X - Mat_inv(1,2) = -Mat(1,2)/X - Mat_inv(2,1) = -Mat(2,1)/X - Latt%b1_perp_p(1) = Mat_inv(1,1) - Latt%b1_perp_p(2) = Mat_inv(2,1) - Latt%b2_perp_p(1) = Mat_inv(1,2) - Latt%b2_perp_p(2) = Mat_inv(2,2) - - Deallocate ( Mat, Mat_inv ) - - - - ! Count the number of lattice points. - L = abs(nint ( Iscalar(Latt%BZ1_p,L1_p) / (2.d0*pi) )) - L1 = abs(nint ( Iscalar(Latt%BZ2_p,L1_p) / (2.d0*pi) )) - if (L1 .gt. L) L = L1 - L1 = abs(nint ( Iscalar(Latt%BZ1_p,L2_p) / (2.d0*pi) )) - if (L1 .gt. L) L = L1 - L1 = abs(nint ( Iscalar(Latt%BZ2_p,L2_p) / (2.d0*pi) )) - if (L1 .gt. L) L = L1 - nc = 0 - do i1 = -L,L - do i2 = -L,L - x_p = dble(i1)*a1_p + dble(i2)*a2_p - L_f = 1 - do i = 1,4 - if (i.eq.1) a_p = L2_p - if (i.eq.2) a_p = L1_p - if (i.eq.3) a_p = L2_p - L1_p - if (i.eq.4) a_p = L2_p + L1_p - if ( Iscalar(x_p, a_p) .le. xnorm(a_p)**2/2.d0 + Zero .and. & - & Iscalar(x_p, a_p) .ge. -xnorm(a_p)**2/2.d0 + Zero ) then - L_f = L_f * 1 - else - L_f = 0 - endif - enddo - if (L_f .eq. 1) then - nc = nc + 1 - endif - enddo - enddo - LQ = nc - Latt%Ns = LQ - Latt%N = LQ - Write(6,*) L, LQ - - - Allocate ( Latt%List(LQ,ndim), Latt%Invlist(-L:L, -L:L ) ) - !Setting up real space lattice - nc = 0 - do i1 = -L,L - do i2 = -L,L - x_p = dble(i1)*a1_p + dble(i2)*a2_p - L_f = 1 - do i = 1,4 - if (i.eq.1) a_p = L2_p - if (i.eq.2) a_p = L1_p - if (i.eq.3) a_p = L2_p - L1_p - if (i.eq.4) a_p = L2_p + L1_p - if ( Iscalar( x_p, a_p ) .le. xnorm(a_p)**2/2.d0 + Zero .and. & - & Iscalar( x_p, a_p ) .ge. -xnorm(a_p)**2/2.d0 + Zero ) then - L_f = L_f * 1 - else - L_f = 0 - endif - enddo - if (L_f .eq. 1) then - nc = nc + 1 - Latt%list(nc,1) = i1 - Latt%list(nc,2) = i2 - Latt%invlist(i1, i2 ) = nc - endif - enddo - enddo - - - Allocate ( Latt%Listk(LQ,ndim), Latt%Invlistk(-L:L, -L:L) ) - nc = 0 - do m = -L,L - do n = -L,L - xk_p = dble(m) * b1_p + dble(n) * b2_p - L_f = 1 - do i = 1,4 - if (i.eq.1) b_p = BZ2_p - if (i.eq.2) b_p = BZ1_p - if (i.eq.3) b_p = BZ2_p - BZ1_p - if (i.eq.4) b_p = BZ2_p + BZ1_p - if ( Iscalar( xk_p, b_p ) .le. xnorm(b_p)**2/2.d0 + Zero .and. & - & Iscalar( xk_p, b_p ) .ge. -xnorm(b_p)**2/2.d0 + Zero ) then - L_f = L_f * 1 - else - L_f = 0 - endif - enddo - if (L_f .eq. 1) then - !write(11,"(F14.7,2x,F14.7)") xk_p(1), xk_p(2) - nc = nc + 1 - Latt%listk(nc,1) = m - Latt%listk(nc,2) = n - Latt%invlistk(m,n) = nc - endif - enddo - enddo - If (nc.ne.Latt%N) Then - write(6,*) 'Error ', nc, Latt%N - stop - endif - - !Setup nnlist - Allocate ( Latt%nnlist(LQ,-1:1,-1:1) ) - - do nr = 1, Latt%N - do nd1 = -1,1 - do nd2 = -1,1 - d_p = dble(nd1)*a1_p + dble(nd2)*a2_p - x_p = dble(Latt%list(nr,1))*Latt%a1_p + dble(Latt%list(nr,2))*Latt%a2_p + d_p - call npbc(x1_p, x_p , Latt%L1_p, Latt%L2_p) - call npbc(x_p , x1_p, Latt%L1_p, Latt%L2_p) - call npbc(x1_p, x_p , Latt%L1_p, Latt%L2_p) - call npbc(x_p , x1_p, Latt%L1_p, Latt%L2_p) - nnr1 = nint ( Iscalar(Latt%BZ1_p,x_p) / (2.d0*pi) ) - nnr2 = nint ( Iscalar(Latt%BZ2_p,x_p) / (2.d0*pi) ) - nnr = Latt%invlist(nnr1,nnr2) - Latt%nnlist(nr,nd1,nd2) = nnr - if ( nnr < 1 .or. nnr > Latt%N ) then - write(6,*) "Error in nnlist ", nnr - x1_p = dble(Latt%list(nr,1))*Latt%a1_p + dble(Latt%list(nr,2))*Latt%a2_p - !Write(91,"(F14.7,2x,F14.7,2x,F14.7,2x,F14.7)") x1_p(1), x1_p(2), d_p(1), d_p(2) - Write(91,"(F14.7,2x,F14.7)") x1_p(1) , x1_p(2) - Write(91,*) - endif - enddo - enddo - enddo - - !Setup imj - If (LQ .lt. 1000 ) then - Allocate ( Latt%imj(LQ,LQ) ) - do nr = 1, Latt%N - x_p = dble(Latt%list(nr,1))*Latt%a1_p + dble(Latt%list(nr,2))*a2_p - do nr1 = 1,Latt%N - x1_p = dble(Latt%list(nr1,1))*Latt%a1_p + dble(Latt%list(nr1,2))*a2_p - d_p = x_p - x1_p - call npbc(x1_p , d_p , Latt%L1_p, Latt%L2_p) - call npbc(d_p , x1_p, Latt%L1_p, Latt%L2_p) - imj_1 = nint ( Iscalar(Latt%BZ1_p,d_p) / (2.d0*pi) ) - imj_2 = nint ( Iscalar(Latt%BZ2_p,d_p) / (2.d0*pi) ) - imj = Latt%invlist(imj_1,imj_2) - Latt%imj(nr,nr1) = imj - enddo - enddo - endif - - deallocate ( b1_p, b2_p, xk_p, b_p ) - deallocate ( BZ1_p, BZ2_p ) - deallocate ( x_p, x1_p, d_p, a_p ) - - - - end subroutine MAKE_LATTICE - -!******** - subroutine npbc_I(nr_p, n_p, L1_p, L2_p) - - Implicit none - - integer, dimension(:) :: nr_p, n_p, L1_p, L2_p - - integer, dimension(:), allocatable :: x_p - Real (Kind=8) :: Zero, X - Integer :: Ndim, i - - Zero = 1.E-5 - nr_p = n_p - ndim = size(nr_p) - - allocate (x_p(ndim)) - - do i = 1,4 - if (i.eq.1) x_p = L2_p - if (i.eq.2) x_p = L1_p - if (i.eq.3) x_p = L2_p - L1_p - if (i.eq.4) x_p = L2_p + L1_p - - X = dble(Iscalar(nr_p,x_p))/(Xnorm(x_p)**2) - if (X .ge. 0.5+Zero ) nr_p = nr_p - x_p - if (X .le. -0.5+Zero ) nr_p = nr_p + x_p - enddo - - deallocate(x_p) - - end subroutine npbc_I - - - subroutine npbc_R(nr_p, n_p, L1_p, L2_p) - - Implicit none - Real (Kind=8), dimension(:) :: nr_p, n_p, L1_p, L2_p - - Real (Kind=8), dimension(:), allocatable :: x_p - - Real (Kind=8) :: Zero, X - Integer :: ndim, i - ndim = size(nr_p) - - allocate (x_p(ndim)) - Zero = 1.E-5 - nr_p = n_p - do i = 1,4 - if (i.eq.1) x_p = L2_p - if (i.eq.2) x_p = L1_p - if (i.eq.3) x_p = L2_p - L1_p - if (i.eq.4) x_p = L2_p + L1_p - X = Iscalar(nr_p,x_p)/(Xnorm(x_p)**2) - if (X .ge. 0.5+Zero ) nr_p = nr_p - x_p - if (X .le. -0.5+Zero ) nr_p = nr_p + x_p - enddo - - deallocate(x_p) - - end subroutine npbc_R - -!******** - integer Function Inv_K(XK_P,Latt) - - Implicit None - Real (Kind=8) :: XK_P(2) - Type (Lattice) :: Latt - - Integer :: nkx, nky, nk - Real (Kind=8) :: XK1_P(2), XK2_P(2), X, Zero - - call npbc(xk1_p, xk_p , Latt%BZ1_p, Latt%BZ2_p) - call npbc(xk2_p, xk1_p, Latt%BZ1_p, Latt%BZ2_p) - - nkx = nint (Iscalar(XK2_P,Latt%b1_perp_p) ) - nky = nint (Iscalar(XK2_P,Latt%b2_perp_p) ) - nk = Latt%Invlistk(nkx,nky) - - !Test - Zero = 1.D-10 - XK1_P = Latt%listk(nk,1)*latt%b1_p + Latt%listk(nk,2)*latt%b2_p - if (Xnorm(XK1_P - XK2_P) < Zero ) then - Inv_K = nk - else - write(6,*) 'Error in Inv_K Lattice_new' - stop - endif - -!!$ nk = 1 -!!$ do -!!$ XK1_P = Latt%listk(nk,1)*latt%b1_p + Latt%listk(nk,2)*latt%b2_p -!!$ if (Xnorm(XK1_P - XK_P) < Zero ) then -!!$ Inv_K = nk -!!$ exit -!!$ elseif (nk < Latt%N) then -!!$ nk = nk + 1 -!!$ else -!!$ write(6,*) 'Error in Inv_K Lattice_new' -!!$ stop -!!$ endif -!!$ enddo - - end Function Inv_K - - - -!******** - integer Function Inv_R(XR_P,Latt) - - Implicit None - Real (Kind=8) :: XR_P(2) - Type (Lattice) :: Latt - - Real (Kind=8) :: XR1_P(2), XR2_P(2) - - Integer :: n_1, n_2 - Real (Kind=8) :: pi - - pi = acos(-1.d0) - call npbc(xr1_p, xr_p , Latt%L1_p, Latt%L2_p) - call npbc(xr2_p, xr1_p, Latt%L1_p, Latt%L2_p) - - n_1 = nint ( Iscalar(Latt%BZ1_p,XR2_p) / (2.d0*pi) ) - n_2 = nint ( Iscalar(Latt%BZ2_p,XR2_p) / (2.d0*pi) ) - Inv_R = Latt%invlist(n_1,n_2) - - end Function Inv_R -!******** - - integer function Iscalar_II(i_p, j_p) - Implicit none - integer, dimension(:) :: i_p, j_p - integer i - - Iscalar_II = 0 - !write(6,*) size(i_p) - do i = 1, size(i_p) - ! write(6,*) i - Iscalar_II = Iscalar_II + i_p(i)*j_p(i) - enddo - end function Iscalar_II - -!******** - Real (Kind=8) function Iscalar_IR(x_p, j_p) - Implicit none - Real (Kind=8), dimension(:) :: x_p - integer, dimension(:) :: j_p - integer i - - Iscalar_IR = 0.d0 - !write(6,*) size(i_p) - do i = 1, size(x_p) - ! write(6,*) i - Iscalar_IR = Iscalar_IR + x_p(i)*dble(j_p(i)) - enddo - end function Iscalar_IR -!******** - - Real (Kind=8) function Iscalar_RR(x_p, y_p) - Implicit none - Real (Kind=8), dimension(:) :: x_p, y_p - integer i - - Iscalar_RR = 0.d0 - do i = 1, size(x_p) - Iscalar_RR = Iscalar_RR + x_p(i)*y_p(i) - enddo - end function Iscalar_RR - -!******** - Real (Kind=8) function Xnorm_I(i_p) - Implicit none - integer, dimension(:) :: i_p - integer :: i - - Xnorm_I = 0.d0 - do i = 1, size(i_p) - Xnorm_I = Xnorm_I + dble(i_p(i)*i_p(i)) - enddo - Xnorm_I = sqrt(Xnorm_I) - end function Xnorm_I - -!******** - Real (Kind=8) function Xnorm_R(x_p) - Implicit none - Real (Kind=8), dimension(:) :: x_p - integer :: i - - Xnorm_R = 0.d0 - do i = 1, size(x_p) - Xnorm_R = Xnorm_R + x_p(i)*x_p(i) - enddo - Xnorm_R = sqrt(Xnorm_R) - end function Xnorm_R - -!******** - subroutine Print_latt(Latt) - - Implicit Real (Kind=8) (A-G,O-Z) - Implicit Integer (H-N) - - Type (Lattice) :: Latt - Real (Kind=8) :: i_p(2),nd_p(2) - Real (Kind=8) :: x_p(2) - - Open (Unit=55,file="Latt_info", status = "unknown") - write(55,*) ' Reciprocal vector 1: ', Latt%BZ1_p(1), Latt%BZ1_p(2) - write(55,*) ' Reciprocal vector 2: ', Latt%BZ2_p(1), Latt%BZ2_p(2) - write(55,*) ' Latt vector 1: ', Latt%a1_p(1), Latt%a1_p(2) - write(55,*) ' Latt vector 2: ', Latt%a2_p(1), Latt%a2_p(2) - close(55) - Open (Unit=56,file="Real_space_latt", status = "unknown") - Open (Unit=57,file="K_space_latt", status = "unknown") - Open (Unit=58,file="nn_latt", status = "unknown") - do n = 1, Latt%n - i_p = dble(Latt%list(n,1))*Latt%a1_p + dble(Latt%list(n,2))*Latt%a2_p - write(56,"(F14.7,2x,F14.7)") i_p(1), i_p(2) - x_p = dble(Latt%listk(n,1))*Latt%b1_p + dble(Latt%listk(n,2))*Latt%b2_p - write(57,"(F14.7,2x,F14.7)") x_p(1), x_p(2) - write(58,*) - write(58,"('I :',F14.7,2x,F14.7)") i_p(1), i_p(2) - do nd1 = -1,1 - do nd2 = -1,1 - nd_p = dble(nd1)*Latt%a1_p + dble(nd2)*Latt%a2_p - nnr = Latt%nnlist(n,nd1,nd2) - !Write(6,*) 'nnr : ', nnr - i_p = dble(Latt%list(nnr,1))*Latt%a1_p + dble(Latt%list(nnr,2))*Latt%a2_p - write(58,"('I+(',F12.6,',',F12.6,')=',2x,F14.7,2x,F14.7)") nd_p(1),nd_p(2),i_p(1), i_p(2) - enddo - enddo - enddo - close(56) - close(57) - close(58) - end subroutine Print_latt - -!******* - subroutine FT_K_to_R_Mat( Xin_K, Xout_R, Latt) - - Implicit none - - Type (Lattice) :: Latt - Type (Mat_R ), Dimension(:,:) :: Xin_K, Xout_R - Real (Kind=8), Dimension(:,:), allocatable :: X_MAT - Real (Kind=8) :: XK_p(2), IR_p(2) - - Integer :: nb, norb, LQ, nt, nr, nk - nb = size(Xin_K,2 ) - norb = size(Xin_K(1,1)%el,1) - LQ = Latt%N - - !Write(6,*) 'Ltrot, norb ', Ltrot, norb - !Write(6,*) Xin_K(1,1)%el(1,1) - !Write(6,*) Xin_K(Latt%N,Ltrot)%el(1,1) - - allocate ( X_MAT(norb,norb) ) - - - do nt = 1,nb - do nr = 1,LQ - IR_p = dble(Latt%list(nr,1))*Latt%a1_p + dble(Latt%list(nr,2))*Latt%a2_p - X_MAT = 0.d0 - do nk = 1,LQ - XK_p = dble(Latt%listk(nk,1))*Latt%b1_p + dble(Latt%listk(nk,2))*Latt%b2_p - X_MAT = X_MAT + cos(Iscalar(XK_p,IR_p))*Xin_K(nk,nt)%el - enddo - Xout_R(nr,nt)%el = X_MAT/dble(LQ) - enddo - enddo - - deallocate(X_Mat) - end subroutine FT_K_to_R_Mat - -!******** - subroutine FT_K_to_R_Mat_C( Xin_K, Xout_R, Latt) - - Implicit none - - Type (Lattice) :: Latt - Type (Mat_C ) , Dimension(:,:) :: Xin_K, Xout_R - Complex (Kind=8), Dimension(:,:), allocatable :: X_MAT - Real (Kind=8) :: XK_p(2), IR_p(2) - - Integer :: nb, norb, LQ, nt, nr, nk - - nb = size(Xin_K,2 ) - norb = size(Xin_K(1,1)%el,1) - LQ = Latt%N - - !Write(6,*) 'Ltrot, norb ', Ltrot, norb - !Write(6,*) Xin_K(1,1)%el(1,1) - !Write(6,*) Xin_K(Latt%N,nb)%el(1,1) - - allocate ( X_MAT(norb,norb) ) - - - do nt = 1,nb - do nr = 1,LQ - IR_p = dble(Latt%list(nr,1))*Latt%a1_p + dble(Latt%list(nr,2))*Latt%a2_p - X_MAT = cmplx(0.d0,0.d0) - do nk = 1,LQ - XK_p = dble(Latt%listk(nk,1))*Latt%b1_p + dble(Latt%listk(nk,2))*Latt%b2_p - X_MAT = X_MAT + exp( cmplx(0.d0,(Iscalar(XK_p,IR_p))) ) *Xin_K(nk,nt)%el - enddo - Xout_R(nr,nt)%el = X_MAT/cmplx(dble(LQ),0.d0) - enddo - enddo - - deallocate(X_Mat) - - end subroutine FT_K_to_R_Mat_C - -!******** - - subroutine FT_K_to_R( Xin_K, Xout_R, Latt) - - Implicit none - - Type (Lattice) :: Latt - Real (Kind=8), Dimension(:,:) :: Xin_K, Xout_R - Real (Kind=8) :: XK_p(2), IR_p(2), X_Mat - Integer :: LQ, nb, nt, nr, nk - - nb = size(Xin_K,2 ) - LQ = Latt%N - - !Write(6,*) 'Ltrot, norb ', Ltrot, norb - !Write(6,*) Xin_K(1,1)%el(1,1) - !Write(6,*) Xin_K(Latt%N,Ltrot)%el(1,1) - - - do nt = 1,nb - do nr = 1,LQ - IR_p = dble(Latt%list(nr,1))*Latt%a1_p + dble(Latt%list(nr,2))*Latt%a2_p - X_MAT = 0.d0 - do nk = 1,LQ - XK_p = dble(Latt%listk(nk,1))*Latt%b1_p + dble(Latt%listk(nk,2))*Latt%b2_p - X_MAT = X_MAT + cos(Iscalar(XK_p,IR_p))*Xin_K(nk,nt) - enddo - Xout_R(nr,nt) = X_MAT/dble(LQ) - enddo - enddo - - end subroutine FT_K_to_R - - - subroutine FT_K_to_R_C( Xin_K, Xout_R, Latt) - - Implicit none - - Type (Lattice) :: Latt - Complex (Kind=8), Dimension(:,:) :: Xin_K, Xout_R - Complex (Kind=8) :: Z - Real (Kind=8) :: XK_p(2), IR_p(2) - - Integer :: nb, LQ, nt, nr, nk - - nb = size(Xin_K,2 ) - LQ = Latt%N - - !Write(6,*) 'Ltrot, norb ', Ltrot, norb - !Write(6,*) Xin_K(1,1)%el(1,1) - !Write(6,*) Xin_K(Latt%N,Ltrot)%el(1,1) - - - do nt = 1,nb - do nr = 1,LQ - IR_p = dble(Latt%list(nr,1))*Latt%a1_p + dble(Latt%list(nr,2))*Latt%a2_p - Z = cmplx(0.d0,0.d0) - do nk = 1,LQ - XK_p = dble(Latt%listk(nk,1))*Latt%b1_p + dble(Latt%listk(nk,2))*Latt%b2_p - Z = Z + cmplx(cos(Iscalar(XK_p,IR_p)),0.d0)*Xin_K(nk,nt) - enddo - Xout_R(nr,nt) = Z/cmplx(dble(LQ),0.d0) - enddo - enddo - - end subroutine FT_K_to_R_C - - - subroutine FT_R_to_K_mat( Xin_R, Xout_K, Latt) - - Implicit none - - Type (Lattice) :: Latt - Type (Mat_R ), Dimension(:,:) :: Xin_R, Xout_K - Real (Kind=8), Dimension(:,:), allocatable :: X_MAT - Real (Kind=8) :: XK_p(2), IR_p(2) - - Integer :: nb, norb, nk, nt, LQ, nr - - nb = size(Xin_R,2 ) - norb = size(Xin_R(1,1)%el,1) - LQ = Latt%N - - !Write(6,*) 'Ltrot, norb ', Ltrot, norb - !Write(6,*) Xin_R(1,1)%el(1,1) - !Write(6,*) Xin_R(Latt%N,Ltrot)%el(1,1) - - allocate ( X_MAT(norb,norb) ) - - - do nt = 1,nb - do nk = 1,LQ - XK_p = dble(Latt%listk(nk,1))*Latt%b1_p + dble(Latt%listk(nk,2))*Latt%b2_p - X_MAT = 0.d0 - do nr = 1,LQ - IR_p = dble(Latt%list(nr,1))*Latt%a1_p + dble(Latt%list(nr,2))*Latt%a2_p - X_MAT = X_MAT + cos(Iscalar(XK_p,IR_p))*Xin_R(nr,nt)%el - enddo - Xout_K(nk,nt)%el = X_MAT/dble(LQ) - enddo - enddo - - deallocate(X_Mat) - end subroutine FT_R_to_K_mat - - subroutine FT_R_to_K( Xin_R, Xout_K, Latt) - - Implicit none - - Type (Lattice) :: Latt - Real (Kind=8), Dimension(:) :: Xin_R, Xout_K - - Real (Kind=8) :: XK_p(2), IR_p(2), X_mat - - Integer :: nb, norb, nk, nt, LQ, nr - - LQ = Latt%N - - !Write(6,*) 'Ltrot, norb ', Ltrot, norb - !Write(6,*) Xin_R(1,1)%el(1,1) - !Write(6,*) Xin_R(Latt%N,Ltrot)%el(1,1) - - do nk = 1,LQ - XK_p = dble(Latt%listk(nk,1))*Latt%b1_p + dble(Latt%listk(nk,2))*Latt%b2_p - X_MAT = 0.d0 - do nr = 1,LQ - IR_p = dble(Latt%list(nr,1))*Latt%a1_p + dble(Latt%list(nr,2))*Latt%a2_p - X_MAT = X_MAT + cos(Iscalar(XK_p,IR_p))*Xin_R(nr) - enddo - Xout_K(nk) = X_MAT/dble(LQ) - enddo - - end subroutine FT_R_to_K - -!******** - subroutine FT_R_to_K_C( Xin_R, Xout_K, Latt) - - Implicit none - - Type (Lattice) :: Latt - Complex (Kind=8), Dimension(:) :: Xin_R, Xout_K - Complex (Kind=8) :: X_MAT - Real (Kind=8) :: XK_p(2), IR_p(2) - - Integer :: nb, norb, LQ, nt, nr, nk - - LQ = Latt%N - - !Write(6,*) 'Ltrot, norb ', Ltrot, norb - !Write(6,*) Xin_K(1,1)%el(1,1) - !Write(6,*) Xin_K(Latt%N,nb)%el(1,1) - - do nk = 1,LQ - XK_p = dble(Latt%listk(nk,1))*Latt%b1_p + dble(Latt%listk(nk,2))*Latt%b2_p - X_MAT = cmplx(0.d0,0.d0) - do nr = 1,LQ - IR_p = dble(Latt%list(nr,1))*Latt%a1_p + dble(Latt%list(nr,2))*Latt%a2_p - X_MAT = X_MAT + exp( cmplx(0.d0,-(Iscalar(XK_p,IR_p))) ) *Xin_R(nr) - enddo - Xout_K(nk) = X_MAT/cmplx(dble(LQ),0.d0) - enddo - - end subroutine FT_R_to_K_C - - - end Module Lattices_v3 - - diff --git a/Libraries/Modules/log_mesh.f90 b/Libraries/Modules/log_mesh.f90 deleted file mode 100644 index 4bd964719..000000000 --- a/Libraries/Modules/log_mesh.f90 +++ /dev/null @@ -1,318 +0,0 @@ - Module Log_Mesh - - Type logmesh - Real (Kind=8) :: Lambda, Center, Log_Lambda - Real (Kind=8) :: Range - Real (Kind=8) :: Om_st, Om_en, dom - Real (Kind=8) :: Precision - Integer :: Nom,Nw - Real (Kind=8), pointer :: Xom(:),DXom(:) - Character(len=10) :: Type - end Type logmesh - - Interface Lookup_log_mesh - module procedure Lookup_log_mesh_R, Lookup_log_mesh_C - end Interface - Interface Inter_log_mesh - module procedure Inter_log_mesh_R, Inter_log_mesh_C - end Interface - - Contains - - - subroutine Make_log_mesh ( Mesh, Lambda, Center, Range, Type, Nw_1 ) - - Implicit None - - Type (logmesh) :: Mesh - Real (Kind=8) :: Lambda, Center, Range - Integer, Optional :: Nw_1 - Real (Kind=8) :: DeltaX, XS - Integer :: N, nc, Nw - Character(len=10) :: Type - - Real (Kind=8) :: Dom, Om_st, Om_en - - Mesh%Center = Center - Mesh%Range = Range - If (Type == "Log" ) Then - OM_st = Center - Range - OM_en = Center + Range - Mesh%Om_st = Om_st - Mesh%Om_en = Om_en - Mesh%Lambda = Lambda - Mesh%Type = "Log" - if (Present(Nw_1) ) then - Nw = Nw_1 - else - Nw = 10.d0*log(10.d0)/log(Lambda) - endif - Mesh%Nw = Nw - Mesh%Nom = 2*Nw + 3 - Mesh%Log_Lambda = Log(Lambda) - Allocate ( Mesh%Xom(2*Nw + 3), Mesh%DXom(2*Nw+3) ) - Do n = 0,Nw - Mesh%xom (n+1 ) = Center - Range * (Lambda**(-n)) - enddo - Mesh%xom (Nw+2 ) = Center - do n = Nw,0,-1 - Mesh%xom(Nw+3 +(Nw-n) ) = Center + Range * (Lambda**(-n)) - enddo - Mesh%Precision = Mesh%Lambda**(-Mesh%Nw) - elseif (Type == "Lin" ) then - Mesh%Type = "Lin" - If ( Present(Nw_1) ) then - Nw = Nw_1 - Mesh%Nw = Nw - Mesh%Nom = 2*Nw + 1 - Mesh%Type = "Lin" - Allocate ( Mesh%Xom(2*Nw + 1), Mesh%DXom(2*Nw+1) ) - OM_st = Center - Range - OM_en = Center + Range - Dom = Range/dble(Nw_1) - Mesh%Dom = Dom - Mesh%Om_st = Om_st - Mesh%Om_en = Om_en - do n = 1,Mesh%Nom - Mesh%xom(n) = Om_st + dble(n-1)*dom - enddo - else - Write(6,*) ' You need to include Nw for the Lin Mesh ' - stop - endif - else - Write(6,*) 'Mesh has no type!! ' - stop - endif - do n = 1,Mesh%Nom-1 - Mesh%DXom(n) = Mesh%xom (n+1) - Mesh%xom (n ) - enddo - - end subroutine Make_log_mesh - - subroutine Clear_log_mesh ( Mesh ) - Implicit None - - Type (logmesh) :: Mesh - - deallocate ( Mesh%Xom, Mesh%DXom ) - - end subroutine Clear_log_mesh - - Integer Function m_find(X,Mesh) - - Implicit None - - Type (logmesh) :: Mesh - Real (Kind=8) :: X - Integer :: m - - if ( Mesh%Type == "Log" ) then - if ( X > (Mesh%OM_en) .or. X < (Mesh%Om_st) ) then - m = 0 - else - if ( X < Mesh%Xom(Mesh%Nw+1) ) then - m = 2 - Int( log ( (Mesh%Center - X)/Mesh%Range ) / Mesh%Log_Lambda ) - !Write(6,*) 'Hi 1', X - elseif ( X > Mesh%Xom(Mesh%Nw+3) ) then - m = 2*Mesh%Nw + 3 + Int( log ( (X- Mesh%Center) /Mesh%Range ) / Mesh%Log_Lambda ) - !Write(6,*) 'Hi 2', X, Mesh%Center + Mesh%Range - elseif ( X > Mesh%Center ) then - m = Mesh%Nw+3 - else - m = Mesh%Nw+2 - endif - endif - m_find = m - else - m_find = int((x - Mesh%Om_st)/Mesh%dom) + 2 - if (m_find > Mesh%Nom) m_find=Mesh%Nom - if (m_find < 2 ) m_find=2 - endif - - - !Write(6,*) - !Write(6,*) 'Point: ', X - !if ( m > 0 ) then - ! Write(6,*) 'Your point lies inbetween ', Mesh%Xom(m-1), ' and ', Mesh%Xom(m) - !else - ! Write(6,*) 'Out of range ' - !endif - - end Function m_find -!******* - Real(Kind=8) Function Lookup_log_mesh_R(f, x,Mesh,m_1) - - Implicit None - - Type (logmesh) :: Mesh - Real (Kind=8), dimension(:) :: f - Real (Kind=8) :: X - Integer , Optional :: m_1 - - Integer :: n, m - Real (Kind=8) :: X1,X2,Y1,Y2,a,b - - m = m_find(X,Mesh) - if (m == 0 ) then - Lookup_log_mesh_R = 0.d0 - else - x1 = Mesh%xom(m-1) - x2 = Mesh%xom(m ) - y1 = f(m-1) - y2 = f(m) - a = (y1-y2)/(x1-x2) - b = (x1*y2 - x2*y1)/(x1-x2) - Lookup_log_mesh_R = a*x + b - endif - - If ( Present(m_1) ) m_1 = m - - end Function Lookup_log_mesh_R - - - -!******* -!!$ Complex (Kind=8) Function Lookup_log_mesh_C(f, x,Mesh,m_1) -!!$ -!!$ Implicit None -!!$ -!!$ Type (logmesh) :: Mesh -!!$ Complex (Kind=8), dimension(:) :: f -!!$ Real (Kind=8) :: X -!!$ Integer , Optional :: m_1 -!!$ -!!$ -!!$ Integer :: n, m -!!$ Complex (Kind=8) :: X1,X2,Y1,Y2,a,b -!!$ -!!$ m = m_find(X,Mesh) -!!$ if (m == 0 ) then -!!$ Lookup_log_mesh_C = cmplx(0.d0,0.d0) -!!$ else -!!$ x1 = cmplx( Mesh%xom(m-1),0.d0 ) -!!$ x2 = cmplx( Mesh%xom(m ),0.d0 ) -!!$ y1 = f(m-1) -!!$ y2 = f(m ) -!!$ a = (y1-y2)/(x1-x2) -!!$ b = (x1*y2 - x2*y1)/(x1-x2) -!!$ Lookup_log_mesh_C = a*cmplx( x , 0.d0 ) + b -!!$ endif -!!$ -!!$ If ( Present(m_1) ) m_1 = m -!!$ -!!$ end Function Lookup_log_mesh_C - - Complex (Kind=8) Function Lookup_log_mesh_C(f, x,Mesh,m_1) - - Implicit None - - Type (logmesh) :: Mesh - Complex (Kind=8), dimension(:) :: f - Real (Kind=8) :: X - Integer , Optional :: m_1 - - - Integer :: n, m - Complex (Kind=8) :: Z1,Z2, Z - Real (Kind=8) :: x1,x2,t - - m = m_find(X,Mesh) - if (m == 0 ) then - Lookup_log_mesh_C = cmplx(0.d0,0.d0) - else - x1 = Mesh%xom(m-1) - x2 = Mesh%xom(m ) - t = (x1 - X)/(x2-x1) - Z1 = f(m-1) - Z2 = f(m ) - Z = Z1 + (Z1-Z2)*cmplx(t,0.d0) - Lookup_log_mesh_C = Z - endif - - If ( Present(m_1) ) m_1 = m - - end Function Lookup_log_mesh_C - - -!****** - Real (Kind=8) Function Inter_log_mesh_R(f,Mesh) - - Implicit None - - Type (logmesh) :: Mesh - Real (Kind=8), dimension(:) :: f - Real (Kind=8) :: X - Integer :: n - - X = 0.d0 - do n = 1,Mesh%Nom-1 - X = X + Mesh%DXom(n) * (f(n+1) + f(n) ) - enddo - Inter_log_mesh_R = X / 2.d0 - - end Function Inter_log_mesh_R - -!****** - Complex (Kind=8) Function Inter_log_mesh_C(f,Mesh) - - Implicit None - - Type (logmesh) :: Mesh - Complex (Kind=8), dimension(:) :: f - Complex (Kind=8) :: Z - Integer :: n - - Z = cmplx(0.d0,0.d0) - do n = 1,Mesh%Nom-1 - Z = Z + cmplx(Mesh%DXom(n),0.d0) * ( f(n+1) + f(n) ) - enddo - Inter_log_mesh_C = Z / cmplx(2.d0,0.d0) - - end Function Inter_log_mesh_C - - - - subroutine Print_log_mesh(Mesh) - - Implicit None - - Type (logmesh) :: Mesh - - Integer :: n - - If (Mesh%Type == "Log" ) Then - Open (Unit=10,File="Log_Mesh", status="unknown" ) - Write(10,*) '# Log Mesh : ' - Write(10,*) '# Lambda : ', Mesh%Lambda - Write(10,*) '# Range : ', Mesh%Range - Write(10,*) '# Center : ', Mesh%Center - Write(10,*) '# Nom : ', Mesh%Nom - Write(10,*) '# Precision : ', Mesh%Lambda**(-Mesh%Nw) - do n = 1,Mesh%Nom - write(10,"(F16.8)") Mesh%xom(n) - enddo - close(10) - endif - - If (Mesh%Type == "Lin" ) Then - Open (Unit=10,File="Lin_Mesh", status="unknown" ) - Write(10,*) '# Lin Mesh : ' - Write(10,*) '# Range : ', Mesh%Range - Write(10,*) '# Center : ', Mesh%Center - Write(10,*) '# Nom : ', Mesh%Nom - Write(10,*) '# Dom : ', Mesh%dom - do n = 1,Mesh%Nom - write(10,"(F16.8)") Mesh%xom(n) - enddo - close(10) - endif - - - - end subroutine Print_log_mesh - - - end Module Log_Mesh - - diff --git a/Libraries/Modules/machine b/Libraries/Modules/machine deleted file mode 100644 index 0caa441b4..000000000 --- a/Libraries/Modules/machine +++ /dev/null @@ -1 +0,0 @@ -#define DEC diff --git a/Libraries/Modules/mat_mod.f90 b/Libraries/Modules/mat_mod.f90 deleted file mode 100644 index c9a6fbde5..000000000 --- a/Libraries/Modules/mat_mod.f90 +++ /dev/null @@ -1,1265 +0,0 @@ - - MODULE MyMats - - INTERFACE MMULT - !C = A*B MMULT(C, A, B) - MODULE PROCEDURE MMULT_R, MMULT_C - END INTERFACE - INTERFACE INITD - MODULE PROCEDURE INITD_R, INITD_C - END INTERFACE - INTERFACE COMPARE - MODULE PROCEDURE COMPARE_R, COMPARE_C - END INTERFACE - INTERFACE DET - MODULE PROCEDURE DET_C - END INTERFACE DET - INTERFACE INV - MODULE PROCEDURE INV_R0, INV_R_Variable, INV_R_VARIABLE_1, INV_R1, INV_R2, INV_C, INV_C1, & - & INV_C_Variable - END INTERFACE - INTERFACE UDV - MODULE PROCEDURE UDV1_R, UDV_C - END INTERFACE - INTERFACE QR - MODULE PROCEDURE QR_C - END INTERFACE QR - INTERFACE SVD - MODULE PROCEDURE SVD_C - END INTERFACE SVD - INTERFACE DIAG - MODULE PROCEDURE DIAG_R, DIAG_I - END INTERFACE - INTERFACE DIAG_GEN - MODULE PROCEDURE DIAG_GEN - END INTERFACE DIAG_GEN - INTERFACE SECONDS - MODULE PROCEDURE SECONDS - END INTERFACE - CONTAINS - -!************* - SUBROUTINE DIAG_GEN(Z_MAT,U,W,LR,ICON) - IMPLICIT NONE - COMPLEX (KIND=8), INTENT(IN), DIMENSION(:,:) :: Z_MAT - CHARACTER (LEN=1), INTENT(IN) :: LR - COMPLEX (KIND=8), INTENT(INOUT), DIMENSION(:,:) :: U - COMPLEX (KIND=8), INTENT(INOUT), DIMENSION(:) :: W - INTEGER :: ICON - - !!!! Uses Lapack !!! - ! LR = L then U*A = W*U Left eigenvectors - ! LR = R then A*U = W*U Right eigenvectors - - - ! Local space - INTEGER :: N, LDA, LDVL, LDVR, INFO, LWORK, I, J, M - CHARACTER (LEN=1) :: JOBVL, JOBVR - COMPLEX (KIND=8), ALLOCATABLE, DIMENSION(:,:) :: A, VL, VR - REAL (KIND=8) , ALLOCATABLE, DIMENSION(:) :: RWORK - COMPLEX (KIND=8), ALLOCATABLE, DIMENSION(:) :: WORK - - REAL (KIND=8) :: XMAX, X - COMPLEX (KIND=8) :: Z - - N = SIZE(Z_MAT,1) - ALLOCATE(A(N,N)) - A = Z_MAT - LDA = N - - JOBVR = "N" - JOBVL = "N" - LDVL = 1 - LDVR = 1 - IF (LR =="L") THEN - JOBVL ="V" - LDVL = N - ELSEIF (LR =="R") THEN - JOBVR ="V" - LDVR = N - ELSE - WRITE(6,*) 'Error in DIAG_GEN' - STOP - ENDIF - ALLOCATE(VL(LDVL,N), VR(LDVR,N) ) - LWORK = 2*N - ALLOCATE (WORK(LWORK), RWORK(LWORK) ) - - CALL ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, & - & WORK, LWORK, RWORK, INFO ) - - IF (LR=="R") THEN - DO I = 1,N - DO J = 1,N - U(I,J) = VR(I,J) - ENDDO - ENDDO - ELSE - DO I = 1,N - DO J = 1,N - U(I,J) = CONJG(VL(J,I)) - ENDDO - ENDDO - ENDIF - - IF (ICON == 1 ) THEN - !Test - XMAX = 0.d0 - DO I = 1,N - DO J = 1,N - IF (LR=="R") THEN - Z = cmplx(0.d0,0.d0,kind=8) - DO M = 1,N - Z = Z + Z_MAT(I,M)*U(M,J) - ENDDO - Z = Z - W(I)*U(I,J) - X = SQRT( DBLE( Z*CONJG(Z) ) ) - ENDIF - IF (LR=="L") THEN - Z = cmplx(0.d0,0.d0,kind=8) - DO M = 1,N - Z = Z + U(I,M)*Z_MAT(M,J) - ENDDO - Z = Z - W(I)*U(I,J) - X = SQRT( DBLE( Z*CONJG(Z) ) ) - ENDIF - IF ( X > XMAX ) XMAX = X - ENDDO - ENDDO - WRITE(6,*) 'Testing Diag_GEN :', XMAX - !End Test - ENDIF - - DEALLOCATE(VL, VR) - DEALLOCATE(WORK, RWORK) - DEALLOCATE(A) - - - END SUBROUTINE DIAG_GEN -!************* - SUBROUTINE MMULT_R(C, A, B) - IMPLICIT NONE - REAL (KIND=8), DIMENSION(:,:) :: A,B,C - REAL (KIND=8) :: X, ALP, BET - INTEGER I,J, K, N, M, P, LDA, LDB, LDC - N = SIZE(A,1) ! Rows in A - M = SIZE(A,2) ! Columns in A - P = SIZE(B,2) ! Columns in B - LDA = N; LDB = SIZE(B,1); LDC = SIZE(C,1) - - ALP = 1.D0 - BET = 0.D0 - - - CALL DGEMM('n','n',N,P,M,ALP,A,LDA,B,LDB,BET,C,LDC) - - - - - - -! WRITE(6,*) 'In real', N,M,P -! DO I = 1,N -! DO J = 1,P -! X = 0.D0 -! DO K = 1,M -! X = X + A(I,K)*B(K,J) -! ENDDO -! C(I,J) = X -! ENDDO -! ENDDO - END SUBROUTINE MMULT_R - - SUBROUTINE MMULT_C(C, A, B) - IMPLICIT NONE - COMPLEX (KIND=8), DIMENSION(:,:) :: A,B,C - COMPLEX (KIND=8) :: ALP, BET - INTEGER I,J, K, N, M, P, LDA, LDB, LDC - - N = SIZE(A,1) - M = SIZE(A,2) - P = SIZE(B,2) - LDA = N; LDB = SIZE(B,1); LDC = SIZE(C,1) - - ALP = DCMPLX(1.D0,0.D0) - BET = DCMPLX(0.D0,0.D0) - - CALL ZGEMM('n','n',N,P,M,ALP,A,LDA,B,LDB,BET,C,LDC) - - - ! WRITE(6,*) 'In complex', N,M,P - ! DO I = 1,N - ! DO J = 1,P - ! X = CMPLX(0.D0,0.D0) - ! DO K = 1,M - ! X = X + A(I,K)*B(K,J) - ! ENDDO - ! C(I,J) = X - ! ENDDO - ! ENDDO - - END SUBROUTINE MMULT_C - -!********* - SUBROUTINE INITD_R(A,X) - IMPLICIT NONE - REAL (KIND=8), DIMENSION(:,:) :: A - REAL (KIND=8) X - INTEGER I,J, N, M - - N = SIZE(A,1) - M = SIZE(A,2) - - ! WRITE(6,*) 'In Init1 real', N,M - DO I = 1,N - DO J = 1,M - A(I,J) = 0.D0 - ENDDO - ENDDO - DO I = 1,N - A(I,I) = X - ENDDO - END SUBROUTINE INITD_R - - SUBROUTINE INITD_C(A,X) - IMPLICIT NONE - COMPLEX (KIND=8), DIMENSION(:,:) :: A - COMPLEX (KIND=8) X - INTEGER I,J, N, M - - N = SIZE(A,1) - M = SIZE(A,2) - -! WRITE(6,*) 'In Init1 complex', N,M - DO I = 1,N - DO J = 1,M - A(I,J) = CMPLX(0.D0,0.D0) - ENDDO - ENDDO - DO I = 1,N - A(I,I) = X - ENDDO - END SUBROUTINE INITD_C - - -!************* - SUBROUTINE INV_R0(A,AINV,DET) - IMPLICIT NONE - REAL (KIND=8), DIMENSION(:,:) :: A,AINV - REAL (KIND=8) :: DET - INTEGER I,J, N, M - -! Working space. - REAL (KIND=8) :: DET1(2) - REAL (KIND=8), DIMENSION(:), ALLOCATABLE :: WORK - INTEGER, DIMENSION(:), ALLOCATABLE :: IPVT - INTEGER INFO, JOB, LDA - - LDA = SIZE(A,1) -! Working space. - ALLOCATE ( IPVT(LDA) ) - ALLOCATE ( WORK(LDA) ) - - - DO I = 1,LDA - DO J = 1,LDA - AINV(J,I) = A(J,I) - ENDDO - ENDDO - -! Linpack routines. - - CALL DGEFA(AINV,LDA,LDA,IPVT,INFO) - JOB = 11 - CALL DGEDI(AINV,LDA,LDA,IPVT,DET1,WORK,JOB) - - !Write(6,*) 'In Inv_R0', DET1 - DET = DET1(1) * 10.D0**DET1(2) - - - DEALLOCATE (IPVT) - DEALLOCATE (WORK) - END SUBROUTINE INV_R0 - - -!************* - SUBROUTINE INV_R_Variable(A,AINV,DET,Ndim) - IMPLICIT NONE - REAL (KIND=8), DIMENSION(:,:) :: A,AINV - REAL (KIND=8) :: DET - INTEGER I,J, N, M, Ndim - -! Working space. - REAL (KIND=8) :: DET1(2) - REAL (KIND=8), DIMENSION(:), ALLOCATABLE :: WORK - INTEGER, DIMENSION(:), ALLOCATABLE :: IPVT - INTEGER INFO, JOB, LDA - - LDA = SIZE(A,1) -! Working space. - ALLOCATE ( IPVT(Ndim) ) - ALLOCATE ( WORK(Ndim) ) - - - DO I = 1,LDA - DO J = 1,LDA - AINV(J,I) = A(J,I) - ENDDO - ENDDO - -! Linpack routines. - - CALL DGEFA(AINV,LDA,Ndim,IPVT,INFO) - JOB = 11 - CALL DGEDI(AINV,LDA,Ndim,IPVT,DET1,WORK,JOB) - - DET = DET1(1) * 10.D0**DET1(2) - - DEALLOCATE (IPVT) - DEALLOCATE (WORK) - END SUBROUTINE INV_R_VARIABLE - -!************* - SUBROUTINE INV_R_Variable_1(A,AINV,DET,Ndim) - IMPLICIT NONE - REAL (KIND=8), DIMENSION(:,:) :: A,AINV - REAL (KIND=8) :: DET(2) - INTEGER I,J, N, M, Ndim - -! Working space. - REAL (KIND=8) :: DET1(2) - REAL (KIND=8), DIMENSION(:), ALLOCATABLE :: WORK - INTEGER, DIMENSION(:), ALLOCATABLE :: IPVT - INTEGER INFO, JOB, LDA - - LDA = SIZE(A,1) -! Working space. - ALLOCATE ( IPVT(Ndim) ) - ALLOCATE ( WORK(Ndim) ) - - - DO I = 1,LDA - DO J = 1,LDA - AINV(J,I) = A(J,I) - ENDDO - ENDDO - -! Linpack routines. - - CALL DGEFA(AINV,LDA,Ndim,IPVT,INFO) - JOB = 11 - CALL DGEDI(AINV,LDA,Ndim,IPVT,DET1,WORK,JOB) - - ! Determinant = DET1(1) * 10.D0**DET1(2) - DET(1) = DET1(1) - DET(2) = DET1(2) - - DEALLOCATE (IPVT) - DEALLOCATE (WORK) - END SUBROUTINE INV_R_VARIABLE_1 - - -!************* - SUBROUTINE INV_R1(A,AINV,DET1) - IMPLICIT NONE - REAL (KIND=8), DIMENSION(:,:) :: A,AINV - REAL (KIND=8) :: DET1(2) - INTEGER I,J, N, M - -! Working space. - REAL (KIND=8), DIMENSION(:), ALLOCATABLE :: WORK - INTEGER, DIMENSION(:), ALLOCATABLE :: IPVT - INTEGER INFO, JOB, LDA - - LDA = SIZE(A,1) -! Working space. - ALLOCATE ( IPVT(LDA) ) - ALLOCATE ( WORK(LDA) ) - - - DO I = 1,LDA - DO J = 1,LDA - AINV(J,I) = A(J,I) - ENDDO - ENDDO - -! Linpack routines. - - CALL DGEFA(AINV,LDA,LDA,IPVT,INFO) - JOB = 11 - CALL DGEDI(AINV,LDA,LDA,IPVT,DET1,WORK,JOB) - - - - - - - - DEALLOCATE (IPVT) - DEALLOCATE (WORK) - END SUBROUTINE INV_R1 - -!************* - SUBROUTINE INV_R2(A,AINV) - IMPLICIT NONE - REAL (KIND=8), DIMENSION(:,:) :: A,AINV - - INTEGER I,J, N, M - -! Uses Lapack routines. - -! Working space. - REAL (KIND=8), DIMENSION(:), ALLOCATABLE :: WORK - INTEGER, DIMENSION(:), ALLOCATABLE :: IPIV - INTEGER INFO, JOB, LDA, LWORK - - LDA = SIZE(A,1) - - !Write(6,*) 'Inv_r2:', LDA - ALLOCATE ( IPIV(LDA) ) - LWORK = LDA - ALLOCATE ( WORK(LWORK) ) - WORK = 0.0 - IPIV = 0 - DO I = 1,LDA - DO J = 1,LDA - AINV(J,I) = A(J,I) - ENDDO - ENDDO - INFO = 0 - - - CALL DGETRF( LDA, LDA, AINV, LDA, IPIV, INFO ) - CALL DGETRI(LDA, AINV, LDA, IPIV, WORK, LWORK, INFO) - - - - - - - -! Compute the determinant here if needed. -! detz = dcmplx(1.d0,0.d0) -! do n = 1,ne -! detz = detz * AINV(n,n) -! enddo ! Check. This may be wrong. - - - DEALLOCATE (IPIV) - DEALLOCATE (WORK) - END SUBROUTINE INV_R2 -!************* - - SUBROUTINE INV_C(A,AINV,DET) - IMPLICIT NONE - COMPLEX (KIND=8), DIMENSION(:,:) :: A,AINV - COMPLEX (KIND=8) :: DET - INTEGER I,J, N, M - -! Working space. - COMPLEX (KIND=8) :: DET1(2) - COMPLEX (KIND=8), DIMENSION(:), ALLOCATABLE :: WORK - INTEGER, DIMENSION(:), ALLOCATABLE :: IPVT - INTEGER INFO, JOB, LDA - - LDA = SIZE(A,1) -! Working space. - ALLOCATE ( IPVT(LDA) ) - ALLOCATE ( WORK(LDA) ) - - - DO I = 1,LDA - DO J = 1,LDA - AINV(J,I) = A(J,I) - ENDDO - ENDDO - -! Linpack routines. - - CALL ZGEFA(AINV,LDA,LDA,IPVT,INFO) - JOB = 11 - CALL ZGEDI(AINV,LDA,LDA,IPVT,DET1,WORK,JOB) - - - - - - - - DET = DET1(1)*10.D0**DET1(2) - - DEALLOCATE (IPVT) - DEALLOCATE (WORK) - END SUBROUTINE INV_C - -!======================================================================== - SUBROUTINE INV_C_Variable(A,AINV,DET,Ndim) - IMPLICIT NONE - COMPLEX (KIND=8), DIMENSION(:,:) :: A,AINV - COMPLEX (KIND=8) :: DET - INTEGER I,J, N, M,Ndim - -! Working space. - COMPLEX (KIND=8) :: DET1(2) - COMPLEX (KIND=8), DIMENSION(:), ALLOCATABLE :: WORK - INTEGER, DIMENSION(:), ALLOCATABLE :: IPVT - INTEGER INFO, JOB, LDA - - LDA = SIZE(A,1) -! Working space. - ALLOCATE ( IPVT(Ndim) ) - ALLOCATE ( WORK(Ndim) ) - - - DO I = 1,LDA - DO J = 1,LDA - AINV(J,I) = A(J,I) - ENDDO - ENDDO - -! Linpack routines. - - CALL ZGEFA(AINV,LDA,Ndim,IPVT,INFO) - JOB = 11 - CALL ZGEDI(AINV,LDA,Ndim,IPVT,DET1,WORK,JOB) - - - DET = DET1(1)*10.D0**DET1(2) - - DEALLOCATE (IPVT) - DEALLOCATE (WORK) - END SUBROUTINE INV_C_VARIABLE - -!======================================================================== - SUBROUTINE INV_C1(A,AINV,DET1) - IMPLICIT NONE - COMPLEX (KIND=8), DIMENSION(:,:) :: A,AINV - COMPLEX (KIND=8) :: DET1(2) - INTEGER I,J, N, M - -! Working space. - COMPLEX (KIND=8), DIMENSION(:), ALLOCATABLE :: WORK - INTEGER, DIMENSION(:), ALLOCATABLE :: IPVT - INTEGER INFO, JOB, LDA - - LDA = SIZE(A,1) -! Working space. - ALLOCATE ( IPVT(LDA) ) - ALLOCATE ( WORK(LDA) ) - - - DO I = 1,LDA - DO J = 1,LDA - AINV(J,I) = A(J,I) - ENDDO - ENDDO - -! Linpack routines. - - CALL ZGEFA(AINV,LDA,LDA,IPVT,INFO) - JOB = 11 - CALL ZGEDI(AINV,LDA,LDA,IPVT,DET1,WORK,JOB) - - - DEALLOCATE (IPVT) - DEALLOCATE (WORK) - END SUBROUTINE INV_C1 -!***** - - - - SUBROUTINE COMPARE_C(A,B,XMAX,XMEAN) - IMPLICIT NONE - COMPLEX (KIND=8), DIMENSION(:,:) :: A,B - REAL (KIND=8) :: XMAX, XMEAN - INTEGER I,J, N, M - - REAL (KIND=8) :: DIFF - - N = SIZE(A,1) - M = SIZE(A,2) - - XMAX = 0.D0 - XMEAN = 0.D0 - DO I = 1,N - DO J = 1,M - DIFF = SQRT( (A(I,J) - B(I,J))*CONJG(A(I,J)-B(I,J))) - IF (DIFF.GT.XMAX) XMAX = DIFF - XMEAN = XMEAN + DIFF - ENDDO - ENDDO - XMEAN = XMEAN/DBLE(N*M) - END SUBROUTINE COMPARE_C - - SUBROUTINE COMPARE_R(A,B,XMAX,XMEAN) - IMPLICIT NONE - REAL (KIND=8) , INTENT(IN), DIMENSION(:,:) :: A,B - REAL (KIND=8) , INTENT(INOUT) :: XMAX, XMEAN - INTEGER I,J, N, M - - REAL (KIND=8) :: DIFF - - N = SIZE(A,1) - M = SIZE(A,2) - - XMAX = 0.D0 - XMEAN = 0.D0 - DO I = 1,N - DO J = 1,M - DIFF = ABS( ( B(I,J) - A(I,J) ) ) - IF (DIFF.GT.XMAX) XMAX = DIFF - XMEAN = XMEAN + DIFF - ENDDO - ENDDO - XMEAN = XMEAN/DBLE(N*M) - END SUBROUTINE COMPARE_R - -!***************** - SUBROUTINE UDV1_R(A,U,D,V,NCON) - IMPLICIT NONE - REAL (KIND=8), INTENT(IN), DIMENSION(:,:) :: A - REAL (KIND=8), INTENT(INOUT), DIMENSION(:,:) :: U,V - REAL (KIND=8), INTENT(INOUT), DIMENSION(:) :: D - INTEGER, INTENT(IN) :: NCON - INTEGER I,J,K, N, M, ND1, ND2, NR, IMAX, IFAIL - -! The Det of V is not equal to unity. -! Locals: - INTEGER, DIMENSION(:), ALLOCATABLE :: IVPT, IVPTM1 - REAL (KIND=8), DIMENSION(:), ALLOCATABLE :: XNORM, VHELP,& - & THETA, WORK - REAL (KIND=8), DIMENSION(:,:), ALLOCATABLE :: TMP, V1,& - & TEST, TEST1, TEST2 - REAL (KIND=8) :: XMAX, XMEAN, Z, DETV - - ND1 = SIZE(A,1) - ND2 = SIZE(A,2) - - - -! WRITE(6,*) 'Udv A: ',ND1,ND2 -! WRITE(6,*) 'Udv V: ',size(V,1), size(V,2) -! You should now check corresponding sizes for U,V,D. - IF (SIZE(U,1).NE.ND1 .OR. SIZE(U,2).NE.ND2) THEN - WRITE(6,*) 'UDV dim mistake: U' - STOP - ENDIF - IF (SIZE(D,1).NE.ND2 ) THEN - WRITE(6,*) 'UDV dim mistake: D' - STOP - ENDIF - IF (SIZE(V,1).NE.ND2 .OR. SIZE(V,2).NE.ND2) THEN - WRITE(6,*) 'UDV dim mistake: V' - STOP - ENDIF - - ALLOCATE(XNORM (ND2)) - ALLOCATE(VHELP (ND2)) - ALLOCATE(IVPT (ND2)) - ALLOCATE(IVPTM1(ND2)) - ALLOCATE(WORK (ND2)) - ALLOCATE(THETA (ND2)) - - ALLOCATE(TMP(ND1,ND2)) - ALLOCATE(V1 (ND2,ND2)) - - V1 = 0.D0 - - DO I = 1,ND2 - XNORM(I) = 0.D0 - DO NR = 1,ND1 - XNORM(I) = XNORM(I) + ABS(A(NR,I)) - ENDDO - ENDDO - DO I = 1,ND2 - VHELP(I) = XNORM(I) - ENDDO - - DO I = 1,ND2 - XMAX = 0.D0 - DO J = 1,ND2 - IF (VHELP(J).GT.XMAX) IMAX = J - IF (VHELP(J).GT.XMAX) XMAX = VHELP(J) - ENDDO - VHELP(IMAX) = -1.D0 - IVPTM1(IMAX)=I - IVPT(I) = IMAX - ENDDO - - DO I = 1,ND2 - Z = 1.D0/XNORM(IVPT(I)) - K = IVPT(I) - DO NR = 1,ND1 - TMP(NR,I) = A(NR,K)*Z - ENDDO - ENDDO - - - !You now want to UDV TMP. Nag routines. - IFAIL = 0 - - - CALL F01QCF(ND1,ND2,TMP,ND1,THETA,IFAIL) - - - !Scale V1 to a unit triangluar matrix. - DO I = 1,ND2 - D(I) = ABS(TMP(I,I)) - ENDDO - DO I = 1,ND2 - Z = 1.D0/D(I) - DO J = I,ND2 - V1(I,J) = TMP(I,J)*Z - ENDDO - ENDDO - - -! Compute U - IFAIL = 0 - - CALL F01QEF('Separate', ND1,ND2, ND2, TMP,& - & ND1, THETA, WORK, IFAIL) - - - DO I = 1,ND1 - DO J = 1,ND2 - U(I,J) = TMP(I,J) - ENDDO - ENDDO - - -! Finish the pivotting. - DO I = 1,ND2 - D(I) = D(I)*XNORM(IVPT(I)) - ENDDO - DO I = 1,ND2-1 - Z = 1.D0/XNORM(IVPT(I)) - DO J = I+1,ND2 - V1(I,J) = V1(I,J)*XNORM(IVPT(J))*Z - ENDDO - ENDDO - - DO J = 1,ND2 - DO I = 1,ND2 - V(I,J) = V1(I,IVPTM1(J)) - ENDDO - ENDDO - -! Test accuracy. - IF (NCON.EQ.1) THEN - ALLOCATE (TEST(ND1,ND2)) - DO J = 1,ND2 - DO I = 1,ND1 - Z = 0.D0 - DO NR = 1,ND2 - Z = Z + U(I,NR)*D(NR)*V(NR,J) - ENDDO - TEST(I,J) = Z - ENDDO - ENDDO - XMAX = 0.0; XMEAN = 0.0 - CALL COMPARE(TEST,A,XMAX,XMEAN) - WRITE(6,*) 'Accuracy: ',XMAX - DEALLOCATE (TEST) - - ALLOCATE (TEST (ND2,ND1)) - ALLOCATE (TEST1 (ND2,ND2)) - ALLOCATE (TEST2 (ND2,ND2)) - ! Check orthogonality of U - DO I = 1,ND1 - DO J = 1,ND2 - TEST(J,I) = U(I,J) - ENDDO - ENDDO - CALL MMULT(TEST1,TEST,U) - CALL INITD(TEST2,1.D0) - XMAX = 0.0; XMEAN = 0.0 - CALL COMPARE(TEST1,TEST2,XMAX,XMEAN) - WRITE(6,*) 'UDV1 orth U: ',XMAX - DEALLOCATE (TEST ) - DEALLOCATE (TEST1 ) - DEALLOCATE (TEST2 ) - ENDIF - - - DEALLOCATE(XNORM ) - DEALLOCATE(VHELP ) - DEALLOCATE(IVPT ) - DEALLOCATE(IVPTM1) - DEALLOCATE(WORK ) - DEALLOCATE(THETA ) - - DEALLOCATE(TMP) - DEALLOCATE(V1 ) - - END SUBROUTINE UDV1_R - -!*************** - SUBROUTINE UDV_C(A,U,D,V,NCON) - !Uses Nag library. - !#include "machine" - - IMPLICIT NONE - COMPLEX (KIND=8), INTENT(IN), DIMENSION(:,:) :: A - COMPLEX (KIND=8), INTENT(INOUT), DIMENSION(:,:) :: U,V - COMPLEX (KIND=8), INTENT(INOUT), DIMENSION(:) :: D - INTEGER, INTENT(IN) :: NCON - INTEGER :: NE, LQ, IFAIL, I, J, NR - - !Local - COMPLEX (KIND=8), DIMENSION(:,:), ALLOCATABLE :: TMP, TEST - COMPLEX (KIND=8), DIMENSION(:), ALLOCATABLE :: THETA, WORK - COMPLEX (KIND=8) :: Z - REAL (KIND=8) :: DETV, XMDIFF, X - - LQ = SIZE(A,1) - NE = SIZE(A,2) - - U = DCMPLX(0.D0,0.D0) ; V = DCMPLX(0.D0,0.D0); D = DCMPLX(0.D0,0.D0) - ALLOCATE (TMP(LQ,NE), THETA(NE), WORK(NE)) - - TMP = A - - !You now want to UDV TMP. Nag routines. - IFAIL = 0 - - CALL F01RCF(LQ,NE,TMP,LQ,THETA,IFAIL) - - - DO I = 1,NE - DO J = I,NE - V(I,J) = TMP(I,J) - ENDDO - ENDDO - DETV = 1.D0 - !V is an NE by NE upper triangular matrix with real diagonal elements. - DO I = 1,NE - DETV = DETV * DBLE( TMP(I,I) ) - ENDDO - - !Compute U - - CALL F01REF('Separate', LQ,NE, NE, TMP, & - & LQ, THETA, WORK, IFAIL) - - - - - - DO J = 1,NE - DO I = 1,LQ - U(I,J) = TMP(I,J) - ENDDO - ENDDO - - IF (DBLE(DETV).LT.0.D0) THEN - DO I = 1,LQ - U(I,1) = -U(I,1) - ENDDO - DO I = 1,NE - V(1,I) = -V(1,I) - ENDDO - ENDIF - - !Scale V1 to a unit triangluar matrix. - DO I = 1,NE - D(I) = CMPLX(ABS(DBLE(V(I,I))),0.D0) - ENDDO - DO I = 1,NE - Z = DCMPLX(1.D0,0.D0)/D(I) - DO J = I,NE - V(I,J) = V(I,J)*Z - ENDDO - ENDDO - - !Test accuracy. - IF (NCON.EQ.1) THEN - ALLOCATE( TEST(LQ,NE) ) - DO J = 1,NE - DO I = 1,LQ - Z = DCMPLX(0.D0,0.D0) - DO NR = 1,NE - Z = Z + U(I,NR)*D(NR)*V(NR,J) - ENDDO - TEST(I,J) = Z - ENDDO - ENDDO - XMDIFF = 0.D0 - DO J = 1,LQ - DO I = 1,NE - Z = (TEST(J,I)-A(J,I)) * CONJG(TEST(J,I)-A(J,I)) - X = SQRT(DBLE(Z)) - IF (X.GT.XMDIFF) XMDIFF = X - ENDDO - ENDDO - WRITE(6,*) 'Accuracy, ortho: ',XMDIFF - DEALLOCATE( TEST ) - ENDIF - - DEALLOCATE (TMP, THETA, WORK) - - RETURN - END SUBROUTINE UDV_C - -!*************** - SUBROUTINE QR_C(A,U,V,NCON) - !Uses Nag library. - !#include "machine" - - IMPLICIT NONE - COMPLEX (KIND=8), INTENT(IN), DIMENSION(:,:) :: A - COMPLEX (KIND=8), INTENT(INOUT), DIMENSION(:,:) :: U,V - INTEGER, INTENT(IN) :: NCON - INTEGER :: NE, LQ, IFAIL, I, J, NR - - !Local - COMPLEX (KIND=8), DIMENSION(:,:), ALLOCATABLE :: TMP, TEST - COMPLEX (KIND=8), DIMENSION(:), ALLOCATABLE :: THETA, WORK - COMPLEX (KIND=8) :: Z - REAL (KIND=8) :: DETV, XMDIFF, X - - LQ = SIZE(A,1) - NE = SIZE(A,2) - - U = DCMPLX(0.D0,0.D0) ; V = DCMPLX(0.D0,0.D0) - ALLOCATE (TMP(LQ,NE), THETA(NE), WORK(NE)) - - TMP = A - - !You now want to UDV TMP. Nag routines. - IFAIL = 0 - - CALL F01RCF(LQ,NE,TMP,LQ,THETA,IFAIL) - - - DO I = 1,NE - DO J = I,NE - V(I,J) = TMP(I,J) - ENDDO - ENDDO - DETV = 1.D0 - !V is an NE by NE upper triangular matrix with real diagonal elements. - DO I = 1,NE - DETV = DETV * DBLE( TMP(I,I) ) - ENDDO - - !Compute U - - CALL F01REF('Separate', LQ,NE, NE, TMP, & - & LQ, THETA, WORK, IFAIL) - - DO J = 1,NE - DO I = 1,LQ - U(I,J) = TMP(I,J) - ENDDO - ENDDO - - IF (DBLE(DETV).LT.0.D0) THEN - DO I = 1,LQ - U(I,1) = -U(I,1) - ENDDO - DO I = 1,NE - V(1,I) = -V(1,I) - ENDDO - ENDIF - - - !Test accuracy. - IF (NCON.EQ.1) THEN - ALLOCATE( TEST(LQ,NE) ) - DO J = 1,NE - DO I = 1,LQ - Z = DCMPLX(0.D0,0.D0) - DO NR = 1,NE - Z = Z + U(I,NR)*V(NR,J) - ENDDO - TEST(I,J) = Z - ENDDO - ENDDO - XMDIFF = 0.D0 - DO J = 1,LQ - DO I = 1,NE - Z = (TEST(J,I)-A(J,I)) * CONJG(TEST(J,I)-A(J,I)) - X = SQRT(DBLE(Z)) - IF (X.GT.XMDIFF) XMDIFF = X - ENDDO - ENDDO - WRITE(6,*) 'Accuracy, QR: ',XMDIFF - DEALLOCATE( TEST ) - ENDIF - - DEALLOCATE (TMP, THETA, WORK) - - RETURN - END SUBROUTINE QR_C -!******************** - SUBROUTINE SVD_C(A,U,D,V,NCON) - !Uses LaPack Routine - !#include "machine" - - IMPLICIT NONE - COMPLEX (KIND=8), INTENT(IN), DIMENSION(:,:) :: A - COMPLEX (KIND=8), INTENT(INOUT), DIMENSION(:,:) :: U,V - COMPLEX (KIND=8), INTENT(INOUT), DIMENSION(:) :: D - INTEGER, INTENT(IN) :: NCON - - !! Local - REAL (Kind=8), Allocatable :: RWORK(:), S(:) - COMPLEX (Kind=8), Allocatable :: WORK(:), A1(:,:) - CHARACTER (Len=1):: JOBU,JOBVT - INTEGER :: M,N, LDA, LDVT, LDU, LWORK, I, J, I1, INFO - REAL (Kind=8) :: X, Xmax - COMPLEX (Kind=8) :: Z - - JOBU = "A" - JOBVT= "A" - M = SIZE(A,1) - N = SIZE(A,2) - Allocate (A1(M,N)) - Allocate (S(N)) - A1 = A - LDA = M - LDU = M - LDVT = N - if (M > N) then - LWORK = 2*N + M - I = 3*N - IF ( 5*N -4 > I) I = 5*N -4 - ALLOCATE (RWORK(I)) - Else - LWORK = 2*M + N - I = 3*M - IF ( 5*M -4 > I) I = 5*M -4 - ALLOCATE (RWORK(I)) - Endif - Allocate (WORK(LWORK)) - - - CALL ZGESVD( JOBU, JOBVT, M, N, A1, LDA, S, U, LDU, V, LDVT,& - & WORK, LWORK, RWORK, INFO ) - - DO I = 1,N - D(I) = cmplx(S(I),0.d0,kind=8) - ENDDO - - IF (NCON == 1) THEN - Write(6,*) JobU, JobVT - Xmax = 0.d0 - DO I = 1,M - DO I1 = 1,N - Z = cmplx(0.d0,0.d0,Kind=8) - DO J = 1,N - Z = Z + U(I,J) *D(J) *V(J,I1) - ENDDO - X = sqrt(Real((Z - A(I,I1))*Conjg(Z - A(I,I1)))) - IF (X > Xmax ) Xmax = X - ENDDO - ENDDO - WRITE(6,*) "Success (0), PRE ", INFO, Xmax - ENDIF - - - Deallocate (WORK,RWORK,A1,S) - - - END SUBROUTINE SVD_C -!*************** - - SUBROUTINE DIAG_R(A,U,W) - IMPLICIT NONE - REAL (KIND=8), INTENT(IN), DIMENSION(:,:) :: A - REAL (KIND=8), INTENT(INOUT), DIMENSION(:,:) :: U - REAL (KIND=8), INTENT(INOUT), DIMENSION(:) :: W - - - INTEGER ND1,ND2, MATZ,IERR - REAL (KIND=8), DIMENSION(:), ALLOCATABLE :: FV1,FV2 - - ND1 = SIZE(A,1) - ND2 = SIZE(A,2) - - IF (ND1.NE.ND2) THEN - WRITE(6,*) 'Error in matrix dimension DIAG_R' - STOP - ENDIF - - MATZ = 1 - IERR = 0 - U=0 - W=0 - ALLOCATE(FV1(ND1)) - ALLOCATE(FV2(ND1)) - CALL RS(ND1,ND1,A,W,MATZ,U, FV1,FV2,IERR) - DEALLOCATE(FV1) - DEALLOCATE(FV2) - - END SUBROUTINE DIAG_R -!********* - - SUBROUTINE DIAG_I(A,U,W) - ! Uses Lapack - IMPLICIT NONE - COMPLEX (KIND=8), INTENT(IN) , DIMENSION(:,:) :: A - COMPLEX (KIND=8), INTENT(INOUT), DIMENSION(:,:) :: U - REAL (KIND=8), INTENT(INOUT), DIMENSION(:) :: W - - CHARACTER (len=1) :: UPLO, JOBZ - INTEGER :: N, LWORK, INFO - COMPLEX (KIND=8), allocatable :: WORK (:) - REAL (KIND=8), allocatable :: RWORK(:) - Logical :: Test - Integer :: I,J,m - Complex (Kind=8) :: Z - Real (Kind=8) :: X, XMAX - - JOBZ = "V" - UPLO = "U" - N = size(A,1) - U = A - LWORK = 2*N -1 - Allocate ( WORK(LWORK) ) - Allocate ( RWORK(3*N-2)) - - !Write(6,*) 'In Diag' - - Call ZHEEV (JOBZ, UPLO, N, U, N, W, WORK, LWORK, RWORK, INFO) - - Deallocate (WORK, RWORK) - - Test = .false. - If (Test) then - XMAX = 0.d0 - DO I = 1,N - DO J = 1,N - Z = cmplx(0.d0,0.d0,kind=8) - DO m = 1,N - Z = Z + U(I,m)*cmplx(W(m),0.d0, Kind=8)*Conjg(U(J,m)) - ENDDO - Z = Z - A(I,J) - X = sqrt( Z*Conjg(Z) ) - If (X > XMAX ) XMAX = X - ENDDO - ENDDO - write(6,*) ' Test Diag_I: ', XMAX - endif - - End SUBROUTINE DIAG_I -!==================================================== - SUBROUTINE DIAG_I_old(A,U,W) - ! Uses Eispack - IMPLICIT NONE - COMPLEX (KIND=8), INTENT(IN) , DIMENSION(:,:) :: A - COMPLEX (KIND=8), INTENT(INOUT), DIMENSION(:,:) :: U - REAL (KIND=8), INTENT(INOUT), DIMENSION(:) :: W - - - INTEGER ND1,ND2, MATZ,IERR, I,J - REAL (KIND=8), DIMENSION( :), ALLOCATABLE :: FV1,FV2 - REAL (KIND=8), DIMENSION(:,:), ALLOCATABLE :: AR,AI, ER, EI, FM1 - - - ND1 = SIZE(A,1) - ND2 = SIZE(A,2) - - IF (ND1.NE.ND2) THEN - WRITE(6,*) 'Error in matrix dimension DIAG_I' - STOP - ENDIF - ND2 = SIZE(W,1) - IF (ND2.NE.ND1) THEN - WRITE(6,*) 'Error 1 in matrix dimension DIAG_I' - STOP - ENDIF - ND2 = SIZE(U,1) - IF (ND2.NE.ND1) THEN - WRITE(6,*) 'Error 2 in matrix dimension DIAG_I' - STOP - ENDIF - ND2 = SIZE(U,2) - IF (ND2.NE.ND1) THEN - WRITE(6,*) 'Error 3 in matrix dimension DIAG_I' - STOP - ENDIF - ALLOCATE (AR(ND1,ND1), AI(ND1,ND1), ER(ND1,ND1), EI(ND1,ND1)) - ALLOCATE (FV1(ND1), FV2(ND1), FM1(2,ND1)) - - MATZ = 1 - IERR = 0 - U=0 - W=0 - DO J = 1,ND1 - DO I = 1,ND1 - AR(I,J) = DBLE (A(I,J)) - AI(I,J) = AIMAG(A(I,J)) - ENDDO - ENDDO - CALL CH(ND1,ND1,AR,AI, W, MATZ,ER,EI, FV1,FV2,FM1,IERR) - DO J = 1,ND1 - DO I = 1,ND1 - U(I,J) = CMPLX (ER(I,J), EI(I,J)) - ENDDO - ENDDO - - DEALLOCATE (AR, AI, ER, EI) - DEALLOCATE (FV1, FV2, FM1) - - END SUBROUTINE DIAG_I_OLD - - - SUBROUTINE SECONDS(X) - IMPLICIT NONE - REAL (KIND=8), INTENT(INOUT) :: X - - !DATE_AND_TIME(date, time, zone, values) - !date_and_time([date][,time][,zone][,values]) - !Subroutine. Die Parameter haben das Attribut intent(out), geben also Werte zurück. - - ! date: skalare, normale Zeichenvariable von wenigstens 8 Zeichen. Die linken 8 Zeichen bekommen einen Wert der Form JJJJMMTT . JJJJ Jahr, MM Monat, TT Tag im Monat. - !time: skalare, normale Zeichenvariable von wenigstens 10 Zeichen. Die linken 10 Zeichen bekommen einen Wert der Form hhmmss.sss , wobei hh die Stunde des Tages ist, mm die Minute innerhalb der Stunde, und ss.sss die Sekunde mit Bruchteilen. - ! zone: skalare, normale Zeichenvariable von wenigstens 5 Zeichen. Die linken 5 Zeichen bekommen einen Wert der Form hhmm . hh Stunden, mm Minuten Zeitdifferenz gegenüber der UTC-Weltzeit. - !values: Eindimensionales Integer-Feld. Länge wenigstens 8. 1: Jahr, z.B. 1993. 2: Monat. 3: Monatstag. 4: Zeitdifferenz zur Weltzeit in Minuten. 5: Stunde des Tages. 6: Minute innerhalb der Stunde. 7: Sekunden 8. Millisekunden. - - !character(len=10) :: d,t - integer,dimension(8) :: V - !d = "" - !call date_and_time(date=d,time=t) - call date_and_time(values=V) - - X = DBLE(V(5)*3600 + V(6)*60 + V(7)) - - END SUBROUTINE SECONDS - -!==================================================== - Complex (Kind=8) Function DET_C(Mat,N) - - Implicit none - - ! Arguments - Integer, intent(in) :: N - Complex(kind=8), intent(inout) :: mat(N,N) - - integer :: i, info - integer :: ipiv(N) - - integer :: sgn - - ipiv = 0 - - !Lapack LU decomposition - call zgetrf(N, N, mat, N, ipiv, info) - - det_C = cmplx(1.d0,0.d0) - do i = 1, N - det_C = det_C*mat(i, i) - enddo - - sgn = 1 - do i = 1, N - if(ipiv(i) /= i) sgn = -sgn - enddo - if (sgn == -1 ) det_C = - det_C - - end function DET_C - - - END MODULE MyMats diff --git a/Libraries/Modules/matrix.f90 b/Libraries/Modules/matrix.f90 deleted file mode 100644 index 295b76179..000000000 --- a/Libraries/Modules/matrix.f90 +++ /dev/null @@ -1,80 +0,0 @@ - MODULE Matrix - - - - Type Mat_C - complex (Kind=8), pointer :: el(:,:) - Integer :: dim - end Type Mat_C - - Type Mat_R - Real (Kind=8), pointer :: el(:,:) - Integer :: dim - end Type Mat_R - - Interface Make_Mat - module procedure constructor_C, constructor_R - end Interface - Interface Clear_Mat - module procedure Destroy_C, Destroy_R - end Interface - - Contains - subroutine constructor_C(Mat,N) - type (Mat_C) :: Mat - Integer :: N - allocate (Mat%el(N,N)) - Mat%el = cmplx(0.0,0.0) - Mat%dim = N - end subroutine constructor_C - - subroutine constructor_R(Mat,N) - type (Mat_R) :: Mat - Integer :: N - allocate (Mat%el(N,N)) - Mat%el = 0.0 - Mat%dim = N - end subroutine constructor_R - - subroutine Destroy_C(Mat) - type (Mat_C) :: Mat - deallocate (Mat%el) - end subroutine Destroy_C - - subroutine Destroy_R(Mat) - type (Mat_R) :: Mat - deallocate (Mat%el) - end subroutine Destroy_R - end MODULE Matrix - - - -!!!!!!!!!!!!! Would be nice to implement one day.... !!!!!!!!!!!!!!!!!!!!! -! Use MyMats -! -! interface assignment(=) -! module procedure Equal_C -! end interface -! interface operator(*) -! module procedure Mat_mult_C -! end interface -! subroutine Equal_C(Z_out, Z_in) -! type (Mat_C), intent(in) :: Z_in -! type (MAT_C), intent(out) :: Z_out -! Z_out%A = Z_in%A -! end subroutine Equal_C -! -! function Mat_mult_C(Z1, Z2) result(Z3) -! -! type (Mat_C) , intent(in) :: Z1 , Z2 -! type (Mat_C) :: Z3 -! integer N -! -! N = size(Z1%A,1) -! Call Construct_Mat(Z3,N) -! -! Call MMULT(Z3%A, Z1%A, Z2%A) -! -! end function Mat_mult_C - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/Libraries/Modules/maxent.f90 b/Libraries/Modules/maxent.f90 deleted file mode 100644 index edf239205..000000000 --- a/Libraries/Modules/maxent.f90 +++ /dev/null @@ -1,807 +0,0 @@ -Module MaxEnt_mod - - Use MyMats - Use Errors - - - Interface MaxEnt - Module Procedure MaxEnt_T, MaxEnt_T0 - end Interface - - REAL (KIND=8), Private :: ZERO, ALPHA, PI, XMOM1 - REAL (KIND=8), Dimension(:), Private :: XPARAM(20) - REAL (KIND=8), Dimension(:), Allocatable, Private :: XLAM, DEF, SIG1 - REAL (KIND=8), DIMENSION(:,:), Allocatable, Private :: COVM1, UC - Integer, Private :: NTAU, NOM - - - CONTAINS - - Subroutine MaxEnt_T( XQMC, COV, A, XKER, ALPHA_ST, CHISQ,DEFAULT) - - Implicit None - Real (Kind=8), Dimension(:) :: XQMC, A - Real (Kind=8), Dimension(:,:) :: COV, XKER - Real (Kind=8) :: ALPHA_ST, CHISQ, ALPHA_N - Real (Kind=8), Dimension(:), optional :: Default - - Integer :: NT, NT1, NT2, NW, NFLAG, NCOUNT - Real (Kind=8) :: X, XENT, XQ, PR_ALP, XTRACE, DIFF1, DIFF , Tol_chi_def - - - Tol_chi_def = 1000000000000.0 - NTAU = SIZE(XQMC,1) - NOM = SIZE(A, 1) - !WRITE(6,*) 'NTAU, Nom: ', NTAU,NOM - PI = ACOS(-1.d0) - Xmom1 = Xqmc(1) - - ZERO = 1.0D-8 - ALLOCATE ( XLAM(NTAU), SIG1(NTAU), COVM1(NTAU,NTAU), UC(NTAU,NTAU), DEF(NOM) ) - XLAM=0.D0; SIG1=0.D0; UC = 0.D0 - - !Open (Unit=77,File='Aom_steps',Status='unknown') - - !Open(Unit=14) - !do nt = 1, NTAU - ! Write(14,*) Nt, XQMC(nt), sqrt(Cov(Nt,Nt)) - !enddo - !Close(14) - - CALL DIAG(COV,UC,SIG1) - DO NT1 = 1,NTAU - DO NT2 = 1,NTAU - X = 0.D0 - DO NT = 1,NTAU - X = X + UC(NT1,NT)*UC(NT2,NT)/SIG1(NT) - ENDDO - COVM1(NT1,NT2) = X - ENDDO - ENDDO - - - Open (Unit=50, File="info_Maxent", Status="unknown", position="append") - - Write(50,*) 'N E W R U N' - Write(50,*) '# of data points: ', NTAU - Write(6,*) 'N E W R U N' - ! Set the Default. - ALPHA = Alpha_st - DEF = XMOM1/dble(NOM) - XLAM = 0.d0 - if ( Present(Default) ) then - DEF = Default - Write(6,*) 'Default is present' - else - XQ = 0.d0; XENT= 0.d0; CHISQ = 0.d0 - Call Maximize_Newton( XQMC, COV, A, XKER, XQ,XENT,CHISQ) - IF (CHISQ .GT. Tol_chi_def*NTAU ) THEN - DO - XQ = 0.d0; XENT= 0.d0; CHISQ = 0.d0 - Call Maximize_Newton( XQMC, COV, A, XKER, XQ,XENT,CHISQ) - Write(50,*) 'Default: ', Alpha, Chisq - Write(6,*) 'Default: ', Alpha, Chisq - IF (CHISQ .GT. Tol_chi_def*NTAU .AND. ALPHA.GT.100 ) THEN - ALPHA = ALPHA - ALPHA*0.1 - ELSE - CALL SETA(A,XKER) - DO NW = 1,NOM - IF (A(NW).LT.ZERO) THEN - DEF(NW)= ZERO - ELSE - DEF(NW) = A(NW) - ENDIF - ENDDO - EXIT - ENDIF - ENDDO - ELSE - Write(6,*) 'Flat Default' - Endif - !DO NW = 1,NOM - ! Write(13,*) NW, DEF(NW) - !ENDDO - Write(6,*) 'Default Final: ', Alpha, Chisq - - DEF = XMOM1/dble(NOM) - Write(6,*) 'Setting the default to a flat default' - endif - - ! Calssic MaxEnt. - NFLAG = 0 - NCOUNT = 0 - !ALPHA = ALPHA_ST - XLAM = 0.D0 - DO - !WRITE(6,*) 'Starting classic ', ALPHA - WRITE(50,*) '========= Alpha: ', ALPHA - XQ = 0.d0; XENT= 0.d0; CHISQ = 0.d0 - !write(6,*) 'Calling maximize' - CALL MAXIMIZE_Newton( XQMC, COV, A, XKER, XQ,XENT,CHISQ) - !write(6,*) 'Return: Calling maximize' - IF (NFLAG.EQ.0) THEN - CALL CALCPR_ALP(XQMC, COV, A, XKER,XQ,XENT,PR_ALP,XTRACE) - ALPHA_N = -XTRACE/(2.D0*XENT) - WRITE(50,*) 'Max at:', ALPHA_N - WRITE(6,*) 'Max at:', ALPHA_N - WRITE(6,*) 'Old_alp', ALPHA - DIFF1 = ABS(ALPHA_N - ALPHA) - ENDIF - CALL SETA(A,XKER) - CALL SETQ(A,XKER,XQMC, XQ,XENT,CHISQ) - WRITE(50,2006) ALPHA, XQ,XENT,CHISQ - WRITE(6,2006 ) ALPHA, XQ,XENT,CHISQ - DIFF = ALPHA_N - ALPHA - IF ( ABS(DIFF) .GT. 0.1*ALPHA ) THEN - ALPHA = ALPHA + 0.1 * ALPHA * DIFF/ABS(DIFF) - NFLAG = 1 - ELSE - ALPHA = ALPHA_N - NFLAG = 0 - ENDIF - NCOUNT = NCOUNT + 1 - IF (NCOUNT .EQ. 100) THEN - WRITE(50,*) 'NOT CONVERGED' - ENDIF - IF ( ABS(DIFF1)/ABS(ALPHA_N).LT.0.01D0 .OR. NCOUNT.GT.1000 ) Exit - !& - ! & .OR. CHISQ.LT. 0.*dble(NTAU) ) EXIT - ENDDO - - - CLOSE(50) - -2006 FORMAT('Res: Alpha, XQ,S,CHI: ', F24.12,2x,F24.12,2x,F24.12,2x,F24.12) - - - DEALLOCATE ( XLAM, SIG1, COVM1, UC, DEF ) - !Close(77) - End Subroutine MaxEnt_T - - - - Subroutine Maximize_Newton( XQMC, COV, A, XKER, XQ,XENT,CHISQ) - - ! Sloves F(tau) = 0 with Newton. - - - Implicit None - !Arguments - REAL (KIND=8) :: XQ,XENT,CHISQ - REAL (Kind=8), Dimension(:) :: XQMC, A - REAL (Kind=8), Dimension(:,:) :: COV, XKER - - - !Working space - REAL (KIND=8), DIMENSION(:), ALLOCATABLE :: XLAM1, F - REAL (KIND=8), DIMENSION(:,:),ALLOCATABLE :: AH, AHINV - - Real (Kind=8) :: X, XNORM, DET1(2), XMAX - Integer :: NITER, NT, NT1, NW - - - ALLOCATE (XLAM1(NTAU), F(NTAU)) - XLAM1 = 0.D0; F = 0.D0 - ALLOCATE (AH(NTAU,NTAU), AHINV(NTAU,NTAU)) - AH = 0.D0; AHINV = 0.D0 - - NITER = 0 - !WRITE(6,*) "Starting Maximize" - DO - !Write(6,*) ' Iteration :: ', Niter - CALL SETA (A,XKER) - !Write(6,*) ' Back From SetA ' - CALL SETAH(AH, A,XKER,COV) - !Write(6,*) ' Back From SetAH ' - CALL SETF (F, COV, XKER, A, XQMC) - !Write(6,*) ' Back From SetF ' - Write(6,*) 'Calling INV' - CALL INV(AH, AHINV, DET1) - Write(6,*) 'Back Calling INV', Det1(1),Det1(2) - !CALL INV(AH, AHINV) - !Write(6,*) ' Back From INV ' - XNORM = 0.D0 - XMAX = 0.d0 - DO NT = 1,NTAU - X = 0.D0 - DO NT1 = 1,NTAU - X = X + AHINV(NT,NT1)*F(NT1) - ENDDO - XLAM1(NT) = XLAM(NT) - X - XNORM = XNORM + X*X - If (ABS(X).GT.XMAX) XMAX = ABS(X) - ENDDO - !Write(6,*) 'Max Diff Newton: ', XMAX - XNORM = SQRT(XNORM)/DBLE(NTAU) - !DO nw = 1,Nom - !write(77,*) nw, A(nw) - !enddo - !write(77,*) '# Chisq : ', CHISQ, XMAX - !write(77,*) - DO NT = 1,NTAU - XLAM(NT) = XLAM1(NT) - ENDDO - NITER = NITER + 1 - !WRITE(6,*) 'Maximize: ', XNORM, NITER - IF (XNORM.LT.1.0D-6 .OR. NITER.GE.100) EXIT - ENDDO - CALL SETQ(A,XKER,XQMC, XQ,XENT,CHISQ) - - IF (NITER.GE.100) THEN - WRITE(50,*) 'Convergence problem:' - ENDIF - - Deallocate (XLAM1, F) - Deallocate (AH, AHINV) - - END Subroutine Maximize_Newton - - - ! Working HERE - Subroutine Maximize_Self( XQMC, COV, A, XKER, XQ,XENT,CHISQ) - - ! Sloves F(tau) = 0 with self-consistency. - ! That is. Iterate to solve: alpha Cov(t,t1) xlam(t1) = \bar{G}(t) - G_qmc(t) - ! bar{G}(t) is the fit - - Implicit None - - - !Arguments - REAL (KIND=8) :: XQ,XENT,CHISQ - REAL (Kind=8), Dimension(:) :: XQMC, A - REAL (Kind=8), Dimension(:,:) :: COV, XKER - - - !Working space - REAL (KIND=8), DIMENSION(:), ALLOCATABLE :: XLAM1, F, GBAR - - Real (Kind=8) :: X, XNORM, DET1(2), XMAX - Integer :: NITER, NT, NT1, NW - - - ALLOCATE (XLAM1(NTAU), F(NTAU), GBAR(NTAU) ) - XLAM1 = 0.D0; F = 0.D0 - - - NITER = 0 - DO - CALL SETA (A,XKER) - DO NT = 1,NTAU - GBAR(NT) = 0.d0 - DO NW = 1,NOM - GBAR(NT) = GBAR(NT) + XKER(NT,NW)*A(NW) - ENDDO - GBAR(NT) = ( GBAR(NT) - XQMC(NT) ) / ALPHA - ENDDO - XNORM = 0.D0 - DO NT = 1,NTAU - XLAM1(NT) = 0.d0 - DO NT1 = 1,NTAU - XLAM1(NT) = XLAM1(NT) + COVM1(NT,NT1)*GBAR(NT1) - ENDDO - XNORM = XNORM + ( XLAM1(NT) - XLAM(NT) )**2 - ENDDO - IF (MOD(NITER,100) .EQ. 0 ) THEN - DO NT = 1,NTAU - Write(6,*) 'Self: ', XLAM(NT), XLAM1(NT) - ENDDO - ENDIF - XNORM = SQRT(XNORM)/DBLE(NTAU) - DO NT = 1,NTAU - XLAM(NT) = XLAM1(NT) - ENDDO - NITER = NITER + 1 - WRITE(6,*) 'Maximize_Self: ', XNORM, NITER - IF (XNORM.LT.1.0D-6 .OR. NITER.GE.1000) EXIT - ENDDO - CALL SETQ(A,XKER,XQMC, XQ,XENT,CHISQ) - - IF (NITER.GE.100) THEN - WRITE(50,*) 'Convergence problem:' - ENDIF - - Deallocate (XLAM1, F, GBAR ) - - END Subroutine Maximize_Self - - - - Subroutine SETA(A,XKER) - Implicit None - - ! Arguments: - Real (Kind=8), Dimension(:) :: A - Real (Kind=8), Dimension(:,:) :: XKER - - Real (Kind=8) :: X - Integer :: Nw, Nt - - DO NW = 1,NOM - X = 0.D0 - DO NT = 1,NTAU - X = X + XLAM(NT)*XKER(NT,NW) - ENDDO - A(NW) = DEF(NW)*EXP(-X) - !Write(6,*) 'SetA : ',NW, ' ' , X, ' ', A(NW) - ENDDO - End Subroutine SETA - - Subroutine SETAH(AH, A,XKER,COV) - Implicit None - !Given XLAM, A, and alpha, calcluates - !AH(tau,tau1) = \frac{\partial F_tau} {\partial tau1 } - - ! Arguments - REAL (KIND=8), DIMENSION(:,:) :: AH, COV, XKER - REAL (KIND=8), DIMENSION(:) :: A - - Integer NT, NT1, NW - Real (Kind=8) :: X - - IF ( SIZE(AH,1).NE.NTAU .OR. SIZE(AH,2).NE.NTAU) THEN - WRITE(6,*) 'Error in Setah ' - STOP - ENDIF - - DO NT = 1,NTAU - DO NT1 = 1,NTAU - X = 0.D0 - DO NW = 1,NOM - X = X + XKER(NT,NW)*XKER(NT1,NW)*A(NW) - ENDDO - AH(NT,NT1) = COV(NT,NT1)*ALPHA + X - ENDDO - ENDDO - - End Subroutine SETAH - - Subroutine SETF (F,COV,XKER,A,XQMC) - Implicit None - - !Given XLAM, A, and alpha, calcluates F - - - !Arguments - REAL (KIND=8), DIMENSION(:) :: F, A, XQMC - REAL (KIND=8), DIMENSION(:,:) :: COV, XKER - - REAL (Kind=8) :: X, X1 - Integer :: Nt, Nt1, Nw - - IF (SIZE(F,1).NE.NTAU) THEN - WRITE(6,*) 'Error in Setf ' - STOP - ENDIF - DO NT = 1,NTAU - X = 0.D0 - DO NT1 = 1,NTAU - X = X + COV(NT,NT1)*XLAM(NT1) - ENDDO - X = ALPHA*X - X1 = 0.D0 - DO NW = 1,NOM - X1 = X1 + XKER(NT,NW)*A(NW) - ENDDO - F(NT) = X + XQMC(NT) - X1 - ENDDO - End Subroutine SETF - - Subroutine SETQ(A,XKER,XQMC, XQ,XENT,CHISQ) - Implicit None - - !Arguments - REAL (KIND=8) :: XQ, XENT, CHISQ - Real (Kind=8), Dimension(:) :: A, XQMC - Real (Kind=8), Dimension(:,:) :: XKER - - !Local - REAL (KIND=8), DIMENSION(:), ALLOCATABLE :: VHLP - Integer :: Nw, Nt, Nt1 - Real (Kind=8) :: X - - XENT = 0.D0 - CHISQ = 0.D0 - ALLOCATE (VHLP(NTAU)) - - DO NW = 1,NOM - X = A(NW) - IF (A(NW).LT.ZERO) X = ZERO - XENT = XENT + X-DEF(NW) - X*LOG(X/DEF(NW)) - ENDDO - - DO NT = 1,NTAU - X = 0.D0 - DO NW = 1,NOM - X = X + XKER(NT,NW)*A(NW) - ENDDO - VHLP(NT) = XQMC(NT) - X - ENDDO - - DO NT1= 1,NTAU - DO NT = 1,NTAU - CHISQ = CHISQ + VHLP(NT)*COVM1(NT,NT1)*VHLP(NT1) - ENDDO - ENDDO - - XQ = ALPHA*XENT - CHISQ/2.D0 - - DEALLOCATE (VHLP) - End Subroutine SETQ - - SUBROUTINE CALCPR_ALP(XQMC, COV, A, XKER,XQ,XENT,PR_ALP,XTRACE) - Implicit None - - Real (Kind=8), Dimension(:) :: XQMC, A - Real (Kind=8), Dimension(:,:) :: COV, XKER - - - ! Arguments - REAL (KIND=8) :: XQ,XENT, PR_ALP,XTRACE - - - ! Local - REAL (KIND=8), DIMENSION(:) :: DET1(2) - REAL (KIND=8), DIMENSION(:,:), ALLOCATABLE :: XMAT, XMATM1, XKER1 - - Integer :: NFLAG, NW, NT, NT1, NW1 - REAL (Kind=8) :: XLDET - - ALLOCATE (XKER1(NTAU,NOM), XMAT(NOM,NOM), XMATM1(NOM,NOM) ) - XKER1 = 0.D0; XMAT = 0.D0; XMATM1 = 0.D0 - NFLAG = 0 - - IF (NFLAG.EQ.0) THEN - - !WRITE(6,*) 'Hi1' - XKER1 = 0.D0 - DO NW = 1,NOM - DO NT = 1,NTAU - DO NT1 = 1,NTAU - XKER1(NT,NW) = XKER1(NT,NW)+COVM1(NT,NT1)*XKER(NT1,NW) - ENDDO - XKER1(NT,NW) = XKER1(NT,NW)*SQRT(A(NW)) - ENDDO - ENDDO - - DO NW = 1,NOM - DO NW1= 1,NOM - XMAT(NW,NW1) = 0.D0 - DO NT = 1,NTAU - XMAT(NW,NW1)=XMAT(NW,NW1)+XKER(NT,NW)*XKER1(NT,NW1) - ENDDO - XMAT(NW,NW1) = SQRT(A(NW))*XMAT(NW,NW1) - ENDDO - ENDDO - - - DO NW = 1,NOM - XMAT(NW,NW) = XMAT(NW,NW) + ALPHA - ENDDO - - - CALL INV(XMAT, XMATM1, DET1) - - DO NW = 1,NOM - XMAT(NW,NW) = XMAT(NW,NW) - ALPHA - ENDDO - - !write(6,*) XQ, ALPHA, NOM, DET1(1), DET1(2) - XLDET = LOG(DET1(1)) + DET1(2)*LOG(10.D0) - - PR_ALP = XQ + 0.5*LOG(ALPHA)*DBLE(NOM) - 0.5*XLDET - - - XTRACE = 0.D0 - DO NW = 1,NOM - DO NW1 = 1,NOM - XTRACE = XTRACE + XMAT(NW,NW1)*XMATM1(NW1,NW) - ENDDO - ENDDO - - - ENDIF - - DEALLOCATE ( XKER1, XMAT, XMATM1 ) - - RETURN - END SUBROUTINE CALCPR_ALP - - - - - !real (kind=8) function f_fit(k,x) - ! integer k - ! real (kind=8) x - ! - ! if ( k.eq.1) f_fit = 1.d0 - ! if ( k.eq.2) f_fit = x - ! - ! return - !end function f_fit - - - Subroutine MaxEnt_T0 ( XQMC, COV, A, XKER, ALPHA_ST, CHISQ, Rel_err, Shift, xtau, f_fit) - - Implicit None - Real (Kind=8), Dimension(:) :: XQMC, A - Real (Kind=8), Dimension(:,:) :: COV, XKER - Real (Kind=8) :: ALPHA_ST, CHISQ, Rel_err - Real (Kind=8), Optional :: Shift - Real (Kind=8), Dimension(:), Optional :: xtau - Real (Kind=8), external, Optional :: f_fit - - Real (Kind=8), Dimension(:) , Allocatable :: XQMC_1 - Real (Kind=8), Dimension(:,:), Allocatable :: COV_1, XKER_1 - - ! For the fit if requested. - Real (Kind=8) :: chisq_fit, Ares(2) - Real (Kind=8), Dimension(:), allocatable :: xdata_fit, fdata_fit, error_fit - Integer :: Nd_fit - !real (kind=8), external :: f_fit - - Integer nt, nt1, ntau_eff, nw - Real (Kind=8) :: X - - ntau = size(xqmc,1) - Nom = Size(A,1) - ntau_eff = 0 - nt = 0 - do - nt = nt + 1 - X = sqrt( cov(nt,nt) )/ xqmc(nt) - if ( X.lt.Rel_err) then - ntau_eff = ntau_eff + 1 - else - exit - endif - if (nt.eq.ntau) exit - enddo - write(6,*) 'Ntau_eff: ', Ntau_eff - - Write(6,*) 'Resizing' - Allocate ( XQMC_1(Ntau_eff), Cov_1(Ntau_eff,Ntau_eff), Xker_1(Ntau_eff,Nom) ) - do nt = 1,Ntau_eff - xqmc_1(nt) = xqmc(nt) - enddo - do nt = 1,Ntau_eff - do nt1 = 1,Ntau_eff - cov_1(nt,nt1) = cov(nt,nt1) - enddo - enddo - do nt = 1,Ntau_eff - do nw = 1,Nom - XKer_1(nt, nw) = XKer(nt, nw) - enddo - enddo - IF ( PRESENT(Shift) .and. PRESENT(xtau) .and. PRESENT(F_FIT) ) Then - write(6,*) 'The data will be shifted' - shift = 0.d0 - Nd_fit = Ntau_eff/2 - Allocate (xdata_fit(Nd_fit), fdata_fit(Nd_fit), error_fit(Nd_fit) ) - do nt = 1,Nd_fit - xdata_fit(nt) = xtau(nt + Nd_fit) - fdata_fit(nt) = log(xqmc_1(nt + Nd_fit)) - error_fit (nt) = sqrt( cov_1(nt + Nd_fit,nt + Nd_fit) )/xqmc_1(nt + Nd_fit) - enddo - call fit(xdata_fit,fdata_fit,error_fit,ares,chisq_fit,f_fit) - write(6,*) 'The slope is : ', Ares(2) - shift = -Ares(2) - 0.2 - Deallocate (xdata_fit, fdata_fit, error_fit ) - do nt = 1,Ntau_eff - xqmc_1(nt) = xqmc_1(nt)*exp(xtau(nt)*shift) - enddo - do nt = 1,Ntau_eff - do nt1 = 1,Ntau_eff - cov_1(nt,nt1) = cov_1(nt,nt1)*exp( (xtau(nt) + xtau(nt1))*shift ) - enddo - enddo - else - write(6,*) 'The data will not be shifted' - endif - Call MaxEnt_T(XQMC_1, COV_1, A, XKER_1, ALPHA_ST, CHISQ) - Deallocate ( Xqmc_1, Cov_1, Xker_1 ) - - - end Subroutine MaxEnt_T0 - - - - Subroutine MaxEnt_gr(XTAU, XQMC, COV, A, XOM, Beta, ALPHA_ST, CHISQ ) - ! Sets the Kernel for Green functions. - Implicit none - - Real (Kind=8), Dimension(:) :: XTAU, XQMC, A, XOM - Real (Kind=8), Dimension(:,:) :: COV - - Real (Kind=8) :: ALPHA_ST, CHISQ, BETA - - - Real (Kind=8), Dimension(:,:), allocatable :: xker - - Integer :: NT, NW, NTAU, NOM - - - Nom = Size(Xom ,1) - Ntau = Size(Xtau,1) - - Allocate ( Xker(Ntau,Nom) ) - do nt = 1,ntau - do nw = 1,Nom - XKer(nt,nw) = EXP(-xtau(nt)*xom(nw) ) / ( 1.d0 + EXP( -BETA*xom(nw) ) ) - Enddo - Enddo - - Call MaxEnt_T(XQMC, COV, A, XKER, ALPHA_ST, CHISQ ) - - Deallocate ( Xker ) - End Subroutine MaxEnt_gr - - - Subroutine MaxEnt_T_Bryan( XQMC, COV, A, XKER, ALPHA_ST, ALPHA_EN, CHISQ ) - - Implicit None - Real (Kind=8), Dimension(:) :: XQMC, A - Real (Kind=8), Dimension(:,:) :: COV, XKER - Real (Kind=8) :: ALPHA_ST, CHISQ, ALPHA_N, ALPHA_EN - - Integer :: NT, NT1, NT2, NW, NFLAG, NCOUNT, NTH - Real (Kind=8) :: X, XENT, XQ, PR_ALP, XTRACE, DIFF1, DIFF , Tol_chi_def, XNORM, & - & D_ALPHA, ALPHA_OLD, XNORM_TOT - - Real (Kind=8), Dimension(:), allocatable :: A_ME - - Tol_chi_def = 100000000000000.0 - NTAU = SIZE(XQMC,1) - NOM = SIZE(A, 1) - ALLOCATE(A_ME(NOM)) - !WRITE(6,*) 'NTAU, Nom: ', NTAU,NOM - PI = ACOS(-1.d0) - XMOM1= 1.0 !PI - ZERO = 1.0D-8 - ALLOCATE ( XLAM(NTAU), SIG1(NTAU), COVM1(NTAU,NTAU), UC(NTAU,NTAU), DEF(NOM) ) - XLAM=0.D0; SIG1=0.D0; UC = 0.D0 - - !Open (Unit=77,File='Aom_steps',Status='unknown') - !Open(Unit=14) - !do nt = 1, NTAU - ! Write(14,*) Nt, XQMC(nt), sqrt(Cov(Nt,Nt)) - !enddo - !Close(14) - - CALL DIAG(COV,UC,SIG1) - DO NT1 = 1,NTAU - DO NT2 = 1,NTAU - X = 0.D0 - DO NT = 1,NTAU - X = X + UC(NT1,NT)*UC(NT2,NT)/SIG1(NT) - ENDDO - COVM1(NT1,NT2) = X - ENDDO - ENDDO - - - Open (Unit=50, File="info_Maxent", Status="unknown", position="append") - - Write(50,*) 'N E W R U N' - Write(50,*) '# of data points: ', NTAU - Write(6,*) 'N E W R U N' - ! Set the Default. - ALPHA = Alpha_st - DEF = XMOM1/dble(NOM) - XLAM = 0.d0 - XQ = 0.d0; XENT= 0.d0; CHISQ = 0.d0 - Call Maximize_Newton( XQMC, COV, A, XKER, XQ,XENT,CHISQ) - IF (CHISQ .GT. Tol_chi_def*NTAU ) THEN - DO - XQ = 0.d0; XENT= 0.d0; CHISQ = 0.d0 - Call Maximize_Newton( XQMC, COV, A, XKER, XQ,XENT,CHISQ) - Write(50,*) 'Default: ', Alpha, Chisq - Write(6,*) 'Default: ', Alpha, Chisq - IF (CHISQ .GT. Tol_chi_def*NTAU .AND. ALPHA.GT.100 ) THEN - ALPHA = ALPHA - ALPHA*0.1 - ELSE - CALL SETA(A,XKER) - DO NW = 1,NOM - IF (A(NW).LT.ZERO) THEN - DEF(NW)= ZERO - ELSE - DEF(NW) = A(NW) - ENDIF - ENDDO - EXIT - ENDIF - ENDDO - ELSE - Write(6,*) 'Flat Default' - Endif - !DO NW = 1,NOM - ! Write(13,*) NW, DEF(NW) - !ENDDO - Write(6,*) 'Default Final: ', Alpha, Chisq - - DEF = XMOM1/dble(NOM) - Write(6,*) 'Setting the default to a flat default' - - - ! Calssic MaxEnt. - NFLAG = 0 - NCOUNT = 0 - !ALPHA = ALPHA_ST - ALPHA_N = ALPHA_EN - XLAM = 0.D0 - NTH = 0 - A_ME = 0.d0 - XNORM_TOT = 0.d0 - OPEN (Unit=55,File="Tmp",status="unknown") - DO - !WRITE(6,*) 'Starting classic ', ALPHA - WRITE(50,*) '========= Alpha: ', ALPHA - XQ = 0.d0; XENT= 0.d0; CHISQ = 0.d0 - !write(6,*) 'Calling maximize' - CALL MAXIMIZE_Newton( XQMC, COV, A, XKER, XQ,XENT,CHISQ) - !write(6,*) 'Return: Calling maximize' - !IF (NFLAG.EQ.0) THEN - CALL CALCPR_ALP(XQMC, COV, A, XKER,XQ,XENT,PR_ALP,XTRACE) - IF (NTH.EQ.0) XNORM = EXP(PR_ALP) - NTH = NTH + 1 - !ALPHA_N = -XTRACE/(2.D0*XENT) - WRITE(50,*) 'Max at:', ALPHA_N - WRITE(6,*) 'Max at:', ALPHA_N - DIFF1 = ABS(ALPHA_N - ALPHA) - !ENDIF - CALL SETA(A,XKER) - CALL SETQ(A,XKER,XQMC, XQ,XENT,CHISQ) - WRITE(50,2006) ALPHA, XQ,XENT,CHISQ - WRITE(6,2006 ) ALPHA, XQ,XENT,CHISQ - DIFF = ALPHA_N - ALPHA - ALPHA_OLD = ALPHA - IF ( ABS(DIFF) .GT. 0.05*ALPHA ) THEN - D_alpha = 0.05 * ALPHA - ALPHA = ALPHA + 0.05 * ALPHA * DIFF/ABS(DIFF) - NFLAG = 1 - ELSE - D_alpha = ABS(ALPHA_N - ALPHA) - ALPHA = ALPHA_N - NFLAG = 0 - ENDIF - NCOUNT = NCOUNT + 1 - IF (NCOUNT .EQ. 100) THEN - WRITE(50,*) 'NOT CONVERGED' - ENDIF - WRITE(55,*) ALPHA_OLD, EXP(PR_ALP)/XNORM, D_ALPHA - XNORM_TOT = XNORM_TOT + D_ALPHA*(EXP(PR_ALP)/XNORM) - do nw = 1, NOM - A_ME(nw) = A_ME(nw) + D_ALPHA*A(nw)*(EXP(PR_ALP)/XNORM) - enddo - IF ( ABS(DIFF1)/ABS(ALPHA_N).LT.0.01D0 .OR. NCOUNT.GT.1000 ) EXIT - ENDDO - CLOSE(55) - - A_ME = A_ME/XNORM_TOT - A = A_ME - WRITE(50,*) 'Tot Norm:', XNORM_TOT - OPEN(Unit=55,File="Tmp", Status="unknown") - OPEN(Unit=57,File="Pr_alpha", Status="unknown") - do - read(55,*,End=10) ALPHA_OLD, XNORM, D_ALPHA - XNORM = XNORM/XNORM_TOT - write(57,*) ALPHA_OLD, XNORM, D_ALPHA - enddo -10 continue - Close(55) - Close(57) - CLOSE(50) - - -2006 FORMAT('Res: Alpha, XQ,S,CHI: ', F14.7,2x,F14.7,2x,F14.7,2x,F14.7) - - - DEALLOCATE ( XLAM, SIG1, COVM1, UC, DEF ) - DEALLOCATE ( A_ME ) - !Close(77) - End Subroutine MaxEnt_T_Bryan - - end Module MaxEnt_mod - - diff --git a/Libraries/Modules/maxent_stoch.G90 b/Libraries/Modules/maxent_stoch.G90 deleted file mode 100644 index 30fd2337b..000000000 --- a/Libraries/Modules/maxent_stoch.G90 +++ /dev/null @@ -1,964 +0,0 @@ -#include "machine" -#ifdef MPI -Module MaxEnt_stoch_mod_MPI -#else -Module MaxEnt_stoch_mod -#endif - - Use MyMats - Use Files_mod - - - Integer, private :: NTAU, nt, Ngamma, ng, Ndis, nd, Iseed - Real (Kind=8), private :: Delta, Delta2, OM_st_1, Om_en_1, DeltaXMAX, Beta, Pi, Dom - Real (Kind=8), allocatable, private :: XQMC1(:) - - ! You can still optimize a bit for by redefining the Kernel table to: - ! xker_table(nt,nw) -> xker_table(nt,nw) / sigma(nt) - ! This will save quite a lot of divisions in the - ! MC routine. And this is where all the time goes now. - - CONTAINS - - Subroutine MaxEnt_stoch(XQMC, Xtau, COV,Xmom1, XKER, Back_Trans_Aom, Beta_1, Alpha_tot,& - & Ngamma_1, OM_ST, OM_EN, Ndis_1, Nsweeps, NBins, NWarm, L_cov) - - Implicit None - -#ifdef MPI - include 'mpif.h' -#endif - - Real (Kind=8), Dimension(:) :: XQMC, Xtau, Alpha_tot - Real (Kind=8), Dimension(:,:) :: COV - Real (Kind=8), External :: XKER, Back_trans_Aom - Real (Kind=8) :: CHISQ, OM_ST, OM_EN, Beta_1, Xmom1, Err - Integer :: Nsweeps, NBins, Ngamma_1, Ndis_1, nw, nt1 - Integer, optional :: L_cov - - ! Local - Integer lp, NSims, ns, nb, nc, Nwarm, nalp1, nalp2, Nex, p_star, Ndis_table, & - & io_error, io_error1, i, n, nc1 - Real (Kind=8), Allocatable :: Xn_M_tot(:,:), En_M_tot(:), Xn_E_tot(:,:), En_E_tot(:), & - & Xn_tot(:,:,:), En_tot(:) - Real (Kind=8), Allocatable :: G_Mean(:), Xn_m(:), Xn_e(:), Xn(:,:), Vhelp(:) - Real (Kind=8) :: Ranf, En_M, Res, X, Alpha, Acc_1, Acc_2, En, DeltaE, Ratio, D - Real (Kind=8) :: Aom, om, XMAX, tau - Real (Kind=8) :: CPUT, CPUTM - Integer :: ICPU_1, ICPU_2, N_P_SEC - Character (64) :: File_root, File1, File_conf, File_Aom - Real (Kind=8), allocatable :: Xker_table(:,:), U(:,:), sigma(:) - - ! Space for moments. - Real (Kind=8), allocatable:: Mom_M_tot(:,:), Mom_E_tot(:,:) - - -#ifdef MPI - INTEGER, allocatable :: Iseed_table(:), n1, n2, n, IRANK, IERR, ISIZE - INTEGER STATUS(MPI_STATUS_SIZE) - Real (Kind=8), Allocatable :: Collect1(:), Collect2(:,:) - CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) - CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) -#endif - - Pi = acos(-1.d0) - NDis = Ndis_1 - DeltaXMAX = 0.01 - delta = 0.001 - delta2 = delta*delta - Ngamma = Ngamma_1 - Beta = Beta_1 ! Physical temperature for calculation of the kernel. - - Ntau = Size(xqmc,1) - NSims = Size(Alpha_tot,1) - Allocate (Xn_tot(Ngamma,2,NSims)) - Allocate (En_m_tot(NSims), En_e_tot(NSims), En_tot(NSims) ) - Allocate (Xn_m_tot(NDis,NSims), Xn_e_tot(NDis,NSims) ) - Allocate (Mom_M_tot(2,Nsims), Mom_E_tot(2,Nsims) ) - - Allocate (Xn(Ngamma,2)) - Allocate (Xn_m(NDis), Xn_e(NDis) ) - - Om_st_1 = OM_st; Om_en_1 = OM_en - - ! Setup table for the Kernel - Ndis_table = 50000 - Dom = (OM_EN_1 - OM_ST_1)/dble(Ndis_table-1) - Allocate ( Xker_table(Ntau, Ndis_table) ) - do nt = 1,Ntau - do nw = 1,Ndis_table - tau = xtau(nt) - Om = OM_st + dble(nw-1)*dom - Xker_table(nt,nw) = Xker(tau,om,beta) - enddo - enddo - ! Normalize data to have zeroth moment of unity. - xqmc = xqmc / XMOM1 - cov = cov / ((XMOM1)**2) - ! Diagonalize the covariance - - Allocate( U(ntau,ntau), Sigma(ntau), xqmc1(Ntau) ) - If ( Present(L_cov) ) then - Call Diag(cov,U,sigma) - ! Write(6,*) " Cov Used" - else - Write(6,*) "No Cov Used" - U = 0.d0 - do nt = 1,ntau - U(nt,nt) = 1.d0 - sigma(nt) = cov(nt,nt) - enddo - endif - do nt = 1,ntau - sigma(nt) = sqrt(sigma(nt)) - enddo - xqmc1 = 0.d0 - do nt1 = 1,ntau - do nt = 1,ntau - xqmc1(nt1) = xqmc1(nt1) + xqmc(nt)*U(nt,nt1) - enddo - xqmc1(nt1) = xqmc1(nt1)/sigma(nt1) - enddo - ! Transform the Kernel - allocate ( Vhelp(Ntau) ) - do nw = 1,Ndis_table - Vhelp = 0.d0 - do nt1 = 1,Ntau - do nt = 1,Ntau - Vhelp(nt1) = Vhelp(nt1) + Xker_table(nt,nw)*U(nt,nt1) - enddo - enddo - do nt1 = 1,ntau - Xker_table(nt1,nw) = Vhelp(nt1)/sigma(nt1) !! This has changed !! - enddo - enddo - deallocate( U, Sigma ) - Allocate ( G_Mean(Ntau) ) - G_mean = 0.d0 - -! write(6,*) ' There are ', Ngamma,' delta-functions for a spectrum' -! Write(6,*) ' Initializing' - ! D(om) = 1/(Om_en_1 - Om_st_1) - D = 1.d0 / (Om_en_1 - Om_st_1) - -#ifdef MPI - allocate (iseed_table(ISIZE+1)) - if (Irank.eq.0) then - Open (Unit=10,File="seeds", status = "unknown") - do i = 1,isize + 1 - read(10,*) iseed_table(i) - enddo - close(10) - endif - Call MPI_BCAST(Iseed_table ,Isize+1,MPI_INTEGER,0,MPI_COMM_WORLD,IERR) - iseed = iseed_table(Irank + 1) -#else - Iseed = 8752143 -#endif - -#ifdef MPI - File_root = "dump_conf" - File_conf = File_i( File_root, Irank ) - File_root = "dump_Aom" - File_Aom = File_i( File_root, Irank ) -#else - File_conf = "dump_conf" - File_Aom = "dump_Aom" -#endif - - Open(unit=41,file=File_conf,status='old',action='read', iostat=io_error) - Open(unit=42,file=File_Aom, status='old',action='read', iostat=io_error1) - If (io_error == 0 .and. io_error1 == 0 ) then - Nwarm = 0 - read(41,*) Iseed - do ns = 1,Nsims - do ng = 1,Ngamma - read(41,*) Xn_tot(ng,1,ns), Xn_tot(ng,2,ns) - enddo - read(41,*) En_m_tot(ns), En_e_tot(ns) - enddo - read(42,*) nc - do ns = 1,Nsims - do nd = 1,Ndis - read(42,*) Xn_m_tot(nd,ns), Xn_e_tot(nd,ns) - enddo - enddo -#ifdef MPI - if (Irank == 0) then -#endif - Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") - Write(44,*) 'Read from dump: nc = ', nc - close(44) -#ifdef MPI - endif -#endif - else - !Iseed is alrady set. - Do Ns = 1,NSims - do ng = 1,NGamma - Xn_tot(ng,1,ns) = ranf(iseed) - Xn_tot(ng,2,ns) = 1.d0/dble(Ngamma) - enddo - enddo - Xn_m_tot = 0.d0 - En_m_tot = 0.d0 - Xn_e_tot = 0.d0 - En_e_tot = 0.d0 - nc = 0 -#ifdef MPI - if (Irank == 0) then -#endif - Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") - Write(44,*) ' No dump data ' - close(44) -#ifdef MPI - endif -#endif - endif - close(41) - close(42) - - nc1 = 0 - Mom_M_tot = 0.d0 - Mom_E_tot = 0.d0 - - - CALL SYSTEM_CLOCK(COUNT_RATE=N_P_SEC) - CALL SYSTEM_CLOCK(COUNT=ICPU_1) - ! Start Simulations. - do Nb = 1,Nbins - do ns = 1,NSims - do ng = 1,Ngamma - Xn(ng,1) = Xn_tot(ng,1,ns) - Xn(ng,2) = Xn_tot(ng,2,ns) - enddo - Alpha = Alpha_tot(ns) - Call MC(Xtau, Xker_table, Xn, Alpha, NSweeps, Xn_m, En, En_m, & - & Acc_1, Acc_2 ) ! Just one bin - do ng = 1,Ngamma - Xn_tot(ng,1,ns) = Xn(ng,1) - Xn_tot(ng,2,ns) = Xn(ng,2) - enddo - En_tot(ns) = En ! this is the energy of the configuration Xn_tot for simulation ns -#ifdef MPI -#else - Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") - Write(44,2003) 1.d0/Alpha, En_m, Acc_1, Acc_2 - close(44) - -#endif - if (nb.gt.nwarm) then - if (ns.eq.1) nc = nc + 1 - do nd = 1,NDis - Xn_m(nd) = Xn_m(nd) * D * dble(Ndis) - Xn_m_tot(nd,ns) = Xn_m_tot(nd,ns) + Xn_m(nd) - Xn_e_tot(nd,ns) = Xn_e_tot(nd,ns) + Xn_m(nd)*Xn_m(nd) - enddo - En_m_tot(ns) = En_m_tot(ns) + En_m - En_e_tot(ns) = En_e_tot(ns) + En_m*En_m - ! Compute moments - if (ns.eq.1) nc1 = nc1 + 1 - do n = 1,Size(Mom_M_tot,1) - x = 0.d0 - do ng = 1,Ngamma - X = X + ( Phim1(Xn_tot(ng,1,ns))**(n-1) ) * Xn_tot(ng,2,Ns) - enddo - Mom_M_tot(n,ns) = Mom_M_tot(n,ns) + X - Mom_E_tot(n,ns) = Mom_E_tot(n,ns) + X*X - enddo - endif - enddo - ! Exchange - Acc_1 = 0.d0 - Do Nex = 1, 2*NSims - nalp1= nint( ranf(iseed)*dble(NSims-1) + 0.5 ) ! 1..(NSims-1) - nalp2 = nalp1 + 1 - DeltaE = (Alpha_tot(nalp1)*En_tot(nalp2) + Alpha_tot(nalp2)*En_tot(nalp1))& - & -(Alpha_tot(nalp1)*En_tot(nalp1) + Alpha_tot(nalp2)*En_tot(nalp2)) - Ratio = exp(-DeltaE) - if (Ratio.gt.ranf(iseed)) Then - Acc_1 = Acc_1 + 1.0 - !Switch confs an Energies. - do ng = 1,Ngamma - Xn(ng,1) = Xn_tot(ng,1,nalp1) - Xn(ng,2) = Xn_tot(ng,2,nalp1) - enddo - do ng = 1,Ngamma - Xn_tot(ng,1,nalp1) = Xn_tot(ng,1,nalp2) - Xn_tot(ng,2,nalp1) = Xn_tot(ng,2,nalp2) - Xn_tot(ng,1,nalp2) = Xn(ng,1) - Xn_tot(ng,2,nalp2) = Xn(ng,2) - enddo - En_m = En_tot(nalp1) - En_tot(nalp1) = En_tot(nalp2) - En_tot(nalp2) = En_m - endif - enddo - Acc_1 = Acc_1/dble(Nex) -#ifdef MPI -#else - - Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") - Write(44,*) 'Acc Exchange: ', Acc_1 - close(44) -#endif - enddo - - CALL SYSTEM_CLOCK(COUNT=ICPU_2) - CPUT = 0.D0 - CPUT = DBLE(ICPU_2 - ICPU_1)/DBLE(N_P_SEC) -#ifdef MPI - CPUTM = 0.d0 - call MPI_REDUCE(CPUT,CPUTM,1,MPI_REAL8,MPI_SUM, 0,MPI_COMM_WORLD,IERR) - CPUT = CPUTM/dble(Isize) -#endif -#ifdef MPI - if (Irank == 0 ) then -#endif - Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") - Write(44,*) 'Total time: ', CPUT - close(44) -#ifdef MPI - endif -#endif - ! dump so as to restart. - Open(unit=41,file=File_conf,status='unknown') - Open(unit=42,file=File_Aom, status='unknown') - write(41,*) Iseed - do ns = 1,Nsims - do ng = 1,Ngamma - write(41,*) Xn_tot(ng,1,ns), Xn_tot(ng,2,ns) - enddo - write(41,*) En_m_tot(ns), En_e_tot(ns) - enddo - write(42,*) nc - do ns = 1,Nsims - do nd = 1,Ndis - write(42,*) Xn_m_tot(nd,ns), Xn_e_tot(nd,ns) - enddo - enddo - close(41) - close(42) - ! Stop dump - -#ifdef MPI - !Collect En_m_tot(ns), En_e_tot(ns) - n1 = size(En_m_tot,1) - Allocate (Collect1(n1)) - n = n1 - - Collect1 = 0.d0 - call MPI_REDUCE(En_m_tot,Collect1,N,MPI_REAL8,MPI_SUM, 0,MPI_COMM_WORLD,IERR) - En_m_tot = Collect1/dble(Isize) - - Collect1 = 0.d0 - call MPI_REDUCE(En_e_tot,Collect1,N,MPI_REAL8,MPI_SUM, 0,MPI_COMM_WORLD,IERR) - En_e_tot = Collect1/dble(Isize) - - deallocate (Collect1) - - ! Collect Xn_m_tot(nd,ns), Xn_e_tot(nd,ns) - n1 = size(Xn_m_tot,1) - n2 = size(Xn_m_tot,2) - n = n1*n2 - allocate (Collect2(n1,n2)) - - Collect2 = 0.d0 - call MPI_REDUCE(Xn_m_tot,Collect2,N,MPI_REAL8,MPI_SUM, 0,MPI_COMM_WORLD,IERR) - Xn_m_tot = Collect2/dble(Isize) - - Collect2 = 0.d0 - call MPI_REDUCE(Xn_e_tot,Collect2,N,MPI_REAL8,MPI_SUM, 0,MPI_COMM_WORLD,IERR) - Xn_e_tot = Collect2/dble(Isize) - deallocate (Collect2) -#endif - - -#ifdef MPI - if (Irank == 0 ) then -#endif - - Open(Unit=66,File="energies",status="unknown") - do ns = 1,Nsims - En_m_tot(ns) = En_m_tot(ns) / dble(nc) - En_e_tot(ns) = En_e_tot(ns) / dble(nc) - En_e_tot(ns) = ( En_e_tot(ns) - En_m_tot(ns)**2)/dble(nc) - if ( En_e_tot(ns) .gt. 0.d0) then - En_e_tot(ns) = sqrt(En_e_tot(ns)) - else - En_e_tot(ns) = 0.d0 - endif - write(66,*) Alpha_tot(ns), En_m_tot(ns), En_e_tot(ns) - enddo - close(66) - - Open(Unit=66,File="moments",status="unknown") - do ns = 1,Nsims - do n = 1,Size(Mom_m_tot,1) - Mom_m_tot(n,ns) = Mom_m_tot(n,ns) / dble(nc1) - Mom_e_tot(n,ns) = Mom_e_tot(n,ns) / dble(nc1) - Mom_e_tot(n,ns) = ( Mom_e_tot(n,ns) - Mom_m_tot(n,ns)**2)/dble(nc1) - if ( Mom_e_tot(n,ns) .gt. 0.d0) then - Mom_e_tot(n,ns) = sqrt(Mom_e_tot(n,ns)) - else - Mom_e_tot(n,ns) = 0.d0 - endif - enddo - write(66,"(F12.6,2x,F12.6,2x,F12.6,2x,F12.6,2x,F12.6)") & - & Alpha_tot(ns), Mom_m_tot(1,ns), Mom_e_tot(1,ns), & - & Mom_m_tot(2,ns), Mom_e_tot(2,ns) - enddo - close(66) - - File_root = "Aom" - do ns = 1,Nsims - File1 = File_i(File_root,ns) - Open(Unit=66,File=File1,status="unknown") - do nd = 1,Ndis - Xn_m_tot(nd,ns) = Xn_m_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) - Xn_e_tot(nd,ns) = Xn_e_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) - Xn_e_tot(nd,ns) = (Xn_e_tot(nd,ns) - Xn_m_tot(nd,ns)* Xn_m_tot(nd,ns))/dble(nc) - if (Xn_e_tot(nd,ns).gt.0.d0) then - Xn_e_tot(nd,ns) = sqrt(Xn_e_tot(nd,ns)) - else - Xn_e_tot(nd,ns) = 0.d0 - endif - om = PhiM1(dble(nd)/dble(NDis)) - Aom = Xn_m_tot(nd,ns) * Xmom1 - Err = Xn_e_tot(nd,ns) * Xmom1 - write(66,2001) om, Back_Trans_Aom(Aom,Beta,om), Back_Trans_Aom(Err,Beta,om) - ! PhiM1(dble(nd)/dble(NDis)), Xn_m_tot(nd,ns) - enddo - Close(66) - enddo - - ! Now do the averaging. - File_root ="Aom_ps" - do p_star = 1,NSims - 10 - Xn_m = 0.0 - Xn_e = 0.0 - do ns = p_star, NSims-1 - do nd = 1, NDis - Xn_m(nd) = Xn_m(nd) + (En_m_tot(ns) - En_m_tot(ns+1))*Xn_m_tot(nd,ns) - Xn_e(nd) = Xn_e(nd) + (En_m_tot(ns) - En_m_tot(ns+1))*Xn_e_tot(nd,ns) - enddo - enddo - do nd = 1,NDis - Xn_m(nd) = Xn_m(nd) / (En_m_tot(p_star) - En_m_tot(NSims)) - Xn_e(nd) = Xn_e(nd) / (En_m_tot(p_star) - En_m_tot(NSims)) - enddo - File1 = File_i(File_root,p_star) - Open(Unit=66,File=File1,status="unknown") - XMAX = 0.d0 - Do nd = 1,Ndis - om = PhiM1(dble(nd)/dble(NDis)) - Aom = Xn_m(nd) * Xmom1 - Err = Xn_e(nd) * Xmom1 - Xn_m(nd) = Back_Trans_Aom(Aom,Beta,om) - Xn_e(nd) = Back_Trans_Aom(Err,Beta,om) - IF (Xn_m(nd) .gt. XMAX ) XMAX = Xn_m(nd) - enddo - do nd = 1,Ndis - om = PhiM1(dble(nd)/dble(NDis)) - write(66,2005) om, Xn_m(nd), Xn_e(nd), Xn_m(nd)/XMAX, Xn_e(nd)/XMAX - ! PhiM1(dble(nd)/dble(NDis)), Xn_m(nd) - enddo - close(66) - enddo - - Open (Unit=41,File='Best_fit', Status="unknown") - do ng = 1,Ngamma - Write(41,*) Phim1(Xn_tot(ng,1,Nsims)) , Xn_tot(ng,2,Nsims) - enddo - close(41) -#ifdef MPI - endif -#endif - - DeAllocate (Xn_tot) - DeAllocate (En_m_tot, En_e_tot, En_tot ) - DeAllocate (Xn_m_tot, Xn_e_tot ) - DeAllocate (Xn) - DeAllocate (Xn_m, Xn_e) - DeAllocate( G_Mean ) - DeAllocate( xqmc1 ) - Deallocate( Xker_table ) - - -2001 format(F14.7,2x,F14.7,2x,F14.7) -2004 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7) -2005 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7,2x,F14.7) -2003 format('Alpha, En_m, Acc ', F14.7,2x,F24.12,2x,F14.7,2x,F14.7,2x,F14.7) - end Subroutine MaxEnt_stoch - - -#ifdef MPI -#else -!------------------- - Subroutine MaxEnt_stoch_fit(XQMC, Xtau, COV, Lcov, XKER, Xmom1, Beta_1, Alpha_tot,& - & Ngamma_1, OM_ST, OM_EN, Nsweeps, NBins, NWarm, Aom_res,& - & xom_res, Chisq ) - - Implicit None - Real (Kind=8), Dimension(:) :: XQMC, Xtau, Alpha_tot, Aom_res, Xom_res - Real (Kind=8), Dimension(:,:) :: COV - Real (Kind=8), external :: XKER - Real (Kind=8) :: CHISQ, OM_ST, OM_EN, Beta_1, Xmom1, Err - Integer :: Nsweeps, NBins, Ngamma_1, Ndis_1, nw, nt1, Lcov - - ! Local - Integer lp, NSims, ns, nb, nc, Nwarm, nalp1, nalp2, Nex, p_star - Real (Kind=8), Allocatable :: Xn_M_tot(:,:), En_M_tot(:), Xn_E_tot(:,:), En_E_tot(:), & - & Xn_tot(:,:,:), En_tot(:), Xker_table(:,:) - Real (Kind=8), Allocatable :: G_Mean(:), Xn_m(:), Xn_e(:), Xn(:,:), Vhelp(:) - Real (Kind=8) :: Ranf, En_M, Res, X, Alpha, Acc_1, Acc_2, En, DeltaE, Ratio, D - Real (Kind=8) :: Aom, om, XMAX, tau - Real (Kind=8), allocatable :: U(:,:), sigma(:) - - - Pi = acos(-1.d0) - Iseed = 8752143 - NDis = Size(Aom_res,1) - DeltaXMAX = 0.01 - delta = 0.001 - delta2 = delta*delta - Ngamma = Ngamma_1 - Beta = Beta_1 ! Physical temperature for calculation of the kernel. - - Ntau = Size(xqmc,1) - NSims = Size(Alpha_tot,1) - Allocate (Xn_tot(Ngamma,2,NSims)) - Allocate (En_m_tot(NSims), En_e_tot(NSims), En_tot(NSims) ) - Allocate (Xn_m_tot(NDis,NSims), Xn_e_tot(NDis,NSims) ) - - Allocate (Xn(Ngamma,2)) - Allocate (Xn_m(NDis), Xn_e(NDis) ) - - Om_st_1 = OM_st; Om_en_1 = OM_en - - ! Setup table for the Kernel - Ndis = Size(Aom_res) - Dom = (OM_EN_1 - OM_ST_1)/dble(Ndis-1) - Allocate ( Xker_table(Ntau, Ndis) ) - Dom = (OM_EN - OM_ST)/dble(Ndis-1) - do nt = 1,Ntau - do nw = 1,Ndis - tau = xtau(nt) - Om = OM_st + dble(nw-1)*dom - Xker_table(nt,nw) = Xker(tau,om,beta) - enddo - enddo - - ! Normalize data to have zeroth moment of unity. - xqmc = xqmc / XMOM1 - cov = cov / ((XMOM1)**2) - ! Diagonalize the covariance - - If (Lcov.eq.1) then - Allocate( U(ntau,ntau), Sigma(ntau), xqmc1(Ntau) ) - Call Diag(cov,U,sigma) - do nt = 1,ntau - sigma(nt) = sqrt(sigma(nt)) - enddo - xqmc1 = 0.d0 - do nt1 = 1,ntau - do nt = 1,ntau - xqmc1(nt1) = xqmc1(nt1) + xqmc(nt)*U(nt,nt1) - enddo - xqmc1(nt1) = xqmc1(nt1)/sigma(nt1) - enddo - ! Transform the Kernel - allocate ( Vhelp(Ntau) ) - do nw = 1,Ndis - Vhelp = 0.d0 - do nt1 = 1,Ntau - do nt = 1,Ntau - Vhelp(nt1) = Vhelp(nt1) + Xker_table(nt,nw)*U(nt,nt1) - enddo - enddo - do nt1 = 1,ntau - Xker_table(nt1,nw) = Vhelp(nt1)/sigma(nt1) !! This has changed !! - enddo - enddo - Deallocate (U,sigma) - else - Allocate( Sigma(ntau), xqmc1(Ntau) ) - !Call Diag(cov,U,sigma) - do nt = 1,ntau - sigma(nt) = 1.d0/sqrt(cov(nt,nt)) - enddo - xqmc1 = 0.d0 - do nt1 = 1,ntau - xqmc1(nt1) = xqmc(nt1)*sigma(nt1) - enddo - ! Transform the Kernel - allocate ( Vhelp(Ntau) ) - do nw = 1,Ndis - do nt1 = 1,ntau - Xker_table(nt1,nw) = Xker_table(nt1,nw)*sigma(nt1) !! This has changed !! - enddo - enddo - deallocate(Sigma) - endif - Allocate(G_Mean(Ntau)) - G_mean = 0.d0 - -! write(6,*) ' There are ', Ngamma,' delta-functions for a spectrum' -! Write(6,*) ' Initializing' - Do Ns = 1,NSims - do ng = 1,NGamma - Xn_tot(ng,1,ns) = ranf(iseed) - Xn_tot(ng,2,ns) = 1.d0/dble(Ngamma) - enddo - enddo - Xn_m_tot = 0.d0 - En_m_tot = 0.d0 - Xn_e_tot = 0.d0 - En_e_tot = 0.d0 - ! D(om) = 1/(Om_en_1 - Om_st_1) - D = 1.d0 / (Om_en_1 - Om_st_1) - - Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") - Write(44,*) "N E W R U N " - nc = 0 - do Nb = 1,Nbins - do ns = 1,NSims - do ng = 1,Ngamma - Xn(ng,1) = Xn_tot(ng,1,ns) - Xn(ng,2) = Xn_tot(ng,2,ns) - enddo - Alpha = Alpha_tot(ns) - Call MC(Xtau, Xker_table, Xn, Alpha, NSweeps, Xn_m, En, En_m, & - & Acc_1, Acc_2 ) ! Just one bin - do ng = 1,Ngamma - Xn_tot(ng,1,ns) = Xn(ng,1) - Xn_tot(ng,2,ns) = Xn(ng,2) - enddo - En_tot(ns) = En ! this is the energy of the configuration Xn_tot for simulation ns - Write(44,2003) 1.d0/Alpha, En_m, Acc_1, Acc_2 - if (nb.gt.nwarm) then - if (ns.eq.1) nc = nc + 1 - do nd = 1,NDis - Xn_m(nd) = Xn_m(nd) * D * dble(Ndis) - Xn_m_tot(nd,ns) = Xn_m_tot(nd,ns) + Xn_m(nd) - Xn_e_tot(nd,ns) = Xn_e_tot(nd,ns) + Xn_m(nd)*Xn_m(nd) - enddo - En_m_tot(ns) = En_m_tot(ns) + En_m - En_e_tot(ns) = En_e_tot(ns) + En_m*En_m - endif - enddo - ! Exchange - Acc_1 = 0.d0 - Do Nex = 1, 2*NSims - nalp1= nint( ranf(iseed)*dble(NSims-1) + 0.5 ) ! 1..(NSims-1) - nalp2 = nalp1 + 1 - DeltaE = (Alpha_tot(nalp1)*En_tot(nalp2) + Alpha_tot(nalp2)*En_tot(nalp1))& - & -(Alpha_tot(nalp1)*En_tot(nalp1) + Alpha_tot(nalp2)*En_tot(nalp2)) - Ratio = exp(-DeltaE) - if (Ratio.gt.ranf(iseed)) Then - Acc_1 = Acc_1 + 1.0 - !Switch confs an Energies. - do ng = 1,Ngamma - Xn(ng,1) = Xn_tot(ng,1,nalp1) - Xn(ng,2) = Xn_tot(ng,2,nalp1) - enddo - do ng = 1,Ngamma - Xn_tot(ng,1,nalp1) = Xn_tot(ng,1,nalp2) - Xn_tot(ng,2,nalp1) = Xn_tot(ng,2,nalp2) - Xn_tot(ng,1,nalp2) = Xn(ng,1) - Xn_tot(ng,2,nalp2) = Xn(ng,2) - enddo - En_m = En_tot(nalp1) - En_tot(nalp1) = En_tot(nalp2) - En_tot(nalp2) = En_m - endif - enddo - Acc_1 = Acc_1/dble(Nex) - Write(44,*) 'Acc Exchange: ', Acc_1 - enddo - - !Open(Unit=66,File="energies",status="unknown") - do ns = Nsims,Nsims - En_m_tot(ns) = En_m_tot(ns) / dble(nc) - En_e_tot(ns) = En_e_tot(ns) / dble(nc) - En_e_tot(ns) = ( En_e_tot(ns) - En_m_tot(ns)**2)/dble(nc) - if ( En_e_tot(ns) .gt. 0.d0) then - En_e_tot(ns) = sqrt(En_e_tot(ns)) - else - En_e_tot(ns) = 0.d0 - endif - !write(66,*) Alpha_tot(ns), En_m_tot(ns), En_e_tot(ns) - enddo - !close(60) - Chisq = En_e_tot(Nsims) - Close(44) - - do ns = Nsims,Nsims - do nd = 1,Ndis - Xn_m_tot(nd,ns) = Xn_m_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) - Xn_e_tot(nd,ns) = Xn_e_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) - Xn_e_tot(nd,ns) = (Xn_e_tot(nd,ns) - Xn_m_tot(nd,ns)* Xn_m_tot(nd,ns))/dble(nc) - if (Xn_e_tot(nd,ns).gt.0.d0) then - Xn_e_tot(nd,ns) = sqrt(Xn_e_tot(nd,ns)) - else - Xn_e_tot(nd,ns) = 0.d0 - endif - om = PhiM1(dble(nd)/dble(NDis)) - Aom = Xn_m_tot(nd,ns) * Xmom1 - Err = Xn_e_tot(nd,ns) * Xmom1 - !write(66,2001) om, Aom, Err - if (ns.eq.Nsims) then - Aom_res(nd) = Aom - xom_res(nd) = om - endif - enddo - !Close(66) - enddo - - ! Reset the input data - xqmc = XMOM1* xqmc - cov = ((XMOM1)**2)* cov - - - DeAllocate (Xn_tot) - DeAllocate (En_m_tot, En_e_tot, En_tot ) - DeAllocate (Xn_m_tot, Xn_e_tot ) - DeAllocate (Xn) - DeAllocate (Xn_m, Xn_e) - DeAllocate( G_Mean ) - DeAllocate( xqmc1 ) - Deallocate( Xker_table ) - -2001 format(F14.7,2x,F14.7,2x,F14.7) -2004 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7) -2005 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7,2x,F14.7) -2003 format('Alpha, En_m, Acc ', F14.7,2x,F14.7,2x,F14.7,2x,F14.7,2x,F14.7) - end Subroutine MaxEnt_stoch_fit -#endif -!*********** - Real (Kind=8) Function Phim1(x) - Implicit None - ! Flat Default with sum 1. This is the correct sum rule for the data! - ! D(om) = 1/(Om_en_1 - Om_st_1) - Real (Kind=8) :: x - PhiM1 = x*(Om_en_1 - Om_st_1) + Om_st_1 - end Function Phim1 - - - Integer Function NPhim1(x) - Implicit None - - ! Flat Default with sum 1. This is the correct sum rule for the data! - ! D(om) = 1/(Om_en_1 - Om_st_1) - - Real (Kind=8) :: x, om - om = x*(Om_en_1 - Om_st_1) + Om_st_1 - NPhiM1 = Nint ( (om - Om_st_1)/Dom + 0.75 ) - - end Function NPhim1 - - -!*********** - Subroutine Sum_Xn(Xn_m,Xn) - - Implicit none - Real (Kind=8), Dimension(:,:) :: Xn - Real (Kind=8), Dimension(:) :: Xn_m - Real (Kind=8) :: X - - - do nd = 1,NDis - X = dble( nd )/dble( NDis ) - do ng = 1,Ngamma - Xn_m(nd) = Xn_m(nd) + Xn(ng,2)/( (X-Xn(ng,1))**2 + Delta2) - !aimag( cmplx(Xn(ng,2),0.d0)/cmplx( X-Xn(ng,1), -Delta) ) - enddo - enddo - - end Subroutine Sum_Xn - -!*********** - Subroutine Sum_Xn_Boxes(Xn_m,Xn) - - Implicit none - Real (Kind=8), Dimension(:,:) :: Xn - Real (Kind=8), Dimension(:) :: Xn_m - Real (Kind=8) :: X - - - do ng = 1,Ngamma - X = Xn(ng,1) - nd = Nint(dble(NDis)*X + 0.5 ) - Xn_m(nd) = Xn_m(nd) + Xn(ng,2) - Enddo - - end Subroutine Sum_Xn_Boxes - - -!*********** - Subroutine MC(Xtau, Xker_table, Xn, Alpha, NSweeps, Xn_m, En, En_m, Acc_1,Acc_2) - - !Implicit Real (KIND=8) (A-G,O-Z) - !Implicit Integer (H-N) - Implicit None - - Real (Kind=8), Dimension(:,:) :: Xn, Xker_table - Real (Kind=8), Dimension(:) :: Xtau, Xn_m - Real (Kind=8) :: Alpha, En_m, s, ratio, ranf, A_gamma, Z_gamma, Acc_1, Acc_2 - Integer :: NSweeps, nl, Lambda_max, ng1, ng2 - - !Local - Real (Kind=8), Allocatable :: h(:), Deltah(:), A_gamma_p(:), Z_gamma_p(:), & - & A_gamma_o(:), Z_gamma_o(:) - - Real (Kind=8), Allocatable :: XKER_stor(:,:), XKER_new(:) - - Real (Kind=8) :: X, En, En1, DeltaE, XP, XM, om - Integer, Allocatable :: Lambda(:) - Integer :: nb, nsw, Nacc_1, Nacc_2, nw - - Allocate (h(ntau), Deltah(ntau) ) - Allocate (Lambda(2), Z_gamma_p(2), A_gamma_p(2), & - & Z_gamma_o(2), A_gamma_o(2) ) ! Max of moves of two walkers. - - Allocate ( XKer_stor(Ntau,Ngamma), XKer_New(Ntau) ) - - Xn_m = 0.d0 - En_m = 0.d0 - - - ! Setup h(tau) - do nt = 1,Ntau - X = 0.d0 - do ng = 1,Ngamma - A_gamma = xn(ng,1) - Z_gamma = xn(ng,2) - XKer_stor( nt, ng ) = XKER_table(nt, NPhiM1(A_gamma) ) - ! XKER(xtau(nt),PhiM1(A_gamma),beta) - X = X + Xker_stor(nt,ng)*Z_gamma - enddo - h(nt) = X - xqmc1(nt) - enddo - - - NAcc_1 = 0; NAcc_2 = 0; - do nsw = 1,Nsweeps - ! Weight sharing moves. - do ng = 1,Ngamma - x = ranf(iseed) - if (x.gt.0.5) then - ! Weight sharing moves. - Lambda_max = 2 - Lambda(1) = nint(ranf(iseed)*dble(Ngamma) + 0.5) - do - Lambda(2) = nint(ranf(iseed)*dble(Ngamma) + 0.5) - if ( Lambda(2) .ne. Lambda(1) ) exit - enddo - ng1 = Lambda(1) - ng2 = Lambda(2) - - A_gamma_o(1) = Xn(ng1,1) - A_gamma_o(2) = Xn(ng2,1) - Z_gamma_o(1) = Xn(ng1,2) - Z_gamma_o(2) = Xn(ng2,2) - - A_gamma_p(1) = Xn(ng1,1) - A_gamma_p(2) = Xn(ng2,1) - - s = (Z_gamma_o(1) + Z_gamma_o(2))*ranf(iseed) - Z_gamma_o(1) - Z_gamma_p(1) = Z_gamma_o(1) + s - Z_gamma_p(2) = Z_gamma_o(2) - s - - ! Kernel stays unchanged. - - ! Compute Delta H - do nt = 1,ntau - X = Xker_stor(nt,ng1)*( Z_gamma_p(1) - Z_gamma_o(1) ) + & - & Xker_stor(nt,ng2)*( Z_gamma_p(2) - Z_gamma_o(2) ) - Deltah(nt) = X - enddo - else - Lambda_max = 1 - Lambda(1) = nint(ranf(iseed)*dble(Ngamma) + 0.5) - ng1 = Lambda(1) - Z_gamma_o(1) = Xn(ng1,2) - Z_gamma_p(1) = Xn(ng1,2) - - A_gamma_o(1) = Xn(ng1,1) - A_gamma_p(1) = xpbc( Xn(ng1,1) + (ranf(iseed) - 0.5)*DeltaXMAX, 1.d0 ) - - !om = PhiM1(A_gamma_p(1)) - nw = NPhiM1(A_gamma_p(1)) - do nt = 1,ntau - Xker_new(nt) = Xker_table(nt,nw) ! Xker(xtau(nt),om, beta) - enddo - - do nt = 1,ntau - X = ( Xker_new(nt) - Xker_stor(nt,ng1) ) * Z_gamma_o(1) - Deltah(nt) = X - enddo - endif - - - DeltaE = 0.d0 - do nt = 1,ntau - DeltaE = DeltaE + (Deltah(nt) + 2.0 * h(nt) ) *Deltah(nt) - enddo - Ratio = exp( -alpha * DeltaE ) - ! write(6,*) ' Ratio : ',Ratio, DeltaE - if (Ratio .gt. ranf(iseed)) Then - ! write(6,*) 'Accepted' - if (Lambda_max.eq.1) then - Nacc_1 = Nacc_1 + 1 - ng1 = Lambda(1) - do nt = 1,ntau - Xker_stor(nt,ng1) = Xker_new(nt) - enddo - endif - if (Lambda_max.eq.2) Nacc_2 = Nacc_2 + 1 - do nl = 1,Lambda_max - Xn(Lambda(nl),1) = A_gamma_p(nl) - Xn(Lambda(nl),2) = Z_gamma_p(nl) - enddo - do nt = 1,ntau - h(nt) = h(nt) + Deltah(nt) - enddo - endif - enddo - En = 0.0 - do nt = 1,Ntau - En = En + h(nt)*h(nt) - enddo - En_m = En_m + En - Call Sum_Xn_Boxes( Xn_m, Xn ) - enddo - Acc_1 = dble(Nacc_1)/dble(Ngamma*NSweeps) - Acc_2 = dble(Nacc_2)/dble(Ngamma*NSweeps) - En_m = En_m/dble( nsweeps ) - Xn_m = Xn_m/dble( nsweeps ) - - - Deallocate ( h, Deltah ) - Deallocate ( Lambda, Z_gamma_p, A_gamma_p, Z_gamma_o, A_gamma_o ) - Deallocate ( XKER_stor, XKER_new ) - -2005 format(I4,2x,I4,2x,F14.7,2x,F14.7,' --> ',F14.7,2x,F14.7) -2006 format(I4,2x,F14.7, ' --> ',F14.7) - end Subroutine MC - - - -!********** - real (Kind=8) function xpbc(X,XL) - real (kind=8) :: X, XL - XPBC = X - if (X.GT. XL ) XPBC = X - XL - if (X.LT. 0.0) XPBC = X + XL - end function xpbc - - -#ifdef MPI -end Module MaxEnt_stoch_mod_MPI -#else -end Module MaxEnt_stoch_mod -#endif diff --git a/Libraries/Modules/maxent_stoch.f90 b/Libraries/Modules/maxent_stoch.f90 deleted file mode 100644 index 418d544e6..000000000 --- a/Libraries/Modules/maxent_stoch.f90 +++ /dev/null @@ -1,748 +0,0 @@ -Module MaxEnt_stoch_mod - Use MyMats - Use Files_mod - Integer, private :: NTAU, nt, Ngamma, ng, Ndis, nd, Iseed - Real (Kind=8), private :: Delta, Delta2, OM_st_1, Om_en_1, DeltaXMAX, Beta, Pi, Dom - Real (Kind=8), allocatable, private :: XQMC1(:) - ! You can still optimize a bit for by redefining the Kernel table to: - ! xker_table(nt,nw) -> xker_table(nt,nw) / sigma(nt) - ! This will save quite a lot of divisions in the - ! MC routine. And this is where all the time goes now. - CONTAINS - Subroutine MaxEnt_stoch(XQMC, Xtau, COV,Xmom1, XKER, Back_Trans_Aom, Beta_1, Alpha_tot,& - & Ngamma_1, OM_ST, OM_EN, Ndis_1, Nsweeps, NBins, NWarm, L_cov) - Implicit None - Real (Kind=8), Dimension(:) :: XQMC, Xtau, Alpha_tot - Real (Kind=8), Dimension(:,:) :: COV - Real (Kind=8), External :: XKER, Back_trans_Aom - Real (Kind=8) :: CHISQ, OM_ST, OM_EN, Beta_1, Xmom1, Err - Integer :: Nsweeps, NBins, Ngamma_1, Ndis_1, nw, nt1 - Integer, optional :: L_cov - ! Local - Integer lp, NSims, ns, nb, nc, Nwarm, nalp1, nalp2, Nex, p_star, Ndis_table, & - & io_error, io_error1, i, n, nc1 - Real (Kind=8), Allocatable :: Xn_M_tot(:,:), En_M_tot(:), Xn_E_tot(:,:), En_E_tot(:), & - & Xn_tot(:,:,:), En_tot(:) - Real (Kind=8), Allocatable :: G_Mean(:), Xn_m(:), Xn_e(:), Xn(:,:), Vhelp(:) - Real (Kind=8) :: Ranf, En_M, Res, X, Alpha, Acc_1, Acc_2, En, DeltaE, Ratio, D - Real (Kind=8) :: Aom, om, XMAX, tau - Real (Kind=8) :: CPUT, CPUTM - Integer :: ICPU_1, ICPU_2, N_P_SEC - Character (64) :: File_root, File1, File_conf, File_Aom - Real (Kind=8), allocatable :: Xker_table(:,:), U(:,:), sigma(:) - ! Space for moments. - Real (Kind=8), allocatable:: Mom_M_tot(:,:), Mom_E_tot(:,:) - Pi = acos(-1.d0) - NDis = Ndis_1 - DeltaXMAX = 0.01 - delta = 0.001 - delta2 = delta*delta - Ngamma = Ngamma_1 - Beta = Beta_1 ! Physical temperature for calculation of the kernel. - Ntau = Size(xqmc,1) - NSims = Size(Alpha_tot,1) - Allocate (Xn_tot(Ngamma,2,NSims)) - Allocate (En_m_tot(NSims), En_e_tot(NSims), En_tot(NSims) ) - Allocate (Xn_m_tot(NDis,NSims), Xn_e_tot(NDis,NSims) ) - Allocate (Mom_M_tot(2,Nsims), Mom_E_tot(2,Nsims) ) - Allocate (Xn(Ngamma,2)) - Allocate (Xn_m(NDis), Xn_e(NDis) ) - Om_st_1 = OM_st; Om_en_1 = OM_en - ! Setup table for the Kernel - Ndis_table = 50000 - Dom = (OM_EN_1 - OM_ST_1)/dble(Ndis_table-1) - Allocate ( Xker_table(Ntau, Ndis_table) ) - do nt = 1,Ntau - do nw = 1,Ndis_table - tau = xtau(nt) - Om = OM_st + dble(nw-1)*dom - Xker_table(nt,nw) = Xker(tau,om,beta) - enddo - enddo - ! Normalize data to have zeroth moment of unity. - xqmc = xqmc / XMOM1 - cov = cov / ((XMOM1)**2) - ! Diagonalize the covariance - Allocate( U(ntau,ntau), Sigma(ntau), xqmc1(Ntau) ) - If ( Present(L_cov) ) then - Call Diag(cov,U,sigma) - ! Write(6,*) " Cov Used" - else - Write(6,*) "No Cov Used" - U = 0.d0 - do nt = 1,ntau - U(nt,nt) = 1.d0 - sigma(nt) = cov(nt,nt) - enddo - endif - do nt = 1,ntau - sigma(nt) = sqrt(sigma(nt)) - enddo - xqmc1 = 0.d0 - do nt1 = 1,ntau - do nt = 1,ntau - xqmc1(nt1) = xqmc1(nt1) + xqmc(nt)*U(nt,nt1) - enddo - xqmc1(nt1) = xqmc1(nt1)/sigma(nt1) - enddo - ! Transform the Kernel - allocate ( Vhelp(Ntau) ) - do nw = 1,Ndis_table - Vhelp = 0.d0 - do nt1 = 1,Ntau - do nt = 1,Ntau - Vhelp(nt1) = Vhelp(nt1) + Xker_table(nt,nw)*U(nt,nt1) - enddo - enddo - do nt1 = 1,ntau - Xker_table(nt1,nw) = Vhelp(nt1)/sigma(nt1) !! This has changed !! - enddo - enddo - deallocate( U, Sigma ) - Allocate ( G_Mean(Ntau) ) - G_mean = 0.d0 -! write(6,*) ' There are ', Ngamma,' delta-functions for a spectrum' -! Write(6,*) ' Initializing' - ! D(om) = 1/(Om_en_1 - Om_st_1) - D = 1.d0 / (Om_en_1 - Om_st_1) - Iseed = 8752143 - File_conf = "dump_conf" - File_Aom = "dump_Aom" - Open(unit=41,file=File_conf,status='old',action='read', iostat=io_error) - Open(unit=42,file=File_Aom, status='old',action='read', iostat=io_error1) - If (io_error == 0 .and. io_error1 == 0 ) then - Nwarm = 0 - read(41,*) Iseed - do ns = 1,Nsims - do ng = 1,Ngamma - read(41,*) Xn_tot(ng,1,ns), Xn_tot(ng,2,ns) - enddo - read(41,*) En_m_tot(ns), En_e_tot(ns) - enddo - read(42,*) nc - do ns = 1,Nsims - do nd = 1,Ndis - read(42,*) Xn_m_tot(nd,ns), Xn_e_tot(nd,ns) - enddo - enddo - Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") - Write(44,*) 'Read from dump: nc = ', nc - close(44) - else - !Iseed is alrady set. - Do Ns = 1,NSims - do ng = 1,NGamma - Xn_tot(ng,1,ns) = ranf(iseed) - Xn_tot(ng,2,ns) = 1.d0/dble(Ngamma) - enddo - enddo - Xn_m_tot = 0.d0 - En_m_tot = 0.d0 - Xn_e_tot = 0.d0 - En_e_tot = 0.d0 - nc = 0 - Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") - Write(44,*) ' No dump data ' - close(44) - endif - close(41) - close(42) - nc1 = 0 - Mom_M_tot = 0.d0 - Mom_E_tot = 0.d0 - CALL SYSTEM_CLOCK(COUNT_RATE=N_P_SEC) - CALL SYSTEM_CLOCK(COUNT=ICPU_1) - ! Start Simulations. - do Nb = 1,Nbins - do ns = 1,NSims - do ng = 1,Ngamma - Xn(ng,1) = Xn_tot(ng,1,ns) - Xn(ng,2) = Xn_tot(ng,2,ns) - enddo - Alpha = Alpha_tot(ns) - Call MC(Xtau, Xker_table, Xn, Alpha, NSweeps, Xn_m, En, En_m, & - & Acc_1, Acc_2 ) ! Just one bin - do ng = 1,Ngamma - Xn_tot(ng,1,ns) = Xn(ng,1) - Xn_tot(ng,2,ns) = Xn(ng,2) - enddo - En_tot(ns) = En ! this is the energy of the configuration Xn_tot for simulation ns - Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") - Write(44,2003) 1.d0/Alpha, En_m, Acc_1, Acc_2 - close(44) - if (nb.gt.nwarm) then - if (ns.eq.1) nc = nc + 1 - do nd = 1,NDis - Xn_m(nd) = Xn_m(nd) * D * dble(Ndis) - Xn_m_tot(nd,ns) = Xn_m_tot(nd,ns) + Xn_m(nd) - Xn_e_tot(nd,ns) = Xn_e_tot(nd,ns) + Xn_m(nd)*Xn_m(nd) - enddo - En_m_tot(ns) = En_m_tot(ns) + En_m - En_e_tot(ns) = En_e_tot(ns) + En_m*En_m - ! Compute moments - if (ns.eq.1) nc1 = nc1 + 1 - do n = 1,Size(Mom_M_tot,1) - x = 0.d0 - do ng = 1,Ngamma - X = X + ( Phim1(Xn_tot(ng,1,ns))**(n-1) ) * Xn_tot(ng,2,Ns) - enddo - Mom_M_tot(n,ns) = Mom_M_tot(n,ns) + X - Mom_E_tot(n,ns) = Mom_E_tot(n,ns) + X*X - enddo - endif - enddo - ! Exchange - Acc_1 = 0.d0 - Do Nex = 1, 2*NSims - nalp1= nint( ranf(iseed)*dble(NSims-1) + 0.5 ) ! 1..(NSims-1) - nalp2 = nalp1 + 1 - DeltaE = (Alpha_tot(nalp1)*En_tot(nalp2) + Alpha_tot(nalp2)*En_tot(nalp1))& - & -(Alpha_tot(nalp1)*En_tot(nalp1) + Alpha_tot(nalp2)*En_tot(nalp2)) - Ratio = exp(-DeltaE) - if (Ratio.gt.ranf(iseed)) Then - Acc_1 = Acc_1 + 1.0 - !Switch confs an Energies. - do ng = 1,Ngamma - Xn(ng,1) = Xn_tot(ng,1,nalp1) - Xn(ng,2) = Xn_tot(ng,2,nalp1) - enddo - do ng = 1,Ngamma - Xn_tot(ng,1,nalp1) = Xn_tot(ng,1,nalp2) - Xn_tot(ng,2,nalp1) = Xn_tot(ng,2,nalp2) - Xn_tot(ng,1,nalp2) = Xn(ng,1) - Xn_tot(ng,2,nalp2) = Xn(ng,2) - enddo - En_m = En_tot(nalp1) - En_tot(nalp1) = En_tot(nalp2) - En_tot(nalp2) = En_m - endif - enddo - Acc_1 = Acc_1/dble(Nex) - Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") - Write(44,*) 'Acc Exchange: ', Acc_1 - close(44) - enddo - CALL SYSTEM_CLOCK(COUNT=ICPU_2) - CPUT = 0.D0 - CPUT = DBLE(ICPU_2 - ICPU_1)/DBLE(N_P_SEC) - Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") - Write(44,*) 'Total time: ', CPUT - close(44) - ! dump so as to restart. - Open(unit=41,file=File_conf,status='unknown') - Open(unit=42,file=File_Aom, status='unknown') - write(41,*) Iseed - do ns = 1,Nsims - do ng = 1,Ngamma - write(41,*) Xn_tot(ng,1,ns), Xn_tot(ng,2,ns) - enddo - write(41,*) En_m_tot(ns), En_e_tot(ns) - enddo - write(42,*) nc - do ns = 1,Nsims - do nd = 1,Ndis - write(42,*) Xn_m_tot(nd,ns), Xn_e_tot(nd,ns) - enddo - enddo - close(41) - close(42) - ! Stop dump - Open(Unit=66,File="energies",status="unknown") - do ns = 1,Nsims - En_m_tot(ns) = En_m_tot(ns) / dble(nc) - En_e_tot(ns) = En_e_tot(ns) / dble(nc) - En_e_tot(ns) = ( En_e_tot(ns) - En_m_tot(ns)**2)/dble(nc) - if ( En_e_tot(ns) .gt. 0.d0) then - En_e_tot(ns) = sqrt(En_e_tot(ns)) - else - En_e_tot(ns) = 0.d0 - endif - write(66,*) Alpha_tot(ns), En_m_tot(ns), En_e_tot(ns) - enddo - close(66) - Open(Unit=66,File="moments",status="unknown") - do ns = 1,Nsims - do n = 1,Size(Mom_m_tot,1) - Mom_m_tot(n,ns) = Mom_m_tot(n,ns) / dble(nc1) - Mom_e_tot(n,ns) = Mom_e_tot(n,ns) / dble(nc1) - Mom_e_tot(n,ns) = ( Mom_e_tot(n,ns) - Mom_m_tot(n,ns)**2)/dble(nc1) - if ( Mom_e_tot(n,ns) .gt. 0.d0) then - Mom_e_tot(n,ns) = sqrt(Mom_e_tot(n,ns)) - else - Mom_e_tot(n,ns) = 0.d0 - endif - enddo - write(66,"(F12.6,2x,F12.6,2x,F12.6,2x,F12.6,2x,F12.6)") & - & Alpha_tot(ns), Mom_m_tot(1,ns), Mom_e_tot(1,ns), & - & Mom_m_tot(2,ns), Mom_e_tot(2,ns) - enddo - close(66) - File_root = "Aom" - do ns = 1,Nsims - File1 = File_i(File_root,ns) - Open(Unit=66,File=File1,status="unknown") - do nd = 1,Ndis - Xn_m_tot(nd,ns) = Xn_m_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) - Xn_e_tot(nd,ns) = Xn_e_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) - Xn_e_tot(nd,ns) = (Xn_e_tot(nd,ns) - Xn_m_tot(nd,ns)* Xn_m_tot(nd,ns))/dble(nc) - if (Xn_e_tot(nd,ns).gt.0.d0) then - Xn_e_tot(nd,ns) = sqrt(Xn_e_tot(nd,ns)) - else - Xn_e_tot(nd,ns) = 0.d0 - endif - om = PhiM1(dble(nd)/dble(NDis)) - Aom = Xn_m_tot(nd,ns) * Xmom1 - Err = Xn_e_tot(nd,ns) * Xmom1 - write(66,2001) om, Back_Trans_Aom(Aom,Beta,om), Back_Trans_Aom(Err,Beta,om) - ! PhiM1(dble(nd)/dble(NDis)), Xn_m_tot(nd,ns) - enddo - Close(66) - enddo - ! Now do the averaging. - File_root ="Aom_ps" - do p_star = 1,NSims - 10 - Xn_m = 0.0 - Xn_e = 0.0 - do ns = p_star, NSims-1 - do nd = 1, NDis - Xn_m(nd) = Xn_m(nd) + (En_m_tot(ns) - En_m_tot(ns+1))*Xn_m_tot(nd,ns) - Xn_e(nd) = Xn_e(nd) + (En_m_tot(ns) - En_m_tot(ns+1))*Xn_e_tot(nd,ns) - enddo - enddo - do nd = 1,NDis - Xn_m(nd) = Xn_m(nd) / (En_m_tot(p_star) - En_m_tot(NSims)) - Xn_e(nd) = Xn_e(nd) / (En_m_tot(p_star) - En_m_tot(NSims)) - enddo - File1 = File_i(File_root,p_star) - Open(Unit=66,File=File1,status="unknown") - XMAX = 0.d0 - Do nd = 1,Ndis - om = PhiM1(dble(nd)/dble(NDis)) - Aom = Xn_m(nd) * Xmom1 - Err = Xn_e(nd) * Xmom1 - Xn_m(nd) = Back_Trans_Aom(Aom,Beta,om) - Xn_e(nd) = Back_Trans_Aom(Err,Beta,om) - IF (Xn_m(nd) .gt. XMAX ) XMAX = Xn_m(nd) - enddo - do nd = 1,Ndis - om = PhiM1(dble(nd)/dble(NDis)) - write(66,2005) om, Xn_m(nd), Xn_e(nd), Xn_m(nd)/XMAX, Xn_e(nd)/XMAX - ! PhiM1(dble(nd)/dble(NDis)), Xn_m(nd) - enddo - close(66) - enddo - Open (Unit=41,File='Best_fit', Status="unknown") - do ng = 1,Ngamma - Write(41,*) Phim1(Xn_tot(ng,1,Nsims)) , Xn_tot(ng,2,Nsims) - enddo - close(41) - DeAllocate (Xn_tot) - DeAllocate (En_m_tot, En_e_tot, En_tot ) - DeAllocate (Xn_m_tot, Xn_e_tot ) - DeAllocate (Xn) - DeAllocate (Xn_m, Xn_e) - DeAllocate( G_Mean ) - DeAllocate( xqmc1 ) - Deallocate( Xker_table ) -2001 format(F14.7,2x,F14.7,2x,F14.7) -2004 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7) -2005 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7,2x,F14.7) -2003 format('Alpha, En_m, Acc ', F14.7,2x,F24.12,2x,F14.7,2x,F14.7,2x,F14.7) - end Subroutine MaxEnt_stoch -!------------------- - Subroutine MaxEnt_stoch_fit(XQMC, Xtau, COV, Lcov, XKER, Xmom1, Beta_1, Alpha_tot,& - & Ngamma_1, OM_ST, OM_EN, Nsweeps, NBins, NWarm, Aom_res,& - & xom_res, Chisq ) - Implicit None - Real (Kind=8), Dimension(:) :: XQMC, Xtau, Alpha_tot, Aom_res, Xom_res - Real (Kind=8), Dimension(:,:) :: COV - Real (Kind=8), external :: XKER - Real (Kind=8) :: CHISQ, OM_ST, OM_EN, Beta_1, Xmom1, Err - Integer :: Nsweeps, NBins, Ngamma_1, Ndis_1, nw, nt1, Lcov - ! Local - Integer lp, NSims, ns, nb, nc, Nwarm, nalp1, nalp2, Nex, p_star - Real (Kind=8), Allocatable :: Xn_M_tot(:,:), En_M_tot(:), Xn_E_tot(:,:), En_E_tot(:), & - & Xn_tot(:,:,:), En_tot(:), Xker_table(:,:) - Real (Kind=8), Allocatable :: G_Mean(:), Xn_m(:), Xn_e(:), Xn(:,:), Vhelp(:) - Real (Kind=8) :: Ranf, En_M, Res, X, Alpha, Acc_1, Acc_2, En, DeltaE, Ratio, D - Real (Kind=8) :: Aom, om, XMAX, tau - Real (Kind=8), allocatable :: U(:,:), sigma(:) - Pi = acos(-1.d0) - Iseed = 8752143 - NDis = Size(Aom_res,1) - DeltaXMAX = 0.01 - delta = 0.001 - delta2 = delta*delta - Ngamma = Ngamma_1 - Beta = Beta_1 ! Physical temperature for calculation of the kernel. - Ntau = Size(xqmc,1) - NSims = Size(Alpha_tot,1) - Allocate (Xn_tot(Ngamma,2,NSims)) - Allocate (En_m_tot(NSims), En_e_tot(NSims), En_tot(NSims) ) - Allocate (Xn_m_tot(NDis,NSims), Xn_e_tot(NDis,NSims) ) - Allocate (Xn(Ngamma,2)) - Allocate (Xn_m(NDis), Xn_e(NDis) ) - Om_st_1 = OM_st; Om_en_1 = OM_en - ! Setup table for the Kernel - Ndis = Size(Aom_res) - Dom = (OM_EN_1 - OM_ST_1)/dble(Ndis-1) - Allocate ( Xker_table(Ntau, Ndis) ) - Dom = (OM_EN - OM_ST)/dble(Ndis-1) - do nt = 1,Ntau - do nw = 1,Ndis - tau = xtau(nt) - Om = OM_st + dble(nw-1)*dom - Xker_table(nt,nw) = Xker(tau,om,beta) - enddo - enddo - ! Normalize data to have zeroth moment of unity. - xqmc = xqmc / XMOM1 - cov = cov / ((XMOM1)**2) - ! Diagonalize the covariance - If (Lcov.eq.1) then - Allocate( U(ntau,ntau), Sigma(ntau), xqmc1(Ntau) ) - Call Diag(cov,U,sigma) - do nt = 1,ntau - sigma(nt) = sqrt(sigma(nt)) - enddo - xqmc1 = 0.d0 - do nt1 = 1,ntau - do nt = 1,ntau - xqmc1(nt1) = xqmc1(nt1) + xqmc(nt)*U(nt,nt1) - enddo - xqmc1(nt1) = xqmc1(nt1)/sigma(nt1) - enddo - ! Transform the Kernel - allocate ( Vhelp(Ntau) ) - do nw = 1,Ndis - Vhelp = 0.d0 - do nt1 = 1,Ntau - do nt = 1,Ntau - Vhelp(nt1) = Vhelp(nt1) + Xker_table(nt,nw)*U(nt,nt1) - enddo - enddo - do nt1 = 1,ntau - Xker_table(nt1,nw) = Vhelp(nt1)/sigma(nt1) !! This has changed !! - enddo - enddo - Deallocate (U,sigma) - else - Allocate( Sigma(ntau), xqmc1(Ntau) ) - !Call Diag(cov,U,sigma) - do nt = 1,ntau - sigma(nt) = 1.d0/sqrt(cov(nt,nt)) - enddo - xqmc1 = 0.d0 - do nt1 = 1,ntau - xqmc1(nt1) = xqmc(nt1)*sigma(nt1) - enddo - ! Transform the Kernel - allocate ( Vhelp(Ntau) ) - do nw = 1,Ndis - do nt1 = 1,ntau - Xker_table(nt1,nw) = Xker_table(nt1,nw)*sigma(nt1) !! This has changed !! - enddo - enddo - deallocate(Sigma) - endif - Allocate(G_Mean(Ntau)) - G_mean = 0.d0 -! write(6,*) ' There are ', Ngamma,' delta-functions for a spectrum' -! Write(6,*) ' Initializing' - Do Ns = 1,NSims - do ng = 1,NGamma - Xn_tot(ng,1,ns) = ranf(iseed) - Xn_tot(ng,2,ns) = 1.d0/dble(Ngamma) - enddo - enddo - Xn_m_tot = 0.d0 - En_m_tot = 0.d0 - Xn_e_tot = 0.d0 - En_e_tot = 0.d0 - ! D(om) = 1/(Om_en_1 - Om_st_1) - D = 1.d0 / (Om_en_1 - Om_st_1) - Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") - Write(44,*) "N E W R U N " - nc = 0 - do Nb = 1,Nbins - do ns = 1,NSims - do ng = 1,Ngamma - Xn(ng,1) = Xn_tot(ng,1,ns) - Xn(ng,2) = Xn_tot(ng,2,ns) - enddo - Alpha = Alpha_tot(ns) - Call MC(Xtau, Xker_table, Xn, Alpha, NSweeps, Xn_m, En, En_m, & - & Acc_1, Acc_2 ) ! Just one bin - do ng = 1,Ngamma - Xn_tot(ng,1,ns) = Xn(ng,1) - Xn_tot(ng,2,ns) = Xn(ng,2) - enddo - En_tot(ns) = En ! this is the energy of the configuration Xn_tot for simulation ns - Write(44,2003) 1.d0/Alpha, En_m, Acc_1, Acc_2 - if (nb.gt.nwarm) then - if (ns.eq.1) nc = nc + 1 - do nd = 1,NDis - Xn_m(nd) = Xn_m(nd) * D * dble(Ndis) - Xn_m_tot(nd,ns) = Xn_m_tot(nd,ns) + Xn_m(nd) - Xn_e_tot(nd,ns) = Xn_e_tot(nd,ns) + Xn_m(nd)*Xn_m(nd) - enddo - En_m_tot(ns) = En_m_tot(ns) + En_m - En_e_tot(ns) = En_e_tot(ns) + En_m*En_m - endif - enddo - ! Exchange - Acc_1 = 0.d0 - Do Nex = 1, 2*NSims - nalp1= nint( ranf(iseed)*dble(NSims-1) + 0.5 ) ! 1..(NSims-1) - nalp2 = nalp1 + 1 - DeltaE = (Alpha_tot(nalp1)*En_tot(nalp2) + Alpha_tot(nalp2)*En_tot(nalp1))& - & -(Alpha_tot(nalp1)*En_tot(nalp1) + Alpha_tot(nalp2)*En_tot(nalp2)) - Ratio = exp(-DeltaE) - if (Ratio.gt.ranf(iseed)) Then - Acc_1 = Acc_1 + 1.0 - !Switch confs an Energies. - do ng = 1,Ngamma - Xn(ng,1) = Xn_tot(ng,1,nalp1) - Xn(ng,2) = Xn_tot(ng,2,nalp1) - enddo - do ng = 1,Ngamma - Xn_tot(ng,1,nalp1) = Xn_tot(ng,1,nalp2) - Xn_tot(ng,2,nalp1) = Xn_tot(ng,2,nalp2) - Xn_tot(ng,1,nalp2) = Xn(ng,1) - Xn_tot(ng,2,nalp2) = Xn(ng,2) - enddo - En_m = En_tot(nalp1) - En_tot(nalp1) = En_tot(nalp2) - En_tot(nalp2) = En_m - endif - enddo - Acc_1 = Acc_1/dble(Nex) - Write(44,*) 'Acc Exchange: ', Acc_1 - enddo - !Open(Unit=66,File="energies",status="unknown") - do ns = Nsims,Nsims - En_m_tot(ns) = En_m_tot(ns) / dble(nc) - En_e_tot(ns) = En_e_tot(ns) / dble(nc) - En_e_tot(ns) = ( En_e_tot(ns) - En_m_tot(ns)**2)/dble(nc) - if ( En_e_tot(ns) .gt. 0.d0) then - En_e_tot(ns) = sqrt(En_e_tot(ns)) - else - En_e_tot(ns) = 0.d0 - endif - !write(66,*) Alpha_tot(ns), En_m_tot(ns), En_e_tot(ns) - enddo - !close(60) - Chisq = En_e_tot(Nsims) - Close(44) - do ns = Nsims,Nsims - do nd = 1,Ndis - Xn_m_tot(nd,ns) = Xn_m_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) - Xn_e_tot(nd,ns) = Xn_e_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) - Xn_e_tot(nd,ns) = (Xn_e_tot(nd,ns) - Xn_m_tot(nd,ns)* Xn_m_tot(nd,ns))/dble(nc) - if (Xn_e_tot(nd,ns).gt.0.d0) then - Xn_e_tot(nd,ns) = sqrt(Xn_e_tot(nd,ns)) - else - Xn_e_tot(nd,ns) = 0.d0 - endif - om = PhiM1(dble(nd)/dble(NDis)) - Aom = Xn_m_tot(nd,ns) * Xmom1 - Err = Xn_e_tot(nd,ns) * Xmom1 - !write(66,2001) om, Aom, Err - if (ns.eq.Nsims) then - Aom_res(nd) = Aom - xom_res(nd) = om - endif - enddo - !Close(66) - enddo - ! Reset the input data - xqmc = XMOM1* xqmc - cov = ((XMOM1)**2)* cov - DeAllocate (Xn_tot) - DeAllocate (En_m_tot, En_e_tot, En_tot ) - DeAllocate (Xn_m_tot, Xn_e_tot ) - DeAllocate (Xn) - DeAllocate (Xn_m, Xn_e) - DeAllocate( G_Mean ) - DeAllocate( xqmc1 ) - Deallocate( Xker_table ) -2001 format(F14.7,2x,F14.7,2x,F14.7) -2004 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7) -2005 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7,2x,F14.7) -2003 format('Alpha, En_m, Acc ', F14.7,2x,F14.7,2x,F14.7,2x,F14.7,2x,F14.7) - end Subroutine MaxEnt_stoch_fit -!*********** - Real (Kind=8) Function Phim1(x) - Implicit None - ! Flat Default with sum 1. This is the correct sum rule for the data! - ! D(om) = 1/(Om_en_1 - Om_st_1) - Real (Kind=8) :: x - PhiM1 = x*(Om_en_1 - Om_st_1) + Om_st_1 - end Function Phim1 - Integer Function NPhim1(x) - Implicit None - ! Flat Default with sum 1. This is the correct sum rule for the data! - ! D(om) = 1/(Om_en_1 - Om_st_1) - Real (Kind=8) :: x, om - om = x*(Om_en_1 - Om_st_1) + Om_st_1 - NPhiM1 = Nint ( (om - Om_st_1)/Dom + 0.75 ) - end Function NPhim1 -!*********** - Subroutine Sum_Xn(Xn_m,Xn) - Implicit none - Real (Kind=8), Dimension(:,:) :: Xn - Real (Kind=8), Dimension(:) :: Xn_m - Real (Kind=8) :: X - do nd = 1,NDis - X = dble( nd )/dble( NDis ) - do ng = 1,Ngamma - Xn_m(nd) = Xn_m(nd) + Xn(ng,2)/( (X-Xn(ng,1))**2 + Delta2) - !aimag( cmplx(Xn(ng,2),0.d0)/cmplx( X-Xn(ng,1), -Delta) ) - enddo - enddo - end Subroutine Sum_Xn -!*********** - Subroutine Sum_Xn_Boxes(Xn_m,Xn) - Implicit none - Real (Kind=8), Dimension(:,:) :: Xn - Real (Kind=8), Dimension(:) :: Xn_m - Real (Kind=8) :: X - do ng = 1,Ngamma - X = Xn(ng,1) - nd = Nint(dble(NDis)*X + 0.5 ) - Xn_m(nd) = Xn_m(nd) + Xn(ng,2) - Enddo - end Subroutine Sum_Xn_Boxes -!*********** - Subroutine MC(Xtau, Xker_table, Xn, Alpha, NSweeps, Xn_m, En, En_m, Acc_1,Acc_2) - !Implicit Real (KIND=8) (A-G,O-Z) - !Implicit Integer (H-N) - Implicit None - Real (Kind=8), Dimension(:,:) :: Xn, Xker_table - Real (Kind=8), Dimension(:) :: Xtau, Xn_m - Real (Kind=8) :: Alpha, En_m, s, ratio, ranf, A_gamma, Z_gamma, Acc_1, Acc_2 - Integer :: NSweeps, nl, Lambda_max, ng1, ng2 - !Local - Real (Kind=8), Allocatable :: h(:), Deltah(:), A_gamma_p(:), Z_gamma_p(:), & - & A_gamma_o(:), Z_gamma_o(:) - Real (Kind=8), Allocatable :: XKER_stor(:,:), XKER_new(:) - Real (Kind=8) :: X, En, En1, DeltaE, XP, XM, om - Integer, Allocatable :: Lambda(:) - Integer :: nb, nsw, Nacc_1, Nacc_2, nw - Allocate (h(ntau), Deltah(ntau) ) - Allocate (Lambda(2), Z_gamma_p(2), A_gamma_p(2), & - & Z_gamma_o(2), A_gamma_o(2) ) ! Max of moves of two walkers. - Allocate ( XKer_stor(Ntau,Ngamma), XKer_New(Ntau) ) - Xn_m = 0.d0 - En_m = 0.d0 - ! Setup h(tau) - do nt = 1,Ntau - X = 0.d0 - do ng = 1,Ngamma - A_gamma = xn(ng,1) - Z_gamma = xn(ng,2) - XKer_stor( nt, ng ) = XKER_table(nt, NPhiM1(A_gamma) ) - ! XKER(xtau(nt),PhiM1(A_gamma),beta) - X = X + Xker_stor(nt,ng)*Z_gamma - enddo - h(nt) = X - xqmc1(nt) - enddo - NAcc_1 = 0; NAcc_2 = 0; - do nsw = 1,Nsweeps - ! Weight sharing moves. - do ng = 1,Ngamma - x = ranf(iseed) - if (x.gt.0.5) then - ! Weight sharing moves. - Lambda_max = 2 - Lambda(1) = nint(ranf(iseed)*dble(Ngamma) + 0.5) - do - Lambda(2) = nint(ranf(iseed)*dble(Ngamma) + 0.5) - if ( Lambda(2) .ne. Lambda(1) ) exit - enddo - ng1 = Lambda(1) - ng2 = Lambda(2) - A_gamma_o(1) = Xn(ng1,1) - A_gamma_o(2) = Xn(ng2,1) - Z_gamma_o(1) = Xn(ng1,2) - Z_gamma_o(2) = Xn(ng2,2) - A_gamma_p(1) = Xn(ng1,1) - A_gamma_p(2) = Xn(ng2,1) - s = (Z_gamma_o(1) + Z_gamma_o(2))*ranf(iseed) - Z_gamma_o(1) - Z_gamma_p(1) = Z_gamma_o(1) + s - Z_gamma_p(2) = Z_gamma_o(2) - s - ! Kernel stays unchanged. - ! Compute Delta H - do nt = 1,ntau - X = Xker_stor(nt,ng1)*( Z_gamma_p(1) - Z_gamma_o(1) ) + & - & Xker_stor(nt,ng2)*( Z_gamma_p(2) - Z_gamma_o(2) ) - Deltah(nt) = X - enddo - else - Lambda_max = 1 - Lambda(1) = nint(ranf(iseed)*dble(Ngamma) + 0.5) - ng1 = Lambda(1) - Z_gamma_o(1) = Xn(ng1,2) - Z_gamma_p(1) = Xn(ng1,2) - A_gamma_o(1) = Xn(ng1,1) - A_gamma_p(1) = xpbc( Xn(ng1,1) + (ranf(iseed) - 0.5)*DeltaXMAX, 1.d0 ) - !om = PhiM1(A_gamma_p(1)) - nw = NPhiM1(A_gamma_p(1)) - do nt = 1,ntau - Xker_new(nt) = Xker_table(nt,nw) ! Xker(xtau(nt),om, beta) - enddo - do nt = 1,ntau - X = ( Xker_new(nt) - Xker_stor(nt,ng1) ) * Z_gamma_o(1) - Deltah(nt) = X - enddo - endif - DeltaE = 0.d0 - do nt = 1,ntau - DeltaE = DeltaE + (Deltah(nt) + 2.0 * h(nt) ) *Deltah(nt) - enddo - Ratio = exp( -alpha * DeltaE ) - ! write(6,*) ' Ratio : ',Ratio, DeltaE - if (Ratio .gt. ranf(iseed)) Then - ! write(6,*) 'Accepted' - if (Lambda_max.eq.1) then - Nacc_1 = Nacc_1 + 1 - ng1 = Lambda(1) - do nt = 1,ntau - Xker_stor(nt,ng1) = Xker_new(nt) - enddo - endif - if (Lambda_max.eq.2) Nacc_2 = Nacc_2 + 1 - do nl = 1,Lambda_max - Xn(Lambda(nl),1) = A_gamma_p(nl) - Xn(Lambda(nl),2) = Z_gamma_p(nl) - enddo - do nt = 1,ntau - h(nt) = h(nt) + Deltah(nt) - enddo - endif - enddo - En = 0.0 - do nt = 1,Ntau - En = En + h(nt)*h(nt) - enddo - En_m = En_m + En - Call Sum_Xn_Boxes( Xn_m, Xn ) - enddo - Acc_1 = dble(Nacc_1)/dble(Ngamma*NSweeps) - Acc_2 = dble(Nacc_2)/dble(Ngamma*NSweeps) - En_m = En_m/dble( nsweeps ) - Xn_m = Xn_m/dble( nsweeps ) - Deallocate ( h, Deltah ) - Deallocate ( Lambda, Z_gamma_p, A_gamma_p, Z_gamma_o, A_gamma_o ) - Deallocate ( XKER_stor, XKER_new ) -2005 format(I4,2x,I4,2x,F14.7,2x,F14.7,' --> ',F14.7,2x,F14.7) -2006 format(I4,2x,F14.7, ' --> ',F14.7) - end Subroutine MC -!********** - real (Kind=8) function xpbc(X,XL) - real (kind=8) :: X, XL - XPBC = X - if (X.GT. XL ) XPBC = X - XL - if (X.LT. 0.0) XPBC = X + XL - end function xpbc -end Module MaxEnt_stoch_mod diff --git a/Libraries/Modules/maxent_stoch_w.f90 b/Libraries/Modules/maxent_stoch_w.f90 deleted file mode 100644 index a0baf0565..000000000 --- a/Libraries/Modules/maxent_stoch_w.f90 +++ /dev/null @@ -1,836 +0,0 @@ - - - - - - -Module MaxEnt_stoch_mod - - - Use MyMats - Use Files_mod - - - Integer, private :: NTAU, nt, Ngamma, ng, Ndis, nd, Iseed - Real (Kind=8), private :: Delta, Delta2, OM_st_1, Om_en_1, DeltaXMAX, Beta, Pi, Dom - Real (Kind=8), allocatable, private :: XQMC1(:) - - ! You can still optimize a bit for by redefining the Kernel table to: - ! xker_table(nt,nw) -> xker_table(nt,nw) / sigma(nt) - ! This will save quite a lot of divisions in the - ! MC routine. And this is where all the time goes now. - - CONTAINS - - Subroutine MaxEnt_stoch(XQMC, Xtau, COV,Xmom1, XKER, Back_Trans_Aom, Beta_1, Alpha_tot,& - & Ngamma_1, OM_ST, OM_EN, Ndis_1, Nsweeps, NBins, NWarm, L_cov ) - - Implicit None - - - - - - Real (Kind=8), Dimension(:) :: XQMC, Xtau, Alpha_tot - Real (Kind=8), Dimension(:,:) :: COV - Real (Kind=8), External :: XKER, Back_trans_Aom - Real (Kind=8) :: CHISQ, OM_ST, OM_EN, Beta_1, Xmom1, Err - Integer :: Nsweeps, NBins, Ngamma_1, Ndis_1, nw, nt1 - Integer, optional :: L_cov - - ! Local - Integer lp, NSims, ns, nb, nc, Nwarm, nalp1, nalp2, Nex, p_star, Ndis_table, & - & io_error, io_error1, i - Real (Kind=8), Allocatable :: Xn_M_tot(:,:), En_M_tot(:), Xn_E_tot(:,:), En_E_tot(:), & - & Xn_tot(:,:,:), En_tot(:) - Real (Kind=8), Allocatable :: G_Mean(:), Xn_m(:), Xn_e(:), Xn(:,:), Vhelp(:) - Real (Kind=8) :: Ranf, En_M, Res, X, Alpha, Acc_1, Acc_2, En, DeltaE, Ratio, D - Real (Kind=8) :: Aom, om, XMAX, tau - Real (Kind=8) :: CPUT, CPUTM - Integer :: ICPU_1, ICPU_2, N_P_SEC - Character (64) :: File_root, File1, File_conf, File_Aom - Real (Kind=8), allocatable :: Xker_table(:,:), U(:,:), sigma(:) - - - - - - - - - - - Pi = acos(-1.d0) - NDis = Ndis_1 - DeltaXMAX = 0.01 - delta = 0.001 - delta2 = delta*delta - Ngamma = Ngamma_1 - Beta = Beta_1 ! Physical temperature for calculation of the kernel. - - Ntau = Size(xqmc,1) - NSims = Size(Alpha_tot,1) - Allocate (Xn_tot(Ngamma,2,NSims)) - Allocate (En_m_tot(NSims), En_e_tot(NSims), En_tot(NSims) ) - Allocate (Xn_m_tot(NDis,NSims), Xn_e_tot(NDis,NSims) ) - - Allocate (Xn(Ngamma,2)) - Allocate (Xn_m(NDis), Xn_e(NDis) ) - - Om_st_1 = OM_st; Om_en_1 = OM_en - - ! Setup table for the Kernel - Ndis_table = 50000 - Dom = (OM_EN_1 - OM_ST_1)/dble(Ndis_table-1) - Allocate ( Xker_table(Ntau, Ndis_table) ) - do nt = 1,Ntau - do nw = 1,Ndis_table - tau = xtau(nt) - Om = OM_st + dble(nw-1)*dom - Xker_table(nt,nw) = Xker(tau,om,beta) - enddo - enddo - ! Normalize data to have zeroth moment of unity. - xqmc = xqmc / XMOM1 - cov = cov / ((XMOM1)**2) - ! Diagonalize the covariance - - Allocate( U(ntau,ntau), Sigma(ntau), xqmc1(Ntau) ) - If ( Present(L_cov) ) then - Call Diag(cov,U,sigma) - ! Write(6,*) " Cov Used" - else - Write(6,*) "No Cov Used" - U = 0.d0 - do nt = 1,ntau - U(nt,nt) = 1.d0 - sigma(nt) = cov(nt,nt) - enddo - endif - do nt = 1,ntau - sigma(nt) = sqrt(sigma(nt)) - enddo - xqmc1 = 0.d0 - do nt1 = 1,ntau - do nt = 1,ntau - xqmc1(nt1) = xqmc1(nt1) + xqmc(nt)*U(nt,nt1) - enddo - xqmc1(nt1) = xqmc1(nt1)/sigma(nt1) - enddo - ! Transform the Kernel - allocate ( Vhelp(Ntau) ) - do nw = 1,Ndis_table - Vhelp = 0.d0 - do nt1 = 1,Ntau - do nt = 1,Ntau - Vhelp(nt1) = Vhelp(nt1) + Xker_table(nt,nw)*U(nt,nt1) - enddo - enddo - do nt1 = 1,ntau - Xker_table(nt1,nw) = Vhelp(nt1)/sigma(nt1) !! This has changed !! - enddo - enddo - deallocate( U, Sigma ) - Allocate ( G_Mean(Ntau) ) - G_mean = 0.d0 - -! write(6,*) ' There are ', Ngamma,' delta-functions for a spectrum' -! Write(6,*) ' Initializing' - ! D(om) = 1/(Om_en_1 - Om_st_1) - D = 1.d0 / (Om_en_1 - Om_st_1) - - Iseed = 8752143 - - File_conf = "dump_conf" - File_Aom = "dump_Aom" - - Open(unit=41,file=File_conf,status='old',action='read', iostat=io_error) - Open(unit=42,file=File_Aom, status='old',action='read', iostat=io_error1) - If (io_error == 0 .and. io_error1 == 0 ) then - Nwarm = 0 - read(41,*) Iseed - do ns = 1,Nsims - do ng = 1,Ngamma - read(41,*) Xn_tot(ng,1,ns), Xn_tot(ng,2,ns) - enddo - read(41,*) En_m_tot(ns), En_e_tot(ns) - enddo - read(42,*) nc - do ns = 1,Nsims - do nd = 1,Ndis - read(42,*) Xn_m_tot(nd,ns), Xn_e_tot(nd,ns) - enddo - enddo - Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") - Write(44,*) 'Read from dump: nc = ', nc - close(44) - else - !Iseed is alrady set. - Do Ns = 1,NSims - do ng = 1,NGamma - Xn_tot(ng,1,ns) = ranf(iseed) - Xn_tot(ng,2,ns) = 1.d0/dble(Ngamma) - enddo - enddo - Xn_m_tot = 0.d0 - En_m_tot = 0.d0 - Xn_e_tot = 0.d0 - En_e_tot = 0.d0 - nc = 0 - Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") - Write(44,*) ' No dump data ' - close(44) - endif - close(41) - close(42) - - CALL SYSTEM_CLOCK(COUNT_RATE=N_P_SEC) - CALL SYSTEM_CLOCK(COUNT=ICPU_1) - ! Start Simulations. - do Nb = 1,Nbins - do ns = 1,NSims - do ng = 1,Ngamma - Xn(ng,1) = Xn_tot(ng,1,ns) - Xn(ng,2) = Xn_tot(ng,2,ns) - enddo - Alpha = Alpha_tot(ns) - Call MC(Xtau, Xker_table, Xn, Alpha, NSweeps, Xn_m, En, En_m, & - & Acc_1, Acc_2 ) ! Just one bin - do ng = 1,Ngamma - Xn_tot(ng,1,ns) = Xn(ng,1) - Xn_tot(ng,2,ns) = Xn(ng,2) - enddo - En_tot(ns) = En ! this is the energy of the configuration Xn_tot for simulation ns - Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") - Write(44,2003) 1.d0/Alpha, En_m, Acc_1, Acc_2 - close(44) - - if (nb.gt.nwarm) then - if (ns.eq.1) nc = nc + 1 - do nd = 1,NDis - Xn_m(nd) = Xn_m(nd) * D * dble(Ndis) - Xn_m_tot(nd,ns) = Xn_m_tot(nd,ns) + Xn_m(nd) - Xn_e_tot(nd,ns) = Xn_e_tot(nd,ns) + Xn_m(nd)*Xn_m(nd) - enddo - En_m_tot(ns) = En_m_tot(ns) + En_m - En_e_tot(ns) = En_e_tot(ns) + En_m*En_m - endif - enddo - ! Exchange - Acc_1 = 0.d0 - Do Nex = 1, 2*NSims - nalp1= nint( ranf(iseed)*dble(NSims-1) + 0.5 ) ! 1..(NSims-1) - nalp2 = nalp1 + 1 - DeltaE = (Alpha_tot(nalp1)*En_tot(nalp2) + Alpha_tot(nalp2)*En_tot(nalp1))& - & -(Alpha_tot(nalp1)*En_tot(nalp1) + Alpha_tot(nalp2)*En_tot(nalp2)) - Ratio = exp(-DeltaE) - if (Ratio.gt.ranf(iseed)) Then - Acc_1 = Acc_1 + 1.0 - !Switch confs an Energies. - do ng = 1,Ngamma - Xn(ng,1) = Xn_tot(ng,1,nalp1) - Xn(ng,2) = Xn_tot(ng,2,nalp1) - enddo - do ng = 1,Ngamma - Xn_tot(ng,1,nalp1) = Xn_tot(ng,1,nalp2) - Xn_tot(ng,2,nalp1) = Xn_tot(ng,2,nalp2) - Xn_tot(ng,1,nalp2) = Xn(ng,1) - Xn_tot(ng,2,nalp2) = Xn(ng,2) - enddo - En_m = En_tot(nalp1) - En_tot(nalp1) = En_tot(nalp2) - En_tot(nalp2) = En_m - endif - enddo - Acc_1 = Acc_1/dble(Nex) - - Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") - Write(44,*) 'Acc Exchange: ', Acc_1 - close(44) - enddo - - CALL SYSTEM_CLOCK(COUNT=ICPU_2) - CPUT = 0.D0 - CPUT = DBLE(ICPU_2 - ICPU_1)/DBLE(N_P_SEC) - Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") - Write(44,*) 'Total time: ', CPUT - close(44) - ! dump so as to restart. - Open(unit=41,file=File_conf,status='unknown') - Open(unit=42,file=File_Aom, status='unknown') - write(41,*) Iseed - do ns = 1,Nsims - do ng = 1,Ngamma - write(41,*) Xn_tot(ng,1,ns), Xn_tot(ng,2,ns) - enddo - write(41,*) En_m_tot(ns), En_e_tot(ns) - enddo - write(42,*) nc - do ns = 1,Nsims - do nd = 1,Ndis - write(42,*) Xn_m_tot(nd,ns), Xn_e_tot(nd,ns) - enddo - enddo - close(41) - close(42) - ! Stop dump - - - - - Open(Unit=66,File="energies",status="unknown") - do ns = 1,Nsims - En_m_tot(ns) = En_m_tot(ns) / dble(nc) - En_e_tot(ns) = En_e_tot(ns) / dble(nc) - En_e_tot(ns) = ( En_e_tot(ns) - En_m_tot(ns)**2)/dble(nc) - if ( En_e_tot(ns) .gt. 0.d0) then - En_e_tot(ns) = sqrt(En_e_tot(ns)) - else - En_e_tot(ns) = 0.d0 - endif - write(66,*) Alpha_tot(ns), En_m_tot(ns), En_e_tot(ns) - enddo - close(66) - - File_root = "Aom" - do ns = 1,Nsims - File1 = File_i(File_root,ns) - Open(Unit=66,File=File1,status="unknown") - do nd = 1,Ndis - Xn_m_tot(nd,ns) = Xn_m_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) - Xn_e_tot(nd,ns) = Xn_e_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) - Xn_e_tot(nd,ns) = (Xn_e_tot(nd,ns) - Xn_m_tot(nd,ns)* Xn_m_tot(nd,ns))/dble(nc) - if (Xn_e_tot(nd,ns).gt.0.d0) then - Xn_e_tot(nd,ns) = sqrt(Xn_e_tot(nd,ns)) - else - Xn_e_tot(nd,ns) = 0.d0 - endif - om = PhiM1(dble(nd)/dble(NDis)) - Aom = Xn_m_tot(nd,ns) * Xmom1 - Err = Xn_e_tot(nd,ns) * Xmom1 - write(66,2001) om, Back_Trans_Aom(Aom,Beta,om), Back_Trans_Aom(Err,Beta,om) - ! PhiM1(dble(nd)/dble(NDis)), Xn_m_tot(nd,ns) - enddo - Close(66) - enddo - - ! Now do the averaging. - File_root ="Aom_ps" - do p_star = 1,NSims - 10 - Xn_m = 0.0 - Xn_e = 0.0 - do ns = p_star, NSims-1 - do nd = 1, NDis - Xn_m(nd) = Xn_m(nd) + (En_m_tot(ns) - En_m_tot(ns+1))*Xn_m_tot(nd,ns) - Xn_e(nd) = Xn_e(nd) + (En_m_tot(ns) - En_m_tot(ns+1))*Xn_e_tot(nd,ns) - enddo - enddo - do nd = 1,NDis - Xn_m(nd) = Xn_m(nd) / (En_m_tot(p_star) - En_m_tot(NSims)) - Xn_e(nd) = Xn_e(nd) / (En_m_tot(p_star) - En_m_tot(NSims)) - enddo - File1 = File_i(File_root,p_star) - Open(Unit=66,File=File1,status="unknown") - XMAX = 0.d0 - Do nd = 1,Ndis - om = PhiM1(dble(nd)/dble(NDis)) - Aom = Xn_m(nd) * Xmom1 - Err = Xn_e(nd) * Xmom1 - Xn_m(nd) = Back_Trans_Aom(Aom,Beta,om) - Xn_e(nd) = Back_Trans_Aom(Err,Beta,om) - IF (Xn_m(nd) .gt. XMAX ) XMAX = Xn_m(nd) - enddo - do nd = 1,Ndis - om = PhiM1(dble(nd)/dble(NDis)) - write(66,2005) om, Xn_m(nd), Xn_e(nd), Xn_m(nd)/XMAX, Xn_e(nd)/XMAX - ! PhiM1(dble(nd)/dble(NDis)), Xn_m(nd) - enddo - close(66) - enddo - - Open (Unit=41,File='Best_fit', Status="unknown") - do ng = 1,Ngamma - Write(41,*) Phim1(Xn_tot(ng,1,Nsims)) , Xn_tot(ng,2,Nsims) - enddo - close(41) - - DeAllocate (Xn_tot) - DeAllocate (En_m_tot, En_e_tot, En_tot ) - DeAllocate (Xn_m_tot, Xn_e_tot ) - DeAllocate (Xn) - DeAllocate (Xn_m, Xn_e) - DeAllocate( G_Mean ) - DeAllocate( xqmc1 ) - Deallocate( Xker_table ) - - -2001 format(F14.7,2x,F14.7,2x,F14.7) -2004 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7) -2005 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7,2x,F14.7) -2003 format('Alpha, En_m, Acc ', F14.7,2x,F24.12,2x,F14.7,2x,F14.7,2x,F14.7) - end Subroutine MaxEnt_stoch - - -!------------------- - Subroutine MaxEnt_stoch_fit(XQMC, Xtau, COV, Lcov, XKER, Xmom1, Beta_1, Alpha_tot,& - & Ngamma_1, OM_ST, OM_EN, Nsweeps, NBins, NWarm, Aom_res,& - & xom_res, Chisq ) - - Implicit None - Real (Kind=8), Dimension(:) :: XQMC, Xtau, Alpha_tot, Aom_res, Xom_res - Real (Kind=8), Dimension(:,:) :: COV - Real (Kind=8), external :: XKER - Real (Kind=8) :: CHISQ, OM_ST, OM_EN, Beta_1, Xmom1, Err - Integer :: Nsweeps, NBins, Ngamma_1, Ndis_1, nw, nt1, Lcov - - ! Local - Integer lp, NSims, ns, nb, nc, Nwarm, nalp1, nalp2, Nex, p_star - Real (Kind=8), Allocatable :: Xn_M_tot(:,:), En_M_tot(:), Xn_E_tot(:,:), En_E_tot(:), & - & Xn_tot(:,:,:), En_tot(:), Xker_table(:,:) - Real (Kind=8), Allocatable :: G_Mean(:), Xn_m(:), Xn_e(:), Xn(:,:), Vhelp(:) - Real (Kind=8) :: Ranf, En_M, Res, X, Alpha, Acc_1, Acc_2, En, DeltaE, Ratio, D - Real (Kind=8) :: Aom, om, XMAX, tau - Real (Kind=8), allocatable :: U(:,:), sigma(:) - - - Pi = acos(-1.d0) - Iseed = 8752143 - NDis = Size(Aom_res,1) - DeltaXMAX = 0.01 - delta = 0.001 - delta2 = delta*delta - Ngamma = Ngamma_1 - Beta = Beta_1 ! Physical temperature for calculation of the kernel. - - Ntau = Size(xqmc,1) - NSims = Size(Alpha_tot,1) - Allocate (Xn_tot(Ngamma,2,NSims)) - Allocate (En_m_tot(NSims), En_e_tot(NSims), En_tot(NSims) ) - Allocate (Xn_m_tot(NDis,NSims), Xn_e_tot(NDis,NSims) ) - - Allocate (Xn(Ngamma,2)) - Allocate (Xn_m(NDis), Xn_e(NDis) ) - - Om_st_1 = OM_st; Om_en_1 = OM_en - - ! Setup table for the Kernel - Ndis = Size(Aom_res) - Dom = (OM_EN_1 - OM_ST_1)/dble(Ndis-1) - Allocate ( Xker_table(Ntau, Ndis) ) - Dom = (OM_EN - OM_ST)/dble(Ndis-1) - do nt = 1,Ntau - do nw = 1,Ndis - tau = xtau(nt) - Om = OM_st + dble(nw-1)*dom - Xker_table(nt,nw) = Xker(tau,om,beta) - enddo - enddo - - ! Normalize data to have zeroth moment of unity. - xqmc = xqmc / XMOM1 - cov = cov / ((XMOM1)**2) - ! Diagonalize the covariance - - If (Lcov.eq.1) then - Allocate( U(ntau,ntau), Sigma(ntau), xqmc1(Ntau) ) - Call Diag(cov,U,sigma) - do nt = 1,ntau - sigma(nt) = sqrt(sigma(nt)) - enddo - xqmc1 = 0.d0 - do nt1 = 1,ntau - do nt = 1,ntau - xqmc1(nt1) = xqmc1(nt1) + xqmc(nt)*U(nt,nt1) - enddo - xqmc1(nt1) = xqmc1(nt1)/sigma(nt1) - enddo - ! Transform the Kernel - allocate ( Vhelp(Ntau) ) - do nw = 1,Ndis - Vhelp = 0.d0 - do nt1 = 1,Ntau - do nt = 1,Ntau - Vhelp(nt1) = Vhelp(nt1) + Xker_table(nt,nw)*U(nt,nt1) - enddo - enddo - do nt1 = 1,ntau - Xker_table(nt1,nw) = Vhelp(nt1)/sigma(nt1) !! This has changed !! - enddo - enddo - Deallocate (U,sigma) - else - Allocate( Sigma(ntau), xqmc1(Ntau) ) - !Call Diag(cov,U,sigma) - do nt = 1,ntau - sigma(nt) = 1.d0/sqrt(cov(nt,nt)) - enddo - xqmc1 = 0.d0 - do nt1 = 1,ntau - xqmc1(nt1) = xqmc(nt1)*sigma(nt1) - enddo - ! Transform the Kernel - allocate ( Vhelp(Ntau) ) - do nw = 1,Ndis - do nt1 = 1,ntau - Xker_table(nt1,nw) = Xker_table(nt1,nw)*sigma(nt1) !! This has changed !! - enddo - enddo - deallocate(Sigma) - endif - Allocate(G_Mean(Ntau)) - G_mean = 0.d0 - -! write(6,*) ' There are ', Ngamma,' delta-functions for a spectrum' -! Write(6,*) ' Initializing' - Do Ns = 1,NSims - do ng = 1,NGamma - Xn_tot(ng,1,ns) = ranf(iseed) - Xn_tot(ng,2,ns) = 1.d0/dble(Ngamma) - enddo - enddo - Xn_m_tot = 0.d0 - En_m_tot = 0.d0 - Xn_e_tot = 0.d0 - En_e_tot = 0.d0 - ! D(om) = 1/(Om_en_1 - Om_st_1) - D = 1.d0 / (Om_en_1 - Om_st_1) - - Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") - Write(44,*) "N E W R U N " - nc = 0 - do Nb = 1,Nbins - do ns = 1,NSims - do ng = 1,Ngamma - Xn(ng,1) = Xn_tot(ng,1,ns) - Xn(ng,2) = Xn_tot(ng,2,ns) - enddo - Alpha = Alpha_tot(ns) - Call MC(Xtau, Xker_table, Xn, Alpha, NSweeps, Xn_m, En, En_m, & - & Acc_1, Acc_2 ) ! Just one bin - do ng = 1,Ngamma - Xn_tot(ng,1,ns) = Xn(ng,1) - Xn_tot(ng,2,ns) = Xn(ng,2) - enddo - En_tot(ns) = En ! this is the energy of the configuration Xn_tot for simulation ns - Write(44,2003) 1.d0/Alpha, En_m, Acc_1, Acc_2 - if (nb.gt.nwarm) then - if (ns.eq.1) nc = nc + 1 - do nd = 1,NDis - Xn_m(nd) = Xn_m(nd) * D * dble(Ndis) - Xn_m_tot(nd,ns) = Xn_m_tot(nd,ns) + Xn_m(nd) - Xn_e_tot(nd,ns) = Xn_e_tot(nd,ns) + Xn_m(nd)*Xn_m(nd) - enddo - En_m_tot(ns) = En_m_tot(ns) + En_m - En_e_tot(ns) = En_e_tot(ns) + En_m*En_m - endif - enddo - ! Exchange - Acc_1 = 0.d0 - Do Nex = 1, 2*NSims - nalp1= nint( ranf(iseed)*dble(NSims-1) + 0.5 ) ! 1..(NSims-1) - nalp2 = nalp1 + 1 - DeltaE = (Alpha_tot(nalp1)*En_tot(nalp2) + Alpha_tot(nalp2)*En_tot(nalp1))& - & -(Alpha_tot(nalp1)*En_tot(nalp1) + Alpha_tot(nalp2)*En_tot(nalp2)) - Ratio = exp(-DeltaE) - if (Ratio.gt.ranf(iseed)) Then - Acc_1 = Acc_1 + 1.0 - !Switch confs an Energies. - do ng = 1,Ngamma - Xn(ng,1) = Xn_tot(ng,1,nalp1) - Xn(ng,2) = Xn_tot(ng,2,nalp1) - enddo - do ng = 1,Ngamma - Xn_tot(ng,1,nalp1) = Xn_tot(ng,1,nalp2) - Xn_tot(ng,2,nalp1) = Xn_tot(ng,2,nalp2) - Xn_tot(ng,1,nalp2) = Xn(ng,1) - Xn_tot(ng,2,nalp2) = Xn(ng,2) - enddo - En_m = En_tot(nalp1) - En_tot(nalp1) = En_tot(nalp2) - En_tot(nalp2) = En_m - endif - enddo - Acc_1 = Acc_1/dble(Nex) - Write(44,*) 'Acc Exchange: ', Acc_1 - enddo - - !Open(Unit=66,File="energies",status="unknown") - do ns = Nsims,Nsims - En_m_tot(ns) = En_m_tot(ns) / dble(nc) - En_e_tot(ns) = En_e_tot(ns) / dble(nc) - En_e_tot(ns) = ( En_e_tot(ns) - En_m_tot(ns)**2)/dble(nc) - if ( En_e_tot(ns) .gt. 0.d0) then - En_e_tot(ns) = sqrt(En_e_tot(ns)) - else - En_e_tot(ns) = 0.d0 - endif - !write(66,*) Alpha_tot(ns), En_m_tot(ns), En_e_tot(ns) - enddo - !close(60) - Chisq = En_e_tot(Nsims) - Close(44) - - do ns = Nsims,Nsims - do nd = 1,Ndis - Xn_m_tot(nd,ns) = Xn_m_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) - Xn_e_tot(nd,ns) = Xn_e_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) - Xn_e_tot(nd,ns) = (Xn_e_tot(nd,ns) - Xn_m_tot(nd,ns)* Xn_m_tot(nd,ns))/dble(nc) - if (Xn_e_tot(nd,ns).gt.0.d0) then - Xn_e_tot(nd,ns) = sqrt(Xn_e_tot(nd,ns)) - else - Xn_e_tot(nd,ns) = 0.d0 - endif - om = PhiM1(dble(nd)/dble(NDis)) - Aom = Xn_m_tot(nd,ns) * Xmom1 - Err = Xn_e_tot(nd,ns) * Xmom1 - !write(66,2001) om, Aom, Err - if (ns.eq.Nsims) then - Aom_res(nd) = Aom - xom_res(nd) = om - endif - enddo - !Close(66) - enddo - - ! Reset the input data - xqmc = XMOM1* xqmc - cov = ((XMOM1)**2)* cov - - - DeAllocate (Xn_tot) - DeAllocate (En_m_tot, En_e_tot, En_tot ) - DeAllocate (Xn_m_tot, Xn_e_tot ) - DeAllocate (Xn) - DeAllocate (Xn_m, Xn_e) - DeAllocate( G_Mean ) - DeAllocate( xqmc1 ) - Deallocate( Xker_table ) - -2001 format(F14.7,2x,F14.7,2x,F14.7) -2004 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7) -2005 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7,2x,F14.7) -2003 format('Alpha, En_m, Acc ', F14.7,2x,F14.7,2x,F14.7,2x,F14.7,2x,F14.7) - end Subroutine MaxEnt_stoch_fit -!*********** - Real (Kind=8) Function Phim1(x) - Implicit None - ! Flat Default with sum 1. This is the correct sum rule for the data! - ! D(om) = 1/(Om_en_1 - Om_st_1) - Real (Kind=8) :: x - PhiM1 = x*(Om_en_1 - Om_st_1) + Om_st_1 - end Function Phim1 - - - Integer Function NPhim1(x) - Implicit None - - ! Flat Default with sum 1. This is the correct sum rule for the data! - ! D(om) = 1/(Om_en_1 - Om_st_1) - - Real (Kind=8) :: x, om - om = x*(Om_en_1 - Om_st_1) + Om_st_1 - NPhiM1 = Nint ( (om - Om_st_1)/Dom + 0.75 ) - - end Function NPhim1 - - -!*********** - Subroutine Sum_Xn(Xn_m,Xn) - - Implicit none - Real (Kind=8), Dimension(:,:) :: Xn - Real (Kind=8), Dimension(:) :: Xn_m - Real (Kind=8) :: X - - - do nd = 1,NDis - X = dble( nd )/dble( NDis ) - do ng = 1,Ngamma - Xn_m(nd) = Xn_m(nd) + Xn(ng,2)/( (X-Xn(ng,1))**2 + Delta2) - !aimag( cmplx(Xn(ng,2),0.d0)/cmplx( X-Xn(ng,1), -Delta) ) - enddo - enddo - - end Subroutine Sum_Xn - -!*********** - Subroutine Sum_Xn_Boxes(Xn_m,Xn) - - Implicit none - Real (Kind=8), Dimension(:,:) :: Xn - Real (Kind=8), Dimension(:) :: Xn_m - Real (Kind=8) :: X - - - do ng = 1,Ngamma - X = Xn(ng,1) - nd = Nint(dble(NDis)*X + 0.5 ) - Xn_m(nd) = Xn_m(nd) + Xn(ng,2) - Enddo - - end Subroutine Sum_Xn_Boxes - - -!*********** - Subroutine MC(Xtau, Xker_table, Xn, Alpha, NSweeps, Xn_m, En, En_m, Acc_1,Acc_2) - - !Implicit Real (KIND=8) (A-G,O-Z) - !Implicit Integer (H-N) - Implicit None - - Real (Kind=8), Dimension(:,:) :: Xn, Xker_table - Real (Kind=8), Dimension(:) :: Xtau, Xn_m - Real (Kind=8) :: Alpha, En_m, s, ratio, ranf, A_gamma, Z_gamma, Acc_1, Acc_2 - Integer :: NSweeps, nl, Lambda_max, ng1, ng2 - - !Local - Real (Kind=8), Allocatable :: h(:), Deltah(:), A_gamma_p(:), Z_gamma_p(:), & - & A_gamma_o(:), Z_gamma_o(:) - - Real (Kind=8), Allocatable :: XKER_stor(:,:), XKER_new(:) - - Real (Kind=8) :: X, En, En1, DeltaE, XP, XM, om - Integer, Allocatable :: Lambda(:) - Integer :: nb, nsw, Nacc_1, Nacc_2, nw - - Allocate (h(ntau), Deltah(ntau) ) - Allocate (Lambda(2), Z_gamma_p(2), A_gamma_p(2), & - & Z_gamma_o(2), A_gamma_o(2) ) ! Max of moves of two walkers. - - Allocate ( XKer_stor(Ntau,Ngamma), XKer_New(Ntau) ) - - Xn_m = 0.d0 - En_m = 0.d0 - - - ! Setup h(tau) - do nt = 1,Ntau - X = 0.d0 - do ng = 1,Ngamma - A_gamma = xn(ng,1) - Z_gamma = xn(ng,2) - XKer_stor( nt, ng ) = XKER_table(nt, NPhiM1(A_gamma) ) - ! XKER(xtau(nt),PhiM1(A_gamma),beta) - X = X + Xker_stor(nt,ng)*Z_gamma - enddo - h(nt) = X - xqmc1(nt) - enddo - - - NAcc_1 = 0; NAcc_2 = 0; - do nsw = 1,Nsweeps - ! Weight sharing moves. - do ng = 1,Ngamma - x = ranf(iseed) - if (x.gt.0.5) then - ! Weight sharing moves. - Lambda_max = 2 - Lambda(1) = nint(ranf(iseed)*dble(Ngamma) + 0.5) - do - Lambda(2) = nint(ranf(iseed)*dble(Ngamma) + 0.5) - if ( Lambda(2) .ne. Lambda(1) ) exit - enddo - ng1 = Lambda(1) - ng2 = Lambda(2) - - A_gamma_o(1) = Xn(ng1,1) - A_gamma_o(2) = Xn(ng2,1) - Z_gamma_o(1) = Xn(ng1,2) - Z_gamma_o(2) = Xn(ng2,2) - - A_gamma_p(1) = Xn(ng1,1) - A_gamma_p(2) = Xn(ng2,1) - - s = (Z_gamma_o(1) + Z_gamma_o(2))*ranf(iseed) - Z_gamma_o(1) - Z_gamma_p(1) = Z_gamma_o(1) + s - Z_gamma_p(2) = Z_gamma_o(2) - s - - ! Kernel stays unchanged. - - ! Compute Delta H - do nt = 1,ntau - X = Xker_stor(nt,ng1)*( Z_gamma_p(1) - Z_gamma_o(1) ) + & - & Xker_stor(nt,ng2)*( Z_gamma_p(2) - Z_gamma_o(2) ) - Deltah(nt) = X - enddo - else - Lambda_max = 1 - Lambda(1) = nint(ranf(iseed)*dble(Ngamma) + 0.5) - ng1 = Lambda(1) - Z_gamma_o(1) = Xn(ng1,2) - Z_gamma_p(1) = Xn(ng1,2) - - A_gamma_o(1) = Xn(ng1,1) - A_gamma_p(1) = xpbc( Xn(ng1,1) + (ranf(iseed) - 0.5)*DeltaXMAX, 1.d0 ) - - !om = PhiM1(A_gamma_p(1)) - nw = NPhiM1(A_gamma_p(1)) - do nt = 1,ntau - Xker_new(nt) = Xker_table(nt,nw) ! Xker(xtau(nt),om, beta) - enddo - - do nt = 1,ntau - X = ( Xker_new(nt) - Xker_stor(nt,ng1) ) * Z_gamma_o(1) - Deltah(nt) = X - enddo - endif - - - DeltaE = 0.d0 - do nt = 1,ntau - DeltaE = DeltaE + (Deltah(nt) + 2.0 * h(nt) ) *Deltah(nt) - enddo - Ratio = exp( -alpha * DeltaE ) - ! write(6,*) ' Ratio : ',Ratio, DeltaE - if (Ratio .gt. ranf(iseed)) Then - ! write(6,*) 'Accepted' - if (Lambda_max.eq.1) then - Nacc_1 = Nacc_1 + 1 - ng1 = Lambda(1) - do nt = 1,ntau - Xker_stor(nt,ng1) = Xker_new(nt) - enddo - endif - if (Lambda_max.eq.2) Nacc_2 = Nacc_2 + 1 - do nl = 1,Lambda_max - Xn(Lambda(nl),1) = A_gamma_p(nl) - Xn(Lambda(nl),2) = Z_gamma_p(nl) - enddo - do nt = 1,ntau - h(nt) = h(nt) + Deltah(nt) - enddo - endif - enddo - En = 0.0 - do nt = 1,Ntau - En = En + h(nt)*h(nt) - enddo - En_m = En_m + En - Call Sum_Xn_Boxes( Xn_m, Xn ) - enddo - Acc_1 = dble(Nacc_1)/dble(Ngamma*NSweeps) - Acc_2 = dble(Nacc_2)/dble(Ngamma*NSweeps) - En_m = En_m/dble( nsweeps ) - Xn_m = Xn_m/dble( nsweeps ) - - - Deallocate ( h, Deltah ) - Deallocate ( Lambda, Z_gamma_p, A_gamma_p, Z_gamma_o, A_gamma_o ) - Deallocate ( XKER_stor, XKER_new ) - -2005 format(I4,2x,I4,2x,F14.7,2x,F14.7,' --> ',F14.7,2x,F14.7) -2006 format(I4,2x,F14.7, ' --> ',F14.7) - end Subroutine MC - - - -!********** - real (Kind=8) function xpbc(X,XL) - real (kind=8) :: X, XL - XPBC = X - if (X.GT. XL ) XPBC = X - XL - if (X.LT. 0.0) XPBC = X + XL - end function xpbc - - -end Module MaxEnt_stoch_mod diff --git a/Libraries/Modules/pre1 b/Libraries/Modules/pre1 deleted file mode 100644 index 38a649688..000000000 --- a/Libraries/Modules/pre1 +++ /dev/null @@ -1,12 +0,0 @@ -PRE = cpp -PREF = -P -OBJ= maxent_stoch.f90 - -all: $(OBJ) - -.SUFFIXES: .G90 .f90 -.G90.f90: - $(PRE) $(PREF) $? $@ - -clean: - rm $(OBJ) diff --git a/Libraries/Modules/precdef.mod.f90 b/Libraries/Modules/precdef.mod.f90 deleted file mode 100644 index 9b2f2e961..000000000 --- a/Libraries/Modules/precdef.mod.f90 +++ /dev/null @@ -1,23 +0,0 @@ -!=============================================================================== - MODULE precdef -!------------------------------------------------------------------------------- -! - IMPLICIT NONE - - INTEGER, PARAMETER :: & - byte = selected_int_kind(2), & ! -128 ... 127, 1 byte - long = selected_int_kind(9), & ! −2147483648 ... 2147483647, 4 byte - int64 = selected_int_kind(18), & ! −9223372036854775808 ... 9223372036854775807 8 byte - single = selected_real_kind(p=6,r=37), & ! kind(1.0), 4 byte - !double = selected_real_kind(p=15,r=307) ! selected_real_kind(2*precision(1.0_double)), 8 byte - double = 8 ! selected_real_kind(2*precision(1.0_double)), 8 byte - - REAL(kind=double), PARAMETER :: & - rone = 1.0D0, & - rzero = 0.0D0 - - COMPLEX(kind=double), PARAMETER :: & - cone = cmplx(rone,rzero,double), & - czero = cmplx(rzero,rzero,double) - - END MODULE precdef diff --git a/Libraries/Modules/smooth_stoch.f90 b/Libraries/Modules/smooth_stoch.f90 deleted file mode 100644 index 3207ab751..000000000 --- a/Libraries/Modules/smooth_stoch.f90 +++ /dev/null @@ -1,40 +0,0 @@ - Program Trans - - Implicit Real (KIND=8) (A-G,O-Z) - Implicit Integer (H-N) - - parameter (Ndis=650) - Real (Kind=8) :: Xn_m(Ndis), om(Ndis), Xn_m_new(Ndis) - - open (Unit=10, File="Aom_ps_20",status="unknown") - do i = 1,Ndis - read(10,*) om(i), Xn_m(i), X, Y, Z - enddo - close(10) - - pi = acos(-1.0) - Xn_m_new = 0.d0 - Del = om(2) - om(1) - do nd = 1,Ndis - weight = Xn_m(nd) - x_0 = om(nd) - do i = 1,Ndis - x = om(i) - Xn_m_new(i) = Xn_m_new(i) + weight*del*g(10.0*del,x_0,x,pi) - enddo - enddo - - do i = 1,Ndis - write(20,*) Om(i), Xn_m_new(i) - enddo - end Program Trans - - - real (Kind=8) function g(del,a,om,pi) - - implicit none - real (Kind=8) :: del, a, om, pi - - g = exp( -((om - a)/del)**2)/(sqrt(pi)*del) - - end function g diff --git a/Libraries/Modules/tmp.f90 b/Libraries/Modules/tmp.f90 deleted file mode 100644 index 83932960a..000000000 --- a/Libraries/Modules/tmp.f90 +++ /dev/null @@ -1,735 +0,0 @@ - - - - - - -Module MaxEnt_stoch_mod - - - Use MyMats - Use Files_mod - - - Integer, private :: NTAU, nt, Ngamma, ng, Ndis, nd, Iseed - Real (Kind=8), private :: Delta, Delta2, OM_st_1, Om_en_1, DeltaXMAX, Beta, Pi, Dom - Real (Kind=8), allocatable, private :: XQMC1(:) - - ! You can still optimize a bit for by redefining the Kernel table to: - ! xker_table(nt,nw) -> xker_table(nt,nw) / sigma(nt) - ! This will save quite a lot of divisions in the - ! MC routine. And this is where all the time goes now. - - CONTAINS - - Subroutine MaxEnt_stoch(XQMC, Xtau, COV,Xmom1, XKER, Back_Trans_Aom, Beta_1, Alpha_tot,& - & Ngamma_1, OM_ST, OM_EN, Ndis_1, Nsweeps, NBins, NWarm, L_cov ) - - Implicit None - - - - - - Real (Kind=8), Dimension(:) :: XQMC, Xtau, Alpha_tot - Real (Kind=8), Dimension(:,:) :: COV - Real (Kind=8), External :: XKER, Back_trans_Aom - Real (Kind=8) :: CHISQ, OM_ST, OM_EN, Beta_1, Xmom1, Err - Integer :: Nsweeps, NBins, Ngamma_1, Ndis_1, nw, nt1 - Integer, optional :: L_cov - - ! Local - Integer lp, NSims, ns, nb, nc, Nwarm, nalp1, nalp2, Nex, p_star, Ndis_table, & - & io_error, io_error1, i - Real (Kind=8), Allocatable :: Xn_M_tot(:,:), En_M_tot(:), Xn_E_tot(:,:), En_E_tot(:), & - & Xn_tot(:,:,:), En_tot(:) - Real (Kind=8), Allocatable :: G_Mean(:), Xn_m(:), Xn_e(:), Xn(:,:), Vhelp(:) - Real (Kind=8) :: Ranf, En_M, Res, X, Alpha, Acc_1, Acc_2, En, DeltaE, Ratio, D - Real (Kind=8) :: Aom, om, XMAX, tau - Real (Kind=8) :: CPUT, CPUTM - Integer :: ICPU_1, ICPU_2, N_P_SEC - Character (64) :: File_root, File1, File_conf, File_Aom - Real (Kind=8), allocatable :: Xker_table(:,:), U(:,:), sigma(:) - Pi = acos(-1.d0) - NDis = Ndis_1 - DeltaXMAX = 0.01 - delta = 0.001 - delta2 = delta*delta - Ngamma = Ngamma_1 - Beta = Beta_1 ! Physical temperature for calculation of the kernel. - Ntau = Size(xqmc,1) - NSims = Size(Alpha_tot,1) - Allocate (Xn_tot(Ngamma,2,NSims)) - Allocate (En_m_tot(NSims), En_e_tot(NSims), En_tot(NSims) ) - Allocate (Xn_m_tot(NDis,NSims), Xn_e_tot(NDis,NSims) ) - Allocate (Xn(Ngamma,2)) - Allocate (Xn_m(NDis), Xn_e(NDis) ) - Om_st_1 = OM_st; Om_en_1 = OM_en - ! Setup table for the Kernel - Ndis_table = 50000 - Dom = (OM_EN_1 - OM_ST_1)/dble(Ndis_table-1) - Allocate ( Xker_table(Ntau, Ndis_table) ) - do nt = 1,Ntau - do nw = 1,Ndis_table - tau = xtau(nt) - Om = OM_st + dble(nw-1)*dom - Xker_table(nt,nw) = Xker(tau,om,beta) - enddo - enddo - ! Normalize data to have zeroth moment of unity. - xqmc = xqmc / XMOM1 - cov = cov / ((XMOM1)**2) - ! Diagonalize the covariance - Allocate( U(ntau,ntau), Sigma(ntau), xqmc1(Ntau) ) - If ( Present(L_cov) ) then - Call Diag(cov,U,sigma) - ! Write(6,*) " Cov Used" - else - Write(6,*) "No Cov Used" - U = 0.d0 - do nt = 1,ntau - U(nt,nt) = 1.d0 - sigma(nt) = cov(nt,nt) - enddo - endif - do nt = 1,ntau - sigma(nt) = sqrt(sigma(nt)) - enddo - xqmc1 = 0.d0 - do nt1 = 1,ntau - do nt = 1,ntau - xqmc1(nt1) = xqmc1(nt1) + xqmc(nt)*U(nt,nt1) - enddo - xqmc1(nt1) = xqmc1(nt1)/sigma(nt1) - enddo - ! Transform the Kernel - allocate ( Vhelp(Ntau) ) - do nw = 1,Ndis_table - Vhelp = 0.d0 - do nt1 = 1,Ntau - do nt = 1,Ntau - Vhelp(nt1) = Vhelp(nt1) + Xker_table(nt,nw)*U(nt,nt1) - enddo - enddo - do nt1 = 1,ntau - Xker_table(nt1,nw) = Vhelp(nt1)/sigma(nt1) !! This has changed !! - enddo - enddo - deallocate( U, Sigma ) - Allocate ( G_Mean(Ntau) ) - G_mean = 0.d0 -! write(6,*) ' There are ', Ngamma,' delta-functions for a spectrum' -! Write(6,*) ' Initializing' - ! D(om) = 1/(Om_en_1 - Om_st_1) - D = 1.d0 / (Om_en_1 - Om_st_1) - Iseed = 8752143 - File_conf = "dump_conf" - File_Aom = "dump_Aom" - Open(unit=41,file=File_conf,status='old',action='read', iostat=io_error) - Open(unit=42,file=File_Aom, status='old',action='read', iostat=io_error1) - If (io_error == 0 .and. io_error1 == 0 ) then - Nwarm = 0 - read(41,*) Iseed - do ns = 1,Nsims - do ng = 1,Ngamma - read(41,*) Xn_tot(ng,1,ns), Xn_tot(ng,2,ns) - enddo - read(41,*) En_m_tot(ns), En_e_tot(ns) - enddo - read(42,*) nc - do ns = 1,Nsims - do nd = 1,Ndis - read(42,*) Xn_m_tot(nd,ns), Xn_e_tot(nd,ns) - enddo - enddo - Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") - Write(44,*) 'Read from dump: nc = ', nc - close(44) - else - !Iseed is alrady set. - Do Ns = 1,NSims - do ng = 1,NGamma - Xn_tot(ng,1,ns) = ranf(iseed) - Xn_tot(ng,2,ns) = 1.d0/dble(Ngamma) - enddo - enddo - Xn_m_tot = 0.d0 - En_m_tot = 0.d0 - Xn_e_tot = 0.d0 - En_e_tot = 0.d0 - nc = 0 - Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") - Write(44,*) ' No dump data ' - close(44) - endif - close(41) - close(42) - CALL SYSTEM_CLOCK(COUNT_RATE=N_P_SEC) - CALL SYSTEM_CLOCK(COUNT=ICPU_1) - ! Start Simulations. - do Nb = 1,Nbins - do ns = 1,NSims - do ng = 1,Ngamma - Xn(ng,1) = Xn_tot(ng,1,ns) - Xn(ng,2) = Xn_tot(ng,2,ns) - enddo - Alpha = Alpha_tot(ns) - Call MC(Xtau, Xker_table, Xn, Alpha, NSweeps, Xn_m, En, En_m, & - & Acc_1, Acc_2 ) ! Just one bin - do ng = 1,Ngamma - Xn_tot(ng,1,ns) = Xn(ng,1) - Xn_tot(ng,2,ns) = Xn(ng,2) - enddo - En_tot(ns) = En ! this is the energy of the configuration Xn_tot for simulation ns - Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") - Write(44,2003) 1.d0/Alpha, En_m, Acc_1, Acc_2 - close(44) - if (nb.gt.nwarm) then - if (ns.eq.1) nc = nc + 1 - do nd = 1,NDis - Xn_m(nd) = Xn_m(nd) * D * dble(Ndis) - Xn_m_tot(nd,ns) = Xn_m_tot(nd,ns) + Xn_m(nd) - Xn_e_tot(nd,ns) = Xn_e_tot(nd,ns) + Xn_m(nd)*Xn_m(nd) - enddo - En_m_tot(ns) = En_m_tot(ns) + En_m - En_e_tot(ns) = En_e_tot(ns) + En_m*En_m - endif - enddo - ! Exchange - Acc_1 = 0.d0 - Do Nex = 1, 2*NSims - nalp1= nint( ranf(iseed)*dble(NSims-1) + 0.5 ) ! 1..(NSims-1) - nalp2 = nalp1 + 1 - DeltaE = (Alpha_tot(nalp1)*En_tot(nalp2) + Alpha_tot(nalp2)*En_tot(nalp1))& - & -(Alpha_tot(nalp1)*En_tot(nalp1) + Alpha_tot(nalp2)*En_tot(nalp2)) - Ratio = exp(-DeltaE) - if (Ratio.gt.ranf(iseed)) Then - Acc_1 = Acc_1 + 1.0 - !Switch confs an Energies. - do ng = 1,Ngamma - Xn(ng,1) = Xn_tot(ng,1,nalp1) - Xn(ng,2) = Xn_tot(ng,2,nalp1) - enddo - do ng = 1,Ngamma - Xn_tot(ng,1,nalp1) = Xn_tot(ng,1,nalp2) - Xn_tot(ng,2,nalp1) = Xn_tot(ng,2,nalp2) - Xn_tot(ng,1,nalp2) = Xn(ng,1) - Xn_tot(ng,2,nalp2) = Xn(ng,2) - enddo - En_m = En_tot(nalp1) - En_tot(nalp1) = En_tot(nalp2) - En_tot(nalp2) = En_m - endif - enddo - Acc_1 = Acc_1/dble(Nex) - Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") - Write(44,*) 'Acc Exchange: ', Acc_1 - close(44) - enddo - CALL SYSTEM_CLOCK(COUNT=ICPU_2) - CPUT = 0.D0 - CPUT = DBLE(ICPU_2 - ICPU_1)/DBLE(N_P_SEC) - Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") - Write(44,*) 'Total time: ', CPUT - close(44) - ! dump so as to restart. - Open(unit=41,file=File_conf,status='unknown') - Open(unit=42,file=File_Aom, status='unknown') - write(41,*) Iseed - do ns = 1,Nsims - do ng = 1,Ngamma - write(41,*) Xn_tot(ng,1,ns), Xn_tot(ng,2,ns) - enddo - write(41,*) En_m_tot(ns), En_e_tot(ns) - enddo - write(42,*) nc - do ns = 1,Nsims - do nd = 1,Ndis - write(42,*) Xn_m_tot(nd,ns), Xn_e_tot(nd,ns) - enddo - enddo - close(41) - close(42) - ! Stop dump - Open(Unit=66,File="energies",status="unknown") - do ns = 1,Nsims - En_m_tot(ns) = En_m_tot(ns) / dble(nc) - En_e_tot(ns) = En_e_tot(ns) / dble(nc) - En_e_tot(ns) = ( En_e_tot(ns) - En_m_tot(ns)**2)/dble(nc) - if ( En_e_tot(ns) .gt. 0.d0) then - En_e_tot(ns) = sqrt(En_e_tot(ns)) - else - En_e_tot(ns) = 0.d0 - endif - write(66,*) Alpha_tot(ns), En_m_tot(ns), En_e_tot(ns) - enddo - close(66) - File_root = "Aom" - do ns = 1,Nsims - File1 = File_i(File_root,ns) - Open(Unit=66,File=File1,status="unknown") - do nd = 1,Ndis - Xn_m_tot(nd,ns) = Xn_m_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) - Xn_e_tot(nd,ns) = Xn_e_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) - Xn_e_tot(nd,ns) = (Xn_e_tot(nd,ns) - Xn_m_tot(nd,ns)* Xn_m_tot(nd,ns))/dble(nc) - if (Xn_e_tot(nd,ns).gt.0.d0) then - Xn_e_tot(nd,ns) = sqrt(Xn_e_tot(nd,ns)) - else - Xn_e_tot(nd,ns) = 0.d0 - endif - om = PhiM1(dble(nd)/dble(NDis)) - Aom = Xn_m_tot(nd,ns) * Xmom1 - Err = Xn_e_tot(nd,ns) * Xmom1 - write(66,2001) om, Back_Trans_Aom(Aom,Beta,om), Back_Trans_Aom(Err,Beta,om) - ! PhiM1(dble(nd)/dble(NDis)), Xn_m_tot(nd,ns) - enddo - Close(66) - enddo - ! Now do the averaging. - File_root ="Aom_ps" - do p_star = 1,NSims - 10 - Xn_m = 0.0 - Xn_e = 0.0 - do ns = p_star, NSims-1 - do nd = 1, NDis - Xn_m(nd) = Xn_m(nd) + (En_m_tot(ns) - En_m_tot(ns+1))*Xn_m_tot(nd,ns) - Xn_e(nd) = Xn_e(nd) + (En_m_tot(ns) - En_m_tot(ns+1))*Xn_e_tot(nd,ns) - enddo - enddo - do nd = 1,NDis - Xn_m(nd) = Xn_m(nd) / (En_m_tot(p_star) - En_m_tot(NSims)) - Xn_e(nd) = Xn_e(nd) / (En_m_tot(p_star) - En_m_tot(NSims)) - enddo - File1 = File_i(File_root,p_star) - Open(Unit=66,File=File1,status="unknown") - XMAX = 0.d0 - Do nd = 1,Ndis - om = PhiM1(dble(nd)/dble(NDis)) - Aom = Xn_m(nd) * Xmom1 - Err = Xn_e(nd) * Xmom1 - Xn_m(nd) = Back_Trans_Aom(Aom,Beta,om) - Xn_e(nd) = Back_Trans_Aom(Err,Beta,om) - IF (Xn_m(nd) .gt. XMAX ) XMAX = Xn_m(nd) - enddo - do nd = 1,Ndis - om = PhiM1(dble(nd)/dble(NDis)) - write(66,2005) om, Xn_m(nd), Xn_e(nd), Xn_m(nd)/XMAX, Xn_e(nd)/XMAX - ! PhiM1(dble(nd)/dble(NDis)), Xn_m(nd) - enddo - close(66) - enddo - Open (Unit=41,File='Best_fit', Status="unknown") - do ng = 1,Ngamma - Write(41,*) Phim1(Xn_tot(ng,1,Nsims)) , Xn_tot(ng,2,Nsims) - enddo - close(41) - DeAllocate (Xn_tot) - DeAllocate (En_m_tot, En_e_tot, En_tot ) - DeAllocate (Xn_m_tot, Xn_e_tot ) - DeAllocate (Xn) - DeAllocate (Xn_m, Xn_e) - DeAllocate( G_Mean ) - DeAllocate( xqmc1 ) - Deallocate( Xker_table ) -2001 format(F14.7,2x,F14.7,2x,F14.7) -2004 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7) -2005 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7,2x,F14.7) -2003 format('Alpha, En_m, Acc ', F14.7,2x,F14.7,2x,F14.7,2x,F14.7,2x,F14.7) - end Subroutine MaxEnt_stoch -!------------------- - Subroutine MaxEnt_stoch_fit(XQMC, Xtau, COV, Lcov, XKER, Xmom1, Beta_1, Alpha_tot,& - & Ngamma_1, OM_ST, OM_EN, Nsweeps, NBins, NWarm, Aom_res,& - & xom_res, Chisq ) - Implicit None - Real (Kind=8), Dimension(:) :: XQMC, Xtau, Alpha_tot, Aom_res, Xom_res - Real (Kind=8), Dimension(:,:) :: COV - Real (Kind=8), external :: XKER - Real (Kind=8) :: CHISQ, OM_ST, OM_EN, Beta_1, Xmom1, Err - Integer :: Nsweeps, NBins, Ngamma_1, Ndis_1, nw, nt1, Lcov - ! Local - Integer lp, NSims, ns, nb, nc, Nwarm, nalp1, nalp2, Nex, p_star - Real (Kind=8), Allocatable :: Xn_M_tot(:,:), En_M_tot(:), Xn_E_tot(:,:), En_E_tot(:), & - & Xn_tot(:,:,:), En_tot(:), Xker_table(:,:) - Real (Kind=8), Allocatable :: G_Mean(:), Xn_m(:), Xn_e(:), Xn(:,:), Vhelp(:) - Real (Kind=8) :: Ranf, En_M, Res, X, Alpha, Acc_1, Acc_2, En, DeltaE, Ratio, D - Real (Kind=8) :: Aom, om, XMAX, tau - Real (Kind=8), allocatable :: U(:,:), sigma(:) - Pi = acos(-1.d0) - Iseed = 8752143 - NDis = Size(Aom_res,1) - DeltaXMAX = 0.01 - delta = 0.001 - delta2 = delta*delta - Ngamma = Ngamma_1 - Beta = Beta_1 ! Physical temperature for calculation of the kernel. - Ntau = Size(xqmc,1) - NSims = Size(Alpha_tot,1) - Allocate (Xn_tot(Ngamma,2,NSims)) - Allocate (En_m_tot(NSims), En_e_tot(NSims), En_tot(NSims) ) - Allocate (Xn_m_tot(NDis,NSims), Xn_e_tot(NDis,NSims) ) - Allocate (Xn(Ngamma,2)) - Allocate (Xn_m(NDis), Xn_e(NDis) ) - Om_st_1 = OM_st; Om_en_1 = OM_en - ! Setup table for the Kernel - Ndis = Size(Aom_res) - Dom = (OM_EN_1 - OM_ST_1)/dble(Ndis-1) - Allocate ( Xker_table(Ntau, Ndis) ) - Dom = (OM_EN - OM_ST)/dble(Ndis-1) - do nt = 1,Ntau - do nw = 1,Ndis - tau = xtau(nt) - Om = OM_st + dble(nw-1)*dom - Xker_table(nt,nw) = Xker(tau,om,beta) - enddo - enddo - ! Normalize data to have zeroth moment of unity. - xqmc = xqmc / XMOM1 - cov = cov / ((XMOM1)**2) - ! Diagonalize the covariance - If (Lcov.eq.1) then - Allocate( U(ntau,ntau), Sigma(ntau), xqmc1(Ntau) ) - Call Diag(cov,U,sigma) - do nt = 1,ntau - sigma(nt) = sqrt(sigma(nt)) - enddo - xqmc1 = 0.d0 - do nt1 = 1,ntau - do nt = 1,ntau - xqmc1(nt1) = xqmc1(nt1) + xqmc(nt)*U(nt,nt1) - enddo - xqmc1(nt1) = xqmc1(nt1)/sigma(nt1) - enddo - ! Transform the Kernel - allocate ( Vhelp(Ntau) ) - do nw = 1,Ndis - Vhelp = 0.d0 - do nt1 = 1,Ntau - do nt = 1,Ntau - Vhelp(nt1) = Vhelp(nt1) + Xker_table(nt,nw)*U(nt,nt1) - enddo - enddo - do nt1 = 1,ntau - Xker_table(nt1,nw) = Vhelp(nt1)/sigma(nt1) !! This has changed !! - enddo - enddo - Deallocate (U,sigma) - else - Allocate( Sigma(ntau), xqmc1(Ntau) ) - !Call Diag(cov,U,sigma) - do nt = 1,ntau - sigma(nt) = 1.d0/sqrt(cov(nt,nt)) - enddo - xqmc1 = 0.d0 - do nt1 = 1,ntau - xqmc1(nt1) = xqmc(nt1)*sigma(nt1) - enddo - ! Transform the Kernel - allocate ( Vhelp(Ntau) ) - do nw = 1,Ndis - do nt1 = 1,ntau - Xker_table(nt1,nw) = Xker_table(nt1,nw)*sigma(nt1) !! This has changed !! - enddo - enddo - deallocate(Sigma) - endif - Allocate(G_Mean(Ntau)) - G_mean = 0.d0 -! write(6,*) ' There are ', Ngamma,' delta-functions for a spectrum' -! Write(6,*) ' Initializing' - Do Ns = 1,NSims - do ng = 1,NGamma - Xn_tot(ng,1,ns) = ranf(iseed) - Xn_tot(ng,2,ns) = 1.d0/dble(Ngamma) - enddo - enddo - Xn_m_tot = 0.d0 - En_m_tot = 0.d0 - Xn_e_tot = 0.d0 - En_e_tot = 0.d0 - ! D(om) = 1/(Om_en_1 - Om_st_1) - D = 1.d0 / (Om_en_1 - Om_st_1) - Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") - Write(44,*) "N E W R U N " - nc = 0 - do Nb = 1,Nbins - do ns = 1,NSims - do ng = 1,Ngamma - Xn(ng,1) = Xn_tot(ng,1,ns) - Xn(ng,2) = Xn_tot(ng,2,ns) - enddo - Alpha = Alpha_tot(ns) - Call MC(Xtau, Xker_table, Xn, Alpha, NSweeps, Xn_m, En, En_m, & - & Acc_1, Acc_2 ) ! Just one bin - do ng = 1,Ngamma - Xn_tot(ng,1,ns) = Xn(ng,1) - Xn_tot(ng,2,ns) = Xn(ng,2) - enddo - En_tot(ns) = En ! this is the energy of the configuration Xn_tot for simulation ns - Write(44,2003) 1.d0/Alpha, En_m, Acc_1, Acc_2 - if (nb.gt.nwarm) then - if (ns.eq.1) nc = nc + 1 - do nd = 1,NDis - Xn_m(nd) = Xn_m(nd) * D * dble(Ndis) - Xn_m_tot(nd,ns) = Xn_m_tot(nd,ns) + Xn_m(nd) - Xn_e_tot(nd,ns) = Xn_e_tot(nd,ns) + Xn_m(nd)*Xn_m(nd) - enddo - En_m_tot(ns) = En_m_tot(ns) + En_m - En_e_tot(ns) = En_e_tot(ns) + En_m*En_m - endif - enddo - ! Exchange - Acc_1 = 0.d0 - Do Nex = 1, 2*NSims - nalp1= nint( ranf(iseed)*dble(NSims-1) + 0.5 ) ! 1..(NSims-1) - nalp2 = nalp1 + 1 - DeltaE = (Alpha_tot(nalp1)*En_tot(nalp2) + Alpha_tot(nalp2)*En_tot(nalp1))& - & -(Alpha_tot(nalp1)*En_tot(nalp1) + Alpha_tot(nalp2)*En_tot(nalp2)) - Ratio = exp(-DeltaE) - if (Ratio.gt.ranf(iseed)) Then - Acc_1 = Acc_1 + 1.0 - !Switch confs an Energies. - do ng = 1,Ngamma - Xn(ng,1) = Xn_tot(ng,1,nalp1) - Xn(ng,2) = Xn_tot(ng,2,nalp1) - enddo - do ng = 1,Ngamma - Xn_tot(ng,1,nalp1) = Xn_tot(ng,1,nalp2) - Xn_tot(ng,2,nalp1) = Xn_tot(ng,2,nalp2) - Xn_tot(ng,1,nalp2) = Xn(ng,1) - Xn_tot(ng,2,nalp2) = Xn(ng,2) - enddo - En_m = En_tot(nalp1) - En_tot(nalp1) = En_tot(nalp2) - En_tot(nalp2) = En_m - endif - enddo - Acc_1 = Acc_1/dble(Nex) - Write(44,*) 'Acc Exchange: ', Acc_1 - enddo - !Open(Unit=66,File="energies",status="unknown") - do ns = Nsims,Nsims - En_m_tot(ns) = En_m_tot(ns) / dble(nc) - En_e_tot(ns) = En_e_tot(ns) / dble(nc) - En_e_tot(ns) = ( En_e_tot(ns) - En_m_tot(ns)**2)/dble(nc) - if ( En_e_tot(ns) .gt. 0.d0) then - En_e_tot(ns) = sqrt(En_e_tot(ns)) - else - En_e_tot(ns) = 0.d0 - endif - !write(66,*) Alpha_tot(ns), En_m_tot(ns), En_e_tot(ns) - enddo - !close(60) - Chisq = En_e_tot(Nsims) - Close(44) - do ns = Nsims,Nsims - do nd = 1,Ndis - Xn_m_tot(nd,ns) = Xn_m_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) - Xn_e_tot(nd,ns) = Xn_e_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) - Xn_e_tot(nd,ns) = (Xn_e_tot(nd,ns) - Xn_m_tot(nd,ns)* Xn_m_tot(nd,ns))/dble(nc) - if (Xn_e_tot(nd,ns).gt.0.d0) then - Xn_e_tot(nd,ns) = sqrt(Xn_e_tot(nd,ns)) - else - Xn_e_tot(nd,ns) = 0.d0 - endif - om = PhiM1(dble(nd)/dble(NDis)) - Aom = Xn_m_tot(nd,ns) * Xmom1 - Err = Xn_e_tot(nd,ns) * Xmom1 - !write(66,2001) om, Aom, Err - if (ns.eq.Nsims) then - Aom_res(nd) = Aom - xom_res(nd) = om - endif - enddo - !Close(66) - enddo - ! Reset the input data - xqmc = XMOM1* xqmc - cov = ((XMOM1)**2)* cov - DeAllocate (Xn_tot) - DeAllocate (En_m_tot, En_e_tot, En_tot ) - DeAllocate (Xn_m_tot, Xn_e_tot ) - DeAllocate (Xn) - DeAllocate (Xn_m, Xn_e) - DeAllocate( G_Mean ) - DeAllocate( xqmc1 ) - Deallocate( Xker_table ) -2001 format(F14.7,2x,F14.7,2x,F14.7) -2004 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7) -2005 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7,2x,F14.7) -2003 format('Alpha, En_m, Acc ', F14.7,2x,F14.7,2x,F14.7,2x,F14.7,2x,F14.7) - end Subroutine MaxEnt_stoch_fit -!*********** - Real (Kind=8) Function Phim1(x) - Implicit None - ! Flat Default with sum 1. This is the correct sum rule for the data! - ! D(om) = 1/(Om_en_1 - Om_st_1) - Real (Kind=8) :: x - PhiM1 = x*(Om_en_1 - Om_st_1) + Om_st_1 - end Function Phim1 - Integer Function NPhim1(x) - Implicit None - ! Flat Default with sum 1. This is the correct sum rule for the data! - ! D(om) = 1/(Om_en_1 - Om_st_1) - Real (Kind=8) :: x, om - om = x*(Om_en_1 - Om_st_1) + Om_st_1 - NPhiM1 = Nint ( (om - Om_st_1)/Dom + 0.75 ) - end Function NPhim1 -!*********** - Subroutine Sum_Xn(Xn_m,Xn) - Implicit none - Real (Kind=8), Dimension(:,:) :: Xn - Real (Kind=8), Dimension(:) :: Xn_m - Real (Kind=8) :: X - do nd = 1,NDis - X = dble( nd )/dble( NDis ) - do ng = 1,Ngamma - Xn_m(nd) = Xn_m(nd) + Xn(ng,2)/( (X-Xn(ng,1))**2 + Delta2) - !aimag( cmplx(Xn(ng,2),0.d0)/cmplx( X-Xn(ng,1), -Delta) ) - enddo - enddo - end Subroutine Sum_Xn -!*********** - Subroutine Sum_Xn_Boxes(Xn_m,Xn) - Implicit none - Real (Kind=8), Dimension(:,:) :: Xn - Real (Kind=8), Dimension(:) :: Xn_m - Real (Kind=8) :: X - do ng = 1,Ngamma - X = Xn(ng,1) - nd = Nint(dble(NDis)*X + 0.5 ) - Xn_m(nd) = Xn_m(nd) + Xn(ng,2) - Enddo - end Subroutine Sum_Xn_Boxes -!*********** - Subroutine MC(Xtau, Xker_table, Xn, Alpha, NSweeps, Xn_m, En, En_m, Acc_1,Acc_2) - !Implicit Real (KIND=8) (A-G,O-Z) - !Implicit Integer (H-N) - Implicit None - Real (Kind=8), Dimension(:,:) :: Xn, Xker_table - Real (Kind=8), Dimension(:) :: Xtau, Xn_m - Real (Kind=8) :: Alpha, En_m, s, ratio, ranf, A_gamma, Z_gamma, Acc_1, Acc_2 - Integer :: NSweeps, nl, Lambda_max, ng1, ng2 - !Local - Real (Kind=8), Allocatable :: h(:), Deltah(:), A_gamma_p(:), Z_gamma_p(:), & - & A_gamma_o(:), Z_gamma_o(:) - Real (Kind=8), Allocatable :: XKER_stor(:,:), XKER_new(:) - Real (Kind=8) :: X, En, En1, DeltaE, XP, XM, om - Integer, Allocatable :: Lambda(:) - Integer :: nb, nsw, Nacc_1, Nacc_2, nw - Allocate (h(ntau), Deltah(ntau) ) - Allocate (Lambda(2), Z_gamma_p(2), A_gamma_p(2), & - & Z_gamma_o(2), A_gamma_o(2) ) ! Max of moves of two walkers. - Allocate ( XKer_stor(Ntau,Ngamma), XKer_New(Ntau) ) - Xn_m = 0.d0 - En_m = 0.d0 - ! Setup h(tau) - do nt = 1,Ntau - X = 0.d0 - do ng = 1,Ngamma - A_gamma = xn(ng,1) - Z_gamma = xn(ng,2) - XKer_stor( nt, ng ) = XKER_table(nt, NPhiM1(A_gamma) ) - ! XKER(xtau(nt),PhiM1(A_gamma),beta) - X = X + Xker_stor(nt,ng)*Z_gamma - enddo - h(nt) = X - xqmc1(nt) - enddo - NAcc_1 = 0; NAcc_2 = 0; - do nsw = 1,Nsweeps - ! Weight sharing moves. - do ng = 1,Ngamma - x = ranf(iseed) - if (x.gt.0.5) then - ! Weight sharing moves. - Lambda_max = 2 - Lambda(1) = nint(ranf(iseed)*dble(Ngamma) + 0.5) - do - Lambda(2) = nint(ranf(iseed)*dble(Ngamma) + 0.5) - if ( Lambda(2) .ne. Lambda(1) ) exit - enddo - ng1 = Lambda(1) - ng2 = Lambda(2) - A_gamma_o(1) = Xn(ng1,1) - A_gamma_o(2) = Xn(ng2,1) - Z_gamma_o(1) = Xn(ng1,2) - Z_gamma_o(2) = Xn(ng2,2) - A_gamma_p(1) = Xn(ng1,1) - A_gamma_p(2) = Xn(ng2,1) - s = (Z_gamma_o(1) + Z_gamma_o(2))*ranf(iseed) - Z_gamma_o(1) - Z_gamma_p(1) = Z_gamma_o(1) + s - Z_gamma_p(2) = Z_gamma_o(2) - s - ! Kernel stays unchanged. - ! Compute Delta H - do nt = 1,ntau - X = Xker_stor(nt,ng1)*( Z_gamma_p(1) - Z_gamma_o(1) ) + & - & Xker_stor(nt,ng2)*( Z_gamma_p(2) - Z_gamma_o(2) ) - Deltah(nt) = X - enddo - else - Lambda_max = 1 - Lambda(1) = nint(ranf(iseed)*dble(Ngamma) + 0.5) - ng1 = Lambda(1) - Z_gamma_o(1) = Xn(ng1,2) - Z_gamma_p(1) = Xn(ng1,2) - A_gamma_o(1) = Xn(ng1,1) - A_gamma_p(1) = xpbc( Xn(ng1,1) + (ranf(iseed) - 0.5)*DeltaXMAX, 1.d0 ) - !om = PhiM1(A_gamma_p(1)) - nw = NPhiM1(A_gamma_p(1)) - do nt = 1,ntau - Xker_new(nt) = Xker_table(nt,nw) ! Xker(xtau(nt),om, beta) - enddo - do nt = 1,ntau - X = ( Xker_new(nt) - Xker_stor(nt,ng1) ) * Z_gamma_o(1) - Deltah(nt) = X - enddo - endif - DeltaE = 0.d0 - do nt = 1,ntau - DeltaE = DeltaE + (Deltah(nt) + 2.0 * h(nt) ) *Deltah(nt) - enddo - Ratio = exp( -alpha * DeltaE ) - ! write(6,*) ' Ratio : ',Ratio, DeltaE - if (Ratio .gt. ranf(iseed)) Then - ! write(6,*) 'Accepted' - if (Lambda_max.eq.1) then - Nacc_1 = Nacc_1 + 1 - ng1 = Lambda(1) - do nt = 1,ntau - Xker_stor(nt,ng1) = Xker_new(nt) - enddo - endif - if (Lambda_max.eq.2) Nacc_2 = Nacc_2 + 1 - do nl = 1,Lambda_max - Xn(Lambda(nl),1) = A_gamma_p(nl) - Xn(Lambda(nl),2) = Z_gamma_p(nl) - enddo - do nt = 1,ntau - h(nt) = h(nt) + Deltah(nt) - enddo - endif - enddo - En = 0.0 - do nt = 1,Ntau - En = En + h(nt)*h(nt) - enddo - En_m = En_m + En - Call Sum_Xn_Boxes( Xn_m, Xn ) - enddo - Acc_1 = dble(Nacc_1)/dble(Ngamma*NSweeps) - Acc_2 = dble(Nacc_2)/dble(Ngamma*NSweeps) - En_m = En_m/dble( nsweeps ) - Xn_m = Xn_m/dble( nsweeps ) - Deallocate ( h, Deltah ) - Deallocate ( Lambda, Z_gamma_p, A_gamma_p, Z_gamma_o, A_gamma_o ) - Deallocate ( XKER_stor, XKER_new ) -2005 format(I4,2x,I4,2x,F14.7,2x,F14.7,' --> ',F14.7,2x,F14.7) -2006 format(I4,2x,F14.7, ' --> ',F14.7) - end Subroutine MC -!********** - real (Kind=8) function xpbc(X,XL) - real (kind=8) :: X, XL - XPBC = X - if (X.GT. XL ) XPBC = X - XL - if (X.LT. 0.0) XPBC = X + XL - end function xpbc -end Module MaxEnt_stoch_mod diff --git a/Libraries/MyEis/Makefile b/Libraries/MyEis/Makefile deleted file mode 100644 index 90addb657..000000000 --- a/Libraries/MyEis/Makefile +++ /dev/null @@ -1,11 +0,0 @@ -LIB=libeis.a -OBJS=balanc.o cdiv.o comqr2.o eltran.o htribk.o rs.o\ -tred2.o balbak.o cg.o corth.o epslon.o htridi.o tql2.o\ -cbabk2.o ch.o csroot.o hqr.o pythag.o tqlrat.o\ -cbal.o comqr.o elmhes.o hqr2.o rg.o tred1.o -$(LIB): $(OBJS) - ar r $(LIB) $(OBJS) -.f.o: - $(FC) $(FLAGS) $< -clean: - rm $(LIB) $(OBJS) diff --git a/Libraries/MyEis/balanc.f b/Libraries/MyEis/balanc.f deleted file mode 100644 index 7addb368d..000000000 --- a/Libraries/MyEis/balanc.f +++ /dev/null @@ -1,166 +0,0 @@ - SUBROUTINE BALANC(NM,N,A,LOW,IGH,SCALE) -C - INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC - DOUBLE PRECISION A(NM,N),SCALE(N) - DOUBLE PRECISION C,F,G,R,S,B2,RADIX - LOGICAL NOCONV -C -C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BALANCE, -C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). -C -C THIS SUBROUTINE BALANCES A REAL MATRIX AND ISOLATES -C EIGENVALUES WHENEVER POSSIBLE. -C -C ON INPUT -C -C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL -C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM -C DIMENSION STATEMENT. -C -C N IS THE ORDER OF THE MATRIX. -C -C A CONTAINS THE INPUT MATRIX TO BE BALANCED. -C -C ON OUTPUT -C -C A CONTAINS THE BALANCED MATRIX. -C -C LOW AND IGH ARE TWO INTEGERS SUCH THAT A(I,J) -C IS EQUAL TO ZERO IF -C (1) I IS GREATER THAN J AND -C (2) J=1,...,LOW-1 OR I=IGH+1,...,N. -C -C SCALE CONTAINS INFORMATION DETERMINING THE -C PERMUTATIONS AND SCALING FACTORS USED. -C -C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH -C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED -C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS -C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN -C SCALE(J) = P(J), FOR J = 1,...,LOW-1 -C = D(J,J), J = LOW,...,IGH -C = P(J) J = IGH+1,...,N. -C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1, -C THEN 1 TO LOW-1. -C -C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY. -C -C THE ALGOL PROCEDURE EXC CONTAINED IN BALANCE APPEARS IN -C BALANC IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS -C K,L HAVE BEEN REVERSED.) -C -C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, -C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY -C -C THIS VERSION DATED AUGUST 1983. -C -C ------------------------------------------------------------------ -C - RADIX = 16.0D0 -C - B2 = RADIX * RADIX - K = 1 - L = N - GO TO 100 -C .......... IN-LINE PROCEDURE FOR ROW AND -C COLUMN EXCHANGE .......... - 20 SCALE(M) = J - IF (J .EQ. M) GO TO 50 -C - DO 30 I = 1, L - F = A(I,J) - A(I,J) = A(I,M) - A(I,M) = F - 30 CONTINUE -C - DO 40 I = K, N - F = A(J,I) - A(J,I) = A(M,I) - A(M,I) = F - 40 CONTINUE -C - 50 GO TO (80,130), IEXC -C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE -C AND PUSH THEM DOWN .......... - 80 IF (L .EQ. 1) GO TO 280 - L = L - 1 -C .......... FOR J=L STEP -1 UNTIL 1 DO -- .......... - 100 DO 120 JJ = 1, L - J = L + 1 - JJ -C - DO 110 I = 1, L - IF (I .EQ. J) GO TO 110 - IF (A(J,I) .NE. 0.0D0) GO TO 120 - 110 CONTINUE -C - M = L - IEXC = 1 - GO TO 20 - 120 CONTINUE -C - GO TO 140 -C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE -C AND PUSH THEM LEFT .......... - 130 K = K + 1 -C - 140 DO 170 J = K, L -C - DO 150 I = K, L - IF (I .EQ. J) GO TO 150 - IF (A(I,J) .NE. 0.0D0) GO TO 170 - 150 CONTINUE -C - M = K - IEXC = 2 - GO TO 20 - 170 CONTINUE -C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L .......... - DO 180 I = K, L - 180 SCALE(I) = 1.0D0 -C .......... ITERATIVE LOOP FOR NORM REDUCTION .......... - 190 NOCONV = .FALSE. -C - DO 270 I = K, L - C = 0.0D0 - R = 0.0D0 -C - DO 200 J = K, L - IF (J .EQ. I) GO TO 200 - C = C + DABS(A(J,I)) - R = R + DABS(A(I,J)) - 200 CONTINUE -C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW .......... - IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GO TO 270 - G = R / RADIX - F = 1.0D0 - S = C + R - 210 IF (C .GE. G) GO TO 220 - F = F * RADIX - C = C * B2 - GO TO 210 - 220 G = R * RADIX - 230 IF (C .LT. G) GO TO 240 - F = F / RADIX - C = C / B2 - GO TO 230 -C .......... NOW BALANCE .......... - 240 IF ((C + R) / F .GE. 0.95D0 * S) GO TO 270 - G = 1.0D0 / F - SCALE(I) = SCALE(I) * F - NOCONV = .TRUE. -C - DO 250 J = K, N - 250 A(I,J) = A(I,J) * G -C - DO 260 J = 1, L - 260 A(J,I) = A(J,I) * F -C - 270 CONTINUE -C - IF (NOCONV) GO TO 190 -C - 280 LOW = K - IGH = L - RETURN - END diff --git a/Libraries/MyEis/balbak.f b/Libraries/MyEis/balbak.f deleted file mode 100644 index c57a5c017..000000000 --- a/Libraries/MyEis/balbak.f +++ /dev/null @@ -1,75 +0,0 @@ - SUBROUTINE BALBAK(NM,N,LOW,IGH,SCALE,M,Z) -C - INTEGER I,J,K,M,N,II,NM,IGH,LOW - DOUBLE PRECISION SCALE(N),Z(NM,M) - DOUBLE PRECISION S -C -C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BALBAK, -C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). -C -C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL GENERAL -C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING -C BALANCED MATRIX DETERMINED BY BALANC. -C -C ON INPUT -C -C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL -C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM -C DIMENSION STATEMENT. -C -C N IS THE ORDER OF THE MATRIX. -C -C LOW AND IGH ARE INTEGERS DETERMINED BY BALANC. -C -C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS -C AND SCALING FACTORS USED BY BALANC. -C -C M IS THE NUMBER OF COLUMNS OF Z TO BE BACK TRANSFORMED. -C -C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGEN- -C VECTORS TO BE BACK TRANSFORMED IN ITS FIRST M COLUMNS. -C -C ON OUTPUT -C -C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE -C TRANSFORMED EIGENVECTORS IN ITS FIRST M COLUMNS. -C -C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, -C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY -C -C THIS VERSION DATED AUGUST 1983. -C -C ------------------------------------------------------------------ -C - IF (M .EQ. 0) GO TO 200 - IF (IGH .EQ. LOW) GO TO 120 -C - DO 110 I = LOW, IGH - S = SCALE(I) -C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED -C IF THE FOREGOING STATEMENT IS REPLACED BY -C S=1.0D0/SCALE(I). .......... - DO 100 J = 1, M - 100 Z(I,J) = Z(I,J) * S -C - 110 CONTINUE -C ......... FOR I=LOW-1 STEP -1 UNTIL 1, -C IGH+1 STEP 1 UNTIL N DO -- .......... - 120 DO 140 II = 1, N - I = II - IF (I .GE. LOW .AND. I .LE. IGH) GO TO 140 - IF (I .LT. LOW) I = LOW - II - K = SCALE(I) - IF (K .EQ. I) GO TO 140 -C - DO 130 J = 1, M - S = Z(I,J) - Z(I,J) = Z(K,J) - Z(K,J) = S - 130 CONTINUE -C - 140 CONTINUE -C - 200 RETURN - END diff --git a/Libraries/MyEis/cbabk2.f b/Libraries/MyEis/cbabk2.f deleted file mode 100644 index 631e60dbe..000000000 --- a/Libraries/MyEis/cbabk2.f +++ /dev/null @@ -1,83 +0,0 @@ - SUBROUTINE CBABK2(NM,N,LOW,IGH,SCALE,M,ZR,ZI) -C - INTEGER I,J,K,M,N,II,NM,IGH,LOW - DOUBLE PRECISION SCALE(N),ZR(NM,M),ZI(NM,M) - DOUBLE PRECISION S -C -C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE -C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK, -C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). -C -C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL -C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING -C BALANCED MATRIX DETERMINED BY CBAL. -C -C ON INPUT -C -C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL -C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM -C DIMENSION STATEMENT. -C -C N IS THE ORDER OF THE MATRIX. -C -C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL. -C -C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS -C AND SCALING FACTORS USED BY CBAL. -C -C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. -C -C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, -C RESPECTIVELY, OF THE EIGENVECTORS TO BE -C BACK TRANSFORMED IN THEIR FIRST M COLUMNS. -C -C ON OUTPUT -C -C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, -C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS -C IN THEIR FIRST M COLUMNS. -C -C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, -C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY -C -C THIS VERSION DATED AUGUST 1983. -C -C ------------------------------------------------------------------ -C - IF (M .EQ. 0) GO TO 200 - IF (IGH .EQ. LOW) GO TO 120 -C - DO 110 I = LOW, IGH - S = SCALE(I) -C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED -C IF THE FOREGOING STATEMENT IS REPLACED BY -C S=1.0D0/SCALE(I). .......... - DO 100 J = 1, M - ZR(I,J) = ZR(I,J) * S - ZI(I,J) = ZI(I,J) * S - 100 CONTINUE -C - 110 CONTINUE -C .......... FOR I=LOW-1 STEP -1 UNTIL 1, -C IGH+1 STEP 1 UNTIL N DO -- .......... - 120 DO 140 II = 1, N - I = II - IF (I .GE. LOW .AND. I .LE. IGH) GO TO 140 - IF (I .LT. LOW) I = LOW - II - K = SCALE(I) - IF (K .EQ. I) GO TO 140 -C - DO 130 J = 1, M - S = ZR(I,J) - ZR(I,J) = ZR(K,J) - ZR(K,J) = S - S = ZI(I,J) - ZI(I,J) = ZI(K,J) - ZI(K,J) = S - 130 CONTINUE -C - 140 CONTINUE -C - 200 RETURN - END diff --git a/Libraries/MyEis/cbal.f b/Libraries/MyEis/cbal.f deleted file mode 100644 index bfc297790..000000000 --- a/Libraries/MyEis/cbal.f +++ /dev/null @@ -1,181 +0,0 @@ - SUBROUTINE CBAL(NM,N,AR,AI,LOW,IGH,SCALE) -C - INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC - DOUBLE PRECISION AR(NM,N),AI(NM,N),SCALE(N) - DOUBLE PRECISION C,F,G,R,S,B2,RADIX - LOGICAL NOCONV -C -C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE -C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE, -C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). -C -C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES -C EIGENVALUES WHENEVER POSSIBLE. -C -C ON INPUT -C -C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL -C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM -C DIMENSION STATEMENT. -C -C N IS THE ORDER OF THE MATRIX. -C -C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, -C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED. -C -C ON OUTPUT -C -C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, -C RESPECTIVELY, OF THE BALANCED MATRIX. -C -C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J) -C ARE EQUAL TO ZERO IF -C (1) I IS GREATER THAN J AND -C (2) J=1,...,LOW-1 OR I=IGH+1,...,N. -C -C SCALE CONTAINS INFORMATION DETERMINING THE -C PERMUTATIONS AND SCALING FACTORS USED. -C -C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH -C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED -C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS -C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN -C SCALE(J) = P(J), FOR J = 1,...,LOW-1 -C = D(J,J) J = LOW,...,IGH -C = P(J) J = IGH+1,...,N. -C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1, -C THEN 1 TO LOW-1. -C -C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY. -C -C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN -C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS -C K,L HAVE BEEN REVERSED.) -C -C ARITHMETIC IS REAL THROUGHOUT. -C -C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, -C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY -C -C THIS VERSION DATED AUGUST 1983. -C -C ------------------------------------------------------------------ -C - RADIX = 16.0D0 -C - B2 = RADIX * RADIX - K = 1 - L = N - GO TO 100 -C .......... IN-LINE PROCEDURE FOR ROW AND -C COLUMN EXCHANGE .......... - 20 SCALE(M) = J - IF (J .EQ. M) GO TO 50 -C - DO 30 I = 1, L - F = AR(I,J) - AR(I,J) = AR(I,M) - AR(I,M) = F - F = AI(I,J) - AI(I,J) = AI(I,M) - AI(I,M) = F - 30 CONTINUE -C - DO 40 I = K, N - F = AR(J,I) - AR(J,I) = AR(M,I) - AR(M,I) = F - F = AI(J,I) - AI(J,I) = AI(M,I) - AI(M,I) = F - 40 CONTINUE -C - 50 GO TO (80,130), IEXC -C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE -C AND PUSH THEM DOWN .......... - 80 IF (L .EQ. 1) GO TO 280 - L = L - 1 -C .......... FOR J=L STEP -1 UNTIL 1 DO -- .......... - 100 DO 120 JJ = 1, L - J = L + 1 - JJ -C - DO 110 I = 1, L - IF (I .EQ. J) GO TO 110 - IF (AR(J,I) .NE. 0.0D0 .OR. AI(J,I) .NE. 0.0D0) GO TO 120 - 110 CONTINUE -C - M = L - IEXC = 1 - GO TO 20 - 120 CONTINUE -C - GO TO 140 -C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE -C AND PUSH THEM LEFT .......... - 130 K = K + 1 -C - 140 DO 170 J = K, L -C - DO 150 I = K, L - IF (I .EQ. J) GO TO 150 - IF (AR(I,J) .NE. 0.0D0 .OR. AI(I,J) .NE. 0.0D0) GO TO 170 - 150 CONTINUE -C - M = K - IEXC = 2 - GO TO 20 - 170 CONTINUE -C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L .......... - DO 180 I = K, L - 180 SCALE(I) = 1.0D0 -C .......... ITERATIVE LOOP FOR NORM REDUCTION .......... - 190 NOCONV = .FALSE. -C - DO 270 I = K, L - C = 0.0D0 - R = 0.0D0 -C - DO 200 J = K, L - IF (J .EQ. I) GO TO 200 - C = C + DABS(AR(J,I)) + DABS(AI(J,I)) - R = R + DABS(AR(I,J)) + DABS(AI(I,J)) - 200 CONTINUE -C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW .......... - IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GO TO 270 - G = R / RADIX - F = 1.0D0 - S = C + R - 210 IF (C .GE. G) GO TO 220 - F = F * RADIX - C = C * B2 - GO TO 210 - 220 G = R * RADIX - 230 IF (C .LT. G) GO TO 240 - F = F / RADIX - C = C / B2 - GO TO 230 -C .......... NOW BALANCE .......... - 240 IF ((C + R) / F .GE. 0.95D0 * S) GO TO 270 - G = 1.0D0 / F - SCALE(I) = SCALE(I) * F - NOCONV = .TRUE. -C - DO 250 J = K, N - AR(I,J) = AR(I,J) * G - AI(I,J) = AI(I,J) * G - 250 CONTINUE -C - DO 260 J = 1, L - AR(J,I) = AR(J,I) * F - AI(J,I) = AI(J,I) * F - 260 CONTINUE -C - 270 CONTINUE -C - IF (NOCONV) GO TO 190 -C - 280 LOW = K - IGH = L - RETURN - END diff --git a/Libraries/MyEis/cdiv.f b/Libraries/MyEis/cdiv.f deleted file mode 100644 index fdca82c97..000000000 --- a/Libraries/MyEis/cdiv.f +++ /dev/null @@ -1,16 +0,0 @@ - SUBROUTINE CDIV(AR,AI,BR,BI,CR,CI) - DOUBLE PRECISION AR,AI,BR,BI,CR,CI -C -C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI) -C - DOUBLE PRECISION S,ARS,AIS,BRS,BIS - S = DABS(BR) + DABS(BI) - ARS = AR/S - AIS = AI/S - BRS = BR/S - BIS = BI/S - S = BRS**2 + BIS**2 - CR = (ARS*BRS + AIS*BIS)/S - CI = (AIS*BRS - ARS*BIS)/S - RETURN - END diff --git a/Libraries/MyEis/cg.f b/Libraries/MyEis/cg.f deleted file mode 100644 index 6b488a81e..000000000 --- a/Libraries/MyEis/cg.f +++ /dev/null @@ -1,63 +0,0 @@ - SUBROUTINE CG(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR) -C - INTEGER N,NM,IS1,IS2,IERR,MATZ - DOUBLE PRECISION AR(NM,N),AI(NM,N),WR(N),WI(N),ZR(NM,N),ZI(NM,N), - X FV1(N),FV2(N),FV3(N) -C -C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF -C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) -C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) -C OF A COMPLEX GENERAL MATRIX. -C -C ON INPUT -C -C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL -C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM -C DIMENSION STATEMENT. -C -C N IS THE ORDER OF THE MATRIX A=(AR,AI). -C -C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, -C RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX. -C -C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF -C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO -C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. -C -C ON OUTPUT -C -C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, -C RESPECTIVELY, OF THE EIGENVALUES. -C -C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, -C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO. -C -C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR -C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR -C AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO. -C -C FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS. -C -C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, -C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY -C -C THIS VERSION DATED AUGUST 1983. -C -C ------------------------------------------------------------------ -C - IF (N .LE. NM) GO TO 10 - IERR = 10 * N - GO TO 50 -C - 10 CALL CBAL(NM,N,AR,AI,IS1,IS2,FV1) - CALL CORTH(NM,N,IS1,IS2,AR,AI,FV2,FV3) - IF (MATZ .NE. 0) GO TO 20 -C .......... FIND EIGENVALUES ONLY .......... - CALL COMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR) - GO TO 50 -C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... - 20 CALL COMQR2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR) - IF (IERR .NE. 0) GO TO 50 - CALL CBABK2(NM,N,IS1,IS2,FV1,N,ZR,ZI) - 50 RETURN - END diff --git a/Libraries/MyEis/ch.f b/Libraries/MyEis/ch.f deleted file mode 100644 index 302faae4d..000000000 --- a/Libraries/MyEis/ch.f +++ /dev/null @@ -1,70 +0,0 @@ - SUBROUTINE CH(NM,N,AR,AI,W,MATZ,ZR,ZI,FV1,FV2,FM1,IERR) -C - INTEGER I,J,N,NM,IERR,MATZ - DOUBLE PRECISION AR(NM,N),AI(NM,N),W(N),ZR(NM,N),ZI(NM,N), - X FV1(N),FV2(N),FM1(2,N) -C -C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF -C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) -C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) -C OF A COMPLEX HERMITIAN MATRIX. -C -C ON INPUT -C -C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL -C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM -C DIMENSION STATEMENT. -C -C N IS THE ORDER OF THE MATRIX A=(AR,AI). -C -C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, -C RESPECTIVELY, OF THE COMPLEX HERMITIAN MATRIX. -C -C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF -C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO -C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. -C -C ON OUTPUT -C -C W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. -C -C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, -C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO. -C -C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR -C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT -C AND TQL2. THE NORMAL COMPLETION CODE IS ZERO. -C -C FV1, FV2, AND FM1 ARE TEMPORARY STORAGE ARRAYS. -C -C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, -C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY -C -C THIS VERSION DATED AUGUST 1983. -C -C ------------------------------------------------------------------ -C - IF (N .LE. NM) GO TO 10 - IERR = 10 * N - GO TO 50 -C - 10 CALL HTRIDI(NM,N,AR,AI,W,FV1,FV2,FM1) - IF (MATZ .NE. 0) GO TO 20 -C .......... FIND EIGENVALUES ONLY .......... - CALL TQLRAT(N,W,FV2,IERR) - GO TO 50 -C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... - 20 DO 40 I = 1, N -C - DO 30 J = 1, N - ZR(J,I) = 0.0D0 - 30 CONTINUE -C - ZR(I,I) = 1.0D0 - 40 CONTINUE -C - CALL TQL2(NM,N,W,FV1,ZR,IERR) - IF (IERR .NE. 0) GO TO 50 - CALL HTRIBK(NM,N,AR,AI,FM1,N,ZR,ZI) - 50 RETURN - END diff --git a/Libraries/MyEis/comp b/Libraries/MyEis/comp deleted file mode 100644 index 189980942..000000000 --- a/Libraries/MyEis/comp +++ /dev/null @@ -1 +0,0 @@ -if77 -c -O4 -Mvect -nx *.f diff --git a/Libraries/MyEis/comqr.f b/Libraries/MyEis/comqr.f deleted file mode 100644 index 173afc342..000000000 --- a/Libraries/MyEis/comqr.f +++ /dev/null @@ -1,222 +0,0 @@ - SUBROUTINE COMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR) -C - INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR - DOUBLE PRECISION HR(NM,N),HI(NM,N),WR(N),WI(N) - DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2, - X PYTHAG -C -C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE -C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN -C AND WILKINSON. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971). -C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS -C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM. -C -C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX -C UPPER HESSENBERG MATRIX BY THE QR METHOD. -C -C ON INPUT -C -C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL -C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM -C DIMENSION STATEMENT. -C -C N IS THE ORDER OF THE MATRIX. -C -C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING -C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, -C SET LOW=1, IGH=N. -C -C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS, -C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX. -C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN -C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN -C THE REDUCTION BY CORTH, IF PERFORMED. -C -C ON OUTPUT -C -C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN -C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE -C CALLING COMQR IF SUBSEQUENT CALCULATION OF -C EIGENVECTORS IS TO BE PERFORMED. -C -C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, -C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR -C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT -C FOR INDICES IERR+1,...,N. -C -C IERR IS SET TO -C ZERO FOR NORMAL RETURN, -C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED -C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. -C -C CALLS CDIV FOR COMPLEX DIVISION. -C CALLS CSROOT FOR COMPLEX SQUARE ROOT. -C CALLS PYTHAG FOR DSQRT(A*A + B*B) . -C -C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, -C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY -C -C THIS VERSION DATED AUGUST 1983. -C -C ------------------------------------------------------------------ -C - IERR = 0 - IF (LOW .EQ. IGH) GO TO 180 -C .......... CREATE REAL SUBDIAGONAL ELEMENTS .......... - L = LOW + 1 -C - DO 170 I = L, IGH - LL = MIN0(I+1,IGH) - IF (HI(I,I-1) .EQ. 0.0D0) GO TO 170 - NORM = PYTHAG(HR(I,I-1),HI(I,I-1)) - YR = HR(I,I-1) / NORM - YI = HI(I,I-1) / NORM - HR(I,I-1) = NORM - HI(I,I-1) = 0.0D0 -C - DO 155 J = I, IGH - SI = YR * HI(I,J) - YI * HR(I,J) - HR(I,J) = YR * HR(I,J) + YI * HI(I,J) - HI(I,J) = SI - 155 CONTINUE -C - DO 160 J = LOW, LL - SI = YR * HI(J,I) + YI * HR(J,I) - HR(J,I) = YR * HR(J,I) - YI * HI(J,I) - HI(J,I) = SI - 160 CONTINUE -C - 170 CONTINUE -C .......... STORE ROOTS ISOLATED BY CBAL .......... - 180 DO 200 I = 1, N - IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200 - WR(I) = HR(I,I) - WI(I) = HI(I,I) - 200 CONTINUE -C - EN = IGH - TR = 0.0D0 - TI = 0.0D0 - ITN = 30*N -C .......... SEARCH FOR NEXT EIGENVALUE .......... - 220 IF (EN .LT. LOW) GO TO 1001 - ITS = 0 - ENM1 = EN - 1 -C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT -C FOR L=EN STEP -1 UNTIL LOW D0 -- .......... - 240 DO 260 LL = LOW, EN - L = EN + LOW - LL - IF (L .EQ. LOW) GO TO 300 - TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1)) - X + DABS(HR(L,L)) + DABS(HI(L,L)) - TST2 = TST1 + DABS(HR(L,L-1)) - IF (TST2 .EQ. TST1) GO TO 300 - 260 CONTINUE -C .......... FORM SHIFT .......... - 300 IF (L .EQ. EN) GO TO 660 - IF (ITN .EQ. 0) GO TO 1000 - IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320 - SR = HR(EN,EN) - SI = HI(EN,EN) - XR = HR(ENM1,EN) * HR(EN,ENM1) - XI = HI(ENM1,EN) * HR(EN,ENM1) - IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GO TO 340 - YR = (HR(ENM1,ENM1) - SR) / 2.0D0 - YI = (HI(ENM1,ENM1) - SI) / 2.0D0 - CALL CSROOT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI) - IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GO TO 310 - ZZR = -ZZR - ZZI = -ZZI - 310 CALL CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI) - SR = SR - XR - SI = SI - XI - GO TO 340 -C .......... FORM EXCEPTIONAL SHIFT .......... - 320 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2)) - SI = 0.0D0 -C - 340 DO 360 I = LOW, EN - HR(I,I) = HR(I,I) - SR - HI(I,I) = HI(I,I) - SI - 360 CONTINUE -C - TR = TR + SR - TI = TI + SI - ITS = ITS + 1 - ITN = ITN - 1 -C .......... REDUCE TO TRIANGLE (ROWS) .......... - LP1 = L + 1 -C - DO 500 I = LP1, EN - SR = HR(I,I-1) - HR(I,I-1) = 0.0D0 - NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR) - XR = HR(I-1,I-1) / NORM - WR(I-1) = XR - XI = HI(I-1,I-1) / NORM - WI(I-1) = XI - HR(I-1,I-1) = NORM - HI(I-1,I-1) = 0.0D0 - HI(I,I-1) = SR / NORM -C - DO 490 J = I, EN - YR = HR(I-1,J) - YI = HI(I-1,J) - ZZR = HR(I,J) - ZZI = HI(I,J) - HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR - HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI - HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR - HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI - 490 CONTINUE -C - 500 CONTINUE -C - SI = HI(EN,EN) - IF (SI .EQ. 0.0D0) GO TO 540 - NORM = PYTHAG(HR(EN,EN),SI) - SR = HR(EN,EN) / NORM - SI = SI / NORM - HR(EN,EN) = NORM - HI(EN,EN) = 0.0D0 -C .......... INVERSE OPERATION (COLUMNS) .......... - 540 DO 600 J = LP1, EN - XR = WR(J-1) - XI = WI(J-1) -C - DO 580 I = L, J - YR = HR(I,J-1) - YI = 0.0D0 - ZZR = HR(I,J) - ZZI = HI(I,J) - IF (I .EQ. J) GO TO 560 - YI = HI(I,J-1) - HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI - 560 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR - HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR - HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI - 580 CONTINUE -C - 600 CONTINUE -C - IF (SI .EQ. 0.0D0) GO TO 240 -C - DO 630 I = L, EN - YR = HR(I,EN) - YI = HI(I,EN) - HR(I,EN) = SR * YR - SI * YI - HI(I,EN) = SR * YI + SI * YR - 630 CONTINUE -C - GO TO 240 -C .......... A ROOT FOUND .......... - 660 WR(EN) = HR(EN,EN) + TR - WI(EN) = HI(EN,EN) + TI - EN = ENM1 - GO TO 220 -C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT -C CONVERGED AFTER 30*N ITERATIONS .......... - 1000 IERR = EN - 1001 RETURN - END diff --git a/Libraries/MyEis/comqr2.f b/Libraries/MyEis/comqr2.f deleted file mode 100644 index 919ce50c3..000000000 --- a/Libraries/MyEis/comqr2.f +++ /dev/null @@ -1,409 +0,0 @@ - SUBROUTINE COMQR2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR) -C - INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1, - X ITN,ITS,LOW,LP1,ENM1,IEND,IERR - DOUBLE PRECISION HR(NM,N),HI(NM,N),WR(N),WI(N),ZR(NM,N),ZI(NM,N), - X ORTR(IGH),ORTI(IGH) - DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2, - X PYTHAG -C -C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE -C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS -C AND WILKINSON. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). -C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS -C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM. -C -C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS -C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR -C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX -C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE -C THIS GENERAL MATRIX TO HESSENBERG FORM. -C -C ON INPUT -C -C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL -C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM -C DIMENSION STATEMENT. -C -C N IS THE ORDER OF THE MATRIX. -C -C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING -C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, -C SET LOW=1, IGH=N. -C -C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS- -C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED. -C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS -C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND -C ORTI(J) TO 0.0D0 FOR THESE ELEMENTS. -C -C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS, -C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX. -C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER -C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE -C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF -C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE -C ARBITRARY. -C -C ON OUTPUT -C -C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI -C HAVE BEEN DESTROYED. -C -C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, -C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR -C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT -C FOR INDICES IERR+1,...,N. -C -C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, -C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS -C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF -C THE EIGENVECTORS HAS BEEN FOUND. -C -C IERR IS SET TO -C ZERO FOR NORMAL RETURN, -C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED -C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. -C -C CALLS CDIV FOR COMPLEX DIVISION. -C CALLS CSROOT FOR COMPLEX SQUARE ROOT. -C CALLS PYTHAG FOR DSQRT(A*A + B*B) . -C -C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, -C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY -C -C THIS VERSION DATED AUGUST 1983. -C -C ------------------------------------------------------------------ -C - IERR = 0 -C .......... INITIALIZE EIGENVECTOR MATRIX .......... - DO 101 J = 1, N -C - DO 100 I = 1, N - ZR(I,J) = 0.0D0 - ZI(I,J) = 0.0D0 - 100 CONTINUE - ZR(J,J) = 1.0D0 - 101 CONTINUE -C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS -C FROM THE INFORMATION LEFT BY CORTH .......... - IEND = IGH - LOW - 1 - IF (IEND) 180, 150, 105 -C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... - 105 DO 140 II = 1, IEND - I = IGH - II - IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GO TO 140 - IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GO TO 140 -C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH .......... - NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I) - IP1 = I + 1 -C - DO 110 K = IP1, IGH - ORTR(K) = HR(K,I-1) - ORTI(K) = HI(K,I-1) - 110 CONTINUE -C - DO 130 J = I, IGH - SR = 0.0D0 - SI = 0.0D0 -C - DO 115 K = I, IGH - SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J) - SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J) - 115 CONTINUE -C - SR = SR / NORM - SI = SI / NORM -C - DO 120 K = I, IGH - ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K) - ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K) - 120 CONTINUE -C - 130 CONTINUE -C - 140 CONTINUE -C .......... CREATE REAL SUBDIAGONAL ELEMENTS .......... - 150 L = LOW + 1 -C - DO 170 I = L, IGH - LL = MIN0(I+1,IGH) - IF (HI(I,I-1) .EQ. 0.0D0) GO TO 170 - NORM = PYTHAG(HR(I,I-1),HI(I,I-1)) - YR = HR(I,I-1) / NORM - YI = HI(I,I-1) / NORM - HR(I,I-1) = NORM - HI(I,I-1) = 0.0D0 -C - DO 155 J = I, N - SI = YR * HI(I,J) - YI * HR(I,J) - HR(I,J) = YR * HR(I,J) + YI * HI(I,J) - HI(I,J) = SI - 155 CONTINUE -C - DO 160 J = 1, LL - SI = YR * HI(J,I) + YI * HR(J,I) - HR(J,I) = YR * HR(J,I) - YI * HI(J,I) - HI(J,I) = SI - 160 CONTINUE -C - DO 165 J = LOW, IGH - SI = YR * ZI(J,I) + YI * ZR(J,I) - ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I) - ZI(J,I) = SI - 165 CONTINUE -C - 170 CONTINUE -C .......... STORE ROOTS ISOLATED BY CBAL .......... - 180 DO 200 I = 1, N - IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200 - WR(I) = HR(I,I) - WI(I) = HI(I,I) - 200 CONTINUE -C - EN = IGH - TR = 0.0D0 - TI = 0.0D0 - ITN = 30*N -C .......... SEARCH FOR NEXT EIGENVALUE .......... - 220 IF (EN .LT. LOW) GO TO 680 - ITS = 0 - ENM1 = EN - 1 -C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT -C FOR L=EN STEP -1 UNTIL LOW DO -- .......... - 240 DO 260 LL = LOW, EN - L = EN + LOW - LL - IF (L .EQ. LOW) GO TO 300 - TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1)) - X + DABS(HR(L,L)) + DABS(HI(L,L)) - TST2 = TST1 + DABS(HR(L,L-1)) - IF (TST2 .EQ. TST1) GO TO 300 - 260 CONTINUE -C .......... FORM SHIFT .......... - 300 IF (L .EQ. EN) GO TO 660 - IF (ITN .EQ. 0) GO TO 1000 - IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320 - SR = HR(EN,EN) - SI = HI(EN,EN) - XR = HR(ENM1,EN) * HR(EN,ENM1) - XI = HI(ENM1,EN) * HR(EN,ENM1) - IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GO TO 340 - YR = (HR(ENM1,ENM1) - SR) / 2.0D0 - YI = (HI(ENM1,ENM1) - SI) / 2.0D0 - CALL CSROOT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI) - IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GO TO 310 - ZZR = -ZZR - ZZI = -ZZI - 310 CALL CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI) - SR = SR - XR - SI = SI - XI - GO TO 340 -C .......... FORM EXCEPTIONAL SHIFT .......... - 320 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2)) - SI = 0.0D0 -C - 340 DO 360 I = LOW, EN - HR(I,I) = HR(I,I) - SR - HI(I,I) = HI(I,I) - SI - 360 CONTINUE -C - TR = TR + SR - TI = TI + SI - ITS = ITS + 1 - ITN = ITN - 1 -C .......... REDUCE TO TRIANGLE (ROWS) .......... - LP1 = L + 1 -C - DO 500 I = LP1, EN - SR = HR(I,I-1) - HR(I,I-1) = 0.0D0 - NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR) - XR = HR(I-1,I-1) / NORM - WR(I-1) = XR - XI = HI(I-1,I-1) / NORM - WI(I-1) = XI - HR(I-1,I-1) = NORM - HI(I-1,I-1) = 0.0D0 - HI(I,I-1) = SR / NORM -C - DO 490 J = I, N - YR = HR(I-1,J) - YI = HI(I-1,J) - ZZR = HR(I,J) - ZZI = HI(I,J) - HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR - HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI - HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR - HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI - 490 CONTINUE -C - 500 CONTINUE -C - SI = HI(EN,EN) - IF (SI .EQ. 0.0D0) GO TO 540 - NORM = PYTHAG(HR(EN,EN),SI) - SR = HR(EN,EN) / NORM - SI = SI / NORM - HR(EN,EN) = NORM - HI(EN,EN) = 0.0D0 - IF (EN .EQ. N) GO TO 540 - IP1 = EN + 1 -C - DO 520 J = IP1, N - YR = HR(EN,J) - YI = HI(EN,J) - HR(EN,J) = SR * YR + SI * YI - HI(EN,J) = SR * YI - SI * YR - 520 CONTINUE -C .......... INVERSE OPERATION (COLUMNS) .......... - 540 DO 600 J = LP1, EN - XR = WR(J-1) - XI = WI(J-1) -C - DO 580 I = 1, J - YR = HR(I,J-1) - YI = 0.0D0 - ZZR = HR(I,J) - ZZI = HI(I,J) - IF (I .EQ. J) GO TO 560 - YI = HI(I,J-1) - HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI - 560 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR - HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR - HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI - 580 CONTINUE -C - DO 590 I = LOW, IGH - YR = ZR(I,J-1) - YI = ZI(I,J-1) - ZZR = ZR(I,J) - ZZI = ZI(I,J) - ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR - ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI - ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR - ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI - 590 CONTINUE -C - 600 CONTINUE -C - IF (SI .EQ. 0.0D0) GO TO 240 -C - DO 630 I = 1, EN - YR = HR(I,EN) - YI = HI(I,EN) - HR(I,EN) = SR * YR - SI * YI - HI(I,EN) = SR * YI + SI * YR - 630 CONTINUE -C - DO 640 I = LOW, IGH - YR = ZR(I,EN) - YI = ZI(I,EN) - ZR(I,EN) = SR * YR - SI * YI - ZI(I,EN) = SR * YI + SI * YR - 640 CONTINUE -C - GO TO 240 -C .......... A ROOT FOUND .......... - 660 HR(EN,EN) = HR(EN,EN) + TR - WR(EN) = HR(EN,EN) - HI(EN,EN) = HI(EN,EN) + TI - WI(EN) = HI(EN,EN) - EN = ENM1 - GO TO 220 -C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND -C VECTORS OF UPPER TRIANGULAR FORM .......... - 680 NORM = 0.0D0 -C - DO 720 I = 1, N -C - DO 720 J = I, N - TR = DABS(HR(I,J)) + DABS(HI(I,J)) - IF (TR .GT. NORM) NORM = TR - 720 CONTINUE -C - IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GO TO 1001 -C .......... FOR EN=N STEP -1 UNTIL 2 DO -- .......... - DO 800 NN = 2, N - EN = N + 2 - NN - XR = WR(EN) - XI = WI(EN) - HR(EN,EN) = 1.0D0 - HI(EN,EN) = 0.0D0 - ENM1 = EN - 1 -C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- .......... - DO 780 II = 1, ENM1 - I = EN - II - ZZR = 0.0D0 - ZZI = 0.0D0 - IP1 = I + 1 -C - DO 740 J = IP1, EN - ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN) - ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN) - 740 CONTINUE -C - YR = XR - WR(I) - YI = XI - WI(I) - IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GO TO 765 - TST1 = NORM - YR = TST1 - 760 YR = 0.01D0 * YR - TST2 = NORM + YR - IF (TST2 .GT. TST1) GO TO 760 - 765 CONTINUE - CALL CDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN)) -C .......... OVERFLOW CONTROL .......... - TR = DABS(HR(I,EN)) + DABS(HI(I,EN)) - IF (TR .EQ. 0.0D0) GO TO 780 - TST1 = TR - TST2 = TST1 + 1.0D0/TST1 - IF (TST2 .GT. TST1) GO TO 780 - DO 770 J = I, EN - HR(J,EN) = HR(J,EN)/TR - HI(J,EN) = HI(J,EN)/TR - 770 CONTINUE -C - 780 CONTINUE -C - 800 CONTINUE -C .......... END BACKSUBSTITUTION .......... - ENM1 = N - 1 -C .......... VECTORS OF ISOLATED ROOTS .......... - DO 840 I = 1, ENM1 - IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840 - IP1 = I + 1 -C - DO 820 J = IP1, N - ZR(I,J) = HR(I,J) - ZI(I,J) = HI(I,J) - 820 CONTINUE -C - 840 CONTINUE -C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE -C VECTORS OF ORIGINAL FULL MATRIX. -C FOR J=N STEP -1 UNTIL LOW+1 DO -- .......... - DO 880 JJ = LOW, ENM1 - J = N + LOW - JJ - M = MIN0(J,IGH) -C - DO 880 I = LOW, IGH - ZZR = 0.0D0 - ZZI = 0.0D0 -C - DO 860 K = LOW, M - ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J) - ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J) - 860 CONTINUE -C - ZR(I,J) = ZZR - ZI(I,J) = ZZI - 880 CONTINUE -C - GO TO 1001 -C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT -C CONVERGED AFTER 30*N ITERATIONS .......... - 1000 IERR = EN - 1001 RETURN - END diff --git a/Libraries/MyEis/corth.f b/Libraries/MyEis/corth.f deleted file mode 100644 index c09949321..000000000 --- a/Libraries/MyEis/corth.f +++ /dev/null @@ -1,134 +0,0 @@ - SUBROUTINE CORTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI) -C - INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW - DOUBLE PRECISION AR(NM,N),AI(NM,N),ORTR(IGH),ORTI(IGH) - DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG -C -C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF -C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968) -C BY MARTIN AND WILKINSON. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). -C -C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE -C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS -C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY -C UNITARY SIMILARITY TRANSFORMATIONS. -C -C ON INPUT -C -C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL -C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM -C DIMENSION STATEMENT. -C -C N IS THE ORDER OF THE MATRIX. -C -C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING -C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, -C SET LOW=1, IGH=N. -C -C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, -C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX. -C -C ON OUTPUT -C -C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, -C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION -C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION -C IS STORED IN THE REMAINING TRIANGLES UNDER THE -C HESSENBERG MATRIX. -C -C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE -C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED. -C -C CALLS PYTHAG FOR DSQRT(A*A + B*B) . -C -C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, -C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY -C -C THIS VERSION DATED AUGUST 1983. -C -C ------------------------------------------------------------------ -C - LA = IGH - 1 - KP1 = LOW + 1 - IF (LA .LT. KP1) GO TO 200 -C - DO 180 M = KP1, LA - H = 0.0D0 - ORTR(M) = 0.0D0 - ORTI(M) = 0.0D0 - SCALE = 0.0D0 -C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) .......... - DO 90 I = M, IGH - 90 SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1)) -C - IF (SCALE .EQ. 0.0D0) GO TO 180 - MP = M + IGH -C .......... FOR I=IGH STEP -1 UNTIL M DO -- .......... - DO 100 II = M, IGH - I = MP - II - ORTR(I) = AR(I,M-1) / SCALE - ORTI(I) = AI(I,M-1) / SCALE - H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I) - 100 CONTINUE -C - G = DSQRT(H) - F = PYTHAG(ORTR(M),ORTI(M)) - IF (F .EQ. 0.0D0) GO TO 103 - H = H + F * G - G = G / F - ORTR(M) = (1.0D0 + G) * ORTR(M) - ORTI(M) = (1.0D0 + G) * ORTI(M) - GO TO 105 -C - 103 ORTR(M) = G - AR(M,M-1) = SCALE -C .......... FORM (I-(U*UT)/H) * A .......... - 105 DO 130 J = M, N - FR = 0.0D0 - FI = 0.0D0 -C .......... FOR I=IGH STEP -1 UNTIL M DO -- .......... - DO 110 II = M, IGH - I = MP - II - FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J) - FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J) - 110 CONTINUE -C - FR = FR / H - FI = FI / H -C - DO 120 I = M, IGH - AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I) - AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I) - 120 CONTINUE -C - 130 CONTINUE -C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) .......... - DO 160 I = 1, IGH - FR = 0.0D0 - FI = 0.0D0 -C .......... FOR J=IGH STEP -1 UNTIL M DO -- .......... - DO 140 JJ = M, IGH - J = MP - JJ - FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J) - FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J) - 140 CONTINUE -C - FR = FR / H - FI = FI / H -C - DO 150 J = M, IGH - AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J) - AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J) - 150 CONTINUE -C - 160 CONTINUE -C - ORTR(M) = SCALE * ORTR(M) - ORTI(M) = SCALE * ORTI(M) - AR(M,M-1) = -G * AR(M,M-1) - AI(M,M-1) = -G * AI(M,M-1) - 180 CONTINUE -C - 200 RETURN - END diff --git a/Libraries/MyEis/csroot.f b/Libraries/MyEis/csroot.f deleted file mode 100644 index d81bbfe74..000000000 --- a/Libraries/MyEis/csroot.f +++ /dev/null @@ -1,17 +0,0 @@ - SUBROUTINE CSROOT(XR,XI,YR,YI) - DOUBLE PRECISION XR,XI,YR,YI -C -C (YR,YI) = COMPLEX DSQRT(XR,XI) -C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI) -C - DOUBLE PRECISION S,TR,TI,PYTHAG - TR = XR - TI = XI - S = DSQRT(0.5D0*(PYTHAG(TR,TI) + DABS(TR))) - IF (TR .GE. 0.0D0) YR = S - IF (TI .LT. 0.0D0) S = -S - IF (TR .LE. 0.0D0) YI = S - IF (TR .LT. 0.0D0) YR = 0.5D0*(TI/YI) - IF (TR .GT. 0.0D0) YI = 0.5D0*(TI/YR) - RETURN - END diff --git a/Libraries/MyEis/elmhes.f b/Libraries/MyEis/elmhes.f deleted file mode 100644 index a5b7a4846..000000000 --- a/Libraries/MyEis/elmhes.f +++ /dev/null @@ -1,98 +0,0 @@ - SUBROUTINE ELMHES(NM,N,LOW,IGH,A,INT) -C - INTEGER I,J,M,N,LA,NM,IGH,KP1,LOW,MM1,MP1 - DOUBLE PRECISION A(NM,N) - DOUBLE PRECISION X,Y - INTEGER INT(IGH) -C -C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ELMHES, -C NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). -C -C GIVEN A REAL GENERAL MATRIX, THIS SUBROUTINE -C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS -C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY -C STABILIZED ELEMENTARY SIMILARITY TRANSFORMATIONS. -C -C ON INPUT -C -C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL -C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM -C DIMENSION STATEMENT. -C -C N IS THE ORDER OF THE MATRIX. -C -C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING -C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, -C SET LOW=1, IGH=N. -C -C A CONTAINS THE INPUT MATRIX. -C -C ON OUTPUT -C -C A CONTAINS THE HESSENBERG MATRIX. THE MULTIPLIERS -C WHICH WERE USED IN THE REDUCTION ARE STORED IN THE -C REMAINING TRIANGLE UNDER THE HESSENBERG MATRIX. -C -C INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS -C INTERCHANGED IN THE REDUCTION. -C ONLY ELEMENTS LOW THROUGH IGH ARE USED. -C -C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, -C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY -C -C THIS VERSION DATED AUGUST 1983. -C -C ------------------------------------------------------------------ -C - LA = IGH - 1 - KP1 = LOW + 1 - IF (LA .LT. KP1) GO TO 200 -C - DO 180 M = KP1, LA - MM1 = M - 1 - X = 0.0D0 - I = M -C - DO 100 J = M, IGH - IF (DABS(A(J,MM1)) .LE. DABS(X)) GO TO 100 - X = A(J,MM1) - I = J - 100 CONTINUE -C - INT(M) = I - IF (I .EQ. M) GO TO 130 -C .......... INTERCHANGE ROWS AND COLUMNS OF A .......... - DO 110 J = MM1, N - Y = A(I,J) - A(I,J) = A(M,J) - A(M,J) = Y - 110 CONTINUE -C - DO 120 J = 1, IGH - Y = A(J,I) - A(J,I) = A(J,M) - A(J,M) = Y - 120 CONTINUE -C .......... END INTERCHANGE .......... - 130 IF (X .EQ. 0.0D0) GO TO 180 - MP1 = M + 1 -C - DO 160 I = MP1, IGH - Y = A(I,MM1) - IF (Y .EQ. 0.0D0) GO TO 160 - Y = Y / X - A(I,MM1) = Y -C - DO 140 J = M, N - 140 A(I,J) = A(I,J) - Y * A(M,J) -C - DO 150 J = 1, IGH - 150 A(J,M) = A(J,M) + Y * A(J,I) -C - 160 CONTINUE -C - 180 CONTINUE -C - 200 RETURN - END diff --git a/Libraries/MyEis/eltran.f b/Libraries/MyEis/eltran.f deleted file mode 100644 index b6110930e..000000000 --- a/Libraries/MyEis/eltran.f +++ /dev/null @@ -1,78 +0,0 @@ - SUBROUTINE ELTRAN(NM,N,LOW,IGH,A,INT,Z) -C - INTEGER I,J,N,KL,MM,MP,NM,IGH,LOW,MP1 - DOUBLE PRECISION A(NM,IGH),Z(NM,N) - INTEGER INT(IGH) -C -C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ELMTRANS, -C NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). -C -C THIS SUBROUTINE ACCUMULATES THE STABILIZED ELEMENTARY -C SIMILARITY TRANSFORMATIONS USED IN THE REDUCTION OF A -C REAL GENERAL MATRIX TO UPPER HESSENBERG FORM BY ELMHES. -C -C ON INPUT -C -C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL -C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM -C DIMENSION STATEMENT. -C -C N IS THE ORDER OF THE MATRIX. -C -C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING -C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, -C SET LOW=1, IGH=N. -C -C A CONTAINS THE MULTIPLIERS WHICH WERE USED IN THE -C REDUCTION BY ELMHES IN ITS LOWER TRIANGLE -C BELOW THE SUBDIAGONAL. -C -C INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS -C INTERCHANGED IN THE REDUCTION BY ELMHES. -C ONLY ELEMENTS LOW THROUGH IGH ARE USED. -C -C ON OUTPUT -C -C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE -C REDUCTION BY ELMHES. -C -C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, -C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY -C -C THIS VERSION DATED AUGUST 1983. -C -C ------------------------------------------------------------------ -C -C .......... INITIALIZE Z TO IDENTITY MATRIX .......... - DO 80 J = 1, N -C - DO 60 I = 1, N - 60 Z(I,J) = 0.0D0 -C - Z(J,J) = 1.0D0 - 80 CONTINUE -C - KL = IGH - LOW - 1 - IF (KL .LT. 1) GO TO 200 -C .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... - DO 140 MM = 1, KL - MP = IGH - MM - MP1 = MP + 1 -C - DO 100 I = MP1, IGH - 100 Z(I,MP) = A(I,MP-1) -C - I = INT(MP) - IF (I .EQ. MP) GO TO 140 -C - DO 130 J = MP, IGH - Z(MP,J) = Z(I,J) - Z(I,J) = 0.0D0 - 130 CONTINUE -C - Z(I,MP) = 1.0D0 - 140 CONTINUE -C - 200 RETURN - END diff --git a/Libraries/MyEis/epslon.f b/Libraries/MyEis/epslon.f deleted file mode 100644 index 88e25254c..000000000 --- a/Libraries/MyEis/epslon.f +++ /dev/null @@ -1,36 +0,0 @@ - DOUBLE PRECISION FUNCTION EPSLON (X) - DOUBLE PRECISION X -C -C ESTIMATE UNIT ROUNDOFF IN QUANTITIES OF SIZE X. -C - DOUBLE PRECISION A,B,C,EPS -C -C THIS PROGRAM SHOULD FUNCTION PROPERLY ON ALL SYSTEMS -C SATISFYING THE FOLLOWING TWO ASSUMPTIONS, -C 1. THE BASE USED IN REPRESENTING FLOATING POINT -C NUMBERS IS NOT A POWER OF THREE. -C 2. THE QUANTITY A IN STATEMENT 10 IS REPRESENTED TO -C THE ACCURACY USED IN FLOATING POINT VARIABLES -C THAT ARE STORED IN MEMORY. -C THE STATEMENT NUMBER 10 AND THE GO TO 10 ARE INTENDED TO -C FORCE OPTIMIZING COMPILERS TO GENERATE CODE SATISFYING -C ASSUMPTION 2. -C UNDER THESE ASSUMPTIONS, IT SHOULD BE TRUE THAT, -C A IS NOT EXACTLY EQUAL TO FOUR-THIRDS, -C B HAS A ZERO FOR ITS LAST BIT OR DIGIT, -C C IS NOT EXACTLY EQUAL TO ONE, -C EPS MEASURES THE SEPARATION OF 1.0 FROM -C THE NEXT LARGER FLOATING POINT NUMBER. -C THE DEVELOPERS OF EISPACK WOULD APPRECIATE BEING INFORMED -C ABOUT ANY SYSTEMS WHERE THESE ASSUMPTIONS DO NOT HOLD. -C -C THIS VERSION DATED 4/6/83. -C - A = 4.0D0/3.0D0 - 10 B = A - 1.0D0 - C = B + B + B - EPS = DABS(C-1.0D0) - IF (EPS .EQ. 0.0D0) GO TO 10 - EPSLON = EPS*DABS(X) - RETURN - END diff --git a/Libraries/MyEis/hqr.f b/Libraries/MyEis/hqr.f deleted file mode 100644 index 1ec242352..000000000 --- a/Libraries/MyEis/hqr.f +++ /dev/null @@ -1,234 +0,0 @@ - SUBROUTINE HQR(NM,N,LOW,IGH,H,WR,WI,IERR) -C - INTEGER I,J,K,L,M,N,EN,LL,MM,NA,NM,IGH,ITN,ITS,LOW,MP2,ENM2,IERR - DOUBLE PRECISION H(NM,N),WR(N),WI(N) - DOUBLE PRECISION P,Q,R,S,T,W,X,Y,ZZ,NORM,TST1,TST2 - LOGICAL NOTLAS -C -C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE HQR, -C NUM. MATH. 14, 219-231(1970) BY MARTIN, PETERS, AND WILKINSON. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 359-371(1971). -C -C THIS SUBROUTINE FINDS THE EIGENVALUES OF A REAL -C UPPER HESSENBERG MATRIX BY THE QR METHOD. -C -C ON INPUT -C -C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL -C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM -C DIMENSION STATEMENT. -C -C N IS THE ORDER OF THE MATRIX. -C -C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING -C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, -C SET LOW=1, IGH=N. -C -C H CONTAINS THE UPPER HESSENBERG MATRIX. INFORMATION ABOUT -C THE TRANSFORMATIONS USED IN THE REDUCTION TO HESSENBERG -C FORM BY ELMHES OR ORTHES, IF PERFORMED, IS STORED -C IN THE REMAINING TRIANGLE UNDER THE HESSENBERG MATRIX. -C -C ON OUTPUT -C -C H HAS BEEN DESTROYED. THEREFORE, IT MUST BE SAVED -C BEFORE CALLING HQR IF SUBSEQUENT CALCULATION AND -C BACK TRANSFORMATION OF EIGENVECTORS IS TO BE PERFORMED. -C -C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, -C RESPECTIVELY, OF THE EIGENVALUES. THE EIGENVALUES -C ARE UNORDERED EXCEPT THAT COMPLEX CONJUGATE PAIRS -C OF VALUES APPEAR CONSECUTIVELY WITH THE EIGENVALUE -C HAVING THE POSITIVE IMAGINARY PART FIRST. IF AN -C ERROR EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT -C FOR INDICES IERR+1,...,N. -C -C IERR IS SET TO -C ZERO FOR NORMAL RETURN, -C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED -C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. -C -C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, -C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY -C -C THIS VERSION DATED AUGUST 1983. -C -C ------------------------------------------------------------------ -C - IERR = 0 - NORM = 0.0D0 - K = 1 -C .......... STORE ROOTS ISOLATED BY BALANC -C AND COMPUTE MATRIX NORM .......... - DO 50 I = 1, N -C - DO 40 J = K, N - 40 NORM = NORM + DABS(H(I,J)) -C - K = I - IF (I .GE. LOW .AND. I .LE. IGH) GO TO 50 - WR(I) = H(I,I) - WI(I) = 0.0D0 - 50 CONTINUE -C - EN = IGH - T = 0.0D0 - ITN = 30*N -C .......... SEARCH FOR NEXT EIGENVALUES .......... - 60 IF (EN .LT. LOW) GO TO 1001 - ITS = 0 - NA = EN - 1 - ENM2 = NA - 1 -C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT -C FOR L=EN STEP -1 UNTIL LOW DO -- .......... - 70 DO 80 LL = LOW, EN - L = EN + LOW - LL - IF (L .EQ. LOW) GO TO 100 - S = DABS(H(L-1,L-1)) + DABS(H(L,L)) - IF (S .EQ. 0.0D0) S = NORM - TST1 = S - TST2 = TST1 + DABS(H(L,L-1)) - IF (TST2 .EQ. TST1) GO TO 100 - 80 CONTINUE -C .......... FORM SHIFT .......... - 100 X = H(EN,EN) - IF (L .EQ. EN) GO TO 270 - Y = H(NA,NA) - W = H(EN,NA) * H(NA,EN) - IF (L .EQ. NA) GO TO 280 - IF (ITN .EQ. 0) GO TO 1000 - IF (ITS .NE. 10 .AND. ITS .NE. 20) GO TO 130 -C .......... FORM EXCEPTIONAL SHIFT .......... - T = T + X -C - DO 120 I = LOW, EN - 120 H(I,I) = H(I,I) - X -C - S = DABS(H(EN,NA)) + DABS(H(NA,ENM2)) - X = 0.75D0 * S - Y = X - W = -0.4375D0 * S * S - 130 ITS = ITS + 1 - ITN = ITN - 1 -C .......... LOOK FOR TWO CONSECUTIVE SMALL -C SUB-DIAGONAL ELEMENTS. -C FOR M=EN-2 STEP -1 UNTIL L DO -- .......... - DO 140 MM = L, ENM2 - M = ENM2 + L - MM - ZZ = H(M,M) - R = X - ZZ - S = Y - ZZ - P = (R * S - W) / H(M+1,M) + H(M,M+1) - Q = H(M+1,M+1) - ZZ - R - S - R = H(M+2,M+1) - S = DABS(P) + DABS(Q) + DABS(R) - P = P / S - Q = Q / S - R = R / S - IF (M .EQ. L) GO TO 150 - TST1 = DABS(P)*(DABS(H(M-1,M-1)) + DABS(ZZ) + DABS(H(M+1,M+1))) - TST2 = TST1 + DABS(H(M,M-1))*(DABS(Q) + DABS(R)) - IF (TST2 .EQ. TST1) GO TO 150 - 140 CONTINUE -C - 150 MP2 = M + 2 -C - DO 160 I = MP2, EN - H(I,I-2) = 0.0D0 - IF (I .EQ. MP2) GO TO 160 - H(I,I-3) = 0.0D0 - 160 CONTINUE -C .......... DOUBLE QR STEP INVOLVING ROWS L TO EN AND -C COLUMNS M TO EN .......... - DO 260 K = M, NA - NOTLAS = K .NE. NA - IF (K .EQ. M) GO TO 170 - P = H(K,K-1) - Q = H(K+1,K-1) - R = 0.0D0 - IF (NOTLAS) R = H(K+2,K-1) - X = DABS(P) + DABS(Q) + DABS(R) - IF (X .EQ. 0.0D0) GO TO 260 - P = P / X - Q = Q / X - R = R / X - 170 S = DSIGN(DSQRT(P*P+Q*Q+R*R),P) - IF (K .EQ. M) GO TO 180 - H(K,K-1) = -S * X - GO TO 190 - 180 IF (L .NE. M) H(K,K-1) = -H(K,K-1) - 190 P = P + S - X = P / S - Y = Q / S - ZZ = R / S - Q = Q / P - R = R / P - IF (NOTLAS) GO TO 225 -C .......... ROW MODIFICATION .......... - DO 200 J = K, N - P = H(K,J) + Q * H(K+1,J) - H(K,J) = H(K,J) - P * X - H(K+1,J) = H(K+1,J) - P * Y - 200 CONTINUE -C - J = MIN0(EN,K+3) -C .......... COLUMN MODIFICATION .......... - DO 210 I = 1, J - P = X * H(I,K) + Y * H(I,K+1) - H(I,K) = H(I,K) - P - H(I,K+1) = H(I,K+1) - P * Q - 210 CONTINUE - GO TO 255 - 225 CONTINUE -C .......... ROW MODIFICATION .......... - DO 230 J = K, N - P = H(K,J) + Q * H(K+1,J) + R * H(K+2,J) - H(K,J) = H(K,J) - P * X - H(K+1,J) = H(K+1,J) - P * Y - H(K+2,J) = H(K+2,J) - P * ZZ - 230 CONTINUE -C - J = MIN0(EN,K+3) -C .......... COLUMN MODIFICATION .......... - DO 240 I = 1, J - P = X * H(I,K) + Y * H(I,K+1) + ZZ * H(I,K+2) - H(I,K) = H(I,K) - P - H(I,K+1) = H(I,K+1) - P * Q - H(I,K+2) = H(I,K+2) - P * R - 240 CONTINUE - 255 CONTINUE -C - 260 CONTINUE -C - GO TO 70 -C .......... ONE ROOT FOUND .......... - 270 WR(EN) = X + T - WI(EN) = 0.0D0 - EN = NA - GO TO 60 -C .......... TWO ROOTS FOUND .......... - 280 P = (Y - X) / 2.0D0 - Q = P * P + W - ZZ = DSQRT(DABS(Q)) - X = X + T - IF (Q .LT. 0.0D0) GO TO 320 -C .......... REAL PAIR .......... - ZZ = P + DSIGN(ZZ,P) - WR(NA) = X + ZZ - WR(EN) = WR(NA) - IF (ZZ .NE. 0.0D0) WR(EN) = X - W / ZZ - WI(NA) = 0.0D0 - WI(EN) = 0.0D0 - GO TO 330 -C .......... COMPLEX PAIR .......... - 320 WR(NA) = X + P - WR(EN) = X + P - WI(NA) = ZZ - WI(EN) = -ZZ - 330 EN = ENM2 - GO TO 60 -C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT -C CONVERGED AFTER 30*N ITERATIONS .......... - 1000 IERR = EN - 1001 RETURN - END diff --git a/Libraries/MyEis/hqr2.f b/Libraries/MyEis/hqr2.f deleted file mode 100644 index c22cdece4..000000000 --- a/Libraries/MyEis/hqr2.f +++ /dev/null @@ -1,449 +0,0 @@ - SUBROUTINE HQR2(NM,N,LOW,IGH,H,WR,WI,Z,IERR) -C - INTEGER I,J,K,L,M,N,EN,II,JJ,LL,MM,NA,NM,NN, - X IGH,ITN,ITS,LOW,MP2,ENM2,IERR - DOUBLE PRECISION H(NM,N),WR(N),WI(N),Z(NM,N) - DOUBLE PRECISION P,Q,R,S,T,W,X,Y,RA,SA,VI,VR,ZZ,NORM,TST1,TST2 - LOGICAL NOTLAS -C -C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE HQR2, -C NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). -C -C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS -C OF A REAL UPPER HESSENBERG MATRIX BY THE QR METHOD. THE -C EIGENVECTORS OF A REAL GENERAL MATRIX CAN ALSO BE FOUND -C IF ELMHES AND ELTRAN OR ORTHES AND ORTRAN HAVE -C BEEN USED TO REDUCE THIS GENERAL MATRIX TO HESSENBERG FORM -C AND TO ACCUMULATE THE SIMILARITY TRANSFORMATIONS. -C -C ON INPUT -C -C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL -C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM -C DIMENSION STATEMENT. -C -C N IS THE ORDER OF THE MATRIX. -C -C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING -C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, -C SET LOW=1, IGH=N. -C -C H CONTAINS THE UPPER HESSENBERG MATRIX. -C -C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED BY ELTRAN -C AFTER THE REDUCTION BY ELMHES, OR BY ORTRAN AFTER THE -C REDUCTION BY ORTHES, IF PERFORMED. IF THE EIGENVECTORS -C OF THE HESSENBERG MATRIX ARE DESIRED, Z MUST CONTAIN THE -C IDENTITY MATRIX. -C -C ON OUTPUT -C -C H HAS BEEN DESTROYED. -C -C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, -C RESPECTIVELY, OF THE EIGENVALUES. THE EIGENVALUES -C ARE UNORDERED EXCEPT THAT COMPLEX CONJUGATE PAIRS -C OF VALUES APPEAR CONSECUTIVELY WITH THE EIGENVALUE -C HAVING THE POSITIVE IMAGINARY PART FIRST. IF AN -C ERROR EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT -C FOR INDICES IERR+1,...,N. -C -C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS. -C IF THE I-TH EIGENVALUE IS REAL, THE I-TH COLUMN OF Z -C CONTAINS ITS EIGENVECTOR. IF THE I-TH EIGENVALUE IS COMPLEX -C WITH POSITIVE IMAGINARY PART, THE I-TH AND (I+1)-TH -C COLUMNS OF Z CONTAIN THE REAL AND IMAGINARY PARTS OF ITS -C EIGENVECTOR. THE EIGENVECTORS ARE UNNORMALIZED. IF AN -C ERROR EXIT IS MADE, NONE OF THE EIGENVECTORS HAS BEEN FOUND. -C -C IERR IS SET TO -C ZERO FOR NORMAL RETURN, -C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED -C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. -C -C CALLS CDIV FOR COMPLEX DIVISION. -C -C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, -C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY -C -C THIS VERSION DATED AUGUST 1983. -C -C ------------------------------------------------------------------ -C - IERR = 0 - NORM = 0.0D0 - K = 1 -C .......... STORE ROOTS ISOLATED BY BALANC -C AND COMPUTE MATRIX NORM .......... - DO 50 I = 1, N -C - DO 40 J = K, N - 40 NORM = NORM + DABS(H(I,J)) -C - K = I - IF (I .GE. LOW .AND. I .LE. IGH) GO TO 50 - WR(I) = H(I,I) - WI(I) = 0.0D0 - 50 CONTINUE -C - EN = IGH - T = 0.0D0 - ITN = 30*N -C .......... SEARCH FOR NEXT EIGENVALUES .......... - 60 IF (EN .LT. LOW) GO TO 340 - ITS = 0 - NA = EN - 1 - ENM2 = NA - 1 -C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT -C FOR L=EN STEP -1 UNTIL LOW DO -- .......... - 70 DO 80 LL = LOW, EN - L = EN + LOW - LL - IF (L .EQ. LOW) GO TO 100 - S = DABS(H(L-1,L-1)) + DABS(H(L,L)) - IF (S .EQ. 0.0D0) S = NORM - TST1 = S - TST2 = TST1 + DABS(H(L,L-1)) - IF (TST2 .EQ. TST1) GO TO 100 - 80 CONTINUE -C .......... FORM SHIFT .......... - 100 X = H(EN,EN) - IF (L .EQ. EN) GO TO 270 - Y = H(NA,NA) - W = H(EN,NA) * H(NA,EN) - IF (L .EQ. NA) GO TO 280 - IF (ITN .EQ. 0) GO TO 1000 - IF (ITS .NE. 10 .AND. ITS .NE. 20) GO TO 130 -C .......... FORM EXCEPTIONAL SHIFT .......... - T = T + X -C - DO 120 I = LOW, EN - 120 H(I,I) = H(I,I) - X -C - S = DABS(H(EN,NA)) + DABS(H(NA,ENM2)) - X = 0.75D0 * S - Y = X - W = -0.4375D0 * S * S - 130 ITS = ITS + 1 - ITN = ITN - 1 -C .......... LOOK FOR TWO CONSECUTIVE SMALL -C SUB-DIAGONAL ELEMENTS. -C FOR M=EN-2 STEP -1 UNTIL L DO -- .......... - DO 140 MM = L, ENM2 - M = ENM2 + L - MM - ZZ = H(M,M) - R = X - ZZ - S = Y - ZZ - P = (R * S - W) / H(M+1,M) + H(M,M+1) - Q = H(M+1,M+1) - ZZ - R - S - R = H(M+2,M+1) - S = DABS(P) + DABS(Q) + DABS(R) - P = P / S - Q = Q / S - R = R / S - IF (M .EQ. L) GO TO 150 - TST1 = DABS(P)*(DABS(H(M-1,M-1)) + DABS(ZZ) + DABS(H(M+1,M+1))) - TST2 = TST1 + DABS(H(M,M-1))*(DABS(Q) + DABS(R)) - IF (TST2 .EQ. TST1) GO TO 150 - 140 CONTINUE -C - 150 MP2 = M + 2 -C - DO 160 I = MP2, EN - H(I,I-2) = 0.0D0 - IF (I .EQ. MP2) GO TO 160 - H(I,I-3) = 0.0D0 - 160 CONTINUE -C .......... DOUBLE QR STEP INVOLVING ROWS L TO EN AND -C COLUMNS M TO EN .......... - DO 260 K = M, NA - NOTLAS = K .NE. NA - IF (K .EQ. M) GO TO 170 - P = H(K,K-1) - Q = H(K+1,K-1) - R = 0.0D0 - IF (NOTLAS) R = H(K+2,K-1) - X = DABS(P) + DABS(Q) + DABS(R) - IF (X .EQ. 0.0D0) GO TO 260 - P = P / X - Q = Q / X - R = R / X - 170 S = DSIGN(DSQRT(P*P+Q*Q+R*R),P) - IF (K .EQ. M) GO TO 180 - H(K,K-1) = -S * X - GO TO 190 - 180 IF (L .NE. M) H(K,K-1) = -H(K,K-1) - 190 P = P + S - X = P / S - Y = Q / S - ZZ = R / S - Q = Q / P - R = R / P - IF (NOTLAS) GO TO 225 -C .......... ROW MODIFICATION .......... - DO 200 J = K, N - P = H(K,J) + Q * H(K+1,J) - H(K,J) = H(K,J) - P * X - H(K+1,J) = H(K+1,J) - P * Y - 200 CONTINUE -C - J = MIN0(EN,K+3) -C .......... COLUMN MODIFICATION .......... - DO 210 I = 1, J - P = X * H(I,K) + Y * H(I,K+1) - H(I,K) = H(I,K) - P - H(I,K+1) = H(I,K+1) - P * Q - 210 CONTINUE -C .......... ACCUMULATE TRANSFORMATIONS .......... - DO 220 I = LOW, IGH - P = X * Z(I,K) + Y * Z(I,K+1) - Z(I,K) = Z(I,K) - P - Z(I,K+1) = Z(I,K+1) - P * Q - 220 CONTINUE - GO TO 255 - 225 CONTINUE -C .......... ROW MODIFICATION .......... - DO 230 J = K, N - P = H(K,J) + Q * H(K+1,J) + R * H(K+2,J) - H(K,J) = H(K,J) - P * X - H(K+1,J) = H(K+1,J) - P * Y - H(K+2,J) = H(K+2,J) - P * ZZ - 230 CONTINUE -C - J = MIN0(EN,K+3) -C .......... COLUMN MODIFICATION .......... - DO 240 I = 1, J - P = X * H(I,K) + Y * H(I,K+1) + ZZ * H(I,K+2) - H(I,K) = H(I,K) - P - H(I,K+1) = H(I,K+1) - P * Q - H(I,K+2) = H(I,K+2) - P * R - 240 CONTINUE -C .......... ACCUMULATE TRANSFORMATIONS .......... - DO 250 I = LOW, IGH - P = X * Z(I,K) + Y * Z(I,K+1) + ZZ * Z(I,K+2) - Z(I,K) = Z(I,K) - P - Z(I,K+1) = Z(I,K+1) - P * Q - Z(I,K+2) = Z(I,K+2) - P * R - 250 CONTINUE - 255 CONTINUE -C - 260 CONTINUE -C - GO TO 70 -C .......... ONE ROOT FOUND .......... - 270 H(EN,EN) = X + T - WR(EN) = H(EN,EN) - WI(EN) = 0.0D0 - EN = NA - GO TO 60 -C .......... TWO ROOTS FOUND .......... - 280 P = (Y - X) / 2.0D0 - Q = P * P + W - ZZ = DSQRT(DABS(Q)) - H(EN,EN) = X + T - X = H(EN,EN) - H(NA,NA) = Y + T - IF (Q .LT. 0.0D0) GO TO 320 -C .......... REAL PAIR .......... - ZZ = P + DSIGN(ZZ,P) - WR(NA) = X + ZZ - WR(EN) = WR(NA) - IF (ZZ .NE. 0.0D0) WR(EN) = X - W / ZZ - WI(NA) = 0.0D0 - WI(EN) = 0.0D0 - X = H(EN,NA) - S = DABS(X) + DABS(ZZ) - P = X / S - Q = ZZ / S - R = DSQRT(P*P+Q*Q) - P = P / R - Q = Q / R -C .......... ROW MODIFICATION .......... - DO 290 J = NA, N - ZZ = H(NA,J) - H(NA,J) = Q * ZZ + P * H(EN,J) - H(EN,J) = Q * H(EN,J) - P * ZZ - 290 CONTINUE -C .......... COLUMN MODIFICATION .......... - DO 300 I = 1, EN - ZZ = H(I,NA) - H(I,NA) = Q * ZZ + P * H(I,EN) - H(I,EN) = Q * H(I,EN) - P * ZZ - 300 CONTINUE -C .......... ACCUMULATE TRANSFORMATIONS .......... - DO 310 I = LOW, IGH - ZZ = Z(I,NA) - Z(I,NA) = Q * ZZ + P * Z(I,EN) - Z(I,EN) = Q * Z(I,EN) - P * ZZ - 310 CONTINUE -C - GO TO 330 -C .......... COMPLEX PAIR .......... - 320 WR(NA) = X + P - WR(EN) = X + P - WI(NA) = ZZ - WI(EN) = -ZZ - 330 EN = ENM2 - GO TO 60 -C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND -C VECTORS OF UPPER TRIANGULAR FORM .......... - 340 IF (NORM .EQ. 0.0D0) GO TO 1001 -C .......... FOR EN=N STEP -1 UNTIL 1 DO -- .......... - DO 800 NN = 1, N - EN = N + 1 - NN - P = WR(EN) - Q = WI(EN) - NA = EN - 1 - IF (Q) 710, 600, 800 -C .......... REAL VECTOR .......... - 600 M = EN - H(EN,EN) = 1.0D0 - IF (NA .EQ. 0) GO TO 800 -C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- .......... - DO 700 II = 1, NA - I = EN - II - W = H(I,I) - P - R = 0.0D0 -C - DO 610 J = M, EN - 610 R = R + H(I,J) * H(J,EN) -C - IF (WI(I) .GE. 0.0D0) GO TO 630 - ZZ = W - S = R - GO TO 700 - 630 M = I - IF (WI(I) .NE. 0.0D0) GO TO 640 - T = W - IF (T .NE. 0.0D0) GO TO 635 - TST1 = NORM - T = TST1 - 632 T = 0.01D0 * T - TST2 = NORM + T - IF (TST2 .GT. TST1) GO TO 632 - 635 H(I,EN) = -R / T - GO TO 680 -C .......... SOLVE REAL EQUATIONS .......... - 640 X = H(I,I+1) - Y = H(I+1,I) - Q = (WR(I) - P) * (WR(I) - P) + WI(I) * WI(I) - T = (X * S - ZZ * R) / Q - H(I,EN) = T - IF (DABS(X) .LE. DABS(ZZ)) GO TO 650 - H(I+1,EN) = (-R - W * T) / X - GO TO 680 - 650 H(I+1,EN) = (-S - Y * T) / ZZ -C -C .......... OVERFLOW CONTROL .......... - 680 T = DABS(H(I,EN)) - IF (T .EQ. 0.0D0) GO TO 700 - TST1 = T - TST2 = TST1 + 1.0D0/TST1 - IF (TST2 .GT. TST1) GO TO 700 - DO 690 J = I, EN - H(J,EN) = H(J,EN)/T - 690 CONTINUE -C - 700 CONTINUE -C .......... END REAL VECTOR .......... - GO TO 800 -C .......... COMPLEX VECTOR .......... - 710 M = NA -C .......... LAST VECTOR COMPONENT CHOSEN IMAGINARY SO THAT -C EIGENVECTOR MATRIX IS TRIANGULAR .......... - IF (DABS(H(EN,NA)) .LE. DABS(H(NA,EN))) GO TO 720 - H(NA,NA) = Q / H(EN,NA) - H(NA,EN) = -(H(EN,EN) - P) / H(EN,NA) - GO TO 730 - 720 CALL CDIV(0.0D0,-H(NA,EN),H(NA,NA)-P,Q,H(NA,NA),H(NA,EN)) - 730 H(EN,NA) = 0.0D0 - H(EN,EN) = 1.0D0 - ENM2 = NA - 1 - IF (ENM2 .EQ. 0) GO TO 800 -C .......... FOR I=EN-2 STEP -1 UNTIL 1 DO -- .......... - DO 795 II = 1, ENM2 - I = NA - II - W = H(I,I) - P - RA = 0.0D0 - SA = 0.0D0 -C - DO 760 J = M, EN - RA = RA + H(I,J) * H(J,NA) - SA = SA + H(I,J) * H(J,EN) - 760 CONTINUE -C - IF (WI(I) .GE. 0.0D0) GO TO 770 - ZZ = W - R = RA - S = SA - GO TO 795 - 770 M = I - IF (WI(I) .NE. 0.0D0) GO TO 780 - CALL CDIV(-RA,-SA,W,Q,H(I,NA),H(I,EN)) - GO TO 790 -C .......... SOLVE COMPLEX EQUATIONS .......... - 780 X = H(I,I+1) - Y = H(I+1,I) - VR = (WR(I) - P) * (WR(I) - P) + WI(I) * WI(I) - Q * Q - VI = (WR(I) - P) * 2.0D0 * Q - IF (VR .NE. 0.0D0 .OR. VI .NE. 0.0D0) GO TO 784 - TST1 = NORM * (DABS(W) + DABS(Q) + DABS(X) - X + DABS(Y) + DABS(ZZ)) - VR = TST1 - 783 VR = 0.01D0 * VR - TST2 = TST1 + VR - IF (TST2 .GT. TST1) GO TO 783 - 784 CALL CDIV(X*R-ZZ*RA+Q*SA,X*S-ZZ*SA-Q*RA,VR,VI, - X H(I,NA),H(I,EN)) - IF (DABS(X) .LE. DABS(ZZ) + DABS(Q)) GO TO 785 - H(I+1,NA) = (-RA - W * H(I,NA) + Q * H(I,EN)) / X - H(I+1,EN) = (-SA - W * H(I,EN) - Q * H(I,NA)) / X - GO TO 790 - 785 CALL CDIV(-R-Y*H(I,NA),-S-Y*H(I,EN),ZZ,Q, - X H(I+1,NA),H(I+1,EN)) -C -C .......... OVERFLOW CONTROL .......... - 790 T = DMAX1(DABS(H(I,NA)), DABS(H(I,EN))) - IF (T .EQ. 0.0D0) GO TO 795 - TST1 = T - TST2 = TST1 + 1.0D0/TST1 - IF (TST2 .GT. TST1) GO TO 795 - DO 792 J = I, EN - H(J,NA) = H(J,NA)/T - H(J,EN) = H(J,EN)/T - 792 CONTINUE -C - 795 CONTINUE -C .......... END COMPLEX VECTOR .......... - 800 CONTINUE -C .......... END BACK SUBSTITUTION. -C VECTORS OF ISOLATED ROOTS .......... - DO 840 I = 1, N - IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840 -C - DO 820 J = I, N - 820 Z(I,J) = H(I,J) -C - 840 CONTINUE -C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE -C VECTORS OF ORIGINAL FULL MATRIX. -C FOR J=N STEP -1 UNTIL LOW DO -- .......... - DO 880 JJ = LOW, N - J = N + LOW - JJ - M = MIN0(J,IGH) -C - DO 880 I = LOW, IGH - ZZ = 0.0D0 -C - DO 860 K = LOW, M - 860 ZZ = ZZ + Z(I,K) * H(K,J) -C - Z(I,J) = ZZ - 880 CONTINUE -C - GO TO 1001 -C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT -C CONVERGED AFTER 30*N ITERATIONS .......... - 1000 IERR = EN - 1001 RETURN - END diff --git a/Libraries/MyEis/htribk.f b/Libraries/MyEis/htribk.f deleted file mode 100644 index cd97b8a8a..000000000 --- a/Libraries/MyEis/htribk.f +++ /dev/null @@ -1,91 +0,0 @@ - SUBROUTINE HTRIBK(NM,N,AR,AI,TAU,M,ZR,ZI) -C - INTEGER I,J,K,L,M,N,NM - DOUBLE PRECISION AR(NM,N),AI(NM,N),TAU(2,N),ZR(NM,M),ZI(NM,M) - DOUBLE PRECISION H,S,SI -C -C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF -C THE ALGOL PROCEDURE TRBAK1, NUM. MATH. 11, 181-195(1968) -C BY MARTIN, REINSCH, AND WILKINSON. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). -C -C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX HERMITIAN -C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING -C REAL SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY HTRIDI. -C -C ON INPUT -C -C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL -C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM -C DIMENSION STATEMENT. -C -C N IS THE ORDER OF THE MATRIX. -C -C AR AND AI CONTAIN INFORMATION ABOUT THE UNITARY TRANS- -C FORMATIONS USED IN THE REDUCTION BY HTRIDI IN THEIR -C FULL LOWER TRIANGLES EXCEPT FOR THE DIAGONAL OF AR. -C -C TAU CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS. -C -C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. -C -C ZR CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED -C IN ITS FIRST M COLUMNS. -C -C ON OUTPUT -C -C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, -C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS -C IN THEIR FIRST M COLUMNS. -C -C NOTE THAT THE LAST COMPONENT OF EACH RETURNED VECTOR -C IS REAL AND THAT VECTOR EUCLIDEAN NORMS ARE PRESERVED. -C -C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, -C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY -C -C THIS VERSION DATED AUGUST 1983. -C -C ------------------------------------------------------------------ -C - IF (M .EQ. 0) GO TO 200 -C .......... TRANSFORM THE EIGENVECTORS OF THE REAL SYMMETRIC -C TRIDIAGONAL MATRIX TO THOSE OF THE HERMITIAN -C TRIDIAGONAL MATRIX. .......... - DO 50 K = 1, N -C - DO 50 J = 1, M - ZI(K,J) = -ZR(K,J) * TAU(2,K) - ZR(K,J) = ZR(K,J) * TAU(1,K) - 50 CONTINUE -C - IF (N .EQ. 1) GO TO 200 -C .......... RECOVER AND APPLY THE HOUSEHOLDER MATRICES .......... - DO 140 I = 2, N - L = I - 1 - H = AI(I,I) - IF (H .EQ. 0.0D0) GO TO 140 -C - DO 130 J = 1, M - S = 0.0D0 - SI = 0.0D0 -C - DO 110 K = 1, L - S = S + AR(I,K) * ZR(K,J) - AI(I,K) * ZI(K,J) - SI = SI + AR(I,K) * ZI(K,J) + AI(I,K) * ZR(K,J) - 110 CONTINUE -C .......... DOUBLE DIVISIONS AVOID POSSIBLE UNDERFLOW .......... - S = (S / H) / H - SI = (SI / H) / H -C - DO 120 K = 1, L - ZR(K,J) = ZR(K,J) - S * AR(I,K) - SI * AI(I,K) - ZI(K,J) = ZI(K,J) - SI * AR(I,K) + S * AI(I,K) - 120 CONTINUE -C - 130 CONTINUE -C - 140 CONTINUE -C - 200 RETURN - END diff --git a/Libraries/MyEis/htridi.f b/Libraries/MyEis/htridi.f deleted file mode 100644 index c68881c00..000000000 --- a/Libraries/MyEis/htridi.f +++ /dev/null @@ -1,154 +0,0 @@ - SUBROUTINE HTRIDI(NM,N,AR,AI,D,E,E2,TAU) -C - INTEGER I,J,K,L,N,II,NM,JP1 - DOUBLE PRECISION AR(NM,N),AI(NM,N),D(N),E(N),E2(N),TAU(2,N) - DOUBLE PRECISION F,G,H,FI,GI,HH,SI,SCALE,PYTHAG -C -C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF -C THE ALGOL PROCEDURE TRED1, NUM. MATH. 11, 181-195(1968) -C BY MARTIN, REINSCH, AND WILKINSON. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). -C -C THIS SUBROUTINE REDUCES A COMPLEX HERMITIAN MATRIX -C TO A REAL SYMMETRIC TRIDIAGONAL MATRIX USING -C UNITARY SIMILARITY TRANSFORMATIONS. -C -C ON INPUT -C -C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL -C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM -C DIMENSION STATEMENT. -C -C N IS THE ORDER OF THE MATRIX. -C -C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, -C RESPECTIVELY, OF THE COMPLEX HERMITIAN INPUT MATRIX. -C ONLY THE LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED. -C -C ON OUTPUT -C -C AR AND AI CONTAIN INFORMATION ABOUT THE UNITARY TRANS- -C FORMATIONS USED IN THE REDUCTION IN THEIR FULL LOWER -C TRIANGLES. THEIR STRICT UPPER TRIANGLES AND THE -C DIAGONAL OF AR ARE UNALTERED. -C -C D CONTAINS THE DIAGONAL ELEMENTS OF THE THE TRIDIAGONAL MATRIX. -C -C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL -C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO. -C -C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. -C E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. -C -C TAU CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS. -C -C CALLS PYTHAG FOR DSQRT(A*A + B*B) . -C -C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, -C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY -C -C THIS VERSION DATED AUGUST 1983. -C -C ------------------------------------------------------------------ -C - TAU(1,N) = 1.0D0 - TAU(2,N) = 0.0D0 -C - DO 100 I = 1, N - 100 D(I) = AR(I,I) -C .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... - DO 300 II = 1, N - I = N + 1 - II - L = I - 1 - H = 0.0D0 - SCALE = 0.0D0 - IF (L .LT. 1) GO TO 130 -C .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... - DO 120 K = 1, L - 120 SCALE = SCALE + DABS(AR(I,K)) + DABS(AI(I,K)) -C - IF (SCALE .NE. 0.0D0) GO TO 140 - TAU(1,L) = 1.0D0 - TAU(2,L) = 0.0D0 - 130 E(I) = 0.0D0 - E2(I) = 0.0D0 - GO TO 290 -C - 140 DO 150 K = 1, L - AR(I,K) = AR(I,K) / SCALE - AI(I,K) = AI(I,K) / SCALE - H = H + AR(I,K) * AR(I,K) + AI(I,K) * AI(I,K) - 150 CONTINUE -C - E2(I) = SCALE * SCALE * H - G = DSQRT(H) - E(I) = SCALE * G - F = PYTHAG(AR(I,L),AI(I,L)) -C .......... FORM NEXT DIAGONAL ELEMENT OF MATRIX T .......... - IF (F .EQ. 0.0D0) GO TO 160 - TAU(1,L) = (AI(I,L) * TAU(2,I) - AR(I,L) * TAU(1,I)) / F - SI = (AR(I,L) * TAU(2,I) + AI(I,L) * TAU(1,I)) / F - H = H + F * G - G = 1.0D0 + G / F - AR(I,L) = G * AR(I,L) - AI(I,L) = G * AI(I,L) - IF (L .EQ. 1) GO TO 270 - GO TO 170 - 160 TAU(1,L) = -TAU(1,I) - SI = TAU(2,I) - AR(I,L) = G - 170 F = 0.0D0 -C - DO 240 J = 1, L - G = 0.0D0 - GI = 0.0D0 -C .......... FORM ELEMENT OF A*U .......... - DO 180 K = 1, J - G = G + AR(J,K) * AR(I,K) + AI(J,K) * AI(I,K) - GI = GI - AR(J,K) * AI(I,K) + AI(J,K) * AR(I,K) - 180 CONTINUE -C - JP1 = J + 1 - IF (L .LT. JP1) GO TO 220 -C - DO 200 K = JP1, L - G = G + AR(K,J) * AR(I,K) - AI(K,J) * AI(I,K) - GI = GI - AR(K,J) * AI(I,K) - AI(K,J) * AR(I,K) - 200 CONTINUE -C .......... FORM ELEMENT OF P .......... - 220 E(J) = G / H - TAU(2,J) = GI / H - F = F + E(J) * AR(I,J) - TAU(2,J) * AI(I,J) - 240 CONTINUE -C - HH = F / (H + H) -C .......... FORM REDUCED A .......... - DO 260 J = 1, L - F = AR(I,J) - G = E(J) - HH * F - E(J) = G - FI = -AI(I,J) - GI = TAU(2,J) - HH * FI - TAU(2,J) = -GI -C - DO 260 K = 1, J - AR(J,K) = AR(J,K) - F * E(K) - G * AR(I,K) - X + FI * TAU(2,K) + GI * AI(I,K) - AI(J,K) = AI(J,K) - F * TAU(2,K) - G * AI(I,K) - X - FI * E(K) - GI * AR(I,K) - 260 CONTINUE -C - 270 DO 280 K = 1, L - AR(I,K) = SCALE * AR(I,K) - AI(I,K) = SCALE * AI(I,K) - 280 CONTINUE -C - TAU(2,L) = -SI - 290 HH = D(I) - D(I) = AR(I,I) - AR(I,I) = HH - AI(I,I) = SCALE * DSQRT(H) - 300 CONTINUE -C - RETURN - END diff --git a/Libraries/MyEis/pythag.f b/Libraries/MyEis/pythag.f deleted file mode 100644 index b4a8ba6ed..000000000 --- a/Libraries/MyEis/pythag.f +++ /dev/null @@ -1,20 +0,0 @@ - DOUBLE PRECISION FUNCTION PYTHAG(A,B) - DOUBLE PRECISION A,B -C -C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW -C - DOUBLE PRECISION P,R,S,T,U - P = DMAX1(DABS(A),DABS(B)) - IF (P .EQ. 0.0D0) GO TO 20 - R = (DMIN1(DABS(A),DABS(B))/P)**2 - 10 CONTINUE - T = 4.0D0 + R - IF (T .EQ. 4.0D0) GO TO 20 - S = R/T - U = 1.0D0 + 2.0D0*S - P = U*P - R = (S/U)**2 * R - GO TO 10 - 20 PYTHAG = P - RETURN - END diff --git a/Libraries/MyEis/rg.f b/Libraries/MyEis/rg.f deleted file mode 100644 index 34545aea3..000000000 --- a/Libraries/MyEis/rg.f +++ /dev/null @@ -1,70 +0,0 @@ - SUBROUTINE RG(NM,N,A,WR,WI,MATZ,Z,IV1,FV1,IERR) -C - INTEGER N,NM,IS1,IS2,IERR,MATZ - DOUBLE PRECISION A(NM,N),WR(N),WI(N),Z(NM,N),FV1(N) - INTEGER IV1(N) -C -C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF -C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) -C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) -C OF A REAL GENERAL MATRIX. -C -C ON INPUT -C -C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL -C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM -C DIMENSION STATEMENT. -C -C N IS THE ORDER OF THE MATRIX A. -C -C A CONTAINS THE REAL GENERAL MATRIX. -C -C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF -C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO -C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. -C -C ON OUTPUT -C -C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, -C RESPECTIVELY, OF THE EIGENVALUES. COMPLEX CONJUGATE -C PAIRS OF EIGENVALUES APPEAR CONSECUTIVELY WITH THE -C EIGENVALUE HAVING THE POSITIVE IMAGINARY PART FIRST. -C -C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS -C IF MATZ IS NOT ZERO. IF THE J-TH EIGENVALUE IS REAL, THE -C J-TH COLUMN OF Z CONTAINS ITS EIGENVECTOR. IF THE J-TH -C EIGENVALUE IS COMPLEX WITH POSITIVE IMAGINARY PART, THE -C J-TH AND (J+1)-TH COLUMNS OF Z CONTAIN THE REAL AND -C IMAGINARY PARTS OF ITS EIGENVECTOR. THE CONJUGATE OF THIS -C VECTOR IS THE EIGENVECTOR FOR THE CONJUGATE EIGENVALUE. -C -C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR -C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR HQR -C AND HQR2. THE NORMAL COMPLETION CODE IS ZERO. -C -C IV1 AND FV1 ARE TEMPORARY STORAGE ARRAYS. -C -C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, -C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY -C -C THIS VERSION DATED AUGUST 1983. -C -C ------------------------------------------------------------------ -C - IF (N .LE. NM) GO TO 10 - IERR = 10 * N - GO TO 50 -C - 10 CALL BALANC(NM,N,A,IS1,IS2,FV1) - CALL ELMHES(NM,N,IS1,IS2,A,IV1) - IF (MATZ .NE. 0) GO TO 20 -C .......... FIND EIGENVALUES ONLY .......... - CALL HQR(NM,N,IS1,IS2,A,WR,WI,IERR) - GO TO 50 -C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... - 20 CALL ELTRAN(NM,N,IS1,IS2,A,IV1,Z) - CALL HQR2(NM,N,IS1,IS2,A,WR,WI,Z,IERR) - IF (IERR .NE. 0) GO TO 50 - CALL BALBAK(NM,N,IS1,IS2,FV1,N,Z) - 50 RETURN - END diff --git a/Libraries/MyEis/rs.f b/Libraries/MyEis/rs.f deleted file mode 100644 index 1adcb959d..000000000 --- a/Libraries/MyEis/rs.f +++ /dev/null @@ -1,57 +0,0 @@ - SUBROUTINE RS(NM,N,A,W,MATZ,Z,FV1,FV2,IERR) -C - INTEGER N,NM,IERR,MATZ - DOUBLE PRECISION A(NM,N),W(N),Z(NM,N),FV1(N),FV2(N) -C -C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF -C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) -C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) -C OF A REAL SYMMETRIC MATRIX. -C -C ON INPUT -C -C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL -C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM -C DIMENSION STATEMENT. -C -C N IS THE ORDER OF THE MATRIX A. -C -C A CONTAINS THE REAL SYMMETRIC MATRIX. -C -C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF -C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO -C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. -C -C ON OUTPUT -C -C W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. -C -C Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO. -C -C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR -C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT -C AND TQL2. THE NORMAL COMPLETION CODE IS ZERO. -C -C FV1 AND FV2 ARE TEMPORARY STORAGE ARRAYS. -C -C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, -C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY -C -C THIS VERSION DATED AUGUST 1983. -C -C ------------------------------------------------------------------ -C - IF (N .LE. NM) GO TO 10 - IERR = 10 * N - GO TO 50 -C - 10 IF (MATZ .NE. 0) GO TO 20 -C .......... FIND EIGENVALUES ONLY .......... - CALL TRED1(NM,N,A,W,FV1,FV2) - CALL TQLRAT(N,W,FV2,IERR) - GO TO 50 -C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... - 20 CALL TRED2(NM,N,A,W,FV1,Z) - CALL TQL2(NM,N,W,FV1,Z,IERR) - 50 RETURN - END diff --git a/Libraries/MyEis/tql2.f b/Libraries/MyEis/tql2.f deleted file mode 100644 index 92321bc5a..000000000 --- a/Libraries/MyEis/tql2.f +++ /dev/null @@ -1,170 +0,0 @@ - SUBROUTINE TQL2(NM,N,D,E,Z,IERR) -C - INTEGER I,J,K,L,M,N,II,L1,L2,NM,MML,IERR - DOUBLE PRECISION D(N),E(N),Z(NM,N) - DOUBLE PRECISION C,C2,C3,DL1,EL1,F,G,H,P,R,S,S2,TST1,TST2,PYTHAG -C -C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQL2, -C NUM. MATH. 11, 293-306(1968) BY BOWDLER, MARTIN, REINSCH, AND -C WILKINSON. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971). -C -C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS -C OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE QL METHOD. -C THE EIGENVECTORS OF A FULL SYMMETRIC MATRIX CAN ALSO -C BE FOUND IF TRED2 HAS BEEN USED TO REDUCE THIS -C FULL MATRIX TO TRIDIAGONAL FORM. -C -C ON INPUT -C -C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL -C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM -C DIMENSION STATEMENT. -C -C N IS THE ORDER OF THE MATRIX. -C -C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. -C -C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX -C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. -C -C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE -C REDUCTION BY TRED2, IF PERFORMED. IF THE EIGENVECTORS -C OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN -C THE IDENTITY MATRIX. -C -C ON OUTPUT -C -C D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN -C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT -C UNORDERED FOR INDICES 1,2,...,IERR-1. -C -C E HAS BEEN DESTROYED. -C -C Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC -C TRIDIAGONAL (OR FULL) MATRIX. IF AN ERROR EXIT IS MADE, -C Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED -C EIGENVALUES. -C -C IERR IS SET TO -C ZERO FOR NORMAL RETURN, -C J IF THE J-TH EIGENVALUE HAS NOT BEEN -C DETERMINED AFTER 30 ITERATIONS. -C -C CALLS PYTHAG FOR DSQRT(A*A + B*B) . -C -C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, -C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY -C -C THIS VERSION DATED AUGUST 1983. -C -C ------------------------------------------------------------------ -C - IERR = 0 - IF (N .EQ. 1) GO TO 1001 -C - DO 100 I = 2, N - 100 E(I-1) = E(I) -C - F = 0.0D0 - TST1 = 0.0D0 - E(N) = 0.0D0 -C - DO 240 L = 1, N - J = 0 - H = DABS(D(L)) + DABS(E(L)) - IF (TST1 .LT. H) TST1 = H -C .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT .......... - DO 110 M = L, N - TST2 = TST1 + DABS(E(M)) - IF (TST2 .EQ. TST1) GO TO 120 -C .......... E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT -C THROUGH THE BOTTOM OF THE LOOP .......... - 110 CONTINUE -C - 120 IF (M .EQ. L) GO TO 220 - 130 IF (J .EQ. 30) GO TO 1000 - J = J + 1 -C .......... FORM SHIFT .......... - L1 = L + 1 - L2 = L1 + 1 - G = D(L) - P = (D(L1) - G) / (2.0D0 * E(L)) - R = PYTHAG(P,1.0D0) - D(L) = E(L) / (P + DSIGN(R,P)) - D(L1) = E(L) * (P + DSIGN(R,P)) - DL1 = D(L1) - H = G - D(L) - IF (L2 .GT. N) GO TO 145 -C - DO 140 I = L2, N - 140 D(I) = D(I) - H -C - 145 F = F + H -C .......... QL TRANSFORMATION .......... - P = D(M) - C = 1.0D0 - C2 = C - EL1 = E(L1) - S = 0.0D0 - MML = M - L -C .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... - DO 200 II = 1, MML - C3 = C2 - C2 = C - S2 = S - I = M - II - G = C * E(I) - H = C * P - R = PYTHAG(P,E(I)) - E(I+1) = S * R - S = E(I) / R - C = P / R - P = C * D(I) - S * G - D(I+1) = H + S * (C * G + S * D(I)) -C .......... FORM VECTOR .......... - DO 180 K = 1, N - H = Z(K,I+1) - Z(K,I+1) = S * Z(K,I) + C * H - Z(K,I) = C * Z(K,I) - S * H - 180 CONTINUE -C - 200 CONTINUE -C - P = -S * S2 * C3 * EL1 * E(L) / DL1 - E(L) = S * P - D(L) = C * P - TST2 = TST1 + DABS(E(L)) - IF (TST2 .GT. TST1) GO TO 130 - 220 D(L) = D(L) + F - 240 CONTINUE -C .......... ORDER EIGENVALUES AND EIGENVECTORS .......... - DO 300 II = 2, N - I = II - 1 - K = I - P = D(I) -C - DO 260 J = II, N - IF (D(J) .GE. P) GO TO 260 - K = J - P = D(J) - 260 CONTINUE -C - IF (K .EQ. I) GO TO 300 - D(K) = D(I) - D(I) = P -C - DO 280 J = 1, N - P = Z(J,I) - Z(J,I) = Z(J,K) - Z(J,K) = P - 280 CONTINUE -C - 300 CONTINUE -C - GO TO 1001 -C .......... SET ERROR -- NO CONVERGENCE TO AN -C EIGENVALUE AFTER 30 ITERATIONS .......... - 1000 IERR = L - 1001 RETURN - END diff --git a/Libraries/MyEis/tqlrat.f b/Libraries/MyEis/tqlrat.f deleted file mode 100644 index 41d9c382a..000000000 --- a/Libraries/MyEis/tqlrat.f +++ /dev/null @@ -1,130 +0,0 @@ - SUBROUTINE TQLRAT(N,D,E2,IERR) -C - INTEGER I,J,L,M,N,II,L1,MML,IERR - DOUBLE PRECISION D(N),E2(N) - DOUBLE PRECISION B,C,F,G,H,P,R,S,T,EPSLON,PYTHAG -C -C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQLRAT, -C ALGORITHM 464, COMM. ACM 16, 689(1973) BY REINSCH. -C -C THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC -C TRIDIAGONAL MATRIX BY THE RATIONAL QL METHOD. -C -C ON INPUT -C -C N IS THE ORDER OF THE MATRIX. -C -C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. -C -C E2 CONTAINS THE SQUARES OF THE SUBDIAGONAL ELEMENTS OF THE -C INPUT MATRIX IN ITS LAST N-1 POSITIONS. E2(1) IS ARBITRARY. -C -C ON OUTPUT -C -C D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN -C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND -C ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE -C THE SMALLEST EIGENVALUES. -C -C E2 HAS BEEN DESTROYED. -C -C IERR IS SET TO -C ZERO FOR NORMAL RETURN, -C J IF THE J-TH EIGENVALUE HAS NOT BEEN -C DETERMINED AFTER 30 ITERATIONS. -C -C CALLS PYTHAG FOR DSQRT(A*A + B*B) . -C -C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, -C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY -C -C THIS VERSION DATED AUGUST 1983. -C -C ------------------------------------------------------------------ -C - IERR = 0 - IF (N .EQ. 1) GO TO 1001 -C - DO 100 I = 2, N - 100 E2(I-1) = E2(I) -C - F = 0.0D0 - T = 0.0D0 - E2(N) = 0.0D0 -C - DO 290 L = 1, N - J = 0 - H = DABS(D(L)) + DSQRT(E2(L)) - IF (T .GT. H) GO TO 105 - T = H - B = EPSLON(T) - C = B * B -C .......... LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT .......... - 105 DO 110 M = L, N - IF (E2(M) .LE. C) GO TO 120 -C .......... E2(N) IS ALWAYS ZERO, SO THERE IS NO EXIT -C THROUGH THE BOTTOM OF THE LOOP .......... - 110 CONTINUE -C - 120 IF (M .EQ. L) GO TO 210 - 130 IF (J .EQ. 30) GO TO 1000 - J = J + 1 -C .......... FORM SHIFT .......... - L1 = L + 1 - S = DSQRT(E2(L)) - G = D(L) - P = (D(L1) - G) / (2.0D0 * S) - R = PYTHAG(P,1.0D0) - D(L) = S / (P + DSIGN(R,P)) - H = G - D(L) -C - DO 140 I = L1, N - 140 D(I) = D(I) - H -C - F = F + H -C .......... RATIONAL QL TRANSFORMATION .......... - G = D(M) - IF (G .EQ. 0.0D0) G = B - H = G - S = 0.0D0 - MML = M - L -C .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... - DO 200 II = 1, MML - I = M - II - P = G * H - R = P + E2(I) - E2(I+1) = S * R - S = E2(I) / R - D(I+1) = H + S * (H + D(I)) - G = D(I) - E2(I) / G - IF (G .EQ. 0.0D0) G = B - H = G * P / R - 200 CONTINUE -C - E2(L) = S * G - D(L) = H -C .......... GUARD AGAINST UNDERFLOW IN CONVERGENCE TEST .......... - IF (H .EQ. 0.0D0) GO TO 210 - IF (DABS(E2(L)) .LE. DABS(C/H)) GO TO 210 - E2(L) = H * E2(L) - IF (E2(L) .NE. 0.0D0) GO TO 130 - 210 P = D(L) + F -C .......... ORDER EIGENVALUES .......... - IF (L .EQ. 1) GO TO 250 -C .......... FOR I=L STEP -1 UNTIL 2 DO -- .......... - DO 230 II = 2, L - I = L + 2 - II - IF (P .GE. D(I-1)) GO TO 270 - D(I) = D(I-1) - 230 CONTINUE -C - 250 I = 1 - 270 D(I) = P - 290 CONTINUE -C - GO TO 1001 -C .......... SET ERROR -- NO CONVERGENCE TO AN -C EIGENVALUE AFTER 30 ITERATIONS .......... - 1000 IERR = L - 1001 RETURN - END diff --git a/Libraries/MyEis/tred1.f b/Libraries/MyEis/tred1.f deleted file mode 100644 index cf916ed32..000000000 --- a/Libraries/MyEis/tred1.f +++ /dev/null @@ -1,135 +0,0 @@ - SUBROUTINE TRED1(NM,N,A,D,E,E2) -C - INTEGER I,J,K,L,N,II,NM,JP1 - DOUBLE PRECISION A(NM,N),D(N),E(N),E2(N) - DOUBLE PRECISION F,G,H,SCALE -C -C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED1, -C NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). -C -C THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX -C TO A SYMMETRIC TRIDIAGONAL MATRIX USING -C ORTHOGONAL SIMILARITY TRANSFORMATIONS. -C -C ON INPUT -C -C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL -C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM -C DIMENSION STATEMENT. -C -C N IS THE ORDER OF THE MATRIX. -C -C A CONTAINS THE REAL SYMMETRIC INPUT MATRIX. ONLY THE -C LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED. -C -C ON OUTPUT -C -C A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS- -C FORMATIONS USED IN THE REDUCTION IN ITS STRICT LOWER -C TRIANGLE. THE FULL UPPER TRIANGLE OF A IS UNALTERED. -C -C D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX. -C -C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL -C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO. -C -C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. -C E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. -C -C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, -C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY -C -C THIS VERSION DATED AUGUST 1983. -C -C ------------------------------------------------------------------ -C - DO 100 I = 1, N - D(I) = A(N,I) - A(N,I) = A(I,I) - 100 CONTINUE -C .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... - DO 300 II = 1, N - I = N + 1 - II - L = I - 1 - H = 0.0D0 - SCALE = 0.0D0 - IF (L .LT. 1) GO TO 130 -C .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... - DO 120 K = 1, L - 120 SCALE = SCALE + DABS(D(K)) -C - IF (SCALE .NE. 0.0D0) GO TO 140 -C - DO 125 J = 1, L - D(J) = A(L,J) - A(L,J) = A(I,J) - A(I,J) = 0.0D0 - 125 CONTINUE -C - 130 E(I) = 0.0D0 - E2(I) = 0.0D0 - GO TO 300 -C - 140 DO 150 K = 1, L - D(K) = D(K) / SCALE - H = H + D(K) * D(K) - 150 CONTINUE -C - E2(I) = SCALE * SCALE * H - F = D(L) - G = -DSIGN(DSQRT(H),F) - E(I) = SCALE * G - H = H - F * G - D(L) = F - G - IF (L .EQ. 1) GO TO 285 -C .......... FORM A*U .......... - DO 170 J = 1, L - 170 E(J) = 0.0D0 -C - DO 240 J = 1, L - F = D(J) - G = E(J) + A(J,J) * F - JP1 = J + 1 - IF (L .LT. JP1) GO TO 220 -C - DO 200 K = JP1, L - G = G + A(K,J) * D(K) - E(K) = E(K) + A(K,J) * F - 200 CONTINUE -C - 220 E(J) = G - 240 CONTINUE -C .......... FORM P .......... - F = 0.0D0 -C - DO 245 J = 1, L - E(J) = E(J) / H - F = F + E(J) * D(J) - 245 CONTINUE -C - H = F / (H + H) -C .......... FORM Q .......... - DO 250 J = 1, L - 250 E(J) = E(J) - H * D(J) -C .......... FORM REDUCED A .......... - DO 280 J = 1, L - F = D(J) - G = E(J) -C - DO 260 K = J, L - 260 A(K,J) = A(K,J) - F * E(K) - G * D(K) -C - 280 CONTINUE -C - 285 DO 290 J = 1, L - F = D(J) - D(J) = A(L,J) - A(L,J) = A(I,J) - A(I,J) = F * SCALE - 290 CONTINUE -C - 300 CONTINUE -C - RETURN - END diff --git a/Libraries/MyEis/tred2.f b/Libraries/MyEis/tred2.f deleted file mode 100644 index 098703366..000000000 --- a/Libraries/MyEis/tred2.f +++ /dev/null @@ -1,164 +0,0 @@ - SUBROUTINE TRED2(NM,N,A,D,E,Z) -C - INTEGER I,J,K,L,N,II,NM,JP1 - DOUBLE PRECISION A(NM,N),D(N),E(N),Z(NM,N) - DOUBLE PRECISION F,G,H,HH,SCALE -C -C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED2, -C NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. -C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). -C -C THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX TO A -C SYMMETRIC TRIDIAGONAL MATRIX USING AND ACCUMULATING -C ORTHOGONAL SIMILARITY TRANSFORMATIONS. -C -C ON INPUT -C -C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL -C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM -C DIMENSION STATEMENT. -C -C N IS THE ORDER OF THE MATRIX. -C -C A CONTAINS THE REAL SYMMETRIC INPUT MATRIX. ONLY THE -C LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED. -C -C ON OUTPUT -C -C D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX. -C -C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL -C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO. -C -C Z CONTAINS THE ORTHOGONAL TRANSFORMATION MATRIX -C PRODUCED IN THE REDUCTION. -C -C A AND Z MAY COINCIDE. IF DISTINCT, A IS UNALTERED. -C -C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, -C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY -C -C THIS VERSION DATED AUGUST 1983. -C -C ------------------------------------------------------------------ -C - DO 100 I = 1, N -C - DO 80 J = I, N - 80 Z(J,I) = A(J,I) -C - D(I) = A(N,I) - 100 CONTINUE -C - IF (N .EQ. 1) GO TO 510 -C .......... FOR I=N STEP -1 UNTIL 2 DO -- .......... - DO 300 II = 2, N - I = N + 2 - II - L = I - 1 - H = 0.0D0 - SCALE = 0.0D0 - IF (L .LT. 2) GO TO 130 -C .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... - DO 120 K = 1, L - 120 SCALE = SCALE + DABS(D(K)) -C - IF (SCALE .NE. 0.0D0) GO TO 140 - 130 E(I) = D(L) -C - DO 135 J = 1, L - D(J) = Z(L,J) - Z(I,J) = 0.0D0 - Z(J,I) = 0.0D0 - 135 CONTINUE -C - GO TO 290 -C - 140 DO 150 K = 1, L - D(K) = D(K) / SCALE - H = H + D(K) * D(K) - 150 CONTINUE -C - F = D(L) - G = -DSIGN(DSQRT(H),F) - E(I) = SCALE * G - H = H - F * G - D(L) = F - G -C .......... FORM A*U .......... - DO 170 J = 1, L - 170 E(J) = 0.0D0 -C - DO 240 J = 1, L - F = D(J) - Z(J,I) = F - G = E(J) + Z(J,J) * F - JP1 = J + 1 - IF (L .LT. JP1) GO TO 220 -C - DO 200 K = JP1, L - G = G + Z(K,J) * D(K) - E(K) = E(K) + Z(K,J) * F - 200 CONTINUE -C - 220 E(J) = G - 240 CONTINUE -C .......... FORM P .......... - F = 0.0D0 -C - DO 245 J = 1, L - E(J) = E(J) / H - F = F + E(J) * D(J) - 245 CONTINUE -C - HH = F / (H + H) -C .......... FORM Q .......... - DO 250 J = 1, L - 250 E(J) = E(J) - HH * D(J) -C .......... FORM REDUCED A .......... - DO 280 J = 1, L - F = D(J) - G = E(J) -C - DO 260 K = J, L - 260 Z(K,J) = Z(K,J) - F * E(K) - G * D(K) -C - D(J) = Z(L,J) - Z(I,J) = 0.0D0 - 280 CONTINUE -C - 290 D(I) = H - 300 CONTINUE -C .......... ACCUMULATION OF TRANSFORMATION MATRICES .......... - DO 500 I = 2, N - L = I - 1 - Z(N,L) = Z(L,L) - Z(L,L) = 1.0D0 - H = D(I) - IF (H .EQ. 0.0D0) GO TO 380 -C - DO 330 K = 1, L - 330 D(K) = Z(K,I) / H -C - DO 360 J = 1, L - G = 0.0D0 -C - DO 340 K = 1, L - 340 G = G + Z(K,I) * Z(K,J) -C - DO 360 K = 1, L - Z(K,J) = Z(K,J) - G * D(K) - 360 CONTINUE -C - 380 DO 400 K = 1, L - 400 Z(K,I) = 0.0D0 -C - 500 CONTINUE -C - 510 DO 520 I = 1, N - D(I) = Z(N,I) - Z(N,I) = 0.0D0 - 520 CONTINUE -C - Z(N,N) = 1.0D0 - E(1) = 0.0D0 - RETURN - END diff --git a/Libraries/MyLin/Makefile b/Libraries/MyLin/Makefile deleted file mode 100644 index 6ab5dbefc..000000000 --- a/Libraries/MyLin/Makefile +++ /dev/null @@ -1,8 +0,0 @@ -LIB=liblin.a -OBJS= cgedi.o cgefa.o dgedi.o dgefa.o zgedi.o zgefa.o zqrdc.o zqrsl.o -$(LIB): $(OBJS) - ar r $(LIB) $(OBJS) -.f.o: - $(FC) $(FLAGS) $< -clean: - rm $(LIB) $(OBJS) diff --git a/Libraries/MyLin/bidon b/Libraries/MyLin/bidon deleted file mode 100644 index dbea126e0..000000000 --- a/Libraries/MyLin/bidon +++ /dev/null @@ -1,6 +0,0 @@ -dgedi.f -dgefa.f -zgedi.f -zgefa.f -zqrdc.f -zqrsl.f diff --git a/Libraries/MyLin/cgedi.f b/Libraries/MyLin/cgedi.f deleted file mode 100644 index 3467f3104..000000000 --- a/Libraries/MyLin/cgedi.f +++ /dev/null @@ -1,131 +0,0 @@ - subroutine cgedi(a,lda,n,ipvt,det,work,job) - integer lda,n,ipvt(1),job - complex a(lda,1),det(2),work(1) -c -c cgedi computes the determinant and inverse of a matrix -c using the factors computed by cgeco or cgefa. -c -c on entry -c -c a complex(lda, n) -c the output from cgeco or cgefa. -c -c lda integer -c the leading dimension of the array a . -c -c n integer -c the order of the matrix a . -c -c ipvt integer(n) -c the pivot vector from cgeco or cgefa. -c -c work complex(n) -c work vector. contents destroyed. -c -c job integer -c = 11 both determinant and inverse. -c = 01 inverse only. -c = 10 determinant only. -c -c on return -c -c a inverse of original matrix if requested. -c otherwise unchanged. -c -c det complex(2) -c determinant of original matrix if requested. -c otherwise not referenced. -c determinant = det(1) * 10.0**det(2) -c with 1.0 .le. cabs1(det(1)) .lt. 10.0 -c or det(1) .eq. 0.0 . -c -c error condition -c -c a division by zero will occur if the input factor contains -c a zero on the diagonal and the inverse is requested. -c it will not occur if the subroutines are called correctly -c and if cgeco has set rcond .gt. 0.0 or cgefa has set -c info .eq. 0 . -c -c linpack. this version dated 08/14/78 . -c cleve moler, university of new mexico, argonne national lab. -c -c subroutines and functions -c -c blas caxpy,cscal,cswap -c fortran abs,aimag,cmplx,mod,real -c -c internal variables -c - complex t - real ten - integer i,j,k,kb,kp1,l,nm1 -c - complex zdum - real cabs1 - cabs1(zdum) = abs(real(zdum)) + abs(aimag(zdum)) -c -c compute determinant -c - if (job/10 .eq. 0) go to 70 - det(1) = (1.0e0,0.0e0) - det(2) = (0.0e0,0.0e0) - ten = 10.0e0 - do 50 i = 1, n - if (ipvt(i) .ne. i) det(1) = -det(1) - det(1) = a(i,i)*det(1) -c ...exit - if (cabs1(det(1)) .eq. 0.0e0) go to 60 - 10 if (cabs1(det(1)) .ge. 1.0e0) go to 20 - det(1) = cmplx(ten,0.0e0)*det(1) - det(2) = det(2) - (1.0e0,0.0e0) - go to 10 - 20 continue - 30 if (cabs1(det(1)) .lt. ten) go to 40 - det(1) = det(1)/cmplx(ten,0.0e0) - det(2) = det(2) + (1.0e0,0.0e0) - go to 30 - 40 continue - 50 continue - 60 continue - 70 continue -c -c compute inverse(u) -c - if (mod(job,10) .eq. 0) go to 150 - do 100 k = 1, n - a(k,k) = (1.0e0,0.0e0)/a(k,k) - t = -a(k,k) - call cscal(k-1,t,a(1,k),1) - kp1 = k + 1 - if (n .lt. kp1) go to 90 - do 80 j = kp1, n - t = a(k,j) - a(k,j) = (0.0e0,0.0e0) - call caxpy(k,t,a(1,k),1,a(1,j),1) - 80 continue - 90 continue - 100 continue -c -c form inverse(u)*inverse(l) -c - nm1 = n - 1 - if (nm1 .lt. 1) go to 140 - do 130 kb = 1, nm1 - k = n - kb - kp1 = k + 1 - do 110 i = kp1, n - work(i) = a(i,k) - a(i,k) = (0.0e0,0.0e0) - 110 continue - do 120 j = kp1, n - t = work(j) - call caxpy(n,t,a(1,j),1,a(1,k),1) - 120 continue - l = ipvt(k) - if (l .ne. k) call cswap(n,a(1,k),1,a(1,l),1) - 130 continue - 140 continue - 150 continue - return - end diff --git a/Libraries/MyLin/cgefa.f b/Libraries/MyLin/cgefa.f deleted file mode 100644 index ba12cb860..000000000 --- a/Libraries/MyLin/cgefa.f +++ /dev/null @@ -1,107 +0,0 @@ - subroutine cgefa(a,lda,n,ipvt,info) - integer lda,n,ipvt(1),info - complex a(lda,1) -c -c cgefa factors a complex matrix by gaussian elimination. -c -c cgefa is usually called by cgeco, but it can be called -c directly with a saving in time if rcond is not needed. -c (time for cgeco) = (1 + 9/n)*(time for cgefa) . -c -c on entry -c -c a complex(lda, n) -c the matrix to be factored. -c -c lda integer -c the leading dimension of the array a . -c -c n integer -c the order of the matrix a . -c -c on return -c -c a an upper triangular matrix and the multipliers -c which were used to obtain it. -c the factorization can be written a = l*u where -c l is a product of permutation and unit lower -c triangular matrices and u is upper triangular. -c -c ipvt integer(n) -c an integer vector of pivot indices. -c -c info integer -c = 0 normal value. -c = k if u(k,k) .eq. 0.0 . this is not an error -c condition for this subroutine, but it does -c indicate that cgesl or cgedi will divide by zero -c if called. use rcond in cgeco for a reliable -c indication of singularity. -c -c linpack. this version dated 08/14/78 . -c cleve moler, university of new mexico, argonne national lab. -c -c subroutines and functions -c -c blas caxpy,cscal,icamax -c fortran abs,aimag,real -c -c internal variables -c - complex t - integer icamax,j,k,kp1,l,nm1 -c - complex zdum - real cabs1 - cabs1(zdum) = abs(real(zdum)) + abs(aimag(zdum)) -c -c gaussian elimination with partial pivoting -c - info = 0 - nm1 = n - 1 - if (nm1 .lt. 1) go to 70 - do 60 k = 1, nm1 - kp1 = k + 1 -c -c find l = pivot index -c - l = icamax(n-k+1,a(k,k),1) + k - 1 - ipvt(k) = l -c -c zero pivot implies this column already triangularized -c - if (cabs1(a(l,k)) .eq. 0.0e0) go to 40 -c -c interchange if necessary -c - if (l .eq. k) go to 10 - t = a(l,k) - a(l,k) = a(k,k) - a(k,k) = t - 10 continue -c -c compute multipliers -c - t = -(1.0e0,0.0e0)/a(k,k) - call cscal(n-k,t,a(k+1,k),1) -c -c row elimination with column indexing -c - do 30 j = kp1, n - t = a(l,j) - if (l .eq. k) go to 20 - a(l,j) = a(k,j) - a(k,j) = t - 20 continue - call caxpy(n-k,t,a(k+1,k),1,a(k+1,j),1) - 30 continue - go to 50 - 40 continue - info = k - 50 continue - 60 continue - 70 continue - ipvt(n) = n - if (cabs1(a(n,n)) .eq. 0.0e0) info = n - return - end diff --git a/Libraries/MyLin/dgedi.f b/Libraries/MyLin/dgedi.f deleted file mode 100644 index 2c02b62b3..000000000 --- a/Libraries/MyLin/dgedi.f +++ /dev/null @@ -1,128 +0,0 @@ - subroutine dgedi(a,lda,n,ipvt,det,work,job) - integer lda,n,ipvt(1),job - double precision a(lda,1),det(2),work(1) -c -c dgedi computes the determinant and inverse of a matrix -c using the factors computed by dgeco or dgefa. -c -c on entry -c -c a double precision(lda, n) -c the output from dgeco or dgefa. -c -c lda integer -c the leading dimension of the array a . -c -c n integer -c the order of the matrix a . -c -c ipvt integer(n) -c the pivot vector from dgeco or dgefa. -c -c work double precision(n) -c work vector. contents destroyed. -c -c job integer -c = 11 both determinant and inverse. -c = 01 inverse only. -c = 10 determinant only. -c -c on return -c -c a inverse of original matrix if requested. -c otherwise unchanged. -c -c det double precision(2) -c determinant of original matrix if requested. -c otherwise not referenced. -c determinant = det(1) * 10.0**det(2) -c with 1.0 .le. dabs(det(1)) .lt. 10.0 -c or det(1) .eq. 0.0 . -c -c error condition -c -c a division by zero will occur if the input factor contains -c a zero on the diagonal and the inverse is requested. -c it will not occur if the subroutines are called correctly -c and if dgeco has set rcond .gt. 0.0 or dgefa has set -c info .eq. 0 . -c -c linpack. this version dated 08/14/78 . -c cleve moler, university of new mexico, argonne national lab. -c -c subroutines and functions -c -c blas daxpy,dscal,dswap -c fortran dabs,mod -c -c internal variables -c - double precision t - double precision ten - integer i,j,k,kb,kp1,l,nm1 -c -c -c compute determinant -c - if (job/10 .eq. 0) go to 70 - det(1) = 1.0d0 - det(2) = 0.0d0 - ten = 10.0d0 - do 50 i = 1, n - if (ipvt(i) .ne. i) det(1) = -det(1) - det(1) = a(i,i)*det(1) -c ...exit - if (det(1) .eq. 0.0d0) go to 60 - 10 if (dabs(det(1)) .ge. 1.0d0) go to 20 - det(1) = ten*det(1) - det(2) = det(2) - 1.0d0 - go to 10 - 20 continue - 30 if (dabs(det(1)) .lt. ten) go to 40 - det(1) = det(1)/ten - det(2) = det(2) + 1.0d0 - go to 30 - 40 continue - 50 continue - 60 continue - 70 continue -c -c compute inverse(u) -c - if (mod(job,10) .eq. 0) go to 150 - do 100 k = 1, n - a(k,k) = 1.0d0/a(k,k) - t = -a(k,k) - call dscal(k-1,t,a(1,k),1) - kp1 = k + 1 - if (n .lt. kp1) go to 90 - do 80 j = kp1, n - t = a(k,j) - a(k,j) = 0.0d0 - call daxpy(k,t,a(1,k),1,a(1,j),1) - 80 continue - 90 continue - 100 continue -c -c form inverse(u)*inverse(l) -c - nm1 = n - 1 - if (nm1 .lt. 1) go to 140 - do 130 kb = 1, nm1 - k = n - kb - kp1 = k + 1 - do 110 i = kp1, n - work(i) = a(i,k) - a(i,k) = 0.0d0 - 110 continue - do 120 j = kp1, n - t = work(j) - call daxpy(n,t,a(1,j),1,a(1,k),1) - 120 continue - l = ipvt(k) - if (l .ne. k) call dswap(n,a(1,k),1,a(1,l),1) - 130 continue - 140 continue - 150 continue - return - end diff --git a/Libraries/MyLin/dgefa.f b/Libraries/MyLin/dgefa.f deleted file mode 100644 index 37d705f14..000000000 --- a/Libraries/MyLin/dgefa.f +++ /dev/null @@ -1,103 +0,0 @@ - subroutine dgefa(a,lda,n,ipvt,info) - integer lda,n,ipvt(1),info - double precision a(lda,1) -c -c dgefa factors a double precision matrix by gaussian elimination. -c -c dgefa is usually called by dgeco, but it can be called -c directly with a saving in time if rcond is not needed. -c (time for dgeco) = (1 + 9/n)*(time for dgefa) . -c -c on entry -c -c a double precision(lda, n) -c the matrix to be factored. -c -c lda integer -c the leading dimension of the array a . -c -c n integer -c the order of the matrix a . -c -c on return -c -c a an upper triangular matrix and the multipliers -c which were used to obtain it. -c the factorization can be written a = l*u where -c l is a product of permutation and unit lower -c triangular matrices and u is upper triangular. -c -c ipvt integer(n) -c an integer vector of pivot indices. -c -c info integer -c = 0 normal value. -c = k if u(k,k) .eq. 0.0 . this is not an error -c condition for this subroutine, but it does -c indicate that dgesl or dgedi will divide by zero -c if called. use rcond in dgeco for a reliable -c indication of singularity. -c -c linpack. this version dated 08/14/78 . -c cleve moler, university of new mexico, argonne national lab. -c -c subroutines and functions -c -c blas daxpy,dscal,idamax -c -c internal variables -c - double precision t - integer idamax,j,k,kp1,l,nm1 -c -c -c gaussian elimination with partial pivoting -c - info = 0 - nm1 = n - 1 - if (nm1 .lt. 1) go to 70 - do 60 k = 1, nm1 - kp1 = k + 1 -c -c find l = pivot index -c - l = idamax(n-k+1,a(k,k),1) + k - 1 - ipvt(k) = l -c -c zero pivot implies this column already triangularized -c - if (a(l,k) .eq. 0.0d0) go to 40 -c -c interchange if necessary -c - if (l .eq. k) go to 10 - t = a(l,k) - a(l,k) = a(k,k) - a(k,k) = t - 10 continue -c -c compute multipliers -c - t = -1.0d0/a(k,k) - call dscal(n-k,t,a(k+1,k),1) -c -c row elimination with column indexing -c - do 30 j = kp1, n - t = a(l,j) - if (l .eq. k) go to 20 - a(l,j) = a(k,j) - a(k,j) = t - 20 continue - call daxpy(n-k,t,a(k+1,k),1,a(k+1,j),1) - 30 continue - go to 50 - 40 continue - info = k - 50 continue - 60 continue - 70 continue - ipvt(n) = n - if (a(n,n) .eq. 0.0d0) info = n - return - end diff --git a/Libraries/MyLin/work.pc b/Libraries/MyLin/work.pc deleted file mode 100644 index 285842ebb80eef69e4e17d1058603f49efe83fba..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 1016 zcmZ9KJ4*vW6os#bn6)y9h>uPMA&7*OB4W%MQBwG-L|B$t69ReZMvYU5rKP2%rC9nq zEUhiA{0)ic&dw~88JNtO`}pq3u(|EttqA)&%U+!pi!(IsHE3;qjyxhNVjoWuy-yJ3 z*NGr0L%3jZ-Kwq|VR4L4&dy?Iu$OcU$Jk;<2@%8Cf_51`V$7&nImmP|qmG;L+kti& z1H_o|WaS{!#f(?n4C4*jWqcsUj87{EnJ#90;bs`$&@ST#u`Kqlm4i$dGxB&i^BxP( zE@K5T_EE5MDFA{Qdluu!s$&+ebdDcpTv|Doafh7wFOOE8VLWTbi&=3!XAW zk2F)109EQKQcsa_G6fyg@+j#@rl2F4BGr^#w--}RPW=iylh-$qU}s9GDNM~#Bs(|l zQs7y=QMWI+Le0-o#k_|wPL)7~&`yPRDzsB{RLg&uio(RH68s)QIUTya%IR6HkT{K7 Q+G)(MEk#$owjA^I4?RovNB{r; diff --git a/Libraries/MyLin/work.pcl b/Libraries/MyLin/work.pcl deleted file mode 100644 index 7f6c06e22..000000000 --- a/Libraries/MyLin/work.pcl +++ /dev/null @@ -1 +0,0 @@ -work.pc diff --git a/Libraries/MyLin/zgedi.f b/Libraries/MyLin/zgedi.f deleted file mode 100644 index eab9c9052..000000000 --- a/Libraries/MyLin/zgedi.f +++ /dev/null @@ -1,135 +0,0 @@ - subroutine zgedi(a,lda,n,ipvt,det,work,job) - integer lda,n,ipvt(1),job - complex*16 a(lda,1),det(2),work(1) -c -c zgedi computes the determinant and inverse of a matrix -c using the factors computed by zgeco or zgefa. -c -c on entry -c -c a complex*16(lda, n) -c the output from zgeco or zgefa. -c -c lda integer -c the leading dimension of the array a . -c -c n integer -c the order of the matrix a . -c -c ipvt integer(n) -c the pivot vector from zgeco or zgefa. -c -c work complex*16(n) -c work vector. contents destroyed. -c -c job integer -c = 11 both determinant and inverse. -c = 01 inverse only. -c = 10 determinant only. -c -c on return -c -c a inverse of original matrix if requested. -c otherwise unchanged. -c -c det complex*16(2) -c determinant of original matrix if requested. -c otherwise not referenced. -c determinant = det(1) * 10.0**det(2) -c with 1.0 .le. cabs1(det(1)) .lt. 10.0 -c or det(1) .eq. 0.0 . -c -c error condition -c -c a division by zero will occur if the input factor contains -c a zero on the diagonal and the inverse is requested. -c it will not occur if the subroutines are called correctly -c and if zgeco has set rcond .gt. 0.0 or zgefa has set -c info .eq. 0 . -c -c linpack. this version dated 08/14/78 . -c cleve moler, university of new mexico, argonne national lab. -c -c subroutines and functions -c -c blas zaxpy,zscal,zswap -c fortran dabs,dcmplx,mod -c -c internal variables -c - complex*16 t - double precision ten - integer i,j,k,kb,kp1,l,nm1 -c - complex*16 zdum - double precision cabs1 - double precision dreal,dimag - complex*16 zdumr,zdumi - dreal(zdumr) = zdumr - dimag(zdumi) = (0.0d0,-1.0d0)*zdumi - cabs1(zdum) = dabs(dreal(zdum)) + dabs(dimag(zdum)) -c -c compute determinant -c - if (job/10 .eq. 0) go to 70 - det(1) = (1.0d0,0.0d0) - det(2) = (0.0d0,0.0d0) - ten = 10.0d0 - do 50 i = 1, n - if (ipvt(i) .ne. i) det(1) = -det(1) - det(1) = a(i,i)*det(1) -c ...exit - if (cabs1(det(1)) .eq. 0.0d0) go to 60 - 10 if (cabs1(det(1)) .ge. 1.0d0) go to 20 - det(1) = dcmplx(ten,0.0d0)*det(1) - det(2) = det(2) - (1.0d0,0.0d0) - go to 10 - 20 continue - 30 if (cabs1(det(1)) .lt. ten) go to 40 - det(1) = det(1)/dcmplx(ten,0.0d0) - det(2) = det(2) + (1.0d0,0.0d0) - go to 30 - 40 continue - 50 continue - 60 continue - 70 continue -c -c compute inverse(u) -c - if (mod(job,10) .eq. 0) go to 150 - do 100 k = 1, n - a(k,k) = (1.0d0,0.0d0)/a(k,k) - t = -a(k,k) - call zscal(k-1,t,a(1,k),1) - kp1 = k + 1 - if (n .lt. kp1) go to 90 - do 80 j = kp1, n - t = a(k,j) - a(k,j) = (0.0d0,0.0d0) - call zaxpy(k,t,a(1,k),1,a(1,j),1) - 80 continue - 90 continue - 100 continue -c -c form inverse(u)*inverse(l) -c - nm1 = n - 1 - if (nm1 .lt. 1) go to 140 - do 130 kb = 1, nm1 - k = n - kb - kp1 = k + 1 - do 110 i = kp1, n - work(i) = a(i,k) - a(i,k) = (0.0d0,0.0d0) - 110 continue - do 120 j = kp1, n - t = work(j) - call zaxpy(n,t,a(1,j),1,a(1,k),1) - 120 continue - l = ipvt(k) - if (l .ne. k) call zswap(n,a(1,k),1,a(1,l),1) - 130 continue - 140 continue - 150 continue - return - end diff --git a/Libraries/MyLin/zgefa.f b/Libraries/MyLin/zgefa.f deleted file mode 100644 index f5dba9739..000000000 --- a/Libraries/MyLin/zgefa.f +++ /dev/null @@ -1,111 +0,0 @@ - subroutine zgefa(a,lda,n,ipvt,info) - integer lda,n,ipvt(1),info - complex*16 a(lda,1) -c -c zgefa factors a complex*16 matrix by gaussian elimination. -c -c zgefa is usually called by zgeco, but it can be called -c directly with a saving in time if rcond is not needed. -c (time for zgeco) = (1 + 9/n)*(time for zgefa) . -c -c on entry -c -c a complex*16(lda, n) -c the matrix to be factored. -c -c lda integer -c the leading dimension of the array a . -c -c n integer -c the order of the matrix a . -c -c on return -c -c a an upper triangular matrix and the multipliers -c which were used to obtain it. -c the factorization can be written a = l*u where -c l is a product of permutation and unit lower -c triangular matrices and u is upper triangular. -c -c ipvt integer(n) -c an integer vector of pivot indices. -c -c info integer -c = 0 normal value. -c = k if u(k,k) .eq. 0.0 . this is not an error -c condition for this subroutine, but it does -c indicate that zgesl or zgedi will divide by zero -c if called. use rcond in zgeco for a reliable -c indication of singularity. -c -c linpack. this version dated 08/14/78 . -c cleve moler, university of new mexico, argonne national lab. -c -c subroutines and functions -c -c blas zaxpy,zscal,izamax -c fortran dabs -c -c internal variables -c - complex*16 t - integer izamax,j,k,kp1,l,nm1 -c - complex*16 zdum - double precision cabs1 - double precision dreal,dimag - complex*16 zdumr,zdumi - dreal(zdumr) = zdumr - dimag(zdumi) = (0.0d0,-1.0d0)*zdumi - cabs1(zdum) = dabs(dreal(zdum)) + dabs(dimag(zdum)) -c -c gaussian elimination with partial pivoting -c - info = 0 - nm1 = n - 1 - if (nm1 .lt. 1) go to 70 - do 60 k = 1, nm1 - kp1 = k + 1 -c -c find l = pivot index -c - l = izamax(n-k+1,a(k,k),1) + k - 1 - ipvt(k) = l -c -c zero pivot implies this column already triangularized -c - if (cabs1(a(l,k)) .eq. 0.0d0) go to 40 -c -c interchange if necessary -c - if (l .eq. k) go to 10 - t = a(l,k) - a(l,k) = a(k,k) - a(k,k) = t - 10 continue -c -c compute multipliers -c - t = -(1.0d0,0.0d0)/a(k,k) - call zscal(n-k,t,a(k+1,k),1) -c -c row elimination with column indexing -c - do 30 j = kp1, n - t = a(l,j) - if (l .eq. k) go to 20 - a(l,j) = a(k,j) - a(k,j) = t - 20 continue - call zaxpy(n-k,t,a(k+1,k),1,a(k+1,j),1) - 30 continue - go to 50 - 40 continue - info = k - 50 continue - 60 continue - 70 continue - ipvt(n) = n - if (cabs1(a(n,n)) .eq. 0.0d0) info = n - return - end diff --git a/Libraries/MyLin/zqrdc.f b/Libraries/MyLin/zqrdc.f deleted file mode 100644 index fd81c52a9..000000000 --- a/Libraries/MyLin/zqrdc.f +++ /dev/null @@ -1,218 +0,0 @@ - subroutine zqrdc(x,ldx,n,p,qraux,jpvt,work,job) - integer ldx,n,p,job - integer jpvt(1) - complex*16 x(ldx,1),qraux(1),work(1) -c -c zqrdc uses householder transformations to compute the qr -c factorization of an n by p matrix x. column pivoting -c based on the 2-norms of the reduced columns may be -c performed at the users option. -c -c on entry -c -c x complex*16(ldx,p), where ldx .ge. n. -c x contains the matrix whose decomposition is to be -c computed. -c -c ldx integer. -c ldx is the leading dimension of the array x. -c -c n integer. -c n is the number of rows of the matrix x. -c -c p integer. -c p is the number of columns of the matrix x. -c -c jpvt integer(p). -c jpvt contains integers that control the selection -c of the pivot columns. the k-th column x(k) of x -c is placed in one of three classes according to the -c value of jpvt(k). -c -c if jpvt(k) .gt. 0, then x(k) is an initial -c column. -c -c if jpvt(k) .eq. 0, then x(k) is a free column. -c -c if jpvt(k) .lt. 0, then x(k) is a final column. -c -c before the decomposition is computed, initial columns -c are moved to the beginning of the array x and final -c columns to the end. both initial and final columns -c are frozen in place during the computation and only -c free columns are moved. at the k-th stage of the -c reduction, if x(k) is occupied by a free column -c it is interchanged with the free column of largest -c reduced norm. jpvt is not referenced if -c job .eq. 0. -c -c work complex*16(p). -c work is a work array. work is not referenced if -c job .eq. 0. -c -c job integer. -c job is an integer that initiates column pivoting. -c if job .eq. 0, no pivoting is done. -c if job .ne. 0, pivoting is done. -c -c on return -c -c x x contains in its upper triangle the upper -c triangular matrix r of the qr factorization. -c below its diagonal x contains information from -c which the unitary part of the decomposition -c can be recovered. note that if pivoting has -c been requested, the decomposition is not that -c of the original matrix x but that of x -c with its columns permuted as described by jpvt. -c -c qraux complex*16(p). -c qraux contains further information required to recover -c the unitary part of the decomposition. -c -c jpvt jpvt(k) contains the index of the column of the -c original matrix that has been interchanged into -c the k-th column, if pivoting was requested. -c -c linpack. this version dated 08/14/78 . -c g.w. stewart, university of maryland, argonne national lab. -c -c zqrdc uses the following functions and subprograms. -c -c blas zaxpy,zdotc,zscal,zswap,dznrm2 -c fortran dabs,dmax1,cdabs,dcmplx,cdsqrt,min0 -c -c internal variables -c - integer j,jp,l,lp1,lup,maxj,pl,pu - double precision maxnrm,dznrm2,tt - complex*16 zdotc,nrmxl,t - logical negj,swapj -c - complex*16 csign,zdum,zdum1,zdum2 - double precision cabs1 - double precision dreal,dimag - complex*16 zdumr,zdumi - dreal(zdumr) = zdumr - dimag(zdumi) = (0.0d0,-1.0d0)*zdumi - csign(zdum1,zdum2) = cdabs(zdum1)*(zdum2/cdabs(zdum2)) - cabs1(zdum) = dabs(dreal(zdum)) + dabs(dimag(zdum)) -c - pl = 1 - pu = 0 - if (job .eq. 0) go to 60 -c -c pivoting has been requested. rearrange the columns -c according to jpvt. -c - do 20 j = 1, p - swapj = jpvt(j) .gt. 0 - negj = jpvt(j) .lt. 0 - jpvt(j) = j - if (negj) jpvt(j) = -j - if (.not.swapj) go to 10 - if (j .ne. pl) call zswap(n,x(1,pl),1,x(1,j),1) - jpvt(j) = jpvt(pl) - jpvt(pl) = j - pl = pl + 1 - 10 continue - 20 continue - pu = p - do 50 jj = 1, p - j = p - jj + 1 - if (jpvt(j) .ge. 0) go to 40 - jpvt(j) = -jpvt(j) - if (j .eq. pu) go to 30 - call zswap(n,x(1,pu),1,x(1,j),1) - jp = jpvt(pu) - jpvt(pu) = jpvt(j) - jpvt(j) = jp - 30 continue - pu = pu - 1 - 40 continue - 50 continue - 60 continue -c -c compute the norms of the free columns. -c - if (pu .lt. pl) go to 80 - do 70 j = pl, pu - qraux(j) = dcmplx(dznrm2(n,x(1,j),1),0.0d0) - work(j) = qraux(j) - 70 continue - 80 continue -c -c perform the householder reduction of x. -c - lup = min0(n,p) - do 200 l = 1, lup - if (l .lt. pl .or. l .ge. pu) go to 120 -c -c locate the column of largest norm and bring it -c into the pivot position. -c - maxnrm = 0.0d0 - maxj = l - do 100 j = l, pu - if (dreal(qraux(j)) .le. maxnrm) go to 90 - maxnrm = dreal(qraux(j)) - maxj = j - 90 continue - 100 continue - if (maxj .eq. l) go to 110 - call zswap(n,x(1,l),1,x(1,maxj),1) - qraux(maxj) = qraux(l) - work(maxj) = work(l) - jp = jpvt(maxj) - jpvt(maxj) = jpvt(l) - jpvt(l) = jp - 110 continue - 120 continue - qraux(l) = (0.0d0,0.0d0) - if (l .eq. n) go to 190 -c -c compute the householder transformation for column l. -c - nrmxl = dcmplx(dznrm2(n-l+1,x(l,l),1),0.0d0) - if (cabs1(nrmxl) .eq. 0.0d0) go to 180 - if (cabs1(x(l,l)) .ne. 0.0d0) - * nrmxl = csign(nrmxl,x(l,l)) - call zscal(n-l+1,(1.0d0,0.0d0)/nrmxl,x(l,l),1) - x(l,l) = (1.0d0,0.0d0) + x(l,l) -c -c apply the transformation to the remaining columns, -c updating the norms. -c - lp1 = l + 1 - if (p .lt. lp1) go to 170 - do 160 j = lp1, p - t = -zdotc(n-l+1,x(l,l),1,x(l,j),1)/x(l,l) - call zaxpy(n-l+1,t,x(l,l),1,x(l,j),1) - if (j .lt. pl .or. j .gt. pu) go to 150 - if (cabs1(qraux(j)) .eq. 0.0d0) go to 150 - tt = 1.0d0 - (cdabs(x(l,j))/dreal(qraux(j)))**2 - tt = dmax1(tt,0.0d0) - t = dcmplx(tt,0.0d0) - tt = 1.0d0 - * + 0.05d0*tt - * *(dreal(qraux(j))/dreal(work(j)))**2 - if (tt .eq. 1.0d0) go to 130 - qraux(j) = qraux(j)*cdsqrt(t) - go to 140 - 130 continue - qraux(j) = dcmplx(dznrm2(n-l,x(l+1,j),1),0.0d0) - work(j) = qraux(j) - 140 continue - 150 continue - 160 continue - 170 continue -c -c save the transformation. -c - qraux(l) = x(l,l) - x(l,l) = -nrmxl - 180 continue - 190 continue - 200 continue - return - end diff --git a/Libraries/MyLin/zqrsl.f b/Libraries/MyLin/zqrsl.f deleted file mode 100644 index 6ee5f382b..000000000 --- a/Libraries/MyLin/zqrsl.f +++ /dev/null @@ -1,280 +0,0 @@ - subroutine zqrsl(x,ldx,n,k,qraux,y,qy,qty,b,rsd,xb,job,info) - integer ldx,n,k,job,info - complex*16 x(ldx,1),qraux(1),y(1),qy(1),qty(1),b(1),rsd(1),xb(1) -c -c zqrsl applies the output of zqrdc to compute coordinate -c transformations, projections, and least squares solutions. -c for k .le. min(n,p), let xk be the matrix -c -c xk = (x(jpvt(1)),x(jpvt(2)), ... ,x(jpvt(k))) -c -c formed from columnns jpvt(1), ... ,jpvt(k) of the original -c n x p matrix x that was input to zqrdc (if no pivoting was -c done, xk consists of the first k columns of x in their -c original order). zqrdc produces a factored unitary matrix q -c and an upper triangular matrix r such that -c -c xk = q * (r) -c (0) -c -c this information is contained in coded form in the arrays -c x and qraux. -c -c on entry -c -c x complex*16(ldx,p). -c x contains the output of zqrdc. -c -c ldx integer. -c ldx is the leading dimension of the array x. -c -c n integer. -c n is the number of rows of the matrix xk. it must -c have the same value as n in zqrdc. -c -c k integer. -c k is the number of columns of the matrix xk. k -c must nnot be greater than min(n,p), where p is the -c same as in the calling sequence to zqrdc. -c -c qraux complex*16(p). -c qraux contains the auxiliary output from zqrdc. -c -c y complex*16(n) -c y contains an n-vector that is to be manipulated -c by zqrsl. -c -c job integer. -c job specifies what is to be computed. job has -c the decimal expansion abcde, with the following -c meaning. -c -c if a.ne.0, compute qy. -c if b,c,d, or e .ne. 0, compute qty. -c if c.ne.0, compute b. -c if d.ne.0, compute rsd. -c if e.ne.0, compute xb. -c -c note that a request to compute b, rsd, or xb -c automatically triggers the computation of qty, for -c which an array must be provided in the calling -c sequence. -c -c on return -c -c qy complex*16(n). -c qy conntains q*y, if its computation has been -c requested. -c -c qty complex*16(n). -c qty contains ctrans(q)*y, if its computation has -c been requested. here ctrans(q) is the conjugate -c transpose of the matrix q. -c -c b complex*16(k) -c b contains the solution of the least squares problem -c -c minimize norm2(y - xk*b), -c -c if its computation has been requested. (note that -c if pivoting was requested in zqrdc, the j-th -c component of b will be associated with column jpvt(j) -c of the original matrix x that was input into zqrdc.) -c -c rsd complex*16(n). -c rsd contains the least squares residual y - xk*b, -c if its computation has been requested. rsd is -c also the orthogonal projection of y onto the -c orthogonal complement of the column space of xk. -c -c xb complex*16(n). -c xb contains the least squares approximation xk*b, -c if its computation has been requested. xb is also -c the orthogonal projection of y onto the column space -c of x. -c -c info integer. -c info is zero unless the computation of b has -c been requested and r is exactly singular. in -c this case, info is the index of the first zero -c diagonal element of r and b is left unaltered. -c -c the parameters qy, qty, b, rsd, and xb are not referenced -c if their computation is not requested and in this case -c can be replaced by dummy variables in the calling program. -c to save storage, the user may in some cases use the same -c array for different parameters in the calling sequence. a -c frequently occuring example is when one wishes to compute -c any of b, rsd, or xb and does not need y or qty. in this -c case one may identify y, qty, and one of b, rsd, or xb, while -c providing separate arrays for anything else that is to be -c computed. thus the calling sequence -c -c call zqrsl(x,ldx,n,k,qraux,y,dum,y,b,y,dum,110,info) -c -c will result in the computation of b and rsd, with rsd -c overwriting y. more generally, each item in the following -c list contains groups of permissible identifications for -c a single callinng sequence. -c -c 1. (y,qty,b) (rsd) (xb) (qy) -c -c 2. (y,qty,rsd) (b) (xb) (qy) -c -c 3. (y,qty,xb) (b) (rsd) (qy) -c -c 4. (y,qy) (qty,b) (rsd) (xb) -c -c 5. (y,qy) (qty,rsd) (b) (xb) -c -c 6. (y,qy) (qty,xb) (b) (rsd) -c -c in any group the value returned in the array allocated to -c the group corresponds to the last member of the group. -c -c linpack. this version dated 08/14/78 . -c g.w. stewart, university of maryland, argonne national lab. -c -c zqrsl uses the following functions and subprograms. -c -c blas zaxpy,zcopy,zdotc -c fortran dabs,min0,mod -c -c internal variables -c - integer i,j,jj,ju,kp1 - complex*16 zdotc,t,temp - logical cb,cqy,cqty,cr,cxb -c - complex*16 zdum - double precision cabs1 - double precision dreal,dimag - complex*16 zdumr,zdumi - dreal(zdumr) = zdumr - dimag(zdumi) = (0.0d0,-1.0d0)*zdumi - cabs1(zdum) = dabs(dreal(zdum)) + dabs(dimag(zdum)) -c -c set info flag. -c - info = 0 -c -c determine what is to be computed. -c - cqy = job/10000 .ne. 0 - cqty = mod(job,10000) .ne. 0 - cb = mod(job,1000)/100 .ne. 0 - cr = mod(job,100)/10 .ne. 0 - cxb = mod(job,10) .ne. 0 - ju = min0(k,n-1) -c -c special action when n=1. -c - if (ju .ne. 0) go to 40 - if (cqy) qy(1) = y(1) - if (cqty) qty(1) = y(1) - if (cxb) xb(1) = y(1) - if (.not.cb) go to 30 - if (cabs1(x(1,1)) .ne. 0.0d0) go to 10 - info = 1 - go to 20 - 10 continue - b(1) = y(1)/x(1,1) - 20 continue - 30 continue - if (cr) rsd(1) = (0.0d0,0.0d0) - go to 250 - 40 continue -c -c set up to compute qy or qty. -c - if (cqy) call zcopy(n,y,1,qy,1) - if (cqty) call zcopy(n,y,1,qty,1) - if (.not.cqy) go to 70 -c -c compute qy. -c - do 60 jj = 1, ju - j = ju - jj + 1 - if (cabs1(qraux(j)) .eq. 0.0d0) go to 50 - temp = x(j,j) - x(j,j) = qraux(j) - t = -zdotc(n-j+1,x(j,j),1,qy(j),1)/x(j,j) - call zaxpy(n-j+1,t,x(j,j),1,qy(j),1) - x(j,j) = temp - 50 continue - 60 continue - 70 continue - if (.not.cqty) go to 100 -c -c compute ctrans(q)*y. -c - do 90 j = 1, ju - if (cabs1(qraux(j)) .eq. 0.0d0) go to 80 - temp = x(j,j) - x(j,j) = qraux(j) - t = -zdotc(n-j+1,x(j,j),1,qty(j),1)/x(j,j) - call zaxpy(n-j+1,t,x(j,j),1,qty(j),1) - x(j,j) = temp - 80 continue - 90 continue - 100 continue -c -c set up to compute b, rsd, or xb. -c - if (cb) call zcopy(k,qty,1,b,1) - kp1 = k + 1 - if (cxb) call zcopy(k,qty,1,xb,1) - if (cr .and. k .lt. n) call zcopy(n-k,qty(kp1),1,rsd(kp1),1) - if (.not.cxb .or. kp1 .gt. n) go to 120 - do 110 i = kp1, n - xb(i) = (0.0d0,0.0d0) - 110 continue - 120 continue - if (.not.cr) go to 140 - do 130 i = 1, k - rsd(i) = (0.0d0,0.0d0) - 130 continue - 140 continue - if (.not.cb) go to 190 -c -c compute b. -c - do 170 jj = 1, k - j = k - jj + 1 - if (cabs1(x(j,j)) .ne. 0.0d0) go to 150 - info = j -c ......exit - go to 180 - 150 continue - b(j) = b(j)/x(j,j) - if (j .eq. 1) go to 160 - t = -b(j) - call zaxpy(j-1,t,x(1,j),1,b,1) - 160 continue - 170 continue - 180 continue - 190 continue - if (.not.cr .and. .not.cxb) go to 240 -c -c compute rsd or xb as required. -c - do 230 jj = 1, ju - j = ju - jj + 1 - if (cabs1(qraux(j)) .eq. 0.0d0) go to 220 - temp = x(j,j) - x(j,j) = qraux(j) - if (.not.cr) go to 200 - t = -zdotc(n-j+1,x(j,j),1,rsd(j),1)/x(j,j) - call zaxpy(n-j+1,t,x(j,j),1,rsd(j),1) - 200 continue - if (.not.cxb) go to 210 - t = -zdotc(n-j+1,x(j,j),1,xb(j),1)/x(j,j) - call zaxpy(n-j+1,t,x(j,j),1,xb(j),1) - 210 continue - x(j,j) = temp - 220 continue - 230 continue - 240 continue - 250 continue - return - end diff --git a/Libraries/MyNag/F01QCF.f b/Libraries/MyNag/F01QCF.f deleted file mode 100644 index d597b551e..000000000 --- a/Libraries/MyNag/F01QCF.f +++ /dev/null @@ -1,258 +0,0 @@ - SUBROUTINE F01QCF(M,N,A,LDA,ZETA,IFAIL) -C MARK 14 RELEASE. NAG COPYRIGHT 1989. -C -C 1. Purpose -C ======= -C -C F01QCF finds the QR factorization of the real m by n, m .ge. n, -C matrix A, so that A is reduced to upper triangular form by means of -C orthogonal transformations. -C -C 2. Description -C =========== -C -C The m by n matrix A is factorized as -C -C A = Q*( R ) when m.gt.n, -C ( 0 ) -C -C A = Q*R when m = n, -C -C where Q is an m by m orthogonal matrix and R is an n by n upper -C triangular matrix. -C -C The factorization is obtained by Householder's method. The kth -C transformation matrix, Q( k ), which is used to introduce zeros into -C the kth column of A is given in the form -C -C Q( k ) = ( I 0 ), -C ( 0 T( k ) ) -C -C where -C -C T( k ) = I - u( k )*u( k )', -C -C u( k ) = ( zeta( k ) ), -C ( z( k ) ) -C -C zeta( k ) is a scalar and z( k ) is an ( m - k ) element vector. -C zeta( k ) and z( k ) are chosen to annhilate the elements below the -C triangular part of A. -C -C The vector u( k ) is returned in the kth element of ZETA and in the -C kth column of A, such that zeta( k ) is in ZETA( k ) and the elements -C of z( k ) are in a( k + 1, k ), ..., a( m, k ). The elements of R -C are returned in the upper triangular part of A. -C -C Q is given by -C -C Q = ( Q( n )*Q( n - 1 )*...*Q( 1 ) )'. -C -C 3. Parameters -C ========== -C -C M - INTEGER. -C -C On entry, M must specify the number of rows of A. M must be -C at least n. -C -C Unchanged on exit. -C -C N - INTEGER. -C -C On entry, N must specify the number of columns of A. N must -C be at least zero. When N = 0 then an immediate return is -C effected. -C -C Unchanged on exit. -C -C A - REAL array of DIMENSION ( LDA, n ). -C -C Before entry, the leading M by N part of the array A must -C contain the matrix to be factorized. -C -C On exit, the N by N upper triangular part of A will contain -C the upper triangular matrix R and the M by N strictly lower -C triangular part of A will contain details of the -C factorization as described above. -C -C LDA - INTEGER. -C -C On entry, LDA must specify the leading dimension of the -C array A as declared in the calling (sub) program. LDA must -C be at least m. -C -C Unchanged on exit. -C -C ZETA - REAL array of DIMENSION at least ( n ). -C -C On exit, ZETA( k ) contains the scalar zeta( k ) for the -C kth transformation. If T( k ) = I then ZETA( k ) = 0.0, -C otherwise ZETA( k ) contains zeta( k ) as described above -C and zeta( k ) is always in the range ( 1.0, sqrt( 2.0 ) ). -C -C IFAIL - INTEGER. -C -C Before entry, IFAIL must contain one of the values -1 or 0 -C or 1 to specify noisy soft failure or noisy hard failure or -C silent soft failure. ( See Chapter P01 for further details.) -C -C On successful exit IFAIL will be zero, otherwise IFAIL -C will be set to -1 indicating that an input parameter has -C been incorrectly set. See the next section for further -C details. -C -C 4. Diagnostic Information -C ====================== -C -C IFAIL = -1 -C -C One or more of the following conditions holds: -C -C M .lt. N -C N .lt. 0 -C LDA .lt. M -C -C If on entry, IFAIL was either -1 or 0 then further diagnostic -C information will be output on the error message channel. ( See -C routine X04AAF. ) -C -C 5. Further information -C =================== -C -C Following the use of this routine the operations -C -C B := Q*B and B := Q'*B, -C -C where B is an m by k matrix, can be performed by calls to the -C NAG Library routine F01QDF. The operation B := Q*B can be obtained -C by the call: -C -C IFAIL = 0 -C CALL F01QDF( 'No transpose', 'Separate', M, N, A, LDA, ZETA, -C $ K, B, LDB, WORK, IFAIL ) -C -C and B := Q'*B can be obtained by the call: -C -C IFAIL = 0 -C CALL F01QDF( 'Transpose', 'Separate', M, N, A, LDA, ZETA, -C $ K, B, LDB, WORK, IFAIL ) -C -C In both cases WORK must be a k element array that is used as -C workspace. If B is a one-dimensional array (single column) then the -C parameter LDB can be replaced by M. See routine F01QDF for further -C details. -C -C The first k columns of the orthogonal matrix Q can either be obtained -C by setting B to the first k columns of the unit matrix and using the -C first of the above two calls, or by calling the NAG Library routine -C F01QEF, which overwrites the k columns of Q on the first k columns of -C the array A. Q is obtained by the call: -C -C CALL F01QEF( 'Separate', M, N, K, A, LDA, ZETA, WORK, IFAIL ) -C -C As above WORK must be a k element array. If K is larger than N, then -C A must have been declared to have at least K columns. -C -C Operations involving the matrix R can readily be performed by the -C Level 2 BLAS routines DTRSV and DTRMV (see Chapter F06), but note -C that no test for near singularity of R is incorporated in DTRSV . -C If R is singular, or nearly singular then the NAG Library routine -C F02WUF can be used to determine the singular value decomposition -C of R. -C -C -C Nag Fortran 77 Auxiliary linear algebra routine. -C -C -- Written on 21-December-1985. -C Sven Hammarling, Nag Central Office. -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) - CHARACTER*6 SRNAME - PARAMETER (SRNAME='F01QCF') -C .. Scalar Arguments .. - INTEGER IFAIL, LDA, M, N -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), ZETA(*) -C .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER IERR, K, LA -C .. Local Arrays .. - CHARACTER*46 REC(1) -C .. External Functions .. - INTEGER P01ABF - EXTERNAL P01ABF -C .. External Subroutines .. - EXTERNAL DGEMV, DGER, F06FRF, P01ABY -C .. Intrinsic Functions .. - INTRINSIC MIN -C .. Executable Statements .. -C -C Check the input parameters. -C - IERR = 0 - IF (M.LT.N) CALL P01ABY(M,'M',IFAIL,IERR,SRNAME) - IF (N.LT.0) CALL P01ABY(N,'N',IFAIL,IERR,SRNAME) - IF (LDA.LT.M) CALL P01ABY(LDA,'LDA',IFAIL,IERR,SRNAME) - IF (IERR.GT.0) THEN - WRITE (REC,FMT=99999) IERR - IFAIL = P01ABF(IFAIL,-1,SRNAME,1,REC) - RETURN - END IF -C -C Perform the factorization. -C - IF (N.EQ.0) THEN - IFAIL = P01ABF(IFAIL,0,SRNAME,0,REC) - RETURN - END IF - LA = LDA - DO 20 K = 1, MIN(M-1,N) -C -C Use a Householder reflection to zero the kth column of A. -C First set up the reflection. -C - CALL F06FRF(M-K,A(K,K),A(K+1,K),1,ZERO,ZETA(K)) - IF ((ZETA(K).GT.ZERO) .AND. (K.LT.N)) THEN - IF ((K+1).EQ.N) LA = M - K + 1 -C -C Temporarily store beta and put zeta( k ) in a( k, k ). -C - TEMP = A(K,K) - A(K,K) = ZETA(K) -C -C We now perform the operation A := Q( k )*A. -C -C Let B denote the bottom ( m - k + 1 ) by ( n - k ) part -C of A. -C -C First form work = B'*u. ( work is stored in the elements -C ZETA( k + 1 ), ..., ZETA( n ). ) -C - CALL DGEMV('Transpose',M-K+1,N-K,ONE,A(K,K+1),LA,A(K,K),1, - * ZERO,ZETA(K+1),1) -C -C Now form B := B - u*work'. -C - CALL DGER(M-K+1,N-K,-ONE,A(K,K),1,ZETA(K+1),1,A(K,K+1),LA) -C -C Restore beta. -C - A(K,K) = TEMP - END IF - 20 CONTINUE -C -C Set the final ZETA when m.eq.n. -C - IF (M.EQ.N) ZETA(N) = ZERO -C - IFAIL = P01ABF(IFAIL,0,SRNAME,0,REC) - RETURN -C -C -C End of F01QCF. ( SGEQR ) -C -99999 FORMAT (' The input parameters contained ',I2,' error(s)') - END diff --git a/Libraries/MyNag/F01QDF.f b/Libraries/MyNag/F01QDF.f deleted file mode 100644 index c987960e5..000000000 --- a/Libraries/MyNag/F01QDF.f +++ /dev/null @@ -1,290 +0,0 @@ - SUBROUTINE F01QDF(TRANS,WHERET,M,N,A,LDA,ZETA,NCOLB,B,LDB,WORK, - * IFAIL) -C MARK 14 RELEASE. NAG COPYRIGHT 1989. -C -C 1. Purpose -C ======= -C -C F01QDF performs one of the transformations -C -C B := Q*B or B := Q'*B, -C -C where B is an m by ncolb real matrix and Q is an m by m orthogonal -C matrix, given as the product of Householder transformation matrices. -C -C This routine is intended for use following NAG Fortran Library -C routine F01QCF. -C -C 2. Description -C =========== -C -C Q is assumed to be given by -C -C Q = ( Q( n )*Q( n - 1 )*...*Q( 1 ) )', -C -C Q( k ) being given in the form -C -C Q( k ) = ( I 0 ), -C ( 0 T( k ) ) -C -C where -C -C T( k ) = I - u( k )*u( k )' -C -C u( k ) = ( zeta( k ) ), -C ( z( k ) ) -C -C zeta( k ) is a scalar and z( k ) is an ( m - k ) element vector. -C -C z( k ) must be supplied in the kth column of A in elements -C a( k + 1, k ), ..., a( m, k ) and zeta( k ) must be supplied either -C in a( k, k ) or in zeta( k ), depending upon the parameter WHERET. -C -C To obtain Q explicitly B may be set to I and premultiplied by Q. This -C is more efficient than obtaining Q'. -C -C 3. Parameters -C ========== -C -C TRANS - CHARACTER*1. -C -C On entry, TRANS specifies the operation to be performed as -C follows. -C -C TRANS = 'N' or 'n' ( No transpose ) -C -C Perform the operation B := Q*B. -C -C TRANS = 'T' or 't' or 'C' or 'c' ( Transpose ) -C -C Perform the operation B := Q'*B. -C -C Unchanged on exit. -C -C WHERET - CHARACTER*1. -C -C On entry, WHERET specifies where the elements of zeta are -C to be found as follows. -C -C WHERET = 'I' or 'i' ( In A ) -C -C The elements of zeta are in A. -C -C WHERET = 'S' or 's' ( Separate ) -C -C The elements of zeta are separate from A, in ZETA. -C -C Unchanged on exit. -C -C M - INTEGER. -C -C On entry, M must specify the number of rows of A. M must be -C at least n. -C -C Unchanged on exit. -C -C N - INTEGER. -C -C On entry, N must specify the number of columns of A. N must -C be at least zero. When N = 0 then an immediate return is -C effected. -C -C Unchanged on exit. -C -C A - REAL array of DIMENSION ( LDA, n ). -C -C Before entry, the leading M by N stricly lower triangular -C part of the array A must contain details of the matrix Q. -C In addition, when WHERET = 'I' or 'i' then the diagonal -C elements of A must contain the elements of zeta as described -C under the argument ZETA below. -C -C When WHERET = 'S' or 's' then the diagonal elements of the -C array A are referenced, since they are used temporarily to -C store the zeta( k ), but they contain their original values -C on return. -C -C Unchanged on exit. -C -C LDA - INTEGER. -C -C On entry, LDA must specify the leading dimension of the -C array A as declared in the calling (sub) program. LDA must -C be at least m. -C -C Unchanged on exit. -C -C ZETA - REAL array of DIMENSION at least ( n ), when -C WHERET = 'S' or 's'. -C -C Before entry with WHERET = 'S' or 's', the array ZETA must -C contain the elements of zeta. If ZETA( k ) = 0.0 then -C T( k ) is assumed to be I otherwise ZETA( k ) is assumed -C to contain zeta( k ). -C -C When WHERET = 'I' or 'i', the array ZETA is not referenced. -C -C Unchanged on exit. -C -C NCOLB - INTEGER. -C -C On entry, NCOLB must specify the number of columns of B. -C NCOLB must be at least zero. When NCOLB = 0 then an -C immediate return is effected. -C -C Unchanged on exit. -C -C B - REAL array of DIMENSION ( LDB, ncolb ). -C -C Before entry, the leading M by NCOLB part of the array B -C must contain the matrix to be transformed. -C -C On exit, B is overwritten by the transformed matrix. -C -C LDB - INTEGER. -C -C On entry, LDB must specify the leading dimension of the -C array B as declared in the calling (sub) program. LDB must -C be at least m. -C -C Unchanged on exit. -C -C WORK - REAL array of DIMENSION at least ( ncolb ). -C -C Used as internal workspace. -C -C IFAIL - INTEGER. -C -C Before entry, IFAIL must contain one of the values -1 or 0 -C or 1 to specify noisy soft failure or noisy hard failure or -C silent soft failure. ( See Chapter P01 for further details.) -C -C On successful exit IFAIL will be zero, otherwise IFAIL -C will be set to -1 indicating that an input parameter has -C been incorrectly set. See the next section for further -C details. -C -C 4. Diagnostic Information -C ====================== -C -C IFAIL = -1 -C -C One or more of the following conditions holds: -C -C TRANS .ne. 'N' or 'n' or 'T' or 't' or 'C' or 'c' -C WHERET .ne. 'I' or 'i' or 'S' or 's' -C M .lt. N -C N .lt. 0 -C LDA .lt. M -C NCOLB .lt. 0 -C LDB .lt. M -C -C If on entry, IFAIL was either -1 or 0 then further diagnostic -C information will be output on the error message channel. ( See -C routine X04AAF. ) -C -C -C Nag Fortran 77 Auxiliary linear algebra routine. -C -C -- Written on 13-November-1987. -C Sven Hammarling, Nag Central Office. -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) - CHARACTER*6 SRNAME - PARAMETER (SRNAME='F01QDF') -C .. Scalar Arguments .. - INTEGER IFAIL, LDA, LDB, M, N, NCOLB - CHARACTER*1 TRANS, WHERET -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), B(LDB,*), WORK(*), ZETA(*) -C .. Local Scalars .. - DOUBLE PRECISION TEMP, ZETAK - INTEGER IERR, K, KK, LB -C .. Local Arrays .. - CHARACTER*46 REC(1) -C .. External Functions .. - INTEGER P01ABF - EXTERNAL P01ABF -C .. External Subroutines .. - EXTERNAL DGEMV, DGER, P01ABW, P01ABY -C .. Intrinsic Functions .. - INTRINSIC MIN -C .. Executable Statements .. -C -C Check the input parameters. -C - IERR = 0 - IF ((TRANS.NE.'N') .AND. (TRANS.NE.'n') .AND. (TRANS.NE.'T') - * .AND. (TRANS.NE.'t') .AND. (TRANS.NE.'C') .AND. (TRANS.NE.'c') - * ) CALL P01ABW(TRANS,'TRANS',IFAIL,IERR,SRNAME) - IF ((WHERET.NE.'I') .AND. (WHERET.NE.'i') .AND. (WHERET.NE.'S') - * .AND. (WHERET.NE.'s')) CALL P01ABW(WHERET,'WHERET',IFAIL, - * IERR,SRNAME) - IF (M.LT.N) CALL P01ABY(M,'M',IFAIL,IERR,SRNAME) - IF (N.LT.0) CALL P01ABY(N,'N',IFAIL,IERR,SRNAME) - IF (LDA.LT.M) CALL P01ABY(LDA,'LDA',IFAIL,IERR,SRNAME) - IF (NCOLB.LT.0) CALL P01ABY(NCOLB,'NCOLB',IFAIL,IERR,SRNAME) - IF (LDB.LT.M) CALL P01ABY(LDB,'LDB',IFAIL,IERR,SRNAME) - IF (IERR.GT.0) THEN - WRITE (REC,FMT=99999) IERR - IFAIL = P01ABF(IFAIL,-1,SRNAME,1,REC) - RETURN - END IF -C -C Perform the transformation. -C - IF (MIN(N,NCOLB).EQ.0) THEN - IFAIL = P01ABF(IFAIL,0,SRNAME,0,REC) - RETURN - END IF - LB = LDB - DO 20 KK = 1, N - IF ((TRANS.EQ.'T') .OR. (TRANS.EQ.'t') .OR. (TRANS.EQ.'C') - * .OR. (TRANS.EQ.'c')) THEN -C -C Q'*B = Q( n )*...*Q( 2 )*Q( 1 )*B, -C - K = KK - ELSE -C -C Q*B = Q( 1 )'*Q( 2 )'*...*Q( n )'*B, -C - K = N + 1 - KK - END IF - IF ((WHERET.EQ.'S') .OR. (WHERET.EQ.'s')) THEN - ZETAK = ZETA(K) - ELSE - ZETAK = A(K,K) - END IF - IF (ZETAK.GT.ZERO) THEN - TEMP = A(K,K) - A(K,K) = ZETAK - IF (NCOLB.EQ.1) LB = M - K + 1 -C -C Let C denote the bottom ( m - k + 1 ) by ncolb part of B. -C -C First form work = C'*u. -C - CALL DGEMV('Transpose',M-K+1,NCOLB,ONE,B(K,1),LB,A(K,K),1, - * ZERO,WORK,1) -C -C Now form C := C - u*work'. -C - CALL DGER(M-K+1,NCOLB,-ONE,A(K,K),1,WORK,1,B(K,1),LB) -C -C Restore the diagonal element of A. -C - A(K,K) = TEMP - END IF - 20 CONTINUE -C - IFAIL = P01ABF(IFAIL,0,SRNAME,0,REC) - RETURN -C -C -C End of F01QDF. ( SGEAPQ ) -C -99999 FORMAT (' The input parameters contained ',I2,' error(s)') - END diff --git a/Libraries/MyNag/F01QEF.f b/Libraries/MyNag/F01QEF.f deleted file mode 100644 index 6d435f19e..000000000 --- a/Libraries/MyNag/F01QEF.f +++ /dev/null @@ -1,259 +0,0 @@ - SUBROUTINE F01QEF(WHERET,M,N,NCOLQ,A,LDA,ZETA,WORK,IFAIL) -C MARK 14 RELEASE. NAG COPYRIGHT 1989. -C MARK 14C REVISED. IER-885 (NOV 1990). -C -C 1. Purpose -C ======= -C -C F01QEF returns the first ncolq columns of the m by m orthogonal -C matrix Q, where Q is given as the product of Householder -C transformation matrices. -C -C This routine is intended for use following NAG Fortran Library -C routine F01QCF. -C -C 2. Description -C =========== -C -C Q is assumed to be given by -C -C Q = ( Q( n )*Q( n - 1 )*...*Q( 1 ) )', -C -C Q( k ) being given in the form -C -C Q( k ) = ( I 0 ), -C ( 0 T( k ) ) -C -C where -C -C T( k ) = I - u( k )*u( k )' -C -C u( k ) = ( zeta( k ) ), -C ( z( k ) ) -C -C zeta( k ) is a scalar and z( k ) is an ( m - k ) element vector. -C -C z( k ) must be supplied in the kth column of A in elements -C a( k + 1, k ), ..., a( m, k ) and zeta( k ) must be supplied either -C in a( k, k ) or in zeta( k ), depending upon the parameter WHERET. -C -C 3. Parameters -C ========== -C -C WHERET - CHARACTER*1. -C -C On entry, WHERET specifies where the elements of zeta are -C to be found as follows. -C -C WHERET = 'I' or 'i' ( In A ) -C -C The elements of zeta are in A. -C -C WHERET = 'S' or 's' ( Separate ) -C -C The elements of zeta are separate from A, in ZETA. -C -C Unchanged on exit. -C -C M - INTEGER. -C -C On entry, M must specify the number of rows of A. M must be -C at least n. -C -C Unchanged on exit. -C -C N - INTEGER. -C -C On entry, N must specify the number of columns of A. N must -C be at least zero. -C -C Unchanged on exit. -C -C NCOLQ - INTEGER. -C -C On entry, NCOLQ must specify the required number of columns -C of Q. NCOLQ must be at least zero and not be larger than m. -C When NCOLQ = 0 then an immediate return is effected. -C -C Unchanged on exit. -C -C A - REAL array of DIMENSION ( LDA, nca ), where nca -C must be at least max( n, ncolq ). -C -C Before entry, the leading M by N stricly lower triangular -C part of the array A must contain details of the matrix Q. -C In addition, when WHERET = 'I' or 'i' then the diagonal -C elements of A must contain the elements of zeta as described -C under the argument ZETA below. -C -C On exit, the first NCOLQ columns of the array A are -C overwritten by the first ncolq columns of the m by m -C orthogonal matrix Q. -C -C Unchanged on exit. -C -C LDA - INTEGER. -C -C On entry, LDA must specify the leading dimension of the -C array A as declared in the calling (sub) program. LDA must -C be at least m. -C -C Unchanged on exit. -C -C ZETA - REAL array of DIMENSION at least ( n ), when -C WHERET = 'S' or 's'. -C -C Before entry with WHERET = 'S' or 's', the array ZETA must -C contain the elements of zeta. If ZETA( k ) = 0.0 then -C T( k ) is assumed to be I, otherwise ZETA( k ) is assumed -C to contain zeta( k ). -C -C When WHERET = 'I' or 'i', the array ZETA is not referenced. -C -C Unchanged on exit. -C -C WORK - REAL array of DIMENSION at least ( ncolq ). -C -C Used as internal workspace. -C -C IFAIL - INTEGER. -C -C Before entry, IFAIL must contain one of the values -1 or 0 -C or 1 to specify noisy soft failure or noisy hard failure or -C silent soft failure. ( See Chapter P01 for further details.) -C -C On successful exit IFAIL will be zero, otherwise IFAIL -C will be set to -1 indicating that an input parameter has -C been incorrectly set. See the next section for further -C details. -C -C 4. Diagnostic Information -C ====================== -C -C IFAIL = -1 -C -C One or more of the following conditions holds: -C -C WHERET .ne. 'I' or 'i' or 'S' or 's' -C M .lt. N -C N .lt. 0 -C NCOLQ .lt. 0 .or. NCOLQ .gt. M -C LDA .lt. M -C -C If on entry, IFAIL was either -1 or 0 then further diagnostic -C information will be output on the error message channel. ( See -C routine X04AAF. ) -C -C -C Nag Fortran 77 Auxiliary linear algebra routine. -C -C -- Written on 13-November-1987. -C Sven Hammarling, Nag Central Office. -C -C .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) - CHARACTER*6 SRNAME - PARAMETER (SRNAME='F01QEF') -C .. Scalar Arguments .. - INTEGER IFAIL, LDA, M, N, NCOLQ - CHARACTER*1 WHERET -C .. Array Arguments .. - DOUBLE PRECISION A(LDA,*), WORK(*), ZETA(*) -C .. Local Scalars .. - DOUBLE PRECISION ZETAK - INTEGER IERR, K, NCQ, P -C .. Local Arrays .. - CHARACTER*46 REC(1) -C .. External Functions .. - INTEGER P01ABF - EXTERNAL P01ABF -C .. External Subroutines .. - EXTERNAL F06FBF, F06QHF, P01ABW, P01ABY, DGEMV, DGER, - * DSCAL -C .. Intrinsic Functions .. - INTRINSIC MIN -C .. Executable Statements .. -C -C Check the input parameters. -C - IERR = 0 - IF ((WHERET.NE.'I') .AND. (WHERET.NE.'i') .AND. (WHERET.NE.'S') - * .AND. (WHERET.NE.'s')) CALL P01ABW(WHERET,'WHERET',IFAIL, - * IERR,SRNAME) - IF (M.LT.N) CALL P01ABY(M,'M',IFAIL,IERR,SRNAME) - IF (N.LT.0) CALL P01ABY(N,'N',IFAIL,IERR,SRNAME) - IF ((NCOLQ.LT.0) .OR. (NCOLQ.GT.M)) CALL P01ABY(NCOLQ,'NCOLQ', - * IFAIL,IERR,SRNAME) - IF (LDA.LT.M) CALL P01ABY(LDA,'LDA',IFAIL,IERR,SRNAME) - IF (IERR.GT.0) THEN - WRITE (REC,FMT=99999) IERR - IFAIL = P01ABF(IFAIL,-1,SRNAME,1,REC) - RETURN - END IF -C -C Start to form Q. First set the elements above the leading diagonal -C to zero. -C - IF (NCOLQ.EQ.0) THEN - IFAIL = P01ABF(IFAIL,0,SRNAME,0,REC) - RETURN - END IF - P = MIN(N,NCOLQ) - IF (P.GT.1) CALL F06QHF('Upper',P-1,P-1,ZERO,ZERO,A(1,2),LDA) - IF (NCOLQ.GT.N) THEN - NCQ = NCOLQ - N -C -C Set the last ( ncolq - n ) columns of Q to those of the unit -C matrix. -C - CALL F06QHF('General',N,NCOLQ-N,ZERO,ZERO,A(1,N+1),LDA) - CALL F06QHF('General',M-N,NCOLQ-N,ZERO,ONE,A(N+1,N+1),LDA) - ELSE - NCQ = 0 - END IF - DO 20 K = P, 1, -1 -C -C Q*E( ncolq ) = Q( 1 )'*...*Q( p )'*E( ncolq ), where E( ncolq ) -C is the matrix containing the first ncolq columns of I. -C - IF ((WHERET.EQ.'S') .OR. (WHERET.EQ.'s')) THEN - ZETAK = ZETA(K) - ELSE - ZETAK = A(K,K) - END IF - IF (ZETAK.GT.ZERO) THEN - A(K,K) = ZETAK -C -C Let C denote the bottom ( m - k + 1 ) by ncq part of Q. -C -C First form work = C'*u. -C - IF ((K.LT.M) .AND. (NCQ.GT.0)) THEN - CALL DGEMV('Transpose',M-K+1,NCQ,ONE,A(K,K+1),LDA,A(K,K), - * 1,ZERO,WORK,1) -C -C Now form C := C - u*work'. -C - CALL DGER(M-K+1,NCQ,-ONE,A(K,K),1,WORK,1,A(K,K+1),LDA) - END IF -C -C Now form the kth column of Q. -C - CALL DSCAL(M-K+1,-ZETAK,A(K,K),1) - A(K,K) = ONE + A(K,K) - ELSE - A(K,K) = ONE - IF (K.LT.M) CALL F06FBF(M-K,ZERO,A(K+1,K),1) - END IF - NCQ = NCQ + 1 - 20 CONTINUE -C - IFAIL = P01ABF(IFAIL,0,SRNAME,0,REC) - RETURN -C -C -C End of F01QEF. ( SGEFQ ) -C -99999 FORMAT (' The input parameters contained ',I2,' error(s)') - END diff --git a/Libraries/MyNag/F01RCF.f b/Libraries/MyNag/F01RCF.f deleted file mode 100644 index 194233a28..000000000 --- a/Libraries/MyNag/F01RCF.f +++ /dev/null @@ -1,282 +0,0 @@ - SUBROUTINE F01RCF(M,N,A,LDA,THETA,IFAIL) -C MARK 13 RELEASE. NAG COPYRIGHT 1988. -C MARK 14 REVISED. IER-732 (DEC 1989). -C -C 1. Purpose -C ======= -C -C F01RCF finds the QR factorization of the complex m by n, m .ge. n, -C matrix A, so that A is reduced to upper triangular form by means of -C unitary transformations. -C -C 2. Description -C =========== -C -C The m by n matrix A is factorized as -C -C A = Q*( R ) when m.gt.n, -C ( 0 ) -C -C A = Q*R when m = n, -C -C where Q is an m by m unitary matrix and R is an n by n upper -C triangular matrix with real diagonal elements. -C -C The factorization is obtained by Householder's method. The kth -C transformation matrix, Q( k ), which is used to introduce zeros into -C the kth column of A is given in the form -C -C Q( k ) = ( I 0 ), -C ( 0 T( k ) ) -C -C where -C -C T( k ) = I - gamma( k )*u( k )*conjg( u( k )' ), -C -C u( k ) = ( zeta( k ) ), -C ( z( k ) ) -C -C gamma( k ) is a scalar for which real( gamma( k ) ) = 1.0, zeta( k ) -C is a real scalar and z( k ) is an ( m - k ) element vector. -C gamma( k ), zeta( k ) and z( k ) are chosen to annhilate the elements -C below the triangular part of A and to make the diagonal elements -C real. -C -C The scalar gamma( k ) and the vector u( k ) are returned in the kth -C element of THETA and in the kth column of A, such that theta( k ), -C given by -C -C theta( k ) = ( zeta( k ), aimag( gamma( k ) ) ), -C -C is in THETA( k ) and the elements of z( k ) are in a( k + 1, k ), -C ..., a( m, k ). The elements of R are returned in the upper -C triangular part of A. -C -C Q is given by -C -C Q = conjg( ( Q( n )*Q( n - 1 )*...*Q( 1 ) )' ). -C -C 3. Parameters -C ========== -C -C M - INTEGER. -C -C On entry, M must specify the number of rows of A. M must be -C at least n. -C -C Unchanged on exit. -C -C N - INTEGER. -C -C On entry, N must specify the number of columns of A. N must -C be at least zero. When N = 0 then an immediate return is -C effected. -C -C Unchanged on exit. -C -C A - COMPLEX array of DIMENSION ( LDA, n ). -C -C Before entry, the leading M by N part of the array A must -C contain the matrix to be factorized. -C -C On exit, the N by N upper triangular part of A will contain -C the upper triangular matrix R, with the imaginary parts of -C the diagonal elements set to zero, and the M by N strictly -C lower triangular part of A will contain details of the -C factorization as described above. -C -C LDA - INTEGER. -C -C On entry, LDA must specify the leading dimension of the -C array A as declared in the calling (sub) program. LDA must -C be at least m. -C -C Unchanged on exit. -C -C THETA - COMPLEX array of DIMENSION at least ( n ). -C -C On exit, THETA( k ) contains the scalar theta( k ) for the -C kth transformation. If T( k ) = I then THETA( k ) = 0.0, -C if -C -C T( k ) = ( alpha 0 ), real( alpha ) .lt. 0.0, -C ( 0 I ) -C -C then THETA( k ) = alpha, otherwise THETA( k ) contains -C theta( k ) as described above and real( theta( k ) ) is -C always in the range ( 1.0, sqrt( 2.0 ) ). -C -C IFAIL - INTEGER. -C -C Before entry, IFAIL must contain one of the values -1 or 0 -C or 1 to specify noisy soft failure or noisy hard failure or -C silent soft failure. ( See Chapter P01 for further details.) -C -C On successful exit IFAIL will be zero, otherwise IFAIL -C will be set to -1 indicating that an input parameter has -C been incorrectly set. See the next section for further -C details. -C -C 4. Diagnostic Information -C ====================== -C -C IFAIL = -1 -C -C One or more of the following conditions holds: -C -C M .lt. N -C N .lt. 0 -C LDA .lt. M -C -C If on entry, IFAIL was either -1 or 0 then further diagnostic -C information will be output on the error message channel. ( See -C routine X04AAF. ) -C -C 5. Further information -C =================== -C -C Following the use of this routine the operations -C -C B := Q*B and B := conjg( Q' )*B, -C -C where B is an m by k matrix, can be performed by calls to the -C NAG Library routine F01RDF. The operation B := Q*B can be obtained -C by the call: -C -C IFAIL = 0 -C CALL F01RDF( 'No conjugate', 'Separate', M, N, A, LDA, THETA, -C $ K, B, LDB, WORK, IFAIL ) -C -C and B := conjg( Q' )*B can be obtained by the call: -C -C IFAIL = 0 -C CALL F01RDF( 'Conjugate', 'Separate', M, N, A, LDA, THETA, -C $ K, B, LDB, WORK, IFAIL ) -C -C In both cases WORK must be a k element array that is used as -C workspace. If B is a one-dimensional array (single column) then the -C parameter LDB can be replaced by M. See routine F01RDF for further -C details. -C -C The first k columns of the unitary matrix Q can either be obtained -C by setting B to the first k columns of the unit matrix and using the -C first of the above two calls, or by calling the NAG Library routine -C F01REF, which overwrites the k columns of Q on the first k columns of -C the array A. Q is obtained by the call: -C -C CALL F01REF( 'Separate', M, N, K, A, LDA, THETA, WORK, IFAIL ) -C -C As above WORK must be a k element array. If K is larger than N, then -C A must have been declared to have at least K columns. -C -C Operations involving the matrix R can readily be performed by the -C Level 2 BLAS routines CTRSV and CTRMV (see Chapter F06), but note -C that no test for near singularity of R is incorporated in CTRSV . -C If R is singular, or nearly singular then the NAG Library routine -C F02XUF can be used to determine the singular value decomposition -C of R. -C -C -C Nag Fortran 77 Auxiliary linear algebra routine. -C -C -- Written on 21-December-1985. -C Sven Hammarling, Nag Central Office. -C -C .. Parameters .. - COMPLEX*16 ONE - PARAMETER (ONE=(1.0D+0,0.0D+0)) - COMPLEX*16 ZERO - PARAMETER (ZERO=(0.0D+0,0.0D+0)) - CHARACTER*6 SRNAME - PARAMETER (SRNAME='F01RCF') -C .. Scalar Arguments .. - INTEGER IFAIL, LDA, M, N -C .. Array Arguments .. - COMPLEX*16 A(LDA,*), THETA(*) -C .. Local Scalars .. - COMPLEX*16 GAMMA - DOUBLE PRECISION TEMP - INTEGER IERR, K, LA -C .. Local Arrays .. - COMPLEX*16 DUMMY(1) - CHARACTER*46 REC(1) -C .. External Functions .. - INTEGER P01ABF - EXTERNAL P01ABF -C .. External Subroutines .. - EXTERNAL ZGEMV, ZGERC, ZSCAL, F06HRF, P01ABY -C .. Intrinsic Functions .. - INTRINSIC DIMAG, DCMPLX, MIN, DREAL -C .. Executable Statements .. -C -C Check the input parameters. -C - IF (N.EQ.0) THEN - IFAIL = P01ABF(IFAIL,0,SRNAME,0,REC) - RETURN - END IF - IERR = 0 - IF (M.LT.N) CALL P01ABY(M,'M',IFAIL,IERR,SRNAME) - IF (N.LT.0) CALL P01ABY(N,'N',IFAIL,IERR,SRNAME) - IF (LDA.LT.M) CALL P01ABY(LDA,'LDA',IFAIL,IERR,SRNAME) - IF (IERR.GT.0) THEN - WRITE (REC,FMT=99999) IERR - IFAIL = P01ABF(IFAIL,-1,SRNAME,1,REC) - RETURN - END IF -C -C Perform the factorization. -C - LA = LDA - DO 20 K = 1, MIN(M-1,N) -C -C Use a Householder reflection to zero the kth column of A. -C First set up the reflection. -C - CALL F06HRF(M-K,A(K,K),A(K+1,K),1,DREAL(ZERO),THETA(K)) - IF ((DREAL(THETA(K)).GT.DREAL(ZERO)) .AND. (K.LT.N)) THEN - IF ((K+1).EQ.N) LA = M - K + 1 -C -C Temporarily store beta, put zeta( k ) in a( k, k ) and -C form gamma( k ). -C - TEMP = A(K,K) - A(K,K) = DREAL(THETA(K)) - GAMMA = DCMPLX(DREAL(ONE),DIMAG(THETA(K))) -C -C We now perform the operation A := Q( k )*A. -C -C Let B denote the bottom ( m - k + 1 ) by ( n - k ) part -C of A. -C -C First form work = conjg( B' )*u. ( work is stored in the -C elements THETA( k + 1 ), ..., THETA( n ). ) -C - CALL ZGEMV('Conjugate',M-K+1,N-K,ONE,A(K,K+1),LA,A(K,K),1, - * ZERO,THETA(K+1),1) -C -C Now form B := B - gamma( k )*u*conjg( work' ). -C - CALL ZGERC(M-K+1,N-K,-GAMMA,A(K,K),1,THETA(K+1),1,A(K,K+1), - * LA) -C -C Restore beta. -C - A(K,K) = TEMP - ELSE IF (DIMAG(THETA(K)).NE.DREAL(ZERO)) THEN - CALL ZSCAL(N-K,THETA(K),A(K,K+1),LDA) - END IF - 20 CONTINUE -C -C Find the final THETA when m.eq.n. This ensures that the last -C diagonal element of R is real. -C - IF (M.EQ.N) CALL F06HRF(0,A(N,N),DUMMY,1,DREAL(ZERO),THETA(N)) -C - IFAIL = P01ABF(IFAIL,0,SRNAME,0,REC) - RETURN -C -C End of F01RCF. ( CGEQR ) -C -99999 FORMAT (' The input parameters contained ',I2,' error(s)') - END diff --git a/Libraries/MyNag/F01REF.f b/Libraries/MyNag/F01REF.f deleted file mode 100644 index ed79ed0ee..000000000 --- a/Libraries/MyNag/F01REF.f +++ /dev/null @@ -1,283 +0,0 @@ - SUBROUTINE F01REF(WHERET,M,N,NCOLQ,A,LDA,THETA,WORK,IFAIL) -C MARK 13 RELEASE. NAG COPYRIGHT 1988. -C MARK 14 REVISED. IER-733 (DEC 1989). -C MARK 14C REVISED. IER-886 (NOV 1990). -C -C 1. Purpose -C ======= -C -C F01REF returns the first ncolq columns of the m by m unitary matrix -C Q, where Q is given as the product of Householder transformation -C matrices. -C -C This routine is intended for use following NAG Fortran Library -C routine F01RCF. -C -C 2. Description -C =========== -C -C Q is assumed to be given by -C -C Q = conjg( ( Q( n )*Q( n - 1 )*...*Q( 1 ) )' ), -C -C Q( k ) being given in the form -C -C Q( k ) = ( I 0 ), -C ( 0 T( k ) ) -C -C where -C -C T( k ) = I - gamma( k )*u( k )*conjg( u( k )' ) -C -C u( k ) = ( zeta( k ) ), -C ( z( k ) ) -C -C gamma( k ) is a scalar for which real( gamma( k ) ) = 1.0, zeta( k ) -C is a real scalar and z( k ) is an ( m - k ) element vector. -C -C z( k ) must be supplied in the kth column of A in elements -C a( k + 1, k ), ..., a( m, k ) and theta( k ), given by -C -C theta( k ) = ( zeta( k ), aimag( gamma( k ) ) ), -C -C must be supplied either in a( k, k ) or in theta( k ), depending upon -C the parameter WHERET. -C -C 3. Parameters -C ========== -C -C WHERET - CHARACTER*1. -C -C On entry, WHERET specifies where the elements of theta are -C to be found as follows. -C -C WHERET = 'I' or 'i' ( In A ) -C -C The elements of theta are in A. -C -C WHERET = 'S' or 's' ( Separate ) -C -C The elements of theta are separate from A, in THETA. -C -C Unchanged on exit. -C -C M - INTEGER. -C -C On entry, M must specify the number of rows of A. M must be -C at least n. -C -C Unchanged on exit. -C -C N - INTEGER. -C -C On entry, N must specify the number of columns of A. N must -C be at least zero. -C -C Unchanged on exit. -C -C NCOLQ - INTEGER. -C -C On entry, NCOLQ must specify the required number of columns -C of Q. NCOLQ must be at least zero and not be larger than m. -C When NCOLQ = 0 then an immediate return is effected. -C -C Unchanged on exit. -C -C A - COMPLEX array of DIMENSION ( LDA, nca ), where nca must be -C at least max( n, ncolq ). -C -C Before entry, the leading M by N stricly lower triangular -C part of the array A must contain details of the matrix Q. -C In addition, when WHERET = 'I' or 'i' then the diagonal -C elements of A must contain the elements of theta as -C described under the argument THETA below. -C -C On exit, the first NCOLQ columns of the array A are -C overwritten by the first ncolq columns of the m by m unitary -C matrix Q. -C -C Unchanged on exit. -C -C LDA - INTEGER. -C -C On entry, LDA must specify the leading dimension of the -C array A as declared in the calling (sub) program. LDA must -C be at least m. -C -C Unchanged on exit. -C -C THETA - COMPLEX array of DIMENSION at least ( n ), when WHERET = 'S' -C or 's'. -C -C Before entry with WHERET = 'S' or 's', the array THETA must -C contain the elements of theta. If THETA( k ) = 0.0 then -C T( k ) is assumed to be I, if THETA( k ) = alpha, with -C real( alpha ) .lt. 0.0 then T( k ) is assumed to be of -C the form -C -C T( k ) = ( alpha 0 ), -C ( 0 I ) -C -C otherwise THETA( k ) is assumed to contain theta( k ) given -C by theta( k ) = ( zeta( k ), aimag( gamma( k ) ) ). -C -C When WHERET = 'I' or 'i', the array THETA is not referenced. -C -C Unchanged on exit. -C -C WORK - COMPLEX array of DIMENSION at least ( ncolq ). -C -C Used as internal workspace. -C -C IFAIL - INTEGER. -C -C Before entry, IFAIL must contain one of the values -1 or 0 -C or 1 to specify noisy soft failure or noisy hard failure or -C silent soft failure. ( See Chapter P01 for further details.) -C -C On successful exit IFAIL will be zero, otherwise IFAIL -C will be set to -1 indicating that an input parameter has -C been incorrectly set. See the next section for further -C details. -C -C 4. Diagnostic Information -C ====================== -C -C IFAIL = -1 -C -C One or more of the following conditions holds: -C -C WHERET .ne. 'I' or 'i' or 'S' or 's' -C M .lt. N -C N .lt. 0 -C NCOLQ .lt. 0 .or. NCOLQ .gt. M -C LDA .lt. M -C -C If on entry, IFAIL was either -1 or 0 then further diagnostic -C information will be output on the error message channel. ( See -C routine X04AAF. ) -C -C -C Nag Fortran 77 Auxiliary linear algebra routine. -C -C -- Written on 13-November-1987. -C Sven Hammarling, Nag Central Office. -C -C .. Parameters .. - COMPLEX*16 ONE - PARAMETER (ONE=(1.0D+0,0.0D+0)) - COMPLEX*16 ZERO - PARAMETER (ZERO=(0.0D+0,0.0D+0)) - CHARACTER*6 SRNAME - PARAMETER (SRNAME='F01REF') -C .. Scalar Arguments .. - INTEGER IFAIL, LDA, M, N, NCOLQ - CHARACTER*1 WHERET -C .. Array Arguments .. - COMPLEX*16 A(LDA,*), THETA(*), WORK(*) -C .. Local Scalars .. - COMPLEX*16 GAMMA, THETAK - INTEGER IERR, K, NCQ, P -C .. Local Arrays .. - CHARACTER*46 REC(1) -C .. External Functions .. - INTEGER P01ABF - EXTERNAL P01ABF -C .. External Subroutines .. - EXTERNAL ZGEMV, ZGERC, ZSCAL, F06HBF, F06THF, P01ABW, - * P01ABY -C .. Intrinsic Functions .. - INTRINSIC DIMAG, DCMPLX, DCONJG, MIN, DREAL -C .. Executable Statements .. -C -C Check the input parameters. -C - IF (NCOLQ.EQ.0) THEN - IFAIL = P01ABF(IFAIL,0,SRNAME,0,REC) - RETURN - END IF - IERR = 0 - IF ((WHERET.NE.'I') .AND. (WHERET.NE.'i') .AND. (WHERET.NE.'S') - * .AND. (WHERET.NE.'s')) CALL P01ABW(WHERET,'WHERET',IFAIL, - * IERR,SRNAME) - IF (M.LT.N) CALL P01ABY(M,'M',IFAIL,IERR,SRNAME) - IF (N.LT.0) CALL P01ABY(N,'N',IFAIL,IERR,SRNAME) - IF ((NCOLQ.LT.0) .OR. (NCOLQ.GT.M)) CALL P01ABY(NCOLQ,'NCOLQ', - * IFAIL,IERR,SRNAME) - IF (LDA.LT.M) CALL P01ABY(LDA,'LDA',IFAIL,IERR,SRNAME) - IF (IERR.GT.0) THEN - WRITE (REC,FMT=99999) IERR - IFAIL = P01ABF(IFAIL,-1,SRNAME,1,REC) - RETURN - END IF -C -C Start to form Q. First set the elements above the leading diagonal -C to zero. -C - P = MIN(N,NCOLQ) - IF (P.GT.1) CALL F06THF('Upper',P-1,P-1,ZERO,ZERO,A(1,2),LDA) - IF (NCOLQ.GT.N) THEN - NCQ = NCOLQ - N -C -C Set the last ( ncolq - n ) columns of Q to those of the unit -C matrix. -C - CALL F06THF('General',N,NCOLQ-N,ZERO,ZERO,A(1,N+1),LDA) - CALL F06THF('General',M-N,NCOLQ-N,ZERO,ONE,A(N+1,N+1),LDA) - ELSE - NCQ = 0 - END IF - DO 20 K = P, 1, -1 -C -C Q*E( ncolq ) = -C conjg( Q( 1 )' )*...*conjg( Q( p )' )*E( ncolq ), -C where E( ncolq ) is the matrix containing the first ncolq -C columns of I. -C - IF ((WHERET.EQ.'S') .OR. (WHERET.EQ.'s')) THEN - THETAK = THETA(K) - ELSE - THETAK = A(K,K) - END IF -C -C If real( THETA( k ) ) .le. zero then Q( k ) is special. -C - IF (DREAL(THETAK).GT.DREAL(ZERO)) THEN - A(K,K) = DREAL(THETAK) - GAMMA = DCMPLX(DREAL(ONE),-DIMAG(THETAK)) -C -C Let C denote the bottom ( m - k + 1 ) by ncq part of Q. -C -C First form work = conjg( C' )*u. -C - IF ((K.LT.M) .AND. (NCQ.GT.0)) THEN - CALL ZGEMV('Conjugate',M-K+1,NCQ,ONE,A(K,K+1),LDA,A(K,K), - * 1,ZERO,WORK,1) -C -C Now form C := C - gamma( k )*u*conjg( work' ). -C - CALL ZGERC(M-K+1,NCQ,-GAMMA,A(K,K),1,WORK,1,A(K,K+1),LDA) - END IF -C -C Now form the kth column of Q. -C - CALL ZSCAL(M-K+1,-GAMMA*DREAL(THETAK),A(K,K),1) - A(K,K) = ONE + A(K,K) - ELSE - IF (DIMAG(THETAK).EQ.DREAL(ZERO)) THEN - A(K,K) = ONE - ELSE - A(K,K) = DCONJG(THETAK) - END IF - IF (K.LT.M) CALL F06HBF(M-K,ZERO,A(K+1,K),1) - END IF - NCQ = NCQ + 1 - 20 CONTINUE -C - IFAIL = P01ABF(IFAIL,0,SRNAME,0,REC) - RETURN -C -C End of F01REF. ( CGEFQ ) -C -99999 FORMAT (' The input parameters contained ',I2,' error(s)') - END diff --git a/Libraries/MyNag/F06AAZ.f b/Libraries/MyNag/F06AAZ.f deleted file mode 100644 index 23b208da2..000000000 --- a/Libraries/MyNag/F06AAZ.f +++ /dev/null @@ -1,61 +0,0 @@ - SUBROUTINE F06AAZ ( SRNAME, INFO ) -C MARK 12 RELEASE. NAG COPYRIGHT 1986. -C MARK 15 REVISED. IER-915 (APR 1991). -C .. Scalar Arguments .. - INTEGER INFO - CHARACTER*13 SRNAME -C .. -C -C Purpose -C ======= -C -C F06AAZ is an error handler for the Level 2 BLAS routines. -C -C It is called by the Level 2 BLAS routines if an input parameter is -C invalid. -C -C Parameters -C ========== -C -C SRNAME - CHARACTER*13. -C On entry, SRNAME specifies the name of the routine which -C called F06AAZ. -C -C INFO - INTEGER. -C On entry, INFO specifies the position of the invalid -C parameter in the parameter-list of the calling routine. -C -C -C Auxiliary routine for Level 2 Blas. -C -C Written on 20-July-1986. -C -C .. Local Scalars .. - INTEGER IERR, IFAIL - CHARACTER*4 VARBNM -C .. Local Arrays .. - CHARACTER*80 REC (1) -C .. External Functions .. - INTEGER P01ACF - EXTERNAL P01ACF -C .. -C .. Executable Statements .. - WRITE (REC (1),99999) SRNAME, INFO - IF (SRNAME(1:3).EQ.'F06') THEN - IERR = -1 - VARBNM = ' ' - ELSE - IERR = -INFO - VARBNM = 'INFO' - END IF - IFAIL = 0 - IFAIL = P01ACF (IFAIL, IERR, SRNAME(1:6), VARBNM, 1, REC) -C - RETURN -C -99999 FORMAT ( ' ** On entry to ', A13, ' parameter number ', I2, - $ ' had an illegal value' ) -C -C End of F06AAZ. -C - END diff --git a/Libraries/MyNag/F06FBF.f b/Libraries/MyNag/F06FBF.f deleted file mode 100644 index 40454acde..000000000 --- a/Libraries/MyNag/F06FBF.f +++ /dev/null @@ -1,44 +0,0 @@ - SUBROUTINE F06FBF( N, CONST, X, INCX ) -C MARK 12 RELEASE. NAG COPYRIGHT 1986. -C .. Scalar Arguments .. - DOUBLE PRECISION CONST - INTEGER INCX, N -C .. Array Arguments .. - DOUBLE PRECISION X( * ) -C .. -C -C F06FBF performs the operation -C -C x = const*e, e' = ( 1 1 ... 1 ). -C -C -C Nag Fortran 77 O( n ) basic linear algebra routine. -C -C -- Written on 22-September-1983. -C Sven Hammarling, Nag Central Office. -C -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -C .. Local Scalars .. - INTEGER IX -C .. -C .. Executable Statements .. - IF( N.GT.0 )THEN - IF( CONST.NE.ZERO )THEN - DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX - X( IX ) = CONST - 10 CONTINUE - ELSE - DO 20, IX = 1, 1 + ( N - 1 )*INCX, INCX - X( IX ) = ZERO - 20 CONTINUE - END IF - END IF -C - RETURN -C -C End of F06FBF. ( SLOAD ) -C - END diff --git a/Libraries/MyNag/F06FJF.f b/Libraries/MyNag/F06FJF.f deleted file mode 100644 index 9692407fc..000000000 --- a/Libraries/MyNag/F06FJF.f +++ /dev/null @@ -1,62 +0,0 @@ - SUBROUTINE F06FJF( N, X, INCX, SCALE, SUMSQ ) -C MARK 12 RELEASE. NAG COPYRIGHT 1986. -C .. Scalar Arguments .. - DOUBLE PRECISION SCALE, SUMSQ - INTEGER INCX, N -C .. Array Arguments .. - DOUBLE PRECISION X( * ) -C .. -C -C F06FJF returns the values scl and smsq such that -C -C ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, -C -C where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is assumed -C to be at least unity and the value of smsq will then satisfy -C -C 1.0 .le. smsq .le. ( sumsq + n ) . -C -C scale is assumed to be non-negative and scl returns the value -C -C scl = max( scale, abs( x( i ) ) ) . -C -C scale and sumsq must be supplied in SCALE and SUMSQ respectively. -C scl and smsq are overwritten on SCALE and SUMSQ respectively. -C -C The routine makes only one pass through the vector X. -C -C -C Nag Fortran 77 O( n ) basic linear algebra routine. -C -C -- Written on 22-October-1982. -C Sven Hammarling, Nag Central Office. -C -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -C .. Local Scalars .. - DOUBLE PRECISION ABSXI - INTEGER IX -C .. Intrinsic Functions .. - INTRINSIC ABS -C .. -C .. Executable Statements .. - IF( N.GT.0 )THEN - DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX - IF( X( IX ).NE.ZERO )THEN - ABSXI = ABS( X( IX ) ) - IF( SCALE.LT.ABSXI )THEN - SUMSQ = 1 + SUMSQ*( SCALE/ABSXI )**2 - SCALE = ABSXI - ELSE - SUMSQ = SUMSQ + ( ABSXI/SCALE )**2 - END IF - END IF - 10 CONTINUE - END IF - RETURN -C -C End of F06FJF. ( SSSQ ) -C - END diff --git a/Libraries/MyNag/F06FRF.f b/Libraries/MyNag/F06FRF.f deleted file mode 100644 index 726560cf2..000000000 --- a/Libraries/MyNag/F06FRF.f +++ /dev/null @@ -1,139 +0,0 @@ - SUBROUTINE F06FRF( N, ALPHA, X, INCX, TOL, ZETA ) -C MARK 12 RELEASE. NAG COPYRIGHT 1986. -C .. Scalar Arguments .. - DOUBLE PRECISION ALPHA, TOL, ZETA - INTEGER INCX, N -C .. Array Arguments .. - DOUBLE PRECISION X( * ) -C .. -C -C F06FRF generates details of a generalized Householder reflection such -C that -C -C P*( alpha ) = ( beta ), P'*P = I. -C ( x ) ( 0 ) -C -C P is given in the form -C -C P = I - ( zeta )*( zeta z' ), -C ( z ) -C -C where z is an n element vector and zeta is a scalar that satisfies -C -C 1.0 .le. zeta .le. sqrt( 2.0 ). -C -C zeta is returned in ZETA unless x is such that -C -C max( abs( x( i ) ) ) .le. max( eps*abs( alpha ), tol ) -C -C where eps is the relative machine precision and tol is the user -C supplied value TOL, in which case ZETA is returned as 0.0 and P can -C be taken to be the unit matrix. -C -C beta is overwritten on alpha and z is overwritten on x. -C the routine may be called with n = 0 and advantage is taken of the -C case where n = 1. -C -C -C Nag Fortran 77 O( n ) basic linear algebra routine. -C -C -- Written on 30-August-1984. -C Sven Hammarling, Nag Central Office. -C This version dated 28-September-1984. -C -C -C .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -C .. Local Scalars .. - DOUBLE PRECISION BETA, EPS, SCALE, SSQ - LOGICAL FIRST -C .. External Functions .. - DOUBLE PRECISION X02AJF - EXTERNAL X02AJF -C .. External Subroutines .. - EXTERNAL F06FJF, DSCAL -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SIGN, SQRT -C .. Save statement .. - SAVE EPS, FIRST -C .. Data statements .. - DATA FIRST/ .TRUE. / -C .. -C .. Executable Statements .. - IF( N.LT.1 )THEN - ZETA = ZERO - ELSE IF( ( N.EQ.1 ).AND.( X( 1 ).EQ.ZERO ) )THEN - ZETA = ZERO - ELSE -C - IF( FIRST )THEN - FIRST = .FALSE. - EPS = X02AJF( ) - END IF -C -C Treat case where P is a 2 by 2 matrix specially. -C - IF( N.EQ.1 )THEN -C -C Deal with cases where ALPHA = zero and -C abs( X( 1 ) ) .le. max( EPS*abs( ALPHA ), TOL ) first. -C - IF( ALPHA.EQ.ZERO )THEN - ZETA = ONE - ALPHA = ABS ( X( 1 ) ) - X( 1 ) = -SIGN( ONE, X( 1 ) ) - ELSE IF( ABS( X( 1 ) ).LE.MAX( EPS*ABS( ALPHA ), TOL ) )THEN - ZETA = ZERO - ELSE - IF( ABS( ALPHA ).GE.ABS( X( 1 ) ) )THEN - BETA = ABS( ALPHA ) *SQRT( 1 + ( X( 1 )/ALPHA )**2 ) - ELSE - BETA = ABS( X( 1 ) )*SQRT( 1 + ( ALPHA/X( 1 ) )**2 ) - END IF - ZETA = SQRT( ( ABS( ALPHA ) + BETA )/BETA ) - IF( ALPHA.GE.ZERO ) - $ BETA = -BETA - X( 1 ) = -X( 1 )/( ZETA*BETA ) - ALPHA = BETA - END IF - ELSE -C -C Now P is larger than 2 by 2. -C - SSQ = ONE - SCALE = ZERO - CALL F06FJF( N, X, INCX, SCALE, SSQ ) -C -C Treat cases where SCALE = zero, -C SCALE .le. max( EPS*abs( ALPHA ), TOL ) and -C ALPHA = zero specially. -C Note that SCALE = max( abs( X( i ) ) ). -C - IF( ( SCALE.EQ.ZERO ).OR. - $ ( SCALE.LE.MAX( EPS*ABS( ALPHA ), TOL ) ) )THEN - ZETA = ZERO - ELSE IF( ALPHA.EQ.ZERO )THEN - ZETA = ONE - ALPHA = SCALE*SQRT( SSQ ) - CALL DSCAL( N, -1/ALPHA, X, INCX ) - ELSE - IF( SCALE.LT.ABS( ALPHA ) )THEN - BETA = ABS( ALPHA )*SQRT( 1 + SSQ*( SCALE/ALPHA )**2 ) - ELSE - BETA = SCALE *SQRT( SSQ + ( ALPHA/SCALE )**2 ) - END IF - ZETA = SQRT( ( BETA + ABS( ALPHA ) )/BETA ) - IF( ALPHA.GT.ZERO ) - $ BETA = -BETA - CALL DSCAL( N, -1/( ZETA*BETA ), X, INCX ) - ALPHA = BETA - END IF - END IF - END IF -C - RETURN -C -C End of F06FRF. ( SGRFG ) -C - END diff --git a/Libraries/MyNag/F06FRF.f~ b/Libraries/MyNag/F06FRF.f~ deleted file mode 100644 index 726560cf2..000000000 --- a/Libraries/MyNag/F06FRF.f~ +++ /dev/null @@ -1,139 +0,0 @@ - SUBROUTINE F06FRF( N, ALPHA, X, INCX, TOL, ZETA ) -C MARK 12 RELEASE. NAG COPYRIGHT 1986. -C .. Scalar Arguments .. - DOUBLE PRECISION ALPHA, TOL, ZETA - INTEGER INCX, N -C .. Array Arguments .. - DOUBLE PRECISION X( * ) -C .. -C -C F06FRF generates details of a generalized Householder reflection such -C that -C -C P*( alpha ) = ( beta ), P'*P = I. -C ( x ) ( 0 ) -C -C P is given in the form -C -C P = I - ( zeta )*( zeta z' ), -C ( z ) -C -C where z is an n element vector and zeta is a scalar that satisfies -C -C 1.0 .le. zeta .le. sqrt( 2.0 ). -C -C zeta is returned in ZETA unless x is such that -C -C max( abs( x( i ) ) ) .le. max( eps*abs( alpha ), tol ) -C -C where eps is the relative machine precision and tol is the user -C supplied value TOL, in which case ZETA is returned as 0.0 and P can -C be taken to be the unit matrix. -C -C beta is overwritten on alpha and z is overwritten on x. -C the routine may be called with n = 0 and advantage is taken of the -C case where n = 1. -C -C -C Nag Fortran 77 O( n ) basic linear algebra routine. -C -C -- Written on 30-August-1984. -C Sven Hammarling, Nag Central Office. -C This version dated 28-September-1984. -C -C -C .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -C .. Local Scalars .. - DOUBLE PRECISION BETA, EPS, SCALE, SSQ - LOGICAL FIRST -C .. External Functions .. - DOUBLE PRECISION X02AJF - EXTERNAL X02AJF -C .. External Subroutines .. - EXTERNAL F06FJF, DSCAL -C .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SIGN, SQRT -C .. Save statement .. - SAVE EPS, FIRST -C .. Data statements .. - DATA FIRST/ .TRUE. / -C .. -C .. Executable Statements .. - IF( N.LT.1 )THEN - ZETA = ZERO - ELSE IF( ( N.EQ.1 ).AND.( X( 1 ).EQ.ZERO ) )THEN - ZETA = ZERO - ELSE -C - IF( FIRST )THEN - FIRST = .FALSE. - EPS = X02AJF( ) - END IF -C -C Treat case where P is a 2 by 2 matrix specially. -C - IF( N.EQ.1 )THEN -C -C Deal with cases where ALPHA = zero and -C abs( X( 1 ) ) .le. max( EPS*abs( ALPHA ), TOL ) first. -C - IF( ALPHA.EQ.ZERO )THEN - ZETA = ONE - ALPHA = ABS ( X( 1 ) ) - X( 1 ) = -SIGN( ONE, X( 1 ) ) - ELSE IF( ABS( X( 1 ) ).LE.MAX( EPS*ABS( ALPHA ), TOL ) )THEN - ZETA = ZERO - ELSE - IF( ABS( ALPHA ).GE.ABS( X( 1 ) ) )THEN - BETA = ABS( ALPHA ) *SQRT( 1 + ( X( 1 )/ALPHA )**2 ) - ELSE - BETA = ABS( X( 1 ) )*SQRT( 1 + ( ALPHA/X( 1 ) )**2 ) - END IF - ZETA = SQRT( ( ABS( ALPHA ) + BETA )/BETA ) - IF( ALPHA.GE.ZERO ) - $ BETA = -BETA - X( 1 ) = -X( 1 )/( ZETA*BETA ) - ALPHA = BETA - END IF - ELSE -C -C Now P is larger than 2 by 2. -C - SSQ = ONE - SCALE = ZERO - CALL F06FJF( N, X, INCX, SCALE, SSQ ) -C -C Treat cases where SCALE = zero, -C SCALE .le. max( EPS*abs( ALPHA ), TOL ) and -C ALPHA = zero specially. -C Note that SCALE = max( abs( X( i ) ) ). -C - IF( ( SCALE.EQ.ZERO ).OR. - $ ( SCALE.LE.MAX( EPS*ABS( ALPHA ), TOL ) ) )THEN - ZETA = ZERO - ELSE IF( ALPHA.EQ.ZERO )THEN - ZETA = ONE - ALPHA = SCALE*SQRT( SSQ ) - CALL DSCAL( N, -1/ALPHA, X, INCX ) - ELSE - IF( SCALE.LT.ABS( ALPHA ) )THEN - BETA = ABS( ALPHA )*SQRT( 1 + SSQ*( SCALE/ALPHA )**2 ) - ELSE - BETA = SCALE *SQRT( SSQ + ( ALPHA/SCALE )**2 ) - END IF - ZETA = SQRT( ( BETA + ABS( ALPHA ) )/BETA ) - IF( ALPHA.GT.ZERO ) - $ BETA = -BETA - CALL DSCAL( N, -1/( ZETA*BETA ), X, INCX ) - ALPHA = BETA - END IF - END IF - END IF -C - RETURN -C -C End of F06FRF. ( SGRFG ) -C - END diff --git a/Libraries/MyNag/F06HBF.f b/Libraries/MyNag/F06HBF.f deleted file mode 100644 index 3471c7b29..000000000 --- a/Libraries/MyNag/F06HBF.f +++ /dev/null @@ -1,44 +0,0 @@ - SUBROUTINE F06HBF( N, CONST, X, INCX ) -C MARK 12 RELEASE. NAG COPYRIGHT 1986. -C .. Scalar Arguments .. - COMPLEX*16 CONST - INTEGER INCX, N -C .. Array Arguments .. - COMPLEX*16 X( * ) -C .. -C -C F06HBF performs the operation -C -C x = const*e, e' = ( 1 1 ... 1 ). -C -C -C Nag Fortran 77 O( n ) basic linear algebra routine. -C -C -- Written on 22-September-1983. -C Sven Hammarling, Nag Central Office. -C -C -C .. Parameters .. - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -C .. Local Scalars .. - INTEGER IX -C .. -C .. Executable Statements .. - IF( N.GT.0 )THEN - IF( CONST.NE.ZERO )THEN - DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX - X( IX ) = CONST - 10 CONTINUE - ELSE - DO 20, IX = 1, 1 + ( N - 1 )*INCX, INCX - X( IX ) = ZERO - 20 CONTINUE - END IF - END IF -C - RETURN -C -C End of F06HBF. ( CLOAD ) -C - END diff --git a/Libraries/MyNag/F06HRF.f b/Libraries/MyNag/F06HRF.f deleted file mode 100644 index 103eda7cf..000000000 --- a/Libraries/MyNag/F06HRF.f +++ /dev/null @@ -1,164 +0,0 @@ - SUBROUTINE F06HRF( N, ALPHA, X, INCX, TOL, THETA ) -C MARK 12 RELEASE. NAG COPYRIGHT 1986. -C .. Scalar Arguments .. - COMPLEX*16 ALPHA, THETA - DOUBLE PRECISION TOL - INTEGER INCX, N -C .. Array Arguments .. - COMPLEX*16 X( * ) -C .. -C -C F06HRF generates details of a generalized Householder reflection such -C that -C -C P*( alpha ) = ( beta ), conjg( P' )*P = I, aimag( beta ) = 0.0. -C ( x ) ( 0 ) -C -C P is given in the form -C -C P = I - gamma*( zeta )*( zeta conjg( z' ) ), -C ( z ) -C -C where z is an n element vector, gamma is a scalar such that -C -C real ( gamma ) = 1.0, -C aimag( gamma ) = aimag( alpha )/( beta - real( alpha ) ) -C -C and zeta is a real scalar that satisfies -C -C 1.0 .le. zeta .le. sqrt( 2.0 ). -C -C Note that when alpha is real then gamma = 1.0. -C -C gamma and zeta are returned in THETA as -C -C THETA = ( zeta, aimag( gamma ) ) -C -C unless x is such that -C -C max( abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ) .le. -C max( tol, eps*max( abs( real( alpha ) ), -C abs( aimag( alpha ) ) ) ), -C -C where eps is the relative machine precision and tol is the user -C supplied tolerance TOL, in which case THETA is returned as 0.0, or -C THETA is such that real( THETA ) .le. 0.0, in which case P can be -C taken to be -C -C P = I when THETA = 0.0, -C -C P = ( THETA 0 ) when real( THETA ) .le. 0.0, THETA .ne. 0.0. -C ( 0 I ) -C -C beta is overwritten on alpha with the imaginary part of alpha set to -C zero and z is overwritten on x. -C -C The routine may be called with n = 0. -C -C -C Nag Fortran 77 O( n ) basic linear algebra routine. -C -C -- Written on 30-August-1984. -C Sven Hammarling, Nag Central Office. -C -C -C .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) - COMPLEX*16 ZERO - PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) -C .. Local Scalars .. - COMPLEX*16 GAMMA - DOUBLE PRECISION BETA, EPS, SCALE, SSQ, ZETA - LOGICAL FIRST -C .. Local Arrays .. - COMPLEX*16 WORK( 1 ) -C .. External Functions .. - DOUBLE PRECISION X02AJF - EXTERNAL X02AJF -C .. External Subroutines .. - EXTERNAL ZSCAL, ZDSCAL, F06KJF -C .. Intrinsic Functions .. - INTRINSIC ABS, DIMAG, DCMPLX, DCONJG, MAX, DREAL, SIGN, - $ SQRT -C .. Save statement .. - SAVE EPS, FIRST -C .. Data statements .. - DATA FIRST/ .TRUE. / -C .. -C .. Executable Statements .. - IF( N.LT.1 )THEN - IF( DIMAG( ALPHA ).EQ.DREAL( ZERO ) )THEN - THETA = ZERO - ELSE - BETA = -SIGN ( ABS( ALPHA ), DREAL( ALPHA ) ) - THETA = DCONJG( ALPHA )/BETA - ALPHA = BETA - END IF - ELSE IF( ( N.EQ.1 ).AND.( X( 1 ).EQ.ZERO ) )THEN - IF( DIMAG( ALPHA ).EQ.DREAL( ZERO ) )THEN - THETA = ZERO - ELSE - BETA = -SIGN ( ABS( ALPHA ), DREAL( ALPHA ) ) - THETA = DCONJG( ALPHA )/BETA - ALPHA = BETA - END IF - ELSE -C - IF( FIRST )THEN - FIRST = .FALSE. - EPS = X02AJF( ) - END IF -C - SSQ = ONE - SCALE = DREAL( ZERO ) - CALL F06KJF( N, X, INCX, SCALE, SSQ ) -C -C Treat cases where SCALE = zero, SCALE is negligible -C and ALPHA = zero specially. -C Note that -C SCALE = max( abs( real( X( i ) ) ), abs( aimag( X( i ) ) ) ). -C - IF( ( SCALE.EQ.DREAL( ZERO ) ).OR. - $ ( SCALE.LE.MAX( TOL, - $ EPS*MAX( ABS( DREAL ( ALPHA ) ), - $ ABS( DIMAG( ALPHA ) ) ) ) ) )THEN - IF( DIMAG( ALPHA ).EQ.DREAL( ZERO ) )THEN - THETA = ZERO - ELSE - BETA = -SIGN ( ABS( ALPHA ), DREAL( ALPHA ) ) - THETA = DCONJG( ALPHA )/BETA - ALPHA = BETA - END IF - ELSE IF( ALPHA.EQ.ZERO )THEN - THETA = ONE - BETA = SCALE*SQRT( SSQ ) - CALL ZDSCAL( N, -1/BETA, X, INCX ) - ALPHA = BETA - ELSE - WORK( 1 ) = ALPHA - CALL F06KJF( 1, WORK, 1, SCALE, SSQ ) - BETA = SCALE*SQRT( SSQ ) - ZETA = SQRT( ( BETA + ABS( DREAL( ALPHA ) ) )/BETA ) - IF( DREAL( ALPHA ).GT.DREAL( ZERO ) ) - $ BETA = -BETA - IF( DIMAG( ALPHA ).EQ.DREAL( ZERO ) )THEN - CALL ZDSCAL( N, -1/( ZETA*BETA ), X, INCX ) - THETA = ZETA - ALPHA = BETA - ELSE - GAMMA = DCMPLX( ONE, - $ DIMAG( ALPHA )/( BETA - DREAL( ALPHA ))) - CALL ZSCAL( N, -1/( DCONJG( GAMMA )*ZETA*BETA ), - $ X, INCX ) - THETA = DCMPLX( ZETA, DIMAG( GAMMA ) ) - ALPHA = BETA - END IF - END IF - END IF -C - RETURN -C -C End of F06HRF. ( CGRFG ) -C - END diff --git a/Libraries/MyNag/F06KJF.f b/Libraries/MyNag/F06KJF.f deleted file mode 100644 index d58f83c74..000000000 --- a/Libraries/MyNag/F06KJF.f +++ /dev/null @@ -1,74 +0,0 @@ - SUBROUTINE F06KJF( N, X, INCX, SCALE, SUMSQ ) -C MARK 12 RELEASE. NAG COPYRIGHT 1986. -C .. Scalar Arguments .. - DOUBLE PRECISION SCALE, SUMSQ - INTEGER INCX, N -C .. Array Arguments .. - COMPLEX*16 X( * ) -C .. -C -C F06KJF returns the values scl and ssq such that -C -C ( scl**2 )*ssq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, -C -C where x( i ) = abs( X( 1 + ( i - 1 )*INCX ) ). The value of sumsq is -C assumed to be at least unity and the value of ssq will then satisfy -C -C 1.0 .le. ssq .le. ( sumsq + 2*n ). -C -C scale is assumed to be non-negative and scl returns the value -C -C scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ), -C i -C -C scale and sumsq must be supplied in SCALE and SUMSQ respectively. -C SCALE and SUMSQ are overwritten by scl and ssq respectively. -C -C The routine makes only one pass through the vector X. -C -C -C Nag Fortran 77 basic linear algebra routine. -C Nag Fortran 77 O( n ) basic linear algebra routine. -C -C -- Written on 27-April-1983. -C Sven Hammarling, Nag Central Office. -C -C -C .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -C .. Local Scalars .. - DOUBLE PRECISION TEMP1 - INTEGER IX -C .. Intrinsic Functions .. - INTRINSIC ABS, DIMAG, DREAL -C .. -C .. Executable Statements .. - IF( N.GT.0 )THEN - DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX - IF( DREAL( X( IX ) ).NE.ZERO )THEN - TEMP1 = ABS( DREAL( X( IX ) ) ) - IF( SCALE.LT.TEMP1 )THEN - SUMSQ = 1 + SUMSQ*( SCALE/TEMP1 )**2 - SCALE = TEMP1 - ELSE - SUMSQ = SUMSQ + ( TEMP1/SCALE )**2 - END IF - END IF - IF( DIMAG( X( IX ) ).NE.ZERO )THEN - TEMP1 = ABS( DIMAG( X( IX ) ) ) - IF( SCALE.LT.TEMP1 )THEN - SUMSQ = 1 + SUMSQ*( SCALE/TEMP1 )**2 - SCALE = TEMP1 - ELSE - SUMSQ = SUMSQ + ( TEMP1/SCALE )**2 - END IF - END IF - 10 CONTINUE - END IF -C - RETURN -C -C End of F06KJF. ( SCSSQ ) -C - END diff --git a/Libraries/MyNag/F06QHF.f b/Libraries/MyNag/F06QHF.f deleted file mode 100644 index e186b4b72..000000000 --- a/Libraries/MyNag/F06QHF.f +++ /dev/null @@ -1,77 +0,0 @@ - SUBROUTINE F06QHF( MATRIX, M, N, CONST, DIAG, A, LDA ) -C MARK 13 RELEASE. NAG COPYRIGHT 1988. -C .. Scalar Arguments .. - CHARACTER*1 MATRIX - DOUBLE PRECISION CONST, DIAG - INTEGER LDA, M, N -C .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -C .. -C -C F06QHF forms the m by n matrix A given by -C -C a( i, j ) = ( diag i.eq.j, -C ( -C ( const i.ne.j. -C -C If MATRIX = 'G' or 'g' then A is regarded as a general matrix, -C if MATRIX = 'U' or 'u' then A is regarded as upper triangular, -C and only elements for which i.le.j are -C referenced, -C if MATRIX = 'L' or 'l' then A is regarded as lower triangular, -C and only elements for which i.ge.j are -C referenced. -C -C -C Nag Fortran 77 O( n**2 ) basic linear algebra routine. -C -C -- Written on 21-November-1986. -C Sven Hammarling, Nag Central Office. -C -C -C .. Local Scalars .. - INTEGER I, J -C .. Intrinsic Functions .. - INTRINSIC MIN -C .. -C .. Executable Statements .. - IF( ( MATRIX.EQ.'G' ).OR.( MATRIX.EQ.'g' ) )THEN - DO 20 J = 1, N - DO 10 I = 1, M - A( I, J ) = CONST - 10 CONTINUE - 20 CONTINUE - IF( CONST.NE.DIAG )THEN - DO 30 I = 1, MIN( M, N ) - A( I, I ) = DIAG - 30 CONTINUE - END IF - ELSE IF( ( MATRIX.EQ.'U' ).OR.( MATRIX.EQ.'u' ) )THEN - DO 50 J = 1, N - DO 40 I = 1, MIN( M, J ) - A( I, J ) = CONST - 40 CONTINUE - 50 CONTINUE - IF( CONST.NE.DIAG )THEN - DO 60 I = 1, MIN( M, N ) - A( I, I ) = DIAG - 60 CONTINUE - END IF - ELSE IF( ( MATRIX.EQ.'L' ).OR.( MATRIX.EQ.'l' ) )THEN - DO 80 J = 1, MIN( M, N ) - DO 70 I = J, M - A( I, J ) = CONST - 70 CONTINUE - 80 CONTINUE - IF( CONST.NE.DIAG )THEN - DO 90 I = 1, MIN( M, N ) - A( I, I ) = DIAG - 90 CONTINUE - END IF - END IF -C - RETURN -C -C End of F06QHF. ( SMLOAD ) -C - END diff --git a/Libraries/MyNag/F06THF.f b/Libraries/MyNag/F06THF.f deleted file mode 100644 index 1223f09fd..000000000 --- a/Libraries/MyNag/F06THF.f +++ /dev/null @@ -1,77 +0,0 @@ - SUBROUTINE F06THF( MATRIX, M, N, CONST, DIAG, A, LDA ) -C MARK 13 RELEASE. NAG COPYRIGHT 1988. -C .. Scalar Arguments .. - CHARACTER*1 MATRIX - COMPLEX*16 CONST, DIAG - INTEGER LDA, M, N -C .. Array Arguments .. - COMPLEX*16 A( LDA, * ) -C .. -C -C F06THF forms the m by n matrix A given by -C -C a( i, j ) = ( diag i.eq.j, -C ( -C ( const i.ne.j. -C -C If MATRIX = 'G' or 'g' then A is regarded as a general matrix, -C if MATRIX = 'U' or 'u' then A is regarded as upper triangular, -C and only elements for which i.le.j are -C referenced, -C if MATRIX = 'L' or 'l' then A is regarded as lower triangular, -C and only elements for which i.ge.j are -C referenced. -C -C -C Nag Fortran 77 O( n**2 ) basic linear algebra routine. -C -C -- Written on 21-November-1986. -C Sven Hammarling, Nag Central Office. -C -C -C .. Local Scalars .. - INTEGER I, J -C .. Intrinsic Functions .. - INTRINSIC MIN -C .. -C .. Executable Statements .. - IF( ( MATRIX.EQ.'G' ).OR.( MATRIX.EQ.'g' ) )THEN - DO 20 J = 1, N - DO 10 I = 1, M - A( I, J ) = CONST - 10 CONTINUE - 20 CONTINUE - IF( CONST.NE.DIAG )THEN - DO 30 I = 1, MIN( M, N ) - A( I, I ) = DIAG - 30 CONTINUE - END IF - ELSE IF( ( MATRIX.EQ.'U' ).OR.( MATRIX.EQ.'u' ) )THEN - DO 50 J = 1, N - DO 40 I = 1, MIN( M, J ) - A( I, J ) = CONST - 40 CONTINUE - 50 CONTINUE - IF( CONST.NE.DIAG )THEN - DO 60 I = 1, MIN( M, N ) - A( I, I ) = DIAG - 60 CONTINUE - END IF - ELSE IF( ( MATRIX.EQ.'L' ).OR.( MATRIX.EQ.'l' ) )THEN - DO 80 J = 1, MIN( M, N ) - DO 70 I = J, M - A( I, J ) = CONST - 70 CONTINUE - 80 CONTINUE - IF( CONST.NE.DIAG )THEN - DO 90 I = 1, MIN( M, N ) - A( I, I ) = DIAG - 90 CONTINUE - END IF - END IF -C - RETURN -C -C End of F06THF. ( CMLOAD ) -C - END diff --git a/Libraries/MyNag/Makefile b/Libraries/MyNag/Makefile deleted file mode 100644 index 4df7646e8..000000000 --- a/Libraries/MyNag/Makefile +++ /dev/null @@ -1,11 +0,0 @@ -LIB=libnag.a -OBJS=F01QCF.o F01REF.o F06FRF.o F06QHF.o P01ABY.o X04AAF.o\ -F01QDF.o F06AAZ.o F06HBF.o F06THF.o P01ABZ.o X04BAF.o\ -F01QEF.o F06FBF.o F06HRF.o P01ABF.o P01ACF.o\ -F01RCF.o F06FJF.o F06KJF.o P01ABW.o X02AJF.o -$(LIB): $(OBJS) - ar r $(LIB) $(OBJS) -.f.o: - $(FC) $(FLAGS) $< -clean: - rm $(LIB) $(OBJS) diff --git a/Libraries/MyNag/P01ABF.f b/Libraries/MyNag/P01ABF.f deleted file mode 100644 index 2c26e6712..000000000 --- a/Libraries/MyNag/P01ABF.f +++ /dev/null @@ -1,82 +0,0 @@ - INTEGER FUNCTION P01ABF(IFAIL,IERROR,SRNAME,NREC,REC) -C MARK 11.5(F77) RELEASE. NAG COPYRIGHT 1986. -C MARK 13 REVISED. IER-621 (APR 1988). -C MARK 13B REVISED. IER-668 (AUG 1988). -C -C P01ABF is the error-handling routine for the NAG Library. -C -C P01ABF either returns the value of IERROR through the routine -C name (soft failure), or terminates execution of the program -C (hard failure). Diagnostic messages may be output. -C -C If IERROR = 0 (successful exit from the calling routine), -C the value 0 is returned through the routine name, and no -C message is output -C -C If IERROR is non-zero (abnormal exit from the calling routine), -C the action taken depends on the value of IFAIL. -C -C IFAIL = 1: soft failure, silent exit (i.e. no messages are -C output) -C IFAIL = -1: soft failure, noisy exit (i.e. messages are output) -C IFAIL =-13: soft failure, noisy exit but standard messages from -C P01ABF are suppressed -C IFAIL = 0: hard failure, noisy exit -C -C For compatibility with certain routines included before Mark 12 -C P01ABF also allows an alternative specification of IFAIL in which -C it is regarded as a decimal integer with least significant digits -C cba. Then -C -C a = 0: hard failure a = 1: soft failure -C b = 0: silent exit b = 1: noisy exit -C -C except that hard failure now always implies a noisy exit. -C -C S.Hammarling, M.P.Hooper and J.J.du Croz, NAG Central Office. -C -C .. Scalar Arguments .. - INTEGER IERROR, IFAIL, NREC - CHARACTER*(*) SRNAME -C .. Array Arguments .. - CHARACTER*(*) REC(*) -C .. Local Scalars .. - INTEGER I, NERR - CHARACTER*72 MESS -C .. External Subroutines .. - EXTERNAL P01ABZ, X04AAF, X04BAF -C .. Intrinsic Functions .. - INTRINSIC ABS, MOD -C .. Executable Statements .. - IF (IERROR.NE.0) THEN -C Abnormal exit from calling routine - IF (IFAIL.EQ.-1 .OR. IFAIL.EQ.0 .OR. IFAIL.EQ.-13 .OR. - * (IFAIL.GT.0 .AND. MOD(IFAIL/10,10).NE.0)) THEN -C Noisy exit - CALL X04AAF(0,NERR) - DO 20 I = 1, NREC - CALL X04BAF(NERR,REC(I)) - 20 CONTINUE - IF (IFAIL.NE.-13) THEN - WRITE (MESS,FMT=99999) SRNAME, IERROR - CALL X04BAF(NERR,MESS) - IF (ABS(MOD(IFAIL,10)).NE.1) THEN -C Hard failure - CALL X04BAF(NERR, - * ' ** NAG hard failure - execution terminated' - * ) - CALL P01ABZ - ELSE -C Soft failure - CALL X04BAF(NERR, - * ' ** NAG soft failure - control returned') - END IF - END IF - END IF - END IF - P01ABF = IERROR - RETURN -C -99999 FORMAT (' ** ABNORMAL EXIT from NAG Library routine ',A,': IFAIL', - * ' =',I6) - END diff --git a/Libraries/MyNag/P01ABW.f b/Libraries/MyNag/P01ABW.f deleted file mode 100644 index 018a9fc29..000000000 --- a/Libraries/MyNag/P01ABW.f +++ /dev/null @@ -1,54 +0,0 @@ - SUBROUTINE P01ABW(N,NAME,INFORM,IERR,SRNAME) -C MARK 12 RELEASE. NAG COPYRIGHT 1986. -C -C P01ABW increases the value of IERR by 1 and, if -C -C ( mod( INFORM, 10 ).ne.1 ).or.( mod( INFORM/10, 10 ).ne.0 ) -C -C writes a message on the current error message channel giving the -C value of N, a message to say that N is invalid and the strings -C NAME and SRNAME. -C -C NAME must be the name of the actual argument for N and SRNAME must -C be the name of the calling routine. -C -C This routine is intended for use when N is an invalid input -C parameter to routine SRNAME. For example -C -C IERR = 0 -C IF( N.NE.'Valid value' ) -C $ CALL P01ABW( N, 'N', IDIAG, IERR, SRNAME ) -C -C -- Written on 15-November-1984. -C Sven Hammarling, Nag Central Office. -C -C .. Scalar Arguments .. - INTEGER IERR, INFORM - CHARACTER*(*) N - CHARACTER*(*) NAME, SRNAME -C .. Local Scalars .. - INTEGER NERR -C .. Local Arrays .. - CHARACTER*65 REC(3) -C .. External Subroutines .. - EXTERNAL X04AAF, X04BAF -C .. Intrinsic Functions .. - INTRINSIC MOD -C .. Executable Statements .. - IERR = IERR + 1 - IF ((MOD(INFORM,10).NE.1) .OR. (MOD(INFORM/10,10).NE.0)) THEN - CALL X04AAF(0,NERR) - WRITE (REC,FMT=99999) NAME, SRNAME, N - CALL X04BAF(NERR,' ') - CALL X04BAF(NERR,REC(1)) - CALL X04BAF(NERR,REC(2)) - CALL X04BAF(NERR,REC(3)) - END IF - RETURN -C -C -C End of P01ABW. -C -99999 FORMAT (' ***** Parameter ',A,' is invalid in routine ',A, - * ' ***** ',/8X,'Value supplied is',/8X,A) - END diff --git a/Libraries/MyNag/P01ABY.f b/Libraries/MyNag/P01ABY.f deleted file mode 100644 index b44156602..000000000 --- a/Libraries/MyNag/P01ABY.f +++ /dev/null @@ -1,50 +0,0 @@ - SUBROUTINE P01ABY(N,NAME,INFORM,IERR,SRNAME) -C MARK 12 RELEASE. NAG COPYRIGHT 1986. -C -C P01ABY increases the value of IERR by 1 and, if -C -C ( mod( INFORM, 10 ).ne.1 ).or.( mod( INFORM/10, 10 ).ne.0 ) -C -C writes a message on the current error message channel giving the -C value of N, a message to say that N is invalid and the strings -C NAME and SRNAME. -C -C NAME must be the name of the actual argument for N and SRNAME must -C be the name of the calling routine. -C -C This routine is intended for use when N is an invalid input -C parameter to routine SRNAME. For example -C -C IERR = 0 -C IF( N.LT.1 )CALL P01ABY( N, 'N', IDIAG, IERR, SRNAME ) -C -C -- Written on 23-February-1984. Sven. -C -C .. Scalar Arguments .. - INTEGER IERR, INFORM, N - CHARACTER*(*) NAME, SRNAME -C .. Local Scalars .. - INTEGER NERR -C .. Local Arrays .. - CHARACTER*65 REC(2) -C .. External Subroutines .. - EXTERNAL X04AAF, X04BAF -C .. Intrinsic Functions .. - INTRINSIC MOD -C .. Executable Statements .. - IERR = IERR + 1 - IF ((MOD(INFORM,10).NE.1) .OR. (MOD(INFORM/10,10).NE.0)) THEN - CALL X04AAF(0,NERR) - WRITE (REC,FMT=99999) NAME, SRNAME, N - CALL X04BAF(NERR,' ') - CALL X04BAF(NERR,REC(1)) - CALL X04BAF(NERR,REC(2)) - END IF - RETURN -C -C -C End of P01ABY. -C -99999 FORMAT (' ***** Parameter ',A,' is invalid in routine ',A, - * ' ***** ',/8X,'Value supplied is ',I6) - END diff --git a/Libraries/MyNag/P01ABZ.f b/Libraries/MyNag/P01ABZ.f deleted file mode 100644 index f48c1690d..000000000 --- a/Libraries/MyNag/P01ABZ.f +++ /dev/null @@ -1,15 +0,0 @@ - SUBROUTINE P01ABZ -C MARK 11.5(F77) RELEASE. NAG COPYRIGHT 1986. -C -C Terminates execution when a hard failure occurs. -C -C ******************** IMPLEMENTATION NOTE ******************** -C The following STOP statement may be replaced by a call to an -C implementation-dependent routine to display a message and/or -C to abort the program. -C ************************************************************* -C .. Executable Statements .. -C F.Assaad extension. ERRTRA commented out. -C CALL ERRTRA - STOP - END diff --git a/Libraries/MyNag/P01ACF.f b/Libraries/MyNag/P01ACF.f deleted file mode 100644 index 66fbf97ea..000000000 --- a/Libraries/MyNag/P01ACF.f +++ /dev/null @@ -1,96 +0,0 @@ - INTEGER FUNCTION P01ACF(IFAIL,IERROR,SRNAME,VARBNM,NREC,REC) -C MARK 15 RELEASE. NAG COPYRIGHT 1991. -C -C P01ACF is the error-handling routine for the F06 AND F07 -C Chapters of the NAG Fortran Library. It is a slightly modified -C version of P01ABF. -C -C P01ACF either returns the value of IERROR through the routine -C name (soft failure), or terminates execution of the program -C (hard failure). Diagnostic messages may be output. -C -C If IERROR = 0 (successful exit from the calling routine), -C the value 0 is returned through the routine name, and no -C message is output -C -C If IERROR is non-zero (abnormal exit from the calling routine), -C the action taken depends on the value of IFAIL. -C -C IFAIL = 1: soft failure, silent exit (i.e. no messages are -C output) -C IFAIL = -1: soft failure, noisy exit (i.e. messages are output) -C IFAIL =-13: soft failure, noisy exit but standard messages from -C P01ACF are suppressed -C IFAIL = 0: hard failure, noisy exit -C -C For compatibility with certain routines included before Mark 12 -C P01ACF also allows an alternative specification of IFAIL in which -C it is regarded as a decimal integer with least significant digits -C cba. Then -C -C a = 0: hard failure a = 1: soft failure -C b = 0: silent exit b = 1: noisy exit -C -C except that hard failure now always implies a noisy exit. -C -C S.Hammarling, M.P.Hooper and J.J.du Croz, NAG Central Office. -C -C .. Scalar Arguments .. - INTEGER IERROR, IFAIL, NREC - CHARACTER*(*) SRNAME, VARBNM -C .. Array Arguments .. - CHARACTER*(*) REC(*) -C .. Local Scalars .. - INTEGER I, NERR, VARLEN - CHARACTER*72 MESS -C .. External Subroutines .. - EXTERNAL P01ABZ, X04AAF, X04BAF -C .. Intrinsic Functions .. - INTRINSIC ABS, LEN, MOD -C .. Executable Statements .. - IF (IERROR.NE.0) THEN - VARLEN = 0 - DO 20 I = LEN(VARBNM), 1, -1 - IF (VARBNM(I:I).NE.' ') THEN - VARLEN = I - GO TO 40 - END IF - 20 CONTINUE - 40 CONTINUE -C Abnormal exit from calling routine - IF (IFAIL.EQ.-1 .OR. IFAIL.EQ.0 .OR. IFAIL.EQ.-13 .OR. - * (IFAIL.GT.0 .AND. MOD(IFAIL/10,10).NE.0)) THEN -C Noisy exit - CALL X04AAF(0,NERR) - DO 60 I = 1, NREC - CALL X04BAF(NERR,REC(I)) - 60 CONTINUE - IF (IFAIL.NE.-13) THEN - IF (VARLEN.NE.0) THEN - WRITE (MESS,FMT=99999) SRNAME, VARBNM(1:VARLEN), - * IERROR - ELSE - WRITE (MESS,FMT=99998) SRNAME - END IF - CALL X04BAF(NERR,MESS) - IF (ABS(MOD(IFAIL,10)).NE.1) THEN -C Hard failure - CALL X04BAF(NERR, - * ' ** NAG hard failure - execution terminated' - * ) - CALL P01ABZ - ELSE -C Soft failure - CALL X04BAF(NERR, - * ' ** NAG soft failure - control returned') - END IF - END IF - END IF - END IF - P01ACF = IERROR - RETURN -C -99999 FORMAT (' ** ABNORMAL EXIT from NAG Library routine ',A,': ',A, - * ' =',I6) -99998 FORMAT (' ** ABNORMAL EXIT from NAG Library routine ',A) - END diff --git a/Libraries/MyNag/X02AJF.f b/Libraries/MyNag/X02AJF.f deleted file mode 100644 index aac6508a3..000000000 --- a/Libraries/MyNag/X02AJF.f +++ /dev/null @@ -1,13 +0,0 @@ - DOUBLE PRECISION FUNCTION X02AJF() -C MARK 12 RELEASE. NAG COPYRIGHT 1986. -C -C RETURNS (1/2)*B**(1-P) IF ROUNDS IS .TRUE. -C RETURNS B**(1-P) OTHERWISE -C -C .. Local Scalars .. - DOUBLE PRECISION Z - DATA Z/0.222044604925031336E-15/ -C .. Executable Statements .. - X02AJF = Z - RETURN - END diff --git a/Libraries/MyNag/X04AAF.f b/Libraries/MyNag/X04AAF.f deleted file mode 100644 index 7395c062c..000000000 --- a/Libraries/MyNag/X04AAF.f +++ /dev/null @@ -1,23 +0,0 @@ - SUBROUTINE X04AAF(I,NERR) -C MARK 7 RELEASE. NAG COPYRIGHT 1978 -C MARK 7C REVISED IER-190 (MAY 1979) -C MARK 11.5(F77) REVISED. (SEPT 1985.) -C MARK 14 REVISED. IER-829 (DEC 1989). -C IF I = 0, SETS NERR TO CURRENT ERROR MESSAGE UNIT NUMBER -C (STORED IN NERR1). -C IF I = 1, CHANGES CURRENT ERROR MESSAGE UNIT NUMBER TO -C VALUE SPECIFIED BY NERR. -C -C .. Scalar Arguments .. - INTEGER I, NERR -C .. Local Scalars .. - INTEGER NERR1 -C .. Save statement .. - SAVE NERR1 -C .. Data statements .. - DATA NERR1/6/ -C .. Executable Statements .. - IF (I.EQ.0) NERR = NERR1 - IF (I.EQ.1) NERR1 = NERR - RETURN - END diff --git a/Libraries/MyNag/X04BAF.f b/Libraries/MyNag/X04BAF.f deleted file mode 100644 index b1827c4b1..000000000 --- a/Libraries/MyNag/X04BAF.f +++ /dev/null @@ -1,30 +0,0 @@ - SUBROUTINE X04BAF(NOUT,REC) -C MARK 11.5(F77) RELEASE. NAG COPYRIGHT 1986. -C -C X04BAF writes the contents of REC to the unit defined by NOUT. -C -C Trailing blanks are not output, except that if REC is entirely -C blank, a single blank character is output. -C If NOUT.lt.0, i.e. if NOUT is not a valid Fortran unit identifier, -C then no output occurs. -C -C .. Scalar Arguments .. - INTEGER NOUT - CHARACTER*(*) REC -C .. Local Scalars .. - INTEGER I -C .. Intrinsic Functions .. - INTRINSIC LEN -C .. Executable Statements .. - IF (NOUT.GE.0) THEN -C Remove trailing blanks - DO 20 I = LEN(REC), 2, -1 - IF (REC(I:I).NE.' ') GO TO 40 - 20 CONTINUE -C Write record to external file - 40 WRITE (NOUT,FMT=99999) REC(1:I) - END IF - RETURN -C -99999 FORMAT (A) - END diff --git a/Libraries/MyNag/comp b/Libraries/MyNag/comp deleted file mode 100644 index 189980942..000000000 --- a/Libraries/MyNag/comp +++ /dev/null @@ -1 +0,0 @@ -if77 -c -O4 -Mvect -nx *.f diff --git a/Libraries/MyNag/work.pc b/Libraries/MyNag/work.pc deleted file mode 100644 index 879a952063cf40e6ad65c1aa519d4a43f969c8ad..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 2673 zcma)7O;1x%5WRqu!bU=nm}pp;$b#T2Azd{lt=JGWrX?gm7h*ps^_x~y?5}X?4=^rS zxNyOe7#GGE7lt))WeiK!>N#`Yyf-|nIHB*JJ2Us(duHx?4CS_-)~nlBFQl7p`pQ{1 zoZfU36XR~eITzrUPC0k?jB}%xo$JTE-}T|?B<~#Z(!jr9^l@Z#9KQklCPN>F6E*;j z96a2M9P_|QjuL#>+Eq*pFfwwy#7xio3OLE}8a|$R*TeuLBgZ~w%JC66$#D>7(@%>Q zhkzW1z{>F*So1it9>@66IH&np{3ORuOtl^;{$x`?H3bEavT|sW0R*G(iAM>oMzV(Q_Bb%r&`8F^RxI#j*8)^_275}AN#UnVlji)^2TuNnmq1F zEqm~Bd~ae&j?aeUz~m{%H~46r)BG%cQp=IyIPSqAjXi~91kKl)jsfdl9HlS39H($h z8IGU_NA5p3iiYD>4~`0ayz31UlY@m1)??Rjyfb;KWgk8o=QKZypXB&tIKKAaID`+M zPxr&bVg~;`9YuoH^gOWc#gR3=1Rs{W852u#+zdJR?Orx{%5eui8s{`Wi=Qc13Nra? z#bGz?!OUYf zQKJAFZE7@ARs{g6pluY$xnnI*(DVu#qF~Tr>`)PlaNVDSK)E^_aSdW5YEIN;yY-K{ z_{!BHMN6UH;*##;PsNVSR;f)^gen_hZBdKzLbwt@Yti;QOXb(J@@o=}Px$9eNV(Nu zE}ti#2eLx*q#ot@upR(fk9Om)RnRJ@SX0~%Tia|tU-3N#(34lIT`J`|c1-TVLLpQL zpn0vRa?7e8K%-&hML+lOK%#OY>>*kUsue(@&?@hQ*Q&iQ$GvZx-X}UP%-W~014-4s zZ@!a}f}-jJPzB8>x}Y}$K%?@;C2oei9Ye0`x8VC|-#=DRs^B@|vubzc%W(30AT^rJ O%e%H35QH_7`}iB4UTl{D diff --git a/Libraries/MyNag/work.pcl b/Libraries/MyNag/work.pcl deleted file mode 100644 index 7f6c06e22..000000000 --- a/Libraries/MyNag/work.pcl +++ /dev/null @@ -1 +0,0 @@ -work.pc diff --git a/Prog_7/Compile_Hub b/Prog_7/Compile_Hub deleted file mode 100644 index ace754b8c..000000000 --- a/Prog_7/Compile_Hub +++ /dev/null @@ -1,16 +0,0 @@ -TARGET= Hubb.out -OBJS= control_mod.o Operator.o print_bin_mod.o Hamiltonian_Hub.o Hop_mod.o UDV_WRAP.o tau_m.o main.o wrapul.o cgr1.o wrapgrup.o wrapur.o upgrade.o \ - nranf.o wrapgrdo.o outconfc.o inconfc.o cgr2.o cgr2_2.o cgr2_1.o - - - -.SUFFIXES: .f90 .f -.f.o .f90.o: - $(FC) -c -cpp -o $@ $(FLAGS) $< - -$(TARGET): $(OBJS) - $(FC) $(LF) -o $(TARGET) $(OBJS) $(LIBS) - -clean: - rm $(OBJS) - diff --git a/Prog_7/Compile_SPT b/Prog_7/Compile_SPT deleted file mode 100644 index e7b63f777..000000000 --- a/Prog_7/Compile_SPT +++ /dev/null @@ -1,20 +0,0 @@ -TARGET= SPT.out -OBJS= control_mod.o Operator.o print_bin_mod.o Hamiltonian_SPT.o Hop_mod.o UDV_WRAP.o tau_m.o main.o wrapul.o cgr1.o wrapgrup.o wrapur.o upgrade.o \ - nranf.o wrapgrdo.o outconfc.o inconfc.o cgr2.o cgr2_2.o cgr2_1.o - -#block.o block_obs.o Mol_Dyn.o Hubb.o inconfc.o outconfc.o npbc.o salph.o sli.o \ -# sthop.o wrapul.o wrapur.o cgr1.o \ -# wrapgrdo.o mmthr.o mmthrm1.o mmthl.o mmthlm1.o obser.o upgradeu.o wrapgrup.o \ -# preq.o cgr2.o propr.o proprm1.o obsert.o prtau.o tau_m.o set_Hopping.o - - -.SUFFIXES: .f90 .f -.f.o .f90.o: - $(FC) -c -cpp -o $@ $(FLAGS) $< - -$(TARGET): $(OBJS) - $(FC) $(LF) -o $(TARGET) $(OBJS) $(LIBS) - -clean: - rm $(OBJS) - diff --git a/Prog_7/Ham_hop b/Prog_7/Ham_hop deleted file mode 100644 index e69de29bb..000000000 diff --git a/Prog_7/Ham_obser.f90 b/Prog_7/Ham_obser.f90 deleted file mode 100644 index 8fa394ab1..000000000 --- a/Prog_7/Ham_obser.f90 +++ /dev/null @@ -1,9 +0,0 @@ - Module - - Implicit none - - Complex (Kind=8) :: Phase - - - end SUBROUTINE Ham_obser - diff --git a/Prog_7/Hamiltonian_Hub.f90 b/Prog_7/Hamiltonian_Hub.f90 deleted file mode 100644 index 72a1d5f17..000000000 --- a/Prog_7/Hamiltonian_Hub.f90 +++ /dev/null @@ -1,539 +0,0 @@ - Module Hamiltonian - - Use Operator_mod - Use Lattices_v3 - Use MyMats - Use Random_Wrap - Use Files_mod - Use Matrix - Use Print_bin_mod - - - Type (Operator), dimension(:,:), allocatable :: Op_V - Type (Operator), dimension(:,:), allocatable :: Op_T - Integer, allocatable :: nsigma(:,:) - Integer :: Ndim, N_FL, N_SUN, Ltrot - !Complex (Kind=8), dimension(:,:,:), allocatable :: Exp_T(:,:,:), Exp_T_M1(:,:,:) - - ! ToDo. Public and private subroutines. - - ! What is below is private - Type (Lattice), private :: Latt - Integer, private :: L1, L2 - real (Kind=8), private :: ham_T , ham_U, Ham_chem - real (Kind=8), private :: Dtau, Beta - Character (len=64), private :: Model, Lattice_type - Logical, private :: One_dimensional - Integer, private :: N_coord - - - ! Observables - Integer, private :: Nobs, Norb - Complex (Kind=8), allocatable, private :: obs_scal(:) - Complex (Kind=8), allocatable, private :: Green_eq (:,:,:), SpinZ_eq (:,:,:), SpinXY_eq (:,:,:), & - & Den_eq(:,:,:) - Complex (Kind=8), allocatable, private :: Green_eq0 (:), SpinZ_eq0(:), SpinXY_eq0(:), & - & Den_eq0(:) - - ! For time displaced - Integer, private :: NobsT - Complex (Kind=8), private :: Phase_tau - Complex (Kind=8), allocatable, private :: Green_tau(:,:,:,:), Den_tau(:,:,:,:) - - contains - - - Subroutine Ham_Set - - Implicit none -#include "machine" -#ifdef MPI - include 'mpif.h' -#endif - - integer :: ierr - - - NAMELIST /VAR_lattice/ L1, L2, Lattice_type, Model - - NAMELIST /VAR_Hubbard/ ham_T, ham_chem, ham_U, Dtau, Beta - - -#ifdef MPI - Integer :: Isize, Irank - Integer :: STATUS(MPI_STATUS_SIZE) - CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) - CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) -#endif - - - ! NAMELIST /VAR_Model/ N_FL, N_SUN, ham_T , ham_xi, ham_h, ham_J, ham_U, Ham_Vint, & - ! & Dtau, Beta - - -#ifdef MPI - If (Irank == 0 ) then -#endif - OPEN(UNIT=5,FILE='parameters',STATUS='old',ACTION='read',IOSTAT=ierr) - IF (ierr /= 0) THEN - WRITE(*,*) 'unable to open ',ierr - STOP - END IF - READ(5,NML=VAR_lattice) - CLOSE(5) - -#ifdef MPI - Endif - CALL MPI_BCAST(L1 ,1 ,MPI_INTEGER, 0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(L2 ,1 ,MPI_INTEGER, 0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(Model ,64 ,MPI_CHARACTER, 0,MPI_COMM_WORLD,IERR) - CALL MPI_BCAST(Lattice_type,64 ,MPI_CHARACTER, 0,MPI_COMM_WORLD,IERR) -#endif - Call Ham_latt - - If ( Model == "Hubbard_Mz") then - N_FL = 2 - N_SUN = 1 - elseif ( Model == "Hubbard_SU2" ) then - N_FL = 1 - N_SUN = 2 - else - Write(6,*) "Model not yet implemented!" - Stop - endif -#ifdef MPI - If (Irank == 0 ) then -#endif - OPEN(UNIT=5,FILE='parameters',STATUS='old',ACTION='read',IOSTAT=ierr) - READ(5,NML=VAR_Hubbard) - CLOSE(5) -#ifdef MPI - endif - CALL MPI_BCAST(ham_T ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(ham_chem ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(ham_U ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(Dtau ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(Beta ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) -#endif - Call Ham_hop - - Ltrot = nint(beta/dtau) -#ifdef MPI - If (Irank == 0) then -#endif - Open (Unit = 50,file="info",status="unknown",position="append") - Write(50,*) '=====================================' - Write(50,*) 'Model is : ', Model - Write(50,*) 'Beta : ', Beta - Write(50,*) 'dtau,Ltrot : ', dtau,Ltrot - Write(50,*) 'N_SUN : ', N_SUN - Write(50,*) 'N_FL : ', N_FL - Write(50,*) 't : ', Ham_T - Write(50,*) 'Ham_U : ', Ham_U - Write(50,*) 'Ham_chem : ', Ham_chem - close(50) -#ifdef MPI - endif -#endif - call Ham_V - end Subroutine Ham_Set -!============================================================================= - Subroutine Ham_Latt - Implicit none - !Set the lattice - Real (Kind=8) :: a1_p(2), a2_p(2), L1_p(2), L2_p(2) - If ( Lattice_type =="Square" ) then - a1_p(1) = 1.0 ; a1_p(2) = 0.d0 - a2_p(1) = 0.0 ; a2_p(2) = 1.d0 - L1_p = dble(L1)*a1_p - L2_p = dble(L2)*a2_p - Call Make_Lattice( L1_p, L2_p, a1_p, a2_p, Latt ) - Ndim = Latt%N - !Write(6,*) 'Lattice: ', Ndim - One_dimensional = .false. - N_coord = 2 - If ( L1 == 1 .or. L2 == 1 ) then - One_dimensional = .true. - N_coord = 1 - If (L1 == 1 ) then - Write(6,*) ' For one dimensional systems set L2 = 1 ' - Stop - endif - endif - else - Write(6,*) "Lattice not yet implemented!" - Stop - endif - end Subroutine Ham_Latt - -!=================================================================================== - Subroutine Ham_hop - Implicit none - - !Setup the hopping - !Per flavor, the hopping is given by: - ! e^{-dtau H_t} = Prod_{n=1}^{Ncheck} e^{-dtau_n H_{n,t}} - - - Integer :: I, I1, I2, n, Ncheck,nc - Real (Kind=8) :: X - - Ncheck = 1 - allocate(Op_T(Ncheck,N_FL)) - do n = 1,N_FL - Do nc = 1,Ncheck - Call Op_make(Op_T(nc,n),Ndim) - If (One_dimensional ) then - DO I = 1, Latt%N - I1 = Latt%nnlist(I,1,0) - Op_T(nc,n)%O(I,I1) = cmplx(-Ham_T,0.d0) - Op_T(nc,n)%O(I1,I) = cmplx(-Ham_T,0.d0) - Op_T(nc,n)%O(I ,I) = cmplx(-Ham_chem,0.d0) - ENDDO - else - DO I = 1, Latt%N - I1 = Latt%nnlist(I,1,0) - I2 = Latt%nnlist(I,0,1) - Op_T(nc,n)%O(I,I1) = cmplx(-Ham_T, 0.d0) - Op_T(nc,n)%O(I1,I) = cmplx(-Ham_T, 0.d0) - Op_T(nc,n)%O(I,I2) = cmplx(-Ham_T, 0.d0) - Op_T(nc,n)%O(I2,I) = cmplx(-Ham_T, 0.d0) - Op_T(nc,n)%O(I ,I) = cmplx(-Ham_chem,0.d0) - ENDDO - endif - - Do I = 1,Latt%N - Op_T(nc,n)%P(i) = i - Enddo - if ( abs(Ham_T) < 1.E-6 .and. abs(Ham_chem) < 1.E-6 ) then - Op_T(nc,n)%g=cmplx(0.d0 ,0.d0) - else - Op_T(nc,n)%g=cmplx(-Dtau,0.d0) - endif - Op_T(nc,n)%alpha=cmplx(0.d0,0.d0) - !Write(6,*) 'In Ham_hop', Ham_T - Call Op_set(Op_T(nc,n)) - !Write(6,*) 'In Ham_hop 1' - !Do I = 1,Latt%N - ! Write(6,*) Op_T(n)%E(i) - !enddo - !Call Op_exp( cmplx(-Dtau,0.d0), Op_T(n), Exp_T (:,:,n) ) - !Call Op_exp( cmplx( Dtau,0.d0), Op_T(n), Exp_T_M1(:,:,n) ) - enddo - enddo - end Subroutine Ham_hop - -!=================================================================================== - - Subroutine Ham_V - - Implicit none - - Integer :: nf, nth, n, n1, n2, n3, n4, I, I1, I2, J, Ix, Iy, nc - Real (Kind=8) :: X_p(2), X1_p(2), X2_p(2), X - - - If (Model == "Hubbard_SU2") then - !Write(50,*) 'Model is ', Model - Allocate(Op_V(Latt%N,N_FL)) - do nf = 1,N_FL - do i = 1, Latt%N - Call Op_make(Op_V(i,nf),1) - enddo - enddo - Do nf = 1,N_FL - nc = 0 - Do i = 1,Latt%N - nc = nc + 1 - Op_V(nc,nf)%P(1) = I - Op_V(nc,nf)%O(1,1) = cmplx(1.d0 ,0.d0) - Op_V(nc,nf)%g = SQRT(CMPLX(-DTAU*ham_U/(DBLE(N_SUN)),0.D0)) - Op_V(nc,nf)%alpha = cmplx(-0.5d0,0.d0) - Op_V(nc,nf)%type = 2 - Call Op_set( Op_V(nc,nf) ) - ! The operator reads: - ! g*s*( c^{dagger} O c + alpha )) - ! with s the HS field. - Enddo - Enddo - Elseif (Model == "Hubbard_Mz") then - !Write(50,*) 'Model is ', Model - Allocate(Op_V(Latt%N,N_FL)) - do nf = 1,N_FL - do i = 1, Latt%N - Call Op_make(Op_V(i,nf),1) - enddo - enddo - Do nf = 1,N_FL - nc = 0 - X = 1.d0 - if (nf == 2) X = -1.d0 - Do i = 1,Latt%N - nc = nc + 1 - Op_V(nc,nf)%P(1) = I - Op_V(nc,nf)%O(1,1) = cmplx(1.d0 ,0.d0) - Op_V(nc,nf)%g = X*SQRT(CMPLX(DTAU*ham_U/2.d0 ,0.D0)) - Op_V(nc,nf)%alpha = cmplx(0.d0,0.d0) - Op_V(nc,nf)%type = 2 - Call Op_set( Op_V(nc,nf) ) - ! The operator reads: - ! g*s*( c^{dagger} O c - alpha )) - ! with s the HS field. - ! Write(6,*) nc,nf, Op_V(nc,nf)%g - Enddo - Enddo - Endif - end Subroutine Ham_V - -!=================================================================================== - Real (Kind=8) function S0(n,nt) - Implicit none - Integer, Intent(IN) :: n,nt - Integer :: i, nt1 - S0 = 1.d0 - - end function S0 - -!=================================================================================== - Subroutine Alloc_obs(Ltau) - - Implicit none - Integer, Intent(In) :: Ltau - Integer :: I - - Allocate ( Obs_scal(5) ) - Allocate ( Green_eq(Latt%N,1,1), SpinZ_eq(Latt%N,1,1), SpinXY_eq(Latt%N,1,1), & - & Den_eq(Latt%N,1,1) ) - Allocate ( Green_eq0(1), SpinZ_eq0(1), SpinXY_eq0(1), Den_eq0(1) ) - - - If (Ltau == 1) then - Allocate ( Green_tau(Latt%N,Ltrot+1,1,1), Den_tau(Latt%N,Ltrot+1,1,1) ) - endif - - end Subroutine Alloc_obs - -!=================================================================================== - - Subroutine Init_obs(Ltau) - - Implicit none - Integer, Intent(In) :: Ltau - - Integer :: I,n - - Nobs = 0 - Obs_scal = cmplx(0.d0,0.d0) - Green_eq = cmplx(0.d0,0.d0) - SpinZ_eq = cmplx(0.d0,0.d0) - SpinXY_eq = cmplx(0.d0,0.d0) - Den_eq = cmplx(0.d0,0.d0) - Green_eq0 = cmplx(0.d0,0.d0) - SpinZ_eq0 = cmplx(0.d0,0.d0) - SpinXY_eq0= cmplx(0.d0,0.d0) - Den_eq0 = cmplx(0.d0,0.d0) - - - If (Ltau == 1) then - NobsT = 0 - Phase_tau = cmplx(0.d0,0.d0) - Green_tau = cmplx(0.d0,0.d0) - Den_tau = cmplx(0.d0,0.d0) - endif - - end Subroutine Init_obs - -!======================================================================== - Subroutine Obser(GR,Phase,Ntau) - - Implicit none - - Complex (Kind=8), INTENT(IN) :: GR(Ndim,Ndim,N_FL) - Complex (Kind=8), Intent(IN) :: PHASE - Integer, INTENT(IN) :: Ntau - - !Local - Complex (Kind=8) :: GRC(Ndim,Ndim,N_FL), ZK - Complex (Kind=8) :: Zrho, Zkin, ZPot, Z, ZP,ZS - Integer :: I,J, no,no1, n, n1, imj, nf, I1, I2, J1, J2 - - Real (Kind=8) :: G(4,4), X, FI, FJ - - Nobs = Nobs + 1 - ZP = PHASE/cmplx(Real(Phase,kind=8),0.d0) - ZS = cmplx(Real(Phase,kind=8)/Abs(Real(Phase,kind=8)), 0.d0) - - - Do nf = 1,N_FL - Do I = 1,Ndim - Do J = 1,Ndim - ZK = cmplx(0.d0,0.d0) - If ( I == J ) ZK = cmplx(1.d0,0.d0) - GRC(I,J,nf) = ZK - GR(J,I,nf) - Enddo - Enddo - Enddo - ! GRC(i,j,nf) = < c^{dagger}_{j,nf } c_{j,nf } > - ! Compute scalar observables. - Zkin = cmplx(0.d0,0.d0) - Do nf = 1,N_FL - Do J = 1,Ndim - DO I = 1,Ndim - Zkin = Zkin + Op_T(1,nf)%O(i,j)*Grc(i,j,nf) - Enddo - ENddo - Enddo - Zkin = Zkin*cmplx( dble(N_SUN), 0.d0 ) - - Zrho = cmplx(0.d0,0.d0) - Do nf = 1,N_FL - Do I = 1,Ndim - Zrho = Zrho + Grc(i,i,nf) - enddo - enddo - Zrho = Zrho*cmplx( dble(N_SUN), 0.d0 ) - - ZPot = cmplx(0.d0,0.d0) - If ( Model == "Hubbard_SU2" ) then - Do I = 1,Ndim - ZPot = ZPot + Grc(i,i,1) * Grc(i,i,1) - Enddo - Zpot = Zpot*cmplx(ham_U,0.d0) - elseif ( Model == "Hubbard_Mz" ) then - Do I = 1,Ndim - ZPot = ZPot + Grc(i,i,1) * Grc(i,i,2) - Enddo - Zpot = Zpot*cmplx(ham_U,0.d0) - endif - - Obs_scal(1) = Obs_scal(1) + zrho * ZP*ZS - Obs_scal(2) = Obs_scal(2) + zkin * ZP*ZS - Obs_scal(3) = Obs_scal(3) + Zpot * ZP*ZS - Obs_scal(4) = Obs_scal(4) + (zkin + Zpot)*ZP*ZS - Obs_scal(5) = Obs_scal(5) + ZS - ! You will have to allocate more space if you want to include more scalar observables. - - ! Compute spin-spin, Green, and den-den correlation functions ! This is general N_SUN, and N_FL = 1 - If ( Model == "Hubbard_SU2" ) then - Z = cmplx(dble(N_SUN),0.d0) - Do I = 1,Latt%N - Do J = 1,Latt%N - imj = latt%imj(I,J) - GREEN_EQ (imj,1,1) = GREEN_EQ (imj,1,1) + Z * GRC(I,J,1) * ZP*ZS - SPINXY_Eq (imj,1,1) = SPINXY_Eq (imj,1,1) + Z * GRC(I,J,1) * GR(I,J,1) * ZP*ZS - SPINZ_Eq (imj,1,1) = SPINZ_Eq (imj,1,1) + Z * GRC(I,J,1) * GR(I,J,1) * ZP*ZS - DEN_Eq (imj,1,1) = DEN_Eq (imj,1,1) + ( & - & GRC(I,I,1) * GRC(J,J,1) *Z + & - & GRC(I,J,1) * GR(I,J,1) & - & ) * Z* ZP*ZS - ENDDO - Den_eq0(1) = Den_eq0(1) + Z * GRC(I,I,1) * ZP * ZS - ENDDO - elseif (Model == "Hubbard_Mz" ) Then - DO I = 1,Latt%N - DO J = 1, Latt%N - imj = latt%imj(I,J) - SPINZ_Eq (imj,1,1) = SPINZ_Eq (imj,1,1) + & - & ( GRC(I,J,1) * GR(I,J,1) + GRC(I,J,2) * GR(I,J,2) + & - & (GRC(I,I,2) - GRC(I,I,1))*(GRC(J,J,2) - GRC(J,J,1)) ) * ZP*ZS - ! c^d_(i,u) c_(i,d) c^d_(j,d) c_(j,u) + c^d_(i,d) c_(i,u) c^d_(j,u) c_(j,d) - SPINXY_Eq (imj,1,1) = SPINXY_Eq (imj,1,1) + & - & ( GRC(I,J,1) * GR(I,J,2) + GRC(I,J,2) * GR(I,J,1) ) * ZP*ZS - - DEN_Eq (imj,1,1) = DEN_Eq (imj,1,1) + & - & ( GRC(I,J,1) * GR(I,J,1) + GRC(I,J,2) * GR(I,J,2) + & - & (GRC(I,I,2) + GRC(I,I,1))*(GRC(J,J,2) + GRC(J,J,1)) ) * ZP*ZS - enddo - Den_eq0(1) = Den_eq0(1) + (GRC(I,I,2) + GRC(I,I,1)) * ZP*ZS - enddo - Endif - - - end Subroutine Obser -!========================================================== - Subroutine Pr_obs(LTAU) - - Implicit none -#include "machine" -#ifdef MPI - include 'mpif.h' -#endif - - - Integer, Intent(In) :: Ltau - - Character (len=64) :: File_pr - Complex (Kind=8) :: Phase_bin -#ifdef MPI - Integer :: Isize, Irank, Ierr - Integer :: STATUS(MPI_STATUS_SIZE) - CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) - CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) -#endif - -!!$#ifdef MPI -!!$ Write(6,*) Irank, 'In Pr_obs', LTAU -!!$#else -!!$ Write(6,*) 'In Pr_obs', LTAU -!!$#endif - - Phase_bin = Obs_scal(5)/cmplx(dble(Nobs),0.d0) - File_pr ="SpinZ_eq" - Call Print_bin(SpinZ_eq ,SpinZ_eq0, Latt, Nobs, Phase_bin, file_pr) - File_pr ="SpinXY_eq" - Call Print_bin(Spinxy_eq, Spinxy_eq0,Latt, Nobs, Phase_bin, file_pr) - File_pr ="Den_eq" - Call Print_bin(Den_eq, Den_eq0, Latt, Nobs, Phase_bin, file_pr) - File_pr ="Green_eq" - Call Print_bin(Green_eq , Green_eq0 ,Latt, Nobs, Phase_bin, file_pr) - - File_pr ="ener" - Call Print_scal(Obs_scal, Nobs, file_pr) - - If (Ltau == 1) then - Phase_tau = Phase_tau/cmplx(dble(NobsT),0.d0) - File_pr = "Green_tau" - Call Print_bin_tau(Green_tau,Latt,NobsT,Phase_tau, file_pr,dtau) - File_pr = "Den_tau" - Call Print_bin_tau(Den_tau,Latt,NobsT,Phase_tau, file_pr,dtau) - endif - -!!$#ifdef MPI -!!$ Write(6,*) Irank, 'out Pr_obs', LTAU -!!$#else -!!$ Write(6,*) 'out Pr_obs', LTAU -!!$#endif - end Subroutine Pr_obs -!========================================================== - - Subroutine OBSERT(NT, GT0,G0T,G00,GTT, PHASE) - Implicit none - - Integer , INTENT(IN) :: NT - Complex (Kind=8), INTENT(IN) :: GT0(Ndim,Ndim,N_FL),G0T(Ndim,Ndim,N_FL),G00(Ndim,Ndim,N_FL),GTT(Ndim,Ndim,N_FL) - Complex (Kind=8), INTENT(IN) :: Phase - - !Locals - Complex (Kind=8) :: Z, ZP, ZS - Integer :: IMJ, I, J - - ZP = PHASE/cmplx(Real(Phase,kind=8),0.d0) - ZS = cmplx(Real(Phase,kind=8)/Abs(Real(Phase,kind=8)), 0.d0) - If (NT == 0 ) then - Phase_tau = Phase_tau + ZS - NobsT = NobsT + 1 - endif - If ( N_FL == 1 ) then - Z = cmplx(dble(N_SUN),0.d0) - Do I = 1,Latt%N - Do J = 1,Latt%N - imj = latt%imj(I,J) - Green_tau(imj,nt+1,1,1) = green_tau(imj,nt+1,1,1) + Z * GT0(I,J,1) * ZP* ZS - Den_tau (imj,nt+1,1,1) = Den_tau (imj,nt+1,1,1) - Z * GT0(I,J,1)*G0T(J,I,1) * ZP* ZS - Enddo - Enddo - Endif - end Subroutine OBSERT - - - end Module Hamiltonian diff --git a/Prog_7/Hamiltonian_SPT.f90 b/Prog_7/Hamiltonian_SPT.f90 deleted file mode 100644 index e16b5adf5..000000000 --- a/Prog_7/Hamiltonian_SPT.f90 +++ /dev/null @@ -1,538 +0,0 @@ - !Model Hamiltonian for interaction-induced topological reduction - Module Hamiltonian - - Use Operator_mod - Use Lattices_v3 - Use MyMats - Use Random_Wrap - Use Files_mod - Use Matrix - - - Type (Operator), dimension(:,:), allocatable :: Op_V - Type (Operator), dimension(:,:), allocatable :: Op_T - Integer, allocatable :: nsigma(:,:) - Integer :: Ndim, N_FL, N_SUN, Ltrot - - - - ! What is below is private - - Type (Lattice), private :: Latt - Integer, parameter, private :: Norb=16 - Integer, allocatable, private :: List(:,:), Invlist(:,:) - Integer, private :: L1, L2 - real (Kind=8), private :: Ham_T, Ham_Vint, Ham_Lam - real (Kind=8), private :: Dtau, Beta - Character (len=64), private :: Model, Lattice_type - Complex (Kind=8), private :: Gamma_M(4,4,5), Sigma_M(2,2,0:3) - - - ! Observables - Integer, private :: Nobs - Complex (Kind=8), allocatable, private :: obs_scal(:) - Complex (Kind=8), allocatable, private :: Den_eq(:,:,:), Den_eq0(:) - - ! For time displaced - Integer, private :: NobsT - Complex (Kind=8), private :: Phase_tau - Complex (Kind=8), allocatable, private :: Green_tau(:,:,:,:), Den_tau(:,:,:,:) - - contains - - Subroutine Ham_Set - - Implicit none -#include "machine" -#ifdef MPI - include 'mpif.h' -#endif - - integer :: ierr - - NAMELIST /VAR_lattice/ L1, L2, Lattice_type, Model - - NAMELIST /VAR_SPT/ ham_T, Ham_Vint, Ham_Lam, Dtau, Beta - - -#ifdef MPI - Integer :: Isize, Irank - Integer :: STATUS(MPI_STATUS_SIZE) - CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) - CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) - If (Irank == 0 ) then -#endif - OPEN(UNIT=5,FILE='parameters',STATUS='old',ACTION='read',IOSTAT=ierr) - IF (ierr /= 0) THEN - WRITE(*,*) 'unable to open ',ierr - STOP - END IF - READ(5,NML=VAR_lattice) - CLOSE(5) -#ifdef MPI - endif - - CALL MPI_BCAST(L1 ,1 ,MPI_INTEGER, 0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(L2 ,1 ,MPI_INTEGER, 0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(Model ,64 ,MPI_CHARACTER, 0,MPI_COMM_WORLD,IERR) - CALL MPI_BCAST(Lattice_type,64 ,MPI_CHARACTER, 0,MPI_COMM_WORLD,IERR) -#endif - Call Ham_latt - - N_FL = 1 - N_SUN = 1 - -#ifdef MPI - If (Irank == 0 ) then -#endif - OPEN(UNIT=5,FILE='parameters',STATUS='old',ACTION='read',IOSTAT=ierr) - READ(5,NML=VAR_SPT) - CLOSE(5) -#ifdef MPI - endif - - CALL MPI_BCAST(ham_T ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(ham_Vint ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(ham_Lam ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(Dtau ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(Beta ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) -#endif - - Call Ham_hop - Ltrot = nint(beta/dtau) -#ifdef MPI - If (Irank == 0) then -#endif - Open (Unit = 50,file="info",status="unknown",position="append") - Write(50,*) '=====================================' - Write(50,*) 'Model is : ', Model - Write(50,*) 'Lattice is : ', Lattice_type - Write(50,*) 'Beta : ', Beta - Write(50,*) 'dtau,Ltrot : ', dtau,Ltrot - Write(50,*) 't : ', Ham_T - Write(50,*) 'V : ', Ham_Vint - Write(50,*) 'Lambda : ', Ham_Lam - close(50) -#ifdef MPI - endif -#endif - call Ham_V - end Subroutine Ham_Set -!============================================================================= - - Subroutine Ham_Latt - Implicit none - !Set the lattice - Integer :: no, I, nc - Real (Kind=8) :: a1_p(2), a2_p(2), L1_p(2), L2_p(2) - If ( Lattice_type =="Square" ) then - a1_p(1) = 1.0 ; a1_p(2) = 0.d0 - a2_p(1) = 0.0 ; a2_p(2) = 1.d0 - L1_p = dble(L1)*a1_p - L2_p = dble(L2)*a2_p - Call Make_Lattice( L1_p, L2_p, a1_p, a2_p, Latt ) - !Write(6,*) 'Lattice: ', Ndim - else - Write(6,*) "Lattice not yet implemented!" - Stop - endif - - Ndim = Latt%N*Norb - Allocate (List(Ndim,Norb), Invlist(Latt%N,Norb)) - nc = 0 - Do I = 1,Latt%N - Do no = 1,Norb - nc = nc + 1 - List(nc,1) = I - List(nc,2) = no - Invlist(I,no) = nc - ! no = 1..4 Xi_1 - ! no = 5..8 Xi_2 - ! no = 9..12 Xi_3 - ! no = 13..16 Xi_4 - Enddo - Enddo - - end Subroutine Ham_Latt - -!=================================================================================== - Subroutine Ham_hop - Implicit none - - ! Setup the hopping - ! Per flavor, the hopping is given by: - ! e^{-dtau H_t} = Prod_{n=1}^{Ncheck} e^{-dtau_n H_{n,t}} - - Integer :: I, I1, I2,I3,no, no1, n, Ncheck, nc , nth - Real (Kind=8) :: X - Complex (Kind=8) :: Z - - - ! Setup Gamma matrices - Gamma_M = cmplx(0.d0,0.d0) - Sigma_M = cmplx(0.d0,0.d0) - Sigma_M(1,1,0) = cmplx( 1.d0, 0.d0) - Sigma_M(2,2,0) = cmplx( 1.d0, 0.d0) - Sigma_M(1,2,1) = cmplx( 1.d0, 0.d0) - Sigma_M(2,1,1) = cmplx( 1.d0, 0.d0) - Sigma_M(1,2,2) = cmplx( 0.d0,-1.d0) - Sigma_M(2,1,2) = cmplx( 0.d0, 1.d0) - Sigma_M(1,1,3) = cmplx( 1.d0, 0.d0) - Sigma_M(2,2,3) = cmplx(-1.d0, 0.d0) - Do no = 1,2 - Do no1 = 1,2 - Gamma_M(no+2,no1 ,1) = Sigma_M(no,no1,0) - Gamma_M(no ,no1+2,1) = Sigma_M(no,no1,0) - Gamma_M(no+2,no1 ,2) = cmplx( 0.d0,-1.d0)*Sigma_M(no,no1,0) - Gamma_M(no ,no1+2,2) = cmplx( 0.d0, 1.d0)*Sigma_M(no,no1,0) - Gamma_M(no ,no1 ,3) = cmplx( 1.d0, 0.d0)*Sigma_M(no,no1,1) - Gamma_M(no+2,no1+2,3) = cmplx(-1.d0, 0.d0)*Sigma_M(no,no1,1) - Gamma_M(no ,no1 ,4) = cmplx( 1.d0, 0.d0)*Sigma_M(no,no1,2) - Gamma_M(no+2,no1+2,4) = cmplx(-1.d0, 0.d0)*Sigma_M(no,no1,2) - Gamma_M(no ,no1 ,5) = cmplx( 1.d0, 0.d0)*Sigma_M(no,no1,3) - Gamma_M(no+2,no1+2,5) = cmplx(-1.d0, 0.d0)*Sigma_M(no,no1,3) - Enddo - Enddo - - Ncheck = 1 - allocate(Op_T(Ncheck,N_FL)) - do n = 1,N_FL - Do nc = 1,NCheck - Call Op_make(Op_T(nc,n),Ndim) - DO I = 1, Ndim - Op_T(nc,n)%P(I) = I - enddo - Do I = 1,Latt%N - do nth = 0,3 - do no = 1,4 - do no1 = 1,4 - Z = cmplx(1.d0*Ham_T,0.d0)*Gamma_M(no,no1,3) - Op_T(nc,n)%O( invlist(I ,no + 4*nth), invlist(I ,no1 + 4*nth ) ) = Z - enddo - enddo - I1 = Latt%nnlist(I,1,0) - do no = 1,4 - do no1 = 1,4 - Z = (cmplx(0.d0,Ham_T)*Gamma_M(no,no1,1) + cmplx(Ham_T,0.d0)*Gamma_M(no,no1,3))/cmplx(2.d0,0.d0) - Op_T(nc,n)%O( invlist(I ,no + 4*nth), invlist(I1,no1 + 4*nth ) ) = Z - Op_T(nc,n)%O( invlist(I1,no1 + 4*nth), invlist(I ,no + 4*nth ) ) = conjg(Z) - enddo - enddo - I2 = Latt%nnlist(I,0,1) - do no = 1,4 - do no1 = 1,4 - Z = (cmplx(0.d0,Ham_Lam)*Gamma_M(no,no1,2) + cmplx(Ham_T,0.d0)*Gamma_M(no,no1,3))/cmplx(2.d0,0.d0) - Op_T(nc,n)%O( invlist(I ,no + 4*nth), invlist(I2,no1 + 4*nth ) ) = Z - Op_T(nc,n)%O( invlist(I2,no1 + 4*nth), invlist(I ,no + 4*nth ) ) = conjg(Z) - enddo - enddo - enddo - enddo - Op_T(nc,n)%g=cmplx(-Dtau,0.d0) - Call Op_set(Op_T(nc,n)) - ! Just for tests - Do I = 1, Ndim - Write(6,*) Op_T(nc,n)%E(i) - enddo - enddo - enddo - - - end Subroutine Ham_hop -!=================================================================================== - Subroutine Ham_V - - Implicit none - - Integer :: nf, nth, n, n1, n2, n3, n4, I, I1, I2, J, Ix, Iy, nc, no,no1, ns, npm - Integer :: nxy - Real (Kind=8) :: X_p(2), X1_p(2), X2_p(2), X, XJ, Xpm - - Complex (Kind=8) :: Ps(4,4,2), Ps_G5(4,4,2), Tmp(4,4), Z - Complex (Kind=8) :: Sx(16,16,2,2), Sy(16,16,2,2) - - - Ps = cmplx(0.d0,0.d0) - Call mmult (Tmp,Gamma_M(:,:,3), Gamma_M(:,:,4) ) - do ns = 1,2 - if (ns == 1) X = 1.d0/2d0 - if (ns == 2) X = -1.d0/2.d0 - Do I = 1,4 - Do J = 1,4 - Z = cmplx(0.d0,0.d0) - if ( I == J ) Z = cmplx(1.d0/2.d0,0.d0) - Ps(I,J,ns) = Z + cmplx(0.d0,X) * tmp(I,J) - Enddo - Enddo - Enddo - - Do ns = 1,2 - Call mmult ( Ps_G5(:,:,ns), Ps(:,:,ns), Gamma_M(:,:,5) ) - enddo - - Sx = cmplx(0.d0,0.d0) - Sy = cmplx(0.d0,0.d0) - Do ns = 1,2 - Do npm = 1,2 - if (npm == 1) Xpm = 1.0 - if (npm == 2) Xpm = -1.0 - Do no = 1,4 - do no1 = 1,4 - Sx(no , no1 + 4 ,ns,npm) = cmplx(1.d0, 0.d0)*Ps_G5(no,no1,ns) - Sx(no +4 , no1 ,ns,npm) = cmplx(1.d0, 0.d0)*Ps_G5(no,no1,ns) - Sx(no +8 , no1 + 12,ns,npm) = cmplx(xpm, 0.d0)*Ps_G5(no,no1,ns) - Sx(no+12 , no1 + 8 ,ns,npm) = cmplx(xpm, 0.d0)*Ps_G5(no,no1,ns) - - Sy(no , no1 + 4 ,ns,npm) = cmplx(0.d0, -1.d0 )*Ps_G5(no,no1,ns) - Sy(no +4 , no1 ,ns,npm) = cmplx(0.d0, 1.d0 )*Ps_G5(no,no1,ns) - Sy(no +8 , no1 + 12,ns,npm) = cmplx(0.d0, 1.d0*xpm)*Ps_G5(no,no1,ns) - Sy(no+12 , no1 + 8 ,ns,npm) = cmplx(0.d0, -1.d0*xpm)*Ps_G5(no,no1,ns) - enddo - enddo - enddo - enddo - - - ! Number of opertors 8 per unit cell - Allocate( Op_V(8*Latt%N,N_FL) ) - do nf = 1,N_FL - do i = 1, 8*Latt%N - Call Op_make(Op_V(i,nf),Norb) - enddo - enddo - nc = 0 - Do nf = 1,N_FL - do nxy = 1,2 - do ns = 1,2 - do npm = 1,2 - Xpm = 1.d0 - if (npm == 2) Xpm = -1.d0 - Do i = 1,Latt%N - nc = nc + 1 - Do no = 1,Norb - Op_V(nc,nf)%P(no) = Invlist(I,no) - enddo - Do no = 1,Norb - Do no1 = 1,Norb - If (nxy == 1) Op_V(nc,nf)%O(no,no1) = Sx(no,no1,ns,npm) - If (nxy == 2) Op_V(nc,nf)%O(no,no1) = Sy(no,no1,ns,npm) - Enddo - Enddo - Op_V(nc,nf)%g = SQRT(CMPLX(-Xpm*DTAU*Ham_Vint/8.d0,0.D0)) - Op_V(nc,nf)%alpha = cmplx(0.d0,0.d0) - Op_V(nc,nf)%type = 2 - Call Op_set( Op_V(nc,nf) ) - ! The operator reads: - ! g*s*( c^{dagger} O c - alpha )) - ! with s the HS field. - Enddo - Enddo - Enddo - Enddo - Enddo - - end Subroutine Ham_V - -!=================================================================================== - Real (Kind=8) function S0(n,nt) - Implicit none - Integer, Intent(IN) :: n,nt - Integer :: i, nt1 - S0 = 1.d0 - end function S0 - -!=================================================================================== - Subroutine Alloc_obs(Ltau) - - Implicit none - Integer, Intent(In) :: Ltau - Integer :: I - Allocate ( Obs_scal(5) ) - Allocate ( Den_eq(Latt%N,Norb,Norb), Den_eq0(Norb) ) - If (Ltau == 1) then - Allocate ( Green_tau(Latt%N,Ltrot+1,Norb,Norb), Den_tau(Latt%N,Ltrot+1,Norb,Norb) ) - endif - - end Subroutine Alloc_obs - -!=================================================================================== - - Subroutine Init_obs(Ltau) - - Implicit none - Integer, Intent(In) :: Ltau - - Integer :: I,n - - Nobs = 0 - Obs_scal = cmplx(0.d0,0.d0) - Den_eq = cmplx(0.d0,0.d0) - Den_eq0 = cmplx(0.d0,0.d0) - - If (Ltau == 1) then - NobsT = 0 - Phase_tau = cmplx(0.d0,0.d0) - Green_tau = cmplx(0.d0,0.d0) - Den_tau = cmplx(0.d0,0.d0) - endif - - end Subroutine Init_obs - -!======================================================================== - Subroutine Obser(GR,Phase,Ntau) - - Implicit none - - Complex (Kind=8), INTENT(IN) :: GR(Ndim,Ndim,N_FL) - Complex (Kind=8), Intent(IN) :: PHASE - Integer, INTENT(IN) :: Ntau - - !Local - Complex (Kind=8) :: GRC(Ndim,Ndim,N_FL), ZK - Complex (Kind=8) :: Zrho, Zkin, ZPot, Z, ZP,ZS - Integer :: I,J, no,no1, n, n1, imj, nf, I1, I2, J1, J2 - - Real (Kind=8) :: G(4,4), X, FI, FJ - - Nobs = Nobs + 1 - ZP = PHASE/cmplx(Real(Phase,kind=8),0.d0) - ZS = cmplx(Real(Phase,kind=8)/Abs(Real(Phase,kind=8)), 0.d0) - - - Do nf = 1,N_FL - Do I = 1,Ndim - Do J = 1,Ndim - ZK = cmplx(0.d0,0.d0) - If ( I == J ) ZK = cmplx(1.d0,0.d0) - GRC(I,J,nf) = ZK - GR(J,I,nf) - Enddo - Enddo - Enddo - ! GRC(i,j,nf) = < c^{dagger}_{j,nf } c_{j,nf } > - ! Compute scalar observables. - - Zkin = cmplx(0.d0,0.d0) - Do nf = 1,N_FL - Do J = 1,Op_T(1,nf)%N - J1 = Op_T(1,nf)%P(J) - DO I = 1,Op_T(1,nf)%N - I1 = Op_T(1,nf)%P(I) - Zkin = Zkin + Op_T(1,nf)%O(i,j)*Grc(i1,j1,nf) - Enddo - ENddo - Enddo - Zkin = Zkin*cmplx( dble(N_SUN), 0.d0 ) - - Zrho = cmplx(0.d0,0.d0) - Do nf = 1,N_FL - Do I = 1,Ndim - Zrho = Zrho + Grc(i,i,nf) - enddo - enddo - Zrho = Zrho*cmplx( dble(N_SUN), 0.d0 ) - - ZPot = cmplx(0.d0,0.d0) - - Obs_scal(1) = Obs_scal(1) + zrho * ZP*ZS - Obs_scal(2) = Obs_scal(2) + zkin * ZP*ZS - Obs_scal(3) = Obs_scal(3) + Zpot * ZP*ZS - Obs_scal(4) = Obs_scal(4) + (zkin + Zpot)*ZP*ZS - Obs_scal(5) = Obs_scal(5) + ZS - ! You will have to allocate more space if you want to include more scalar observables. - DO I1 = 1,Ndim - I = List(I1,1) - no = List(I1,2) - DO J1 = 1, Ndim - J = List(J1,1) - no1 = list(J1,2) - imj = latt%imj(I,J) - - DEN_Eq (imj,no,no1) = DEN_Eq (imj,no,no1) + & - & ( GRC(I1,J1,1) * GR (I1,J1,1) + & - & GRC(I1,I1,1) * GRC(J1,J1,1) ) * ZP*ZS - - enddo - Den_eq0(no) = Den_eq0(no) + GRC(I1,I1,1)*ZP*ZS - enddo - - end Subroutine Obser -!========================================================== - - Subroutine Pr_obs(LTAU) - - Use Print_bin_mod - Implicit none -#include "machine" -#ifdef MPI - include 'mpif.h' -#endif - - - Integer, Intent(In) :: Ltau - - Character (len=64) :: File_pr - Complex (Kind=8) :: Phase_bin -#ifdef MPI - Integer :: Isize, Irank, Ierr - Integer :: STATUS(MPI_STATUS_SIZE) - CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) - CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) -#endif -!!$#ifdef MPI -!!$ Write(6,*) Irank, 'In Pr_obs', LTAU -!!$#else -!!$ Write(6,*) 'In Pr_obs', LTAU -!!$#endif - - Phase_bin = Obs_scal(5)/cmplx(dble(Nobs),0.d0) - File_pr ="Den_eq" - Call Print_bin(Den_eq, Den_eq0, Latt, Nobs, Phase_bin, file_pr) - - File_pr ="ener" - Call Print_scal(Obs_scal, Nobs, file_pr) - If (Ltau == 1) then - Phase_tau = Phase_tau/cmplx(dble(NobsT),0.d0) - File_pr = "Green_tau" - Call Print_bin_tau(Green_tau,Latt,NobsT,Phase_tau, file_pr,dtau) - File_pr = "Den_tau" - Call Print_bin_tau(Den_tau,Latt,NobsT,Phase_tau, file_pr,dtau) - endif -!!$#ifdef MPI -!!$ Write(6,*) Irank, 'out Pr_obs', LTAU -!!$#else -!!$ Write(6,*) 'out Pr_obs', LTAU -!!$#endif - end Subroutine Pr_obs -!========================================================== - - Subroutine OBSERT(NT, GT0,G0T,G00,GTT, PHASE) - Implicit none - - Integer , INTENT(IN) :: NT - Complex (Kind=8), INTENT(IN) :: GT0(Ndim,Ndim,N_FL),G0T(Ndim,Ndim,N_FL),G00(Ndim,Ndim,N_FL),GTT(Ndim,Ndim,N_FL) - Complex (Kind=8), INTENT(IN) :: Phase - - !Locals - Complex (Kind=8) :: Z, ZP, ZS - Integer :: IMJ, I, J - - ZP = PHASE/cmplx(Real(Phase,kind=8),0.d0) - ZS = cmplx(Real(Phase,kind=8)/Abs(Real(Phase,kind=8)), 0.d0) - If (NT == 0 ) then - Phase_tau = Phase_tau + ZS - NobsT = NobsT + 1 - endif - If ( N_FL == 1 ) then - Z = cmplx(dble(N_SUN),0.d0) - Do I = 1,Latt%N - Do J = 1,Latt%N - imj = latt%imj(I,J) - Green_tau(imj,nt+1,1,1) = green_tau(imj,nt+1,1,1) + Z * GT0(I,J,1) * ZP* ZS - Den_tau (imj,nt+1,1,1) = Den_tau (imj,nt+1,1,1) - Z * GT0(I,J,1)*G0T(J,I,1) * ZP* ZS - Enddo - Enddo - Endif - end Subroutine OBSERT - - - end Module Hamiltonian diff --git a/Prog_7/Hop_mod.f90 b/Prog_7/Hop_mod.f90 deleted file mode 100644 index 0d6028fb4..000000000 --- a/Prog_7/Hop_mod.f90 +++ /dev/null @@ -1,217 +0,0 @@ -! This is for the Kondo project with tarun. - Module Hop_mod - - - Use Hamiltonian - Use Random_wrap - Use MyMats - - ! Private variables - Complex (Kind=8), allocatable, private :: Exp_T(:,:,:,:), Exp_T_M1(:,:,:,:) - Complex (Kind=8), allocatable, private :: U_HLP(:,:), U_HLP1(:,:), V_HLP(:,:), V_HLP1(:,:) - Integer, private, save :: Ncheck, Ndim_hop - Real (Kind=8), private, save :: Zero - - Contains - - subroutine Hop_mod_init - - Implicit none - - Integer :: nc, nf - Complex (Kind=8) :: g - - Ncheck = size(Op_T,1) - If ( size(Op_T,2) /= N_FL ) then - Write(6,*) 'Error in the number of flavors.' - Stop - 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(6,*) 'Different size of Hoppings not implemented ' - Stop - 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 ( V_Hlp(Ndim_hop,Ndim) ) - Allocate ( V_Hlp1(Ndim_hop,Ndim) ) - Allocate ( U_Hlp (Ndim, Ndim_hop) ) - Allocate ( U_Hlp1(Ndim, Ndim_hop) ) - - Exp_T = cmplx(0.d0,0.d0) - Exp_T_M1 = cmplx(0.d0,0.d0) - do nf = 1,N_FL - 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)) - enddo - enddo - - Zero = 1.E-12 - - end subroutine Hop_mod_init - -!============================================================================ - Subroutine Hop_mod_mmthr(In, Out,nf) - - - ! In: IN - ! Out: OUT = e^{ -dtau T }.IN - Implicit none - - Complex (Kind=8), intent(IN) :: IN(Ndim,Ndim) - Complex (Kind=8), intent(INOUT) :: OUT(Ndim,Ndim) - Integer :: nf - - !Local - Integer :: nc, I, n - - Out = In - do nc = Ncheck,1,-1 - If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then - do I = 1,Ndim - do n = 1,Ndim_hop - V_Hlp(n,I) = Out(Op_T(nc,nf)%P(n),I) - enddo - enddo - Call mmult(V_HLP1,Exp_T(:,:,nc,nf),V_Hlp) - DO I = 1,Ndim - do n = 1,Ndim_hop - OUT(OP_T(nc,nf)%P(n),I) = V_hlp1(n,I) - Enddo - Enddo - Endif - Enddo - - end Subroutine Hop_mod_mmthr - -!============================================================================ - Subroutine Hop_mod_mmthr_m1(In, Out,nf) - - - ! In: IN - ! Out: OUT = e^{ dtau T }.IN - Implicit none - - Complex (Kind=8), intent(IN) :: IN(Ndim,Ndim) - Complex (Kind=8), intent(INOUT) :: OUT(Ndim,Ndim) - Integer :: nf - - !Local - Integer :: nc, I, n - - - Out = In - do nc = 1,Ncheck - If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then - do I = 1,Ndim - do n = 1,Ndim_hop - V_Hlp(n,I) = Out(Op_T(nc,nf)%P(n),I) - enddo - enddo - Call mmult(V_HLP1,Exp_T_m1(:,:,nc,nf),V_Hlp) - DO I = 1,Ndim - do n = 1,Ndim_hop - OUT(OP_T(nc,nf)%P(n),I) = V_hlp1(n,I) - Enddo - Enddo - Endif - Enddo - - end Subroutine Hop_mod_mmthr_m1 - -!============================================================================ - Subroutine Hop_mod_mmthl (In, Out,nf) - - - ! In: IN - ! Out: OUT = IN * e^{ -dtau T } - Implicit none - - Complex (Kind=8), intent(IN) :: IN(Ndim,Ndim) - Complex (Kind=8), intent(INOUT) :: OUT(Ndim,Ndim) - Integer :: nf - - !Local - Integer :: nc, I, n - - Out = In - do nc = 1, Ncheck - If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then - do n = 1,Ndim_hop - do I = 1,Ndim - U_Hlp(I,n) = Out(I,Op_T(nc,nf)%P(n)) - enddo - enddo - Call mmult(U_Hlp1,U_Hlp,Exp_T(:,:,nc,nf)) - do n = 1,Ndim_hop - DO I = 1,Ndim - OUT(I,OP_T(nc,nf)%P(n)) = U_hlp1(I,n) - Enddo - Enddo - Endif - Enddo - - end Subroutine Hop_mod_mmthl -!============================================================================ - Subroutine Hop_mod_mmthl_m1 (In, Out,nf) - - - ! In: IN - ! Out: OUT = IN * e^{ dtau T } - Implicit none - - Complex (Kind=8), intent(IN) :: IN(Ndim,Ndim) - Complex (Kind=8), intent(INOUT) :: OUT(Ndim,Ndim) - Integer :: nf - - !Local - Integer :: nc, I, n - - Out = In - do nc = Ncheck,1,-1 - If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then - do n = 1,Ndim_hop - do I = 1,Ndim - U_Hlp(I,n) = Out(I,Op_T(nc,nf)%P(n)) - enddo - enddo - Call mmult(U_Hlp1,U_Hlp,Exp_T_M1(:,:,nc,nf)) - do n = 1,Ndim_hop - DO I = 1,Ndim - OUT(I,OP_T(nc,nf)%P(n)) = U_hlp1(I,n) - Enddo - Enddo - Endif - Enddo - - end Subroutine Hop_mod_mmthl_m1 - -!============================================================================ -!!$ Subroutine Hop_mod_test -!!$ -!!$ Implicit none -!!$ -!!$ Complex (Kind=8) :: IN(Ndim,Ndim),Out(Ndim,Ndim) -!!$ Complex (Kind=8) :: Test(Ndim,Ndim) -!!$ -!!$ Integer :: I,J -!!$ -!!$ DO I = 1,Ndim -!!$ DO J = 1,Ndim -!!$ IN(J,I) = cmplx(Ranf(),Ranf()) -!!$ ENDDO -!!$ ENDDO -!!$ -!!$ !Write(6,*) IN -!!$ end Subroutine Hop_mod_test - - end Module Hop_mod diff --git a/Prog_7/Makefile b/Prog_7/Makefile deleted file mode 100644 index 5db5d6c9a..000000000 --- a/Prog_7/Makefile +++ /dev/null @@ -1,22 +0,0 @@ -FC= $(mpif90) -FC= $(f90) -FLAGS= $(FL) -LF = $(Lflags) -LIBS= $(Libs)/Modules/modules_90.a \ - $(Libs)/MyEis/libeis.a \ - $(Libs)/MyNag/libnag.a \ - $(Libs)/MyLin/liblin.a \ - $(LIB_BLAS_LAPACK) - -Hub: - cp $(Libs)/Modules/*.mod . ;\ - (make -f Compile_Hub FC="$(FC)" FLAGS="$(FLAGS)" LIBS="$(LIBS)" ) - -SPT: - cp $(Libs)/Modules/*.mod . ;\ - (make -f Compile_SPT FC="$(FC)" FLAGS="$(FLAGS)" LIBS="$(LIBS)" LF="$(LF)" ) - -clean: - (make -f Compile_Hub clean );\ - (make -f Compile_SPT clean );\ - rm *.mod *~ \#* diff --git a/Prog_7/Operator.f90 b/Prog_7/Operator.f90 deleted file mode 100644 index 35256dcd1..000000000 --- a/Prog_7/Operator.f90 +++ /dev/null @@ -1,420 +0,0 @@ -Module Operator_mod - - Use MyMats - - Implicit none - - Real (Kind=8) :: Phi(-2:2,2), Gaml(-2:2,2) - Integer :: NFLIPL(-2:2,3) - - - ! What information should the operator contain - Type Operator - Integer :: N - complex (kind=8), pointer :: O(:,:), U (:,:) - Real (kind=8), pointer :: E(:) - Integer, pointer :: P(:) - complex (kind=8) :: g - complex (kind=8) :: alpha - Integer :: Type - ! P is an N X Ndim matrix such that P.T*O*P* = A - ! P has only one non-zero entry per column which is specified by P - ! All in all. g * Phi(s,type) * ( c^{dagger} A c + alpha ) - ! The variable Type allows you to define the type of HS. - end type Operator - - -Contains - - Subroutine Op_SetHS - Implicit none - Integer :: n - Phi = 0.d0 - do n = -2,2 - Phi(n,1) = real(n,kind=8) - enddo - Phi(-2,2) = - SQRT(2.D0 * ( 3.D0 + SQRT(6.D0) ) ) - Phi(-1,2) = - SQRT(2.D0 * ( 3.D0 - SQRT(6.D0) ) ) - Phi( 1,2) = SQRT(2.D0 * ( 3.D0 - SQRT(6.D0) ) ) - Phi( 2,2) = SQRT(2.D0 * ( 3.D0 + SQRT(6.D0) ) ) - - Do n = -2,2 - gaml(n,1) = 1.d0 - Enddo - GAML(-2,2) = 1.D0 - SQRT(6.D0)/3.D0 - GAML( 2,2) = 1.D0 - SQRT(6.D0)/3.D0 - GAML(-1,2) = 1.D0 + SQRT(6.D0)/3.D0 - GAML( 1,2) = 1.D0 + SQRT(6.D0)/3.D0 - - NFLIPL(-2,1) = -1 - NFLIPL(-2,2) = 1 - NFLIPL(-2,3) = 2 - - NFLIPL(-1,1) = 1 - NFLIPL(-1,2) = 2 - NFLIPL(-1,3) = -2 - - NFLIPL( 1,1) = 2 - NFLIPL( 1,2) = -2 - NFLIPL( 1,3) = -1 - - NFLIPL( 2,1) = -2 - NFLIPL( 2,2) = -1 - NFLIPL( 2,3) = 1 - - end Subroutine Op_SetHS - - Subroutine Op_phase(Phase,OP_V,Nsigma,N_SUN) ! This also goes in Operator (Input is nsigma, Op_V). - Implicit none - - Complex (Kind=8), Intent(Inout) :: Phase - Integer, Intent(IN) :: N_SUN - Integer, dimension(:,:), Intent(In) :: Nsigma - Type (Operator), dimension(:,:), Intent(In) :: Op_V - - Integer :: n, nf, nt - - do nf = 1,Size(Op_V,2) - do n = 1,size(Op_V,1) - do nt = 1,size(nsigma,2) - Phase = Phase*exp( Op_V(n,nf)%g * Op_V(n,nf)%alpha * Phi(nsigma(n,nt),Op_V(n,nf)%type) ) - enddo - enddo - enddo - Phase = Phase**dble(N_SUN) - - end Subroutine Op_phase - - - subroutine Op_make(Op,N) - Implicit none - Type (Operator), intent(INOUT) :: Op - Integer, Intent(IN) :: N - Allocate (Op%O(N,N), Op%U(N,N), Op%E(N), Op%P(N)) - Op%O = cmplx(0.d0,0.d0) - Op%U = cmplx(0.d0,0.d0) - Op%E = 0.d0 - Op%P = 0 - Op%N = N - Op%g = cmplx(0.d0,0.d0) - end subroutine Op_make - - subroutine Op_clear(Op,N) - Implicit none - Type (Operator), intent(INOUT) :: Op - Integer, Intent(IN) :: N - Deallocate (Op%O, Op%U, Op%E, Op%P) - end subroutine Op_clear - - subroutine Op_set(Op) - Implicit none - Type (Operator), intent(INOUT) :: Op - If (Op%N > 1) then - !Write(6,*) 'Calling diag', Op%O(1,2), Size(Op%O,1), Size(Op%U,1), Size(Op%E,1) - Call Diag(Op%O,Op%U,Op%E) - !Write(6,*) 'Calling diag 1' - else - Op%E(1) = Op%O(1,1) - Op%U(1,1) = cmplx(1.d0,0.d0) - endif - end subroutine Op_set - - - subroutine Op_exp(g,Op,Mat) - Implicit none - Type (Operator), Intent(IN) :: Op - Complex (Kind=8), Dimension(:,:), INTENT(OUT) :: Mat - Complex (Kind=8), INTENT(IN) :: g - Complex (Kind=8) :: Z, Z1 - - Integer :: n, i,j - - Mat = cmplx(0.d0,0.d0) - Do n = 1,Op%N - Z = exp(g*cmplx(Op%E(n),0.d0)) - do J = 1,Op%N - Z1 = Z*conjg(Op%U(J,n)) - Do I = 1,Op%N - Mat(I,J) = Mat(I,J) + Op%U(I,n)*Z1 - enddo - enddo - enddo - end subroutine Op_exp - - subroutine Op_mmultL(Mat,Op,spin,Ndim) - Implicit none - Integer :: Ndim - Type (Operator) , INTENT(IN ) :: Op - Complex (Kind=8), INTENT(INOUT) :: Mat (Ndim,Ndim) - Real (Kind=8), INTENT(IN ) :: spin - - - ! Local - Complex (Kind=8) :: VH(Ndim,Op%N), Z, Z1 - Integer :: n, i, m, m1 - - - ! In Mat - ! Out Mat = Mat*exp(spin*Op) - - VH = cmplx(0.d0,0.d0) - do n = 1,Op%N - Z = exp(Op%g*cmplx(Op%E(n)*spin,0.d0)) - Do m = 1,Op%N - Z1 = Op%U(m,n)* Z - DO I = 1,Ndim - VH(I,n) = VH(I,n) + Mat(I,Op%P(m)) * Z1 - Enddo - enddo - Enddo - Do n = 1,Op%N - Do I = 1,Ndim - Mat(I,Op%P(n)) = VH(I,n) - Enddo - Enddo - - - VH = cmplx(0.d0,0.d0) - do n = 1,Op%N - Do m = 1,Op%N - Z1 = conjg(Op%U(n,m)) - DO I = 1,Ndim - VH(I,n) = VH(I,n) + Mat(I,Op%P(m)) * Z1 - Enddo - enddo - Enddo - Do n = 1,Op%N - Do I = 1,Ndim - Mat(I,Op%P(n)) = VH(I,n) - Enddo - Enddo - - - - end subroutine Op_mmultL - - subroutine Op_mmultR(Mat,Op,spin,Ndim) - Implicit none - Integer :: Ndim - Type (Operator) , INTENT(IN ) :: Op - Complex (Kind=8), INTENT(INOUT) :: Mat (Ndim,Ndim) - Real (Kind=8), INTENT(IN ) :: spin - - - ! Local - Complex (Kind=8) :: VH(Ndim,Op%N), Z, Z1 - Integer :: n, i, m, m1 - - ! In Mat - ! Out Mat = exp(spin*Op)*Mat - VH = cmplx(0.d0,0.d0) - do n = 1,Op%N - Z1 = exp(Op%g*cmplx(Op%E(n)*spin,0.d0)) - Do m = 1,Op%N - Z = conjg(Op%U(m,n))* Z1 - DO I = 1,Ndim - VH(I,n) = VH(I,n) + Z* Mat(Op%P(m),I) - Enddo - enddo - Enddo - Do n = 1,Op%N - Do I = 1,Ndim - Mat(Op%P(n),I) = VH(I,n) - Enddo - Enddo - VH = cmplx(0.d0,0.d0) - do n = 1,Op%N - Do m = 1,Op%N - Z = Op%U(n,m) - DO I = 1,Ndim - VH(I,n) = VH(I,n) + Z* Mat(Op%P(m),I) - Enddo - enddo - Enddo - Do n = 1,Op%N - Do I = 1,Ndim - Mat(Op%P(n),I) = VH(I,n) - Enddo - Enddo - - - end subroutine Op_mmultR - - Subroutine Op_Wrapup(Mat,Op,spin,Ndim,N_Type) - - Implicit none - - Integer :: Ndim - Type (Operator) , INTENT(IN ) :: Op - Complex (Kind=8), INTENT(INOUT) :: Mat (Ndim,Ndim) - Real (Kind=8), INTENT(IN ) :: spin - Integer, INTENT(IN) :: N_Type - - ! Local - Complex (Kind=8) :: VH(Ndim,Op%N), Z, Z1 - Integer :: n, i, m, m1 - - - - - !!!!! N_Type ==1 - ! exp(Op%g*spin*Op%E)*(Op%U^{dagger})*Mat*Op%U*exp(-Op%g*spin*Op%E) - ! - !!!!! - !!!!! N_Type == 2 - ! Op%U * Mat * (Op%U^{dagger}) - !!!!! - If (N_type == 1) then - VH = cmplx(0.d0,0.d0) - do n = 1,Op%N - Z = exp(-Op%g*cmplx(Op%E(n)*spin,0.d0)) - Do m = 1,Op%N - Z1 = Op%U(m,n) * Z - DO I = 1,Ndim - VH(I,n) = VH(I,n) + Mat(I,Op%P(m)) * Z1 - Enddo - enddo - Enddo - Do n = 1,Op%N - Do I = 1,Ndim - Mat(I,Op%P(n)) = VH(I,n) - Enddo - Enddo - - VH = cmplx(0.d0,0.d0) - do n = 1,Op%N - Z = exp(Op%g*cmplx(Op%E(n)*spin,0.d0)) - Do m = 1,Op%N - Z1 = Z * conjg(Op%U(m,n)) - DO I = 1,Ndim - VH(I,n) = VH(I,n) + Z1* Mat(Op%P(m),I) - Enddo - enddo - enddo - Do n = 1,Op%N - Do I = 1,Ndim - Mat(Op%P(n),I) = VH(I,n) - Enddo - Enddo - elseif (N_Type == 2) then - VH = cmplx(0.d0,0.d0) - do n = 1,Op%N - Do m = 1,Op%N - Z1 = conjg(Op%U(n,m)) - DO I = 1,Ndim - VH(I,n) = VH(I,n) + Mat(I,Op%P(m)) * Z1 - Enddo - enddo - Enddo - Do n = 1,Op%N - Do I = 1,Ndim - Mat(I,Op%P(n)) = VH(I,n) - Enddo - Enddo - - VH = cmplx(0.d0,0.d0) - do n = 1,Op%N - Do m = 1,Op%N - Z1 = Op%U(n,m) - DO I = 1,Ndim - VH(I,n) = VH(I,n) + Z1* Mat(Op%P(m),I) - Enddo - enddo - enddo - Do n = 1,Op%N - Do I = 1,Ndim - Mat(Op%P(n),I) = VH(I,n) - Enddo - Enddo - endif - end Subroutine Op_Wrapup - - Subroutine Op_Wrapdo(Mat,Op,spin,Ndim,N_Type) - - Implicit none - - Integer :: Ndim - Type (Operator) , INTENT(IN ) :: Op - Complex (Kind=8), INTENT(INOUT) :: Mat (Ndim,Ndim) - Real (Kind=8), INTENT(IN ) :: spin - Integer, INTENT(IN) :: N_Type - - ! Local - Complex (Kind=8) :: VH(Ndim,Op%N), Z, Z1 - Integer :: n, i, m, m1 - - !!!!! N_Type == 1 - ! Op%U*exp(-Op%g*spin*Op%E)*Mat*exp(Op%g*spin*Op%E)*(Op%U^{dagger}) - ! - !!!!! - !!!!! N_Type == 2 - ! (Op%U^{dagger}) * Mat * Op%U - !!!!! - If (N_type == 1) then - VH = cmplx(0.d0,0.d0) - Do m = 1,Op%N - Z = exp(Op%g*cmplx(Op%E(m)*spin,0.d0)) - do n = 1,Op%N - Z1 = Z * conjg(Op%U(n,m)) - DO I = 1,Ndim - VH(I,n) = VH(I,n) + Mat(I,Op%P(m)) * Z1 - Enddo - enddo - Enddo - Do n = 1,Op%N - Do I = 1,Ndim - Mat(I,Op%P(n)) = VH(I,n) - Enddo - Enddo - - VH = cmplx(0.d0,0.d0) - Do m = 1,Op%N - Z = exp(-Op%g*cmplx(Op%E(m)*spin,0.d0)) - do n = 1,Op%N - Z1 = Z * Op%U(n,m) - DO I = 1,Ndim - VH(I,n) = VH(I,n) + Z1* Mat(Op%P(m),I) - Enddo - enddo - enddo - Do n = 1,Op%N - Do I = 1,Ndim - Mat(Op%P(n),I) = VH(I,n) - Enddo - Enddo - elseif (N_Type == 2) then - VH = cmplx(0.d0,0.d0) - do n = 1,Op%N - Do m = 1,Op%N - Z1 = Op%U(m,n) - DO I = 1,Ndim - VH(I,n) = VH(I,n) + Mat(I,Op%P(m)) * Z1 - Enddo - enddo - Enddo - Do n = 1,Op%N - Do I = 1,Ndim - Mat(I,Op%P(n)) = VH(I,n) - Enddo - Enddo - - VH = cmplx(0.d0,0.d0) - do n = 1,Op%N - Do m = 1,Op%N - Z1 = conjg(Op%U(m,n)) - DO I = 1,Ndim - VH(I,n) = VH(I,n) + Z1* Mat(Op%P(m),I) - Enddo - enddo - enddo - Do n = 1,Op%N - Do I = 1,Ndim - Mat(Op%P(n),I) = VH(I,n) - Enddo - Enddo - endif - - end Subroutine Op_Wrapdo - - -end Module Operator_mod diff --git a/Prog_7/UDV_WRAP.f90 b/Prog_7/UDV_WRAP.f90 deleted file mode 100644 index 4fb367afb..000000000 --- a/Prog_7/UDV_WRAP.f90 +++ /dev/null @@ -1,135 +0,0 @@ - Module UDV_Wrap_mod - Use MyMats - Use Files_mod - - Contains - -!*************************************************************** - Subroutine UDV_Wrap_Pivot(A,U,D,V,NCON,N1,N2) - - Implicit NONE - COMPLEX (KIND=8), INTENT(IN), DIMENSION(:,:) :: A - COMPLEX (KIND=8), INTENT(INOUT), DIMENSION(:,:) :: U,V - COMPLEX (KIND=8), INTENT(INOUT), DIMENSION(:) :: D - INTEGER, INTENT(IN) :: NCON - INTEGER, INTENT(IN) :: N1,N2 - - ! Locals - REAL (Kind=8) :: VHELP(N2), XNORM(N2), XMAX, XMEAN - INTEGER :: IVPT(N2), IVPTM1(N2), I, J, K, IMAX - COMPLEX (KIND=8) :: A1(N1,N2), A2(N1,N2) - - DO I = 1,N2 - XNORM(I) = 0.D0 - DO J = 1,N1 - XNORM(I) = XNORM(I) + DBLE( A(J,I) * CONJG( A(J,I) ) ) - ENDDO - ENDDO - DO I = 1,N2 - VHELP(I) = XNORM(I) - ENDDO - - DO I = 1,N2 - XMAX = 0.D0 - DO J = 1,N2 - IF (VHELP(J).GT.XMAX) THEN - IMAX = J - XMAX = VHELP(J) - ENDIF - ENDDO - VHELP(IMAX) = -1.D0 - IVPTM1(IMAX)= I - IVPT(I) = IMAX - ENDDO - DO I = 1,N2 - K = IVPT(I) - DO J = 1,N1 - A1(J,I) = A(J,K) - ENDDO - ENDDO - - CALL UDV_Wrap(A1,U,D,V,NCON) - - A1 = V - DO I = 1,N2 - K = IVPTM1(I) - DO J = 1,N1 - V(J,I) = A1(J,K) - ENDDO - ENDDO - - - IF (NCON == 1) THEN - !Check the result A = U D V - DO J = 1,N2 - DO I = 1,N1 - A1(I,J) = D(I)*V(I,J) - ENDDO - ENDDO - Call MMULT (A2,U,A1) - CALL COMPARE(A,A2,XMAX,XMEAN) - Write (6,*) 'Check afer Pivoting', XMAX - ENDIF - - - - End Subroutine UDV_Wrap_Pivot -!*************************************************************** - Subroutine UDV_Wrap(A,U,D,V,NCON) - -#include "machine" - - Implicit None -#ifdef MPI - INCLUDE 'mpif.h' -#endif - COMPLEX (KIND=8), INTENT(IN), DIMENSION(:,:) :: A - COMPLEX (KIND=8), INTENT(INOUT), DIMENSION(:,:) :: U,V - COMPLEX (KIND=8), INTENT(INOUT), DIMENSION(:) :: D - INTEGER, INTENT(IN) :: NCON - - !Local - Complex (Kind=8), Allocatable :: A1(:,:),U1(:,:) - Integer :: I,J, N - character (len=64) :: file_sr, File -#ifdef MPI - INTEGER :: STATUS(MPI_STATUS_SIZE) - INTEGER :: Isize, Irank,Ierr - - CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) - CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) -#endif - - File_sr = "SDV" -#ifdef MPI - File = File_i(File_sr, Irank) -#else - File = File_sr -#endif - !Open (Unit = 78,File=File, Status='UNKNOWN', action="write", position="append") - !Write(78,*) 'Call QR' - !Close(78) - CALL QR(A,U,V,NCON) - !Open (Unit = 78,File=File, Status='UNKNOWN', action="write", position="append") - !Write(78,*) 'End call QR' - !Close(78) - N = Size(V,1) - Allocate (A1(N,N),U1(N,N)) - A1 = V - !Open (Unit = 78,File=File, Status='UNKNOWN') - !Write(78,*) 'Call SVD' - !DO I = 1,N - ! Write(78,*) Real(V(I,I)) - !ENDDO - !Close(78) - CALL SVD(A1,U1,D,V,NCON) - !Open (Unit = 78,File=File, Status='UNKNOWN', action="write", position="append") - !Write(78,*) 'End call SVD' - !Close(78) - Call MMULT(A1,U,U1) - U = A1 - - End Subroutine UDV_Wrap - - End Module UDV_Wrap_mod - diff --git a/Prog_7/cgr1.f90 b/Prog_7/cgr1.f90 deleted file mode 100644 index b7fc92ca1..000000000 --- a/Prog_7/cgr1.f90 +++ /dev/null @@ -1,110 +0,0 @@ - SUBROUTINE CGR(PHASE,NVAR, GRUP, URUP,DRUP,VRUP, ULUP,DLUP,VLUP) - - Use UDV_Wrap_mod - - Implicit None - - !!! GRUP = (1 + UR*DR*VR*VL*DL*UL)^-1 - !!! NVAR = 1 Big scales are in DL - !!! NVAR = 2 Big scales are in DR - - !Arguments. - COMPLEX(Kind=8), Dimension(:,:), Intent(IN) :: URUP, VRUP, ULUP, VLUP - COMPLEX(Kind=8), Dimension(:), Intent(In) :: DLUP, DRUP - COMPLEX(Kind=8), Dimension(:,:), Intent(INOUT) :: GRUP - COMPLEX(Kind=8) :: PHASE - INTEGER :: NVAR - - !Local - COMPLEX (Kind=8), Dimension(:,:), Allocatable :: UUP, VUP, TPUP, TPUP1, & - & TPUPM1,TPUP1M1, UUPM1, VUP1 - COMPLEX (Kind=8), Dimension(:) , Allocatable :: DUP - COMPLEX (Kind=8) :: ZDUP1, ZDDO1, ZDUP2, ZDDO2, Z1, ZUP, ZDO, Z - Integer :: I,J, N_size, NCON, NR, NT, N - Real (Kind=8) :: X, Xmax - - N_size = SIZE(DLUP,1) - NCON = 0 - - Allocate( UUP(N_size,N_size), VUP(N_size,N_size), TPUP(N_size,N_size), TPUP1(N_size,N_size), & - & TPUPM1(N_size,N_size),TPUP1M1(N_size,N_size), UUPM1(N_size,N_size), VUP1(N_size,N_size), DUP(N_size) ) - - !Write(6,*) 'In CGR', N_size - CALL MMULT(VUP,VRUP,VLUP) - DO J = 1,N_size - DO I = 1,N_size - TPUP(I,J) = DRUP(I)*VUP(I,J)*DLUP(J) - ENDDO - ENDDO - CALL MMULT(UUP,ULUP,URUP) - DO J = 1,N_size - DO I = 1,N_size - UUPM1(I,J) = CONJG(UUP(J,I)) - ENDDO - ENDDO - DO J = 1,N_size - DO I = 1,N_size - TPUP(I,J) = TPUP(I,J) + UUPM1(I,J) - ENDDO - ENDDO - IF (NVAR.EQ.1) THEN - !WRITE(6,*) 'UDV of U + DR * V * DL' - CALL UDV_WRAP(TPUP,UUP,DUP,VUP,NCON) - !CALL UDV(TPUP,UUP,DUP,VUP,NCON) - CALL MMULT(TPUP,VUP,ULUP) - !Do I = 1,N_size - ! Write(6,*) DLUP(I) - !enddo - CALL INV(TPUP,TPUPM1,ZDUP1) - !WRITE(6,*) 'End called Inv' - CALL MMULT(TPUP1,URUP,UUP) - CALL INV(TPUP1,TPUP1M1,ZDUP2) - Z1 = ZDUP1*ZDUP2 - ELSEIF (NVAR.EQ.2) THEN - !WRITE(6,*) 'UDV of (U + DR * V * DL)^{*}' - DO J = 1,N_size - DO I = 1,N_size - TPUP1(I,J) = CONJG( TPUP(J,I) ) - ENDDO - ENDDO - CALL UDV_WRAP(TPUP1,UUP,DUP,VUP,NCON) - !CALL UDV(TPUP1,UUP,DUP,VUP,NCON) - DO J = 1,N_size - DO I = 1,N_size - TPUP(I,J) = CONJG( ULUP(J,I) ) - ENDDO - ENDDO - CALL MMULT(TPUPM1,TPUP,UUP) - DO J = 1,N_size - DO I = 1,N_size - VUP1(I,J) = CONJG( VUP(J,I) ) - ENDDO - ENDDO - CALL MMULT(TPUP1,URUP,VUP1) - CALL INV(TPUP1,TPUP1M1,ZDUP2) - CALL INV(TPUPM1, TPUP, ZDUP1) - Z1 = ZDUP2/ZDUP1 - ENDIF - DO I = 1,N_size - Z = DUP(I) - if (I == 1) Xmax = real(SQRT( Z* conjg(Z)),kind=8) - if ( real(SQRT( Z* conjg(Z)),kind=8) < Xmax ) Xmax = & - & real(SQRT( Z* conjg(Z)),kind=8) - ENDDO - !Write(6,*) 'Cgr1, Cutoff: ', Xmax - - - DO J = 1,N_size - DO I = 1,N_size - ZUP = CMPLX(0.D0,0.D0) - DO NR = 1,N_size - ZUP = ZUP + TPUPM1(I,NR)*TPUP1M1(NR,J)/DUP(NR) - ENDDO - GRUP(I,J) = ZUP - ENDDO - ENDDO - PHASE = Z1/SQRT( Z1* CONJG(Z1) ) - - Deallocate(UUP, VUP, TPUP,TPUP1,TPUPM1, TPUP1M1, UUPM1, VUP1, DUP ) - - END SUBROUTINE CGR diff --git a/Prog_7/cgr2.f90 b/Prog_7/cgr2.f90 deleted file mode 100644 index 213a01b25..000000000 --- a/Prog_7/cgr2.f90 +++ /dev/null @@ -1,122 +0,0 @@ - SUBROUTINE CGR2(GRT0, GR00, GRTT, GR0T, U2, D2, V2, U1, D1, V1, LQ) - - ! B2 = U2*D2*V2 - ! B1 = V1*D1*U1 - !Calc: ( 1 B1 )^-1 i.e. 2*LQ \times 2*LQ matrix - ! (-B2 1 ) - - - Use Precdef - Use UDV_WRAP_mod - Use MyMats - - Implicit none - - ! Arguments - Integer :: LQ - Complex (Kind=double), intent(in) :: U1(LQ,LQ), V1(LQ,LQ), U2(LQ,LQ), V2(LQ,LQ) - Complex (Kind=double), intent(in) :: D2(LQ), D1(LQ) - Complex (Kind=double), intent(inout) :: GRT0(LQ,LQ), GR0T(LQ,LQ), GR00(LQ,LQ), GRTT(LQ,LQ) - - - ! Local:: - Complex (Kind=double) :: U3B(2*LQ,2*LQ), V3B(2*LQ,2*LQ), HLPB1(2*LQ,2*LQ), HLPB2(2*LQ,2*LQ), & - & V2INV(LQ,LQ), V1INV(LQ,LQ), HLP2(LQ,LQ) - Complex (Kind=double) :: D3B(2*LQ) - Complex (Kind=double) :: Z - - Integer :: LQ2, I,J, M, ILQ, JLQ, NCON, I1, J1 - - LQ2 = LQ*2 - - HLPB1 = cmplx(0.D0,0.d0,double) - DO I = 1,LQ - HLPB1(I , I + LQ ) = D1(I) - HLPB1(I+LQ, I ) = -D2(I) - ENDDO - CALL INV(V2,V2INV,Z) - CALL INV(V1,V1INV,Z) - CALL MMULT(HLP2,V1INV,V2INV) - DO J = 1,LQ - DO I = 1,LQ - HLPB1(I,J) = HLP2(I,J) - ENDDO - ENDDO - CALL MMULT(HLP2,U1,U2) - DO I = 1,LQ - ILQ = I+LQ - DO J = 1,LQ - JLQ = J + LQ - HLPB1(ILQ,JLQ) = conjg( HLP2(J,I) ) ! = (U1*U2)^T - ENDDO - ENDDO - NCON = 0 - CALL UDV_wrap(HLPB1,U3B,D3B,V3B,NCON) - - - ! Multiplication: - ! U3B^T * ( V1INV 0 ) = U3B - ! ( 0 U2^T ) - - DO I = 1,LQ2 - DO J = 1,LQ2 - HLPB1(I,J) = conjg(U3B(J,I)) - ENDDO - ENDDO - HLPB2 = cmplx(0.D0,0.d0,double) - DO I = 1,LQ - DO J = 1,LQ - HLPB2(I,J) = V1INV(I,J) - ENDDO - ENDDO - DO I = 1,LQ - ILQ = I + LQ - DO J = 1,LQ - JLQ = J + LQ - HLPB2(ILQ,JLQ) = conjg(U2(J,I)) - ENDDO - ENDDO - CALL MMULT(U3B,HLPB1,HLPB2) - - - ! Multiplication: - ! ( V2INV 0 )*(V3B)^{-1} = V3B - ! ( 0 U1^T ) - - CALL INV(V3B,HLPB1,Z) - HLPB2 = cmplx(0.d0,0.d0,double) - DO I = 1,LQ - DO J = 1,LQ - HLPB2(I,J) = V2INV(I,J) - ENDDO - ENDDO - DO I = 1,LQ - ILQ = I + LQ - DO J = 1, LQ - JLQ = J + LQ - HLPB2(ILQ,JLQ) = conjg(U1(J,I)) - ENDDO - ENDDO - CALL MMULT(V3B,HLPB2,HLPB1) - - - ! G = V3B * D3B^{-1}* U3B - DO M = 1,LQ2 - Z = cone/D3B(M) - DO J = 1,LQ2 - U3B(M,J) = Z * U3B(M,J) - ENDDO - ENDDO - CALL MMULT(HLPB2, V3B, U3B) - DO I = 1,LQ - I1 = I+LQ - DO J = 1,LQ - J1 = J + LQ - GR00(I,J) = HLPB2(I ,J ) - GRTT(I,J) = HLPB2(I1,J1) - GRT0(I,J) = HLPB2(I1,J ) - GR0T(I,J) = HLPB2(I,J1 ) - ENDDO - ENDDO - - END SUBROUTINE CGR2 diff --git a/Prog_7/cgr2_1.f90 b/Prog_7/cgr2_1.f90 deleted file mode 100644 index 78297bf8d..000000000 --- a/Prog_7/cgr2_1.f90 +++ /dev/null @@ -1,539 +0,0 @@ - SUBROUTINE CGR2_1(GRT0, GR00, GRTT, GR0T, U2, D2, V2, U1, D1, V1, LQ, NVAR) - - ! B2 = U2*D2*V2 is right (i.e. from time slice 0 to tau) propagation to time tau - ! B1 = V1*D1*U1 is left (i.e. from time slice Ltrot to tau) propagation to time tau - !Calc: ( 1 B1 )^-1 ( G00 G0T ) - ! (-B2 1 ) == ( GT0 GTT ) - ! - ! G00 = (1 + B1*B2)^-1 G0T = -(1 - G00 )*B2^-1 - ! GT0 = B2 * G00 GTT = (1 + B2*B1)^-1 - - ! Here you want to compute G00, G0T, GT0 and GTT just by involving LQ x LQ matrix operations. - ! If NVAR == 1 then the large scales are in D1 - ! If NVAR == 2 then the large scales are in D2 - Use Precdef - Use MyMats - USe UDV_Wrap_mod - - Implicit none - - Interface - SUBROUTINE CGR(Z,NVAR, GRUP, URUP,DRUP,VRUP, ULUP,DLUP,VLUP) - COMPLEX(Kind=8), Dimension(:,:), Intent(In) :: URUP, VRUP, ULUP, VLUP - COMPLEX(Kind=8), Dimension(:), Intent(In) :: DLUP, DRUP - COMPLEX(Kind=8), Dimension(:,:), Intent(INOUT) :: GRUP - - COMPLEX(Kind=8) :: Z - END SUBROUTINE CGR - end Interface - - - ! Arguments - Integer, intent(in) :: LQ, NVAR - Complex (Kind=double), intent(in) :: U1(LQ,LQ), V1(LQ,LQ), U2(LQ,LQ), V2(LQ,LQ) - Complex (Kind=double), intent(in) :: D2(LQ), D1(LQ) - Complex (Kind=double), intent(inout) :: GRT0(LQ,LQ), GR0T(LQ,LQ), GR00(LQ,LQ), GRTT(LQ,LQ) - - - ! Local:: - Complex (Kind=double) :: HLP1(LQ,LQ), HLP2(LQ,LQ), U(LQ,LQ), D(LQ), V(LQ,LQ) - Complex (Kind=double) :: Z, Z1, Z2 - Real (Kind=double) :: X, Xmax, Xmin, X1, X2, Xmax1, Xmax2, Xmean - Integer :: I, J, M, NCON, NVAR1 - - Complex (Kind=double) :: V2inv(LQ,LQ), V1inv(LQ,LQ) - - - NCON = 0 - - Call INV( V2, V2inv, Z2) - CALL INV( V1, V1inv, Z1) - - - DO I = 1,LQ - DO J = 1,LQ - HLP1(I,J) = CONJG( U1(J,I) ) - ENDDO - ENDDO - CALL MMULT(HLP2,HLP1,U1) - HLP1 = cmplx(0.d0,0.d0,kind=8) - DO I = 1,LQ - HLP1(I,I) = cmplx(1.d0,0.d0,kind=8) - ENDDO - Xmax = 0.d0 - CALL COMPARE(HLP1, HLP2, XMAX, XMEAN) - - DO I = 1,LQ - DO J = 1,LQ - HLP1(I,J) = CONJG( U2(J,I) ) - ENDDO - ENDDO - CALL MMULT(HLP2,HLP1,U2) - HLP1 = cmplx(0.d0,0.d0,kind=8) - DO I = 1,LQ - HLP1(I,I) = cmplx(1.d0,0.d0,kind=8) - ENDDO - Xmax1 = 0.d0 - CALL COMPARE(HLP1, HLP2, XMAX1, XMEAN) - Write(77,*) "Cgr2_1 V1inv V2inv : ", Xmax, Xmax1 - -!!$ Xmax = 0.d0 -!!$ do I = 1,LQ -!!$ do j = 1,LQ -!!$ X = sqrt(dble(V1(i,j)*conjg(V1(i,j)))) -!!$ if (X > Xmax) Xmax = X -!!$ enddo -!!$ enddo -!!$ Write(77,*) 'In cgr2_1 Xmax V1: ', Xmax, Z2 -!!$ do I = 1,LQ -!!$ do j = 1,LQ -!!$ X = sqrt(dble(V2(i,j)*conjg(V2(i,j)))) -!!$ if (X > Xmax) Xmax = X -!!$ enddo -!!$ enddo -!!$ Write(77,*) 'In cgr2_1 Xmax V2: ', Xmax, Z1 - - ! Compute G00 - ! G00 = (1 + B1*B2)^-1 = (1 + V1 D1 U1 U2 D2 V2 )^-1 = - ! = ( V1 ( V1^-1 V2^-1 + D1 U1 U2 D2 ) V2 )^-1 = - ! = V2^-1 ( (V2 V1)^-1 + D1 U1 U2 D2 )^-1 V1^-1 - Call MMULT(HLP1,V1inv,V2inv) - Call MMULT(HLP2,U1,U2) - DO J = 1,LQ - DO I = 1,LQ - HLP2(I,J) = D1(I)*HLP2(I,J)*D2(J) + HLP1(I,J) - ENDDO - ENDDO - Xmax1 = dble( D1(1) ) - Xmax2 = dble( D2(1) ) - DO I = 2,LQ - If ( dble( D1(I) ) > Xmax1 ) Xmax1 = dble( D1(I) ) - If ( dble( D2(I) ) > Xmax2 ) Xmax2 = dble( D2(I) ) - Enddo - Nvar1 = 1 - If ( Xmax2 > Xmax1) Nvar1 = 2 - If (Nvar1 == 1) then - ! V2^-1 (UDV )^-1 V1^-1 = V2^-1 V^-1 D^-1 U^-1 V1^-1 - Call UDV_WRAP(HLP2, U, D, V, Ncon) - CALL INV (V,HLP2 ,Z ) - CALL MMULT(V,V2inv,HLP2) - DO J = 1,LQ - DO I = 1,LQ - V(I,J) = V(I,J)/D(J) - ENDDO - ENDDO - DO I = 1,LQ - DO J = 1,LQ - HLP1(I,J) = Conjg(U(J,I)) - ENDDO - ENDDO - CALL MMULT( HLP2, HLP1,V1inv) - CALL MMULT (GR00, V, HLP2) - else - ! V2^-1 (UDV )^(-1,*) V1^-1 = V2^-1 U D^-1 V^(-1,*) V1^-1 - DO J = 1,LQ - DO I = 1,LQ - HLP1(I,J) = conjg(HLP2(J,I)) - ENDDO - ENDDO - Call UDV_WRAP(HLP1, U, D, V, Ncon) - Call MMULT(HLP1, V2inv, U) - DO J = 1,LQ - DO I = 1,LQ - HLP1(I,J) = HLP1(I,J)/D(J) - ENDDO - ENDDO - CALL INV (V, HLP2, Z) - DO J = 1,LQ - DO I = 1,LQ - V(I,J) = CONJG(HLP2(J,I)) - ENDDO - ENDDO - CALL MMULT(HLP2,V,V1inv) - CALL MMULT(GR00,HLP1,HLP2) - endif - - ! Compute G0T - ! G00 = (1 + B1*B2)^-1 G0T = -(1 - (1 + B1*B2)^-1 )*B2^-1 = - ! = -( 1 + B1*B2 - 1) (1 + B1*B2)^-1 * B2^-1 = - ! = - B1 * B2 (1 + B1*B2)^-1 * B2^-1 = - ! = -( B2 ( 1+ B1*B2) * B2^-1 B1^-1)^-1 = - ! = -( B2 ( 1+ B1*B2) * (B1 B2)^-1)^-1 = - ! = -( B2 ( (B1 B2)^-1 + 1 ) )^-1 = - ! = -( B1^-1 + B2)^-1 = - ! -G0T*= ( B1*^-1 + B2*)^-1 = - ! = ( V1*^-1 D1*^-1 U1 + V2* D2* U2*)^-1 = - ! = ( V1*^-1 ( D1*^-1 U1 U2 + V1* V2* D2* ) U2* )^-1 = - ! = U2 ( D1*^-1 (U1 U2) + ( V2 V1)* D2* )^-1 V1* - ! = U2 ( D1*^-1 (U1 U2) + ( V2 V1)* D2* )^-1 V1* - ! B2 = U2*D2*V2 - ! B1 = V1*D1*U1 - Xmax2 = dble(cmplx(1.d0,0.d0)/D1(1)) - Xmax1 = dble(D2(1)) - Do I = 2,LQ - X2 = dble(cmplx(1.d0,0.d0)/D1(I)) - X1 = dble(D2(I)) - If ( X2 > Xmax2 ) Xmax2 = X2 - If ( X1 > Xmax1 ) Xmax1 = X1 - ENDDO - NVAR1 = 1 - If (Xmax2 > Xmax1) Nvar1 = 2 - Call MMULT(HLP1,U1,U2) - DO J = 1,LQ - DO I =1,LQ - HLP1(I,J) = HLP1(I,J)/conjg(D1(I)) - ENDDO - ENDDO - Call MMULT(V,V2,V1) - DO J = 1,LQ - DO I = 1,LQ - HLP2(I,J) = Conjg(V(J,I)) - ENDDO - ENDDO - DO J = 1,LQ - DO I =1,LQ - HLP2(I,J) = HLP1(I,J) + HLP2(I,J)*conjg(D2(J)) - ENDDO - ENDDO - NCON = 0 - IF ( NVAR1 == 1 ) Then - ! UDV of HLP2 - ! -G0T*= U2 V^-1 D^-1 U* V1* - CALL UDV_WRAP(HLP2,U,D,V,NCON) - CALL MMULT (HLP1, V1, U) - DO I = 1,LQ - DO J = 1,LQ - U(I,J) = conjg(HLP1(J,I)) - ENDDO - ENDDO - CALL INV(V,HLP2,Z) - Call MMULT(HLP1,U2,HLP2) - DO J = 1,LQ - Z = cmplx(1.d0,0.d0,kind=8)/D(J) - DO I = 1,LQ - HLP1(I,J) = HLP1(I,J)*Z - ENDDO - ENDDO - Call MMULT (HLP2,HLP1,U) - DO I = 1,LQ - DO J = 1,LQ - GR0T(I,J) = -conjg(HLP2(J,I)) - ENDDO - ENDDO - ELSE - ! UDV of HLP2* - ! -G0T*= U2 (U D V)*^-1 V1* = U2 U D*^-1 V*^-1 V1* - DO I = 1,LQ - DO J = 1,LQ - HLP1(I,J) = conjg(HLP2(J,I)) - ENDDO - ENDDO - CALL UDV_WRAP(HLP1,U,D,V,NCON) - CALL MMULT (HLP1, U2, U) - DO J = 1,LQ - Z = cmplx(1.d0,0.d0,kind=8)/D(J) - DO I = 1,LQ - HLP1(I,J) = HLP1(I,J)*Z - ENDDO - ENDDO - CALL INV(V,HLP2,Z) - Call MMULT(V,V1,HLP2) - DO I = 1,LQ - DO J = 1,LQ - HLP2(I,J) = conjg(V(J,I)) - ENDDO - ENDDO - Call MMULT (V,HLP1,HLP2) - DO I = 1,LQ - DO J = 1,LQ - GR0T(I,J) = -conjg(V(J,I)) - ENDDO - ENDDO - ENDIF - - - - - ! Compute GT0 - ! GT0 = B2 * G00 = ( ( 1 + B1* B2) * B2^-1 )^-1 = ( B2^-1 + B1)^-1 = - ! = (V2^-1 D2^-1 U2^-1 + V1 D1 U1)^-1 = - ! = ( (V2^-1 D2^-1 U2^-1 U1^-1 + V1 D1 ) U1 )^-1 = - ! = U1^-1 ( ( D2^-1 (U1 U2)^-1 + V2*V1 D1 ) )^-1 V2 - Xmax2 = dble(cmplx(1.d0,0.d0)/D2(1)) - Xmax1 = dble(D1(1)) - Do I = 2,LQ - X2 = dble(cmplx(1.d0,0.d0)/D2(I)) - X1 = dble(D1(I)) - If ( X2 > Xmax2 ) Xmax2 = X2 - If ( X1 > Xmax1 ) Xmax1 = X1 - ENDDO - NVAR1 = 1 - If (Xmax2 > Xmax1 ) NVAR1 = 2 - !Write(6,*) "CGR2_1: NVAR,NVAR1 ", NVAR, NVAR1 - Call MMULT(HLP2,U1,U2) - DO J = 1,LQ - DO I = 1,LQ - HLP1(I,J) = Conjg(HLP2(J,I)) - ENDDO - ENDDO - DO J = 1,LQ - DO I =1,LQ - HLP1(I,J) = HLP1(I,J)/D2(I) - ENDDO - ENDDO - Call MMULT(HLP2,V2,V1) - DO J = 1,LQ - DO I =1,LQ - HLP2(I,J) = HLP1(I,J) + HLP2(I,J)*D1(J) - ENDDO - ENDDO - NCON = 0 - IF ( NVAR1 == 1 ) Then - ! UDV of HLP2 - CALL UDV_WRAP(HLP2,U,D,V,NCON) - CALL MMULT (HLP1, V, U1) - CALL INV(HLP1,HLP2,Z) - DO J = 1,LQ - Z = cmplx(1.d0,0.d0)/D(J) - DO I = 1,LQ - HLP2(I,J) = HLP2(I,J)*Z - ENDDO - ENDDO - DO I = 1,LQ - DO J = 1,LQ - HLP1(I,J) = Conjg(U(J,I)) - ENDDO - ENDDO - CALL MMULT(U,HLP1,V2) - Call MMULT (GRT0, HLP2,U) - ELSE - !UDV of HLP2^* - DO J = 1,LQ - DO I =1,LQ - HLP1(I,J) = Conjg(HLP2(J,I)) - ENDDO - ENDDO - CALL UDV_WRAP(HLP1,U,D,V,NCON) - DO I = 1,LQ - DO J = 1,LQ - HLP1(I,J) = conjg(U1(J,I)) - ENDDO - ENDDO - CALL MMULT( HLP2, HLP1,U) - DO J = 1,LQ - DO I = 1,LQ - HLP2(I,J) = HLP2(I,J)/Conjg(D(J)) - ENDDO - ENDDO - DO I = 1,LQ - DO J = 1,LQ - HLP1(I,J) = conjg(V(J,I)) - ENDDO - ENDDO - CALL INV(HLP1,V,Z) - CALL MMULT(U,V,V2) - Call MMULT (GRT0, HLP2,U) - ENDIF - Xmin = abs(dble(D(1))) - DO I = 1,LQ - if (abs(dble(D(I))) < Xmin ) Xmin = abs(dble(D(I))) - ENDDO - Write(6,*) 'Cgr2_1 T0, Xmin: ', Xmin - - - !Compute GRTT - Z = cmplx(1.d0,0.d0,kind=8) - Z1 = cmplx(1.d0,0.d0,kind=8) - CALL CGR(Z,NVAR,GRTT, U2,D2,V2, U1,D1,V1) - - - END SUBROUTINE CGR2_1 - - -!!$ ! Compute G0T -!!$ ! G00 = (1 + B1*B2)^-1 G0T = -(1 - (1 + B1*B2)^-1 )*B2^-1 = -!!$ ! = -( 1 + B1*B2 - 1) (1 + B1*B2)^-1 * B2^-1 = -!!$ ! = - B1 * B2 (1 + B1*B2)^-1 * B2^-1 = -!!$ ! = -( B2 ( 1+ B1*B2) * B2^-1 B1^-1)^-1 = -!!$ ! = -( B2 ( 1+ B1*B2) * (B1 B2)^-1)^-1 = -!!$ ! = -( B2 ( (B1 B2)^-1 + 1 ) )^-1 = -!!$ ! = -( B1^-1 + B2)^-1 = -!!$ ! = -( U1^-1 D1^-1 V1^-1 + U2 D2 V2)^-1 = -!!$ ! = -( ( U1^-1 D1^-1 V1^-1 V2^-1 + U2 D2 ) V2 )^-1 = -!!$ ! = -( U1^-1( D1^-1 (V2 V1)^-1 + U1 U2 D2) V2 )^-1 = -!!$ ! = - V2^-1( D1^-1 (V2 V1)^-1 + U1 U2 D2)^-1 U1 -!!$ ! B2 = U2*D2*V2 -!!$ ! B1 = V1*D1*U1 -!!$ Call MMULT (HLP2, V1inv,V2inv) -!!$ DO J = 1,LQ -!!$ DO I = 1,LQ -!!$ HLP2(I,J) = HLP2(I,J)/D1(I) -!!$ ENDDO -!!$ ENDDO -!!$ Call MMULT (HLP1, U1,U2) -!!$ DO J = 1,LQ -!!$ DO I = 1,LQ -!!$ HLP2(I,J) = HLP2(I,J) + HLP1(I,J)*D2(J) -!!$ ENDDO -!!$ ENDDO -!!$ Xmax2 = dble(cmplx(1.d0,0.d0,Kind=8)/D1(1)) -!!$ Xmax1 = dble(D2(1)) -!!$ Do I = 2,LQ -!!$ X2 = dble(cmplx(1.d0,0.d0,Kind=8)/D1(I)) -!!$ X1 = dble(D2(I)) -!!$ If ( X2 > Xmax2 ) Xmax2 = X2 -!!$ If ( X1 > Xmax1 ) Xmax1 = X1 -!!$ ENDDO -!!$ NVAR1 = 1 -!!$ If (Xmax2 > Xmax1 ) NVAR1 = 2 -!!$ IF (NVAR1 == 1) Then -!!$ ! UDV of HLP2 -!!$ != - V2^-1( U D V )^-1 ) U1 = -!!$ != - V2^-1 V^-1 D^-1 U^-1 U1 = - (V V2)^-1 D^-1 U^-1 U1 -!!$ CALL UDV(HLP2,U,D,V,NCON) -!!$ DO J = 1,LQ -!!$ DO I = 1,LQ -!!$ HLP1(I,J) = conjg(U(J,I)) -!!$ ENDDO -!!$ ENDDO -!!$ CALL MMULT( U, HLP1, U1 ) -!!$ CALL MMULT(HLP1,V, V2) -!!$ CALL INV (HLP1,V ,Z) -!!$ DO J = 1,LQ -!!$ DO I = 1,LQ -!!$ HLP1(I,J) = - V(I,J)/D(J) -!!$ ENDDO -!!$ ENDDO -!!$ CALL MMULT(GR0T, HLP1, U) -!!$ Else -!!$ ! UDV of HLP2^* -!!$ != - V2^-1( U D V)^*,-1 ) U1 = -!!$ != - V2^-1 U D^-1 V^*,-1 U1 -!!$ DO I = 1,LQ -!!$ DO J = 1,LQ -!!$ HLP1(J,I) = Conjg(HLP2(I,J)) -!!$ ENDDO -!!$ ENDDO -!!$ CALL UDV(HLP1,U,D,V,NCON) -!!$ CALL INV(V2,HLP1,Z) -!!$ CALL MMULT(HLP2,HLP1,U) -!!$ DO J = 1,LQ -!!$ DO I = 1,LQ -!!$ HLP1(I,J) = -HLP2(I,J)/conjg(D(J)) -!!$ ENDDO -!!$ ENDDO -!!$ CALL INV(V,HLP2,Z) -!!$ DO J = 1,LQ -!!$ DO I = 1,LQ -!!$ V(I,J) = Conjg(HLP2(J,I)) -!!$ ENDDO -!!$ ENDDO -!!$ CALL MMULT(HLP2,V,U1) -!!$ CALL MMULT(GR0T, HLP1,HLP2) -!!$ endif -!!$ Xmin = abs(dble(D(1))) -!!$ DO I = 1,LQ -!!$ if (abs(dble(D(I))) < Xmin ) Xmin = abs(dble(D(I))) -!!$ ENDDO -!!$ Write(6,*) 'Cgr2_1 0T, Xmin: ', Xmin - - - - -!!$ ! Compute G0T -!!$ ! G00 = (1 + B1*B2)^-1 G0T = -(1 - (1 + B1*B2)^-1 )*B2^-1 = -!!$ ! = -( 1 + B1*B2 - 1) (1 + B1*B2)^-1 * B2^-1 = -!!$ ! = - B1 * B2 (1 + B1*B2)^-1 * B2^-1 = -!!$ ! = -( B2 ( 1+ B1*B2) * B2^-1 B1^-1)^-1 = -!!$ ! = -( B2 ( 1+ B1*B2) * (B1 B2)^-1)^-1 = -!!$ ! = -( B2 ( (B1 B2)^-1 + 1 ) )^-1 = -!!$ ! = -( B1^-1 + B2)^-1 = -!!$ ! = -( U1^-1 D1^-1 V1^-1 + U2 D2 V2)^-1 = -!!$ ! = -(U2 (U2^-1 U1^-1 D1^-1 + D2 V2 V1 ) V1^-1 )^-1 = -!!$ ! = - V1 ( (U1 U2)^-1 D1^-1 + D2 V2 V1 )^-1 U2^-1 -!!$ ! B2 = U2*D2*V2 -!!$ ! B1 = V1*D1*U1 -!!$ Call MMULT (HLP1, U1,U2) -!!$ DO J = 1,LQ -!!$ DO I = 1,LQ -!!$ HLP2(I,J) = Conjg(HLP1(J,I)) -!!$ ENDDO -!!$ ENDDO -!!$ DO J = 1,LQ -!!$ DO I = 1,LQ -!!$ HLP2(I,J) = HLP2(I,J) / D1(J) -!!$ ENDDO -!!$ ENDDO -!!$ -!!$ Call MMULT (HLP1, V2,V1) -!!$ DO J = 1,LQ -!!$ DO I = 1,LQ -!!$ HLP2(I,J) = HLP2(I,J) + D2(I)*HLP1(I,J) -!!$ ENDDO -!!$ ENDDO -!!$ Xmax2 = dble(cmplx(1.d0,0.d0)/D1(1)) -!!$ Xmax1 = dble(D2(1)) -!!$ Do I = 2,LQ -!!$ X2 = dble(cmplx(1.d0,0.d0)/D1(I)) -!!$ X1 = dble(D2(I)) -!!$ If ( X2 > Xmax2 ) Xmax2 = X2 -!!$ If ( X1 > Xmax1 ) Xmax1 = X1 -!!$ ENDDO -!!$ NVAR1 = 1 -!!$ If (Xmax1 > Xmax2 ) NVAR1 = 2 -!!$ IF (NVAR1 == 1) Then -!!$ ! UDV of HLP2 -!!$ != - V1 ( U D V)^-1 U2^-1 -!!$ != - V1 V^-1 D^-1 U^-1 U2^-1 = - V1 V^-1 D^-1 (U2 U)^-1 -!!$ CALL UDV(HLP2,U,D,V,NCON) -!!$ CALL MMULT( HLP2, U2, U ) -!!$ DO J = 1,LQ -!!$ DO I = 1,LQ -!!$ HLP1(I,J) = conjg(HLP2(J,I)) -!!$ ENDDO -!!$ ENDDO -!!$ CALL INV (V, HLP2 ,Z) -!!$ CALL MMULT(V, V1, HLP2) -!!$ DO J = 1,LQ -!!$ DO I = 1,LQ -!!$ HLP2(I,J) = - V(I,J)/D(J) -!!$ ENDDO -!!$ ENDDO -!!$ CALL MMULT(GR0T, HLP2, HLP1) -!!$ Else -!!$ ! UDV of HLP2^* -!!$ != - V1 ( U D V)^(*,-1) U2^-1 -!!$ != - V1 U D^(*,-1) V^(*,-1) U2^-1 -!!$ DO I = 1,LQ -!!$ DO J = 1,LQ -!!$ HLP1(J,I) = Conjg(HLP2(I,J)) -!!$ ENDDO -!!$ ENDDO -!!$ CALL UDV(HLP1,U,D,V,NCON) -!!$ CALL MMULT(HLP2,V1,U) -!!$ DO J = 1,LQ -!!$ DO I = 1,LQ -!!$ HLP2(I,J) = -HLP2(I,J)/conjg(D(J)) -!!$ ENDDO -!!$ ENDDO -!!$ -!!$ CALL INV(V,HLP1,Z) -!!$ DO J = 1,LQ -!!$ DO I = 1,LQ -!!$ V(I,J) = Conjg(HLP1(J,I)) -!!$ ENDDO -!!$ ENDDO -!!$ DO J = 1,LQ -!!$ DO I = 1,LQ -!!$ U(I,J) = Conjg(U2(J,I)) -!!$ ENDDO -!!$ ENDDO -!!$ CALL MMULT(HLP1,V,U) -!!$ -!!$ CALL MMULT(GR0T, HLP2,HLP1) -!!$ endif -!!$ Xmin = abs(dble(D(1))) -!!$ DO I = 1,LQ -!!$ if (abs(dble(D(I))) < Xmin ) Xmin = abs(dble(D(I))) -!!$ ENDDO -!!$ Write(6,*) 'Cgr2_1 0T, Xmin: ', Xmin, NVAR1 diff --git a/Prog_7/cgr2_2.f90 b/Prog_7/cgr2_2.f90 deleted file mode 100644 index 87e8a462f..000000000 --- a/Prog_7/cgr2_2.f90 +++ /dev/null @@ -1,176 +0,0 @@ - SUBROUTINE CGR2_2(GRT0, GR00, GRTT, GR0T, U2, D2, V2, U1, D1, V1, LQ) - - - ! B2 = U2*D2*V2 is right (i.e. from time slice 0 to tau) propagation to time tau - ! B1 = V1*D1*U1 is left (i.e. from time slice Ltrot to tau) propagation to time tau - !Calc: ( 1 B1 )^-1 ( G00 G0T ) - ! (-B2 1 ) == ( GT0 GTT ) - ! - ! G00 = (1 + B1*B2)^-1 G0T = -(1 - G00)*B2^-1 - ! GT0 = B2 * G00 GTT = (1 + B2*B1)^-1 - - !( 1 V1*D1*U1 )^-1 ( ( V1 0 ) ( V1^-1 D1*U1 ) )^-1 - !(-U2*D2*V2 1 ) == ( ( 0 U2 ) * (-D2*V2 U2^-1 ) ) == I - ! You should transpose before carrying out the singular value decomposition - ! - ! - ! ( ( V1 0 ) ( V1^-1 D1*U1 )^*^* )^-1 ( V1^-1 0 ) - ! I == ( ( 0 U2 ) * (-D2*V2 U2^-1 ) ) = (UDV^*)^(-1) * ( 0 U2^-1) = - ! - ! ( V1^-1 0 ) - ! == U * D^(*,-1) * V^(*,-1) * ( 0 U2^-1) - - ! Let's see if this could work. - Use Precdef - Use MyMats - Use UDV_WRAP_mod - Implicit none - - ! Arguments - Integer, intent(in) :: LQ - Complex (Kind=double), intent(in) :: U1(LQ,LQ), V1(LQ,LQ), U2(LQ,LQ), V2(LQ,LQ) - Complex (Kind=double), intent(in) :: D2(LQ), D1(LQ) - Complex (Kind=double), intent(inout) :: GRT0(LQ,LQ), GR0T(LQ,LQ), GR00(LQ,LQ), GRTT(LQ,LQ) - - - ! Local:: - Complex (Kind=double) :: U3B(2*LQ,2*LQ), V3B(2*LQ,2*LQ), HLPB1(2*LQ,2*LQ), HLPB2(2*LQ,2*LQ), & - & V2INV(LQ,LQ), V1INV(LQ,LQ), HLP2(LQ,LQ) - Complex (Kind=double) :: D3B(2*LQ) - Complex (Kind=double) :: Z - Real (Kind=double) :: X, Xmax - - Integer :: LQ2, I,J, M, ILQ, JLQ, NCON, I1, J1,N - - LQ2 = LQ*2 - NCON = 0 - - If (dble(D1(1)) > dble(D2(1)) ) Then - - !Write(6,*) "D1(1) > D2(1)", dble(D1(1)), dble(D2(1)) - - HLPB2 = cmplx(0.D0,0.d0,double) - CALL INV(V1,V1INV,Z) - DO J = 1,LQ - DO I = 1,LQ - HLPB2(I , J ) = V1INV(I,J) - HLPB2(I , J+LQ ) = D1(I)*U1(I,J) - HLPB2(I+LQ, J+LQ ) = Conjg(U2(J,I)) - HLPB2(I+LQ, J ) = -D2(I)*V2(I,J) - ENDDO - ENDDO - DO J = 1,LQ2 - DO I = 1,LQ2 - HLPB1(I,J) = Conjg(HLPB2(J,I)) - ENDDO - ENDDO - - !CALL UDV_wrap(HLPB1,U3B,D3B,V3B,NCON) - CALL UDV_wrap_Pivot(HLPB1,U3B,D3B,V3B,NCON,LQ2,LQ2) - -!!$!!!!!!!!!!!!! Tests -!!$ Xmax = 0.d0 -!!$ DO I = 1,LQ2 -!!$ DO J = 1,LQ2 -!!$ Z = cmplx(0.d0,0.d0) -!!$ DO N = 1,LQ2 -!!$ Z = Z + U3B(I,N) *conjg(U3B(J,N)) -!!$ ENDDO -!!$ if (I == J) Z = Z - cmplx(1.d0,0.d0) -!!$ X = real(SQRT( Z* conjg(Z)),kind=8) -!!$ if (X > Xmax) Xmax = X -!!$ ENDDO -!!$ ENDDO -!!$ !Write(6,*) 'Cgr2_2, ortho: ', Xmax -!!$ DO I = 1,LQ2 -!!$ Z = D3B(I) -!!$ if (I == 1) Xmax = real(SQRT( Z* conjg(Z)),kind=8) -!!$ if ( real(SQRT( Z* conjg(Z)),kind=8) < Xmax ) Xmax = & -!!$ & real(SQRT( Z* conjg(Z)),kind=8) -!!$ ENDDO -!!$ !Write(6,*) 'Cgr2_2, Cutoff: ', Xmax -!!$!!!!!!!!!!!!! End Tests - DO J = 1,LQ2 - DO I = 1,LQ2 - HLPB2(I,J) = Conjg(V3B(J,I)) - ENDDO - ENDDO - CALL INV(HLPB2,V3B,Z) - HLPB1 = cmplx(0.d0,0.d0,double) - DO I = 1,LQ - DO J = 1,LQ - HLPB1(I , J ) = V1INV(I,J) - HLPB1(I+LQ, J+LQ ) = Conjg(U2(J,I)) - ENDDO - ENDDO - CALL MMULT(HLPB2,V3B,HLPB1) - DO J = 1,LQ2 - DO I = 1,LQ2 - HLPB1(I,J) = Conjg(cmplx(1.d0,0.d0,double)/D3B(I))*HLPB2(I,J) - ENDDO - ENDDO - CALL MMULT(HLPB2,U3B,HLPB1) - DO I = 1,LQ - I1 = I+LQ - DO J = 1,LQ - J1 = J + LQ - GR00(I,J) = HLPB2(I ,J ) - GRTT(I,J) = HLPB2(I1,J1) - GRT0(I,J) = HLPB2(I1,J ) - GR0T(I,J) = HLPB2(I,J1 ) - ENDDO - ENDDO - Else - !Write(6,*) "D1(1) < D2(1)", dble(D1(1)), dble(D2(1)) - HLPB2 = cmplx(0.D0,0.d0,double) - CALL INV(V1,V1INV,Z) - DO J = 1,LQ - DO I = 1,LQ - HLPB2(I , J ) = Conjg(U2(J,I)) - HLPB2(I , J+LQ ) = -D2(I)*V2(I,J) - HLPB2(I+LQ, J+LQ ) = V1INV(I,J) - HLPB2(I+LQ, J ) = D1(I)*U1(I,J) - ENDDO - ENDDO - DO J = 1,LQ2 - DO I = 1,LQ2 - HLPB1(I,J) = Conjg(HLPB2(J,I)) - ENDDO - ENDDO - - !CALL UDV_wrap(HLPB1,U3B,D3B,V3B,NCON) - CALL UDV_wrap_Pivot(HLPB1,U3B,D3B,V3B,NCON,LQ2,LQ2) - - DO J = 1,LQ2 - DO I = 1,LQ2 - HLPB2(I,J) = Conjg(V3B(J,I)) - ENDDO - ENDDO - CALL INV(HLPB2,V3B,Z) - HLPB1 = cmplx(0.d0,0.d0,double) - DO I = 1,LQ - DO J = 1,LQ - HLPB1(I , J ) = Conjg(U2(J,I)) - HLPB1(I+LQ, J+LQ ) = V1INV(I,J) - ENDDO - ENDDO - CALL MMULT(HLPB2,V3B,HLPB1) - DO J = 1,LQ2 - DO I = 1,LQ2 - HLPB1(I,J) = Conjg(cmplx(1.d0,0.d0,double)/D3B(I))*HLPB2(I,J) - ENDDO - ENDDO - CALL MMULT(HLPB2,U3B,HLPB1) - DO I = 1,LQ - I1 = I+LQ - DO J = 1,LQ - J1 = J + LQ - GRTT(I,J) = HLPB2(I ,J ) - GR00(I,J) = HLPB2(I1,J1) - GR0T(I,J) = HLPB2(I1,J ) - GRT0(I,J) = HLPB2(I,J1 ) - ENDDO - ENDDO - Endif - - END SUBROUTINE CGR2_2 diff --git a/Prog_7/control_mod.f90 b/Prog_7/control_mod.f90 deleted file mode 100644 index ba1b18a04..000000000 --- a/Prog_7/control_mod.f90 +++ /dev/null @@ -1,142 +0,0 @@ - module Control - - Use MyMats - Implicit none - - real (Kind=8) , private, save :: XMEANG, XMAXG, XMAXP, CPU_time_st, CPU_time_en, Xmean_tau, Xmax_tau - Integer , private, save :: NCG, NCG_tau - Integer (Kind=8), private, save :: NC_up, ACC_up - - Contains - - subroutine control_init - Implicit none - XMEANG = 0.d0 - XMEAN_tau = 0.d0 - XMAXG = 0.d0 - XMAX_tau = 0.d0 - NCG = 0 - NCG_tau = 0 - NC_up = 0 - ACC_up = 0 - Call CPU_TIME(CPU_time_st) - end subroutine control_init - - Subroutine Control_upgrade(Log) - Implicit none - Logical :: Log - NC_up = NC_up + 1 - if (Log) ACC_up = ACC_up + 1 - end Subroutine Control_upgrade - - Subroutine Control_PrecisionG(A,B,Ndim) - Implicit none - - Integer :: Ndim - Complex (Kind=8) :: A(Ndim,Ndim), B(Ndim,Ndim) - Real (Kind=8) :: XMAX, XMEAN - - !Local - NCG = NCG + 1 - XMEAN = 0.d0 - XMAX = 0.d0 - CALL COMPARE(A, B, XMAX, XMEAN) - IF (XMAX > XMAXG) XMAXG = XMAX - XMEANG = XMEANG + XMEAN - !Write(6,*) 'Control', XMEAN, XMAX - End Subroutine Control_PrecisionG - - Subroutine Control_Precision_tau(A,B,Ndim) - Implicit none - - Integer :: Ndim - Complex (Kind=8) :: A(Ndim,Ndim), B(Ndim,Ndim) - Real (Kind=8) :: XMAX, XMEAN - - !Local - NCG_tau = NCG_tau + 1 - XMEAN = 0.d0 - XMAX = 0.d0 - CALL COMPARE(A, B, XMAX, XMEAN) - IF (XMAX > XMAX_tau) XMAX_tau = XMAX - XMEAN_tau = XMEAN_tau + XMEAN - !Write(6,*) 'Control_tau', XMEAN, XMAX - End Subroutine Control_Precision_tau - - - Subroutine Control_PrecisionP(Z,Z1) - Implicit none - Complex (Kind=8), INTENT(IN) :: Z,Z1 - Real (Kind=8) :: X - X = sqrt(dble((Z-Z1)*conjg(Z-Z1))) - if ( X > XMAXP ) XMAXP = X - End Subroutine Control_PrecisionP - - - Subroutine control_Print - Implicit none -#include "machine" -#ifdef MPI - include 'mpif.h' -#endif - Real (Kind=8) :: Time, Acc -#ifdef MPI - REAL (KIND=8) :: X - Integer :: Ierr, Isize, Irank - INTEGER :: STATUS(MPI_STATUS_SIZE) - CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) - CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) -#endif - - ACC = 0.d0 - IF (NC_up > 0 ) ACC = dble(ACC_up)/dble(NC_up) - Call CPU_TIME(CPU_time_en) - Time = CPU_time_en - CPU_time_st -#ifdef MPI - X = 0.d0 - CALL MPI_REDUCE(XMEANG,X,1,MPI_REAL8,MPI_SUM, 0,MPI_COMM_WORLD,IERR) - XMEANG = X/dble(Isize) - X = 0.d0 - CALL MPI_REDUCE(XMEAN_tau,X,1,MPI_REAL8,MPI_SUM, 0,MPI_COMM_WORLD,IERR) - XMEAN_tau = X/dble(Isize) - X = 0.d0 - CALL MPI_REDUCE(ACC,X,1,MPI_REAL8,MPI_SUM, 0,MPI_COMM_WORLD,IERR) - ACC = X/dble(Isize) - - X = 0.d0 - CALL MPI_REDUCE(Time,X,1,MPI_REAL8,MPI_SUM, 0,MPI_COMM_WORLD,IERR) - Time = X/dble(Isize) - - - CALL MPI_REDUCE(XMAXG,X,1,MPI_REAL8,MPI_MAX, 0,MPI_COMM_WORLD,IERR) - XMAXG = X - CALL MPI_REDUCE(XMAX_tau,X,1,MPI_REAL8,MPI_MAX, 0,MPI_COMM_WORLD,IERR) - XMAX_tau= X - - - CALL MPI_REDUCE(XMAXP,X,1,MPI_REAL8,MPI_MAX, 0,MPI_COMM_WORLD,IERR) - XMAXP = X - If (Irank == 0 ) then -#endif - - Open (Unit=50,file="info", status="unknown", position="append") - If (NCG > 0 ) then - XMEANG = XMEANG/dble(NCG) - Write(50,*) ' Precision Green Mean, Max : ', XMEANG, XMAXG - Write(50,*) ' Precision Phase, Max : ', XMAXP - endif - If ( NCG_tau > 0 ) then - XMEAN_tau = XMEAN_tau/dble(NCG_tau) - Write(50,*) ' Precision tau Mean, Max : ', XMEAN_tau, XMAX_tau - endif - Write(50,*) ' Acceptance : ', ACC - Write(50,*) ' CPU Time : ', Time - Close(50) -#ifdef MPI - endif -#endif - end Subroutine Control_Print - - end module control - - diff --git a/Prog_7/gperp.f90 b/Prog_7/gperp.f90 deleted file mode 100644 index acb61d3c2..000000000 --- a/Prog_7/gperp.f90 +++ /dev/null @@ -1,98 +0,0 @@ - Subroutine Gperp_sub( G, Gperp, Ndim,Irank) - - Use Precdef - Use MyMats - Implicit none - - ! Arguments - Integer, Intent(In) :: Ndim, Irank - Complex (kind=double), Intent(In) :: G(ndim,ndim) - Complex (kind=double), Intent(InOut) :: Gperp(ndim,ndim) - - ! Local space - Complex (Kind=double) :: A(ndim,ndim), W(ndim), VL(Ndim,ndim), VR(Ndim,ndim) - Character (len=1) :: JOBVL, JOBVR - Integer :: INFO, LDA, LDVL, LDVR, N, lp, LWORK, N_c,m, i, j, NCon - Complex (Kind=double) :: WORK(2*Ndim), U(Ndim,Ndim/2), Vec(Ndim),Z - Real (Kind=double) :: RWORK(2*ndim), X, Xmax, Xmean - Complex (Kind=double) :: U1(Ndim,Ndim/2), V(Ndim/2,Ndim/2), D(Ndim/2) - - - A = G - JOBVL = "N" - JOBVR = "V" - LDA = Ndim - LWORK = 2*Ndim - LDVL = Ndim - LDVR = Ndim - N = Ndim - - Call ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO ) - - !lp = 70 + Irank - !Write(lp,*) "Info: ", INFO - N_c = 0 - do n = 1,Ndim - !Write(lp,*) n, W(n) - if ( abs( dble(W(n)) ) < 0.00001 ) then - N_c = N_c + 1 - do i = 1,Ndim - U1(i,N_c) = VR(i,n) - enddo - endif - enddo - !Write(6,*) "N_c ", N_c - NCON = 0 - Call UDV (U1,U,D,V,NCON) - - ! Setpup G_perp - gperp = cmplx(0.d0,0.d0) - Do i = 1,Ndim - do j = 1,Ndim - do n = 1,Ndim/2 - Gperp(i,j) = Gperp(i,j) + U(i,n) * conjg( U(j,n) ) - enddo - enddo - enddo - -#ifdef Test_gperp - X = 0.05 - A = cmplx(1.d0-X,0.d0) * G + cmplx(x,0.d0)*Gperp - Call Inv(A,VR,Z) - Write(lp,*) "Det is ", Z - Call MMult(VL,A,VR) - VR = cmplx(0.d0,0.d0) - do i = 1,Ndim - VR(I,I) = cmplx(1.d0,0.d0) - enddo - Call Compare(VL,VR,Xmax,Xmean) - Write(lp,*) 'Compare: ', Xmax, Xmean - - ! This is for testing - do n = 1,N_c - Vec = cmplx(0.d0,0.d0) - do i = 1,Ndim - do j = 1,Ndim - Vec(i) = Vec(i) + G(i,j) * U(j,n) - enddo - enddo - X = 0.d0 - do i = 1,Ndim - X = X + dble( Vec(i) * conjg(Vec(i))) - enddo - X = sqrt(x) - Write(lp,*) 'n, G*v = ', n, X - enddo - - do n = 1,N_c - do m = n,N_c - Z = cmplx(0.d0,0.d0) - do j = 1,Ndim - Z = Z + Conjg(U(j,m)) * U(j,n) - enddo - Write(lp,*) "n,m,z ", n,m,z - enddo - enddo -#endif - - end Subroutine Gperp_sub diff --git a/Prog_7/inconfc.f90 b/Prog_7/inconfc.f90 deleted file mode 100644 index 97dffc123..000000000 --- a/Prog_7/inconfc.f90 +++ /dev/null @@ -1,126 +0,0 @@ - SUBROUTINE confin - - Use Hamiltonian - - Implicit none - -#include "machine" - - - -#ifdef MPI - INCLUDE 'mpif.h' - ! Local -#endif - - Integer :: I, IERR, ISIZE, IRANK, seed_in, K, iseed, Nt - Integer, dimension(:), allocatable :: Seed_vec - Real (Kind=8) :: X - Logical :: lconf - character (len=64) :: file_sr, File_tg - -#ifdef MPI - INTEGER :: STATUS(MPI_STATUS_SIZE) - CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) - CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) -#endif - - Allocate (Nsigma(Size(Op_V,1),Ltrot)) - -#ifdef MPI - INQUIRE (FILE='confin_0', EXIST=lconf) - If (lconf) Then - file_sr = "confin" - Call Get_seed_Len(K) - Allocate(Seed_vec(K)) - file_tg = File_i(file_sr,IRANK) - Open (Unit = 10, File=File_tg, status='old', ACTION='read') - Read(10,*) Seed_vec - Call Ranset(Seed_vec) - do NT = 1,LTROT - do I = 1,Size(Op_V,1) - Read(10,*) NSIGMA(I,NT) - enddo - enddo - close(10) - Deallocate(Seed_vec) - else - If (Irank == 0) then - Write(6,*) 'No initial configuration' - OPEN(UNIT=5,FILE='seeds',STATUS='old',ACTION='read',IOSTAT=ierr) - IF (ierr /= 0) THEN - WRITE(*,*) 'unable to open ',ierr - STOP - END IF - DO I = Isize-1,1,-1 - Read (5,*) Seed_in - CALL MPI_SEND(Seed_in,1,MPI_INTEGER, I, I+1024,MPI_COMM_WORLD,IERR) - enddo - Read(5,*) Seed_in - CLOSE(5) - else - CALL MPI_RECV(Seed_in, 1, MPI_INTEGER,0, IRANK + 1024, MPI_COMM_WORLD,STATUS,IERR) - endif - Call Get_seed_Len(K) - !Write(6,*) K - Allocate(Seed_vec(K)) - Do I = 1,K - X = Ranf_Imada(Seed_in) - Seed_vec(I) = Seed_in - enddo - Call Ranset(Seed_vec) - Deallocate(Seed_vec) - do NT = 1,LTROT - do I = 1,Size(Op_V,1) - X = RANF() - NSIGMA(I,NT) = 1 - IF (X.GT.0.5) NSIGMA(I,NT) = -1 - enddo - enddo - endif - -#else - INQUIRE (FILE='confin_0', EXIST=lconf) - If (lconf) Then - file_tg = "confin_0" - Call Get_seed_Len(K) - Allocate(Seed_vec(K)) - Open (Unit = 10, File=File_tg, status='old', ACTION='read') - Read(10,*) Seed_vec - Call Ranset(Seed_vec) - do NT = 1,LTROT - do I = 1,Size(Op_V,1) - Read(10,*) NSIGMA(I,NT) - enddo - enddo - close(10) - Deallocate(Seed_vec) - else - Write(6,*) 'No initial configuration' - OPEN(UNIT=5,FILE='seeds',STATUS='old',ACTION='read',IOSTAT=ierr) - IF (ierr /= 0) THEN - WRITE(*,*) 'unable to open ',ierr - STOP - END IF - Read (5,*) Seed_in - CLOSE(5) - Call Get_seed_Len(K) - !Write(6,*) K - Allocate(Seed_vec(K)) - Do I = 1,K - X = Ranf_Imada(Seed_in) - Seed_vec(I) = Seed_in - enddo - Call Ranset(Seed_vec) - Deallocate(Seed_vec) - do NT = 1,LTROT - do I = 1,Size(Op_V,1) - X = RANF() - NSIGMA(I,NT) = 1 - IF (X.GT.0.5) NSIGMA(I,NT) = -1 - enddo - enddo - endif -#endif - - END SUBROUTINE CONFIN diff --git a/Prog_7/machine b/Prog_7/machine deleted file mode 100644 index 2e1fc39e2..000000000 --- a/Prog_7/machine +++ /dev/null @@ -1 +0,0 @@ -#define noMPI diff --git a/Prog_7/main.f90 b/Prog_7/main.f90 deleted file mode 100644 index bd810ccd1..000000000 --- a/Prog_7/main.f90 +++ /dev/null @@ -1,449 +0,0 @@ -Program Main - - Use Operator_mod - Use Lattices_v3 - Use MyMats - Use Hamiltonian - Use Control - Use Tau_m_mod - Use Hop_mod - Implicit none -#include "machine" -#ifdef MPI - include 'mpif.h' -#endif - - - Interface - SUBROUTINE WRAPUL(NTAU1, NTAU, UL ,DL, VL) - Use Hamiltonian - Implicit none - COMPLEX (KIND=8) :: UL(Ndim,Ndim,N_FL), VL(Ndim,Ndim,N_FL) - COMPLEX (KIND=8) :: DL(Ndim,N_FL) - Integer :: NTAU1, NTAU - END SUBROUTINE WRAPUL - SUBROUTINE CGR(PHASE,NVAR, GRUP, URUP,DRUP,VRUP, ULUP,DLUP,VLUP) - Use UDV_Wrap_mod - Implicit None - COMPLEX(Kind=8), Dimension(:,:), Intent(In) :: URUP, VRUP, ULUP, VLUP - COMPLEX(Kind=8), Dimension(:), Intent(In) :: DLUP, DRUP - COMPLEX(Kind=8), Dimension(:,:), Intent(Inout) :: GRUP - COMPLEX(Kind=8) :: PHASE - INTEGER :: NVAR - END SUBROUTINE CGR - SUBROUTINE WRAPGRUP(GR,NTAU,PHASE) - Use Hamiltonian - Implicit none - COMPLEX (Kind=8), INTENT(INOUT) :: GR(Ndim,Ndim,N_FL) - COMPLEX (Kind=8), INTENT(INOUT) :: PHASE - INTEGER, INTENT(IN) :: NTAU - END SUBROUTINE WRAPGRUP - SUBROUTINE WRAPGRDO(GR,NTAU,PHASE) - Use Hamiltonian - Implicit None - COMPLEX (Kind=8), INTENT(INOUT) :: GR(NDIM,NDIM,N_FL) - COMPLEX (Kind=8), INTENT(INOUT) :: PHASE - Integer :: NTAU - end SUBROUTINE WRAPGRDO - SUBROUTINE WRAPUR(NTAU, NTAU1, UR, DR, VR) - Use Hamiltonian - Use UDV_Wrap_mod - Implicit None - COMPLEX (KIND=8) :: UR(Ndim,Ndim,N_FL), VR(Ndim,Ndim,N_FL) - COMPLEX (KIND=8) :: DR(Ndim,N_FL) - Integer :: NTAU1, NTAU - END SUBROUTINE WRAPUR - - end Interface - - COMPLEX (Kind=8), Dimension(:) , Allocatable :: D - COMPLEX (KIND=8), Dimension(:,:) , Allocatable :: TEST, A, U, V - - COMPLEX (Kind=8), Dimension(:,:) , Allocatable :: DL, DR - COMPLEX (Kind=8), Dimension(:,:,:), Allocatable :: UL, VL, UR, VR - COMPLEX (Kind=8), Dimension(:,:,:), Allocatable :: GR - - - Integer :: Nwrap, NSweep, NBin, Ltau, NSTM, NT, NT1, NVAR, LOBS_EN, LOBS_ST, NBC, NSW - Integer :: NTAU, NTAU1 - - NAMELIST /VAR_QMC/ Nwrap, NSweep, NBin, Ltau, LOBS_EN, LOBS_ST - - Integer :: Ierr, I,J,nf, nst, n - Complex (Kind=8) :: Z_ONE = cmplx(1.d0,0.d0), Phase, Z, Z1 - - ! Space for storage. - COMPLEX (Kind=8), Dimension(:,:,:) , Allocatable :: DST - COMPLEX (Kind=8), Dimension(:,:,:,:), Allocatable :: UST, VST - - ! For tests - Integer, external :: nranf - Real (kind=8) :: Weight - Integer :: nr,nth - Logical :: Log -#ifdef MPI - Integer :: Isize, Irank - INTEGER :: STATUS(MPI_STATUS_SIZE) - CALL MPI_INIT(ierr) - CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) - CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) -#endif - - ! Write(6,*) 'Call Ham_set' - Call Ham_set - ! Write(6,*) 'End Call Ham_set' - Call confin - Call Hop_mod_init - !Call Hop_mod_test - !stop - -#ifdef MPI - If ( Irank == 0 ) then -#endif - OPEN(UNIT=5,FILE='parameters',STATUS='old',ACTION='read',IOSTAT=ierr) - IF (ierr /= 0) THEN - WRITE(*,*) 'unable to open ',ierr - STOP - END IF - READ(5,NML=VAR_QMC) - CLOSE(5) -#ifdef MPI - Endif - CALL MPI_BCAST(Nwrap ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(NSweep ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(NBin ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(Ltau ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(LOBS_EN ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(LOBS_ST ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) -#endif - - - Call control_init - Call Alloc_obs(Ltau) - Call Op_SetHS - - -!!$#ifdef Ising_test -!!$ ! Test Ising -!!$ DO NBC = 1, NBIN -!!$ Call Init_obs -!!$ DO NSW = 1, NSWEEP -!!$ do nth = 1,Ltrot*2*Latt%N -!!$ Nt = nranf(Ltrot) -!!$ Nr = nranf(2*Latt%N) -!!$ Weight = S0(nr,nt) -!!$ log =.false. -!!$ if (Weight > ranf()) then -!!$ nsigma(nr,nt) = - nsigma(nr,nt) -!!$ log =.true. -!!$ endif -!!$ Call Control_upgrade(log) -!!$ enddo -!!$ Call Obser -!!$ Enddo -!!$ Call Preq -!!$ Enddo -!!$ Call Ham_confout -!!$ Call control_Print -!!$ Stop -!!$ ! End Test Ising -!!$#endif - - Allocate( DL(NDIM,N_FL), DR(NDIM,N_FL) ) - Allocate( UL(NDIM,NDIM,N_FL), VL(NDIM,NDIM,N_FL), & - & UR(NDIM,NDIM,N_FL), VR(NDIM,NDIM,N_FL), GR(NDIM,NDIM,N_FL ) ) - NSTM = LTROT/NWRAP -#ifdef MPI - if ( Irank == 0 ) then -#endif - Open (Unit = 50,file="info",status="unknown",position="append") - Write(50,*) 'Sweeps : ', Nsweep - Write(50,*) 'Bin : ', NBin - Write(50,*) 'Measure Int. : ', LOBS_ST, LOBS_EN - Write(50,*) 'Stabilization,Wrap : ', Nwrap - Write(50,*) 'Nstm : ', NSTM - Write(50,*) 'Ltau : ', Ltau - close(50) -#ifdef MPI - endif -#endif - - Allocate ( UST(NDIM,NDIM,NSTM,N_FL), VST(NDIM,NDIM,NSTM,N_FL), DST(NDIM,NSTM,N_FL) ) - Allocate ( Test(Ndim,Ndim) ) - - NST = NINT( DBLE(LTROT)/DBLE(NWRAP) ) - !Write(6,*) "Write UL ", NST - Do nf = 1,N_FL - CALL INITD(UL(:,:,Nf),Z_ONE) - do I = 1,Ndim - DL(I,Nf) = Z_ONE - enddo - CALL INITD(VL(:,:,nf),Z_ONE) - DO I = 1,NDim - DO J = 1,NDim - UST(I,J,NST,nf) = UL(I,J,nf) - VST(I,J,NST,nf) = VL(I,J,nf) - ENDDO - ENDDO - DO I = 1,NDim - DST(I,NST,nf) = DL(I,nf) - ENDDO - - CALL INITD(UR(:,:,nf),Z_ONE) - CALL INITD(VR(:,:,nf),Z_ONE) - Do I = 1,Ndim - DR(I,nf) = Z_ONE - Enddo - Enddo - - DO NT = LTROT-NWRAP,NWRAP,-1 - IF ( MOD(NT,NWRAP) == 0 ) THEN - NT1 = NT + NWRAP - !Write(6,*) 'Calling Wrapul:', NT1,NT - CALL WRAPUL(NT1,NT,UL,DL, VL) - NST = NINT( DBLE(NT)/DBLE(NWRAP) ) - !Write(6,*) "Write UL ", NST - Do nf = 1,N_FL - DO I = 1,Ndim - DO J = 1,Ndim - UST(I,J,NST,nf) = UL(I,J,nf) - VST(I,J,NST,nf) = VL(I,J,nf) - ENDDO - ENDDO - DO I = 1,Ndim - DST(I,NST,nf) = DL(I,nf) - ENDDO - ENDDO - ENDIF - ENDDO - CALL WRAPUL(NWRAP,0, UL ,DL, VL) - - !WRITE(6,*) 'Filling up storage' - !Write(6,*) 'Done wrapping' - NVAR = 1 - Phase = cmplx(1.d0,0.d0) - do nf = 1,N_Fl - CALL CGR(Z, NVAR, GR(:,:,nf), UR(:,:,nf),DR(:,nf),VR(:,:,nf), UL(:,:,nf),DL(:,nf),VL(:,:,nf) ) - Phase = Phase*Z - Enddo - call Op_phase(Phase,OP_V,Nsigma,N_SUN) -#ifdef MPI - WRITE(6,*) 'Phase is: ', Irank, PHASE, GR(1,1,1) -#else - WRITE(6,*) 'Phase is: ', PHASE -!!$ if (N_FL == 1) then -!!$ Do n = 1,Ndim -!!$ Write(6,*) GR(1,n,1) -!!$ enddo -!!$ else -!!$ Do n = 1,Ndim -!!$ Write(6,*) GR(1,n,1), GR(1,n,2) -!!$ enddo -!!$ endif -#endif - - Call Control_init - - DO NBC = 1, NBIN - ! Here, you have the green functions on time slice 1. - ! Set bin observables to zero. - - Call Init_obs(Ltau) - DO NSW = 1, NSWEEP - - !Propagation from 1 to Ltrot - !Set the right storage to 1 - - do nf = 1,N_FL - CALL INITD(UR(:,:,nf),Z_ONE) - CALL INITD(VR(:,:,nf),Z_ONE) - do n = 1,Ndim - DR(n,nf)= Z_ONE - Enddo - Enddo - - DO NTAU = 0, LTROT-1 - NTAU1 = NTAU + 1 - !Write(6,*) "Hi" - CALL WRAPGRUP(GR,NTAU,PHASE) - !Write(6,*) "Hi1" - IF ( MOD(NTAU1,NWRAP ) .EQ. 0 ) THEN - NST = NINT( DBLE(NTAU1)/DBLE(NWRAP) ) - NT1 = NTAU1 - NWRAP - CALL WRAPUR(NT1, NTAU1,UR, DR, VR) - Z = cmplx(1.d0,0.d0) - Do nf = 1, N_FL - DO J = 1,Ndim - DO I = 1,Ndim - UL(I,J,nf) = UST(I,J,NST,nf) - VL(I,J,nf) = VST(I,J,NST,nf) - ENDDO - ENDDO - DO I = 1,Ndim - DL(I,nf) = DST(I,NST,nf) - ENDDO - ! Write in store Right prop from 1 to LTROT/NWRAP - !Write(6,*) 'Write UR, read UL ', NTAU1, NST - DO J = 1,Ndim - DO I = 1,Ndim - UST(I,J,NST,nf) = UR(I,J,nf) - VST(I,J,NST,nf) = VR(I,J,nf) - ENDDO - ENDDO - DO I = 1,Ndim - DST(I,NST,nf) = DR(I,nf) - ENDDO - NVAR = 1 - IF (NTAU1 .GT. LTROT/2) NVAR = 2 - !Write(6,*) ' Call Cgr' - do J = 1,Ndim - do I = 1,Ndim - TEST(I,J) = GR(I,J,nf) - enddo - enddo - CALL CGR(Z1, NVAR, GR(:,:,nf), UR(:,:,nf),DR(:,nf),VR(:,:,nf),UL(:,:,nf),DL(:,nf),VL(:,:,nf) ) - Z = Z*Z1 - !Write(6,*) 'Calling control ',NTAU1, Z1 - Call Control_PrecisionG(GR(:,:,nf),Test,Ndim) - ENDDO - call Op_phase(Z,OP_V,Nsigma,N_SUN) - Call Control_PrecisionP(Z,Phase) - Phase = Z - ENDIF - - IF (NTAU1.GE. LOBS_ST .AND. NTAU1.LE. LOBS_EN ) THEN - !Write(6,*) 'Call obser ', Ntau1 - CALL Obser( GR, PHASE, Ntau1 ) - !Write(6,*) 'Return obser' - ENDIF - !Write(6,*) NTAU1 - ENDDO - - Do nf = 1,N_FL - CALL INITD(UL(:,:,nf),Z_ONE) - CALL INITD(VL(:,:,nf),Z_ONE) - Do n = 1,Ndim - DL(n,nf) = Z_ONE - Enddo - ENDDO - - DO NTAU = LTROT,1,-1 - NTAU1 = NTAU - 1 - CALL WRAPGRDO(GR,NTAU, PHASE) - IF (NTAU1.GE. LOBS_ST .AND. NTAU1.LE. LOBS_EN ) THEN - CALL Obser( GR, PHASE, Ntau1 ) - ENDIF - IF ( MOD(NTAU1,NWRAP).EQ.0 .AND. NTAU1.NE.0 ) THEN - ! WRITE(50,*) 'Recalc at :', NTAU1 - NST = NINT( DBLE(NTAU1)/DBLE(NWRAP) ) - NT1 = NTAU1 + NWRAP - !Write(6,*) 'Wrapul : ', NT1, NTAU1 - CALL WRAPUL(NT1,NTAU1, UL, DL, VL ) - !Write(6,*) 'Write UL, read UR ', NTAU1, NST - Z = cmplx(1.d0,0.d0) - do nf = 1,N_FL - DO J = 1,Ndim - DO I = 1,Ndim - UR(I,J,nf) = UST(I,J,NST,nf) - VR(I,J,nf) = VST(I,J,NST,nf) - ENDDO - ENDDO - DO I = 1,Ndim - DR(I,nf) = DST(I,NST,nf) - ENDDO - ! WRITE in store the left prop. from LTROT/NWRAP-1 to 1 - DO J = 1,Ndim - DO I = 1,Ndim - UST(I,J,NST,nf) = UL(I,J,nf) - VST(I,J,NST,nf) = VL(I,J,nf) - ENDDO - ENDDO - DO I = 1,Ndim - DST(I,NST,nf) = DL(I,nf) - ENDDO - NVAR = 1 - IF (NTAU1 .GT. LTROT/2) NVAR = 2 - !Write(6,*) ' Call Cgr' - do J = 1,Ndim - do I = 1,Ndim - TEST(I,J) = GR(I,J,nf) - enddo - enddo - CALL CGR(Z1, NVAR, GR(:,:,nf), UR(:,:,nf),DR(:,nf),VR(:,:,nf), UL(:,:,nf),DL(:,nf),VL(:,:,nf) ) - Z = Z*Z1 - !Write(6,*) 'Calling control: ', NTAU1, Z1 - Call Control_PrecisionG(GR(:,:,nf),Test,Ndim) - ENDDO - call Op_phase(Z,OP_V,Nsigma,N_SUN) - Call Control_PrecisionP(Z,Phase) - Phase = Z - ENDIF - ENDDO - - !Calculate and compare green functions on time slice 0. - NT1 = 0 - CALL WRAPUL(NWRAP,NT1, UL, DL, VL ) - - do nf = 1,N_FL - CALL INITD(UR(:,:,nf),Z_ONE) - CALL INITD(VR(:,:,nf),Z_ONE) - DO I = 1,Ndim - DR(I,nf) = Z_ONE - ENDDO - ENDDO - Z = cmplx(1.d0,0.d0) - do nf = 1,N_FL - do J = 1,Ndim - do I = 1,Ndim - TEST(I,J) = GR(I,J,nf) - enddo - enddo - NVAR = 1 - CALL CGR(Z1, NVAR, GR(:,:,nf), UR(:,:,nf),DR(:,nf),VR(:,:,nf), UL(:,:,nf),DL(:,nf),VL(:,:,nf) ) - Z = Z*Z1 - !Write(6,*) 'Calling control 0', Z1 - Call Control_PrecisionG(GR(:,:,nf),Test,Ndim) - ENDDO - call Op_phase(Z,OP_V,Nsigma,N_SUN) - Call Control_PrecisionP(Z,Phase) - Phase = Z - NST = NINT( DBLE(LTROT)/DBLE(NWRAP) ) - Do nf = 1,N_FL - DO I = 1,Ndim - DO J = 1,Ndim - UST(I,J,NST,nf) = CMPLX(0.D0,0.D0) - VST(I,J,NST,nf) = CMPLX(0.D0,0.D0) - ENDDO - ENDDO - DO I = 1,Ndim - DST(I ,NST,nf) = CMPLX(1.D0,0.D0) - UST(I,I,NST,nf) = CMPLX(1.D0,0.D0) - VST(I,I,NST,nf) = CMPLX(1.D0,0.D0) - ENDDO - enddo - IF ( LTAU == 1 ) then -!!$#ifdef MPI -!!$ Write(6,*) Irank, 'Calling Tau_m', NWRAP, NSTM -!!$#else -!!$ Write(6,*) 'Calling Tau_m', NWRAP, NSTM -!!$#endif - - Call TAU_M( UST,DST,VST, GR, PHASE, NSTM, NWRAP ) -!!$#ifdef MPI -!!$ Write(6,*) Irank, 'Back Calling Tau_m' -!!$#else -!!$ Write(6,*) 'Back Calling Tau_m' -!!$#endif - endif - - ENDDO - Call Pr_obs(Ltau) - Call confout - Enddo - Call Control_Print - -#ifdef MPI - CALL MPI_FINALIZE(ierr) -#endif - -end Program Main diff --git a/Prog_7/nranf.f90 b/Prog_7/nranf.f90 deleted file mode 100644 index 4662b0f63..000000000 --- a/Prog_7/nranf.f90 +++ /dev/null @@ -1,12 +0,0 @@ - integer function nranf(N) - Use Random_wrap - implicit none - integer :: N - - nranf = nint(ranf()*dble(N) + 0.5) - - if (nranf .lt. 1 ) nranf = 1 - if (nranf .gt. N ) nranf = N - - end function nranf - diff --git a/Prog_7/outconfc.f90 b/Prog_7/outconfc.f90 deleted file mode 100644 index 1a8ec4e53..000000000 --- a/Prog_7/outconfc.f90 +++ /dev/null @@ -1,57 +0,0 @@ - SUBROUTINE confout - - Use Hamiltonian - - Implicit none - -#include "machine" - - -#ifdef MPI - INCLUDE 'mpif.h' - ! Local -#endif - - Integer :: I, IERR, ISIZE, IRANK, seed_in, K, iseed, Nt, nr - Integer, dimension(:), allocatable :: Seed_vec - Real (Kind=8) :: X - Logical :: lconf - character (len=64) :: file_sr, File_tg - -#ifdef MPI - INTEGER :: STATUS(MPI_STATUS_SIZE) - CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) - CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) - - Call Get_seed_Len(K) - Allocate(Seed_vec(K)) - Call Ranget(Seed_vec) - file_sr = "confout" - file_tg = File_i(file_sr,IRANK) - Open (Unit = 10, File=File_tg, status='unknown', ACTION='write') - Write(10,*) Seed_vec - do NT = 1,LTROT - do I = 1,Size(Nsigma,1) - write(10,*) NSIGMA(I,NT) - enddo - enddo - close(10) - Deallocate(Seed_vec) - -#else - Call Get_seed_Len(K) - Allocate(Seed_vec(K)) - Call Ranget(Seed_vec) - file_tg = "confout_0" - Open (Unit = 10, File=File_tg, status='unknown', ACTION='write') - Write(10,*) Seed_vec - do NT = 1,LTROT - do I = 1,Size(Nsigma,1) - write(10,*) Nsigma(I,NT) - enddo - enddo - close(10) - Deallocate(Seed_vec) -#endif - - END SUBROUTINE CONFOUT diff --git a/Prog_7/print_bin_mod.f90 b/Prog_7/print_bin_mod.f90 deleted file mode 100644 index 9f5297d0e..000000000 --- a/Prog_7/print_bin_mod.f90 +++ /dev/null @@ -1,296 +0,0 @@ - Module Print_bin_mod - - Interface Print_bin - module procedure Print_bin_C, Print_bin_R - end Interface Print_bin - - Interface Print_bin_tau - module procedure Print_bin_tau_C - end Interface Print_bin_tau - - Contains - - Subroutine Print_bin_C(Dat_eq,Dat_eq0,Latt, Nobs, Phase_bin, file_pr) - Use Lattices_v3 - Implicit none -#include "machine" -#ifdef MPI - include 'mpif.h' -#endif - - Complex (Kind=8), Dimension(:,:,:), Intent(inout):: Dat_eq - Complex (Kind=8), Dimension(:) , Intent(inout):: Dat_eq0 - Type (Lattice), Intent(In) :: Latt - Complex (Kind=8), Intent(Inout):: Phase_bin - Character (len=64), Intent(In) :: File_pr - Integer, Intent(In) :: Nobs - - ! Local - Integer :: Norb, I, no,no1 - Complex (Kind=8), allocatable :: Tmp(:,:,:), Tmp1(:) - Real (Kind=8) :: x_p(2) -#ifdef MPI - Complex (Kind=8):: Z - Integer :: Ierr, Isize, Irank - INTEGER :: STATUS(MPI_STATUS_SIZE) - CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) - CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) -#endif - - Norb = size(Dat_eq,3) - if ( .not. (Latt%N == Size(Dat_eq,1) ) ) then - Write(6,*) 'Error in Print_bin' - Stop - endif - Allocate (Tmp(Latt%N,Norb,Norb), Tmp1(Norb) ) - Dat_eq = Dat_eq/cmplx(dble(Nobs),0.d0) - Dat_eq0 = Dat_eq0/cmplx(dble(Nobs)*dble(Latt%N),0.d0) - -#ifdef MPI - I = Latt%N*Norb*Norb - Tmp = cmplx(0.d0,0.d0) - CALL MPI_REDUCE(Dat_eq,Tmp,I,MPI_COMPLEX16,MPI_SUM, 0,MPI_COMM_WORLD,IERR) - Dat_eq = Tmp/CMPLX(DBLE(ISIZE),0.D0) - I = 1 - CALL MPI_REDUCE(Phase_bin,Z,I,MPI_COMPLEX16,MPI_SUM, 0,MPI_COMM_WORLD,IERR) - Phase_bin= Z/CMPLX(DBLE(ISIZE),0.D0) - - I = Norb - CALL MPI_REDUCE(Dat_eq0,Tmp1,I,MPI_COMPLEX16,MPI_SUM, 0,MPI_COMM_WORLD,IERR) - Dat_eq0 = Tmp1/CMPLX(DBLE(ISIZE),0.D0) - - If (Irank == 0 ) then -#endif - do no = 1,Norb - do no1 = 1,Norb - Call Fourier_R_to_K(Dat_eq(:,no,no1), Tmp(:,no,no1), Latt) - enddo - enddo - Open (Unit=10,File=File_pr, status="unknown", position="append") - Write(10,*) dble(Phase_bin),Norb,Latt%N - do no = 1,Norb - Write(10,*) Dat_eq0(no) - enddo - do I = 1,Latt%N - x_p = dble(Latt%listk(i,1))*Latt%b1_p + dble(Latt%listk(i,2))*Latt%b2_p - Write(10,*) X_p(1), X_p(2) - do no = 1,Norb - do no1 = 1,Norb - Write(10,*) tmp(I,no,no1) - enddo - enddo - enddo - close(10) -#ifdef MPI - Endif -#endif - - deallocate (Tmp, tmp1 ) - - - End Subroutine Print_bin_C - - -!========================================================= - - Subroutine Print_bin_R(Dat_eq,Dat_eq0,Latt, Nobs, Phase_bin, file_pr) - Use Lattices_v3 - Implicit none -#include "machine" -#ifdef MPI - include 'mpif.h' -#endif - - Real (Kind=8), Dimension(:,:,:), Intent(inout) :: Dat_eq - Real (Kind=8), Dimension(:) , Intent(inout) :: Dat_eq0 - Type (Lattice), Intent(In) :: Latt - Complex (Kind=8), Intent(Inout) :: Phase_bin - Character (len=64), Intent(In) :: File_pr - Integer, Intent(In) :: Nobs - - ! Local - Integer :: Norb, I, no,no1 - Real (Kind=8), allocatable :: Tmp(:,:,:), Tmp1(:) - Real (Kind=8) :: x_p(2) -#ifdef MPI - Integer :: Ierr, Isize, Irank - Complex (Kind=8) :: Z - INTEGER :: STATUS(MPI_STATUS_SIZE) - CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) - CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) -#endif - - Norb = size(Dat_eq,3) - if ( .not. (Latt%N == Size(Dat_eq,1) ) ) then - Write(6,*) 'Error in Print_bin' - Stop - endif - Allocate (Tmp(Latt%N,Norb,Norb), Tmp1(Norb) ) - Dat_eq = Dat_eq/dble(Nobs) - Dat_eq0 = Dat_eq0/(dble(Nobs)*dble(Latt%N)) -#ifdef MPI - I = Latt%N*Norb*Norb - Tmp = 0.d0 - CALL MPI_REDUCE(Dat_eq,Tmp,I,MPI_REAL8,MPI_SUM, 0,MPI_COMM_WORLD,IERR) - Dat_eq = Tmp/DBLE(ISIZE) - I = 1 - CALL MPI_REDUCE(Phase_bin,Z,I,MPI_COMPLEX16,MPI_SUM, 0,MPI_COMM_WORLD,IERR) - Phase_bin= Z/CMPLX(DBLE(ISIZE),0.D0) - If (Irank == 0 ) then - - I = Norb - CALL MPI_REDUCE(Dat_eq0,Tmp1,I,MPI_REAL8,MPI_SUM, 0,MPI_COMM_WORLD,IERR) - Dat_eq0 = Tmp1/CMPLX(DBLE(ISIZE),0.D0) - -#endif - - do no = 1,Norb - do no1 = 1,Norb - Call Fourier_R_to_K(Dat_eq(:,no,no1), Tmp(:,no,no1), Latt) - enddo - enddo - Open (Unit=10,File=File_pr, status="unknown", position="append") - Write(10,*) dble(Phase_bin),Norb,Latt%N - do no = 1,Norb - Write(10,*) Dat_eq0(no) - enddo - do I = 1,Latt%N - x_p = dble(Latt%listk(i,1))*Latt%b1_p + dble(Latt%listk(i,2))*Latt%b2_p - Write(10,*) X_p(1), X_p(2) - do no = 1,Norb - do no1 = 1,Norb - Write(10,*) tmp(I,no,no1) - enddo - enddo - enddo - close(10) -#ifdef MPI - endif -#endif - deallocate (Tmp ) - - End Subroutine Print_bin_R -!============================================================ - Subroutine Print_scal(Obs, Nobs, file_pr) - - Implicit none -#include "machine" -#ifdef MPI - include 'mpif.h' -#endif - - Complex (Kind=8), Dimension(:), Intent(inout) :: Obs - Character (len=64), Intent(In) :: File_pr - Integer, Intent(In) :: Nobs - - ! Local - Integer :: Norb,I - Complex (Kind=8), allocatable :: Tmp(:) -#ifdef MPI - Integer :: Ierr, Isize, Irank - INTEGER :: STATUS(MPI_STATUS_SIZE) - CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) - CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) -#endif - - Norb = size(Obs,1) - Allocate ( Tmp(Norb) ) - Obs = Obs/cmplx(dble(Nobs),0.d0) -#ifdef MPI - Tmp = 0.d0 - CALL MPI_REDUCE(Obs,Tmp,Norb,MPI_COMPLEX16,MPI_SUM, 0,MPI_COMM_WORLD,IERR) - Obs = Tmp/cmplx(DBLE(ISIZE),0.d0) - if (Irank == 0 ) then -#endif - Open (Unit=10,File=File_pr, status="unknown", position="append") - WRITE(10,*) (Obs(I), I=1,size(Obs,1)) - close(10) -#ifdef MPI - endif -#endif - deallocate (Tmp ) - - End Subroutine Print_scal - -!============================================================== - Subroutine Print_bin_tau_C(Dat_tau,Latt, Nobs, Phase_bin, file_pr, dtau) - Use Lattices_v3 - Implicit none -#include "machine" -#ifdef MPI - include 'mpif.h' -#endif - - Complex (Kind=8), Dimension(:,:,:,:), Intent(inout):: Dat_tau - Type (Lattice), Intent(In) :: Latt - Complex (Kind=8), Intent(In) :: Phase_bin - Character (len=64), Intent(In) :: File_pr - Integer, Intent(In) :: Nobs - Real (kind=8), Intent(In) :: dtau - - ! Local - Integer :: Norb, I, no,no1, LT, nt - Complex (Kind=8), allocatable :: Tmp(:,:,:,:) - Complex (Kind=8) :: Phase_mean - Real (Kind=8) :: x_p(2) -#ifdef MPI - Complex (Kind=8):: Z - Integer :: Ierr, Isize, Irank - INTEGER :: STATUS(MPI_STATUS_SIZE) - CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) - CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) -#endif - - Phase_mean = Phase_bin - Norb = size(Dat_tau,3) - if ( .not. (Latt%N == Size(Dat_tau,1) ) ) then - Write(6,*) 'Error in Print_bin' - Stop - endif - LT = Size(Dat_tau,2) - Allocate (Tmp(Latt%N,LT,Norb,Norb) ) - Dat_tau = Dat_tau/cmplx(dble(Nobs),0.d0) - -#ifdef MPI - I = Latt%N*Norb*Norb*LT - Tmp = cmplx(0.d0,0.d0) - CALL MPI_REDUCE(Dat_tau,Tmp,I,MPI_COMPLEX16,MPI_SUM, 0,MPI_COMM_WORLD,IERR) - Dat_tau = Tmp/CMPLX(DBLE(ISIZE),0.D0) - I = 1 - CALL MPI_REDUCE(Phase_mean,Z,I,MPI_COMPLEX16,MPI_SUM, 0,MPI_COMM_WORLD,IERR) - Phase_mean= Z/CMPLX(DBLE(ISIZE),0.D0) - If (Irank == 0 ) then -#endif - do nt = 1,LT - do no = 1,Norb - do no1 = 1,Norb - Call Fourier_R_to_K(Dat_tau(:,nt,no,no1), Tmp(:,nt,no,no1), Latt) - enddo - enddo - enddo - Open (Unit=10,File=File_pr, status="unknown", position="append") - Write(10,*) dble(Phase_mean),Norb,Latt%N, LT, dtau - do I = 1,Latt%N - x_p = dble(Latt%listk(i,1))*Latt%b1_p + dble(Latt%listk(i,2))*Latt%b2_p - Write(10,*) X_p(1), X_p(2) - Do nt = 1,LT - do no = 1,Norb - do no1 = 1,Norb - Write(10,*) tmp(I,nt,no,no1) - enddo - enddo - enddo - enddo - close(10) -#ifdef MPI - Endif -#endif - - deallocate (Tmp ) - - - End Subroutine Print_bin_tau_C - - - - end Module Print_bin_mod diff --git a/Prog_7/tau_m.f90 b/Prog_7/tau_m.f90 deleted file mode 100644 index b1056e18d..000000000 --- a/Prog_7/tau_m.f90 +++ /dev/null @@ -1,236 +0,0 @@ - Module Tau_m_mod - - Use Hamiltonian - Use Operator_mod - Use Precdef - Use Control - Use Hop_mod - - Contains - - SUBROUTINE TAU_M( UST,DST,VST, GR, PHASE, NSTM, NWRAP ) - - Implicit none - - Interface - SUBROUTINE WRAPUL(NTAU1, NTAU, UL ,DL, VL) - Use Hamiltonian - Implicit none - COMPLEX (KIND=8) :: UL(Ndim,Ndim,N_FL), VL(Ndim,Ndim,N_FL) - COMPLEX (KIND=8) :: DL(Ndim,N_FL) - Integer :: NTAU1, NTAU - END SUBROUTINE WRAPUL - SUBROUTINE CGR2_2(GRT0, GR00, GRTT, GR0T, U2, D2, V2, U1, D1, V1, LQ) - Use Precdef - Use MyMats - Use UDV_WRAP_mod - Implicit none - - ! Arguments - Integer, intent(in) :: LQ - Complex (Kind=double), intent(in) :: U1(LQ,LQ), V1(LQ,LQ), U2(LQ,LQ), V2(LQ,LQ) - Complex (Kind=double), intent(in) :: D2(LQ), D1(LQ) - Complex (Kind=double), intent(inout) :: GRT0(LQ,LQ), GR0T(LQ,LQ), GR00(LQ,LQ), GRTT(LQ,LQ) - end SUBROUTINE CGR2_2 - SUBROUTINE CGR2_1(GRT0, GR00, GRTT, GR0T, U2, D2, V2, U1, D1, V1, LQ, NVAR) - Use Precdef - Use MyMats - USe UDV_Wrap_mod - Implicit none - ! Arguments - Integer, intent(in) :: LQ, NVAR - Complex (Kind=double), intent(in) :: U1(LQ,LQ), V1(LQ,LQ), U2(LQ,LQ), V2(LQ,LQ) - Complex (Kind=double), intent(in) :: D2(LQ), D1(LQ) - Complex (Kind=double), intent(inout) :: GRT0(LQ,LQ), GR0T(LQ,LQ), GR00(LQ,LQ), GRTT(LQ,LQ) - end SUBROUTINE CGR2_1 - SUBROUTINE CGR2(GRT0, GR00, GRTT, GR0T, U2, D2, V2, U1, D1, V1, LQ) - - ! B2 = U2*D2*V2 - ! B1 = V1*D1*U1 - !Calc: ( 1 B1 )^-1 i.e. 2*LQ \times 2*LQ matrix - ! (-B2 1 ) - - - Use Precdef - Use UDV_WRAP_mod - Use MyMats - - Implicit none - - ! Arguments - Integer :: LQ - Complex (Kind=double), intent(in) :: U1(LQ,LQ), V1(LQ,LQ), U2(LQ,LQ), V2(LQ,LQ) - Complex (Kind=double), intent(in) :: D2(LQ), D1(LQ) - Complex (Kind=double), intent(inout) :: GRT0(LQ,LQ), GR0T(LQ,LQ), GR00(LQ,LQ), GRTT(LQ,LQ) - end SUBROUTINE CGR2 - end Interface - - Complex (Kind=double), Intent(in) :: UST(NDIM,NDIM,NSTM,N_FL), VST(NDIM,NDIM,NSTM,N_FL), DST(NDIM,NSTM,N_FL) - Complex (Kind=double), Intent(in) :: GR(NDIM,NDIM,N_FL), Phase - Integer, Intent(In) :: NSTM, NWRAP - - - ! Local - ! This could be placed as private for the module - Complex (Kind=double) :: GT0(NDIM,NDIM,N_FL), G00(NDIM,NDIM,N_FL), GTT(NDIM,NDIM,N_FL), G0T(NDIM,NDIM,N_FL) - Complex (Kind=double) :: UL(Ndim,Ndim,N_FL), DL(Ndim,N_FL), VL(Ndim,Ndim,N_FL) - Complex (Kind=double) :: UR(Ndim,Ndim,N_FL), DR(Ndim,N_FL), VR(Ndim,Ndim,N_FL) - Complex (Kind=double) :: HLP4(Ndim,Ndim), HLP5(Ndim,Ndim), HLP6(Ndim,Ndim) - - Complex (Kind=double) :: Z - Integer :: I, J, nf, NT, NT1, NTST, NST, NVAR - - !Tau = 0 - Do nf = 1, N_FL - DO J = 1,Ndim - DO I = 1,Ndim - Z = cmplx(0.d0,0.d0) - if (I == J ) Z = cone - G00(I,J,nf) = GR(I,J,nf) - GT0(I,J,nf) = GR(I,J,nf) - GTT(I,J,nf) = GR(I,J,nf) - G0T(I,J,nf) = -(Z - GR(I,J,nf)) - ENDDO - ENDDO - Enddo - NT = 0 - ! In Module Hamiltonian - CALL OBSERT(NT, GT0,G0T,G00,GTT, PHASE) - - Do nf = 1, N_FL - CALL INITD(UR(:,:,nf),cone) - CALL INITD(VR(:,:,nf),cone) - enddo - DR = cone - - - DO NT = 0,LTROT - 1 - ! Now wrapup: - NT1 = NT + 1 - CALL PROPR (GT0,NT1) - CALL PROPRM1 (G0T,NT1) - CALL PROPRM1 (GTT,NT1) - CALL PROPR (GTT,NT1) - ! In Module Hamiltonian - CALL OBSERT(NT1, GT0,G0T,G00,GTT,PHASE) - - IF ( MOD(NT1,NWRAP).EQ.0 .AND. NT1.NE.LTROT ) THEN - NTST = NT1 - NWRAP - NST = NT1/(NWRAP) - ! WRITE(6,*) 'NT1, NST: ', NT1,NST - CALL WRAPUR(NTST, NT1,UR, DR, VR) - DO nf = 1,N_FL - DO J = 1,NDIM - DO I = 1,NDIM - UL(I,J,nf) = UST(I,J,NST,nf) - VL(I,J,nf) = VST(I,J,NST,nf) - ENDDO - ENDDO - DO I = 1,NDIM - DL(I,nf) = DST(I,NST,nf) - ENDDO - Enddo - Do nf = 1,N_FL - Do J = 1,Ndim - DO I = 1,Ndim - HLP4(I,J) = GTT(I,J,nf) - HLP5(I,J) = GT0(I,J,nf) - HLP6(I,J) = G0T(I,J,nf) - Enddo - Enddo - NVAR = 1 - IF (NT1 > LTROT/2) NVAR = 2 - !DO I = 1,Ndim - ! Write(6,*) DL(I,nf)*DR(I,nf) - !enddo - !Write(6,*) 'Call CGR2' - Call CGR2_2(GT0(:,:,nf), G00(:,:,nf), GTT(:,:,nf), G0T(:,:,nf), & - & UR(:,:,nf),DR(:,nf),VR(:,:,nf), UL(:,:,nf),DL(:,nf),VL(:,:,nf),NDIM) - !Call CGR2 (GT0(:,:,nf), G00(:,:,nf), GTT(:,:,nf), G0T(:,:,nf), & - ! & UR(:,:,nf),DR(:,nf),VR(:,:,nf), UL(:,:,nf),DL(:,nf),VL(:,:,nf),NDIM) - - !Call CGR2_1(GT0(:,:,nf), G00(:,:,nf), GTT(:,:,nf), G0T(:,:,nf), & - ! & UR(:,:,nf),DR(:,nf),VR(:,:,nf), UL(:,:,nf),DL(:,nf),VL(:,:,nf),NDIM,NVAR) - - !Write(6,*) 'End Call CGR2' - !Write(6,*) ' Tau ', NT1 - !Write(6,*) ' G00 ' - Call Control_Precision_tau(GR(:,:,nf), G00(:,:,nf), Ndim) - !Write(6,*) ' GTT ' - Call Control_Precision_tau(HLP4 , GTT(:,:,nf), Ndim) - !Write(6,*) ' GT0 ' - Call Control_Precision_tau(HLP5 , GT0(:,:,nf), Ndim) - !Write(6,*) ' G0T ' - Call Control_Precision_tau(HLP6 , G0T(:,:,nf), Ndim) - Enddo - Endif - ENDDO - - END SUBROUTINE TAU_M - -!============================================================== - - SUBROUTINE PROPR(AIN,NT) - - ! Ain = B(NT-1, NT1) - ! Aout= Ain = B(NT , NT1) - - Implicit none - Complex (Kind=double), intent(INOUT) :: Ain(Ndim,Ndim,N_FL) - Integer, INTENT(IN) :: NT - - !Locals - Integer :: J,I,nf,n - Complex (Kind=double) :: HLP4(Ndim,Ndim) - Real (Kind=double) :: X - - Do nf = 1,N_FL - !CALL MMULT(HLP4,Exp_T(:,:,nf) ,Ain(:,:,nf)) - Call Hop_mod_mmthr(Ain(:,:,nf),HLP4,nf) - Do n = 1,Size(Op_V,1) - X = Phi(nsigma(n,nt),Op_V(n,nf)%type) - Call Op_mmultR(HLP4,Op_V(n,nf),X,Ndim) - ENDDO - Do J = 1,Ndim - do I = 1,Ndim - Ain(I,J,nf) = HLP4(I,J) - enddo - ENDDO - Enddo - - end SUBROUTINE PROPR -!============================================================== - SUBROUTINE PROPRM1(AIN,NT) - - !Ain = B^{-1}(NT-1, NT1) - !Aout= B^{-1}(NT , NT1) - - - Implicit none - - !Arguments - Complex (Kind=double), intent(Inout) :: AIN(Ndim, Ndim, N_FL) - Integer :: NT - - ! Locals - Integer :: J,I,nf,n - Complex (Kind=double) :: HLP4(Ndim,Ndim) - Real (Kind=double) :: X - - do nf = 1,N_FL - !Call MMULT(HLP4,Ain(:,:,nf),Exp_T_M1(:,:,nf) ) - Call Hop_mod_mmthl_m1(Ain(:,:,nf),HLP4,nf) - Do n =1,Size(Op_V,1) - X = -Phi(nsigma(n,nt),Op_V(n,nf)%type) - Call Op_mmultL(HLP4,Op_V(n,nf),X,Ndim) - Enddo - Do J = 1,Ndim - do I = 1,Ndim - Ain(I,J,nf) = HLP4(I,J) - enddo - Enddo - enddo - - END SUBROUTINE PROPRM1 -!============================================================== - end Module Tau_m_mod diff --git a/Prog_7/upgrade.f90 b/Prog_7/upgrade.f90 deleted file mode 100644 index 0dd7cac22..000000000 --- a/Prog_7/upgrade.f90 +++ /dev/null @@ -1,151 +0,0 @@ - Subroutine Upgrade(GR,N_op,NT,PHASE,Op_dim) - - Use Hamiltonian - Use Random_wrap - Use Control - Use Precdef - Implicit none - - Complex (Kind=double) :: GR(Ndim,Ndim, N_FL) - Integer, INTENT(IN) :: N_op, Nt, Op_dim - Complex (Kind=double) :: Phase - - ! Local :: - Complex (Kind=double) :: Mat(Op_dim,Op_Dim), Delta(Op_dim,N_FL) - Complex (Kind=double) :: Ratio(N_FL), Ratiotot, Z1 - Integer :: ns_new, ns_old, n,m,nf, i,j - Complex (Kind= double) :: ZK, Z, D_Mat - Integer, external :: nranf - - Real (Kind = double) :: Weight - Complex (Kind = double) :: u(Ndim,Op_dim), v(Ndim,Op_dim) - Complex (Kind = double) :: x_v(Ndim,Op_dim), y_v(Ndim,Op_dim), xp_v(Ndim,Op_dim) - Complex (Kind = double) :: s_xv(Op_dim), s_yu(Op_dim) - - Logical :: Log - - - if ( sqrt(dble(OP_V(n_op,1)%g*conjg(OP_V(n_op,1)%g))) < 1.D-6 ) return - - ! Compute the ratio - nf = 1 - ns_old = nsigma(n_op,nt) - If ( Op_V(n_op,nf)%type == 1) then - ns_new = -ns_old - else - ns_new = NFLIPL(Ns_old,nranf(3)) - endif - Do nf = 1,N_FL - Z1 = Op_V(n_op,nf)%g * cmplx( Phi(ns_new,Op_V(n_op,nf)%type) - Phi(ns_old,Op_V(n_op,nf)%type), 0.d0) - Do m = 1,Op_V(n_op,nf)%N - Z = exp( Z1* Op_V(n_op,nf)%E(m) ) - cmplx(1.d0,0.d0) - Delta(m,nf) = Z - do n = 1,Op_V(n_op,nf)%N - ZK = cmplx(0.d0,0.d0) - If (n == m ) ZK = cmplx(1.d0,0.d0) - Mat(n , m ) = ZK + ( ZK - GR( Op_V(n_op,nf)%P(n), Op_V(n_op,nf)%P(m),nf )) * Z - Enddo - Enddo - If (Size(Mat,1) == 1 ) then - D_mat = Mat(1,1) - elseif (Size(Mat,1) == 2 ) then - D_mat = Mat(1,1)*Mat(2,2) - Mat(2,1)*Mat(1,2) - else - D_mat = Det(Mat,Size(Mat,1)) - !Write(6,*) 'Not yet programed! ' - !Stop - endif - Ratio(nf) = D_Mat * exp( Z1*Op_V(n_op,nf)%alpha ) - Enddo - - Ratiotot = cmplx(1.d0,0.d0) - Do nf = 1,N_FL - Ratiotot = Ratiotot * Ratio(nf) - enddo - nf = 1 - Ratiotot = (Ratiotot**dble(N_SUN)) * cmplx(Gaml(ns_new, Op_V(n_op,nf)%type)/Gaml(ns_old, Op_V(n_op,nf)%type),0.d0) - Ratiotot = Ratiotot*cmplx(S0(n_op,nt),0.d0) - - - !Write(6,*) Ratiotot - - Weight = abs( real(Phase * Ratiotot, kind=double)/real(Phase,kind=double) ) - - Log = .false. - if ( Weight > ranf() ) Then - Log = .true. - Phase = Phase * Ratiotot/cmplx(weight,0.d0) - !Write(6,*) 'Accepted : ', Ratiotot - - Do nf = 1,N_FL - ! Setup u(i,n), v(n,i) - u = cmplx(0.d0,0.d0) - v = cmplx(0.d0,0.d0) - do n = 1,Op_V(n_op,nf)%N - u( Op_V(n_op,nf)%P(n), n) = Delta(n,nf) - do i = 1,Ndim - v(i,n) = - GR( Op_V(n_op,nf)%P(n), i, nf ) - enddo - v(Op_V(n_op,nf)%P(n), n) = cmplx(1.d0,0.d0) - GR( Op_V(n_op,nf)%P(n), Op_V(n_op,nf)%P(n), nf) - enddo - - - x_v = cmplx(0.d0,0.d0) - y_v = cmplx(0.d0,0.d0) - i = Op_V(n_op,nf)%P(1) - x_v(i,1) = u(i,1)/(cmplx(1.d0,0.d0) + v(i,1)*u(i,1) ) - Do i = 1,Ndim - y_v(i,1) = v(i,1) - enddo - do n = 2,Op_V(n_op,nf)%N - s_yu = cmplx(0.d0,0.d0) - s_xv = cmplx(0.d0,0.d0) - do m = 1,n-1 - do i = 1,Ndim - s_yu(m) = s_yu(m) + y_v(i,m)*u(i,n) - s_xv(m) = s_xv(m) + x_v(i,m)*v(i,n) - enddo - enddo - Do i = 1,Ndim - x_v(i,n) = u(i,n) - y_v(i,n) = v(i,n) - enddo - Z = cmplx(1.d0,0.d0) + u( Op_V(n_op,nf)%P(n), n)*v(Op_V(n_op,nf)%P(n),n) - do m = 1,n-1 - Z = Z - s_xv(m)*s_yu(m) - Do i = 1,Ndim - x_v(i,n) = x_v(i,n) - x_v(i,m)*s_yu(m) - y_v(i,n) = y_v(i,n) - y_v(i,m)*s_xv(m) - enddo - enddo - Do i = 1,Ndim - x_v(i,n) = x_v(i,n)/Z - Enddo - enddo - xp_v = cmplx(0.d0,0.d0) - do n = 1,Op_dim - do m = 1,Op_dim - j = Op_V(n_op,nf)%P(m) - do i = 1,Ndim - xp_v(i,n) = xp_v(i,n) + gr(i,j,nf)*x_v(j,n) - enddo - enddo - enddo - - do n = 1,Op_dim - do j = 1,Ndim - do i = 1,Ndim - gr(i,j,nf) = gr(i,j,nf) - xp_v(i,n)*y_v(j,n) - enddo - enddo - enddo - enddo - - ! Flip the spin - nsigma(n_op,nt) = ns_new - endif - - Call Control_upgrade(Log) - - - End Subroutine Upgrade diff --git a/Prog_7/wrapgrdo.f90 b/Prog_7/wrapgrdo.f90 deleted file mode 100644 index d167cab49..000000000 --- a/Prog_7/wrapgrdo.f90 +++ /dev/null @@ -1,82 +0,0 @@ - SUBROUTINE WRAPGRDO(GR,NTAU,PHASE) - - Use Hamiltonian - Use MyMats - Use Hop_mod - Implicit None - - Interface - Subroutine Upgrade(GR,N_op,NT,PHASE,Op_dim) - Use Hamiltonian - Implicit none - Complex (Kind=8) :: GR(Ndim,Ndim, N_FL) - Integer, INTENT(IN) :: N_op, Nt, Op_dim - Complex (Kind=8) :: Phase - End Subroutine Upgrade - End Interface - - ! Given GREEN at time NTAU => GREEN at time NTAU - 1, - ! Upgrade NTAU [LTROT:1] - - COMPLEX (Kind=8), INTENT(INOUT) :: GR(Ndim,Ndim,N_FL) - COMPLEX (Kind=8), INTENT(INOUT) :: PHASE - Integer :: NTAU - - ! Local - Complex (Kind=8) :: Mat_TMP(Ndim,Ndim) - Integer :: nf, N_Type, n, I,J - real (Kind=8) :: spin - - Do n = size(Op_V,1), 1, -1 - N_type = 2 - nf = 1 - spin = Phi(nsigma(n,ntau),Op_V(n,nf)%type) - do nf = 1,N_FL - Call Op_Wrapdo( Gr(:,:,nf), Op_V(n,nf), spin, Ndim, N_Type) - enddo - !Write(6,*) 'Upgrade : ', ntau,n - Call Upgrade(GR,n,ntau,PHASE,Op_V(n,1)%N) - ! The spin has changed after the upgrade! - nf = 1 - spin = Phi(nsigma(n,ntau),Op_V(n,nf)%type) - N_type = 1 - do nf = 1,N_FL - Call Op_Wrapdo( Gr(:,:,nf), Op_V(n,nf), spin, Ndim, N_Type ) - enddo - enddo - DO nf = 1,N_FL - Call Hop_mod_mmthl (GR(:,:,nf), MAT_TMP, nf) - Call Hop_mod_mmthr_m1(MAT_TMP, GR(:,:,nf), nf) - !CALL MMULT(MAT_TMP , GR(:,:,nf) , Exp_T(:,:,nf) ) - !CALL MMULT(GR(:,:,nf), Exp_T_M1(:,:,nf), MAT_TMP ) - enddo - -!!$ ! Test -!!$ Mat_TMP = cmplx(0.d0,0.d0) -!!$ DO I = 1,Ndim -!!$ Mat_TMP(I,I) = cmplx(1.d0,0.d0) -!!$ Enddo -!!$ Do n = size(Op_V,1), 1, -1 -!!$ N_type = 2 -!!$ nf = 1 -!!$ spin = Phi(nsigma(n,ntau),Op_V(n,nf)%type) -!!$ Write(6,*) n, spin -!!$ do nf = 1,N_FL -!!$ Call Op_Wrapdo( Mat_tmp, Op_V(n,nf), spin, Ndim, N_Type) -!!$ enddo -!!$ !Upgrade -!!$ N_type = 1 -!!$ do nf = 1,N_FL -!!$ Call Op_Wrapdo( Mat_tmp, Op_V(n,nf), spin, Ndim, N_Type ) -!!$ enddo -!!$ enddo -!!$ -!!$ DO I = 1,Ndim -!!$ Do J = 1,NDIM -!!$ WRITE(6,*) I,J, Mat_tmp(I,J) -!!$ ENDDO -!!$ ENDDO -!!$ -!!$ STOP - - END SUBROUTINE WRAPGRDO diff --git a/Prog_7/wrapgrup.f90 b/Prog_7/wrapgrup.f90 deleted file mode 100644 index 9743dd137..000000000 --- a/Prog_7/wrapgrup.f90 +++ /dev/null @@ -1,53 +0,0 @@ - SUBROUTINE WRAPGRUP(GR,NTAU,PHASE) - - Use Hamiltonian - Use Hop_mod - Implicit none - - Interface - Subroutine Upgrade(GR,N_op,NT,PHASE,Op_dim) - Use Hamiltonian - Implicit none - Complex (Kind=8) :: GR(Ndim,Ndim, N_FL) - Integer, INTENT(IN) :: N_op, Nt, Op_dim - Complex (Kind=8) :: Phase - End Subroutine Upgrade - End Interface - - ! Given GRUP at time NTAU => GRUP at time NTAU + 1. - ! Upgrade NTAU + 1 NTAU: [0:LTROT-1] - - ! Arguments - COMPLEX (Kind=8), INTENT(INOUT) :: GR(Ndim,Ndim,N_FL) - COMPLEX (Kind=8), INTENT(INOUT) :: PHASE - INTEGER, INTENT(IN) :: NTAU - - !Local - Integer :: nf, N_Type, NTAU1,n - Complex (Kind=8) :: Mat_TMP(Ndim,Ndim) - Real (Kind=8) :: X - - ! Wrap up, upgrade ntau1. with B^{1}(tau1) - NTAU1 = NTAU + 1 - Do nf = 1,N_FL - CALL HOP_MOD_mmthr( GR(:,:,nf), MAT_TMP,nf) - CALL HOP_MOD_mmthl_m1(MAT_TMP,GR(:,:,nf), nf ) - !CALL MMULT ( MAT_TMP, Exp_T(:,:,nf), GR(:,:,nf) ) - !CALL MMULT ( GR(:,:,nf), MAT_TMP , Exp_T_M1(:,:,nf) ) - Enddo - Do n = 1,Size(Op_V,1) - Do nf = 1, N_FL - X = Phi(nsigma(n,ntau1),Op_V(n,nf)%type) - N_type = 1 - Call Op_Wrapup(Gr(:,:,nf),Op_V(n,nf),X,Ndim,N_Type) - enddo - nf = 1 - !Write(6,*) 'Upgrade: ', ntau1,n - Call Upgrade(GR,N,ntau1,PHASE,Op_V(n,nf)%N) - do nf = 1,N_FL - N_type = 2 - Call Op_Wrapup(Gr(:,:,nf),Op_V(n,nf),X,Ndim,N_Type) - enddo - Enddo - - END SUBROUTINE WRAPGRUP diff --git a/Prog_7/wrapul.f90 b/Prog_7/wrapul.f90 deleted file mode 100644 index 8d93cb17c..000000000 --- a/Prog_7/wrapul.f90 +++ /dev/null @@ -1,77 +0,0 @@ - SUBROUTINE WRAPUL(NTAU1, NTAU, UL ,DL, VL) - - !Given B(LTROT,NTAU1,Nf ) = VLUP, DLUP, ULUP - !Returns B(LTROT,NTAU, Nf ) = VLUP, DLUP, ULUP - - - !NOTE: NTAU1 > NTAU. - ! Does this for all replicas - Use Hamiltonian - Use Hop_mod - Use UDV_Wrap_mod - - Implicit none - - ! Arguments - COMPLEX (KIND=8) :: UL(Ndim,Ndim,N_FL), VL(Ndim,Ndim,N_FL) - COMPLEX (KIND=8) :: DL(Ndim,N_FL) - Integer :: NTAU1, NTAU - - - ! Working space. - COMPLEX (Kind=8) :: U(Ndim,Ndim), U1(Ndim,Ndim), V1(Ndim,Ndim), TMP(Ndim,Ndim), TMP1(Ndim,Ndim) - COMPLEX (Kind=8) :: D1(Ndim), Z_ONE - Integer :: I, J, NT, NCON, nr, n, nf - Real (Kind=8) :: X - - - - NCON = 0 ! Test for UDV :::: 0: Off, 1: On. - - Z_ONE = cmplx(1.d0,0.d0) - Do nf = 1, N_FL - CALL INITD(TMP,Z_ONE) - DO NT = NTAU1, NTAU+1 , -1 - Do n = Size(Op_V,1),1,-1 - X = Phi(nsigma(n,nt),Op_V(n,nf)%type) - Call Op_mmultL(Tmp,Op_V(n,nf),X,Ndim) - enddo - !CALL MMULT( TMP1,Tmp,Exp_T(:,:,nf) ) - Call Hop_mod_mmthl (Tmp, Tmp1,nf) - Tmp = Tmp1 - ENDDO - - !Carry out U,D,V decomposition. - DO J = 1,NDim - DO I = 1,NDim - TMP1(I,J) = CONJG( TMP(J,I) ) - U (I,J) = CONJG( UL (J,I,nf) ) - ENDDO - ENDDO - CALL MMULT(TMP,TMP1,U) - DO J = 1,NDim - DO I = 1,NDim - TMP(I,J) = TMP(I,J)*DL(J,nf) - ENDDO - ENDDO - CALL UDV_WRAP(TMP,U1,D1,V1,NCON) - !CALL UDV(TMP,U1,D1,V1,NCON) - DO J = 1,NDim - DO I = 1,NDim - UL (I,J,nf) = CONJG( U1(J,I) ) - TMP(I,J) = CONJG( V1(J,I) ) - ENDDO - ENDDO - CALL MMULT(TMP1,VL(:,:,nf),TMP) - DO J = 1,NDim - DO I = 1,NDim - VL(I,J,nf) = TMP1(I,J) - ENDDO - ENDDO - DO I = 1,NDim - DL(I,nf) = D1(I) - ENDDO - ENDDO - - END SUBROUTINE WRAPUL - diff --git a/Prog_7/wrapur.f90 b/Prog_7/wrapur.f90 deleted file mode 100644 index c53b28ce3..000000000 --- a/Prog_7/wrapur.f90 +++ /dev/null @@ -1,48 +0,0 @@ - SUBROUTINE WRAPUR(NTAU, NTAU1, UR, DR, VR) - - ! Given B(NTAU, 1 ) = UR, DR, VR - ! Returns B(NTAU1, 1 ) = UR, DR, VR - ! NOTE: NTAU1 > NTAU. - - Use Hamiltonian - Use UDV_Wrap_mod - Use Hop_mod - Implicit None - - ! Arguments - COMPLEX (KIND=8) :: UR(Ndim,Ndim,N_FL), VR(Ndim,Ndim,N_FL) - COMPLEX (KIND=8) :: DR(Ndim,N_FL) - Integer :: NTAU1, NTAU - - - ! Working space. - Complex (Kind=8) :: Z_ONE - COMPLEX (Kind=8) :: V1(Ndim,Ndim), TMP(Ndim,Ndim), TMP1(Ndim,Ndim) - Integer ::NCON, NT, I, J, n, nf - Real (Kind=8) :: X - - NCON = 0 ! Test for UDV :::: 0: Off, 1: On. - Z_ONE = cmplx(1.d0,0.d0) - - Do nf = 1,N_FL - CALL INITD(TMP,Z_ONE) - DO NT = NTAU + 1, NTAU1 - !CALL MMULT(TMP1,Exp_T(:,:,nf) ,TMP) - Call Hop_mod_mmthr(TMP,TMP1,nf) - TMP = TMP1 - Do n = 1,Size(Op_V,1) - X = Phi(nsigma(n,nt),Op_V(n,nf)%type) - Call Op_mmultR(Tmp,Op_V(n,nf),X,Ndim) - ENDDO - ENDDO - CALL MMULT(TMP1,TMP,UR(:,:,nf)) - DO J = 1,NDim - DO I = 1,NDim - TMP1(I,J) = TMP1(I,J)*DR(J,nf) - TMP(I,J) = VR(I,J,nf) - ENDDO - ENDDO - CALL UDV_WRAP(TMP1,UR(:,:,nf),DR(:,nf),V1,NCON) - CALL MMULT(VR(:,:,nf),V1,TMP) - ENDDO - END SUBROUTINE WRAPUR diff --git a/Prog_8/Compile_Hub b/Prog_8/Compile_Hub deleted file mode 100644 index ace754b8c..000000000 --- a/Prog_8/Compile_Hub +++ /dev/null @@ -1,16 +0,0 @@ -TARGET= Hubb.out -OBJS= control_mod.o Operator.o print_bin_mod.o Hamiltonian_Hub.o Hop_mod.o UDV_WRAP.o tau_m.o main.o wrapul.o cgr1.o wrapgrup.o wrapur.o upgrade.o \ - nranf.o wrapgrdo.o outconfc.o inconfc.o cgr2.o cgr2_2.o cgr2_1.o - - - -.SUFFIXES: .f90 .f -.f.o .f90.o: - $(FC) -c -cpp -o $@ $(FLAGS) $< - -$(TARGET): $(OBJS) - $(FC) $(LF) -o $(TARGET) $(OBJS) $(LIBS) - -clean: - rm $(OBJS) - diff --git a/Prog_8/Compile_Ising b/Prog_8/Compile_Ising deleted file mode 100644 index c0400f6e8..000000000 --- a/Prog_8/Compile_Ising +++ /dev/null @@ -1,15 +0,0 @@ -TARGET= Ising.out -OBJS= control_mod.o Operator.o print_bin_mod.o Hamiltonian_Ising.o Hop_mod.o UDV_WRAP.o tau_m.o main.o wrapul.o cgr1.o wrapgrup.o wrapur.o upgrade.o \ - nranf.o wrapgrdo.o outconfc.o inconfc.o cgr2.o cgr2_2.o cgr2_1.o - - -.SUFFIXES: .f90 .f -.f.o .f90.o: - $(FC) -c -cpp -o $@ $(FLAGS) $< - -$(TARGET): $(OBJS) - $(FC) $(LF) -o $(TARGET) $(OBJS) $(LIBS) - -clean: - rm $(OBJS) - diff --git a/Prog_8/Compile_SPT b/Prog_8/Compile_SPT deleted file mode 100644 index e7b63f777..000000000 --- a/Prog_8/Compile_SPT +++ /dev/null @@ -1,20 +0,0 @@ -TARGET= SPT.out -OBJS= control_mod.o Operator.o print_bin_mod.o Hamiltonian_SPT.o Hop_mod.o UDV_WRAP.o tau_m.o main.o wrapul.o cgr1.o wrapgrup.o wrapur.o upgrade.o \ - nranf.o wrapgrdo.o outconfc.o inconfc.o cgr2.o cgr2_2.o cgr2_1.o - -#block.o block_obs.o Mol_Dyn.o Hubb.o inconfc.o outconfc.o npbc.o salph.o sli.o \ -# sthop.o wrapul.o wrapur.o cgr1.o \ -# wrapgrdo.o mmthr.o mmthrm1.o mmthl.o mmthlm1.o obser.o upgradeu.o wrapgrup.o \ -# preq.o cgr2.o propr.o proprm1.o obsert.o prtau.o tau_m.o set_Hopping.o - - -.SUFFIXES: .f90 .f -.f.o .f90.o: - $(FC) -c -cpp -o $@ $(FLAGS) $< - -$(TARGET): $(OBJS) - $(FC) $(LF) -o $(TARGET) $(OBJS) $(LIBS) - -clean: - rm $(OBJS) - diff --git a/Prog_8/Hamiltonian_Hub.f90 b/Prog_8/Hamiltonian_Hub.f90 deleted file mode 100644 index 72a1d5f17..000000000 --- a/Prog_8/Hamiltonian_Hub.f90 +++ /dev/null @@ -1,539 +0,0 @@ - Module Hamiltonian - - Use Operator_mod - Use Lattices_v3 - Use MyMats - Use Random_Wrap - Use Files_mod - Use Matrix - Use Print_bin_mod - - - Type (Operator), dimension(:,:), allocatable :: Op_V - Type (Operator), dimension(:,:), allocatable :: Op_T - Integer, allocatable :: nsigma(:,:) - Integer :: Ndim, N_FL, N_SUN, Ltrot - !Complex (Kind=8), dimension(:,:,:), allocatable :: Exp_T(:,:,:), Exp_T_M1(:,:,:) - - ! ToDo. Public and private subroutines. - - ! What is below is private - Type (Lattice), private :: Latt - Integer, private :: L1, L2 - real (Kind=8), private :: ham_T , ham_U, Ham_chem - real (Kind=8), private :: Dtau, Beta - Character (len=64), private :: Model, Lattice_type - Logical, private :: One_dimensional - Integer, private :: N_coord - - - ! Observables - Integer, private :: Nobs, Norb - Complex (Kind=8), allocatable, private :: obs_scal(:) - Complex (Kind=8), allocatable, private :: Green_eq (:,:,:), SpinZ_eq (:,:,:), SpinXY_eq (:,:,:), & - & Den_eq(:,:,:) - Complex (Kind=8), allocatable, private :: Green_eq0 (:), SpinZ_eq0(:), SpinXY_eq0(:), & - & Den_eq0(:) - - ! For time displaced - Integer, private :: NobsT - Complex (Kind=8), private :: Phase_tau - Complex (Kind=8), allocatable, private :: Green_tau(:,:,:,:), Den_tau(:,:,:,:) - - contains - - - Subroutine Ham_Set - - Implicit none -#include "machine" -#ifdef MPI - include 'mpif.h' -#endif - - integer :: ierr - - - NAMELIST /VAR_lattice/ L1, L2, Lattice_type, Model - - NAMELIST /VAR_Hubbard/ ham_T, ham_chem, ham_U, Dtau, Beta - - -#ifdef MPI - Integer :: Isize, Irank - Integer :: STATUS(MPI_STATUS_SIZE) - CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) - CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) -#endif - - - ! NAMELIST /VAR_Model/ N_FL, N_SUN, ham_T , ham_xi, ham_h, ham_J, ham_U, Ham_Vint, & - ! & Dtau, Beta - - -#ifdef MPI - If (Irank == 0 ) then -#endif - OPEN(UNIT=5,FILE='parameters',STATUS='old',ACTION='read',IOSTAT=ierr) - IF (ierr /= 0) THEN - WRITE(*,*) 'unable to open ',ierr - STOP - END IF - READ(5,NML=VAR_lattice) - CLOSE(5) - -#ifdef MPI - Endif - CALL MPI_BCAST(L1 ,1 ,MPI_INTEGER, 0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(L2 ,1 ,MPI_INTEGER, 0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(Model ,64 ,MPI_CHARACTER, 0,MPI_COMM_WORLD,IERR) - CALL MPI_BCAST(Lattice_type,64 ,MPI_CHARACTER, 0,MPI_COMM_WORLD,IERR) -#endif - Call Ham_latt - - If ( Model == "Hubbard_Mz") then - N_FL = 2 - N_SUN = 1 - elseif ( Model == "Hubbard_SU2" ) then - N_FL = 1 - N_SUN = 2 - else - Write(6,*) "Model not yet implemented!" - Stop - endif -#ifdef MPI - If (Irank == 0 ) then -#endif - OPEN(UNIT=5,FILE='parameters',STATUS='old',ACTION='read',IOSTAT=ierr) - READ(5,NML=VAR_Hubbard) - CLOSE(5) -#ifdef MPI - endif - CALL MPI_BCAST(ham_T ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(ham_chem ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(ham_U ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(Dtau ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(Beta ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) -#endif - Call Ham_hop - - Ltrot = nint(beta/dtau) -#ifdef MPI - If (Irank == 0) then -#endif - Open (Unit = 50,file="info",status="unknown",position="append") - Write(50,*) '=====================================' - Write(50,*) 'Model is : ', Model - Write(50,*) 'Beta : ', Beta - Write(50,*) 'dtau,Ltrot : ', dtau,Ltrot - Write(50,*) 'N_SUN : ', N_SUN - Write(50,*) 'N_FL : ', N_FL - Write(50,*) 't : ', Ham_T - Write(50,*) 'Ham_U : ', Ham_U - Write(50,*) 'Ham_chem : ', Ham_chem - close(50) -#ifdef MPI - endif -#endif - call Ham_V - end Subroutine Ham_Set -!============================================================================= - Subroutine Ham_Latt - Implicit none - !Set the lattice - Real (Kind=8) :: a1_p(2), a2_p(2), L1_p(2), L2_p(2) - If ( Lattice_type =="Square" ) then - a1_p(1) = 1.0 ; a1_p(2) = 0.d0 - a2_p(1) = 0.0 ; a2_p(2) = 1.d0 - L1_p = dble(L1)*a1_p - L2_p = dble(L2)*a2_p - Call Make_Lattice( L1_p, L2_p, a1_p, a2_p, Latt ) - Ndim = Latt%N - !Write(6,*) 'Lattice: ', Ndim - One_dimensional = .false. - N_coord = 2 - If ( L1 == 1 .or. L2 == 1 ) then - One_dimensional = .true. - N_coord = 1 - If (L1 == 1 ) then - Write(6,*) ' For one dimensional systems set L2 = 1 ' - Stop - endif - endif - else - Write(6,*) "Lattice not yet implemented!" - Stop - endif - end Subroutine Ham_Latt - -!=================================================================================== - Subroutine Ham_hop - Implicit none - - !Setup the hopping - !Per flavor, the hopping is given by: - ! e^{-dtau H_t} = Prod_{n=1}^{Ncheck} e^{-dtau_n H_{n,t}} - - - Integer :: I, I1, I2, n, Ncheck,nc - Real (Kind=8) :: X - - Ncheck = 1 - allocate(Op_T(Ncheck,N_FL)) - do n = 1,N_FL - Do nc = 1,Ncheck - Call Op_make(Op_T(nc,n),Ndim) - If (One_dimensional ) then - DO I = 1, Latt%N - I1 = Latt%nnlist(I,1,0) - Op_T(nc,n)%O(I,I1) = cmplx(-Ham_T,0.d0) - Op_T(nc,n)%O(I1,I) = cmplx(-Ham_T,0.d0) - Op_T(nc,n)%O(I ,I) = cmplx(-Ham_chem,0.d0) - ENDDO - else - DO I = 1, Latt%N - I1 = Latt%nnlist(I,1,0) - I2 = Latt%nnlist(I,0,1) - Op_T(nc,n)%O(I,I1) = cmplx(-Ham_T, 0.d0) - Op_T(nc,n)%O(I1,I) = cmplx(-Ham_T, 0.d0) - Op_T(nc,n)%O(I,I2) = cmplx(-Ham_T, 0.d0) - Op_T(nc,n)%O(I2,I) = cmplx(-Ham_T, 0.d0) - Op_T(nc,n)%O(I ,I) = cmplx(-Ham_chem,0.d0) - ENDDO - endif - - Do I = 1,Latt%N - Op_T(nc,n)%P(i) = i - Enddo - if ( abs(Ham_T) < 1.E-6 .and. abs(Ham_chem) < 1.E-6 ) then - Op_T(nc,n)%g=cmplx(0.d0 ,0.d0) - else - Op_T(nc,n)%g=cmplx(-Dtau,0.d0) - endif - Op_T(nc,n)%alpha=cmplx(0.d0,0.d0) - !Write(6,*) 'In Ham_hop', Ham_T - Call Op_set(Op_T(nc,n)) - !Write(6,*) 'In Ham_hop 1' - !Do I = 1,Latt%N - ! Write(6,*) Op_T(n)%E(i) - !enddo - !Call Op_exp( cmplx(-Dtau,0.d0), Op_T(n), Exp_T (:,:,n) ) - !Call Op_exp( cmplx( Dtau,0.d0), Op_T(n), Exp_T_M1(:,:,n) ) - enddo - enddo - end Subroutine Ham_hop - -!=================================================================================== - - Subroutine Ham_V - - Implicit none - - Integer :: nf, nth, n, n1, n2, n3, n4, I, I1, I2, J, Ix, Iy, nc - Real (Kind=8) :: X_p(2), X1_p(2), X2_p(2), X - - - If (Model == "Hubbard_SU2") then - !Write(50,*) 'Model is ', Model - Allocate(Op_V(Latt%N,N_FL)) - do nf = 1,N_FL - do i = 1, Latt%N - Call Op_make(Op_V(i,nf),1) - enddo - enddo - Do nf = 1,N_FL - nc = 0 - Do i = 1,Latt%N - nc = nc + 1 - Op_V(nc,nf)%P(1) = I - Op_V(nc,nf)%O(1,1) = cmplx(1.d0 ,0.d0) - Op_V(nc,nf)%g = SQRT(CMPLX(-DTAU*ham_U/(DBLE(N_SUN)),0.D0)) - Op_V(nc,nf)%alpha = cmplx(-0.5d0,0.d0) - Op_V(nc,nf)%type = 2 - Call Op_set( Op_V(nc,nf) ) - ! The operator reads: - ! g*s*( c^{dagger} O c + alpha )) - ! with s the HS field. - Enddo - Enddo - Elseif (Model == "Hubbard_Mz") then - !Write(50,*) 'Model is ', Model - Allocate(Op_V(Latt%N,N_FL)) - do nf = 1,N_FL - do i = 1, Latt%N - Call Op_make(Op_V(i,nf),1) - enddo - enddo - Do nf = 1,N_FL - nc = 0 - X = 1.d0 - if (nf == 2) X = -1.d0 - Do i = 1,Latt%N - nc = nc + 1 - Op_V(nc,nf)%P(1) = I - Op_V(nc,nf)%O(1,1) = cmplx(1.d0 ,0.d0) - Op_V(nc,nf)%g = X*SQRT(CMPLX(DTAU*ham_U/2.d0 ,0.D0)) - Op_V(nc,nf)%alpha = cmplx(0.d0,0.d0) - Op_V(nc,nf)%type = 2 - Call Op_set( Op_V(nc,nf) ) - ! The operator reads: - ! g*s*( c^{dagger} O c - alpha )) - ! with s the HS field. - ! Write(6,*) nc,nf, Op_V(nc,nf)%g - Enddo - Enddo - Endif - end Subroutine Ham_V - -!=================================================================================== - Real (Kind=8) function S0(n,nt) - Implicit none - Integer, Intent(IN) :: n,nt - Integer :: i, nt1 - S0 = 1.d0 - - end function S0 - -!=================================================================================== - Subroutine Alloc_obs(Ltau) - - Implicit none - Integer, Intent(In) :: Ltau - Integer :: I - - Allocate ( Obs_scal(5) ) - Allocate ( Green_eq(Latt%N,1,1), SpinZ_eq(Latt%N,1,1), SpinXY_eq(Latt%N,1,1), & - & Den_eq(Latt%N,1,1) ) - Allocate ( Green_eq0(1), SpinZ_eq0(1), SpinXY_eq0(1), Den_eq0(1) ) - - - If (Ltau == 1) then - Allocate ( Green_tau(Latt%N,Ltrot+1,1,1), Den_tau(Latt%N,Ltrot+1,1,1) ) - endif - - end Subroutine Alloc_obs - -!=================================================================================== - - Subroutine Init_obs(Ltau) - - Implicit none - Integer, Intent(In) :: Ltau - - Integer :: I,n - - Nobs = 0 - Obs_scal = cmplx(0.d0,0.d0) - Green_eq = cmplx(0.d0,0.d0) - SpinZ_eq = cmplx(0.d0,0.d0) - SpinXY_eq = cmplx(0.d0,0.d0) - Den_eq = cmplx(0.d0,0.d0) - Green_eq0 = cmplx(0.d0,0.d0) - SpinZ_eq0 = cmplx(0.d0,0.d0) - SpinXY_eq0= cmplx(0.d0,0.d0) - Den_eq0 = cmplx(0.d0,0.d0) - - - If (Ltau == 1) then - NobsT = 0 - Phase_tau = cmplx(0.d0,0.d0) - Green_tau = cmplx(0.d0,0.d0) - Den_tau = cmplx(0.d0,0.d0) - endif - - end Subroutine Init_obs - -!======================================================================== - Subroutine Obser(GR,Phase,Ntau) - - Implicit none - - Complex (Kind=8), INTENT(IN) :: GR(Ndim,Ndim,N_FL) - Complex (Kind=8), Intent(IN) :: PHASE - Integer, INTENT(IN) :: Ntau - - !Local - Complex (Kind=8) :: GRC(Ndim,Ndim,N_FL), ZK - Complex (Kind=8) :: Zrho, Zkin, ZPot, Z, ZP,ZS - Integer :: I,J, no,no1, n, n1, imj, nf, I1, I2, J1, J2 - - Real (Kind=8) :: G(4,4), X, FI, FJ - - Nobs = Nobs + 1 - ZP = PHASE/cmplx(Real(Phase,kind=8),0.d0) - ZS = cmplx(Real(Phase,kind=8)/Abs(Real(Phase,kind=8)), 0.d0) - - - Do nf = 1,N_FL - Do I = 1,Ndim - Do J = 1,Ndim - ZK = cmplx(0.d0,0.d0) - If ( I == J ) ZK = cmplx(1.d0,0.d0) - GRC(I,J,nf) = ZK - GR(J,I,nf) - Enddo - Enddo - Enddo - ! GRC(i,j,nf) = < c^{dagger}_{j,nf } c_{j,nf } > - ! Compute scalar observables. - Zkin = cmplx(0.d0,0.d0) - Do nf = 1,N_FL - Do J = 1,Ndim - DO I = 1,Ndim - Zkin = Zkin + Op_T(1,nf)%O(i,j)*Grc(i,j,nf) - Enddo - ENddo - Enddo - Zkin = Zkin*cmplx( dble(N_SUN), 0.d0 ) - - Zrho = cmplx(0.d0,0.d0) - Do nf = 1,N_FL - Do I = 1,Ndim - Zrho = Zrho + Grc(i,i,nf) - enddo - enddo - Zrho = Zrho*cmplx( dble(N_SUN), 0.d0 ) - - ZPot = cmplx(0.d0,0.d0) - If ( Model == "Hubbard_SU2" ) then - Do I = 1,Ndim - ZPot = ZPot + Grc(i,i,1) * Grc(i,i,1) - Enddo - Zpot = Zpot*cmplx(ham_U,0.d0) - elseif ( Model == "Hubbard_Mz" ) then - Do I = 1,Ndim - ZPot = ZPot + Grc(i,i,1) * Grc(i,i,2) - Enddo - Zpot = Zpot*cmplx(ham_U,0.d0) - endif - - Obs_scal(1) = Obs_scal(1) + zrho * ZP*ZS - Obs_scal(2) = Obs_scal(2) + zkin * ZP*ZS - Obs_scal(3) = Obs_scal(3) + Zpot * ZP*ZS - Obs_scal(4) = Obs_scal(4) + (zkin + Zpot)*ZP*ZS - Obs_scal(5) = Obs_scal(5) + ZS - ! You will have to allocate more space if you want to include more scalar observables. - - ! Compute spin-spin, Green, and den-den correlation functions ! This is general N_SUN, and N_FL = 1 - If ( Model == "Hubbard_SU2" ) then - Z = cmplx(dble(N_SUN),0.d0) - Do I = 1,Latt%N - Do J = 1,Latt%N - imj = latt%imj(I,J) - GREEN_EQ (imj,1,1) = GREEN_EQ (imj,1,1) + Z * GRC(I,J,1) * ZP*ZS - SPINXY_Eq (imj,1,1) = SPINXY_Eq (imj,1,1) + Z * GRC(I,J,1) * GR(I,J,1) * ZP*ZS - SPINZ_Eq (imj,1,1) = SPINZ_Eq (imj,1,1) + Z * GRC(I,J,1) * GR(I,J,1) * ZP*ZS - DEN_Eq (imj,1,1) = DEN_Eq (imj,1,1) + ( & - & GRC(I,I,1) * GRC(J,J,1) *Z + & - & GRC(I,J,1) * GR(I,J,1) & - & ) * Z* ZP*ZS - ENDDO - Den_eq0(1) = Den_eq0(1) + Z * GRC(I,I,1) * ZP * ZS - ENDDO - elseif (Model == "Hubbard_Mz" ) Then - DO I = 1,Latt%N - DO J = 1, Latt%N - imj = latt%imj(I,J) - SPINZ_Eq (imj,1,1) = SPINZ_Eq (imj,1,1) + & - & ( GRC(I,J,1) * GR(I,J,1) + GRC(I,J,2) * GR(I,J,2) + & - & (GRC(I,I,2) - GRC(I,I,1))*(GRC(J,J,2) - GRC(J,J,1)) ) * ZP*ZS - ! c^d_(i,u) c_(i,d) c^d_(j,d) c_(j,u) + c^d_(i,d) c_(i,u) c^d_(j,u) c_(j,d) - SPINXY_Eq (imj,1,1) = SPINXY_Eq (imj,1,1) + & - & ( GRC(I,J,1) * GR(I,J,2) + GRC(I,J,2) * GR(I,J,1) ) * ZP*ZS - - DEN_Eq (imj,1,1) = DEN_Eq (imj,1,1) + & - & ( GRC(I,J,1) * GR(I,J,1) + GRC(I,J,2) * GR(I,J,2) + & - & (GRC(I,I,2) + GRC(I,I,1))*(GRC(J,J,2) + GRC(J,J,1)) ) * ZP*ZS - enddo - Den_eq0(1) = Den_eq0(1) + (GRC(I,I,2) + GRC(I,I,1)) * ZP*ZS - enddo - Endif - - - end Subroutine Obser -!========================================================== - Subroutine Pr_obs(LTAU) - - Implicit none -#include "machine" -#ifdef MPI - include 'mpif.h' -#endif - - - Integer, Intent(In) :: Ltau - - Character (len=64) :: File_pr - Complex (Kind=8) :: Phase_bin -#ifdef MPI - Integer :: Isize, Irank, Ierr - Integer :: STATUS(MPI_STATUS_SIZE) - CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) - CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) -#endif - -!!$#ifdef MPI -!!$ Write(6,*) Irank, 'In Pr_obs', LTAU -!!$#else -!!$ Write(6,*) 'In Pr_obs', LTAU -!!$#endif - - Phase_bin = Obs_scal(5)/cmplx(dble(Nobs),0.d0) - File_pr ="SpinZ_eq" - Call Print_bin(SpinZ_eq ,SpinZ_eq0, Latt, Nobs, Phase_bin, file_pr) - File_pr ="SpinXY_eq" - Call Print_bin(Spinxy_eq, Spinxy_eq0,Latt, Nobs, Phase_bin, file_pr) - File_pr ="Den_eq" - Call Print_bin(Den_eq, Den_eq0, Latt, Nobs, Phase_bin, file_pr) - File_pr ="Green_eq" - Call Print_bin(Green_eq , Green_eq0 ,Latt, Nobs, Phase_bin, file_pr) - - File_pr ="ener" - Call Print_scal(Obs_scal, Nobs, file_pr) - - If (Ltau == 1) then - Phase_tau = Phase_tau/cmplx(dble(NobsT),0.d0) - File_pr = "Green_tau" - Call Print_bin_tau(Green_tau,Latt,NobsT,Phase_tau, file_pr,dtau) - File_pr = "Den_tau" - Call Print_bin_tau(Den_tau,Latt,NobsT,Phase_tau, file_pr,dtau) - endif - -!!$#ifdef MPI -!!$ Write(6,*) Irank, 'out Pr_obs', LTAU -!!$#else -!!$ Write(6,*) 'out Pr_obs', LTAU -!!$#endif - end Subroutine Pr_obs -!========================================================== - - Subroutine OBSERT(NT, GT0,G0T,G00,GTT, PHASE) - Implicit none - - Integer , INTENT(IN) :: NT - Complex (Kind=8), INTENT(IN) :: GT0(Ndim,Ndim,N_FL),G0T(Ndim,Ndim,N_FL),G00(Ndim,Ndim,N_FL),GTT(Ndim,Ndim,N_FL) - Complex (Kind=8), INTENT(IN) :: Phase - - !Locals - Complex (Kind=8) :: Z, ZP, ZS - Integer :: IMJ, I, J - - ZP = PHASE/cmplx(Real(Phase,kind=8),0.d0) - ZS = cmplx(Real(Phase,kind=8)/Abs(Real(Phase,kind=8)), 0.d0) - If (NT == 0 ) then - Phase_tau = Phase_tau + ZS - NobsT = NobsT + 1 - endif - If ( N_FL == 1 ) then - Z = cmplx(dble(N_SUN),0.d0) - Do I = 1,Latt%N - Do J = 1,Latt%N - imj = latt%imj(I,J) - Green_tau(imj,nt+1,1,1) = green_tau(imj,nt+1,1,1) + Z * GT0(I,J,1) * ZP* ZS - Den_tau (imj,nt+1,1,1) = Den_tau (imj,nt+1,1,1) - Z * GT0(I,J,1)*G0T(J,I,1) * ZP* ZS - Enddo - Enddo - Endif - end Subroutine OBSERT - - - end Module Hamiltonian diff --git a/Prog_8/Hamiltonian_Ising.f90 b/Prog_8/Hamiltonian_Ising.f90 deleted file mode 100644 index 8d3cc7e58..000000000 --- a/Prog_8/Hamiltonian_Ising.f90 +++ /dev/null @@ -1,579 +0,0 @@ - Module Hamiltonian - - Use Operator_mod - Use Lattices_v3 - Use MyMats - Use Random_Wrap - Use Files_mod - Use Matrix - - - Type (Operator), dimension(:,:), allocatable :: Op_V - Type (Operator), dimension(:,:), allocatable :: Op_T - Integer, allocatable :: nsigma(:,:) - Integer :: Ndim, N_FL, N_SUN, Ltrot - !Complex (Kind=8), dimension(:,:,:), allocatable :: Exp_T(:,:,:), Exp_T_M1(:,:,:) - - - - ! What is below is private - - Type (Lattice), private :: Latt - Integer, private :: L1, L2 - real (Kind=8), private :: ham_T , ham_xi, ham_h, ham_J, ham_U, Ham_Vint, Ham_chem - real (Kind=8), private :: Dtau, Beta - Character (len=64), private :: Model, Lattice_type - Integer, allocatable, private :: L_bond(:,:), Ising_nnlist(:,:) - Real (Kind=8), private :: DW_Ising_tau (-1:1), DW_Ising_Space(-1:1) - Logical, private :: One_dimensional - Integer, private :: N_coord - Real (Kind=8), private :: Bound - - - ! Observables - Integer, private :: Nobs, Norb - Complex (Kind=8), allocatable, private :: obs_scal(:) - Complex (Kind=8), allocatable, private :: Ising_cor(:,:,:) - Complex (Kind=8), allocatable, private :: Green_eq (:,:,:), Spin_eq(:,:,:), Den_eq (:,:,:) - Complex (Kind=8), allocatable, private :: Green_eq0 (:), Spin_eq0(:), Pair_eq0(:), Den_eq0(:) - Complex (Kind=8), allocatable, private :: Ising_cor0(:) - - ! For time displaced - Integer, private :: NobsT - Complex (Kind=8), private :: Phase_tau - Complex (Kind=8), allocatable, private :: Green_tau(:,:,:,:), Den_tau(:,:,:,:) - - contains - - Subroutine Ham_Set - - Implicit none -#include "machine" -#ifdef MPI - include 'mpif.h' -#endif - - integer :: ierr - - NAMELIST /VAR_lattice/ L1, L2, Lattice_type, Model - - - NAMELIST /VAR_Ising/ ham_T, ham_chem, ham_xi, ham_h, ham_J, Beta, dtau, N_SUN - - -#ifdef MPI - Integer :: Isize, Irank - Integer :: STATUS(MPI_STATUS_SIZE) - CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) - CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) -#endif - - -#ifdef MPI - If (Irank == 0 ) then -#endif - OPEN(UNIT=5,FILE='parameters',STATUS='old',ACTION='read',IOSTAT=ierr) - IF (ierr /= 0) THEN - WRITE(*,*) 'unable to open ',ierr - STOP - END IF - READ(5,NML=VAR_lattice) - CLOSE(5) -#ifdef MPI - ENDIF - CALL MPI_BCAST(L1 ,1 ,MPI_INTEGER, 0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(L2 ,1 ,MPI_INTEGER, 0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(Model ,64 ,MPI_CHARACTER, 0,MPI_COMM_WORLD,IERR) - CALL MPI_BCAST(Lattice_type,64 ,MPI_CHARACTER, 0,MPI_COMM_WORLD,IERR) -#endif - Call Ham_latt - - If ( Model == "Ising" ) then - N_FL = 1 -#ifdef MPI - If (Irank == 0 ) then -#endif - OPEN(UNIT=5,FILE='parameters',STATUS='old',ACTION='read',IOSTAT=ierr) - READ(5,NML=VAR_Ising) - CLOSE(5) -#ifdef MPI - endif - CALL MPI_BCAST(ham_T ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(ham_chem ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(ham_xi ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(ham_h ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(ham_J ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(Beta ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(dtau ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(N_SUN ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) -#endif - else - Write(6,*) ' Model not yet programmed : ' - Stop - endif - Call Ham_hop - Ltrot = nint(beta/dtau) -#ifdef MPI - If (Irank == 0) then -#endif - Open (Unit = 50,file="info",status="unknown",position="append") - Write(50,*) '=====================================' - Write(50,*) 'Model is : ', Model - Write(50,*) 'Beta : ', Beta - Write(50,*) 'dtau,Ltrot : ', dtau,Ltrot - Write(50,*) 'N_SUN : ', N_SUN - Write(50,*) 'N_FL : ', N_FL - Write(50,*) 't : ', Ham_T - Write(50,*) 'xi : ', Ham_xi - Write(50,*) 'h : ', Ham_h - Write(50,*) 'Ham_J : ', Ham_J - close(50) -#ifdef MPI - endif -#endif - call Ham_V - end Subroutine Ham_Set -!============================================================================= - Subroutine Ham_Latt - Implicit none - !Set the lattice - Real (Kind=8) :: a1_p(2), a2_p(2), L1_p(2), L2_p(2) - If ( Lattice_type =="Square" ) then - a1_p(1) = 1.0 ; a1_p(2) = 0.d0 - a2_p(1) = 0.0 ; a2_p(2) = 1.d0 - L1_p = dble(L1)*a1_p - L2_p = dble(L2)*a2_p - Call Make_Lattice( L1_p, L2_p, a1_p, a2_p, Latt ) - Ndim = Latt%N - !Write(6,*) 'Lattice: ', Ndim - One_dimensional = .false. - N_coord = 2 - If ( L1 == 1 .or. L2 == 1 ) then - One_dimensional = .true. - N_coord = 1 - If (L1 == 1 ) then - Write(6,*) ' For one dimensional systems set L2 = 1 ' - Stop - endif - endif - else - Write(6,*) "Lattice not yet implemented!" - Stop - endif - end Subroutine Ham_Latt - -!=================================================================================== - Subroutine Ham_hop - Implicit none - - !Setup the hopping - - Integer :: I, I1, I2, n, Ncheck,nc - Real (Kind=8) :: X - - Ncheck = 1 - allocate(Op_T(Ncheck,N_FL)) - do n = 1,N_FL - Do nc = 1,Ncheck - Call Op_make(Op_T(nc,n),Ndim) - If (One_dimensional ) then - DO I = 1, Latt%N - I1 = Latt%nnlist(I,1,0) - Op_T(nc,n)%O(I,I1) = cmplx(-Ham_T,0.d0) - Op_T(nc,n)%O(I1,I) = cmplx(-Ham_T,0.d0) - Op_T(nc,n)%O(I ,I) = cmplx(-Ham_chem,0.d0) - ENDDO - else - DO I = 1, Latt%N - I1 = Latt%nnlist(I,1,0) - I2 = Latt%nnlist(I,0,1) - Op_T(nc,n)%O(I,I1) = cmplx(-Ham_T, 0.d0) - Op_T(nc,n)%O(I1,I) = cmplx(-Ham_T, 0.d0) - Op_T(nc,n)%O(I,I2) = cmplx(-Ham_T, 0.d0) - Op_T(nc,n)%O(I2,I) = cmplx(-Ham_T, 0.d0) - Op_T(nc,n)%O(I ,I) = cmplx(-Ham_chem,0.d0) - ENDDO - endif - - Do I = 1,Latt%N - Op_T(nc,n)%P(i) = i - Enddo - if ( abs(Ham_T) < 1.E-6 .and. abs(Ham_chem) < 1.E-6 ) then - Op_T(nc,n)%g=cmplx(0.d0 ,0.d0) - else - Op_T(nc,n)%g=cmplx(-Dtau,0.d0) - endif - !Write(6,*) 'In Ham_hop', Ham_T - Call Op_set(Op_T(nc,n)) - !Write(6,*) 'In Ham_hop 1' - !Do I = 1,Latt%N - ! Write(6,*) Op_T(n)%E(i) - !enddo - !Call Op_exp( cmplx(-Dtau,0.d0), Op_T(n), Exp_T (:,:,n) ) - !Call Op_exp( cmplx( Dtau,0.d0), Op_T(n), Exp_T_M1(:,:,n) ) - enddo - enddo - end Subroutine Ham_hop - -!=================================================================================== - - Subroutine Ham_V - - Implicit none - - Integer :: nf, nth, n, n1, n2, n3, n4, I, I1, I2, J, Ix, Iy, nc - Real (Kind=8) :: X_p(2), X1_p(2), X2_p(2), X - - - If (Model == "Ising" ) then - Allocate( Op_V(N_coord*Latt%N,N_FL) ) - do nf = 1,N_FL - do i = 1, N_coord*Latt%N - Call Op_make(Op_V(i,nf),2) - enddo - enddo - Allocate (L_Bond(Latt%N,2)) - Do nf = 1,N_FL - nc = 0 - do nth = 1,2*N_coord - Do n1= 1, L1/2 - Do n2 = 1,L2 - nc = nc + 1 - If (nth == 1 ) then - X_p = dble(2*n1)*latt%a1_p + dble(n2)*latt%a2_p - I1 = Inv_R(X_p,Latt) - I2 = Latt%nnlist(I1,1,0) - L_bond(I1,1) = nc - elseif (nth == 2) then - X_p = dble(2*n1)*latt%a1_p + dble(n2)*latt%a2_p + latt%a1_p - I1 = Inv_R(X_p,Latt) - I2 = Latt%nnlist(I1,1,0) - L_bond(I1,1) = nc - elseif (nth == 3) then - X_p = dble(n2)*latt%a1_p + dble(2*n1)*latt%a2_p - I1 = Inv_R(X_p,Latt) - I2 = Latt%nnlist(I1,0,1) - L_bond(I1,2) = nc - elseif (nth == 4) then - X_p = dble(n2)*latt%a1_p + dble(2*n1)*latt%a2_p + latt%a2_p - I1 = Inv_R(X_p,Latt) - I2 = Latt%nnlist(I1,0,1) - L_bond(I1,2) = nc - endif - Op_V(nc,nf)%P(1) = I1; Op_V(nc,nf)%P(2) = I2 - Op_V(nc,nf)%O(1,2) = cmplx(1.d0 ,0.d0) - Op_V(nc,nf)%O(2,1) = cmplx(1.d0 ,0.d0) - Op_V(nc,nf)%g = cmplx(-dtau*Ham_xi,0.d0) - Op_V(nc,nf)%alpha = cmplx(0.d0 ,0.d0) - Op_V(nc,nf)%type = 1 - Call Op_set( Op_V(nc,nf) ) - ! For a single flavour, the operator reads: - ! g*s*( c^{dagger} O c - alpha )) - ! with s the HS field. - Enddo - Enddo - Enddo - Enddo -!!$ Open (Unit=10,File="Latt",status="unknown") -!!$ Do I = 1,Latt%N -!!$ X_p = dble(latt%list(I,1))*latt%a1_p + dble(latt%list(I,2))*latt%a2_p -!!$ Write(10,*) X_p(1), X_p(2) -!!$ Write(10,*) X_p(1)+ latt%a1_p(1), X_p(2) + latt%a1_p(2) -!!$ Write(10,*) -!!$ Write(10,*) X_p(1), X_p(2) -!!$ Write(10,*) X_p(1)+ latt%a2_p(1), X_p(2) + latt%a2_p(2) -!!$ Write(10,*) -!!$ Enddo -!!$ Close(10) - allocate(Ising_nnlist(2*Latt%N,4)) - do I = 1,Latt%N - n = L_bond(I,1) - n1 = L_bond(Latt%nnlist(I, 1, 0),2) - n2 = L_bond(Latt%nnlist(I, 0, 0),2) - n3 = L_bond(Latt%nnlist(I, 0,-1),2) - n4 = L_bond(Latt%nnlist(I, 1,-1),2) - Ising_nnlist(n,1) = n1 - Ising_nnlist(n,2) = n2 - Ising_nnlist(n,3) = n3 - Ising_nnlist(n,4) = n4 - n = L_bond(I,2) - n1 = L_bond(Latt%nnlist(I, 0, 1),1) - n2 = L_bond(Latt%nnlist(I,-1, 1),1) - n3 = L_bond(Latt%nnlist(I,-1, 0),1) - n4 = L_bond(Latt%nnlist(I, 0, 0),1) - Ising_nnlist(n,1) = n1 - Ising_nnlist(n,2) = n2 - Ising_nnlist(n,3) = n3 - Ising_nnlist(n,4) = n4 - enddo - DW_Ising_tau ( 1) = (exp(Dtau*Ham_h) - exp(-Dtau*Ham_h))/(exp(Dtau*Ham_h) + exp(-Dtau*Ham_h)) - DW_Ising_tau (-1) = (exp(Dtau*Ham_h) + exp(-Dtau*Ham_h))/(exp(Dtau*Ham_h) - exp(-Dtau*Ham_h)) - DW_Ising_Space( 1) = exp(-2.d0*Dtau*Ham_J) - DW_Ising_Space(-1) = exp( 2.d0*Dtau*Ham_J) -!!$ Open (Unit=10,File="Ising_latt",status="unknown") -!!$ nf = 1 -!!$ Do I = 1,Latt%N -!!$ I1 = Op_V(L_bond(I,1),nf)%P(2) -!!$ I2 = Op_V(L_bond(I,2),nf)%P(2) -!!$ X_p = dble(latt%list(I,1))*latt%a1_p + dble(latt%list(I,2))*latt%a2_p -!!$ X1_p = dble(latt%list(I1,1))*latt%a1_p + dble(latt%list(I1,2))*latt%a2_p -!!$ X2_p = dble(latt%list(I2,1))*latt%a1_p + dble(latt%list(I2,2))*latt%a2_p -!!$ Write(10,*) X_p (1), X_p (2) -!!$ Write(10,*) X1_p(1), X1_p(2) -!!$ Write(10,*) -!!$ Write(10,*) X_p (1), X_p (2) -!!$ Write(10,*) X2_p(1), X2_p(2) -!!$ Write(10,*) -!!$ Enddo -!!$ Close(10) - endif - end Subroutine Ham_V - -!=================================================================================== - Real (Kind=8) function S0(n,nt) - Implicit none - Integer, Intent(IN) :: n,nt - Integer :: i, nt1 - S0 = 1.d0 - If (Model == "Ising" ) then - do i = 1,4 - S0 = S0*DW_Ising_space(nsigma(n,nt)*nsigma(Ising_nnlist(n,i),nt)) - enddo - nt1 = nt +1 - if (nt1 > Ltrot) nt1 = 1 - S0 = S0*DW_Ising_tau(nsigma(n,nt)*nsigma(n,nt1)) - nt1 = nt - 1 - if (nt1 < 1 ) nt1 = Ltrot - S0 = S0*DW_Ising_tau(nsigma(n,nt)*nsigma(n,nt1)) - If (S0 < 0.d0) Write(6,*) 'S0 : ', S0 - endif - end function S0 - -!=================================================================================== - - Subroutine Alloc_obs(Ltau) - - Implicit none - Integer, Intent(In) :: Ltau - Integer :: I - Norb = 2 - Allocate ( Obs_scal(5) ) - Allocate ( Ising_cor (Latt%N,Norb,Norb) ) - Allocate ( Green_eq(Latt%N,1,1), Spin_eq(Latt%N,1,1), Den_eq(Latt%N,1,1) ) - Allocate ( Ising_cor0(Norb), Green_eq0(1), Spin_eq0(1), Den_eq0(1) ) - If (Ltau == 1) then - Allocate ( Green_tau(Latt%N,Ltrot+1,1,1), Den_tau(Latt%N,Ltrot+1,1,1) ) - endif - - - - end Subroutine Alloc_obs - -!=================================================================================== - - Subroutine Init_obs(Ltau) - - Implicit none - Integer, Intent(In) :: Ltau - - Integer :: I,n - - Nobs = 0 - Obs_scal = cmplx(0.d0,0.d0) - Ising_cor = cmplx(0.d0,0.d0) - Green_eq = cmplx(0.d0,0.d0) - Spin_eq = cmplx(0.d0,0.d0) - Den_eq = cmplx(0.d0,0.d0) - Ising_cor0= cmplx(0.d0,0.d0) - Green_eq0 = cmplx(0.d0,0.d0) - Spin_eq0 = cmplx(0.d0,0.d0) - Den_eq0 = cmplx(0.d0,0.d0) - - If (Ltau == 1) then - NobsT = 0 - Phase_tau = cmplx(0.d0,0.d0) - Green_tau = cmplx(0.d0,0.d0) - Den_tau = cmplx(0.d0,0.d0) - endif - - end Subroutine Init_obs - -!======================================================================== - Subroutine Obser(GR,Phase,Ntau) - - Implicit none - - Complex (Kind=8), INTENT(IN) :: GR(Ndim,Ndim,N_FL) - Complex (Kind=8), Intent(IN) :: PHASE - Integer, INTENT(IN) :: Ntau - - !Local - Complex (Kind=8) :: GRC(Ndim,Ndim,N_FL), ZK - Complex (Kind=8) :: Zrho, Zkin, ZPot, Z, ZP,ZS - Integer :: I,J, no,no1, n, n1, imj, nf, I1, I2, J1, J2 - - Real (Kind=8) :: G(4,4), X, FI, FJ - - Nobs = Nobs + 1 - ZP = PHASE/cmplx(Real(Phase,kind=8),0.d0) - ZS = cmplx(Real(Phase,kind=8)/Abs(Real(Phase,kind=8)), 0.d0) - - - Do nf = 1,N_FL - Do I = 1,Ndim - Do J = 1,Ndim - ZK = cmplx(0.d0,0.d0) - If ( I == J ) ZK = cmplx(1.d0,0.d0) - GRC(I,J,nf) = ZK - GR(J,I,nf) - Enddo - Enddo - Enddo - ! GRC(i,j,nf) = < c^{dagger}_{j,nf } c_{j,nf } > - ! Compute scalar observables. - Zkin = cmplx(0.d0,0.d0) - Do nf = 1,N_FL - Do J = 1,Ndim - DO I = 1,Ndim - Zkin = Zkin + Op_T(1,nf)%O(i,j)*Grc(i,j,nf) - Enddo - ENddo - Enddo - Zkin = Zkin*cmplx( dble(N_SUN), 0.d0 ) - - Zrho = cmplx(0.d0,0.d0) - Do nf = 1,N_FL - Do I = 1,Ndim - Zrho = Zrho + Grc(i,i,nf) - enddo - enddo - Zrho = Zrho*cmplx( dble(N_SUN), 0.d0 ) - - ZPot = cmplx(0.d0,0.d0) - - Obs_scal(1) = Obs_scal(1) + zrho * ZP*ZS - Obs_scal(2) = Obs_scal(2) + zkin * ZP*ZS - Obs_scal(3) = Obs_scal(3) + Zpot * ZP*ZS - Obs_scal(4) = Obs_scal(4) + (zkin + Zpot)*ZP*ZS - Obs_scal(5) = Obs_scal(5) + ZS - ! You will have to allocate more space if you want to include more scalar observables. - - ! Compute spin-spin, Green, and den-den correlation functions ! This is general N_SUN, and N_FL = 1 - If ( N_FL == 1 ) then - Z = cmplx(dble(N_SUN),0.d0) - Do I = 1,Latt%N - Do J = 1,Latt%N - imj = latt%imj(I,J) - GREEN_EQ(imj,1,1) = GREEN_EQ(imj,1,1) + Z * GRC(I,J,1) * ZP*ZS - SPIN_Eq (imj,1,1) = SPIN_Eq (imj,1,1) + Z * GRC(I,J,1) * GR(I,J,1) * ZP*ZS - DEN_Eq (imj,1,1) = DEN_Eq (imj,1,1) + ( & - & GRC(I,I,1) * GRC(J,J,1) *Z + & - & GRC(I,J,1) * GR(I,J,1) & - & ) * Z* ZP*ZS - ENDDO - Den_eq0(1) = Den_eq0(1) + Z* GRC(I,I,1)*ZP*ZS - ENDDO - ENDIF - - If (Model == "Ising" ) then - Do I = 1,Latt%N - do no = 1,Norb - n = L_bond(I,no) - do j = 1,Latt%N - imj = latt%imj(I,J) - do no1 = 1,Norb - n1 = L_bond(J,no1) - Ising_cor(imj,no,no1) = Ising_cor(imj,no,no1) + cmplx(dble(nsigma(n,ntau)*nsigma(n1,ntau)),0.d0)*ZP*ZS - enddo - enddo - enddo - enddo - endif - - end Subroutine Obser -!========================================================== - Subroutine Pr_obs(LTAU) - - - Use Print_bin_mod - Implicit none -#include "machine" -#ifdef MPI - include 'mpif.h' -#endif - - - Integer, Intent(In) :: Ltau - - Character (len=64) :: File_pr - Complex (Kind=8) :: Phase_bin -#ifdef MPI - Integer :: Isize, Irank, Ierr - Integer :: STATUS(MPI_STATUS_SIZE) - CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) - CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) -#endif -!!$#ifdef MPI -!!$ Write(6,*) Irank, 'In Pr_obs', LTAU -!!$#else -!!$ Write(6,*) 'In Pr_obs', LTAU -!!$#endif - - Phase_bin = Obs_scal(5)/cmplx(dble(Nobs),0.d0) - File_pr ="Ising_eq" - Call Print_bin(Ising_cor,Ising_cor0,Latt, Nobs, Phase_bin, file_pr) - File_pr ="Green_eq" - Call Print_bin(Green_eq, Green_eq0, Latt, Nobs, Phase_bin, file_pr) - File_pr ="Spin_eq" - Call Print_bin(Spin_eq, Spin_eq0, Latt, Nobs, Phase_bin, file_pr) - File_pr ="Den_eq" - Call Print_bin(Den_eq, Den_eq0, Latt, Nobs, Phase_bin, file_pr) - - - File_pr ="ener" - Call Print_scal(Obs_scal, Nobs, file_pr) - If (Ltau == 1) then - Phase_tau = Phase_tau/cmplx(dble(NobsT),0.d0) - File_pr = "Green_tau" - Call Print_bin_tau(Green_tau,Latt,NobsT,Phase_tau, file_pr,dtau) - File_pr = "Den_tau" - Call Print_bin_tau(Den_tau,Latt,NobsT,Phase_tau, file_pr,dtau) - endif -!!$#ifdef MPI -!!$ Write(6,*) Irank, 'out Pr_obs', LTAU -!!$#else -!!$ Write(6,*) 'out Pr_obs', LTAU -!!$#endif - end Subroutine Pr_obs -!========================================================== - - Subroutine OBSERT(NT, GT0,G0T,G00,GTT, PHASE) - Implicit none - - Integer , INTENT(IN) :: NT - Complex (Kind=8), INTENT(IN) :: GT0(Ndim,Ndim,N_FL),G0T(Ndim,Ndim,N_FL),G00(Ndim,Ndim,N_FL),GTT(Ndim,Ndim,N_FL) - Complex (Kind=8), INTENT(IN) :: Phase - - !Locals - Complex (Kind=8) :: Z, ZP, ZS - Integer :: IMJ, I, J - - ZP = PHASE/cmplx(Real(Phase,kind=8),0.d0) - ZS = cmplx(Real(Phase,kind=8)/Abs(Real(Phase,kind=8)), 0.d0) - If (NT == 0 ) then - Phase_tau = Phase_tau + ZS - NobsT = NobsT + 1 - endif - If ( N_FL == 1 ) then - Z = cmplx(dble(N_SUN),0.d0) - Do I = 1,Latt%N - Do J = 1,Latt%N - imj = latt%imj(I,J) - Green_tau(imj,nt+1,1,1) = green_tau(imj,nt+1,1,1) + Z * GT0(I,J,1) * ZP* ZS - Den_tau (imj,nt+1,1,1) = Den_tau (imj,nt+1,1,1) - Z * GT0(I,J,1)*G0T(J,I,1) * ZP* ZS - Enddo - Enddo - Endif - end Subroutine OBSERT - - - end Module Hamiltonian diff --git a/Prog_8/Hamiltonian_SPT.f90 b/Prog_8/Hamiltonian_SPT.f90 deleted file mode 100644 index 390ca751c..000000000 --- a/Prog_8/Hamiltonian_SPT.f90 +++ /dev/null @@ -1,548 +0,0 @@ - !Model Hamiltonian for interaction-induced topological reduction - Module Hamiltonian - - Use Operator_mod - Use Lattices_v3 - Use MyMats - Use Random_Wrap - Use Files_mod - Use Matrix - - - Type (Operator), dimension(:,:), allocatable :: Op_V - Type (Operator), dimension(:,:), allocatable :: Op_T - Integer, allocatable :: nsigma(:,:) - Integer :: Ndim, N_FL, N_SUN, Ltrot - - - - ! What is below is private - - Type (Lattice), private :: Latt - Integer, parameter, private :: Norb=16 - Integer, allocatable, private :: List(:,:), Invlist(:,:) - Integer, private :: L1, L2 - real (Kind=8), private :: Ham_T, Ham_Vint, Ham_Lam - real (Kind=8), private :: Dtau, Beta - Character (len=64), private :: Model, Lattice_type - Complex (Kind=8), private :: Gamma_M(4,4,5), Sigma_M(2,2,0:3) - - - ! Observables - Integer, private :: Nobs - Complex (Kind=8), allocatable, private :: obs_scal(:) - Complex (Kind=8), allocatable, private :: Den_eq(:,:,:), Den_eq0(:) - - ! For time displaced - Integer, private :: NobsT - Complex (Kind=8), private :: Phase_tau - Complex (Kind=8), allocatable, private :: Green_tau(:,:,:,:), Den_tau(:,:,:,:) - - contains - - Subroutine Ham_Set - - Implicit none -#include "machine" -#ifdef MPI - include 'mpif.h' -#endif - - integer :: ierr - - NAMELIST /VAR_lattice/ L1, L2, Lattice_type, Model - - NAMELIST /VAR_SPT/ ham_T, Ham_Vint, Ham_Lam, Dtau, Beta - - -#ifdef MPI - Integer :: Isize, Irank - Integer :: STATUS(MPI_STATUS_SIZE) - CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) - CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) - If (Irank == 0 ) then -#endif - OPEN(UNIT=5,FILE='parameters',STATUS='old',ACTION='read',IOSTAT=ierr) - IF (ierr /= 0) THEN - WRITE(*,*) 'unable to open ',ierr - STOP - END IF - READ(5,NML=VAR_lattice) - CLOSE(5) -#ifdef MPI - endif - - CALL MPI_BCAST(L1 ,1 ,MPI_INTEGER, 0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(L2 ,1 ,MPI_INTEGER, 0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(Model ,64 ,MPI_CHARACTER, 0,MPI_COMM_WORLD,IERR) - CALL MPI_BCAST(Lattice_type,64 ,MPI_CHARACTER, 0,MPI_COMM_WORLD,IERR) -#endif - Call Ham_latt - - N_FL = 1 - N_SUN = 1 - -#ifdef MPI - If (Irank == 0 ) then -#endif - OPEN(UNIT=5,FILE='parameters',STATUS='old',ACTION='read',IOSTAT=ierr) - READ(5,NML=VAR_SPT) - CLOSE(5) -#ifdef MPI - endif - - CALL MPI_BCAST(ham_T ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(ham_Vint ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(ham_Lam ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(Dtau ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(Beta ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) -#endif - - Call Ham_hop - Ltrot = nint(beta/dtau) -#ifdef MPI - If (Irank == 0) then -#endif - Open (Unit = 50,file="info",status="unknown",position="append") - Write(50,*) '=====================================' - Write(50,*) 'Model is : ', Model - Write(50,*) 'Lattice is : ', Lattice_type - Write(50,*) 'Beta : ', Beta - Write(50,*) 'dtau,Ltrot : ', dtau,Ltrot - Write(50,*) 't : ', Ham_T - Write(50,*) 'V : ', Ham_Vint - Write(50,*) 'Lambda : ', Ham_Lam - close(50) -#ifdef MPI - endif -#endif - call Ham_V - end Subroutine Ham_Set -!============================================================================= - - Subroutine Ham_Latt - Implicit none - !Set the lattice - Integer :: no, I, nc - Real (Kind=8) :: a1_p(2), a2_p(2), L1_p(2), L2_p(2) - If ( Lattice_type =="Square" ) then - a1_p(1) = 1.0 ; a1_p(2) = 0.d0 - a2_p(1) = 0.0 ; a2_p(2) = 1.d0 - L1_p = dble(L1)*a1_p - L2_p = dble(L2)*a2_p - Call Make_Lattice( L1_p, L2_p, a1_p, a2_p, Latt ) - !Write(6,*) 'Lattice: ', Ndim - else - Write(6,*) "Lattice not yet implemented!" - Stop - endif - - Ndim = Latt%N*Norb - Allocate (List(Ndim,Norb), Invlist(Latt%N,Norb)) - nc = 0 - Do I = 1,Latt%N - Do no = 1,Norb - nc = nc + 1 - List(nc,1) = I - List(nc,2) = no - Invlist(I,no) = nc - ! no = 1..4 Xi_1 - ! no = 5..8 Xi_2 - ! no = 9..12 Xi_3 - ! no = 13..16 Xi_4 - Enddo - Enddo - - end Subroutine Ham_Latt - -!=================================================================================== - Subroutine Ham_hop - Implicit none - - ! Setup the hopping - ! Per flavor, the hopping is given by: - ! e^{-dtau H_t} = Prod_{n=1}^{Ncheck} e^{-dtau_n H_{n,t}} - - Integer :: I, I1, I2,I3,no, no1, n, Ncheck, nc , nth - Integer, allocatable :: Invlist_1(:,:) - Real (Kind=8) :: X - Complex (Kind=8) :: Z - - - ! Setup Gamma matrices - Gamma_M = cmplx(0.d0,0.d0) - Sigma_M = cmplx(0.d0,0.d0) - Sigma_M(1,1,0) = cmplx( 1.d0, 0.d0) - Sigma_M(2,2,0) = cmplx( 1.d0, 0.d0) - Sigma_M(1,2,1) = cmplx( 1.d0, 0.d0) - Sigma_M(2,1,1) = cmplx( 1.d0, 0.d0) - Sigma_M(1,2,2) = cmplx( 0.d0,-1.d0) - Sigma_M(2,1,2) = cmplx( 0.d0, 1.d0) - Sigma_M(1,1,3) = cmplx( 1.d0, 0.d0) - Sigma_M(2,2,3) = cmplx(-1.d0, 0.d0) - Do no = 1,2 - Do no1 = 1,2 - Gamma_M(no+2,no1 ,1) = Sigma_M(no,no1,0) - Gamma_M(no ,no1+2,1) = Sigma_M(no,no1,0) - Gamma_M(no+2,no1 ,2) = cmplx( 0.d0,-1.d0)*Sigma_M(no,no1,0) - Gamma_M(no ,no1+2,2) = cmplx( 0.d0, 1.d0)*Sigma_M(no,no1,0) - Gamma_M(no ,no1 ,3) = cmplx( 1.d0, 0.d0)*Sigma_M(no,no1,1) - Gamma_M(no+2,no1+2,3) = cmplx(-1.d0, 0.d0)*Sigma_M(no,no1,1) - Gamma_M(no ,no1 ,4) = cmplx( 1.d0, 0.d0)*Sigma_M(no,no1,2) - Gamma_M(no+2,no1+2,4) = cmplx(-1.d0, 0.d0)*Sigma_M(no,no1,2) - Gamma_M(no ,no1 ,5) = cmplx( 1.d0, 0.d0)*Sigma_M(no,no1,3) - Gamma_M(no+2,no1+2,5) = cmplx(-1.d0, 0.d0)*Sigma_M(no,no1,3) - Enddo - Enddo - - Ncheck = 4 - Allocate ( Invlist_1(Latt%N,4) ) - allocate(Op_T(Ncheck,N_FL)) - do n = 1,N_FL - Do nc = 1,NCheck - Call Op_make(Op_T(nc,n),Ndim/4) - I1 = 0 - Do no = 1,4 - DO I = 1, Latt%N - I1 = I1 + 1 - Invlist_1(I,no) = I1 - Op_T(nc,n)%P(I1) = Invlist(I, no + 4*(nc -1) ) - enddo - enddo - Do I = 1,Latt%N - do no = 1,4 - do no1 = 1,4 - Z = cmplx(1.d0*Ham_T,0.d0)*Gamma_M(no,no1,3) - Op_T(nc,n)%O( Invlist_1(I,no) ,Invlist_1(I,no1) ) = Z - enddo - enddo - I1 = Latt%nnlist(I,1,0) - do no = 1,4 - do no1 = 1,4 - Z = (cmplx(0.d0,Ham_T)*Gamma_M(no,no1,1) + cmplx(Ham_T,0.d0)*Gamma_M(no,no1,3))/cmplx(2.d0,0.d0) - Op_T(nc,n)%O( invlist_1(I ,no ), invlist_1(I1,no1 ) ) = Z - Op_T(nc,n)%O( invlist_1(I1,no1 ), invlist_1(I ,no ) ) = conjg(Z) - enddo - enddo - I2 = Latt%nnlist(I,0,1) - do no = 1,4 - do no1 = 1,4 - Z = (cmplx(0.d0,Ham_Lam)*Gamma_M(no,no1,2) + cmplx(Ham_T,0.d0)*Gamma_M(no,no1,3))/cmplx(2.d0,0.d0) - Op_T(nc,n)%O( invlist_1(I ,no ), invlist_1(I2,no1 ) ) = Z - Op_T(nc,n)%O( invlist_1(I2,no1), invlist_1(I ,no ) ) = conjg(Z) - enddo - enddo - enddo - Op_T(nc,n)%g=cmplx(-Dtau,0.d0) - Call Op_set(Op_T(nc,n)) - ! Just for tests - Do I = 1, Ndim/4 - Write(6,*) i,Op_T(nc,n)%E(i) - enddo - enddo - enddo - - deallocate (Invlist_1) - - end Subroutine Ham_hop -!=================================================================================== - Subroutine Ham_V - - Implicit none - - Integer :: nf, nth, n, n1, n2, n3, n4, I, I1, I2, J, Ix, Iy, nc, no,no1, ns, npm - Integer :: nxy - Real (Kind=8) :: X_p(2), X1_p(2), X2_p(2), X, XJ, Xpm - - Complex (Kind=8) :: Ps(4,4,2), Ps_G5(4,4,2), Tmp(4,4), Z - Complex (Kind=8) :: Sx(16,16,2,2), Sy(16,16,2,2) - - - Ps = cmplx(0.d0,0.d0) - Call mmult (Tmp,Gamma_M(:,:,3), Gamma_M(:,:,4) ) - do ns = 1,2 - if (ns == 1) X = 1.d0/2d0 - if (ns == 2) X = -1.d0/2.d0 - Do I = 1,4 - Do J = 1,4 - Z = cmplx(0.d0,0.d0) - if ( I == J ) Z = cmplx(1.d0/2.d0,0.d0) - Ps(I,J,ns) = Z + cmplx(0.d0,X) * tmp(I,J) - Enddo - Enddo - Enddo - - Do ns = 1,2 - Call mmult ( Ps_G5(:,:,ns), Ps(:,:,ns), Gamma_M(:,:,5) ) - enddo - - Sx = cmplx(0.d0,0.d0) - Sy = cmplx(0.d0,0.d0) - Do ns = 1,2 - Do npm = 1,2 - if (npm == 1) Xpm = 1.0 - if (npm == 2) Xpm = -1.0 - Do no = 1,4 - do no1 = 1,4 - Sx(no , no1 + 4 ,ns,npm) = cmplx(1.d0, 0.d0)*Ps_G5(no,no1,ns) - Sx(no +4 , no1 ,ns,npm) = cmplx(1.d0, 0.d0)*Ps_G5(no,no1,ns) - Sx(no +8 , no1 + 12,ns,npm) = cmplx(xpm, 0.d0)*Ps_G5(no,no1,ns) - Sx(no+12 , no1 + 8 ,ns,npm) = cmplx(xpm, 0.d0)*Ps_G5(no,no1,ns) - - Sy(no , no1 + 4 ,ns,npm) = cmplx(0.d0, -1.d0 )*Ps_G5(no,no1,ns) - Sy(no +4 , no1 ,ns,npm) = cmplx(0.d0, 1.d0 )*Ps_G5(no,no1,ns) - Sy(no +8 , no1 + 12,ns,npm) = cmplx(0.d0, 1.d0*xpm)*Ps_G5(no,no1,ns) - Sy(no+12 , no1 + 8 ,ns,npm) = cmplx(0.d0, -1.d0*xpm)*Ps_G5(no,no1,ns) - enddo - enddo - enddo - enddo - - - ! Number of opertors 8 per unit cell - Allocate( Op_V(8*Latt%N,N_FL) ) - do nf = 1,N_FL - do i = 1, 8*Latt%N - Call Op_make(Op_V(i,nf),Norb) - enddo - enddo - nc = 0 - Do nf = 1,N_FL - do nxy = 1,2 - do ns = 1,2 - do npm = 1,2 - Xpm = 1.d0 - if (npm == 2) Xpm = -1.d0 - Do i = 1,Latt%N - nc = nc + 1 - Do no = 1,Norb - Op_V(nc,nf)%P(no) = Invlist(I,no) - enddo - Do no = 1,Norb - Do no1 = 1,Norb - If (nxy == 1) Op_V(nc,nf)%O(no,no1) = Sx(no,no1,ns,npm) - If (nxy == 2) Op_V(nc,nf)%O(no,no1) = Sy(no,no1,ns,npm) - Enddo - Enddo - Op_V(nc,nf)%g = SQRT(CMPLX(-Xpm*DTAU*Ham_Vint/8.d0,0.D0)) - Op_V(nc,nf)%alpha = cmplx(0.d0,0.d0) - Op_V(nc,nf)%type = 2 - Call Op_set( Op_V(nc,nf) ) - ! The operator reads: - ! g*s*( c^{dagger} O c - alpha )) - ! with s the HS field. - Enddo - Enddo - Enddo - Enddo - Enddo - - end Subroutine Ham_V - -!=================================================================================== - Real (Kind=8) function S0(n,nt) - Implicit none - Integer, Intent(IN) :: n,nt - Integer :: i, nt1 - S0 = 1.d0 - end function S0 - -!=================================================================================== - Subroutine Alloc_obs(Ltau) - - Implicit none - Integer, Intent(In) :: Ltau - Integer :: I - Allocate ( Obs_scal(5) ) - Allocate ( Den_eq(Latt%N,Norb,Norb), Den_eq0(Norb) ) - If (Ltau == 1) then - Allocate ( Green_tau(Latt%N,Ltrot+1,Norb,Norb), Den_tau(Latt%N,Ltrot+1,Norb,Norb) ) - endif - - end Subroutine Alloc_obs - -!=================================================================================== - - Subroutine Init_obs(Ltau) - - Implicit none - Integer, Intent(In) :: Ltau - - Integer :: I,n - - Nobs = 0 - Obs_scal = cmplx(0.d0,0.d0) - Den_eq = cmplx(0.d0,0.d0) - Den_eq0 = cmplx(0.d0,0.d0) - - If (Ltau == 1) then - NobsT = 0 - Phase_tau = cmplx(0.d0,0.d0) - Green_tau = cmplx(0.d0,0.d0) - Den_tau = cmplx(0.d0,0.d0) - endif - - end Subroutine Init_obs - -!======================================================================== - Subroutine Obser(GR,Phase,Ntau) - - Implicit none - - Complex (Kind=8), INTENT(IN) :: GR(Ndim,Ndim,N_FL) - Complex (Kind=8), Intent(IN) :: PHASE - Integer, INTENT(IN) :: Ntau - - !Local - Complex (Kind=8) :: GRC(Ndim,Ndim,N_FL), ZK - Complex (Kind=8) :: Zrho, Zkin, ZPot, Z, ZP,ZS - Integer :: I,J, no,no1, n, n1, imj, nf, I1, I2, J1, J2, Nc - - Real (Kind=8) :: G(4,4), X, FI, FJ - - Nobs = Nobs + 1 - ZP = PHASE/cmplx(Real(Phase,kind=8),0.d0) - ZS = cmplx(Real(Phase,kind=8)/Abs(Real(Phase,kind=8)), 0.d0) - - - Do nf = 1,N_FL - Do I = 1,Ndim - Do J = 1,Ndim - ZK = cmplx(0.d0,0.d0) - If ( I == J ) ZK = cmplx(1.d0,0.d0) - GRC(I,J,nf) = ZK - GR(J,I,nf) - Enddo - Enddo - Enddo - ! GRC(i,j,nf) = < c^{dagger}_{j,nf } c_{j,nf } > - ! Compute scalar observables. - - Zkin = cmplx(0.d0,0.d0) - - Nc = Size( Op_T,1) - Do nf = 1,N_FL - Do n = 1,Nc - Do J = 1,Op_T(n,nf)%N - J1 = Op_T(n,nf)%P(J) - DO I = 1,Op_T(n,nf)%N - I1 = Op_T(n,nf)%P(I) - Zkin = Zkin + Op_T(n,nf)%O(i,j)*Grc(i1,j1,nf) - Enddo - ENddo - Enddo - Enddo - Zkin = Zkin*cmplx( dble(N_SUN), 0.d0 ) - - Zrho = cmplx(0.d0,0.d0) - Do nf = 1,N_FL - Do I = 1,Ndim - Zrho = Zrho + Grc(i,i,nf) - enddo - enddo - Zrho = Zrho*cmplx( dble(N_SUN), 0.d0 ) - - ZPot = cmplx(0.d0,0.d0) - - Obs_scal(1) = Obs_scal(1) + zrho * ZP*ZS - Obs_scal(2) = Obs_scal(2) + zkin * ZP*ZS - Obs_scal(3) = Obs_scal(3) + Zpot * ZP*ZS - Obs_scal(4) = Obs_scal(4) + (zkin + Zpot)*ZP*ZS - Obs_scal(5) = Obs_scal(5) + ZS - ! You will have to allocate more space if you want to include more scalar observables. - DO I1 = 1,Ndim - I = List(I1,1) - no = List(I1,2) - DO J1 = 1, Ndim - J = List(J1,1) - no1 = list(J1,2) - imj = latt%imj(I,J) - - DEN_Eq (imj,no,no1) = DEN_Eq (imj,no,no1) + & - & ( GRC(I1,J1,1) * GR (I1,J1,1) + & - & GRC(I1,I1,1) * GRC(J1,J1,1) ) * ZP*ZS - - enddo - Den_eq0(no) = Den_eq0(no) + GRC(I1,I1,1)*ZP*ZS - enddo - - end Subroutine Obser -!========================================================== - - Subroutine Pr_obs(LTAU) - - Use Print_bin_mod - Implicit none -#include "machine" -#ifdef MPI - include 'mpif.h' -#endif - - - Integer, Intent(In) :: Ltau - - Character (len=64) :: File_pr - Complex (Kind=8) :: Phase_bin -#ifdef MPI - Integer :: Isize, Irank, Ierr - Integer :: STATUS(MPI_STATUS_SIZE) - CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) - CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) -#endif -!!$#ifdef MPI -!!$ Write(6,*) Irank, 'In Pr_obs', LTAU -!!$#else -!!$ Write(6,*) 'In Pr_obs', LTAU -!!$#endif - - Phase_bin = Obs_scal(5)/cmplx(dble(Nobs),0.d0) - File_pr ="Den_eq" - Call Print_bin(Den_eq, Den_eq0, Latt, Nobs, Phase_bin, file_pr) - - File_pr ="ener" - Call Print_scal(Obs_scal, Nobs, file_pr) - If (Ltau == 1) then - Phase_tau = Phase_tau/cmplx(dble(NobsT),0.d0) - File_pr = "Green_tau" - Call Print_bin_tau(Green_tau,Latt,NobsT,Phase_tau, file_pr,dtau) - File_pr = "Den_tau" - Call Print_bin_tau(Den_tau,Latt,NobsT,Phase_tau, file_pr,dtau) - endif -!!$#ifdef MPI -!!$ Write(6,*) Irank, 'out Pr_obs', LTAU -!!$#else -!!$ Write(6,*) 'out Pr_obs', LTAU -!!$#endif - end Subroutine Pr_obs -!========================================================== - - Subroutine OBSERT(NT, GT0,G0T,G00,GTT, PHASE) - Implicit none - - Integer , INTENT(IN) :: NT - Complex (Kind=8), INTENT(IN) :: GT0(Ndim,Ndim,N_FL),G0T(Ndim,Ndim,N_FL),G00(Ndim,Ndim,N_FL),GTT(Ndim,Ndim,N_FL) - Complex (Kind=8), INTENT(IN) :: Phase - - !Locals - Complex (Kind=8) :: Z, ZP, ZS - Integer :: IMJ, I, J - - ZP = PHASE/cmplx(Real(Phase,kind=8),0.d0) - ZS = cmplx(Real(Phase,kind=8)/Abs(Real(Phase,kind=8)), 0.d0) - If (NT == 0 ) then - Phase_tau = Phase_tau + ZS - NobsT = NobsT + 1 - endif - If ( N_FL == 1 ) then - Z = cmplx(dble(N_SUN),0.d0) - Do I = 1,Latt%N - Do J = 1,Latt%N - imj = latt%imj(I,J) - Green_tau(imj,nt+1,1,1) = green_tau(imj,nt+1,1,1) + Z * GT0(I,J,1) * ZP* ZS - Den_tau (imj,nt+1,1,1) = Den_tau (imj,nt+1,1,1) - Z * GT0(I,J,1)*G0T(J,I,1) * ZP* ZS - Enddo - Enddo - Endif - end Subroutine OBSERT - - - end Module Hamiltonian diff --git a/Prog_8/Hop_mod.f90 b/Prog_8/Hop_mod.f90 deleted file mode 100644 index 0d6028fb4..000000000 --- a/Prog_8/Hop_mod.f90 +++ /dev/null @@ -1,217 +0,0 @@ -! This is for the Kondo project with tarun. - Module Hop_mod - - - Use Hamiltonian - Use Random_wrap - Use MyMats - - ! Private variables - Complex (Kind=8), allocatable, private :: Exp_T(:,:,:,:), Exp_T_M1(:,:,:,:) - Complex (Kind=8), allocatable, private :: U_HLP(:,:), U_HLP1(:,:), V_HLP(:,:), V_HLP1(:,:) - Integer, private, save :: Ncheck, Ndim_hop - Real (Kind=8), private, save :: Zero - - Contains - - subroutine Hop_mod_init - - Implicit none - - Integer :: nc, nf - Complex (Kind=8) :: g - - Ncheck = size(Op_T,1) - If ( size(Op_T,2) /= N_FL ) then - Write(6,*) 'Error in the number of flavors.' - Stop - 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(6,*) 'Different size of Hoppings not implemented ' - Stop - 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 ( V_Hlp(Ndim_hop,Ndim) ) - Allocate ( V_Hlp1(Ndim_hop,Ndim) ) - Allocate ( U_Hlp (Ndim, Ndim_hop) ) - Allocate ( U_Hlp1(Ndim, Ndim_hop) ) - - Exp_T = cmplx(0.d0,0.d0) - Exp_T_M1 = cmplx(0.d0,0.d0) - do nf = 1,N_FL - 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)) - enddo - enddo - - Zero = 1.E-12 - - end subroutine Hop_mod_init - -!============================================================================ - Subroutine Hop_mod_mmthr(In, Out,nf) - - - ! In: IN - ! Out: OUT = e^{ -dtau T }.IN - Implicit none - - Complex (Kind=8), intent(IN) :: IN(Ndim,Ndim) - Complex (Kind=8), intent(INOUT) :: OUT(Ndim,Ndim) - Integer :: nf - - !Local - Integer :: nc, I, n - - Out = In - do nc = Ncheck,1,-1 - If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then - do I = 1,Ndim - do n = 1,Ndim_hop - V_Hlp(n,I) = Out(Op_T(nc,nf)%P(n),I) - enddo - enddo - Call mmult(V_HLP1,Exp_T(:,:,nc,nf),V_Hlp) - DO I = 1,Ndim - do n = 1,Ndim_hop - OUT(OP_T(nc,nf)%P(n),I) = V_hlp1(n,I) - Enddo - Enddo - Endif - Enddo - - end Subroutine Hop_mod_mmthr - -!============================================================================ - Subroutine Hop_mod_mmthr_m1(In, Out,nf) - - - ! In: IN - ! Out: OUT = e^{ dtau T }.IN - Implicit none - - Complex (Kind=8), intent(IN) :: IN(Ndim,Ndim) - Complex (Kind=8), intent(INOUT) :: OUT(Ndim,Ndim) - Integer :: nf - - !Local - Integer :: nc, I, n - - - Out = In - do nc = 1,Ncheck - If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then - do I = 1,Ndim - do n = 1,Ndim_hop - V_Hlp(n,I) = Out(Op_T(nc,nf)%P(n),I) - enddo - enddo - Call mmult(V_HLP1,Exp_T_m1(:,:,nc,nf),V_Hlp) - DO I = 1,Ndim - do n = 1,Ndim_hop - OUT(OP_T(nc,nf)%P(n),I) = V_hlp1(n,I) - Enddo - Enddo - Endif - Enddo - - end Subroutine Hop_mod_mmthr_m1 - -!============================================================================ - Subroutine Hop_mod_mmthl (In, Out,nf) - - - ! In: IN - ! Out: OUT = IN * e^{ -dtau T } - Implicit none - - Complex (Kind=8), intent(IN) :: IN(Ndim,Ndim) - Complex (Kind=8), intent(INOUT) :: OUT(Ndim,Ndim) - Integer :: nf - - !Local - Integer :: nc, I, n - - Out = In - do nc = 1, Ncheck - If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then - do n = 1,Ndim_hop - do I = 1,Ndim - U_Hlp(I,n) = Out(I,Op_T(nc,nf)%P(n)) - enddo - enddo - Call mmult(U_Hlp1,U_Hlp,Exp_T(:,:,nc,nf)) - do n = 1,Ndim_hop - DO I = 1,Ndim - OUT(I,OP_T(nc,nf)%P(n)) = U_hlp1(I,n) - Enddo - Enddo - Endif - Enddo - - end Subroutine Hop_mod_mmthl -!============================================================================ - Subroutine Hop_mod_mmthl_m1 (In, Out,nf) - - - ! In: IN - ! Out: OUT = IN * e^{ dtau T } - Implicit none - - Complex (Kind=8), intent(IN) :: IN(Ndim,Ndim) - Complex (Kind=8), intent(INOUT) :: OUT(Ndim,Ndim) - Integer :: nf - - !Local - Integer :: nc, I, n - - Out = In - do nc = Ncheck,1,-1 - If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then - do n = 1,Ndim_hop - do I = 1,Ndim - U_Hlp(I,n) = Out(I,Op_T(nc,nf)%P(n)) - enddo - enddo - Call mmult(U_Hlp1,U_Hlp,Exp_T_M1(:,:,nc,nf)) - do n = 1,Ndim_hop - DO I = 1,Ndim - OUT(I,OP_T(nc,nf)%P(n)) = U_hlp1(I,n) - Enddo - Enddo - Endif - Enddo - - end Subroutine Hop_mod_mmthl_m1 - -!============================================================================ -!!$ Subroutine Hop_mod_test -!!$ -!!$ Implicit none -!!$ -!!$ Complex (Kind=8) :: IN(Ndim,Ndim),Out(Ndim,Ndim) -!!$ Complex (Kind=8) :: Test(Ndim,Ndim) -!!$ -!!$ Integer :: I,J -!!$ -!!$ DO I = 1,Ndim -!!$ DO J = 1,Ndim -!!$ IN(J,I) = cmplx(Ranf(),Ranf()) -!!$ ENDDO -!!$ ENDDO -!!$ -!!$ !Write(6,*) IN -!!$ end Subroutine Hop_mod_test - - end Module Hop_mod diff --git a/Prog_8/Makefile b/Prog_8/Makefile deleted file mode 100644 index e20263c71..000000000 --- a/Prog_8/Makefile +++ /dev/null @@ -1,27 +0,0 @@ -FC= $(mpif90) -FC= $(f90) -FLAGS= $(FL) -LF = $(Lflags) -LIBS= $(Libs)/Modules/modules_90.a \ - $(Libs)/MyEis/libeis.a \ - $(Libs)/MyNag/libnag.a \ - $(Libs)/MyLin/liblin.a \ - $(LIB_BLAS_LAPACK) - -Hub: - cp $(Libs)/Modules/*.mod . ;\ - (make -f Compile_Hub FC="$(FC)" FLAGS="$(FLAGS)" LIBS="$(LIBS)" ) - -SPT: - cp $(Libs)/Modules/*.mod . ;\ - (make -f Compile_SPT FC="$(FC)" FLAGS="$(FLAGS)" LIBS="$(LIBS)" LF="$(LF)" ) - -Ising: - cp $(Libs)/Modules/*.mod . ;\ - (make -f Compile_Ising FC="$(FC)" FLAGS="$(FLAGS)" LIBS="$(LIBS)" LF="$(LF)" ) - -clean: - (make -f Compile_Hub clean );\ - (make -f Compile_SPT clean );\ - (make -f Compile_Ising clean );\ - rm *.mod *~ \#* diff --git a/Prog_8/Operator.f90 b/Prog_8/Operator.f90 deleted file mode 100644 index e2b1e9fa0..000000000 --- a/Prog_8/Operator.f90 +++ /dev/null @@ -1,459 +0,0 @@ -Module Operator_mod - - Use MyMats - - Implicit none - - Real (Kind=8) :: Phi(-2:2,2), Gaml(-2:2,2) - Integer :: NFLIPL(-2:2,3) - - - ! What information should the operator contain - Type Operator - Integer :: N, N_non_zero - complex (kind=8), pointer :: O(:,:), U (:,:) - Real (kind=8), pointer :: E(:) - Integer, pointer :: P(:) - complex (kind=8) :: g - complex (kind=8) :: alpha - Integer :: Type - ! P is an N X Ndim matrix such that P.T*O*P* = A - ! P has only one non-zero entry per column which is specified by P - ! All in all. g * Phi(s,type) * ( c^{dagger} A c + alpha ) - ! The variable Type allows you to define the type of HS. - ! The first N_non_zero elemets of diagonal matrix E are non-zero. The rest vanish. - end type Operator - - -Contains - - Subroutine Op_SetHS - Implicit none - Integer :: n - Phi = 0.d0 - do n = -2,2 - Phi(n,1) = real(n,kind=8) - enddo - Phi(-2,2) = - SQRT(2.D0 * ( 3.D0 + SQRT(6.D0) ) ) - Phi(-1,2) = - SQRT(2.D0 * ( 3.D0 - SQRT(6.D0) ) ) - Phi( 1,2) = SQRT(2.D0 * ( 3.D0 - SQRT(6.D0) ) ) - Phi( 2,2) = SQRT(2.D0 * ( 3.D0 + SQRT(6.D0) ) ) - - Do n = -2,2 - gaml(n,1) = 1.d0 - Enddo - GAML(-2,2) = 1.D0 - SQRT(6.D0)/3.D0 - GAML( 2,2) = 1.D0 - SQRT(6.D0)/3.D0 - GAML(-1,2) = 1.D0 + SQRT(6.D0)/3.D0 - GAML( 1,2) = 1.D0 + SQRT(6.D0)/3.D0 - - NFLIPL(-2,1) = -1 - NFLIPL(-2,2) = 1 - NFLIPL(-2,3) = 2 - - NFLIPL(-1,1) = 1 - NFLIPL(-1,2) = 2 - NFLIPL(-1,3) = -2 - - NFLIPL( 1,1) = 2 - NFLIPL( 1,2) = -2 - NFLIPL( 1,3) = -1 - - NFLIPL( 2,1) = -2 - NFLIPL( 2,2) = -1 - NFLIPL( 2,3) = 1 - - end Subroutine Op_SetHS - - Subroutine Op_phase(Phase,OP_V,Nsigma,N_SUN) ! This also goes in Operator (Input is nsigma, Op_V). - Implicit none - - Complex (Kind=8), Intent(Inout) :: Phase - Integer, Intent(IN) :: N_SUN - Integer, dimension(:,:), Intent(In) :: Nsigma - Type (Operator), dimension(:,:), Intent(In) :: Op_V - - Integer :: n, nf, nt - - do nf = 1,Size(Op_V,2) - do n = 1,size(Op_V,1) - do nt = 1,size(nsigma,2) - Phase = Phase*exp( Op_V(n,nf)%g * Op_V(n,nf)%alpha * Phi(nsigma(n,nt),Op_V(n,nf)%type) ) - enddo - enddo - enddo - Phase = Phase**dble(N_SUN) - - end Subroutine Op_phase - - - subroutine Op_make(Op,N) - Implicit none - Type (Operator), intent(INOUT) :: Op - Integer, Intent(IN) :: N - Allocate (Op%O(N,N), Op%U(N,N), Op%E(N), Op%P(N)) - Op%O = cmplx(0.d0,0.d0) - Op%U = cmplx(0.d0,0.d0) - Op%E = 0.d0 - Op%P = 0 - Op%N = N - Op%N_non_zero = N - Op%g = cmplx(0.d0,0.d0) - Op%alpha = cmplx(0.d0,0.d0) - end subroutine Op_make - - subroutine Op_clear(Op,N) - Implicit none - Type (Operator), intent(INOUT) :: Op - Integer, Intent(IN) :: N - Deallocate (Op%O, Op%U, Op%E, Op%P) - end subroutine Op_clear - -!========================================================================== - subroutine Op_set(Op) - Implicit none - Type (Operator), intent(INOUT) :: Op - - Complex (Kind=8), allocatable :: U(:,:) - Real (Kind=8), allocatable :: E(:) - Real (Kind=8) :: Zero = 1.E-9 - Integer :: N, I,J,np,nz - - If (Op%N > 1) then - !Write(6,*) 'Calling diag', Op%O(1,2), Size(Op%O,1), Size(Op%U,1), Size(Op%E,1) - N = Op%N - Allocate (U(N,N), E(N)) - Call Diag(Op%O,U, E) - Np = 0 - Nz = 0 - do I = 1,N - if ( abs(E(I)) > Zero ) then - np = np + 1 - do j = 1, N - Op%U(j,np) = U(j,i) - enddo - Op%E(np) = E(I) - else - do j = 1, N - Op%U(j,N-nz) = U(j,i) - enddo - Op%E(N-nz) = E(I) - nz = nz + 1 - endif - enddo - Op%N_non_zero = np - !Write(6,*) "Op_set", np,N - deallocate (U, E) - ! Op%U,Op%E) - !Write(6,*) 'Calling diag 1' - else - Op%E(1) = Op%O(1,1) - Op%U(1,1) = cmplx(1.d0,0.d0) - Op%N_non_zero = 1 - endif -!========================================================================== - end subroutine Op_set - - - subroutine Op_exp(g,Op,Mat) - Implicit none - Type (Operator), Intent(IN) :: Op - Complex (Kind=8), Dimension(:,:), INTENT(OUT) :: Mat - Complex (Kind=8), INTENT(IN) :: g - Complex (Kind=8) :: Z, Z1 - - Integer :: n, i,j - - Mat = cmplx(0.d0,0.d0) - Do n = 1,Op%N - Z = exp(g*cmplx(Op%E(n),0.d0)) - do J = 1,Op%N - Z1 = Z*conjg(Op%U(J,n)) - Do I = 1,Op%N - Mat(I,J) = Mat(I,J) + Op%U(I,n)*Z1 - enddo - enddo - enddo - end subroutine Op_exp - - subroutine Op_mmultL(Mat,Op,spin,Ndim) - Implicit none - Integer :: Ndim - Type (Operator) , INTENT(IN ) :: Op - Complex (Kind=8), INTENT(INOUT) :: Mat (Ndim,Ndim) - Real (Kind=8), INTENT(IN ) :: spin - - - ! Local - Complex (Kind=8) :: VH(Ndim,Op%N), Z, Z1 - Integer :: n, i, m, m1 - - - ! In Mat - ! Out Mat = Mat*exp(spin*Op) - - VH = cmplx(0.d0,0.d0) - do n = 1,Op%N - Z = exp(Op%g*cmplx(Op%E(n)*spin,0.d0)) - Do m = 1,Op%N - Z1 = Op%U(m,n)* Z - DO I = 1,Ndim - VH(I,n) = VH(I,n) + Mat(I,Op%P(m)) * Z1 - Enddo - enddo - Enddo - Do n = 1,Op%N - Do I = 1,Ndim - Mat(I,Op%P(n)) = VH(I,n) - Enddo - Enddo - - - VH = cmplx(0.d0,0.d0) - do n = 1,Op%N - Do m = 1,Op%N - Z1 = conjg(Op%U(n,m)) - DO I = 1,Ndim - VH(I,n) = VH(I,n) + Mat(I,Op%P(m)) * Z1 - Enddo - enddo - Enddo - Do n = 1,Op%N - Do I = 1,Ndim - Mat(I,Op%P(n)) = VH(I,n) - Enddo - Enddo - - - - end subroutine Op_mmultL - - subroutine Op_mmultR(Mat,Op,spin,Ndim) - Implicit none - Integer :: Ndim - Type (Operator) , INTENT(IN ) :: Op - Complex (Kind=8), INTENT(INOUT) :: Mat (Ndim,Ndim) - Real (Kind=8), INTENT(IN ) :: spin - - - ! Local - Complex (Kind=8) :: VH(Ndim,Op%N), Z, Z1 - Integer :: n, i, m, m1 - - ! In Mat - ! Out Mat = exp(spin*Op)*Mat - VH = cmplx(0.d0,0.d0) - do n = 1,Op%N - Z1 = exp(Op%g*cmplx(Op%E(n)*spin,0.d0)) - Do m = 1,Op%N - Z = conjg(Op%U(m,n))* Z1 - DO I = 1,Ndim - VH(I,n) = VH(I,n) + Z* Mat(Op%P(m),I) - Enddo - enddo - Enddo - Do n = 1,Op%N - Do I = 1,Ndim - Mat(Op%P(n),I) = VH(I,n) - Enddo - Enddo - VH = cmplx(0.d0,0.d0) - do n = 1,Op%N - Do m = 1,Op%N - Z = Op%U(n,m) - DO I = 1,Ndim - VH(I,n) = VH(I,n) + Z* Mat(Op%P(m),I) - Enddo - enddo - Enddo - Do n = 1,Op%N - Do I = 1,Ndim - Mat(Op%P(n),I) = VH(I,n) - Enddo - Enddo - - - end subroutine Op_mmultR - - Subroutine Op_Wrapup(Mat,Op,spin,Ndim,N_Type) - - Implicit none - - Integer :: Ndim - Type (Operator) , INTENT(IN ) :: Op - Complex (Kind=8), INTENT(INOUT) :: Mat (Ndim,Ndim) - Real (Kind=8), INTENT(IN ) :: spin - Integer, INTENT(IN) :: N_Type - - ! Local - Complex (Kind=8) :: VH(Ndim,Op%N), Z, Z1 - Integer :: n, i, m, m1 - - - - - !!!!! N_Type ==1 - ! exp(Op%g*spin*Op%E)*(Op%U^{dagger})*Mat*Op%U*exp(-Op%g*spin*Op%E) - ! - !!!!! - !!!!! N_Type == 2 - ! Op%U * Mat * (Op%U^{dagger}) - !!!!! - If (N_type == 1) then - VH = cmplx(0.d0,0.d0) - do n = 1,Op%N - Z=cmplx(1.d0,0.d0) - If ( n <= OP%N_non_Zero) Z = exp(-Op%g*cmplx(Op%E(n)*spin,0.d0)) - Do m = 1,Op%N - Z1 = Op%U(m,n) * Z - DO I = 1,Ndim - VH(I,n) = VH(I,n) + Mat(I,Op%P(m)) * Z1 - Enddo - enddo - Enddo - Do n = 1,Op%N - Do I = 1,Ndim - Mat(I,Op%P(n)) = VH(I,n) - Enddo - Enddo - - VH = cmplx(0.d0,0.d0) - do n = 1,Op%N - Z=cmplx(1.d0,0.d0) - If ( n <= OP%N_non_Zero) Z = exp(Op%g*cmplx(Op%E(n)*spin,0.d0)) - Do m = 1,Op%N - Z1 = Z * conjg(Op%U(m,n)) - DO I = 1,Ndim - VH(I,n) = VH(I,n) + Z1* Mat(Op%P(m),I) - Enddo - enddo - enddo - Do n = 1,Op%N - Do I = 1,Ndim - Mat(Op%P(n),I) = VH(I,n) - Enddo - Enddo - elseif (N_Type == 2) then - VH = cmplx(0.d0,0.d0) - do n = 1,Op%N - Do m = 1,Op%N - Z1 = conjg(Op%U(n,m)) - DO I = 1,Ndim - VH(I,n) = VH(I,n) + Mat(I,Op%P(m)) * Z1 - Enddo - enddo - Enddo - Do n = 1,Op%N - Do I = 1,Ndim - Mat(I,Op%P(n)) = VH(I,n) - Enddo - Enddo - - VH = cmplx(0.d0,0.d0) - do n = 1,Op%N - Do m = 1,Op%N - Z1 = Op%U(n,m) - DO I = 1,Ndim - VH(I,n) = VH(I,n) + Z1* Mat(Op%P(m),I) - Enddo - enddo - enddo - Do n = 1,Op%N - Do I = 1,Ndim - Mat(Op%P(n),I) = VH(I,n) - Enddo - Enddo - endif - end Subroutine Op_Wrapup - - Subroutine Op_Wrapdo(Mat,Op,spin,Ndim,N_Type) - - Implicit none - - Integer :: Ndim - Type (Operator) , INTENT(IN ) :: Op - Complex (Kind=8), INTENT(INOUT) :: Mat (Ndim,Ndim) - Real (Kind=8), INTENT(IN ) :: spin - Integer, INTENT(IN) :: N_Type - - ! Local - Complex (Kind=8) :: VH(Ndim,Op%N), Z, Z1 - Integer :: n, i, m, m1 - - !!!!! N_Type == 1 - ! Op%U*exp(-Op%g*spin*Op%E)*Mat*exp(Op%g*spin*Op%E)*(Op%U^{dagger}) - ! - !!!!! - !!!!! N_Type == 2 - ! (Op%U^{dagger}) * Mat * Op%U - !!!!! - If (N_type == 1) then - VH = cmplx(0.d0,0.d0) - Do m = 1,Op%N - Z = cmplx(1.d0,0.d0) - If ( m <= OP%N_non_Zero) Z = exp(Op%g*cmplx(Op%E(m)*spin,0.d0)) - do n = 1,Op%N - Z1 = Z * conjg(Op%U(n,m)) - DO I = 1,Ndim - VH(I,n) = VH(I,n) + Mat(I,Op%P(m)) * Z1 - Enddo - enddo - Enddo - Do n = 1,Op%N - Do I = 1,Ndim - Mat(I,Op%P(n)) = VH(I,n) - Enddo - Enddo - - VH = cmplx(0.d0,0.d0) - Do m = 1,Op%N - Z = cmplx(1.d0,0.d0) - If ( m <= OP%N_non_Zero) Z = exp(-Op%g*cmplx(Op%E(m)*spin,0.d0)) - do n = 1,Op%N - Z1 = Z * Op%U(n,m) - DO I = 1,Ndim - VH(I,n) = VH(I,n) + Z1* Mat(Op%P(m),I) - Enddo - enddo - enddo - Do n = 1,Op%N - Do I = 1,Ndim - Mat(Op%P(n),I) = VH(I,n) - Enddo - Enddo - elseif (N_Type == 2) then - VH = cmplx(0.d0,0.d0) - do n = 1,Op%N - Do m = 1,Op%N - Z1 = Op%U(m,n) - DO I = 1,Ndim - VH(I,n) = VH(I,n) + Mat(I,Op%P(m)) * Z1 - Enddo - enddo - Enddo - Do n = 1,Op%N - Do I = 1,Ndim - Mat(I,Op%P(n)) = VH(I,n) - Enddo - Enddo - - VH = cmplx(0.d0,0.d0) - do n = 1,Op%N - Do m = 1,Op%N - Z1 = conjg(Op%U(m,n)) - DO I = 1,Ndim - VH(I,n) = VH(I,n) + Z1* Mat(Op%P(m),I) - Enddo - enddo - enddo - Do n = 1,Op%N - Do I = 1,Ndim - Mat(Op%P(n),I) = VH(I,n) - Enddo - Enddo - endif - - end Subroutine Op_Wrapdo - - -end Module Operator_mod diff --git a/Prog_8/UDV_WRAP.f90 b/Prog_8/UDV_WRAP.f90 deleted file mode 100644 index 4fb367afb..000000000 --- a/Prog_8/UDV_WRAP.f90 +++ /dev/null @@ -1,135 +0,0 @@ - Module UDV_Wrap_mod - Use MyMats - Use Files_mod - - Contains - -!*************************************************************** - Subroutine UDV_Wrap_Pivot(A,U,D,V,NCON,N1,N2) - - Implicit NONE - COMPLEX (KIND=8), INTENT(IN), DIMENSION(:,:) :: A - COMPLEX (KIND=8), INTENT(INOUT), DIMENSION(:,:) :: U,V - COMPLEX (KIND=8), INTENT(INOUT), DIMENSION(:) :: D - INTEGER, INTENT(IN) :: NCON - INTEGER, INTENT(IN) :: N1,N2 - - ! Locals - REAL (Kind=8) :: VHELP(N2), XNORM(N2), XMAX, XMEAN - INTEGER :: IVPT(N2), IVPTM1(N2), I, J, K, IMAX - COMPLEX (KIND=8) :: A1(N1,N2), A2(N1,N2) - - DO I = 1,N2 - XNORM(I) = 0.D0 - DO J = 1,N1 - XNORM(I) = XNORM(I) + DBLE( A(J,I) * CONJG( A(J,I) ) ) - ENDDO - ENDDO - DO I = 1,N2 - VHELP(I) = XNORM(I) - ENDDO - - DO I = 1,N2 - XMAX = 0.D0 - DO J = 1,N2 - IF (VHELP(J).GT.XMAX) THEN - IMAX = J - XMAX = VHELP(J) - ENDIF - ENDDO - VHELP(IMAX) = -1.D0 - IVPTM1(IMAX)= I - IVPT(I) = IMAX - ENDDO - DO I = 1,N2 - K = IVPT(I) - DO J = 1,N1 - A1(J,I) = A(J,K) - ENDDO - ENDDO - - CALL UDV_Wrap(A1,U,D,V,NCON) - - A1 = V - DO I = 1,N2 - K = IVPTM1(I) - DO J = 1,N1 - V(J,I) = A1(J,K) - ENDDO - ENDDO - - - IF (NCON == 1) THEN - !Check the result A = U D V - DO J = 1,N2 - DO I = 1,N1 - A1(I,J) = D(I)*V(I,J) - ENDDO - ENDDO - Call MMULT (A2,U,A1) - CALL COMPARE(A,A2,XMAX,XMEAN) - Write (6,*) 'Check afer Pivoting', XMAX - ENDIF - - - - End Subroutine UDV_Wrap_Pivot -!*************************************************************** - Subroutine UDV_Wrap(A,U,D,V,NCON) - -#include "machine" - - Implicit None -#ifdef MPI - INCLUDE 'mpif.h' -#endif - COMPLEX (KIND=8), INTENT(IN), DIMENSION(:,:) :: A - COMPLEX (KIND=8), INTENT(INOUT), DIMENSION(:,:) :: U,V - COMPLEX (KIND=8), INTENT(INOUT), DIMENSION(:) :: D - INTEGER, INTENT(IN) :: NCON - - !Local - Complex (Kind=8), Allocatable :: A1(:,:),U1(:,:) - Integer :: I,J, N - character (len=64) :: file_sr, File -#ifdef MPI - INTEGER :: STATUS(MPI_STATUS_SIZE) - INTEGER :: Isize, Irank,Ierr - - CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) - CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) -#endif - - File_sr = "SDV" -#ifdef MPI - File = File_i(File_sr, Irank) -#else - File = File_sr -#endif - !Open (Unit = 78,File=File, Status='UNKNOWN', action="write", position="append") - !Write(78,*) 'Call QR' - !Close(78) - CALL QR(A,U,V,NCON) - !Open (Unit = 78,File=File, Status='UNKNOWN', action="write", position="append") - !Write(78,*) 'End call QR' - !Close(78) - N = Size(V,1) - Allocate (A1(N,N),U1(N,N)) - A1 = V - !Open (Unit = 78,File=File, Status='UNKNOWN') - !Write(78,*) 'Call SVD' - !DO I = 1,N - ! Write(78,*) Real(V(I,I)) - !ENDDO - !Close(78) - CALL SVD(A1,U1,D,V,NCON) - !Open (Unit = 78,File=File, Status='UNKNOWN', action="write", position="append") - !Write(78,*) 'End call SVD' - !Close(78) - Call MMULT(A1,U,U1) - U = A1 - - End Subroutine UDV_Wrap - - End Module UDV_Wrap_mod - diff --git a/Prog_8/cgr1.f90 b/Prog_8/cgr1.f90 deleted file mode 100644 index b7fc92ca1..000000000 --- a/Prog_8/cgr1.f90 +++ /dev/null @@ -1,110 +0,0 @@ - SUBROUTINE CGR(PHASE,NVAR, GRUP, URUP,DRUP,VRUP, ULUP,DLUP,VLUP) - - Use UDV_Wrap_mod - - Implicit None - - !!! GRUP = (1 + UR*DR*VR*VL*DL*UL)^-1 - !!! NVAR = 1 Big scales are in DL - !!! NVAR = 2 Big scales are in DR - - !Arguments. - COMPLEX(Kind=8), Dimension(:,:), Intent(IN) :: URUP, VRUP, ULUP, VLUP - COMPLEX(Kind=8), Dimension(:), Intent(In) :: DLUP, DRUP - COMPLEX(Kind=8), Dimension(:,:), Intent(INOUT) :: GRUP - COMPLEX(Kind=8) :: PHASE - INTEGER :: NVAR - - !Local - COMPLEX (Kind=8), Dimension(:,:), Allocatable :: UUP, VUP, TPUP, TPUP1, & - & TPUPM1,TPUP1M1, UUPM1, VUP1 - COMPLEX (Kind=8), Dimension(:) , Allocatable :: DUP - COMPLEX (Kind=8) :: ZDUP1, ZDDO1, ZDUP2, ZDDO2, Z1, ZUP, ZDO, Z - Integer :: I,J, N_size, NCON, NR, NT, N - Real (Kind=8) :: X, Xmax - - N_size = SIZE(DLUP,1) - NCON = 0 - - Allocate( UUP(N_size,N_size), VUP(N_size,N_size), TPUP(N_size,N_size), TPUP1(N_size,N_size), & - & TPUPM1(N_size,N_size),TPUP1M1(N_size,N_size), UUPM1(N_size,N_size), VUP1(N_size,N_size), DUP(N_size) ) - - !Write(6,*) 'In CGR', N_size - CALL MMULT(VUP,VRUP,VLUP) - DO J = 1,N_size - DO I = 1,N_size - TPUP(I,J) = DRUP(I)*VUP(I,J)*DLUP(J) - ENDDO - ENDDO - CALL MMULT(UUP,ULUP,URUP) - DO J = 1,N_size - DO I = 1,N_size - UUPM1(I,J) = CONJG(UUP(J,I)) - ENDDO - ENDDO - DO J = 1,N_size - DO I = 1,N_size - TPUP(I,J) = TPUP(I,J) + UUPM1(I,J) - ENDDO - ENDDO - IF (NVAR.EQ.1) THEN - !WRITE(6,*) 'UDV of U + DR * V * DL' - CALL UDV_WRAP(TPUP,UUP,DUP,VUP,NCON) - !CALL UDV(TPUP,UUP,DUP,VUP,NCON) - CALL MMULT(TPUP,VUP,ULUP) - !Do I = 1,N_size - ! Write(6,*) DLUP(I) - !enddo - CALL INV(TPUP,TPUPM1,ZDUP1) - !WRITE(6,*) 'End called Inv' - CALL MMULT(TPUP1,URUP,UUP) - CALL INV(TPUP1,TPUP1M1,ZDUP2) - Z1 = ZDUP1*ZDUP2 - ELSEIF (NVAR.EQ.2) THEN - !WRITE(6,*) 'UDV of (U + DR * V * DL)^{*}' - DO J = 1,N_size - DO I = 1,N_size - TPUP1(I,J) = CONJG( TPUP(J,I) ) - ENDDO - ENDDO - CALL UDV_WRAP(TPUP1,UUP,DUP,VUP,NCON) - !CALL UDV(TPUP1,UUP,DUP,VUP,NCON) - DO J = 1,N_size - DO I = 1,N_size - TPUP(I,J) = CONJG( ULUP(J,I) ) - ENDDO - ENDDO - CALL MMULT(TPUPM1,TPUP,UUP) - DO J = 1,N_size - DO I = 1,N_size - VUP1(I,J) = CONJG( VUP(J,I) ) - ENDDO - ENDDO - CALL MMULT(TPUP1,URUP,VUP1) - CALL INV(TPUP1,TPUP1M1,ZDUP2) - CALL INV(TPUPM1, TPUP, ZDUP1) - Z1 = ZDUP2/ZDUP1 - ENDIF - DO I = 1,N_size - Z = DUP(I) - if (I == 1) Xmax = real(SQRT( Z* conjg(Z)),kind=8) - if ( real(SQRT( Z* conjg(Z)),kind=8) < Xmax ) Xmax = & - & real(SQRT( Z* conjg(Z)),kind=8) - ENDDO - !Write(6,*) 'Cgr1, Cutoff: ', Xmax - - - DO J = 1,N_size - DO I = 1,N_size - ZUP = CMPLX(0.D0,0.D0) - DO NR = 1,N_size - ZUP = ZUP + TPUPM1(I,NR)*TPUP1M1(NR,J)/DUP(NR) - ENDDO - GRUP(I,J) = ZUP - ENDDO - ENDDO - PHASE = Z1/SQRT( Z1* CONJG(Z1) ) - - Deallocate(UUP, VUP, TPUP,TPUP1,TPUPM1, TPUP1M1, UUPM1, VUP1, DUP ) - - END SUBROUTINE CGR diff --git a/Prog_8/cgr2.f90 b/Prog_8/cgr2.f90 deleted file mode 100644 index 213a01b25..000000000 --- a/Prog_8/cgr2.f90 +++ /dev/null @@ -1,122 +0,0 @@ - SUBROUTINE CGR2(GRT0, GR00, GRTT, GR0T, U2, D2, V2, U1, D1, V1, LQ) - - ! B2 = U2*D2*V2 - ! B1 = V1*D1*U1 - !Calc: ( 1 B1 )^-1 i.e. 2*LQ \times 2*LQ matrix - ! (-B2 1 ) - - - Use Precdef - Use UDV_WRAP_mod - Use MyMats - - Implicit none - - ! Arguments - Integer :: LQ - Complex (Kind=double), intent(in) :: U1(LQ,LQ), V1(LQ,LQ), U2(LQ,LQ), V2(LQ,LQ) - Complex (Kind=double), intent(in) :: D2(LQ), D1(LQ) - Complex (Kind=double), intent(inout) :: GRT0(LQ,LQ), GR0T(LQ,LQ), GR00(LQ,LQ), GRTT(LQ,LQ) - - - ! Local:: - Complex (Kind=double) :: U3B(2*LQ,2*LQ), V3B(2*LQ,2*LQ), HLPB1(2*LQ,2*LQ), HLPB2(2*LQ,2*LQ), & - & V2INV(LQ,LQ), V1INV(LQ,LQ), HLP2(LQ,LQ) - Complex (Kind=double) :: D3B(2*LQ) - Complex (Kind=double) :: Z - - Integer :: LQ2, I,J, M, ILQ, JLQ, NCON, I1, J1 - - LQ2 = LQ*2 - - HLPB1 = cmplx(0.D0,0.d0,double) - DO I = 1,LQ - HLPB1(I , I + LQ ) = D1(I) - HLPB1(I+LQ, I ) = -D2(I) - ENDDO - CALL INV(V2,V2INV,Z) - CALL INV(V1,V1INV,Z) - CALL MMULT(HLP2,V1INV,V2INV) - DO J = 1,LQ - DO I = 1,LQ - HLPB1(I,J) = HLP2(I,J) - ENDDO - ENDDO - CALL MMULT(HLP2,U1,U2) - DO I = 1,LQ - ILQ = I+LQ - DO J = 1,LQ - JLQ = J + LQ - HLPB1(ILQ,JLQ) = conjg( HLP2(J,I) ) ! = (U1*U2)^T - ENDDO - ENDDO - NCON = 0 - CALL UDV_wrap(HLPB1,U3B,D3B,V3B,NCON) - - - ! Multiplication: - ! U3B^T * ( V1INV 0 ) = U3B - ! ( 0 U2^T ) - - DO I = 1,LQ2 - DO J = 1,LQ2 - HLPB1(I,J) = conjg(U3B(J,I)) - ENDDO - ENDDO - HLPB2 = cmplx(0.D0,0.d0,double) - DO I = 1,LQ - DO J = 1,LQ - HLPB2(I,J) = V1INV(I,J) - ENDDO - ENDDO - DO I = 1,LQ - ILQ = I + LQ - DO J = 1,LQ - JLQ = J + LQ - HLPB2(ILQ,JLQ) = conjg(U2(J,I)) - ENDDO - ENDDO - CALL MMULT(U3B,HLPB1,HLPB2) - - - ! Multiplication: - ! ( V2INV 0 )*(V3B)^{-1} = V3B - ! ( 0 U1^T ) - - CALL INV(V3B,HLPB1,Z) - HLPB2 = cmplx(0.d0,0.d0,double) - DO I = 1,LQ - DO J = 1,LQ - HLPB2(I,J) = V2INV(I,J) - ENDDO - ENDDO - DO I = 1,LQ - ILQ = I + LQ - DO J = 1, LQ - JLQ = J + LQ - HLPB2(ILQ,JLQ) = conjg(U1(J,I)) - ENDDO - ENDDO - CALL MMULT(V3B,HLPB2,HLPB1) - - - ! G = V3B * D3B^{-1}* U3B - DO M = 1,LQ2 - Z = cone/D3B(M) - DO J = 1,LQ2 - U3B(M,J) = Z * U3B(M,J) - ENDDO - ENDDO - CALL MMULT(HLPB2, V3B, U3B) - DO I = 1,LQ - I1 = I+LQ - DO J = 1,LQ - J1 = J + LQ - GR00(I,J) = HLPB2(I ,J ) - GRTT(I,J) = HLPB2(I1,J1) - GRT0(I,J) = HLPB2(I1,J ) - GR0T(I,J) = HLPB2(I,J1 ) - ENDDO - ENDDO - - END SUBROUTINE CGR2 diff --git a/Prog_8/cgr2_1.f90 b/Prog_8/cgr2_1.f90 deleted file mode 100644 index 78297bf8d..000000000 --- a/Prog_8/cgr2_1.f90 +++ /dev/null @@ -1,539 +0,0 @@ - SUBROUTINE CGR2_1(GRT0, GR00, GRTT, GR0T, U2, D2, V2, U1, D1, V1, LQ, NVAR) - - ! B2 = U2*D2*V2 is right (i.e. from time slice 0 to tau) propagation to time tau - ! B1 = V1*D1*U1 is left (i.e. from time slice Ltrot to tau) propagation to time tau - !Calc: ( 1 B1 )^-1 ( G00 G0T ) - ! (-B2 1 ) == ( GT0 GTT ) - ! - ! G00 = (1 + B1*B2)^-1 G0T = -(1 - G00 )*B2^-1 - ! GT0 = B2 * G00 GTT = (1 + B2*B1)^-1 - - ! Here you want to compute G00, G0T, GT0 and GTT just by involving LQ x LQ matrix operations. - ! If NVAR == 1 then the large scales are in D1 - ! If NVAR == 2 then the large scales are in D2 - Use Precdef - Use MyMats - USe UDV_Wrap_mod - - Implicit none - - Interface - SUBROUTINE CGR(Z,NVAR, GRUP, URUP,DRUP,VRUP, ULUP,DLUP,VLUP) - COMPLEX(Kind=8), Dimension(:,:), Intent(In) :: URUP, VRUP, ULUP, VLUP - COMPLEX(Kind=8), Dimension(:), Intent(In) :: DLUP, DRUP - COMPLEX(Kind=8), Dimension(:,:), Intent(INOUT) :: GRUP - - COMPLEX(Kind=8) :: Z - END SUBROUTINE CGR - end Interface - - - ! Arguments - Integer, intent(in) :: LQ, NVAR - Complex (Kind=double), intent(in) :: U1(LQ,LQ), V1(LQ,LQ), U2(LQ,LQ), V2(LQ,LQ) - Complex (Kind=double), intent(in) :: D2(LQ), D1(LQ) - Complex (Kind=double), intent(inout) :: GRT0(LQ,LQ), GR0T(LQ,LQ), GR00(LQ,LQ), GRTT(LQ,LQ) - - - ! Local:: - Complex (Kind=double) :: HLP1(LQ,LQ), HLP2(LQ,LQ), U(LQ,LQ), D(LQ), V(LQ,LQ) - Complex (Kind=double) :: Z, Z1, Z2 - Real (Kind=double) :: X, Xmax, Xmin, X1, X2, Xmax1, Xmax2, Xmean - Integer :: I, J, M, NCON, NVAR1 - - Complex (Kind=double) :: V2inv(LQ,LQ), V1inv(LQ,LQ) - - - NCON = 0 - - Call INV( V2, V2inv, Z2) - CALL INV( V1, V1inv, Z1) - - - DO I = 1,LQ - DO J = 1,LQ - HLP1(I,J) = CONJG( U1(J,I) ) - ENDDO - ENDDO - CALL MMULT(HLP2,HLP1,U1) - HLP1 = cmplx(0.d0,0.d0,kind=8) - DO I = 1,LQ - HLP1(I,I) = cmplx(1.d0,0.d0,kind=8) - ENDDO - Xmax = 0.d0 - CALL COMPARE(HLP1, HLP2, XMAX, XMEAN) - - DO I = 1,LQ - DO J = 1,LQ - HLP1(I,J) = CONJG( U2(J,I) ) - ENDDO - ENDDO - CALL MMULT(HLP2,HLP1,U2) - HLP1 = cmplx(0.d0,0.d0,kind=8) - DO I = 1,LQ - HLP1(I,I) = cmplx(1.d0,0.d0,kind=8) - ENDDO - Xmax1 = 0.d0 - CALL COMPARE(HLP1, HLP2, XMAX1, XMEAN) - Write(77,*) "Cgr2_1 V1inv V2inv : ", Xmax, Xmax1 - -!!$ Xmax = 0.d0 -!!$ do I = 1,LQ -!!$ do j = 1,LQ -!!$ X = sqrt(dble(V1(i,j)*conjg(V1(i,j)))) -!!$ if (X > Xmax) Xmax = X -!!$ enddo -!!$ enddo -!!$ Write(77,*) 'In cgr2_1 Xmax V1: ', Xmax, Z2 -!!$ do I = 1,LQ -!!$ do j = 1,LQ -!!$ X = sqrt(dble(V2(i,j)*conjg(V2(i,j)))) -!!$ if (X > Xmax) Xmax = X -!!$ enddo -!!$ enddo -!!$ Write(77,*) 'In cgr2_1 Xmax V2: ', Xmax, Z1 - - ! Compute G00 - ! G00 = (1 + B1*B2)^-1 = (1 + V1 D1 U1 U2 D2 V2 )^-1 = - ! = ( V1 ( V1^-1 V2^-1 + D1 U1 U2 D2 ) V2 )^-1 = - ! = V2^-1 ( (V2 V1)^-1 + D1 U1 U2 D2 )^-1 V1^-1 - Call MMULT(HLP1,V1inv,V2inv) - Call MMULT(HLP2,U1,U2) - DO J = 1,LQ - DO I = 1,LQ - HLP2(I,J) = D1(I)*HLP2(I,J)*D2(J) + HLP1(I,J) - ENDDO - ENDDO - Xmax1 = dble( D1(1) ) - Xmax2 = dble( D2(1) ) - DO I = 2,LQ - If ( dble( D1(I) ) > Xmax1 ) Xmax1 = dble( D1(I) ) - If ( dble( D2(I) ) > Xmax2 ) Xmax2 = dble( D2(I) ) - Enddo - Nvar1 = 1 - If ( Xmax2 > Xmax1) Nvar1 = 2 - If (Nvar1 == 1) then - ! V2^-1 (UDV )^-1 V1^-1 = V2^-1 V^-1 D^-1 U^-1 V1^-1 - Call UDV_WRAP(HLP2, U, D, V, Ncon) - CALL INV (V,HLP2 ,Z ) - CALL MMULT(V,V2inv,HLP2) - DO J = 1,LQ - DO I = 1,LQ - V(I,J) = V(I,J)/D(J) - ENDDO - ENDDO - DO I = 1,LQ - DO J = 1,LQ - HLP1(I,J) = Conjg(U(J,I)) - ENDDO - ENDDO - CALL MMULT( HLP2, HLP1,V1inv) - CALL MMULT (GR00, V, HLP2) - else - ! V2^-1 (UDV )^(-1,*) V1^-1 = V2^-1 U D^-1 V^(-1,*) V1^-1 - DO J = 1,LQ - DO I = 1,LQ - HLP1(I,J) = conjg(HLP2(J,I)) - ENDDO - ENDDO - Call UDV_WRAP(HLP1, U, D, V, Ncon) - Call MMULT(HLP1, V2inv, U) - DO J = 1,LQ - DO I = 1,LQ - HLP1(I,J) = HLP1(I,J)/D(J) - ENDDO - ENDDO - CALL INV (V, HLP2, Z) - DO J = 1,LQ - DO I = 1,LQ - V(I,J) = CONJG(HLP2(J,I)) - ENDDO - ENDDO - CALL MMULT(HLP2,V,V1inv) - CALL MMULT(GR00,HLP1,HLP2) - endif - - ! Compute G0T - ! G00 = (1 + B1*B2)^-1 G0T = -(1 - (1 + B1*B2)^-1 )*B2^-1 = - ! = -( 1 + B1*B2 - 1) (1 + B1*B2)^-1 * B2^-1 = - ! = - B1 * B2 (1 + B1*B2)^-1 * B2^-1 = - ! = -( B2 ( 1+ B1*B2) * B2^-1 B1^-1)^-1 = - ! = -( B2 ( 1+ B1*B2) * (B1 B2)^-1)^-1 = - ! = -( B2 ( (B1 B2)^-1 + 1 ) )^-1 = - ! = -( B1^-1 + B2)^-1 = - ! -G0T*= ( B1*^-1 + B2*)^-1 = - ! = ( V1*^-1 D1*^-1 U1 + V2* D2* U2*)^-1 = - ! = ( V1*^-1 ( D1*^-1 U1 U2 + V1* V2* D2* ) U2* )^-1 = - ! = U2 ( D1*^-1 (U1 U2) + ( V2 V1)* D2* )^-1 V1* - ! = U2 ( D1*^-1 (U1 U2) + ( V2 V1)* D2* )^-1 V1* - ! B2 = U2*D2*V2 - ! B1 = V1*D1*U1 - Xmax2 = dble(cmplx(1.d0,0.d0)/D1(1)) - Xmax1 = dble(D2(1)) - Do I = 2,LQ - X2 = dble(cmplx(1.d0,0.d0)/D1(I)) - X1 = dble(D2(I)) - If ( X2 > Xmax2 ) Xmax2 = X2 - If ( X1 > Xmax1 ) Xmax1 = X1 - ENDDO - NVAR1 = 1 - If (Xmax2 > Xmax1) Nvar1 = 2 - Call MMULT(HLP1,U1,U2) - DO J = 1,LQ - DO I =1,LQ - HLP1(I,J) = HLP1(I,J)/conjg(D1(I)) - ENDDO - ENDDO - Call MMULT(V,V2,V1) - DO J = 1,LQ - DO I = 1,LQ - HLP2(I,J) = Conjg(V(J,I)) - ENDDO - ENDDO - DO J = 1,LQ - DO I =1,LQ - HLP2(I,J) = HLP1(I,J) + HLP2(I,J)*conjg(D2(J)) - ENDDO - ENDDO - NCON = 0 - IF ( NVAR1 == 1 ) Then - ! UDV of HLP2 - ! -G0T*= U2 V^-1 D^-1 U* V1* - CALL UDV_WRAP(HLP2,U,D,V,NCON) - CALL MMULT (HLP1, V1, U) - DO I = 1,LQ - DO J = 1,LQ - U(I,J) = conjg(HLP1(J,I)) - ENDDO - ENDDO - CALL INV(V,HLP2,Z) - Call MMULT(HLP1,U2,HLP2) - DO J = 1,LQ - Z = cmplx(1.d0,0.d0,kind=8)/D(J) - DO I = 1,LQ - HLP1(I,J) = HLP1(I,J)*Z - ENDDO - ENDDO - Call MMULT (HLP2,HLP1,U) - DO I = 1,LQ - DO J = 1,LQ - GR0T(I,J) = -conjg(HLP2(J,I)) - ENDDO - ENDDO - ELSE - ! UDV of HLP2* - ! -G0T*= U2 (U D V)*^-1 V1* = U2 U D*^-1 V*^-1 V1* - DO I = 1,LQ - DO J = 1,LQ - HLP1(I,J) = conjg(HLP2(J,I)) - ENDDO - ENDDO - CALL UDV_WRAP(HLP1,U,D,V,NCON) - CALL MMULT (HLP1, U2, U) - DO J = 1,LQ - Z = cmplx(1.d0,0.d0,kind=8)/D(J) - DO I = 1,LQ - HLP1(I,J) = HLP1(I,J)*Z - ENDDO - ENDDO - CALL INV(V,HLP2,Z) - Call MMULT(V,V1,HLP2) - DO I = 1,LQ - DO J = 1,LQ - HLP2(I,J) = conjg(V(J,I)) - ENDDO - ENDDO - Call MMULT (V,HLP1,HLP2) - DO I = 1,LQ - DO J = 1,LQ - GR0T(I,J) = -conjg(V(J,I)) - ENDDO - ENDDO - ENDIF - - - - - ! Compute GT0 - ! GT0 = B2 * G00 = ( ( 1 + B1* B2) * B2^-1 )^-1 = ( B2^-1 + B1)^-1 = - ! = (V2^-1 D2^-1 U2^-1 + V1 D1 U1)^-1 = - ! = ( (V2^-1 D2^-1 U2^-1 U1^-1 + V1 D1 ) U1 )^-1 = - ! = U1^-1 ( ( D2^-1 (U1 U2)^-1 + V2*V1 D1 ) )^-1 V2 - Xmax2 = dble(cmplx(1.d0,0.d0)/D2(1)) - Xmax1 = dble(D1(1)) - Do I = 2,LQ - X2 = dble(cmplx(1.d0,0.d0)/D2(I)) - X1 = dble(D1(I)) - If ( X2 > Xmax2 ) Xmax2 = X2 - If ( X1 > Xmax1 ) Xmax1 = X1 - ENDDO - NVAR1 = 1 - If (Xmax2 > Xmax1 ) NVAR1 = 2 - !Write(6,*) "CGR2_1: NVAR,NVAR1 ", NVAR, NVAR1 - Call MMULT(HLP2,U1,U2) - DO J = 1,LQ - DO I = 1,LQ - HLP1(I,J) = Conjg(HLP2(J,I)) - ENDDO - ENDDO - DO J = 1,LQ - DO I =1,LQ - HLP1(I,J) = HLP1(I,J)/D2(I) - ENDDO - ENDDO - Call MMULT(HLP2,V2,V1) - DO J = 1,LQ - DO I =1,LQ - HLP2(I,J) = HLP1(I,J) + HLP2(I,J)*D1(J) - ENDDO - ENDDO - NCON = 0 - IF ( NVAR1 == 1 ) Then - ! UDV of HLP2 - CALL UDV_WRAP(HLP2,U,D,V,NCON) - CALL MMULT (HLP1, V, U1) - CALL INV(HLP1,HLP2,Z) - DO J = 1,LQ - Z = cmplx(1.d0,0.d0)/D(J) - DO I = 1,LQ - HLP2(I,J) = HLP2(I,J)*Z - ENDDO - ENDDO - DO I = 1,LQ - DO J = 1,LQ - HLP1(I,J) = Conjg(U(J,I)) - ENDDO - ENDDO - CALL MMULT(U,HLP1,V2) - Call MMULT (GRT0, HLP2,U) - ELSE - !UDV of HLP2^* - DO J = 1,LQ - DO I =1,LQ - HLP1(I,J) = Conjg(HLP2(J,I)) - ENDDO - ENDDO - CALL UDV_WRAP(HLP1,U,D,V,NCON) - DO I = 1,LQ - DO J = 1,LQ - HLP1(I,J) = conjg(U1(J,I)) - ENDDO - ENDDO - CALL MMULT( HLP2, HLP1,U) - DO J = 1,LQ - DO I = 1,LQ - HLP2(I,J) = HLP2(I,J)/Conjg(D(J)) - ENDDO - ENDDO - DO I = 1,LQ - DO J = 1,LQ - HLP1(I,J) = conjg(V(J,I)) - ENDDO - ENDDO - CALL INV(HLP1,V,Z) - CALL MMULT(U,V,V2) - Call MMULT (GRT0, HLP2,U) - ENDIF - Xmin = abs(dble(D(1))) - DO I = 1,LQ - if (abs(dble(D(I))) < Xmin ) Xmin = abs(dble(D(I))) - ENDDO - Write(6,*) 'Cgr2_1 T0, Xmin: ', Xmin - - - !Compute GRTT - Z = cmplx(1.d0,0.d0,kind=8) - Z1 = cmplx(1.d0,0.d0,kind=8) - CALL CGR(Z,NVAR,GRTT, U2,D2,V2, U1,D1,V1) - - - END SUBROUTINE CGR2_1 - - -!!$ ! Compute G0T -!!$ ! G00 = (1 + B1*B2)^-1 G0T = -(1 - (1 + B1*B2)^-1 )*B2^-1 = -!!$ ! = -( 1 + B1*B2 - 1) (1 + B1*B2)^-1 * B2^-1 = -!!$ ! = - B1 * B2 (1 + B1*B2)^-1 * B2^-1 = -!!$ ! = -( B2 ( 1+ B1*B2) * B2^-1 B1^-1)^-1 = -!!$ ! = -( B2 ( 1+ B1*B2) * (B1 B2)^-1)^-1 = -!!$ ! = -( B2 ( (B1 B2)^-1 + 1 ) )^-1 = -!!$ ! = -( B1^-1 + B2)^-1 = -!!$ ! = -( U1^-1 D1^-1 V1^-1 + U2 D2 V2)^-1 = -!!$ ! = -( ( U1^-1 D1^-1 V1^-1 V2^-1 + U2 D2 ) V2 )^-1 = -!!$ ! = -( U1^-1( D1^-1 (V2 V1)^-1 + U1 U2 D2) V2 )^-1 = -!!$ ! = - V2^-1( D1^-1 (V2 V1)^-1 + U1 U2 D2)^-1 U1 -!!$ ! B2 = U2*D2*V2 -!!$ ! B1 = V1*D1*U1 -!!$ Call MMULT (HLP2, V1inv,V2inv) -!!$ DO J = 1,LQ -!!$ DO I = 1,LQ -!!$ HLP2(I,J) = HLP2(I,J)/D1(I) -!!$ ENDDO -!!$ ENDDO -!!$ Call MMULT (HLP1, U1,U2) -!!$ DO J = 1,LQ -!!$ DO I = 1,LQ -!!$ HLP2(I,J) = HLP2(I,J) + HLP1(I,J)*D2(J) -!!$ ENDDO -!!$ ENDDO -!!$ Xmax2 = dble(cmplx(1.d0,0.d0,Kind=8)/D1(1)) -!!$ Xmax1 = dble(D2(1)) -!!$ Do I = 2,LQ -!!$ X2 = dble(cmplx(1.d0,0.d0,Kind=8)/D1(I)) -!!$ X1 = dble(D2(I)) -!!$ If ( X2 > Xmax2 ) Xmax2 = X2 -!!$ If ( X1 > Xmax1 ) Xmax1 = X1 -!!$ ENDDO -!!$ NVAR1 = 1 -!!$ If (Xmax2 > Xmax1 ) NVAR1 = 2 -!!$ IF (NVAR1 == 1) Then -!!$ ! UDV of HLP2 -!!$ != - V2^-1( U D V )^-1 ) U1 = -!!$ != - V2^-1 V^-1 D^-1 U^-1 U1 = - (V V2)^-1 D^-1 U^-1 U1 -!!$ CALL UDV(HLP2,U,D,V,NCON) -!!$ DO J = 1,LQ -!!$ DO I = 1,LQ -!!$ HLP1(I,J) = conjg(U(J,I)) -!!$ ENDDO -!!$ ENDDO -!!$ CALL MMULT( U, HLP1, U1 ) -!!$ CALL MMULT(HLP1,V, V2) -!!$ CALL INV (HLP1,V ,Z) -!!$ DO J = 1,LQ -!!$ DO I = 1,LQ -!!$ HLP1(I,J) = - V(I,J)/D(J) -!!$ ENDDO -!!$ ENDDO -!!$ CALL MMULT(GR0T, HLP1, U) -!!$ Else -!!$ ! UDV of HLP2^* -!!$ != - V2^-1( U D V)^*,-1 ) U1 = -!!$ != - V2^-1 U D^-1 V^*,-1 U1 -!!$ DO I = 1,LQ -!!$ DO J = 1,LQ -!!$ HLP1(J,I) = Conjg(HLP2(I,J)) -!!$ ENDDO -!!$ ENDDO -!!$ CALL UDV(HLP1,U,D,V,NCON) -!!$ CALL INV(V2,HLP1,Z) -!!$ CALL MMULT(HLP2,HLP1,U) -!!$ DO J = 1,LQ -!!$ DO I = 1,LQ -!!$ HLP1(I,J) = -HLP2(I,J)/conjg(D(J)) -!!$ ENDDO -!!$ ENDDO -!!$ CALL INV(V,HLP2,Z) -!!$ DO J = 1,LQ -!!$ DO I = 1,LQ -!!$ V(I,J) = Conjg(HLP2(J,I)) -!!$ ENDDO -!!$ ENDDO -!!$ CALL MMULT(HLP2,V,U1) -!!$ CALL MMULT(GR0T, HLP1,HLP2) -!!$ endif -!!$ Xmin = abs(dble(D(1))) -!!$ DO I = 1,LQ -!!$ if (abs(dble(D(I))) < Xmin ) Xmin = abs(dble(D(I))) -!!$ ENDDO -!!$ Write(6,*) 'Cgr2_1 0T, Xmin: ', Xmin - - - - -!!$ ! Compute G0T -!!$ ! G00 = (1 + B1*B2)^-1 G0T = -(1 - (1 + B1*B2)^-1 )*B2^-1 = -!!$ ! = -( 1 + B1*B2 - 1) (1 + B1*B2)^-1 * B2^-1 = -!!$ ! = - B1 * B2 (1 + B1*B2)^-1 * B2^-1 = -!!$ ! = -( B2 ( 1+ B1*B2) * B2^-1 B1^-1)^-1 = -!!$ ! = -( B2 ( 1+ B1*B2) * (B1 B2)^-1)^-1 = -!!$ ! = -( B2 ( (B1 B2)^-1 + 1 ) )^-1 = -!!$ ! = -( B1^-1 + B2)^-1 = -!!$ ! = -( U1^-1 D1^-1 V1^-1 + U2 D2 V2)^-1 = -!!$ ! = -(U2 (U2^-1 U1^-1 D1^-1 + D2 V2 V1 ) V1^-1 )^-1 = -!!$ ! = - V1 ( (U1 U2)^-1 D1^-1 + D2 V2 V1 )^-1 U2^-1 -!!$ ! B2 = U2*D2*V2 -!!$ ! B1 = V1*D1*U1 -!!$ Call MMULT (HLP1, U1,U2) -!!$ DO J = 1,LQ -!!$ DO I = 1,LQ -!!$ HLP2(I,J) = Conjg(HLP1(J,I)) -!!$ ENDDO -!!$ ENDDO -!!$ DO J = 1,LQ -!!$ DO I = 1,LQ -!!$ HLP2(I,J) = HLP2(I,J) / D1(J) -!!$ ENDDO -!!$ ENDDO -!!$ -!!$ Call MMULT (HLP1, V2,V1) -!!$ DO J = 1,LQ -!!$ DO I = 1,LQ -!!$ HLP2(I,J) = HLP2(I,J) + D2(I)*HLP1(I,J) -!!$ ENDDO -!!$ ENDDO -!!$ Xmax2 = dble(cmplx(1.d0,0.d0)/D1(1)) -!!$ Xmax1 = dble(D2(1)) -!!$ Do I = 2,LQ -!!$ X2 = dble(cmplx(1.d0,0.d0)/D1(I)) -!!$ X1 = dble(D2(I)) -!!$ If ( X2 > Xmax2 ) Xmax2 = X2 -!!$ If ( X1 > Xmax1 ) Xmax1 = X1 -!!$ ENDDO -!!$ NVAR1 = 1 -!!$ If (Xmax1 > Xmax2 ) NVAR1 = 2 -!!$ IF (NVAR1 == 1) Then -!!$ ! UDV of HLP2 -!!$ != - V1 ( U D V)^-1 U2^-1 -!!$ != - V1 V^-1 D^-1 U^-1 U2^-1 = - V1 V^-1 D^-1 (U2 U)^-1 -!!$ CALL UDV(HLP2,U,D,V,NCON) -!!$ CALL MMULT( HLP2, U2, U ) -!!$ DO J = 1,LQ -!!$ DO I = 1,LQ -!!$ HLP1(I,J) = conjg(HLP2(J,I)) -!!$ ENDDO -!!$ ENDDO -!!$ CALL INV (V, HLP2 ,Z) -!!$ CALL MMULT(V, V1, HLP2) -!!$ DO J = 1,LQ -!!$ DO I = 1,LQ -!!$ HLP2(I,J) = - V(I,J)/D(J) -!!$ ENDDO -!!$ ENDDO -!!$ CALL MMULT(GR0T, HLP2, HLP1) -!!$ Else -!!$ ! UDV of HLP2^* -!!$ != - V1 ( U D V)^(*,-1) U2^-1 -!!$ != - V1 U D^(*,-1) V^(*,-1) U2^-1 -!!$ DO I = 1,LQ -!!$ DO J = 1,LQ -!!$ HLP1(J,I) = Conjg(HLP2(I,J)) -!!$ ENDDO -!!$ ENDDO -!!$ CALL UDV(HLP1,U,D,V,NCON) -!!$ CALL MMULT(HLP2,V1,U) -!!$ DO J = 1,LQ -!!$ DO I = 1,LQ -!!$ HLP2(I,J) = -HLP2(I,J)/conjg(D(J)) -!!$ ENDDO -!!$ ENDDO -!!$ -!!$ CALL INV(V,HLP1,Z) -!!$ DO J = 1,LQ -!!$ DO I = 1,LQ -!!$ V(I,J) = Conjg(HLP1(J,I)) -!!$ ENDDO -!!$ ENDDO -!!$ DO J = 1,LQ -!!$ DO I = 1,LQ -!!$ U(I,J) = Conjg(U2(J,I)) -!!$ ENDDO -!!$ ENDDO -!!$ CALL MMULT(HLP1,V,U) -!!$ -!!$ CALL MMULT(GR0T, HLP2,HLP1) -!!$ endif -!!$ Xmin = abs(dble(D(1))) -!!$ DO I = 1,LQ -!!$ if (abs(dble(D(I))) < Xmin ) Xmin = abs(dble(D(I))) -!!$ ENDDO -!!$ Write(6,*) 'Cgr2_1 0T, Xmin: ', Xmin, NVAR1 diff --git a/Prog_8/cgr2_2.f90 b/Prog_8/cgr2_2.f90 deleted file mode 100644 index 87e8a462f..000000000 --- a/Prog_8/cgr2_2.f90 +++ /dev/null @@ -1,176 +0,0 @@ - SUBROUTINE CGR2_2(GRT0, GR00, GRTT, GR0T, U2, D2, V2, U1, D1, V1, LQ) - - - ! B2 = U2*D2*V2 is right (i.e. from time slice 0 to tau) propagation to time tau - ! B1 = V1*D1*U1 is left (i.e. from time slice Ltrot to tau) propagation to time tau - !Calc: ( 1 B1 )^-1 ( G00 G0T ) - ! (-B2 1 ) == ( GT0 GTT ) - ! - ! G00 = (1 + B1*B2)^-1 G0T = -(1 - G00)*B2^-1 - ! GT0 = B2 * G00 GTT = (1 + B2*B1)^-1 - - !( 1 V1*D1*U1 )^-1 ( ( V1 0 ) ( V1^-1 D1*U1 ) )^-1 - !(-U2*D2*V2 1 ) == ( ( 0 U2 ) * (-D2*V2 U2^-1 ) ) == I - ! You should transpose before carrying out the singular value decomposition - ! - ! - ! ( ( V1 0 ) ( V1^-1 D1*U1 )^*^* )^-1 ( V1^-1 0 ) - ! I == ( ( 0 U2 ) * (-D2*V2 U2^-1 ) ) = (UDV^*)^(-1) * ( 0 U2^-1) = - ! - ! ( V1^-1 0 ) - ! == U * D^(*,-1) * V^(*,-1) * ( 0 U2^-1) - - ! Let's see if this could work. - Use Precdef - Use MyMats - Use UDV_WRAP_mod - Implicit none - - ! Arguments - Integer, intent(in) :: LQ - Complex (Kind=double), intent(in) :: U1(LQ,LQ), V1(LQ,LQ), U2(LQ,LQ), V2(LQ,LQ) - Complex (Kind=double), intent(in) :: D2(LQ), D1(LQ) - Complex (Kind=double), intent(inout) :: GRT0(LQ,LQ), GR0T(LQ,LQ), GR00(LQ,LQ), GRTT(LQ,LQ) - - - ! Local:: - Complex (Kind=double) :: U3B(2*LQ,2*LQ), V3B(2*LQ,2*LQ), HLPB1(2*LQ,2*LQ), HLPB2(2*LQ,2*LQ), & - & V2INV(LQ,LQ), V1INV(LQ,LQ), HLP2(LQ,LQ) - Complex (Kind=double) :: D3B(2*LQ) - Complex (Kind=double) :: Z - Real (Kind=double) :: X, Xmax - - Integer :: LQ2, I,J, M, ILQ, JLQ, NCON, I1, J1,N - - LQ2 = LQ*2 - NCON = 0 - - If (dble(D1(1)) > dble(D2(1)) ) Then - - !Write(6,*) "D1(1) > D2(1)", dble(D1(1)), dble(D2(1)) - - HLPB2 = cmplx(0.D0,0.d0,double) - CALL INV(V1,V1INV,Z) - DO J = 1,LQ - DO I = 1,LQ - HLPB2(I , J ) = V1INV(I,J) - HLPB2(I , J+LQ ) = D1(I)*U1(I,J) - HLPB2(I+LQ, J+LQ ) = Conjg(U2(J,I)) - HLPB2(I+LQ, J ) = -D2(I)*V2(I,J) - ENDDO - ENDDO - DO J = 1,LQ2 - DO I = 1,LQ2 - HLPB1(I,J) = Conjg(HLPB2(J,I)) - ENDDO - ENDDO - - !CALL UDV_wrap(HLPB1,U3B,D3B,V3B,NCON) - CALL UDV_wrap_Pivot(HLPB1,U3B,D3B,V3B,NCON,LQ2,LQ2) - -!!$!!!!!!!!!!!!! Tests -!!$ Xmax = 0.d0 -!!$ DO I = 1,LQ2 -!!$ DO J = 1,LQ2 -!!$ Z = cmplx(0.d0,0.d0) -!!$ DO N = 1,LQ2 -!!$ Z = Z + U3B(I,N) *conjg(U3B(J,N)) -!!$ ENDDO -!!$ if (I == J) Z = Z - cmplx(1.d0,0.d0) -!!$ X = real(SQRT( Z* conjg(Z)),kind=8) -!!$ if (X > Xmax) Xmax = X -!!$ ENDDO -!!$ ENDDO -!!$ !Write(6,*) 'Cgr2_2, ortho: ', Xmax -!!$ DO I = 1,LQ2 -!!$ Z = D3B(I) -!!$ if (I == 1) Xmax = real(SQRT( Z* conjg(Z)),kind=8) -!!$ if ( real(SQRT( Z* conjg(Z)),kind=8) < Xmax ) Xmax = & -!!$ & real(SQRT( Z* conjg(Z)),kind=8) -!!$ ENDDO -!!$ !Write(6,*) 'Cgr2_2, Cutoff: ', Xmax -!!$!!!!!!!!!!!!! End Tests - DO J = 1,LQ2 - DO I = 1,LQ2 - HLPB2(I,J) = Conjg(V3B(J,I)) - ENDDO - ENDDO - CALL INV(HLPB2,V3B,Z) - HLPB1 = cmplx(0.d0,0.d0,double) - DO I = 1,LQ - DO J = 1,LQ - HLPB1(I , J ) = V1INV(I,J) - HLPB1(I+LQ, J+LQ ) = Conjg(U2(J,I)) - ENDDO - ENDDO - CALL MMULT(HLPB2,V3B,HLPB1) - DO J = 1,LQ2 - DO I = 1,LQ2 - HLPB1(I,J) = Conjg(cmplx(1.d0,0.d0,double)/D3B(I))*HLPB2(I,J) - ENDDO - ENDDO - CALL MMULT(HLPB2,U3B,HLPB1) - DO I = 1,LQ - I1 = I+LQ - DO J = 1,LQ - J1 = J + LQ - GR00(I,J) = HLPB2(I ,J ) - GRTT(I,J) = HLPB2(I1,J1) - GRT0(I,J) = HLPB2(I1,J ) - GR0T(I,J) = HLPB2(I,J1 ) - ENDDO - ENDDO - Else - !Write(6,*) "D1(1) < D2(1)", dble(D1(1)), dble(D2(1)) - HLPB2 = cmplx(0.D0,0.d0,double) - CALL INV(V1,V1INV,Z) - DO J = 1,LQ - DO I = 1,LQ - HLPB2(I , J ) = Conjg(U2(J,I)) - HLPB2(I , J+LQ ) = -D2(I)*V2(I,J) - HLPB2(I+LQ, J+LQ ) = V1INV(I,J) - HLPB2(I+LQ, J ) = D1(I)*U1(I,J) - ENDDO - ENDDO - DO J = 1,LQ2 - DO I = 1,LQ2 - HLPB1(I,J) = Conjg(HLPB2(J,I)) - ENDDO - ENDDO - - !CALL UDV_wrap(HLPB1,U3B,D3B,V3B,NCON) - CALL UDV_wrap_Pivot(HLPB1,U3B,D3B,V3B,NCON,LQ2,LQ2) - - DO J = 1,LQ2 - DO I = 1,LQ2 - HLPB2(I,J) = Conjg(V3B(J,I)) - ENDDO - ENDDO - CALL INV(HLPB2,V3B,Z) - HLPB1 = cmplx(0.d0,0.d0,double) - DO I = 1,LQ - DO J = 1,LQ - HLPB1(I , J ) = Conjg(U2(J,I)) - HLPB1(I+LQ, J+LQ ) = V1INV(I,J) - ENDDO - ENDDO - CALL MMULT(HLPB2,V3B,HLPB1) - DO J = 1,LQ2 - DO I = 1,LQ2 - HLPB1(I,J) = Conjg(cmplx(1.d0,0.d0,double)/D3B(I))*HLPB2(I,J) - ENDDO - ENDDO - CALL MMULT(HLPB2,U3B,HLPB1) - DO I = 1,LQ - I1 = I+LQ - DO J = 1,LQ - J1 = J + LQ - GRTT(I,J) = HLPB2(I ,J ) - GR00(I,J) = HLPB2(I1,J1) - GR0T(I,J) = HLPB2(I1,J ) - GRT0(I,J) = HLPB2(I,J1 ) - ENDDO - ENDDO - Endif - - END SUBROUTINE CGR2_2 diff --git a/Prog_8/control_mod.f90 b/Prog_8/control_mod.f90 deleted file mode 100644 index ba1b18a04..000000000 --- a/Prog_8/control_mod.f90 +++ /dev/null @@ -1,142 +0,0 @@ - module Control - - Use MyMats - Implicit none - - real (Kind=8) , private, save :: XMEANG, XMAXG, XMAXP, CPU_time_st, CPU_time_en, Xmean_tau, Xmax_tau - Integer , private, save :: NCG, NCG_tau - Integer (Kind=8), private, save :: NC_up, ACC_up - - Contains - - subroutine control_init - Implicit none - XMEANG = 0.d0 - XMEAN_tau = 0.d0 - XMAXG = 0.d0 - XMAX_tau = 0.d0 - NCG = 0 - NCG_tau = 0 - NC_up = 0 - ACC_up = 0 - Call CPU_TIME(CPU_time_st) - end subroutine control_init - - Subroutine Control_upgrade(Log) - Implicit none - Logical :: Log - NC_up = NC_up + 1 - if (Log) ACC_up = ACC_up + 1 - end Subroutine Control_upgrade - - Subroutine Control_PrecisionG(A,B,Ndim) - Implicit none - - Integer :: Ndim - Complex (Kind=8) :: A(Ndim,Ndim), B(Ndim,Ndim) - Real (Kind=8) :: XMAX, XMEAN - - !Local - NCG = NCG + 1 - XMEAN = 0.d0 - XMAX = 0.d0 - CALL COMPARE(A, B, XMAX, XMEAN) - IF (XMAX > XMAXG) XMAXG = XMAX - XMEANG = XMEANG + XMEAN - !Write(6,*) 'Control', XMEAN, XMAX - End Subroutine Control_PrecisionG - - Subroutine Control_Precision_tau(A,B,Ndim) - Implicit none - - Integer :: Ndim - Complex (Kind=8) :: A(Ndim,Ndim), B(Ndim,Ndim) - Real (Kind=8) :: XMAX, XMEAN - - !Local - NCG_tau = NCG_tau + 1 - XMEAN = 0.d0 - XMAX = 0.d0 - CALL COMPARE(A, B, XMAX, XMEAN) - IF (XMAX > XMAX_tau) XMAX_tau = XMAX - XMEAN_tau = XMEAN_tau + XMEAN - !Write(6,*) 'Control_tau', XMEAN, XMAX - End Subroutine Control_Precision_tau - - - Subroutine Control_PrecisionP(Z,Z1) - Implicit none - Complex (Kind=8), INTENT(IN) :: Z,Z1 - Real (Kind=8) :: X - X = sqrt(dble((Z-Z1)*conjg(Z-Z1))) - if ( X > XMAXP ) XMAXP = X - End Subroutine Control_PrecisionP - - - Subroutine control_Print - Implicit none -#include "machine" -#ifdef MPI - include 'mpif.h' -#endif - Real (Kind=8) :: Time, Acc -#ifdef MPI - REAL (KIND=8) :: X - Integer :: Ierr, Isize, Irank - INTEGER :: STATUS(MPI_STATUS_SIZE) - CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) - CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) -#endif - - ACC = 0.d0 - IF (NC_up > 0 ) ACC = dble(ACC_up)/dble(NC_up) - Call CPU_TIME(CPU_time_en) - Time = CPU_time_en - CPU_time_st -#ifdef MPI - X = 0.d0 - CALL MPI_REDUCE(XMEANG,X,1,MPI_REAL8,MPI_SUM, 0,MPI_COMM_WORLD,IERR) - XMEANG = X/dble(Isize) - X = 0.d0 - CALL MPI_REDUCE(XMEAN_tau,X,1,MPI_REAL8,MPI_SUM, 0,MPI_COMM_WORLD,IERR) - XMEAN_tau = X/dble(Isize) - X = 0.d0 - CALL MPI_REDUCE(ACC,X,1,MPI_REAL8,MPI_SUM, 0,MPI_COMM_WORLD,IERR) - ACC = X/dble(Isize) - - X = 0.d0 - CALL MPI_REDUCE(Time,X,1,MPI_REAL8,MPI_SUM, 0,MPI_COMM_WORLD,IERR) - Time = X/dble(Isize) - - - CALL MPI_REDUCE(XMAXG,X,1,MPI_REAL8,MPI_MAX, 0,MPI_COMM_WORLD,IERR) - XMAXG = X - CALL MPI_REDUCE(XMAX_tau,X,1,MPI_REAL8,MPI_MAX, 0,MPI_COMM_WORLD,IERR) - XMAX_tau= X - - - CALL MPI_REDUCE(XMAXP,X,1,MPI_REAL8,MPI_MAX, 0,MPI_COMM_WORLD,IERR) - XMAXP = X - If (Irank == 0 ) then -#endif - - Open (Unit=50,file="info", status="unknown", position="append") - If (NCG > 0 ) then - XMEANG = XMEANG/dble(NCG) - Write(50,*) ' Precision Green Mean, Max : ', XMEANG, XMAXG - Write(50,*) ' Precision Phase, Max : ', XMAXP - endif - If ( NCG_tau > 0 ) then - XMEAN_tau = XMEAN_tau/dble(NCG_tau) - Write(50,*) ' Precision tau Mean, Max : ', XMEAN_tau, XMAX_tau - endif - Write(50,*) ' Acceptance : ', ACC - Write(50,*) ' CPU Time : ', Time - Close(50) -#ifdef MPI - endif -#endif - end Subroutine Control_Print - - end module control - - diff --git a/Prog_8/gperp.f90 b/Prog_8/gperp.f90 deleted file mode 100644 index acb61d3c2..000000000 --- a/Prog_8/gperp.f90 +++ /dev/null @@ -1,98 +0,0 @@ - Subroutine Gperp_sub( G, Gperp, Ndim,Irank) - - Use Precdef - Use MyMats - Implicit none - - ! Arguments - Integer, Intent(In) :: Ndim, Irank - Complex (kind=double), Intent(In) :: G(ndim,ndim) - Complex (kind=double), Intent(InOut) :: Gperp(ndim,ndim) - - ! Local space - Complex (Kind=double) :: A(ndim,ndim), W(ndim), VL(Ndim,ndim), VR(Ndim,ndim) - Character (len=1) :: JOBVL, JOBVR - Integer :: INFO, LDA, LDVL, LDVR, N, lp, LWORK, N_c,m, i, j, NCon - Complex (Kind=double) :: WORK(2*Ndim), U(Ndim,Ndim/2), Vec(Ndim),Z - Real (Kind=double) :: RWORK(2*ndim), X, Xmax, Xmean - Complex (Kind=double) :: U1(Ndim,Ndim/2), V(Ndim/2,Ndim/2), D(Ndim/2) - - - A = G - JOBVL = "N" - JOBVR = "V" - LDA = Ndim - LWORK = 2*Ndim - LDVL = Ndim - LDVR = Ndim - N = Ndim - - Call ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO ) - - !lp = 70 + Irank - !Write(lp,*) "Info: ", INFO - N_c = 0 - do n = 1,Ndim - !Write(lp,*) n, W(n) - if ( abs( dble(W(n)) ) < 0.00001 ) then - N_c = N_c + 1 - do i = 1,Ndim - U1(i,N_c) = VR(i,n) - enddo - endif - enddo - !Write(6,*) "N_c ", N_c - NCON = 0 - Call UDV (U1,U,D,V,NCON) - - ! Setpup G_perp - gperp = cmplx(0.d0,0.d0) - Do i = 1,Ndim - do j = 1,Ndim - do n = 1,Ndim/2 - Gperp(i,j) = Gperp(i,j) + U(i,n) * conjg( U(j,n) ) - enddo - enddo - enddo - -#ifdef Test_gperp - X = 0.05 - A = cmplx(1.d0-X,0.d0) * G + cmplx(x,0.d0)*Gperp - Call Inv(A,VR,Z) - Write(lp,*) "Det is ", Z - Call MMult(VL,A,VR) - VR = cmplx(0.d0,0.d0) - do i = 1,Ndim - VR(I,I) = cmplx(1.d0,0.d0) - enddo - Call Compare(VL,VR,Xmax,Xmean) - Write(lp,*) 'Compare: ', Xmax, Xmean - - ! This is for testing - do n = 1,N_c - Vec = cmplx(0.d0,0.d0) - do i = 1,Ndim - do j = 1,Ndim - Vec(i) = Vec(i) + G(i,j) * U(j,n) - enddo - enddo - X = 0.d0 - do i = 1,Ndim - X = X + dble( Vec(i) * conjg(Vec(i))) - enddo - X = sqrt(x) - Write(lp,*) 'n, G*v = ', n, X - enddo - - do n = 1,N_c - do m = n,N_c - Z = cmplx(0.d0,0.d0) - do j = 1,Ndim - Z = Z + Conjg(U(j,m)) * U(j,n) - enddo - Write(lp,*) "n,m,z ", n,m,z - enddo - enddo -#endif - - end Subroutine Gperp_sub diff --git a/Prog_8/inconfc.f90 b/Prog_8/inconfc.f90 deleted file mode 100644 index 97dffc123..000000000 --- a/Prog_8/inconfc.f90 +++ /dev/null @@ -1,126 +0,0 @@ - SUBROUTINE confin - - Use Hamiltonian - - Implicit none - -#include "machine" - - - -#ifdef MPI - INCLUDE 'mpif.h' - ! Local -#endif - - Integer :: I, IERR, ISIZE, IRANK, seed_in, K, iseed, Nt - Integer, dimension(:), allocatable :: Seed_vec - Real (Kind=8) :: X - Logical :: lconf - character (len=64) :: file_sr, File_tg - -#ifdef MPI - INTEGER :: STATUS(MPI_STATUS_SIZE) - CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) - CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) -#endif - - Allocate (Nsigma(Size(Op_V,1),Ltrot)) - -#ifdef MPI - INQUIRE (FILE='confin_0', EXIST=lconf) - If (lconf) Then - file_sr = "confin" - Call Get_seed_Len(K) - Allocate(Seed_vec(K)) - file_tg = File_i(file_sr,IRANK) - Open (Unit = 10, File=File_tg, status='old', ACTION='read') - Read(10,*) Seed_vec - Call Ranset(Seed_vec) - do NT = 1,LTROT - do I = 1,Size(Op_V,1) - Read(10,*) NSIGMA(I,NT) - enddo - enddo - close(10) - Deallocate(Seed_vec) - else - If (Irank == 0) then - Write(6,*) 'No initial configuration' - OPEN(UNIT=5,FILE='seeds',STATUS='old',ACTION='read',IOSTAT=ierr) - IF (ierr /= 0) THEN - WRITE(*,*) 'unable to open ',ierr - STOP - END IF - DO I = Isize-1,1,-1 - Read (5,*) Seed_in - CALL MPI_SEND(Seed_in,1,MPI_INTEGER, I, I+1024,MPI_COMM_WORLD,IERR) - enddo - Read(5,*) Seed_in - CLOSE(5) - else - CALL MPI_RECV(Seed_in, 1, MPI_INTEGER,0, IRANK + 1024, MPI_COMM_WORLD,STATUS,IERR) - endif - Call Get_seed_Len(K) - !Write(6,*) K - Allocate(Seed_vec(K)) - Do I = 1,K - X = Ranf_Imada(Seed_in) - Seed_vec(I) = Seed_in - enddo - Call Ranset(Seed_vec) - Deallocate(Seed_vec) - do NT = 1,LTROT - do I = 1,Size(Op_V,1) - X = RANF() - NSIGMA(I,NT) = 1 - IF (X.GT.0.5) NSIGMA(I,NT) = -1 - enddo - enddo - endif - -#else - INQUIRE (FILE='confin_0', EXIST=lconf) - If (lconf) Then - file_tg = "confin_0" - Call Get_seed_Len(K) - Allocate(Seed_vec(K)) - Open (Unit = 10, File=File_tg, status='old', ACTION='read') - Read(10,*) Seed_vec - Call Ranset(Seed_vec) - do NT = 1,LTROT - do I = 1,Size(Op_V,1) - Read(10,*) NSIGMA(I,NT) - enddo - enddo - close(10) - Deallocate(Seed_vec) - else - Write(6,*) 'No initial configuration' - OPEN(UNIT=5,FILE='seeds',STATUS='old',ACTION='read',IOSTAT=ierr) - IF (ierr /= 0) THEN - WRITE(*,*) 'unable to open ',ierr - STOP - END IF - Read (5,*) Seed_in - CLOSE(5) - Call Get_seed_Len(K) - !Write(6,*) K - Allocate(Seed_vec(K)) - Do I = 1,K - X = Ranf_Imada(Seed_in) - Seed_vec(I) = Seed_in - enddo - Call Ranset(Seed_vec) - Deallocate(Seed_vec) - do NT = 1,LTROT - do I = 1,Size(Op_V,1) - X = RANF() - NSIGMA(I,NT) = 1 - IF (X.GT.0.5) NSIGMA(I,NT) = -1 - enddo - enddo - endif -#endif - - END SUBROUTINE CONFIN diff --git a/Prog_8/machine b/Prog_8/machine deleted file mode 100644 index 2e1fc39e2..000000000 --- a/Prog_8/machine +++ /dev/null @@ -1 +0,0 @@ -#define noMPI diff --git a/Prog_8/main.f90 b/Prog_8/main.f90 deleted file mode 100644 index bd810ccd1..000000000 --- a/Prog_8/main.f90 +++ /dev/null @@ -1,449 +0,0 @@ -Program Main - - Use Operator_mod - Use Lattices_v3 - Use MyMats - Use Hamiltonian - Use Control - Use Tau_m_mod - Use Hop_mod - Implicit none -#include "machine" -#ifdef MPI - include 'mpif.h' -#endif - - - Interface - SUBROUTINE WRAPUL(NTAU1, NTAU, UL ,DL, VL) - Use Hamiltonian - Implicit none - COMPLEX (KIND=8) :: UL(Ndim,Ndim,N_FL), VL(Ndim,Ndim,N_FL) - COMPLEX (KIND=8) :: DL(Ndim,N_FL) - Integer :: NTAU1, NTAU - END SUBROUTINE WRAPUL - SUBROUTINE CGR(PHASE,NVAR, GRUP, URUP,DRUP,VRUP, ULUP,DLUP,VLUP) - Use UDV_Wrap_mod - Implicit None - COMPLEX(Kind=8), Dimension(:,:), Intent(In) :: URUP, VRUP, ULUP, VLUP - COMPLEX(Kind=8), Dimension(:), Intent(In) :: DLUP, DRUP - COMPLEX(Kind=8), Dimension(:,:), Intent(Inout) :: GRUP - COMPLEX(Kind=8) :: PHASE - INTEGER :: NVAR - END SUBROUTINE CGR - SUBROUTINE WRAPGRUP(GR,NTAU,PHASE) - Use Hamiltonian - Implicit none - COMPLEX (Kind=8), INTENT(INOUT) :: GR(Ndim,Ndim,N_FL) - COMPLEX (Kind=8), INTENT(INOUT) :: PHASE - INTEGER, INTENT(IN) :: NTAU - END SUBROUTINE WRAPGRUP - SUBROUTINE WRAPGRDO(GR,NTAU,PHASE) - Use Hamiltonian - Implicit None - COMPLEX (Kind=8), INTENT(INOUT) :: GR(NDIM,NDIM,N_FL) - COMPLEX (Kind=8), INTENT(INOUT) :: PHASE - Integer :: NTAU - end SUBROUTINE WRAPGRDO - SUBROUTINE WRAPUR(NTAU, NTAU1, UR, DR, VR) - Use Hamiltonian - Use UDV_Wrap_mod - Implicit None - COMPLEX (KIND=8) :: UR(Ndim,Ndim,N_FL), VR(Ndim,Ndim,N_FL) - COMPLEX (KIND=8) :: DR(Ndim,N_FL) - Integer :: NTAU1, NTAU - END SUBROUTINE WRAPUR - - end Interface - - COMPLEX (Kind=8), Dimension(:) , Allocatable :: D - COMPLEX (KIND=8), Dimension(:,:) , Allocatable :: TEST, A, U, V - - COMPLEX (Kind=8), Dimension(:,:) , Allocatable :: DL, DR - COMPLEX (Kind=8), Dimension(:,:,:), Allocatable :: UL, VL, UR, VR - COMPLEX (Kind=8), Dimension(:,:,:), Allocatable :: GR - - - Integer :: Nwrap, NSweep, NBin, Ltau, NSTM, NT, NT1, NVAR, LOBS_EN, LOBS_ST, NBC, NSW - Integer :: NTAU, NTAU1 - - NAMELIST /VAR_QMC/ Nwrap, NSweep, NBin, Ltau, LOBS_EN, LOBS_ST - - Integer :: Ierr, I,J,nf, nst, n - Complex (Kind=8) :: Z_ONE = cmplx(1.d0,0.d0), Phase, Z, Z1 - - ! Space for storage. - COMPLEX (Kind=8), Dimension(:,:,:) , Allocatable :: DST - COMPLEX (Kind=8), Dimension(:,:,:,:), Allocatable :: UST, VST - - ! For tests - Integer, external :: nranf - Real (kind=8) :: Weight - Integer :: nr,nth - Logical :: Log -#ifdef MPI - Integer :: Isize, Irank - INTEGER :: STATUS(MPI_STATUS_SIZE) - CALL MPI_INIT(ierr) - CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) - CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) -#endif - - ! Write(6,*) 'Call Ham_set' - Call Ham_set - ! Write(6,*) 'End Call Ham_set' - Call confin - Call Hop_mod_init - !Call Hop_mod_test - !stop - -#ifdef MPI - If ( Irank == 0 ) then -#endif - OPEN(UNIT=5,FILE='parameters',STATUS='old',ACTION='read',IOSTAT=ierr) - IF (ierr /= 0) THEN - WRITE(*,*) 'unable to open ',ierr - STOP - END IF - READ(5,NML=VAR_QMC) - CLOSE(5) -#ifdef MPI - Endif - CALL MPI_BCAST(Nwrap ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(NSweep ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(NBin ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(Ltau ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(LOBS_EN ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) - CALL MPI_BCAST(LOBS_ST ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) -#endif - - - Call control_init - Call Alloc_obs(Ltau) - Call Op_SetHS - - -!!$#ifdef Ising_test -!!$ ! Test Ising -!!$ DO NBC = 1, NBIN -!!$ Call Init_obs -!!$ DO NSW = 1, NSWEEP -!!$ do nth = 1,Ltrot*2*Latt%N -!!$ Nt = nranf(Ltrot) -!!$ Nr = nranf(2*Latt%N) -!!$ Weight = S0(nr,nt) -!!$ log =.false. -!!$ if (Weight > ranf()) then -!!$ nsigma(nr,nt) = - nsigma(nr,nt) -!!$ log =.true. -!!$ endif -!!$ Call Control_upgrade(log) -!!$ enddo -!!$ Call Obser -!!$ Enddo -!!$ Call Preq -!!$ Enddo -!!$ Call Ham_confout -!!$ Call control_Print -!!$ Stop -!!$ ! End Test Ising -!!$#endif - - Allocate( DL(NDIM,N_FL), DR(NDIM,N_FL) ) - Allocate( UL(NDIM,NDIM,N_FL), VL(NDIM,NDIM,N_FL), & - & UR(NDIM,NDIM,N_FL), VR(NDIM,NDIM,N_FL), GR(NDIM,NDIM,N_FL ) ) - NSTM = LTROT/NWRAP -#ifdef MPI - if ( Irank == 0 ) then -#endif - Open (Unit = 50,file="info",status="unknown",position="append") - Write(50,*) 'Sweeps : ', Nsweep - Write(50,*) 'Bin : ', NBin - Write(50,*) 'Measure Int. : ', LOBS_ST, LOBS_EN - Write(50,*) 'Stabilization,Wrap : ', Nwrap - Write(50,*) 'Nstm : ', NSTM - Write(50,*) 'Ltau : ', Ltau - close(50) -#ifdef MPI - endif -#endif - - Allocate ( UST(NDIM,NDIM,NSTM,N_FL), VST(NDIM,NDIM,NSTM,N_FL), DST(NDIM,NSTM,N_FL) ) - Allocate ( Test(Ndim,Ndim) ) - - NST = NINT( DBLE(LTROT)/DBLE(NWRAP) ) - !Write(6,*) "Write UL ", NST - Do nf = 1,N_FL - CALL INITD(UL(:,:,Nf),Z_ONE) - do I = 1,Ndim - DL(I,Nf) = Z_ONE - enddo - CALL INITD(VL(:,:,nf),Z_ONE) - DO I = 1,NDim - DO J = 1,NDim - UST(I,J,NST,nf) = UL(I,J,nf) - VST(I,J,NST,nf) = VL(I,J,nf) - ENDDO - ENDDO - DO I = 1,NDim - DST(I,NST,nf) = DL(I,nf) - ENDDO - - CALL INITD(UR(:,:,nf),Z_ONE) - CALL INITD(VR(:,:,nf),Z_ONE) - Do I = 1,Ndim - DR(I,nf) = Z_ONE - Enddo - Enddo - - DO NT = LTROT-NWRAP,NWRAP,-1 - IF ( MOD(NT,NWRAP) == 0 ) THEN - NT1 = NT + NWRAP - !Write(6,*) 'Calling Wrapul:', NT1,NT - CALL WRAPUL(NT1,NT,UL,DL, VL) - NST = NINT( DBLE(NT)/DBLE(NWRAP) ) - !Write(6,*) "Write UL ", NST - Do nf = 1,N_FL - DO I = 1,Ndim - DO J = 1,Ndim - UST(I,J,NST,nf) = UL(I,J,nf) - VST(I,J,NST,nf) = VL(I,J,nf) - ENDDO - ENDDO - DO I = 1,Ndim - DST(I,NST,nf) = DL(I,nf) - ENDDO - ENDDO - ENDIF - ENDDO - CALL WRAPUL(NWRAP,0, UL ,DL, VL) - - !WRITE(6,*) 'Filling up storage' - !Write(6,*) 'Done wrapping' - NVAR = 1 - Phase = cmplx(1.d0,0.d0) - do nf = 1,N_Fl - CALL CGR(Z, NVAR, GR(:,:,nf), UR(:,:,nf),DR(:,nf),VR(:,:,nf), UL(:,:,nf),DL(:,nf),VL(:,:,nf) ) - Phase = Phase*Z - Enddo - call Op_phase(Phase,OP_V,Nsigma,N_SUN) -#ifdef MPI - WRITE(6,*) 'Phase is: ', Irank, PHASE, GR(1,1,1) -#else - WRITE(6,*) 'Phase is: ', PHASE -!!$ if (N_FL == 1) then -!!$ Do n = 1,Ndim -!!$ Write(6,*) GR(1,n,1) -!!$ enddo -!!$ else -!!$ Do n = 1,Ndim -!!$ Write(6,*) GR(1,n,1), GR(1,n,2) -!!$ enddo -!!$ endif -#endif - - Call Control_init - - DO NBC = 1, NBIN - ! Here, you have the green functions on time slice 1. - ! Set bin observables to zero. - - Call Init_obs(Ltau) - DO NSW = 1, NSWEEP - - !Propagation from 1 to Ltrot - !Set the right storage to 1 - - do nf = 1,N_FL - CALL INITD(UR(:,:,nf),Z_ONE) - CALL INITD(VR(:,:,nf),Z_ONE) - do n = 1,Ndim - DR(n,nf)= Z_ONE - Enddo - Enddo - - DO NTAU = 0, LTROT-1 - NTAU1 = NTAU + 1 - !Write(6,*) "Hi" - CALL WRAPGRUP(GR,NTAU,PHASE) - !Write(6,*) "Hi1" - IF ( MOD(NTAU1,NWRAP ) .EQ. 0 ) THEN - NST = NINT( DBLE(NTAU1)/DBLE(NWRAP) ) - NT1 = NTAU1 - NWRAP - CALL WRAPUR(NT1, NTAU1,UR, DR, VR) - Z = cmplx(1.d0,0.d0) - Do nf = 1, N_FL - DO J = 1,Ndim - DO I = 1,Ndim - UL(I,J,nf) = UST(I,J,NST,nf) - VL(I,J,nf) = VST(I,J,NST,nf) - ENDDO - ENDDO - DO I = 1,Ndim - DL(I,nf) = DST(I,NST,nf) - ENDDO - ! Write in store Right prop from 1 to LTROT/NWRAP - !Write(6,*) 'Write UR, read UL ', NTAU1, NST - DO J = 1,Ndim - DO I = 1,Ndim - UST(I,J,NST,nf) = UR(I,J,nf) - VST(I,J,NST,nf) = VR(I,J,nf) - ENDDO - ENDDO - DO I = 1,Ndim - DST(I,NST,nf) = DR(I,nf) - ENDDO - NVAR = 1 - IF (NTAU1 .GT. LTROT/2) NVAR = 2 - !Write(6,*) ' Call Cgr' - do J = 1,Ndim - do I = 1,Ndim - TEST(I,J) = GR(I,J,nf) - enddo - enddo - CALL CGR(Z1, NVAR, GR(:,:,nf), UR(:,:,nf),DR(:,nf),VR(:,:,nf),UL(:,:,nf),DL(:,nf),VL(:,:,nf) ) - Z = Z*Z1 - !Write(6,*) 'Calling control ',NTAU1, Z1 - Call Control_PrecisionG(GR(:,:,nf),Test,Ndim) - ENDDO - call Op_phase(Z,OP_V,Nsigma,N_SUN) - Call Control_PrecisionP(Z,Phase) - Phase = Z - ENDIF - - IF (NTAU1.GE. LOBS_ST .AND. NTAU1.LE. LOBS_EN ) THEN - !Write(6,*) 'Call obser ', Ntau1 - CALL Obser( GR, PHASE, Ntau1 ) - !Write(6,*) 'Return obser' - ENDIF - !Write(6,*) NTAU1 - ENDDO - - Do nf = 1,N_FL - CALL INITD(UL(:,:,nf),Z_ONE) - CALL INITD(VL(:,:,nf),Z_ONE) - Do n = 1,Ndim - DL(n,nf) = Z_ONE - Enddo - ENDDO - - DO NTAU = LTROT,1,-1 - NTAU1 = NTAU - 1 - CALL WRAPGRDO(GR,NTAU, PHASE) - IF (NTAU1.GE. LOBS_ST .AND. NTAU1.LE. LOBS_EN ) THEN - CALL Obser( GR, PHASE, Ntau1 ) - ENDIF - IF ( MOD(NTAU1,NWRAP).EQ.0 .AND. NTAU1.NE.0 ) THEN - ! WRITE(50,*) 'Recalc at :', NTAU1 - NST = NINT( DBLE(NTAU1)/DBLE(NWRAP) ) - NT1 = NTAU1 + NWRAP - !Write(6,*) 'Wrapul : ', NT1, NTAU1 - CALL WRAPUL(NT1,NTAU1, UL, DL, VL ) - !Write(6,*) 'Write UL, read UR ', NTAU1, NST - Z = cmplx(1.d0,0.d0) - do nf = 1,N_FL - DO J = 1,Ndim - DO I = 1,Ndim - UR(I,J,nf) = UST(I,J,NST,nf) - VR(I,J,nf) = VST(I,J,NST,nf) - ENDDO - ENDDO - DO I = 1,Ndim - DR(I,nf) = DST(I,NST,nf) - ENDDO - ! WRITE in store the left prop. from LTROT/NWRAP-1 to 1 - DO J = 1,Ndim - DO I = 1,Ndim - UST(I,J,NST,nf) = UL(I,J,nf) - VST(I,J,NST,nf) = VL(I,J,nf) - ENDDO - ENDDO - DO I = 1,Ndim - DST(I,NST,nf) = DL(I,nf) - ENDDO - NVAR = 1 - IF (NTAU1 .GT. LTROT/2) NVAR = 2 - !Write(6,*) ' Call Cgr' - do J = 1,Ndim - do I = 1,Ndim - TEST(I,J) = GR(I,J,nf) - enddo - enddo - CALL CGR(Z1, NVAR, GR(:,:,nf), UR(:,:,nf),DR(:,nf),VR(:,:,nf), UL(:,:,nf),DL(:,nf),VL(:,:,nf) ) - Z = Z*Z1 - !Write(6,*) 'Calling control: ', NTAU1, Z1 - Call Control_PrecisionG(GR(:,:,nf),Test,Ndim) - ENDDO - call Op_phase(Z,OP_V,Nsigma,N_SUN) - Call Control_PrecisionP(Z,Phase) - Phase = Z - ENDIF - ENDDO - - !Calculate and compare green functions on time slice 0. - NT1 = 0 - CALL WRAPUL(NWRAP,NT1, UL, DL, VL ) - - do nf = 1,N_FL - CALL INITD(UR(:,:,nf),Z_ONE) - CALL INITD(VR(:,:,nf),Z_ONE) - DO I = 1,Ndim - DR(I,nf) = Z_ONE - ENDDO - ENDDO - Z = cmplx(1.d0,0.d0) - do nf = 1,N_FL - do J = 1,Ndim - do I = 1,Ndim - TEST(I,J) = GR(I,J,nf) - enddo - enddo - NVAR = 1 - CALL CGR(Z1, NVAR, GR(:,:,nf), UR(:,:,nf),DR(:,nf),VR(:,:,nf), UL(:,:,nf),DL(:,nf),VL(:,:,nf) ) - Z = Z*Z1 - !Write(6,*) 'Calling control 0', Z1 - Call Control_PrecisionG(GR(:,:,nf),Test,Ndim) - ENDDO - call Op_phase(Z,OP_V,Nsigma,N_SUN) - Call Control_PrecisionP(Z,Phase) - Phase = Z - NST = NINT( DBLE(LTROT)/DBLE(NWRAP) ) - Do nf = 1,N_FL - DO I = 1,Ndim - DO J = 1,Ndim - UST(I,J,NST,nf) = CMPLX(0.D0,0.D0) - VST(I,J,NST,nf) = CMPLX(0.D0,0.D0) - ENDDO - ENDDO - DO I = 1,Ndim - DST(I ,NST,nf) = CMPLX(1.D0,0.D0) - UST(I,I,NST,nf) = CMPLX(1.D0,0.D0) - VST(I,I,NST,nf) = CMPLX(1.D0,0.D0) - ENDDO - enddo - IF ( LTAU == 1 ) then -!!$#ifdef MPI -!!$ Write(6,*) Irank, 'Calling Tau_m', NWRAP, NSTM -!!$#else -!!$ Write(6,*) 'Calling Tau_m', NWRAP, NSTM -!!$#endif - - Call TAU_M( UST,DST,VST, GR, PHASE, NSTM, NWRAP ) -!!$#ifdef MPI -!!$ Write(6,*) Irank, 'Back Calling Tau_m' -!!$#else -!!$ Write(6,*) 'Back Calling Tau_m' -!!$#endif - endif - - ENDDO - Call Pr_obs(Ltau) - Call confout - Enddo - Call Control_Print - -#ifdef MPI - CALL MPI_FINALIZE(ierr) -#endif - -end Program Main diff --git a/Prog_8/nranf.f90 b/Prog_8/nranf.f90 deleted file mode 100644 index 4662b0f63..000000000 --- a/Prog_8/nranf.f90 +++ /dev/null @@ -1,12 +0,0 @@ - integer function nranf(N) - Use Random_wrap - implicit none - integer :: N - - nranf = nint(ranf()*dble(N) + 0.5) - - if (nranf .lt. 1 ) nranf = 1 - if (nranf .gt. N ) nranf = N - - end function nranf - diff --git a/Prog_8/outconfc.f90 b/Prog_8/outconfc.f90 deleted file mode 100644 index 1a8ec4e53..000000000 --- a/Prog_8/outconfc.f90 +++ /dev/null @@ -1,57 +0,0 @@ - SUBROUTINE confout - - Use Hamiltonian - - Implicit none - -#include "machine" - - -#ifdef MPI - INCLUDE 'mpif.h' - ! Local -#endif - - Integer :: I, IERR, ISIZE, IRANK, seed_in, K, iseed, Nt, nr - Integer, dimension(:), allocatable :: Seed_vec - Real (Kind=8) :: X - Logical :: lconf - character (len=64) :: file_sr, File_tg - -#ifdef MPI - INTEGER :: STATUS(MPI_STATUS_SIZE) - CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) - CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) - - Call Get_seed_Len(K) - Allocate(Seed_vec(K)) - Call Ranget(Seed_vec) - file_sr = "confout" - file_tg = File_i(file_sr,IRANK) - Open (Unit = 10, File=File_tg, status='unknown', ACTION='write') - Write(10,*) Seed_vec - do NT = 1,LTROT - do I = 1,Size(Nsigma,1) - write(10,*) NSIGMA(I,NT) - enddo - enddo - close(10) - Deallocate(Seed_vec) - -#else - Call Get_seed_Len(K) - Allocate(Seed_vec(K)) - Call Ranget(Seed_vec) - file_tg = "confout_0" - Open (Unit = 10, File=File_tg, status='unknown', ACTION='write') - Write(10,*) Seed_vec - do NT = 1,LTROT - do I = 1,Size(Nsigma,1) - write(10,*) Nsigma(I,NT) - enddo - enddo - close(10) - Deallocate(Seed_vec) -#endif - - END SUBROUTINE CONFOUT diff --git a/Prog_8/print_bin_mod.f90 b/Prog_8/print_bin_mod.f90 deleted file mode 100644 index 68376b44d..000000000 --- a/Prog_8/print_bin_mod.f90 +++ /dev/null @@ -1,300 +0,0 @@ - Module Print_bin_mod - - Interface Print_bin - module procedure Print_bin_C, Print_bin_R - end Interface Print_bin - - Interface Print_bin_tau - module procedure Print_bin_tau_C - end Interface Print_bin_tau - - Contains - - Subroutine Print_bin_C(Dat_eq,Dat_eq0,Latt, Nobs, Phase_bin_tmp, file_pr) - Use Lattices_v3 - Implicit none -#include "machine" -#ifdef MPI - include 'mpif.h' -#endif - - Complex (Kind=8), Dimension(:,:,:), Intent(inout):: Dat_eq - Complex (Kind=8), Dimension(:) , Intent(inout):: Dat_eq0 - Type (Lattice), Intent(In) :: Latt - Complex (Kind=8), Intent(In) :: Phase_bin_tmp - Character (len=64), Intent(In) :: File_pr - Integer, Intent(In) :: Nobs - - ! Local - Integer :: Norb, I, no,no1 - Complex (Kind=8), allocatable :: Tmp(:,:,:), Tmp1(:) - Real (Kind=8) :: x_p(2) - Complex (Kind=8) :: Phase_bin -#ifdef MPI - Complex (Kind=8):: Z - Integer :: Ierr, Isize, Irank - INTEGER :: STATUS(MPI_STATUS_SIZE) - CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) - CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) -#endif - - Phase_bin = Phase_bin_tmp - Norb = size(Dat_eq,3) - if ( .not. (Latt%N == Size(Dat_eq,1) ) ) then - Write(6,*) 'Error in Print_bin' - Stop - endif - Allocate (Tmp(Latt%N,Norb,Norb), Tmp1(Norb) ) - Dat_eq = Dat_eq/cmplx(dble(Nobs),0.d0) - Dat_eq0 = Dat_eq0/cmplx(dble(Nobs)*dble(Latt%N),0.d0) - -#ifdef MPI - I = Latt%N*Norb*Norb - Tmp = cmplx(0.d0,0.d0) - CALL MPI_REDUCE(Dat_eq,Tmp,I,MPI_COMPLEX16,MPI_SUM, 0,MPI_COMM_WORLD,IERR) - Dat_eq = Tmp/CMPLX(DBLE(ISIZE),0.D0) - I = 1 - CALL MPI_REDUCE(Phase_bin,Z,I,MPI_COMPLEX16,MPI_SUM, 0,MPI_COMM_WORLD,IERR) - Phase_bin= Z/CMPLX(DBLE(ISIZE),0.D0) - - I = Norb - CALL MPI_REDUCE(Dat_eq0,Tmp1,I,MPI_COMPLEX16,MPI_SUM, 0,MPI_COMM_WORLD,IERR) - Dat_eq0 = Tmp1/CMPLX(DBLE(ISIZE),0.D0) - - If (Irank == 0 ) then -#endif - do no = 1,Norb - do no1 = 1,Norb - Call Fourier_R_to_K(Dat_eq(:,no,no1), Tmp(:,no,no1), Latt) - enddo - enddo - Open (Unit=10,File=File_pr, status="unknown", position="append") - Write(10,*) dble(Phase_bin),Norb,Latt%N - do no = 1,Norb - Write(10,*) Dat_eq0(no) - enddo - do I = 1,Latt%N - x_p = dble(Latt%listk(i,1))*Latt%b1_p + dble(Latt%listk(i,2))*Latt%b2_p - Write(10,*) X_p(1), X_p(2) - do no = 1,Norb - do no1 = 1,Norb - Write(10,*) tmp(I,no,no1) - enddo - enddo - enddo - close(10) -#ifdef MPI - Endif -#endif - - deallocate (Tmp, tmp1 ) - - - End Subroutine Print_bin_C - - -!========================================================= - - Subroutine Print_bin_R(Dat_eq,Dat_eq0,Latt, Nobs, Phase_bin_tmp, file_pr) - Use Lattices_v3 - Implicit none -#include "machine" -#ifdef MPI - include 'mpif.h' -#endif - - Real (Kind=8), Dimension(:,:,:), Intent(inout) :: Dat_eq - Real (Kind=8), Dimension(:) , Intent(inout) :: Dat_eq0 - Type (Lattice), Intent(In) :: Latt - Complex (Kind=8), Intent(In) :: Phase_bin_tmp - Character (len=64), Intent(In) :: File_pr - Integer, Intent(In) :: Nobs - - ! Local - Integer :: Norb, I, no,no1 - Real (Kind=8), allocatable :: Tmp(:,:,:), Tmp1(:) - Real (Kind=8) :: x_p(2) - Complex (Kind=8) :: Phase_bin -#ifdef MPI - Integer :: Ierr, Isize, Irank - Complex (Kind=8) :: Z - INTEGER :: STATUS(MPI_STATUS_SIZE) - CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) - CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) -#endif - - Phase_bin = Phase_bin_tmp - Norb = size(Dat_eq,3) - if ( .not. (Latt%N == Size(Dat_eq,1) ) ) then - Write(6,*) 'Error in Print_bin' - Stop - endif - Allocate (Tmp(Latt%N,Norb,Norb), Tmp1(Norb) ) - Dat_eq = Dat_eq/dble(Nobs) - Dat_eq0 = Dat_eq0/(dble(Nobs)*dble(Latt%N)) -#ifdef MPI - I = Latt%N*Norb*Norb - Tmp = 0.d0 - CALL MPI_REDUCE(Dat_eq,Tmp,I,MPI_REAL8,MPI_SUM, 0,MPI_COMM_WORLD,IERR) - Dat_eq = Tmp/DBLE(ISIZE) - I = 1 - CALL MPI_REDUCE(Phase_bin,Z,I,MPI_COMPLEX16,MPI_SUM, 0,MPI_COMM_WORLD,IERR) - Phase_bin= Z/CMPLX(DBLE(ISIZE),0.D0) - If (Irank == 0 ) then - - I = Norb - CALL MPI_REDUCE(Dat_eq0,Tmp1,I,MPI_REAL8,MPI_SUM, 0,MPI_COMM_WORLD,IERR) - Dat_eq0 = Tmp1/CMPLX(DBLE(ISIZE),0.D0) - -#endif - - do no = 1,Norb - do no1 = 1,Norb - Call Fourier_R_to_K(Dat_eq(:,no,no1), Tmp(:,no,no1), Latt) - enddo - enddo - Open (Unit=10,File=File_pr, status="unknown", position="append") - Write(10,*) dble(Phase_bin),Norb,Latt%N - do no = 1,Norb - Write(10,*) Dat_eq0(no) - enddo - do I = 1,Latt%N - x_p = dble(Latt%listk(i,1))*Latt%b1_p + dble(Latt%listk(i,2))*Latt%b2_p - Write(10,*) X_p(1), X_p(2) - do no = 1,Norb - do no1 = 1,Norb - Write(10,*) tmp(I,no,no1) - enddo - enddo - enddo - close(10) -#ifdef MPI - endif -#endif - deallocate (Tmp ) - - End Subroutine Print_bin_R -!============================================================ - Subroutine Print_scal(Obs, Nobs, file_pr) - - Implicit none -#include "machine" -#ifdef MPI - include 'mpif.h' -#endif - - Complex (Kind=8), Dimension(:), Intent(inout) :: Obs - Character (len=64), Intent(In) :: File_pr - Integer, Intent(In) :: Nobs - - ! Local - Integer :: Norb,I - Complex (Kind=8), allocatable :: Tmp(:) -#ifdef MPI - Integer :: Ierr, Isize, Irank - INTEGER :: STATUS(MPI_STATUS_SIZE) - CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) - CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) -#endif - - Norb = size(Obs,1) - Allocate ( Tmp(Norb) ) - Obs = Obs/cmplx(dble(Nobs),0.d0) -#ifdef MPI - Tmp = 0.d0 - CALL MPI_REDUCE(Obs,Tmp,Norb,MPI_COMPLEX16,MPI_SUM, 0,MPI_COMM_WORLD,IERR) - Obs = Tmp/cmplx(DBLE(ISIZE),0.d0) - if (Irank == 0 ) then -#endif - Open (Unit=10,File=File_pr, status="unknown", position="append") - WRITE(10,*) (Obs(I), I=1,size(Obs,1)) - close(10) -#ifdef MPI - endif -#endif - deallocate (Tmp ) - - End Subroutine Print_scal - -!============================================================== - Subroutine Print_bin_tau_C(Dat_tau,Latt, Nobs, Phase_bin, file_pr, dtau) - Use Lattices_v3 - Implicit none -#include "machine" -#ifdef MPI - include 'mpif.h' -#endif - - Complex (Kind=8), Dimension(:,:,:,:), Intent(inout):: Dat_tau - Type (Lattice), Intent(In) :: Latt - Complex (Kind=8), Intent(In) :: Phase_bin - Character (len=64), Intent(In) :: File_pr - Integer, Intent(In) :: Nobs - Real (kind=8), Intent(In) :: dtau - - ! Local - Integer :: Norb, I, no,no1, LT, nt - Complex (Kind=8), allocatable :: Tmp(:,:,:,:) - Complex (Kind=8) :: Phase_mean - Real (Kind=8) :: x_p(2) -#ifdef MPI - Complex (Kind=8):: Z - Integer :: Ierr, Isize, Irank - INTEGER :: STATUS(MPI_STATUS_SIZE) - CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) - CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) -#endif - - Phase_mean = Phase_bin - Norb = size(Dat_tau,3) - if ( .not. (Latt%N == Size(Dat_tau,1) ) ) then - Write(6,*) 'Error in Print_bin' - Stop - endif - LT = Size(Dat_tau,2) - Allocate (Tmp(Latt%N,LT,Norb,Norb) ) - Dat_tau = Dat_tau/cmplx(dble(Nobs),0.d0) - -#ifdef MPI - I = Latt%N*Norb*Norb*LT - Tmp = cmplx(0.d0,0.d0) - CALL MPI_REDUCE(Dat_tau,Tmp,I,MPI_COMPLEX16,MPI_SUM, 0,MPI_COMM_WORLD,IERR) - Dat_tau = Tmp/CMPLX(DBLE(ISIZE),0.D0) - I = 1 - CALL MPI_REDUCE(Phase_mean,Z,I,MPI_COMPLEX16,MPI_SUM, 0,MPI_COMM_WORLD,IERR) - Phase_mean= Z/CMPLX(DBLE(ISIZE),0.D0) - If (Irank == 0 ) then -#endif - do nt = 1,LT - do no = 1,Norb - do no1 = 1,Norb - Call Fourier_R_to_K(Dat_tau(:,nt,no,no1), Tmp(:,nt,no,no1), Latt) - enddo - enddo - enddo - Open (Unit=10,File=File_pr, status="unknown", position="append") - Write(10,*) dble(Phase_mean),Norb,Latt%N, LT, dtau - do I = 1,Latt%N - x_p = dble(Latt%listk(i,1))*Latt%b1_p + dble(Latt%listk(i,2))*Latt%b2_p - Write(10,*) X_p(1), X_p(2) - Do nt = 1,LT - do no = 1,Norb - do no1 = 1,Norb - Write(10,*) tmp(I,nt,no,no1) - enddo - enddo - enddo - enddo - close(10) -#ifdef MPI - Endif -#endif - - deallocate (Tmp ) - - - End Subroutine Print_bin_tau_C - - - - end Module Print_bin_mod diff --git a/Prog_8/tau_m.f90 b/Prog_8/tau_m.f90 deleted file mode 100644 index b1056e18d..000000000 --- a/Prog_8/tau_m.f90 +++ /dev/null @@ -1,236 +0,0 @@ - Module Tau_m_mod - - Use Hamiltonian - Use Operator_mod - Use Precdef - Use Control - Use Hop_mod - - Contains - - SUBROUTINE TAU_M( UST,DST,VST, GR, PHASE, NSTM, NWRAP ) - - Implicit none - - Interface - SUBROUTINE WRAPUL(NTAU1, NTAU, UL ,DL, VL) - Use Hamiltonian - Implicit none - COMPLEX (KIND=8) :: UL(Ndim,Ndim,N_FL), VL(Ndim,Ndim,N_FL) - COMPLEX (KIND=8) :: DL(Ndim,N_FL) - Integer :: NTAU1, NTAU - END SUBROUTINE WRAPUL - SUBROUTINE CGR2_2(GRT0, GR00, GRTT, GR0T, U2, D2, V2, U1, D1, V1, LQ) - Use Precdef - Use MyMats - Use UDV_WRAP_mod - Implicit none - - ! Arguments - Integer, intent(in) :: LQ - Complex (Kind=double), intent(in) :: U1(LQ,LQ), V1(LQ,LQ), U2(LQ,LQ), V2(LQ,LQ) - Complex (Kind=double), intent(in) :: D2(LQ), D1(LQ) - Complex (Kind=double), intent(inout) :: GRT0(LQ,LQ), GR0T(LQ,LQ), GR00(LQ,LQ), GRTT(LQ,LQ) - end SUBROUTINE CGR2_2 - SUBROUTINE CGR2_1(GRT0, GR00, GRTT, GR0T, U2, D2, V2, U1, D1, V1, LQ, NVAR) - Use Precdef - Use MyMats - USe UDV_Wrap_mod - Implicit none - ! Arguments - Integer, intent(in) :: LQ, NVAR - Complex (Kind=double), intent(in) :: U1(LQ,LQ), V1(LQ,LQ), U2(LQ,LQ), V2(LQ,LQ) - Complex (Kind=double), intent(in) :: D2(LQ), D1(LQ) - Complex (Kind=double), intent(inout) :: GRT0(LQ,LQ), GR0T(LQ,LQ), GR00(LQ,LQ), GRTT(LQ,LQ) - end SUBROUTINE CGR2_1 - SUBROUTINE CGR2(GRT0, GR00, GRTT, GR0T, U2, D2, V2, U1, D1, V1, LQ) - - ! B2 = U2*D2*V2 - ! B1 = V1*D1*U1 - !Calc: ( 1 B1 )^-1 i.e. 2*LQ \times 2*LQ matrix - ! (-B2 1 ) - - - Use Precdef - Use UDV_WRAP_mod - Use MyMats - - Implicit none - - ! Arguments - Integer :: LQ - Complex (Kind=double), intent(in) :: U1(LQ,LQ), V1(LQ,LQ), U2(LQ,LQ), V2(LQ,LQ) - Complex (Kind=double), intent(in) :: D2(LQ), D1(LQ) - Complex (Kind=double), intent(inout) :: GRT0(LQ,LQ), GR0T(LQ,LQ), GR00(LQ,LQ), GRTT(LQ,LQ) - end SUBROUTINE CGR2 - end Interface - - Complex (Kind=double), Intent(in) :: UST(NDIM,NDIM,NSTM,N_FL), VST(NDIM,NDIM,NSTM,N_FL), DST(NDIM,NSTM,N_FL) - Complex (Kind=double), Intent(in) :: GR(NDIM,NDIM,N_FL), Phase - Integer, Intent(In) :: NSTM, NWRAP - - - ! Local - ! This could be placed as private for the module - Complex (Kind=double) :: GT0(NDIM,NDIM,N_FL), G00(NDIM,NDIM,N_FL), GTT(NDIM,NDIM,N_FL), G0T(NDIM,NDIM,N_FL) - Complex (Kind=double) :: UL(Ndim,Ndim,N_FL), DL(Ndim,N_FL), VL(Ndim,Ndim,N_FL) - Complex (Kind=double) :: UR(Ndim,Ndim,N_FL), DR(Ndim,N_FL), VR(Ndim,Ndim,N_FL) - Complex (Kind=double) :: HLP4(Ndim,Ndim), HLP5(Ndim,Ndim), HLP6(Ndim,Ndim) - - Complex (Kind=double) :: Z - Integer :: I, J, nf, NT, NT1, NTST, NST, NVAR - - !Tau = 0 - Do nf = 1, N_FL - DO J = 1,Ndim - DO I = 1,Ndim - Z = cmplx(0.d0,0.d0) - if (I == J ) Z = cone - G00(I,J,nf) = GR(I,J,nf) - GT0(I,J,nf) = GR(I,J,nf) - GTT(I,J,nf) = GR(I,J,nf) - G0T(I,J,nf) = -(Z - GR(I,J,nf)) - ENDDO - ENDDO - Enddo - NT = 0 - ! In Module Hamiltonian - CALL OBSERT(NT, GT0,G0T,G00,GTT, PHASE) - - Do nf = 1, N_FL - CALL INITD(UR(:,:,nf),cone) - CALL INITD(VR(:,:,nf),cone) - enddo - DR = cone - - - DO NT = 0,LTROT - 1 - ! Now wrapup: - NT1 = NT + 1 - CALL PROPR (GT0,NT1) - CALL PROPRM1 (G0T,NT1) - CALL PROPRM1 (GTT,NT1) - CALL PROPR (GTT,NT1) - ! In Module Hamiltonian - CALL OBSERT(NT1, GT0,G0T,G00,GTT,PHASE) - - IF ( MOD(NT1,NWRAP).EQ.0 .AND. NT1.NE.LTROT ) THEN - NTST = NT1 - NWRAP - NST = NT1/(NWRAP) - ! WRITE(6,*) 'NT1, NST: ', NT1,NST - CALL WRAPUR(NTST, NT1,UR, DR, VR) - DO nf = 1,N_FL - DO J = 1,NDIM - DO I = 1,NDIM - UL(I,J,nf) = UST(I,J,NST,nf) - VL(I,J,nf) = VST(I,J,NST,nf) - ENDDO - ENDDO - DO I = 1,NDIM - DL(I,nf) = DST(I,NST,nf) - ENDDO - Enddo - Do nf = 1,N_FL - Do J = 1,Ndim - DO I = 1,Ndim - HLP4(I,J) = GTT(I,J,nf) - HLP5(I,J) = GT0(I,J,nf) - HLP6(I,J) = G0T(I,J,nf) - Enddo - Enddo - NVAR = 1 - IF (NT1 > LTROT/2) NVAR = 2 - !DO I = 1,Ndim - ! Write(6,*) DL(I,nf)*DR(I,nf) - !enddo - !Write(6,*) 'Call CGR2' - Call CGR2_2(GT0(:,:,nf), G00(:,:,nf), GTT(:,:,nf), G0T(:,:,nf), & - & UR(:,:,nf),DR(:,nf),VR(:,:,nf), UL(:,:,nf),DL(:,nf),VL(:,:,nf),NDIM) - !Call CGR2 (GT0(:,:,nf), G00(:,:,nf), GTT(:,:,nf), G0T(:,:,nf), & - ! & UR(:,:,nf),DR(:,nf),VR(:,:,nf), UL(:,:,nf),DL(:,nf),VL(:,:,nf),NDIM) - - !Call CGR2_1(GT0(:,:,nf), G00(:,:,nf), GTT(:,:,nf), G0T(:,:,nf), & - ! & UR(:,:,nf),DR(:,nf),VR(:,:,nf), UL(:,:,nf),DL(:,nf),VL(:,:,nf),NDIM,NVAR) - - !Write(6,*) 'End Call CGR2' - !Write(6,*) ' Tau ', NT1 - !Write(6,*) ' G00 ' - Call Control_Precision_tau(GR(:,:,nf), G00(:,:,nf), Ndim) - !Write(6,*) ' GTT ' - Call Control_Precision_tau(HLP4 , GTT(:,:,nf), Ndim) - !Write(6,*) ' GT0 ' - Call Control_Precision_tau(HLP5 , GT0(:,:,nf), Ndim) - !Write(6,*) ' G0T ' - Call Control_Precision_tau(HLP6 , G0T(:,:,nf), Ndim) - Enddo - Endif - ENDDO - - END SUBROUTINE TAU_M - -!============================================================== - - SUBROUTINE PROPR(AIN,NT) - - ! Ain = B(NT-1, NT1) - ! Aout= Ain = B(NT , NT1) - - Implicit none - Complex (Kind=double), intent(INOUT) :: Ain(Ndim,Ndim,N_FL) - Integer, INTENT(IN) :: NT - - !Locals - Integer :: J,I,nf,n - Complex (Kind=double) :: HLP4(Ndim,Ndim) - Real (Kind=double) :: X - - Do nf = 1,N_FL - !CALL MMULT(HLP4,Exp_T(:,:,nf) ,Ain(:,:,nf)) - Call Hop_mod_mmthr(Ain(:,:,nf),HLP4,nf) - Do n = 1,Size(Op_V,1) - X = Phi(nsigma(n,nt),Op_V(n,nf)%type) - Call Op_mmultR(HLP4,Op_V(n,nf),X,Ndim) - ENDDO - Do J = 1,Ndim - do I = 1,Ndim - Ain(I,J,nf) = HLP4(I,J) - enddo - ENDDO - Enddo - - end SUBROUTINE PROPR -!============================================================== - SUBROUTINE PROPRM1(AIN,NT) - - !Ain = B^{-1}(NT-1, NT1) - !Aout= B^{-1}(NT , NT1) - - - Implicit none - - !Arguments - Complex (Kind=double), intent(Inout) :: AIN(Ndim, Ndim, N_FL) - Integer :: NT - - ! Locals - Integer :: J,I,nf,n - Complex (Kind=double) :: HLP4(Ndim,Ndim) - Real (Kind=double) :: X - - do nf = 1,N_FL - !Call MMULT(HLP4,Ain(:,:,nf),Exp_T_M1(:,:,nf) ) - Call Hop_mod_mmthl_m1(Ain(:,:,nf),HLP4,nf) - Do n =1,Size(Op_V,1) - X = -Phi(nsigma(n,nt),Op_V(n,nf)%type) - Call Op_mmultL(HLP4,Op_V(n,nf),X,Ndim) - Enddo - Do J = 1,Ndim - do I = 1,Ndim - Ain(I,J,nf) = HLP4(I,J) - enddo - Enddo - enddo - - END SUBROUTINE PROPRM1 -!============================================================== - end Module Tau_m_mod diff --git a/Prog_8/upgrade.f90 b/Prog_8/upgrade.f90 deleted file mode 100644 index 9553fc22a..000000000 --- a/Prog_8/upgrade.f90 +++ /dev/null @@ -1,149 +0,0 @@ - Subroutine Upgrade(GR,N_op,NT,PHASE,Op_dim) - - Use Hamiltonian - Use Random_wrap - Use Control - Use Precdef - Implicit none - - Complex (Kind=double) :: GR(Ndim,Ndim, N_FL) - Integer, INTENT(IN) :: N_op, Nt, Op_dim - Complex (Kind=double) :: Phase - - ! Local :: - Complex (Kind=double) :: Mat(Op_dim,Op_Dim), Delta(Op_dim,N_FL) - Complex (Kind=double) :: Ratio(N_FL), Ratiotot, Z1 - Integer :: ns_new, ns_old, n,m,nf, i,j - Complex (Kind= double) :: ZK, Z, D_Mat - Integer, external :: nranf - - Real (Kind = double) :: Weight - Complex (Kind = double) :: u(Ndim,Op_dim), v(Ndim,Op_dim) - Complex (Kind = double) :: x_v(Ndim,Op_dim), y_v(Ndim,Op_dim), xp_v(Ndim,Op_dim) - Complex (Kind = double) :: s_xv(Op_dim), s_yu(Op_dim) - - Logical :: Log - - - if ( sqrt(dble(OP_V(n_op,1)%g*conjg(OP_V(n_op,1)%g))) < 1.D-6 ) return - - ! Compute the ratio - nf = 1 - ns_old = nsigma(n_op,nt) - If ( Op_V(n_op,nf)%type == 1) then - ns_new = -ns_old - else - ns_new = NFLIPL(Ns_old,nranf(3)) - endif - Do nf = 1,N_FL - Z1 = Op_V(n_op,nf)%g * cmplx( Phi(ns_new,Op_V(n_op,nf)%type) - Phi(ns_old,Op_V(n_op,nf)%type), 0.d0) - Do m = 1,Op_V(n_op,nf)%N_non_zero - Z = exp( Z1* Op_V(n_op,nf)%E(m) ) - cmplx(1.d0,0.d0) - Delta(m,nf) = Z - do n = 1,Op_V(n_op,nf)%N_non_zero - ZK = cmplx(0.d0,0.d0) - If (n == m ) ZK = cmplx(1.d0,0.d0) - Mat(n , m ) = ZK + ( ZK - GR( Op_V(n_op,nf)%P(n), Op_V(n_op,nf)%P(m),nf )) * Z - Enddo - Enddo - If (Size(Mat,1) == 1 ) then - D_mat = Mat(1,1) - elseif (Size(Mat,1) == 2 ) then - D_mat = Mat(1,1)*Mat(2,2) - Mat(2,1)*Mat(1,2) - else - D_mat = Det(Mat,Size(Mat,1)) - endif - Ratio(nf) = D_Mat * exp( Z1*Op_V(n_op,nf)%alpha ) - Enddo - - Ratiotot = cmplx(1.d0,0.d0) - Do nf = 1,N_FL - Ratiotot = Ratiotot * Ratio(nf) - enddo - nf = 1 - Ratiotot = (Ratiotot**dble(N_SUN)) * cmplx(Gaml(ns_new, Op_V(n_op,nf)%type)/Gaml(ns_old, Op_V(n_op,nf)%type),0.d0) - Ratiotot = Ratiotot*cmplx(S0(n_op,nt),0.d0) - - - !Write(6,*) Ratiotot - - Weight = abs( real(Phase * Ratiotot, kind=double)/real(Phase,kind=double) ) - - Log = .false. - if ( Weight > ranf() ) Then - Log = .true. - Phase = Phase * Ratiotot/cmplx(weight,0.d0) - !Write(6,*) 'Accepted : ', Ratiotot - - Do nf = 1,N_FL - ! Setup u(i,n), v(n,i) - u = cmplx(0.d0,0.d0) - v = cmplx(0.d0,0.d0) - do n = 1,Op_V(n_op,nf)%N_non_zero - u( Op_V(n_op,nf)%P(n), n) = Delta(n,nf) - do i = 1,Ndim - v(i,n) = - GR( Op_V(n_op,nf)%P(n), i, nf ) - enddo - v(Op_V(n_op,nf)%P(n), n) = cmplx(1.d0,0.d0) - GR( Op_V(n_op,nf)%P(n), Op_V(n_op,nf)%P(n), nf) - enddo - - - x_v = cmplx(0.d0,0.d0) - y_v = cmplx(0.d0,0.d0) - i = Op_V(n_op,nf)%P(1) - x_v(i,1) = u(i,1)/(cmplx(1.d0,0.d0) + v(i,1)*u(i,1) ) - Do i = 1,Ndim - y_v(i,1) = v(i,1) - enddo - do n = 2,Op_V(n_op,nf)%N_non_zero - s_yu = cmplx(0.d0,0.d0) - s_xv = cmplx(0.d0,0.d0) - do m = 1,n-1 - do i = 1,Ndim - s_yu(m) = s_yu(m) + y_v(i,m)*u(i,n) - s_xv(m) = s_xv(m) + x_v(i,m)*v(i,n) - enddo - enddo - Do i = 1,Ndim - x_v(i,n) = u(i,n) - y_v(i,n) = v(i,n) - enddo - Z = cmplx(1.d0,0.d0) + u( Op_V(n_op,nf)%P(n), n)*v(Op_V(n_op,nf)%P(n),n) - do m = 1,n-1 - Z = Z - s_xv(m)*s_yu(m) - Do i = 1,Ndim - x_v(i,n) = x_v(i,n) - x_v(i,m)*s_yu(m) - y_v(i,n) = y_v(i,n) - y_v(i,m)*s_xv(m) - enddo - enddo - Do i = 1,Ndim - x_v(i,n) = x_v(i,n)/Z - Enddo - enddo - xp_v = cmplx(0.d0,0.d0) - do n = 1,Op_dim - do m = 1,Op_dim - j = Op_V(n_op,nf)%P(m) - do i = 1,Ndim - xp_v(i,n) = xp_v(i,n) + gr(i,j,nf)*x_v(j,n) - enddo - enddo - enddo - - do n = 1,Op_dim - do j = 1,Ndim - do i = 1,Ndim - gr(i,j,nf) = gr(i,j,nf) - xp_v(i,n)*y_v(j,n) - enddo - enddo - enddo - enddo - - ! Flip the spin - nsigma(n_op,nt) = ns_new - endif - - Call Control_upgrade(Log) - - - End Subroutine Upgrade diff --git a/Prog_8/wrapgrdo.f90 b/Prog_8/wrapgrdo.f90 deleted file mode 100644 index a7f1c933d..000000000 --- a/Prog_8/wrapgrdo.f90 +++ /dev/null @@ -1,82 +0,0 @@ - SUBROUTINE WRAPGRDO(GR,NTAU,PHASE) - - Use Hamiltonian - Use MyMats - Use Hop_mod - Implicit None - - Interface - Subroutine Upgrade(GR,N_op,NT,PHASE,Op_dim) - Use Hamiltonian - Implicit none - Complex (Kind=8) :: GR(Ndim,Ndim, N_FL) - Integer, INTENT(IN) :: N_op, Nt, Op_dim - Complex (Kind=8) :: Phase - End Subroutine Upgrade - End Interface - - ! Given GREEN at time NTAU => GREEN at time NTAU - 1, - ! Upgrade NTAU [LTROT:1] - - COMPLEX (Kind=8), INTENT(INOUT) :: GR(Ndim,Ndim,N_FL) - COMPLEX (Kind=8), INTENT(INOUT) :: PHASE - Integer :: NTAU - - ! Local - Complex (Kind=8) :: Mat_TMP(Ndim,Ndim) - Integer :: nf, N_Type, n, I,J - real (Kind=8) :: spin - - Do n = size(Op_V,1), 1, -1 - N_type = 2 - nf = 1 - spin = Phi(nsigma(n,ntau),Op_V(n,nf)%type) - do nf = 1,N_FL - Call Op_Wrapdo( Gr(:,:,nf), Op_V(n,nf), spin, Ndim, N_Type) - enddo - !Write(6,*) 'Upgrade : ', ntau,n - Call Upgrade(GR,n,ntau,PHASE,Op_V(n,1)%N_non_zero) - ! The spin has changed after the upgrade! - nf = 1 - spin = Phi(nsigma(n,ntau),Op_V(n,nf)%type) - N_type = 1 - do nf = 1,N_FL - Call Op_Wrapdo( Gr(:,:,nf), Op_V(n,nf), spin, Ndim, N_Type ) - enddo - enddo - DO nf = 1,N_FL - Call Hop_mod_mmthl (GR(:,:,nf), MAT_TMP, nf) - Call Hop_mod_mmthr_m1(MAT_TMP, GR(:,:,nf), nf) - !CALL MMULT(MAT_TMP , GR(:,:,nf) , Exp_T(:,:,nf) ) - !CALL MMULT(GR(:,:,nf), Exp_T_M1(:,:,nf), MAT_TMP ) - enddo - -!!$ ! Test -!!$ Mat_TMP = cmplx(0.d0,0.d0) -!!$ DO I = 1,Ndim -!!$ Mat_TMP(I,I) = cmplx(1.d0,0.d0) -!!$ Enddo -!!$ Do n = size(Op_V,1), 1, -1 -!!$ N_type = 2 -!!$ nf = 1 -!!$ spin = Phi(nsigma(n,ntau),Op_V(n,nf)%type) -!!$ Write(6,*) n, spin -!!$ do nf = 1,N_FL -!!$ Call Op_Wrapdo( Mat_tmp, Op_V(n,nf), spin, Ndim, N_Type) -!!$ enddo -!!$ !Upgrade -!!$ N_type = 1 -!!$ do nf = 1,N_FL -!!$ Call Op_Wrapdo( Mat_tmp, Op_V(n,nf), spin, Ndim, N_Type ) -!!$ enddo -!!$ enddo -!!$ -!!$ DO I = 1,Ndim -!!$ Do J = 1,NDIM -!!$ WRITE(6,*) I,J, Mat_tmp(I,J) -!!$ ENDDO -!!$ ENDDO -!!$ -!!$ STOP - - END SUBROUTINE WRAPGRDO diff --git a/Prog_8/wrapgrup.f90 b/Prog_8/wrapgrup.f90 deleted file mode 100644 index cb5b9f1a6..000000000 --- a/Prog_8/wrapgrup.f90 +++ /dev/null @@ -1,53 +0,0 @@ - SUBROUTINE WRAPGRUP(GR,NTAU,PHASE) - - Use Hamiltonian - Use Hop_mod - Implicit none - - Interface - Subroutine Upgrade(GR,N_op,NT,PHASE,Op_dim) - Use Hamiltonian - Implicit none - Complex (Kind=8) :: GR(Ndim,Ndim, N_FL) - Integer, INTENT(IN) :: N_op, Nt, Op_dim - Complex (Kind=8) :: Phase - End Subroutine Upgrade - End Interface - - ! Given GRUP at time NTAU => GRUP at time NTAU + 1. - ! Upgrade NTAU + 1 NTAU: [0:LTROT-1] - - ! Arguments - COMPLEX (Kind=8), INTENT(INOUT) :: GR(Ndim,Ndim,N_FL) - COMPLEX (Kind=8), INTENT(INOUT) :: PHASE - INTEGER, INTENT(IN) :: NTAU - - !Local - Integer :: nf, N_Type, NTAU1,n - Complex (Kind=8) :: Mat_TMP(Ndim,Ndim) - Real (Kind=8) :: X - - ! Wrap up, upgrade ntau1. with B^{1}(tau1) - NTAU1 = NTAU + 1 - Do nf = 1,N_FL - CALL HOP_MOD_mmthr( GR(:,:,nf), MAT_TMP,nf) - CALL HOP_MOD_mmthl_m1(MAT_TMP,GR(:,:,nf), nf ) - !CALL MMULT ( MAT_TMP, Exp_T(:,:,nf), GR(:,:,nf) ) - !CALL MMULT ( GR(:,:,nf), MAT_TMP , Exp_T_M1(:,:,nf) ) - Enddo - Do n = 1,Size(Op_V,1) - Do nf = 1, N_FL - X = Phi(nsigma(n,ntau1),Op_V(n,nf)%type) - N_type = 1 - Call Op_Wrapup(Gr(:,:,nf),Op_V(n,nf),X,Ndim,N_Type) - enddo - nf = 1 - !Write(6,*) 'Upgrade: ', ntau1,n - Call Upgrade(GR,N,ntau1,PHASE,Op_V(n,nf)%N_non_Zero) - do nf = 1,N_FL - N_type = 2 - Call Op_Wrapup(Gr(:,:,nf),Op_V(n,nf),X,Ndim,N_Type) - enddo - Enddo - - END SUBROUTINE WRAPGRUP diff --git a/Prog_8/wrapul.f90 b/Prog_8/wrapul.f90 deleted file mode 100644 index 8d93cb17c..000000000 --- a/Prog_8/wrapul.f90 +++ /dev/null @@ -1,77 +0,0 @@ - SUBROUTINE WRAPUL(NTAU1, NTAU, UL ,DL, VL) - - !Given B(LTROT,NTAU1,Nf ) = VLUP, DLUP, ULUP - !Returns B(LTROT,NTAU, Nf ) = VLUP, DLUP, ULUP - - - !NOTE: NTAU1 > NTAU. - ! Does this for all replicas - Use Hamiltonian - Use Hop_mod - Use UDV_Wrap_mod - - Implicit none - - ! Arguments - COMPLEX (KIND=8) :: UL(Ndim,Ndim,N_FL), VL(Ndim,Ndim,N_FL) - COMPLEX (KIND=8) :: DL(Ndim,N_FL) - Integer :: NTAU1, NTAU - - - ! Working space. - COMPLEX (Kind=8) :: U(Ndim,Ndim), U1(Ndim,Ndim), V1(Ndim,Ndim), TMP(Ndim,Ndim), TMP1(Ndim,Ndim) - COMPLEX (Kind=8) :: D1(Ndim), Z_ONE - Integer :: I, J, NT, NCON, nr, n, nf - Real (Kind=8) :: X - - - - NCON = 0 ! Test for UDV :::: 0: Off, 1: On. - - Z_ONE = cmplx(1.d0,0.d0) - Do nf = 1, N_FL - CALL INITD(TMP,Z_ONE) - DO NT = NTAU1, NTAU+1 , -1 - Do n = Size(Op_V,1),1,-1 - X = Phi(nsigma(n,nt),Op_V(n,nf)%type) - Call Op_mmultL(Tmp,Op_V(n,nf),X,Ndim) - enddo - !CALL MMULT( TMP1,Tmp,Exp_T(:,:,nf) ) - Call Hop_mod_mmthl (Tmp, Tmp1,nf) - Tmp = Tmp1 - ENDDO - - !Carry out U,D,V decomposition. - DO J = 1,NDim - DO I = 1,NDim - TMP1(I,J) = CONJG( TMP(J,I) ) - U (I,J) = CONJG( UL (J,I,nf) ) - ENDDO - ENDDO - CALL MMULT(TMP,TMP1,U) - DO J = 1,NDim - DO I = 1,NDim - TMP(I,J) = TMP(I,J)*DL(J,nf) - ENDDO - ENDDO - CALL UDV_WRAP(TMP,U1,D1,V1,NCON) - !CALL UDV(TMP,U1,D1,V1,NCON) - DO J = 1,NDim - DO I = 1,NDim - UL (I,J,nf) = CONJG( U1(J,I) ) - TMP(I,J) = CONJG( V1(J,I) ) - ENDDO - ENDDO - CALL MMULT(TMP1,VL(:,:,nf),TMP) - DO J = 1,NDim - DO I = 1,NDim - VL(I,J,nf) = TMP1(I,J) - ENDDO - ENDDO - DO I = 1,NDim - DL(I,nf) = D1(I) - ENDDO - ENDDO - - END SUBROUTINE WRAPUL - diff --git a/Prog_8/wrapur.f90 b/Prog_8/wrapur.f90 deleted file mode 100644 index c53b28ce3..000000000 --- a/Prog_8/wrapur.f90 +++ /dev/null @@ -1,48 +0,0 @@ - SUBROUTINE WRAPUR(NTAU, NTAU1, UR, DR, VR) - - ! Given B(NTAU, 1 ) = UR, DR, VR - ! Returns B(NTAU1, 1 ) = UR, DR, VR - ! NOTE: NTAU1 > NTAU. - - Use Hamiltonian - Use UDV_Wrap_mod - Use Hop_mod - Implicit None - - ! Arguments - COMPLEX (KIND=8) :: UR(Ndim,Ndim,N_FL), VR(Ndim,Ndim,N_FL) - COMPLEX (KIND=8) :: DR(Ndim,N_FL) - Integer :: NTAU1, NTAU - - - ! Working space. - Complex (Kind=8) :: Z_ONE - COMPLEX (Kind=8) :: V1(Ndim,Ndim), TMP(Ndim,Ndim), TMP1(Ndim,Ndim) - Integer ::NCON, NT, I, J, n, nf - Real (Kind=8) :: X - - NCON = 0 ! Test for UDV :::: 0: Off, 1: On. - Z_ONE = cmplx(1.d0,0.d0) - - Do nf = 1,N_FL - CALL INITD(TMP,Z_ONE) - DO NT = NTAU + 1, NTAU1 - !CALL MMULT(TMP1,Exp_T(:,:,nf) ,TMP) - Call Hop_mod_mmthr(TMP,TMP1,nf) - TMP = TMP1 - Do n = 1,Size(Op_V,1) - X = Phi(nsigma(n,nt),Op_V(n,nf)%type) - Call Op_mmultR(Tmp,Op_V(n,nf),X,Ndim) - ENDDO - ENDDO - CALL MMULT(TMP1,TMP,UR(:,:,nf)) - DO J = 1,NDim - DO I = 1,NDim - TMP1(I,J) = TMP1(I,J)*DR(J,nf) - TMP(I,J) = VR(I,J,nf) - ENDDO - ENDDO - CALL UDV_WRAP(TMP1,UR(:,:,nf),DR(:,nf),V1,NCON) - CALL MMULT(VR(:,:,nf),V1,TMP) - ENDDO - END SUBROUTINE WRAPUR From 7e17295334632ac7b14f8afa40be592e305ed972 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Wed, 1 Jun 2016 20:04:00 +0200 Subject: [PATCH 02/11] rearrange the source code to have a common root under src --- src/Analysis/Compile_cov | 14 + src/Analysis/Compile_en | 14 + src/Analysis/Compile_eq | 14 + src/Analysis/Makefile | 19 + src/Analysis/cov_eq.f90 | 238 +++++ src/Analysis/cov_tau.f90 | 150 +++ src/Analysis/jackv5.f90 | 98 ++ src/Modules/BIDON | 846 +++++++++++++++ src/Modules/CMakeLists.txt | 4 + src/Modules/Compile | 13 + src/Modules/Files_mod.f90 | 15 + src/Modules/Histogram.f90 | 109 ++ src/Modules/Histogram_v2.f90 | 123 +++ src/Modules/Makefile | 15 + src/Modules/Makefile_Juropa | 15 + src/Modules/Makefile_cl | 14 + src/Modules/Natural_constants.f90 | 16 + src/Modules/Random_Wrap.f90 | 99 ++ src/Modules/errors.f90 | 856 ++++++++++++++++ src/Modules/fourier.f90 | 1592 +++++++++++++++++++++++++++++ src/Modules/lattices_v3.f90 | 748 ++++++++++++++ src/Modules/log_mesh.f90 | 318 ++++++ src/Modules/machine | 1 + src/Modules/mat_mod.f90 | 1265 +++++++++++++++++++++++ src/Modules/matrix.f90 | 80 ++ src/Modules/maxent.f90 | 807 +++++++++++++++ src/Modules/maxent_stoch.G90 | 964 +++++++++++++++++ src/Modules/maxent_stoch.f90 | 748 ++++++++++++++ src/Modules/maxent_stoch_w.f90 | 836 +++++++++++++++ src/Modules/pre1 | 12 + src/Modules/precdef.mod.f90 | 23 + src/Modules/smooth_stoch.f90 | 40 + src/Modules/tmp.f90 | 735 +++++++++++++ src/MyEis/CMakeLists.txt | 8 + src/MyEis/Makefile | 11 + src/MyEis/balanc.f | 166 +++ src/MyEis/balbak.f | 75 ++ src/MyEis/cbabk2.f | 83 ++ src/MyEis/cbal.f | 181 ++++ src/MyEis/cdiv.f | 16 + src/MyEis/cg.f | 63 ++ src/MyEis/ch.f | 70 ++ src/MyEis/comp | 1 + src/MyEis/comqr.f | 222 ++++ src/MyEis/comqr2.f | 409 ++++++++ src/MyEis/corth.f | 134 +++ src/MyEis/csroot.f | 17 + src/MyEis/elmhes.f | 98 ++ src/MyEis/eltran.f | 78 ++ src/MyEis/epslon.f | 36 + src/MyEis/hqr.f | 234 +++++ src/MyEis/hqr2.f | 449 ++++++++ src/MyEis/htribk.f | 91 ++ src/MyEis/htridi.f | 154 +++ src/MyEis/pythag.f | 20 + src/MyEis/rg.f | 70 ++ src/MyEis/rs.f | 57 ++ src/MyEis/tql2.f | 170 +++ src/MyEis/tqlrat.f | 130 +++ src/MyEis/tred1.f | 135 +++ src/MyEis/tred2.f | 164 +++ src/MyLin/CMakeLists.txt | 12 + src/MyLin/Makefile | 8 + src/MyLin/bidon | 6 + src/MyLin/cgedi.f | 131 +++ src/MyLin/cgefa.f | 107 ++ src/MyLin/dgedi.f | 128 +++ src/MyLin/dgefa.f | 103 ++ src/MyLin/work.pc | Bin 0 -> 1016 bytes src/MyLin/work.pcl | 1 + src/MyLin/zgedi.f | 135 +++ src/MyLin/zgefa.f | 111 ++ src/MyLin/zqrdc.f | 218 ++++ src/MyLin/zqrsl.f | 280 +++++ src/MyNag/CMakeLists.txt | 26 + src/MyNag/F01QCF.f | 258 +++++ src/MyNag/F01QDF.f | 290 ++++++ src/MyNag/F01QEF.f | 259 +++++ src/MyNag/F01RCF.f | 282 +++++ src/MyNag/F01REF.f | 283 +++++ src/MyNag/F06AAZ.f | 61 ++ src/MyNag/F06FBF.f | 44 + src/MyNag/F06FJF.f | 62 ++ src/MyNag/F06FRF.f | 139 +++ src/MyNag/F06FRF.f~ | 139 +++ src/MyNag/F06HBF.f | 44 + src/MyNag/F06HRF.f | 164 +++ src/MyNag/F06KJF.f | 74 ++ src/MyNag/F06QHF.f | 77 ++ src/MyNag/F06THF.f | 77 ++ src/MyNag/Makefile | 11 + src/MyNag/P01ABF.f | 82 ++ src/MyNag/P01ABW.f | 54 + src/MyNag/P01ABY.f | 50 + src/MyNag/P01ABZ.f | 15 + src/MyNag/P01ACF.f | 96 ++ src/MyNag/X02AJF.f | 13 + src/MyNag/X04AAF.f | 23 + src/MyNag/X04BAF.f | 30 + src/MyNag/comp | 1 + src/MyNag/work.pc | Bin 0 -> 2673 bytes src/MyNag/work.pcl | 1 + src/Prog/CMakeLists.txt | 68 ++ src/Prog/Hamiltonian_Hub.F90 | 539 ++++++++++ src/Prog/Hamiltonian_Ising.F90 | 579 +++++++++++ src/Prog/Hamiltonian_SPT.F90 | 548 ++++++++++ src/Prog/Hop_mod.f90 | 217 ++++ src/Prog/Makefile | 27 + src/Prog/Operator.f90 | 459 +++++++++ src/Prog/UDV_WRAP.F90 | 135 +++ src/Prog/cgr1.f90 | 110 ++ src/Prog/cgr2.f90 | 122 +++ src/Prog/cgr2_1.f90 | 539 ++++++++++ src/Prog/cgr2_2.f90 | 176 ++++ src/Prog/control_mod.F90 | 142 +++ src/Prog/gperp.F90 | 98 ++ src/Prog/inconfc.F90 | 126 +++ src/Prog/machine | 1 + src/Prog/main.F90 | 449 ++++++++ src/Prog/nranf.f90 | 12 + src/Prog/outconfc.F90 | 57 ++ src/Prog/print_bin_mod.F90 | 300 ++++++ src/Prog/tau_m.f90 | 236 +++++ src/Prog/upgrade.f90 | 149 +++ src/Prog/wrapgrdo.f90 | 82 ++ src/Prog/wrapgrup.f90 | 53 + src/Prog/wrapul.f90 | 77 ++ src/Prog/wrapur.f90 | 48 + 128 files changed, 23427 insertions(+) create mode 100644 src/Analysis/Compile_cov create mode 100644 src/Analysis/Compile_en create mode 100644 src/Analysis/Compile_eq create mode 100644 src/Analysis/Makefile create mode 100644 src/Analysis/cov_eq.f90 create mode 100644 src/Analysis/cov_tau.f90 create mode 100644 src/Analysis/jackv5.f90 create mode 100644 src/Modules/BIDON create mode 100644 src/Modules/CMakeLists.txt create mode 100644 src/Modules/Compile create mode 100644 src/Modules/Files_mod.f90 create mode 100644 src/Modules/Histogram.f90 create mode 100644 src/Modules/Histogram_v2.f90 create mode 100644 src/Modules/Makefile create mode 100644 src/Modules/Makefile_Juropa create mode 100644 src/Modules/Makefile_cl create mode 100644 src/Modules/Natural_constants.f90 create mode 100644 src/Modules/Random_Wrap.f90 create mode 100644 src/Modules/errors.f90 create mode 100644 src/Modules/fourier.f90 create mode 100644 src/Modules/lattices_v3.f90 create mode 100644 src/Modules/log_mesh.f90 create mode 100644 src/Modules/machine create mode 100644 src/Modules/mat_mod.f90 create mode 100644 src/Modules/matrix.f90 create mode 100644 src/Modules/maxent.f90 create mode 100644 src/Modules/maxent_stoch.G90 create mode 100644 src/Modules/maxent_stoch.f90 create mode 100644 src/Modules/maxent_stoch_w.f90 create mode 100644 src/Modules/pre1 create mode 100644 src/Modules/precdef.mod.f90 create mode 100644 src/Modules/smooth_stoch.f90 create mode 100644 src/Modules/tmp.f90 create mode 100644 src/MyEis/CMakeLists.txt create mode 100644 src/MyEis/Makefile create mode 100644 src/MyEis/balanc.f create mode 100644 src/MyEis/balbak.f create mode 100644 src/MyEis/cbabk2.f create mode 100644 src/MyEis/cbal.f create mode 100644 src/MyEis/cdiv.f create mode 100644 src/MyEis/cg.f create mode 100644 src/MyEis/ch.f create mode 100644 src/MyEis/comp create mode 100644 src/MyEis/comqr.f create mode 100644 src/MyEis/comqr2.f create mode 100644 src/MyEis/corth.f create mode 100644 src/MyEis/csroot.f create mode 100644 src/MyEis/elmhes.f create mode 100644 src/MyEis/eltran.f create mode 100644 src/MyEis/epslon.f create mode 100644 src/MyEis/hqr.f create mode 100644 src/MyEis/hqr2.f create mode 100644 src/MyEis/htribk.f create mode 100644 src/MyEis/htridi.f create mode 100644 src/MyEis/pythag.f create mode 100644 src/MyEis/rg.f create mode 100644 src/MyEis/rs.f create mode 100644 src/MyEis/tql2.f create mode 100644 src/MyEis/tqlrat.f create mode 100644 src/MyEis/tred1.f create mode 100644 src/MyEis/tred2.f create mode 100644 src/MyLin/CMakeLists.txt create mode 100644 src/MyLin/Makefile create mode 100644 src/MyLin/bidon create mode 100644 src/MyLin/cgedi.f create mode 100644 src/MyLin/cgefa.f create mode 100644 src/MyLin/dgedi.f create mode 100644 src/MyLin/dgefa.f create mode 100644 src/MyLin/work.pc create mode 100644 src/MyLin/work.pcl create mode 100644 src/MyLin/zgedi.f create mode 100644 src/MyLin/zgefa.f create mode 100644 src/MyLin/zqrdc.f create mode 100644 src/MyLin/zqrsl.f create mode 100644 src/MyNag/CMakeLists.txt create mode 100644 src/MyNag/F01QCF.f create mode 100644 src/MyNag/F01QDF.f create mode 100644 src/MyNag/F01QEF.f create mode 100644 src/MyNag/F01RCF.f create mode 100644 src/MyNag/F01REF.f create mode 100644 src/MyNag/F06AAZ.f create mode 100644 src/MyNag/F06FBF.f create mode 100644 src/MyNag/F06FJF.f create mode 100644 src/MyNag/F06FRF.f create mode 100644 src/MyNag/F06FRF.f~ create mode 100644 src/MyNag/F06HBF.f create mode 100644 src/MyNag/F06HRF.f create mode 100644 src/MyNag/F06KJF.f create mode 100644 src/MyNag/F06QHF.f create mode 100644 src/MyNag/F06THF.f create mode 100644 src/MyNag/Makefile create mode 100644 src/MyNag/P01ABF.f create mode 100644 src/MyNag/P01ABW.f create mode 100644 src/MyNag/P01ABY.f create mode 100644 src/MyNag/P01ABZ.f create mode 100644 src/MyNag/P01ACF.f create mode 100644 src/MyNag/X02AJF.f create mode 100644 src/MyNag/X04AAF.f create mode 100644 src/MyNag/X04BAF.f create mode 100644 src/MyNag/comp create mode 100644 src/MyNag/work.pc create mode 100644 src/MyNag/work.pcl create mode 100644 src/Prog/CMakeLists.txt create mode 100644 src/Prog/Hamiltonian_Hub.F90 create mode 100644 src/Prog/Hamiltonian_Ising.F90 create mode 100644 src/Prog/Hamiltonian_SPT.F90 create mode 100644 src/Prog/Hop_mod.f90 create mode 100644 src/Prog/Makefile create mode 100644 src/Prog/Operator.f90 create mode 100644 src/Prog/UDV_WRAP.F90 create mode 100644 src/Prog/cgr1.f90 create mode 100644 src/Prog/cgr2.f90 create mode 100644 src/Prog/cgr2_1.f90 create mode 100644 src/Prog/cgr2_2.f90 create mode 100644 src/Prog/control_mod.F90 create mode 100644 src/Prog/gperp.F90 create mode 100644 src/Prog/inconfc.F90 create mode 100644 src/Prog/machine create mode 100644 src/Prog/main.F90 create mode 100644 src/Prog/nranf.f90 create mode 100644 src/Prog/outconfc.F90 create mode 100644 src/Prog/print_bin_mod.F90 create mode 100644 src/Prog/tau_m.f90 create mode 100644 src/Prog/upgrade.f90 create mode 100644 src/Prog/wrapgrdo.f90 create mode 100644 src/Prog/wrapgrup.f90 create mode 100644 src/Prog/wrapul.f90 create mode 100644 src/Prog/wrapur.f90 diff --git a/src/Analysis/Compile_cov b/src/Analysis/Compile_cov new file mode 100644 index 000000000..d3643a78f --- /dev/null +++ b/src/Analysis/Compile_cov @@ -0,0 +1,14 @@ +TARGET= cov_tau.out +OBJS= cov_tau.o + + +.SUFFIXES: .f90 .f +.f.o .f90.o: + $(FC) -c -cpp -o $@ $(FLAGS) $< + +$(TARGET): $(OBJS) + $(FC) $(LF) -o $(TARGET) $(OBJS) $(LIBS) + +clean: + rm $(OBJS) + diff --git a/src/Analysis/Compile_en b/src/Analysis/Compile_en new file mode 100644 index 000000000..8767339d4 --- /dev/null +++ b/src/Analysis/Compile_en @@ -0,0 +1,14 @@ +TARGET= jackv5.out +OBJS= jackv5.o + + +.SUFFIXES: .f90 .f +.f.o .f90.o: + $(FC) -c -cpp -o $@ $(FLAGS) $< + +$(TARGET): $(OBJS) + $(FC) $(LF) -o $(TARGET) $(OBJS) $(LIBS) + +clean: + rm $(OBJS) + diff --git a/src/Analysis/Compile_eq b/src/Analysis/Compile_eq new file mode 100644 index 000000000..9613a2271 --- /dev/null +++ b/src/Analysis/Compile_eq @@ -0,0 +1,14 @@ +TARGET= cov_eq.out +OBJS= cov_eq.o + + +.SUFFIXES: .f90 .f +.f.o .f90.o: + $(FC) -c -cpp -o $@ $(FLAGS) $< + +$(TARGET): $(OBJS) + $(FC) $(LF) -o $(TARGET) $(OBJS) $(LIBS) + +clean: + rm $(OBJS) + diff --git a/src/Analysis/Makefile b/src/Analysis/Makefile new file mode 100644 index 000000000..c92c401c8 --- /dev/null +++ b/src/Analysis/Makefile @@ -0,0 +1,19 @@ +FC= $(mpif90) +FC= $(f90) +FLAGS= $(FL) +LIBS= $(Libs)/Modules/modules_90.a \ + $(Libs)/MyEis/libeis.a \ + $(Libs)/MyNag/libnag.a \ + $(Libs)/MyLin/liblin.a \ + $(LIB_BLAS_LAPACK) + +all: + cp $(Libs)/Modules/*.mod . ;\ + (make -f Compile_en FC="$(FC)" FLAGS="$(FLAGS)" LIBS="$(LIBS)" ) ;\ + (make -f Compile_cov FC="$(FC)" FLAGS="$(FLAGS)" LIBS="$(LIBS)" ) ;\ + (make -f Compile_eq FC="$(FC)" FLAGS="$(FLAGS)" LIBS="$(LIBS)" ) +clean: + (make -f Compile_eq clean );\ + (make -f Compile_cov clean );\ + (make -f Compile_en clean );\ + rm *.mod *~ \#* *.out diff --git a/src/Analysis/cov_eq.f90 b/src/Analysis/cov_eq.f90 new file mode 100644 index 000000000..3c3b1d2b8 --- /dev/null +++ b/src/Analysis/cov_eq.f90 @@ -0,0 +1,238 @@ + Program Cov_eq + + Use Errors + Use MyMats + Use Matrix + Use Lattices_v3 + ! This version of the analysis program requires the information of the lattice, for fourier transforms + ! and for rotations. + + Implicit none + + + + Interface + Integer function Rot90(n, Xk_p, Ndim) + Implicit none + Integer, INTENT(IN) :: Ndim,n + Real (Kind=8), INTENT(IN) :: Xk_p(2,Ndim) + end function Rot90 + end Interface + + Integer :: Ndim, Norb, nr, nx, ny,nk, ierr + Integer :: no, no1, n, n1,m, nbins, n_skip, nb, N_rebin + real (Kind=8):: X, Y + Real (Kind=8), allocatable :: Phase(:) + Type (Mat_C), allocatable :: Bins(:,:), Bins_R(:,:) + Complex (Kind=8), allocatable :: Bins0(:,:) + Complex (Kind=8) :: Z, Xmean,Xerr, Xmean_r,Xerr_r + Real (Kind=8) :: Xk_p(2), XR_p(2) , XR1_p(2) + Complex (Kind=8), allocatable :: V_help(:), V_help_R(:) + Real (Kind=8) :: Pi, a1_p(2), a2_p(2), L1_p(2), L2_p(2), del_p(2) + + Integer :: L1, L2, I + Character (len=64) :: Model, Lattice_type + Type (Lattice) :: Latt + + NAMELIST /VAR_lattice/ L1, L2, Lattice_type, Model + + + OPEN(UNIT=5,FILE='parameters',STATUS='old',ACTION='read',IOSTAT=ierr) + IF (ierr /= 0) THEN + WRITE(*,*) 'unable to open ',ierr + STOP + END IF + READ(5,NML=VAR_lattice) + CLOSE(5) + + If ( Lattice_type =="Square" ) then + a1_p(1) = 1.0 ; a1_p(2) = 0.d0 + a2_p(1) = 0.0 ; a2_p(2) = 1.d0 + L1_p = dble(L1)*a1_p + L2_p = dble(L2)*a2_p + Call Make_Lattice( L1_p, L2_p, a1_p, a2_p, Latt ) + elseif ( Lattice_type=="Honeycomb" ) then + a1_p(1) = 1.0 ; a1_p(2) = 0.d0 + a2_p(1) = 0.5 ; a2_p(2) = sqrt(3.0)/2.0 + del_p = (a2_p - 0.5*a1_p ) * 2.0/3.0 + L1_p = dble(L1) * a1_p + L2_p = dble(L2) * a2_p + Call Make_Lattice( L1_p, L2_p, a1_p, a2_p, Latt ) + Open (Unit=10,File="Lattice", status="unknown") + do I = 1,Latt%N + Xr_p = dble(Latt%list (I,1))*Latt%a1_p + dble(Latt%list (I,2))*Latt%a2_p + Do n = 1,3 + if (n==1) Xr1_p = Xr_p - del_p + if (n==2) Xr1_p = Xr_p - del_p - a1_p + a2_p + if (n==3) Xr1_p = Xr_p + a2_p - del_p + Write(10,"(F14.7,2x,F14.7)") Xr_p (1), Xr_p (2) + Write(10,"(F14.7,2x,F14.7)") Xr1_p(1), Xr1_p(2) + Write(10,*) + enddo + enddo + close(10) + else + Write(6,*) "Lattice not yet implemented!" + Stop + endif + + ! Determine the number of bins. + Pi = acos(-1.d0) + Open ( Unit=10, File="ineq", status="unknown" ) + nbins = 0 + do + Read(10,*,End=10) X,Norb,Ndim + do n = 1,Norb + Read(10,*) Z + enddo + do n = 1,Ndim + Read(10,*) X,Y + do no = 1,Norb + do no1 = 1,Norb + read(10,*) Z + enddo + enddo + enddo + nbins = nbins + 1 + enddo +10 continue + Close(10) + Write(6,*) "# of bins: ", Nbins + n_skip = 1 + nbins = Nbins - n_skip + Write(6,*) "Effective # of bins: ", Nbins + + + ! Allocate space + Allocate ( bins(Ndim,Nbins), bins_r(Ndim,Nbins), Phase(Nbins), V_help(Nbins), V_help_R(Nbins), Bins0(Nbins,Norb)) + Do n = 1,Ndim + do nb = 1,nbins + Call Make_Mat(bins (n,nb),Norb) + Call Make_Mat(bins_r(n,nb),Norb) + bins_r(n,nb)%el = 0.d0 + Enddo + Enddo + Open ( Unit=10, File="ineq", status="unknown" ) + do nb = 1, nbins + n_skip + if (nb > n_skip ) then + Read(10,*,End=10) Phase(nb-n_skip),no,no1 + Do no = 1,Norb + Read(10,*) Bins0(nb-n_skip,no) + enddo + do n = 1,Ndim + Read(10,*) Xk_p(1), Xk_p(2) + m = Inv_K(Xk_p,Latt) + !Write(6,*) m + do no = 1,norb + do no1 = 1,Norb + read(10,*) bins(m,nb-n_skip)%el(no,no1) + enddo + enddo + if ( sqrt(Xk_p(1)**2 + Xk_p(2)**2) < 1.D-6 ) then + do no = 1,norb + do no1 = 1,Norb + bins(m,nb-n_skip)%el(no,no1) = bins(m,nb-n_skip)%el(no,no1) - & + & cmplx(dble(Latt%N),0.d0)*Bins0(nb-n_skip,no)*Bins0(nb-n_skip,no1) + enddo + enddo + endif + enddo + else + Read(10,*,End=10) X,no,no1 + Do no = 1,Norb + Read(10,*) Z + enddo + do n = 1,Ndim + Read(10,*) X,Y + do no = 1,Norb + do no1 = 1,Norb + read(10,*) Z + enddo + enddo + enddo + endif + enddo + close(10) + + + Call Fourier_K_to_R(bins,bins_r,Latt) + + ! Setup symmetries for C4v lattice +#ifdef test + do n = 1,Ndim + n1 = n + Write(6,*) Xk_p(1,n1), Xk_p(2,n1) + do m = 1,4 + n1 = Rot90(n1, Xk_p, Ndim) + Write(6,*) n1, Xk_p(1,n1), Xk_p(2,n1) + enddo + Write(6,*) + enddo +#endif + Open (Unit=33,File="equalJ" ,status="unknown") + N_rebin = 1 + Do n1 = 1,Ndim + n = n1 + do m = 1,1 + V_help = 0.d0 + !n = Rot90(n, Xk_p, Ndim) + do nb = 1,Nbins + do no = 1,Norb + V_help (nb) = V_help (nb) + bins(n,nb)%el(no,no) + enddo + enddo + V_help = V_help/dble(Norb) + call ERRCALCJ(V_help, XMean, XERR, N_rebin ) + Xk_p = dble(Latt%listk(n1,1))*Latt%b1_p + dble(Latt%listk(n1,2))*Latt%b2_p + Write(33,"(F12.6,2x,F12.6,2x,F12.6,2x,F12.6)") & + & Xk_p(1), Xk_p(2), dble(Xmean ), dble(Xerr ) + enddo + enddo + If (Norb > 1 ) then + !Compute susecptibility + Xk_p = 0.d0 + n = Inv_K(Xk_p,Latt) + V_help = 0.d0 + do nb = 1,Nbins + do no = 1,Norb + Do no1 = 1,Norb + V_help (nb) = V_help (nb) + bins(n,nb)%el(no,no1) + enddo + enddo + enddo + call ERRCALCJ(V_help, XMean, XERR, N_rebin ) + Write(33,"('# Suscpetibility: ', F12.6,2x,F12.6)") dble(Xmean ), dble(Xerr ) + endif + Close(33) + + + + end Program Cov_eq + + Integer function Rot90(n, Xk_p, Ndim) + + Implicit none + Integer, INTENT(IN) :: Ndim,n + Real (Kind=8), INTENT(IN) :: Xk_p(2,Ndim) + + !Local + real (Kind=8) :: X1_p(2), Zero, pi, X + Integer :: m + + Zero = 1.D-4 + pi = acos(-1.d0) + X1_p(1) = Xk_p(2,n) + X1_p(2) = -Xk_p(1,n) + if (X1_p(1) < -pi + Zero ) X1_p(1) = X1_p(1) + 2.0*pi + if (X1_p(2) < -pi + Zero ) X1_p(2) = X1_p(2) + 2.0*pi + + Rot90 = 0 + Do m = 1,Ndim + X = sqrt( (X1_p(1) -Xk_p(1,m))**2 + (X1_p(2) -Xk_p(2,m))**2 ) + If ( X < Zero) then + Rot90 = m + exit + endif + Enddo + + end function Rot90 diff --git a/src/Analysis/cov_tau.f90 b/src/Analysis/cov_tau.f90 new file mode 100644 index 000000000..d02f27bed --- /dev/null +++ b/src/Analysis/cov_tau.f90 @@ -0,0 +1,150 @@ + Program Cov_tau + + Use Errors + Use MyMats + Use Matrix + Use Precdef + + Implicit none + + Interface + Integer function Rot90(n, Xk_p, Ndim) + Implicit none + Integer, INTENT(IN) :: Ndim,n + Real (Kind=8), INTENT(IN) :: Xk_p(2,Ndim) + end function Rot90 + end Interface + + Integer :: Ndim, Norb + Integer :: no, no1, n, nbins, n_skip, nb, N_rebin, nT, Lt,m,n1 + real (Kind=8):: X, Y, dtau + real (Kind=8), allocatable :: Xmean(:), Xcov(:,:) + Complex (Kind=8) :: Z + Real (Kind=8) :: Zero=1.D-8 + Real (Kind=8), allocatable :: Phase(:) + Real (Kind=8), allocatable :: Bins(:,:,:) + Real (Kind=8), allocatable :: Xk_p(:,:) + Real (Kind=8), allocatable :: V_help(:,:) + Character (len=64) :: File_out + + + ! Determine the number of bins. + Open ( Unit=10, File="intau", status="unknown" ) + nbins = 0 + do + Read(10,*,End=10) X,Norb,Ndim, LT, dtau + do n = 1,Ndim + Read(10,*) X,Y + do nt = 1,LT + do no = 1,Norb + do no1 = 1,Norb + read(10,*) Z + enddo + enddo + enddo + enddo + Write(6,*) nbins + nbins = nbins + 1 + enddo +10 continue + Close(10) + Write(6,*) "# of bins: ", Nbins + n_skip = 1 + nbins = Nbins - n_skip + Write(6,*) "Effective # of bins: ", Nbins + + + + + ! Allocate space + Allocate ( bins(Ndim,Lt,Nbins), Phase(Nbins), Xk_p(2,ndim), V_help(lt,Nbins)) + Allocate (Xmean(Lt), Xcov(Lt,Lt)) + bins = 0.d0 + Open ( Unit=10, File="intau", status="unknown" ) + do nb = 1, nbins + n_skip + if (nb > n_skip ) then + Read(10,*,End=10) Phase(nb-n_skip),no,no1,n, X + do n = 1,Ndim + Read(10,*) Xk_p(1,n), Xk_p(2,n) + do nt = 1,Lt + do no = 1,norb + do no1 = 1,Norb + read(10,*) Z + if (no == no1) bins(n,nt,nb-n_skip) = bins(n,nt,nb-n_skip) + real(Z,Kind=8) + enddo + enddo + enddo + enddo + else + Read(10,*,End=10) X,no,no1,n,Y + do n = 1,Ndim + Read(10,*) X,Y + do nt = 1,LT + do no = 1,Norb + do no1 = 1,Norb + read(10,*) Z + enddo + enddo + enddo + enddo + endif + enddo + close(10) + + + do n = 1,Nbins + Write(6,*) Phase(n) + Enddo + do n = 1,Ndim + V_help = 0.d0 + n1 = n + if ( Xk_p(1,n) >= -zero .and. XK_p(2,n) >= -zero ) then + do m = 1,4 + n1 = Rot90(n1, Xk_p, Ndim) + do nt = 1,LT + do nb = 1,nbins + V_help(nt,nb) = V_help(nt,nb) + bins (n1,nt,nb) + enddo + enddo + enddo + V_help = V_help/4.d0 + call COV(V_help, phase, Xcov, Xmean ) + write(File_out,'("g_",F4.2,"_"F4.2)') Xk_p(1,n), Xk_p(2,n) + Open (Unit=10,File=File_out,status="unknown") + do nt = 1, LT + Write(10,"(F14.7,2x,F16.8,2x,F16.8)") & + & dble(nt-1)*dtau, Xmean(nt), sqrt(abs(dble(Xcov(nt,nt)))) + enddo + close(10) + endif + enddo + + end Program Cov_tau + + Integer function Rot90(n, Xk_p, Ndim) + + Implicit none + Integer, INTENT(IN) :: Ndim,n + Real (Kind=8), INTENT(IN) :: Xk_p(2,Ndim) + + !Local + real (Kind=8) :: X1_p(2), Zero, pi, X + Integer :: m + + Zero = 1.D-4 + pi = acos(-1.d0) + X1_p(1) = Xk_p(2,n) + X1_p(2) = -Xk_p(1,n) + if (X1_p(1) < -pi + Zero ) X1_p(1) = X1_p(1) + 2.0*pi + if (X1_p(2) < -pi + Zero ) X1_p(2) = X1_p(2) + 2.0*pi + + Rot90 = 0 + Do m = 1,Ndim + X = sqrt( (X1_p(1) -Xk_p(1,m))**2 + (X1_p(2) -Xk_p(2,m))**2 ) + If ( X < Zero) then + Rot90 = m + exit + endif + Enddo + + end function Rot90 diff --git a/src/Analysis/jackv5.f90 b/src/Analysis/jackv5.f90 new file mode 100644 index 000000000..4f97e5abb --- /dev/null +++ b/src/Analysis/jackv5.f90 @@ -0,0 +1,98 @@ + Program enerJ + + + Use ERRORS + Implicit none + + REAL (KIND=8), DIMENSION(:,:), ALLOCATABLE :: OBS + REAL (KIND=8), DIMENSION(:), ALLOCATABLE :: EN, SIGN + REAL (KIND=8) :: XM, XERR + + Complex (Kind=8) Z1,Z2,Z3,Z4,Z5 + Integer :: NST, NS, NS1, NS2, NSTEP, NC, NP, NOBS, Nbins, NP_EFF, ISEED, I, IOBS + Integer :: N, NBIN + + ! Count the number of bins + Open (Unit=10, File="ener", status="unknown") + !Open (Unit=12, File="ener_hist", status="unknown") + nbins = 0 + do + read(10,*,End=10) Z1, Z2, Z3, Z4, Z5 + nbins = nbins + 1 + enddo +10 continue + Write(6,*) "# of bins: ", Nbins + Close(10) + !Close(12) + + NP = NBINS + NOBS = 5 + + ALLOCATE(OBS(NP,NOBS)) + ! Error on energy + + !Open (Unit=25, File="statdat1", status="unknown") + !read(25,*) NST, NS1, NS2, NSTEP + !Close(25) + NST = 1; NS1 = 1; NS2 = 2; NSTEP = 1 + !If ( L == 15 ) NST = 10 + !If ( L == 12 ) NST = 8 + !If ( L == 9 ) NST = 3 + !If ( L == 6 ) NST = 2 + !If ( L == 3 ) NST = 2 + OPEN (UNIT=20, FILE='ener', STATUS='old') + NC = 0 + DO N = 1,NP + IF (N.GE.NST) THEN + NC = NC + 1 + READ(20,*) Z1,Z2,Z3, Z4, Z5 + OBS(NC,1) = dble(Z1) + OBS(NC,2) = dble(Z2) + OBS(NC,3) = dble(Z3) + OBS(NC,4) = dble(Z4) + OBS(NC,5) = dble(Z5) + ELSE + READ(20,*) Z1,Z2,Z3, Z4, Z5 + ENDIF + ENDDO + CLOSE(20) +2100 FORMAT(I6,2X,F16.8) + + OPEN (UNIT=21, FILE='enerJ', STATUS='unknown') + WRITE(21,*) 'Effective number of bins, and bins: ', NC, NP + NP_EFF = NC + ALLOCATE (EN(NP_EFF), SIGN(NP_EFF)) + DO IOBS = 1,NOBS + WRITE(21,*) + DO I = 1,NP_EFF + EN (I) = OBS(I,IOBS) + SIGN(I) = OBS(I,NOBS) + ENDDO + IF (IOBS.EQ.1) WRITE(21,*) ' rho ' + IF (IOBS.EQ.2) WRITE(21,*) ' kin ' + IF (IOBS.EQ.3) WRITE(21,*) ' double ' + IF (IOBS.EQ.4) WRITE(21,*) ' Energy ' + IF (IOBS.EQ.5) WRITE(21,*) ' phase ' + DO NBIN = NS1, NS2, NSTEP + if (NBIN.gt.0) then + IF (IOBS.EQ.NOBS .or. Iobs.eq.1 ) then + CALL ERRCALCJ(EN,XM,XERR,NBIN) + else + CALL ERRCALCJ(EN,SIGN,XM,XERR,NBIN) + endif + WRITE(21,2001) IOBS, XM, XERR + ! Test + ! NBOOT = 40 + ! CALL BOOTSTRAP( EN,XM_BS,XERR_BS,NBOOT,ISEED) + ! WRITE(21,2001) IOBS, XM_BS, XERR_BS + ! IF (IOBS == 4) Write(22,"(F14.7,2x,F14.7)") XM/dble(L*L), XERR/dble(L*L) + endif + ENDDO + ENDDO + CLOSE(21) +2001 FORMAT('OBS : ', I4,4x,F12.6,2X, F12.6) + + DEALLOCATE (EN,SIGN,OBS) + + END Program enerJ + diff --git a/src/Modules/BIDON b/src/Modules/BIDON new file mode 100644 index 000000000..4a69cf8be --- /dev/null +++ b/src/Modules/BIDON @@ -0,0 +1,846 @@ +0a1,6 +> +> +> +> +> +> +1a8,9 +> +> +3,9c11,20 +< Use Files_mod +< Integer, private :: NTAU, nt, Ngamma, ng, Ndis, nd, Iseed +< Real (Kind=8), private :: Delta, Delta2, OM_st_1, Om_en_1, DeltaXMAX, Beta, Pi, Dom +< Real (Kind=8), allocatable, private :: XQMC1(:) +< ! You can still optimize a bit for by redefining the Kernel table to: +< ! xker_table(nt,nw) -> xker_table(nt,nw) / sigma(nt) +< ! This will save quite a lot of divisions in the +--- +> Use Files_mod +> +> +> Integer, private :: NTAU, nt, Ngamma, ng, Ndis, nd, Iseed +> Real (Kind=8), private :: Delta, Delta2, OM_st_1, Om_en_1, DeltaXMAX, Beta, Pi, Dom +> Real (Kind=8), allocatable, private :: XQMC1(:) +> +> ! You can still optimize a bit for by redefining the Kernel table to: +> ! xker_table(nt,nw) -> xker_table(nt,nw) / sigma(nt) +> ! This will save quite a lot of divisions in the +10a22 +> +11a24 +> +13c26,27 +< & Ngamma_1, OM_ST, OM_EN, Ndis_1, Nsweeps, NBins, NWarm, L_cov ) +--- +> & Ngamma_1, OM_ST, OM_EN, Ndis_1, Nsweeps, NBins, NWarm, L_cov ) +> +15c29,34 +< Real (Kind=8), Dimension(:) :: XQMC, Xtau, Alpha_tot +--- +> +> +> +> +> +> Real (Kind=8), Dimension(:) :: XQMC, Xtau, Alpha_tot +17c36 +< Real (Kind=8), External :: XKER, Back_trans_Aom +--- +> Real (Kind=8), External :: XKER, Back_trans_Aom +19,23c38,43 +< Integer :: Nsweeps, NBins, Ngamma_1, Ndis_1, nw, nt1 +< Integer, optional :: L_cov +< ! Local +< Integer lp, NSims, ns, nb, nc, Nwarm, nalp1, nalp2, Nex, p_star, Ndis_table, & +< & io_error, io_error1, i +--- +> Integer :: Nsweeps, NBins, Ngamma_1, Ndis_1, nw, nt1 +> Integer, optional :: L_cov +> +> ! Local +> Integer lp, NSims, ns, nb, nc, Nwarm, nalp1, nalp2, Nex, p_star, Ndis_table, & +> & io_error, io_error1, i +25c45 +< & Xn_tot(:,:,:), En_tot(:) +--- +> & Xn_tot(:,:,:), En_tot(:) +27,29c47,49 +< Real (Kind=8) :: Ranf, En_M, Res, X, Alpha, Acc_1, Acc_2, En, DeltaE, Ratio, D +< Real (Kind=8) :: Aom, om, XMAX, tau +< Real (Kind=8) :: CPUT, CPUTM +--- +> Real (Kind=8) :: Ranf, En_M, Res, X, Alpha, Acc_1, Acc_2, En, DeltaE, Ratio, D +> Real (Kind=8) :: Aom, om, XMAX, tau +> Real (Kind=8) :: CPUT, CPUTM +32c52,62 +< Real (Kind=8), allocatable :: Xker_table(:,:), U(:,:), sigma(:) +--- +> Real (Kind=8), allocatable :: Xker_table(:,:), U(:,:), sigma(:) +> +> +> +> +> +> +> +> +> +> +34c64 +< NDis = Ndis_1 +--- +> NDis = Ndis_1 +36,41c66,72 +< delta = 0.001 +< delta2 = delta*delta +< Ngamma = Ngamma_1 +< Beta = Beta_1 ! Physical temperature for calculation of the kernel. +< Ntau = Size(xqmc,1) +< NSims = Size(Alpha_tot,1) +--- +> delta = 0.001 +> delta2 = delta*delta +> Ngamma = Ngamma_1 +> Beta = Beta_1 ! Physical temperature for calculation of the kernel. +> +> Ntau = Size(xqmc,1) +> NSims = Size(Alpha_tot,1) +43c74 +< Allocate (En_m_tot(NSims), En_e_tot(NSims), En_tot(NSims) ) +--- +> Allocate (En_m_tot(NSims), En_e_tot(NSims), En_tot(NSims) ) +44a76 +> +46a79 +> +48,49c81,83 +< ! Setup table for the Kernel +< Ndis_table = 50000 +--- +> +> ! Setup table for the Kernel +> Ndis_table = 50000 +59,61c93,95 +< ! Normalize data to have zeroth moment of unity. +< xqmc = xqmc / XMOM1 +< cov = cov / ((XMOM1)**2) +--- +> ! Normalize data to have zeroth moment of unity. +> xqmc = xqmc / XMOM1 +> cov = cov / ((XMOM1)**2) +62a97 +> +64c99 +< If ( Present(L_cov) ) then +--- +> If ( Present(L_cov) ) then +76c111 +< sigma(nt) = sqrt(sigma(nt)) +--- +> sigma(nt) = sqrt(sigma(nt)) +81c116 +< xqmc1(nt1) = xqmc1(nt1) + xqmc(nt)*U(nt,nt1) +--- +> xqmc1(nt1) = xqmc1(nt1) + xqmc(nt)*U(nt,nt1) +83c118 +< xqmc1(nt1) = xqmc1(nt1)/sigma(nt1) +--- +> xqmc1(nt1) = xqmc1(nt1)/sigma(nt1) +91c126 +< Vhelp(nt1) = Vhelp(nt1) + Xker_table(nt,nw)*U(nt,nt1) +--- +> Vhelp(nt1) = Vhelp(nt1) + Xker_table(nt,nw)*U(nt,nt1) +95c130 +< Xker_table(nt1,nw) = Vhelp(nt1)/sigma(nt1) !! This has changed !! +--- +> Xker_table(nt1,nw) = Vhelp(nt1)/sigma(nt1) !! This has changed !! +98,99c133,134 +< deallocate( U, Sigma ) +< Allocate ( G_Mean(Ntau) ) +--- +> deallocate( U, Sigma ) +> Allocate ( G_Mean(Ntau) ) +101,102c136,138 +< ! write(6,*) ' There are ', Ngamma,' delta-functions for a spectrum' +< ! Write(6,*) ' Initializing' +--- +> +> ! write(6,*) ' There are ', Ngamma,' delta-functions for a spectrum' +> ! Write(6,*) ' Initializing' +104,105c140,143 +< D = 1.d0 / (Om_en_1 - Om_st_1) +< Iseed = 8752143 +--- +> D = 1.d0 / (Om_en_1 - Om_st_1) +> +> Iseed = 8752143 +> +107c145,146 +< File_Aom = "dump_Aom" +--- +> File_Aom = "dump_Aom" +> +115c154 +< read(41,*) Xn_tot(ng,1,ns), Xn_tot(ng,2,ns) +--- +> read(41,*) Xn_tot(ng,1,ns), Xn_tot(ng,2,ns) +122c161 +< read(42,*) Xn_m_tot(nd,ns), Xn_e_tot(nd,ns) +--- +> read(42,*) Xn_m_tot(nd,ns), Xn_e_tot(nd,ns) +125c164 +< Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") +--- +> Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") +132,133c171,172 +< Xn_tot(ng,1,ns) = ranf(iseed) +< Xn_tot(ng,2,ns) = 1.d0/dble(Ngamma) +--- +> Xn_tot(ng,1,ns) = ranf(iseed) +> Xn_tot(ng,2,ns) = 1.d0/dble(Ngamma) +140,141c179,180 +< nc = 0 +< Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") +--- +> nc = 0 +> Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") +147c186,187 +< CALL SYSTEM_CLOCK(COUNT_RATE=N_P_SEC) +--- +> +> CALL SYSTEM_CLOCK(COUNT_RATE=N_P_SEC) +157,158c197,198 +< Call MC(Xtau, Xker_table, Xn, Alpha, NSweeps, Xn_m, En, En_m, & +< & Acc_1, Acc_2 ) ! Just one bin +--- +> Call MC(Xtau, Xker_table, Xn, Alpha, NSweeps, Xn_m, En, En_m, & +> & Acc_1, Acc_2 ) ! Just one bin +163,165c203,205 +< En_tot(ns) = En ! this is the energy of the configuration Xn_tot for simulation ns +< Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") +< Write(44,2003) 1.d0/Alpha, En_m, Acc_1, Acc_2 +--- +> En_tot(ns) = En ! this is the energy of the configuration Xn_tot for simulation ns +> Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") +> Write(44,2003) 1.d0/Alpha, En_m, Acc_1, Acc_2 +166a207 +> +170c211 +< Xn_m(nd) = Xn_m(nd) * D * dble(Ndis) +--- +> Xn_m(nd) = Xn_m(nd) * D * dble(Ndis) +178c219 +< ! Exchange +--- +> ! Exchange +181c222 +< nalp1= nint( ranf(iseed)*dble(NSims-1) + 0.5 ) ! 1..(NSims-1) +--- +> nalp1= nint( ranf(iseed)*dble(NSims-1) + 0.5 ) ! 1..(NSims-1) +183,184c224,225 +< DeltaE = (Alpha_tot(nalp1)*En_tot(nalp2) + Alpha_tot(nalp2)*En_tot(nalp1))& +< & -(Alpha_tot(nalp1)*En_tot(nalp1) + Alpha_tot(nalp2)*En_tot(nalp2)) +--- +> DeltaE = (Alpha_tot(nalp1)*En_tot(nalp2) + Alpha_tot(nalp2)*En_tot(nalp1))& +> & -(Alpha_tot(nalp1)*En_tot(nalp1) + Alpha_tot(nalp2)*En_tot(nalp2)) +186c227 +< if (Ratio.gt.ranf(iseed)) Then +--- +> if (Ratio.gt.ranf(iseed)) Then +190,191c231,232 +< Xn(ng,1) = Xn_tot(ng,1,nalp1) +< Xn(ng,2) = Xn_tot(ng,2,nalp1) +--- +> Xn(ng,1) = Xn_tot(ng,1,nalp1) +> Xn(ng,2) = Xn_tot(ng,2,nalp1) +194,197c235,238 +< Xn_tot(ng,1,nalp1) = Xn_tot(ng,1,nalp2) +< Xn_tot(ng,2,nalp1) = Xn_tot(ng,2,nalp2) +< Xn_tot(ng,1,nalp2) = Xn(ng,1) +< Xn_tot(ng,2,nalp2) = Xn(ng,2) +--- +> Xn_tot(ng,1,nalp1) = Xn_tot(ng,1,nalp2) +> Xn_tot(ng,2,nalp1) = Xn_tot(ng,2,nalp2) +> Xn_tot(ng,1,nalp2) = Xn(ng,1) +> Xn_tot(ng,2,nalp2) = Xn(ng,2) +205c246,247 +< Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") +--- +> +> Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") +208a251 +> +212c255 +< Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") +--- +> Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") +215c258 +< ! dump so as to restart. +--- +> ! dump so as to restart. +221c264 +< write(41,*) Xn_tot(ng,1,ns), Xn_tot(ng,2,ns) +--- +> write(41,*) Xn_tot(ng,1,ns), Xn_tot(ng,2,ns) +228c271 +< write(42,*) Xn_m_tot(nd,ns), Xn_e_tot(nd,ns) +--- +> write(42,*) Xn_m_tot(nd,ns), Xn_e_tot(nd,ns) +233a277,280 +> +> +> +> +236,237c283,284 +< En_m_tot(ns) = En_m_tot(ns) / dble(nc) +< En_e_tot(ns) = En_e_tot(ns) / dble(nc) +--- +> En_m_tot(ns) = En_m_tot(ns) / dble(nc) +> En_e_tot(ns) = En_e_tot(ns) / dble(nc) +246a294 +> +252,253c300,301 +< Xn_m_tot(nd,ns) = Xn_m_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) +< Xn_e_tot(nd,ns) = Xn_e_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) +--- +> Xn_m_tot(nd,ns) = Xn_m_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) +> Xn_e_tot(nd,ns) = Xn_e_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) +255c303 +< if (Xn_e_tot(nd,ns).gt.0.d0) then +--- +> if (Xn_e_tot(nd,ns).gt.0.d0) then +264c312 +< ! PhiM1(dble(nd)/dble(NDis)), Xn_m_tot(nd,ns) +--- +> ! PhiM1(dble(nd)/dble(NDis)), Xn_m_tot(nd,ns) +267a316 +> +269c318 +< File_root ="Aom_ps" +--- +> File_root ="Aom_ps" +275,276c324,325 +< Xn_m(nd) = Xn_m(nd) + (En_m_tot(ns) - En_m_tot(ns+1))*Xn_m_tot(nd,ns) +< Xn_e(nd) = Xn_e(nd) + (En_m_tot(ns) - En_m_tot(ns+1))*Xn_e_tot(nd,ns) +--- +> Xn_m(nd) = Xn_m(nd) + (En_m_tot(ns) - En_m_tot(ns+1))*Xn_m_tot(nd,ns) +> Xn_e(nd) = Xn_e(nd) + (En_m_tot(ns) - En_m_tot(ns+1))*Xn_e_tot(nd,ns) +290,291c339,340 +< Xn_m(nd) = Back_Trans_Aom(Aom,Beta,om) +< Xn_e(nd) = Back_Trans_Aom(Err,Beta,om) +--- +> Xn_m(nd) = Back_Trans_Aom(Aom,Beta,om) +> Xn_e(nd) = Back_Trans_Aom(Err,Beta,om) +299c348 +< close(66) +--- +> close(66) +300a350 +> +303c353 +< Write(41,*) Phim1(Xn_tot(ng,1,Nsims)) , Xn_tot(ng,2,Nsims) +--- +> Write(41,*) Phim1(Xn_tot(ng,1,Nsims)) , Xn_tot(ng,2,Nsims) +305a356 +> +307c358 +< DeAllocate (En_m_tot, En_e_tot, En_tot ) +--- +> DeAllocate (En_m_tot, En_e_tot, En_tot ) +314,317c365,370 +< 2001 format(F14.7,2x,F14.7,2x,F14.7) +< 2004 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7) +< 2005 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7,2x,F14.7) +< 2003 format('Alpha, En_m, Acc ', F14.7,2x,F24.12,2x,F14.7,2x,F14.7,2x,F14.7) +--- +> +> +> 2001 format(F14.7,2x,F14.7,2x,F14.7) +> 2004 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7) +> 2005 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7,2x,F14.7) +> 2003 format('Alpha, En_m, Acc ', F14.7,2x,F24.12,2x,F14.7,2x,F14.7,2x,F14.7) +318a372,373 +> +> +321,322c376,378 +< & Ngamma_1, OM_ST, OM_EN, Nsweeps, NBins, NWarm, Aom_res,& +< & xom_res, Chisq ) +--- +> & Ngamma_1, OM_ST, OM_EN, Nsweeps, NBins, NWarm, Aom_res,& +> & xom_res, Chisq ) +> +324c380 +< Real (Kind=8), Dimension(:) :: XQMC, Xtau, Alpha_tot, Aom_res, Xom_res +--- +> Real (Kind=8), Dimension(:) :: XQMC, Xtau, Alpha_tot, Aom_res, Xom_res +326c382 +< Real (Kind=8), external :: XKER +--- +> Real (Kind=8), external :: XKER +328,330c384,387 +< Integer :: Nsweeps, NBins, Ngamma_1, Ndis_1, nw, nt1, Lcov +< ! Local +< Integer lp, NSims, ns, nb, nc, Nwarm, nalp1, nalp2, Nex, p_star +--- +> Integer :: Nsweeps, NBins, Ngamma_1, Ndis_1, nw, nt1, Lcov +> +> ! Local +> Integer lp, NSims, ns, nb, nc, Nwarm, nalp1, nalp2, Nex, p_star +332c389 +< & Xn_tot(:,:,:), En_tot(:), Xker_table(:,:) +--- +> & Xn_tot(:,:,:), En_tot(:), Xker_table(:,:) +336c393,395 +< Real (Kind=8), allocatable :: U(:,:), sigma(:) +--- +> Real (Kind=8), allocatable :: U(:,:), sigma(:) +> +> +338,339c397,398 +< Iseed = 8752143 +< NDis = Size(Aom_res,1) +--- +> Iseed = 8752143 +> NDis = Size(Aom_res,1) +341,346c400,406 +< delta = 0.001 +< delta2 = delta*delta +< Ngamma = Ngamma_1 +< Beta = Beta_1 ! Physical temperature for calculation of the kernel. +< Ntau = Size(xqmc,1) +< NSims = Size(Alpha_tot,1) +--- +> delta = 0.001 +> delta2 = delta*delta +> Ngamma = Ngamma_1 +> Beta = Beta_1 ! Physical temperature for calculation of the kernel. +> +> Ntau = Size(xqmc,1) +> NSims = Size(Alpha_tot,1) +348c408 +< Allocate (En_m_tot(NSims), En_e_tot(NSims), En_tot(NSims) ) +--- +> Allocate (En_m_tot(NSims), En_e_tot(NSims), En_tot(NSims) ) +349a410 +> +351a413 +> +353,354c415,417 +< ! Setup table for the Kernel +< Ndis = Size(Aom_res) +--- +> +> ! Setup table for the Kernel +> Ndis = Size(Aom_res) +365,367c428,431 +< ! Normalize data to have zeroth moment of unity. +< xqmc = xqmc / XMOM1 +< cov = cov / ((XMOM1)**2) +--- +> +> ! Normalize data to have zeroth moment of unity. +> xqmc = xqmc / XMOM1 +> cov = cov / ((XMOM1)**2) +368a433 +> +373c438 +< sigma(nt) = sqrt(sigma(nt)) +--- +> sigma(nt) = sqrt(sigma(nt)) +378c443 +< xqmc1(nt1) = xqmc1(nt1) + xqmc(nt)*U(nt,nt1) +--- +> xqmc1(nt1) = xqmc1(nt1) + xqmc(nt)*U(nt,nt1) +380c445 +< xqmc1(nt1) = xqmc1(nt1)/sigma(nt1) +--- +> xqmc1(nt1) = xqmc1(nt1)/sigma(nt1) +388c453 +< Vhelp(nt1) = Vhelp(nt1) + Xker_table(nt,nw)*U(nt,nt1) +--- +> Vhelp(nt1) = Vhelp(nt1) + Xker_table(nt,nw)*U(nt,nt1) +392c457 +< Xker_table(nt1,nw) = Vhelp(nt1)/sigma(nt1) !! This has changed !! +--- +> Xker_table(nt1,nw) = Vhelp(nt1)/sigma(nt1) !! This has changed !! +400c465 +< sigma(nt) = 1.d0/sqrt(cov(nt,nt)) +--- +> sigma(nt) = 1.d0/sqrt(cov(nt,nt)) +404c469 +< xqmc1(nt1) = xqmc(nt1)*sigma(nt1) +--- +> xqmc1(nt1) = xqmc(nt1)*sigma(nt1) +410c475 +< Xker_table(nt1,nw) = Xker_table(nt1,nw)*sigma(nt1) !! This has changed !! +--- +> Xker_table(nt1,nw) = Xker_table(nt1,nw)*sigma(nt1) !! This has changed !! +417,418c482,484 +< ! write(6,*) ' There are ', Ngamma,' delta-functions for a spectrum' +< ! Write(6,*) ' Initializing' +--- +> +> ! write(6,*) ' There are ', Ngamma,' delta-functions for a spectrum' +> ! Write(6,*) ' Initializing' +421,422c487,488 +< Xn_tot(ng,1,ns) = ranf(iseed) +< Xn_tot(ng,2,ns) = 1.d0/dble(Ngamma) +--- +> Xn_tot(ng,1,ns) = ranf(iseed) +> Xn_tot(ng,2,ns) = 1.d0/dble(Ngamma) +431c497,498 +< Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") +--- +> +> Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") +433c500 +< nc = 0 +--- +> nc = 0 +441,442c508,509 +< Call MC(Xtau, Xker_table, Xn, Alpha, NSweeps, Xn_m, En, En_m, & +< & Acc_1, Acc_2 ) ! Just one bin +--- +> Call MC(Xtau, Xker_table, Xn, Alpha, NSweeps, Xn_m, En, En_m, & +> & Acc_1, Acc_2 ) ! Just one bin +447,448c514,515 +< En_tot(ns) = En ! this is the energy of the configuration Xn_tot for simulation ns +< Write(44,2003) 1.d0/Alpha, En_m, Acc_1, Acc_2 +--- +> En_tot(ns) = En ! this is the energy of the configuration Xn_tot for simulation ns +> Write(44,2003) 1.d0/Alpha, En_m, Acc_1, Acc_2 +452c519 +< Xn_m(nd) = Xn_m(nd) * D * dble(Ndis) +--- +> Xn_m(nd) = Xn_m(nd) * D * dble(Ndis) +460c527 +< ! Exchange +--- +> ! Exchange +463c530 +< nalp1= nint( ranf(iseed)*dble(NSims-1) + 0.5 ) ! 1..(NSims-1) +--- +> nalp1= nint( ranf(iseed)*dble(NSims-1) + 0.5 ) ! 1..(NSims-1) +465,466c532,533 +< DeltaE = (Alpha_tot(nalp1)*En_tot(nalp2) + Alpha_tot(nalp2)*En_tot(nalp1))& +< & -(Alpha_tot(nalp1)*En_tot(nalp1) + Alpha_tot(nalp2)*En_tot(nalp2)) +--- +> DeltaE = (Alpha_tot(nalp1)*En_tot(nalp2) + Alpha_tot(nalp2)*En_tot(nalp1))& +> & -(Alpha_tot(nalp1)*En_tot(nalp1) + Alpha_tot(nalp2)*En_tot(nalp2)) +468c535 +< if (Ratio.gt.ranf(iseed)) Then +--- +> if (Ratio.gt.ranf(iseed)) Then +472,473c539,540 +< Xn(ng,1) = Xn_tot(ng,1,nalp1) +< Xn(ng,2) = Xn_tot(ng,2,nalp1) +--- +> Xn(ng,1) = Xn_tot(ng,1,nalp1) +> Xn(ng,2) = Xn_tot(ng,2,nalp1) +476,479c543,546 +< Xn_tot(ng,1,nalp1) = Xn_tot(ng,1,nalp2) +< Xn_tot(ng,2,nalp1) = Xn_tot(ng,2,nalp2) +< Xn_tot(ng,1,nalp2) = Xn(ng,1) +< Xn_tot(ng,2,nalp2) = Xn(ng,2) +--- +> Xn_tot(ng,1,nalp1) = Xn_tot(ng,1,nalp2) +> Xn_tot(ng,2,nalp1) = Xn_tot(ng,2,nalp2) +> Xn_tot(ng,1,nalp2) = Xn(ng,1) +> Xn_tot(ng,2,nalp2) = Xn(ng,2) +486c553 +< Acc_1 = Acc_1/dble(Nex) +--- +> Acc_1 = Acc_1/dble(Nex) +488a556 +> +491,492c559,560 +< En_m_tot(ns) = En_m_tot(ns) / dble(nc) +< En_e_tot(ns) = En_e_tot(ns) / dble(nc) +--- +> En_m_tot(ns) = En_m_tot(ns) / dble(nc) +> En_e_tot(ns) = En_e_tot(ns) / dble(nc) +503a572 +> +506,507c575,576 +< Xn_m_tot(nd,ns) = Xn_m_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) +< Xn_e_tot(nd,ns) = Xn_e_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) +--- +> Xn_m_tot(nd,ns) = Xn_m_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) +> Xn_e_tot(nd,ns) = Xn_e_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) +509c578 +< if (Xn_e_tot(nd,ns).gt.0.d0) then +--- +> if (Xn_e_tot(nd,ns).gt.0.d0) then +518c587 +< if (ns.eq.Nsims) then +--- +> if (ns.eq.Nsims) then +524a594 +> +526,527c596,599 +< xqmc = XMOM1* xqmc +< cov = ((XMOM1)**2)* cov +--- +> xqmc = XMOM1* xqmc +> cov = ((XMOM1)**2)* cov +> +> +529c601 +< DeAllocate (En_m_tot, En_e_tot, En_tot ) +--- +> DeAllocate (En_m_tot, En_e_tot, En_tot ) +536,539c608,612 +< 2001 format(F14.7,2x,F14.7,2x,F14.7) +< 2004 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7) +< 2005 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7,2x,F14.7) +< 2003 format('Alpha, En_m, Acc ', F14.7,2x,F14.7,2x,F14.7,2x,F14.7,2x,F14.7) +--- +> +> 2001 format(F14.7,2x,F14.7,2x,F14.7) +> 2004 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7) +> 2005 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7,2x,F14.7) +> 2003 format('Alpha, En_m, Acc ', F14.7,2x,F14.7,2x,F14.7,2x,F14.7,2x,F14.7) +541,542c614,615 +< !*********** +< Real (Kind=8) Function Phim1(x) +--- +> !*********** +> Real (Kind=8) Function Phim1(x) +549c622,624 +< Integer Function NPhim1(x) +--- +> +> +> Integer Function NPhim1(x) +550a626 +> +552a629 +> +554,555c631,633 +< om = x*(Om_en_1 - Om_st_1) + Om_st_1 +< NPhiM1 = Nint ( (om - Om_st_1)/Dom + 0.75 ) +--- +> om = x*(Om_en_1 - Om_st_1) + Om_st_1 +> NPhiM1 = Nint ( (om - Om_st_1)/Dom + 0.75 ) +> +556a635,636 +> +> +558a639 +> +561c642 +< Real (Kind=8), Dimension(:) :: Xn_m +--- +> Real (Kind=8), Dimension(:) :: Xn_m +562a644,645 +> +> +569a653 +> +570a655 +> +572a658 +> +575c661 +< Real (Kind=8), Dimension(:) :: Xn_m +--- +> Real (Kind=8), Dimension(:) :: Xn_m +576a663,664 +> +> +581a670 +> +582a672,673 +> +> +584c675,676 +< Subroutine MC(Xtau, Xker_table, Xn, Alpha, NSweeps, Xn_m, En, En_m, Acc_1,Acc_2) +--- +> Subroutine MC(Xtau, Xker_table, Xn, Alpha, NSweeps, Xn_m, En, En_m, Acc_1,Acc_2) +> +587a680 +> +589c682 +< Real (Kind=8), Dimension(:) :: Xtau, Xn_m +--- +> Real (Kind=8), Dimension(:) :: Xtau, Xn_m +591,592c684,686 +< Integer :: NSweeps, nl, Lambda_max, ng1, ng2 +< !Local +--- +> Integer :: NSweeps, nl, Lambda_max, ng1, ng2 +> +> !Local +594,597c688,693 +< & A_gamma_o(:), Z_gamma_o(:) +< Real (Kind=8), Allocatable :: XKER_stor(:,:), XKER_new(:) +< Real (Kind=8) :: X, En, En1, DeltaE, XP, XM, om +< Integer, Allocatable :: Lambda(:) +--- +> & A_gamma_o(:), Z_gamma_o(:) +> +> Real (Kind=8), Allocatable :: XKER_stor(:,:), XKER_new(:) +> +> Real (Kind=8) :: X, En, En1, DeltaE, XP, XM, om +> Integer, Allocatable :: Lambda(:) +598a695 +> +601c698,699 +< & Z_gamma_o(2), A_gamma_o(2) ) ! Max of moves of two walkers. +--- +> & Z_gamma_o(2), A_gamma_o(2) ) ! Max of moves of two walkers. +> +603,604c701,705 +< Xn_m = 0.d0 +< En_m = 0.d0 +--- +> +> Xn_m = 0.d0 +> En_m = 0.d0 +> +> +610,611c711,712 +< Z_gamma = xn(ng,2) +< XKer_stor( nt, ng ) = XKER_table(nt, NPhiM1(A_gamma) ) +--- +> Z_gamma = xn(ng,2) +> XKer_stor( nt, ng ) = XKER_table(nt, NPhiM1(A_gamma) ) +615c716 +< h(nt) = X - xqmc1(nt) +--- +> h(nt) = X - xqmc1(nt) +616a718,719 +> +> +619c722 +< ! Weight sharing moves. +--- +> ! Weight sharing moves. +621,623c724,726 +< x = ranf(iseed) +< if (x.gt.0.5) then +< ! Weight sharing moves. +--- +> x = ranf(iseed) +> if (x.gt.0.5) then +> ! Weight sharing moves. +626,627c729,730 +< do +< Lambda(2) = nint(ranf(iseed)*dble(Ngamma) + 0.5) +--- +> do +> Lambda(2) = nint(ranf(iseed)*dble(Ngamma) + 0.5) +632c735,736 +< A_gamma_o(1) = Xn(ng1,1) +--- +> +> A_gamma_o(1) = Xn(ng1,1) +635,636c739,741 +< Z_gamma_o(2) = Xn(ng2,2) +< A_gamma_p(1) = Xn(ng1,1) +--- +> Z_gamma_o(2) = Xn(ng2,2) +> +> A_gamma_p(1) = Xn(ng1,1) +638,640c743,747 +< s = (Z_gamma_o(1) + Z_gamma_o(2))*ranf(iseed) - Z_gamma_o(1) +< Z_gamma_p(1) = Z_gamma_o(1) + s +< Z_gamma_p(2) = Z_gamma_o(2) - s +--- +> +> s = (Z_gamma_o(1) + Z_gamma_o(2))*ranf(iseed) - Z_gamma_o(1) +> Z_gamma_p(1) = Z_gamma_o(1) + s +> Z_gamma_p(2) = Z_gamma_o(2) - s +> +641a749 +> +644,646c752,754 +< X = Xker_stor(nt,ng1)*( Z_gamma_p(1) - Z_gamma_o(1) ) + & +< & Xker_stor(nt,ng2)*( Z_gamma_p(2) - Z_gamma_o(2) ) +< Deltah(nt) = X +--- +> X = Xker_stor(nt,ng1)*( Z_gamma_p(1) - Z_gamma_o(1) ) + & +> & Xker_stor(nt,ng2)*( Z_gamma_p(2) - Z_gamma_o(2) ) +> Deltah(nt) = X +653a762 +> +655c764,765 +< A_gamma_p(1) = xpbc( Xn(ng1,1) + (ranf(iseed) - 0.5)*DeltaXMAX, 1.d0 ) +--- +> A_gamma_p(1) = xpbc( Xn(ng1,1) + (ranf(iseed) - 0.5)*DeltaXMAX, 1.d0 ) +> +657c767 +< nw = NPhiM1(A_gamma_p(1)) +--- +> nw = NPhiM1(A_gamma_p(1)) +660a771 +> +662,663c773,774 +< X = ( Xker_new(nt) - Xker_stor(nt,ng1) ) * Z_gamma_o(1) +< Deltah(nt) = X +--- +> X = ( Xker_new(nt) - Xker_stor(nt,ng1) ) * Z_gamma_o(1) +> Deltah(nt) = X +666c777,779 +< DeltaE = 0.d0 +--- +> +> +> DeltaE = 0.d0 +668c781 +< DeltaE = DeltaE + (Deltah(nt) + 2.0 * h(nt) ) *Deltah(nt) +--- +> DeltaE = DeltaE + (Deltah(nt) + 2.0 * h(nt) ) *Deltah(nt) +670c783 +< Ratio = exp( -alpha * DeltaE ) +--- +> Ratio = exp( -alpha * DeltaE ) +672,674c785,787 +< if (Ratio .gt. ranf(iseed)) Then +< ! write(6,*) 'Accepted' +< if (Lambda_max.eq.1) then +--- +> if (Ratio .gt. ranf(iseed)) Then +> ! write(6,*) 'Accepted' +> if (Lambda_max.eq.1) then +678c791 +< Xker_stor(nt,ng1) = Xker_new(nt) +--- +> Xker_stor(nt,ng1) = Xker_new(nt) +687c800 +< h(nt) = h(nt) + Deltah(nt) +--- +> h(nt) = h(nt) + Deltah(nt) +696c809 +< Call Sum_Xn_Boxes( Xn_m, Xn ) +--- +> Call Sum_Xn_Boxes( Xn_m, Xn ) +701a815,816 +> +> +703c818 +< Deallocate ( Lambda, Z_gamma_p, A_gamma_p, Z_gamma_o, A_gamma_o ) +--- +> Deallocate ( Lambda, Z_gamma_p, A_gamma_p, Z_gamma_o, A_gamma_o ) +705,706c820,822 +< 2005 format(I4,2x,I4,2x,F14.7,2x,F14.7,' --> ',F14.7,2x,F14.7) +< 2006 format(I4,2x,F14.7, ' --> ',F14.7) +--- +> +> 2005 format(I4,2x,I4,2x,F14.7,2x,F14.7,' --> ',F14.7,2x,F14.7) +> 2006 format(I4,2x,F14.7, ' --> ',F14.7) +707a824,826 +> +> +> +709,710c828,829 +< real (Kind=8) function xpbc(X,XL) +< real (kind=8) :: X, XL +--- +> real (Kind=8) function xpbc(X,XL) +> real (kind=8) :: X, XL +714a834,835 +> +> diff --git a/src/Modules/CMakeLists.txt b/src/Modules/CMakeLists.txt new file mode 100644 index 000000000..190350489 --- /dev/null +++ b/src/Modules/CMakeLists.txt @@ -0,0 +1,4 @@ +#Modules library +SET(Modules_src ${SRCMODULES}/Files_mod.f90 ${SRCMODULES}/Histogram.f90 ${SRCMODULES}/Histogram_v2.f90 ${SRCMODULES}/Natural_constants.f90 ${SRCMODULES}/Random_Wrap.f90 ${SRCMODULES}/errors.f90 ${SRCMODULES}/fourier.f90 ${SRCMODULES}/lattices_v3.f90 +${SRCMODULES}/log_mesh.f90 ${SRCMODULES}/mat_mod.f90 ${SRCMODULES}/matrix.f90 ${SRCMODULES}/maxent.f90 ${SRCMODULES}/maxent_stoch.f90 ${SRCMODULES}/maxent_stoch.f90 ${SRCMODULES}/precdef.mod.f90 ${SRCMODULES}/smooth_stoch.f90 ${SRCMODULES}/tmp.f90) +ADD_LIBRARY(${MODULES} STATIC ${Modules_src}) diff --git a/src/Modules/Compile b/src/Modules/Compile new file mode 100644 index 000000000..b602a560e --- /dev/null +++ b/src/Modules/Compile @@ -0,0 +1,13 @@ +OBJS=mat_mod.o Random_Wrap.o errors.o Files_mod.o maxent.o matrix.o maxent_stoch.o fourier.o \ + Histogram.o lattices_v3.o Natural_constants.o log_mesh.o precdef.mod.o \ + Histogram_v2.o + +$(LIB): $(OBJS) + ar -r $(LIB) $(OBJS) + +.SUFFIXES: .f90 +.f90.o: + $(FC) $(SUFFIX) $(FLAGS) $< + +clean: + rm $(OBJS) diff --git a/src/Modules/Files_mod.f90 b/src/Modules/Files_mod.f90 new file mode 100644 index 000000000..922a8d9f6 --- /dev/null +++ b/src/Modules/Files_mod.f90 @@ -0,0 +1,15 @@ +Module Files_mod + contains + + Character (len=64) function File_i( file, I) + character (len=64) :: file + integer :: i + write(File_i,'(A,"_",I0)') trim(file),i + end function File_i + + Character (len=64) function File_add( file, file1) + character (len=64) :: file, file1 + write(File_add,'(A,A)') trim(file),Trim(file1) + end function File_add + +end Module Files_mod diff --git a/src/Modules/Histogram.f90 b/src/Modules/Histogram.f90 new file mode 100644 index 000000000..6086cd5ca --- /dev/null +++ b/src/Modules/Histogram.f90 @@ -0,0 +1,109 @@ + Module Histograms + + Type Histogram + Real (Kind=8), pointer :: el(:) + Real (Kind=8) :: range_st, range_en, dis + Real (Kind=8) :: count + Character (16) :: File + + end Type Histogram + + Interface Make_Hist + module procedure Construct_Hist + end Interface Make_Hist + Interface Clear_Hist + module procedure Destroy_Hist + end Interface Clear_Hist + + contains + + subroutine Construct_Hist(Hist, file, range_st, range_en, dis) + Implicit none + type (Histogram) :: Hist + Real (Kind=8) :: range_st, range_en, dis + Character (16) :: File + + Integer :: n + n = nint( ( range_en - range_st)/dis ) + allocate ( Hist%el(n) ) + Hist%el = 0.d0 + Hist%range_st = range_st + Hist%range_en = range_en + Hist%dis = dis + Hist%file = file + Hist%count = 0.d0 + + end subroutine Construct_Hist + + subroutine Destroy_Hist(Hist) + Implicit none + type (Histogram) :: Hist + + deallocate ( Hist%el ) + Hist%el = 0.d0 + Hist%range_st = 0.d0 + Hist%range_en = 0.d0 + Hist%dis = 0.d0 + Hist%file = "" + Hist%count = 0.d0 + + end subroutine Destroy_Hist + + + subroutine Read_Hist(Hist) + Implicit none + type (Histogram) :: Hist + + integer :: io_error, nv + Real (Kind=8) :: X,Y + + + Open ( unit=20,file=Hist%file,status='old',action='read', iostat=io_error) + If (io_error.eq.0) then + read(20,*) Hist%count + do nv = 1,size(Hist%el,1) + read(20,*) X, Y + Hist%el(nv) = Y * Hist%count * Hist%dis + enddo + else + Hist%count = 0.d0 + Hist%el = 0.d0 + endif + close(20) + end subroutine Read_Hist + + + subroutine Write_Hist(Hist) + Implicit none + type (Histogram) :: Hist + Integer :: nv + + Open ( unit=20,file=Hist%file,status='unknown') + write(20,*) Hist%count + do nv = 1,size(Hist%el,1) + write(20,*) dble(nv)*Hist%dis + Hist%range_st, Hist%el(nv)/(Hist%count * Hist%dis) + enddo + close(20) + + end subroutine Write_Hist + + + subroutine Add_Hist(Hist,value) + Implicit none + type (Histogram) :: Hist + Real (Kind=8) :: value + Integer :: nv + + if ( value .gt. Hist%range_en .or. value .lt. Hist%range_st ) then + write(6,*) 'Error in Add_Hist: ', Hist%file, value + else + nv = int((value - Hist%range_st )/Hist%dis) + if (nv < 1) nv =1 + if (nv > size(Hist%el,1) ) nv = size(Hist%el,1) + Hist%el(nv) = Hist%el(nv) + 1.0 + Hist%count = Hist%count + 1.0 + endif + end subroutine Add_Hist + + + end Module Histograms diff --git a/src/Modules/Histogram_v2.f90 b/src/Modules/Histogram_v2.f90 new file mode 100644 index 000000000..9a8db24da --- /dev/null +++ b/src/Modules/Histogram_v2.f90 @@ -0,0 +1,123 @@ + Module Histograms_v2 + + Use Log_Mesh + + Type Histogram + Type (logmesh) :: mesh + Real (Kind=8), pointer :: el(:) + Real (Kind=8) :: range_st, range_en, dis + Real (Kind=8) :: count + Character (16) :: File + + end Type Histogram + + Interface Make_Hist + module procedure Construct_Hist + end Interface Make_Hist + Interface Clear_Hist + module procedure Destroy_Hist + end Interface Clear_Hist + + contains + + subroutine Construct_Hist(Hist, file, range, center, dis, Type, Lambda) + Implicit none + type (Histogram) :: Hist + Real (Kind=8) :: Range, Center, dis, Lambda + Character (16) :: File + Character(len=10) :: Type + Integer :: n, Nw_1 + + !Local + + + Nw_1 = range*2.d0/dis + + call Make_log_mesh(Hist%Mesh, Lambda, Center, Range, Type, Nw_1) + write(6,*) 'In Construct_hist: ', Size(Hist%Mesh%Xom,1) + n = Size(Hist%Mesh%Xom,1) + allocate ( Hist%el(n) ) + Hist%el = 0.d0 + Hist%file = file + Hist%count = 0.d0 + + end subroutine Construct_Hist + + subroutine Destroy_Hist(Hist) + Implicit none + type (Histogram) :: Hist + + deallocate ( Hist%el ) + Hist%el = 0.d0 + Hist%file = "" + Hist%count = 0.d0 + Call Clear_log_mesh ( Hist%Mesh ) + + end subroutine Destroy_Hist + + +!!$ subroutine Read_Hist(Hist) +!!$ Implicit none +!!$ type (Histogram) :: Hist +!!$ +!!$ integer :: io_error, nv +!!$ Real (Kind=8) :: X,Y +!!$ +!!$ +!!$ Open ( unit=20,file=Hist%file,status='old',action='read', iostat=io_error) +!!$ If (io_error.eq.0) then +!!$ read(20,*) Hist%count +!!$ do nv = 1,size(Hist%el,1) +!!$ read(20,*) X, Y +!!$ Hist%el(nv) = Y * Hist%count * Hist%dis +!!$ enddo +!!$ else +!!$ Hist%count = 0.d0 +!!$ Hist%el = 0.d0 +!!$ endif +!!$ close(20) +!!$ end subroutine Read_Hist + + + subroutine Write_Hist(Hist) + Implicit none + type (Histogram) :: Hist + Integer :: nv + + Open ( unit=20,file=Hist%file,status='unknown') + write(20,*) Hist%count + do nv = 1,size(Hist%el,1) -1 + write(20,*) Hist%Mesh%Xom(nv), Hist%el(nv)/(Hist%count * Hist%Mesh%DXom(nv)) + enddo + close(20) + + end subroutine Write_Hist + + Real (Kind=8) function Inter_Hist(Hist) + Implicit none + type (Histogram) :: Hist + Integer :: nv + Real (Kind=8) :: X + + X = 0.d0 + do nv = 1,size(Hist%el,1) -1 + X = X + Hist%el(nv) !* Hist%Mesh%DXom(nv) + enddo + Inter_Hist = X + end function Inter_Hist + + + + subroutine Add_Hist(Hist,value) + Implicit none + type (Histogram) :: Hist + Real (Kind=8) :: value + Integer :: nv + + nv = m_find(Value,Hist%Mesh) + Hist%el(nv) = Hist%el(nv) + 1.0 + Hist%count = Hist%count + 1.0 + end subroutine Add_Hist + + + end Module Histograms_v2 diff --git a/src/Modules/Makefile b/src/Modules/Makefile new file mode 100644 index 000000000..da09025d1 --- /dev/null +++ b/src/Modules/Makefile @@ -0,0 +1,15 @@ +#FC= $(f90) +#FC= mpxlf90 +#FLAGS= -c -q64 -O4 +#FLAGS= -c -O3 -fbounds-check +FLAGS= -c -O3 +SUFFIX= -qsuffix=f=f90 +LF= +LIB=modules_90.a + +all: + (make -f Compile FC="$(FC)" FLAGS="$(FLAGS)" LIB="$(LIB)" ) + +clean: + (make -f Compile clean ) ;\ + rm *.mod *~ \#* diff --git a/src/Modules/Makefile_Juropa b/src/Modules/Makefile_Juropa new file mode 100644 index 000000000..fb198fdf5 --- /dev/null +++ b/src/Modules/Makefile_Juropa @@ -0,0 +1,15 @@ +FC= ifort +#FC= mpxlf90 +#FLAGS= -c -q64 -O4 +#FLAGS= -c -O1 -pg +FLAGS= -c -O3 +SUFFIX= -qsuffix=f=f90 +LF= -warn all +LIB=modules_90.a + +all: + (make -f Compile FC="$(FC)" FLAGS="$(FLAGS)" LIB="$(LIB)" ) + +clean: + (make -f Compile clean ) ;\ + rm *.mod diff --git a/src/Modules/Makefile_cl b/src/Modules/Makefile_cl new file mode 100644 index 000000000..624f8fd2e --- /dev/null +++ b/src/Modules/Makefile_cl @@ -0,0 +1,14 @@ +FC= ifort +#FC= mpxlf90 +#FLAGS= -c -q64 -O4 +FLAGS= -c -O3 +SUFFIX= -qsuffix=f=f90 +LF= +LIB=modules_90.a + +all: + (make -f Compile FC="$(FC)" FLAGS="$(FLAGS)" LIB="$(LIB)" ) + +clean: + (make -f Compile clean ) ;\ + rm *.mod *~ \#* diff --git a/src/Modules/Natural_constants.f90 b/src/Modules/Natural_constants.f90 new file mode 100644 index 000000000..bd17ff276 --- /dev/null +++ b/src/Modules/Natural_constants.f90 @@ -0,0 +1,16 @@ + Module Natural_Constants + + Real (Kind =8) :: eV, amu, Ang, hbar, pi + + contains + + subroutine Set_NC + + pi = acos(-1.d0) + eV = (1.0/6.24150974) *( 10.0**(-18) ) + amu = 1.66053886 * (10.0**(-27)) + Ang = 10.0**(-10) + hbar = 6.6260755*(10.0**(-34))/(2.0*pi) + + end subroutine Set_NC + end Module Natural_Constants diff --git a/src/Modules/Random_Wrap.f90 b/src/Modules/Random_Wrap.f90 new file mode 100644 index 000000000..83eae9d34 --- /dev/null +++ b/src/Modules/Random_Wrap.f90 @@ -0,0 +1,99 @@ +Module Random_Wrap + + contains + + Subroutine Get_seed_Len(K) + Implicit none + Integer :: K + CALL RANDOM_SEED (SIZE=K) + end Subroutine Get_seed_Len + + Subroutine Ranset(Iseed_vec) + Implicit none + Integer, Dimension(:) :: Iseed_vec + + Integer :: K, N, i, Iseed + Integer, allocatable :: Seed_start(:) + Real (Kind=8) :: X + + N = size(Iseed_vec) + CALL RANDOM_SEED (SIZE=K) + Allocate (SEED_start(K) ) + ! Setup SEED_start + Iseed = Iseed_vec(1) + do i = 1,K + if (i <= N) then + SEED_Start(i) = Iseed_vec(i) + else + X = Ranf_Imada(Iseed) + SEED_Start(i) = Iseed + endif + enddo + CALL RANDOM_SEED (PUT = SEED_start(1:K)) + Write(6,*) 'Starting seeds ', SEED_Start + + end Subroutine Ranset + + Subroutine Ranget(Iseed_vec) + Implicit none + Integer, Dimension(:) :: Iseed_vec + + Integer :: K, N, i, Iseed + Integer, allocatable :: Seed_end(:) + Real (Kind=8) :: X + + N = size(Iseed_vec) + CALL RANDOM_SEED (SIZE=K) + Allocate (SEED_end(K) ) + CALL RANDOM_SEED (GET = SEED_end(1:K)) + ! Setup SEED_start + Iseed = Iseed_vec(1) + do i = 1,N + if (i <= K) then + Iseed_vec(i) = SEED_end(i) + else + X = Ranf_Imada(Iseed) + Iseed_vec(i) = Iseed + endif + enddo + Write(6,*) 'End seeds ', SEED_end + + end Subroutine Ranget + + real (Kind=8) function ranf_imada(iq) + implicit none + integer iq + integer IP,IR + parameter (IP = 48828125, IR = 2147483647) + + iq=iq* IP + ! print *,'iq = ',iq + if(iq) 10,20,20 +10 iq=(iq+IR)+1 +20 ranf_imada = dble(iq)/2.0D0**31 + end function ranf_imada + + real (Kind=8) function ranf(iq) + implicit none + integer, optional :: iq + Real (Kind=8) :: X + Call Random_Number(X) + ranf = X + end function ranf + + + real (kind=8) function rang(iq) + + ! Random variable according to the distribution: exp(-x**2/2)/(sqrt(2*3.1415927)) + + integer iq + real (Kind=8) :: pi, ranmod, theta + + PI = 3.1415926536D0 + RANMOD = SQRT(-2.D0 * LOG(RANF(iq))) + THETA = 2.D0 * PI * RANF(iq) + rang = RANMOD * COS(THETA) + + end function rang + + end Module Random_Wrap diff --git a/src/Modules/errors.f90 b/src/Modules/errors.f90 new file mode 100644 index 000000000..0e4e860c1 --- /dev/null +++ b/src/Modules/errors.f90 @@ -0,0 +1,856 @@ + MODULE ERRORS + + Use MyMats + Use Random_Wrap + + INTERFACE ERRCALC + MODULE PROCEDURE ERRCALC, ERRCALC_C + END INTERFACE + INTERFACE ERRCALCJ + MODULE PROCEDURE ERRCALC_J, ERRCALC_J_REBIN, ERRCALC_JS, ERRCALC_JS_REBIN, & + & ERRCALC_J_C, ERRCALC_J_C_REBIN, ERRCALC_JS_C + END INTERFACE + INTERFACE COV + MODULE PROCEDURE COVJ, COVJS, COVJS_C + END INTERFACE + INTERFACE COV_ERR + MODULE PROCEDURE COV_ERR + END INTERFACE + INTERFACE INTERGRATE_F + MODULE PROCEDURE INTER_F + END INTERFACE + INTERFACE INTERGRATE + MODULE PROCEDURE INTER_QMC + END INTERFACE + INTERFACE FIT + MODULE PROCEDURE FIT + END INTERFACE + INTERFACE AUTO_COR + MODULE PROCEDURE AUTO_COR + END INTERFACE + INTERFACE Bootstrap + MODULE PROCEDURE Bootstrap + END INTERFACE + INTERFACE Bootstrap_fluc + MODULE PROCEDURE BootstrapC_fluc + END INTERFACE + + + + CONTAINS +!*********** + SUBROUTINE ERRCALC(EN,XM,XERR) +! Calculates error on the input vector EN. Just the standard deviation. + + IMPLICIT NONE + REAL (KIND=8), DIMENSION(:) :: EN + REAL (KIND=8) :: XM, XERR, XSQ + INTEGER :: NP, NT + + NP = SIZE(EN) + + XM = 0.D0 + XSQ = 0.D0 + DO NT = 1,NP + XM = XM + EN(NT) + XSQ = XSQ + EN(NT)**2 + ENDDO + XM = XM /DBLE(NP) + XSQ = XSQ/DBLE(NP) + XERR = (XSQ - XM**2)/DBLE(NP) + IF (XERR.GT.0.D0) THEN + XERR = SQRT(XERR) + ELSE + XERR = 0.D0 + ENDIF + + RETURN + END SUBROUTINE ERRCALC + + + SUBROUTINE ERRCALC_C(EN,ZM,ZERR) +! Calculates error on the input vector EN. Just the standard deviation. + + IMPLICIT NONE + Complex (KIND=8), DIMENSION(:) :: EN + Complex (KIND=8) :: ZM, ZERR + INTEGER :: NP, NT + + ! Local + Real (Kind=8), dimension(:), allocatable :: Rhelp + real (Kind=8) :: XM, XERR + + NP = SIZE(EN) + Allocate (Rhelp(NP)) + + do nt = 1,np + Rhelp(nt) = dble(en(nt)) + enddo + call errcalc(Rhelp, xm, xerr) + zm = cmplx(xm , 0.d0) + Zerr = cmplx(xerr, 0.d0) + + do nt = 1,np + Rhelp(nt) = aimag(en(nt)) + enddo + call errcalc(Rhelp, xm, xerr) + zm = zm + cmplx( 0.d0, xm ) + Zerr = Zerr + cmplx( 0.d0, xerr ) + + RETURN + END SUBROUTINE ERRCALC_C + + SUBROUTINE ERRCALC_J(EN,XM,XERR) +! Calculates jacknife error on the input vector EN. Mean and variance. +! The input are the bins. + + IMPLICIT NONE + + REAL (KIND=8), DIMENSION(:) :: EN + REAL (KIND=8) :: XM, XERR, X + REAL (KIND=8), DIMENSION(:), ALLOCATABLE :: EN1 + INTEGER :: NP, N, N1 + + NP = SIZE(EN) + ALLOCATE (EN1(NP)) + + ! Build the jackknife averages and send to errcalc. + + DO N = 1,NP + X = 0.D0 + DO N1 = 1,NP + IF (N1.NE.N) X = X + EN(N1) + ENDDO + EN1(N) = X / DBLE(NP -1) + ENDDO + CALL ERRCALC(EN1,XM,XERR) + XERR = XERR*DBLE(NP) + DEALLOCATE ( EN1 ) + + RETURN + END SUBROUTINE ERRCALC_J + + + SUBROUTINE ERRCALC_J_C(EN,ZM,ZERR) +! Calculates jacknife error on the input vector EN. Mean and variance. +! The input are the bins. + + IMPLICIT NONE + + COMPLEX (KIND=8), DIMENSION(:) :: EN + COMPLEX (KIND=8) :: ZM, ZERR, Z + COMPLEX (KIND=8), DIMENSION(:), ALLOCATABLE :: EN1 + INTEGER :: NP, N, N1 + + NP = SIZE(EN) + ALLOCATE (EN1(NP)) + + ! Build the jackknife averages and send to errcalc. + + DO N = 1,NP + Z = CMPLX(0.D0, 0.D0) + DO N1 = 1,NP + IF (N1.NE.N) Z = Z + EN(N1) + ENDDO + EN1(N) = Z / CMPLX(DBLE(NP -1) , 0.d0) + ENDDO + CALL ERRCALC(EN1,ZM,ZERR) + ZERR = ZERR*CMPLX(DBLE(NP),0.d0) + DEALLOCATE ( EN1 ) + + RETURN + END SUBROUTINE ERRCALC_J_C + +!************ + SUBROUTINE ERRCALC_J_C_REBIN(EN,ZM,ZERR,NREBIN) +! Calculates jacknife error on the input vector EN. Mean and variance. +! The input are the bins. + + IMPLICIT NONE + + COMPLEX (KIND=8), DIMENSION(:) :: EN + COMPLEX (KIND=8) :: ZM, ZERR, Z + COMPLEX (KIND=8), DIMENSION(:), ALLOCATABLE :: EN1 + INTEGER :: NP, N, N1, NP1, NREBIN, NC, NB + + NP = SIZE(EN) + NP1 = NP/NREBIN + ALLOCATE (EN1(NP1)) + ! Rebin + NC = 0 + DO N = 1,NP1 + Z = CMPLX(0.D0,0.D0) + DO NB = 1,NREBIN + NC = NC + 1 + Z = Z + EN(NC) + ENDDO + Z = Z/CMPLX(DBLE(NREBIN),0.d0) + EN1(N) = Z + ENDDO + CALL ERRCALC_J_C(EN1,ZM,ZERR) + + DEALLOCATE(EN1) + + END SUBROUTINE ERRCALC_J_C_REBIN + +!****************** + SUBROUTINE ERRCALC_J_REBIN(EN,XM,XERR,NREBIN) +! Calculates jacknife error on the input vector EN with rebinning. Mean and variance. +! The input are the bins. + + IMPLICIT NONE + + REAL (KIND=8), DIMENSION(:) :: EN + REAL (KIND=8) :: XM, XERR, X + REAL (KIND=8), DIMENSION(:), ALLOCATABLE :: EN1 + INTEGER :: NREBIN, NC, N, NB, NP1, NP + + NP = SIZE(EN) + NP1 = NP/NREBIN + ALLOCATE (EN1(NP1)) + + ! Rebin + NC = 0 + DO N = 1,NP1 + X = 0.D0 + DO NB = 1,NREBIN + NC = NC + 1 + X = X + EN(NC) + ENDDO + X = X/DBLE(NREBIN) + EN1(N) = X + ENDDO + CALL ERRCALC_J(EN1,XM,XERR) + + DEALLOCATE(EN1) + RETURN + END SUBROUTINE ERRCALC_J_REBIN + +!********** + SUBROUTINE ERRCALC_JS(EN,SI,XM,XERR) +! Calculates error on the input vector EN. Just the variance. +! The input are the bins + + IMPLICIT NONE + + REAL (KIND=8), DIMENSION(:) :: EN, SI + REAL (KIND=8) :: XM, XERR, X,XS + REAL (KIND=8), DIMENSION(:), ALLOCATABLE :: EN1 + INTEGER :: N, N1, NP, NP1 + + NP = SIZE(EN) + NP1= SIZE(SI) + IF (NP1.NE.NP) THEN + WRITE(6,*) 'Error in Errcalc_JS' + STOP + ENDIF + ALLOCATE (EN1(NP)) + + ! Build the jackknife averages and send to errcalc + + DO N = 1,NP + X = 0.D0 + XS = 0.D0 + DO N1 = 1,NP + IF (N1.NE.N) X = X + EN(N1) + IF (N1.NE.N) XS = XS + SI(N1) + ENDDO + EN1(N) = X / XS + ENDDO + CALL ERRCALC(EN1,XM,XERR) + XERR = XERR*DBLE(NP) + DEALLOCATE ( EN1 ) + + RETURN + END SUBROUTINE ERRCALC_JS + +!********** + SUBROUTINE ERRCALC_JS_C(EN,SI,XM,XERR) +! Calculates error on the input vector EN. Just the variance. +! The input are the bins + + IMPLICIT NONE + + COMPLEX (KIND=8), DIMENSION(:) :: EN, SI + COMPLEX (KIND=8) :: XM, XERR, X,XS + COMPLEX (KIND=8), DIMENSION(:), ALLOCATABLE :: EN1 + INTEGER :: N, N1, NP, NP1 + + NP = SIZE(EN) + NP1= SIZE(SI) + IF (NP1.NE.NP) THEN + WRITE(6,*) 'Error in Errcalc_JS' + STOP + ENDIF + ALLOCATE (EN1(NP)) + + ! Build the jackknife averages and send to errcalc + + DO N = 1,NP + X = CMPLX(0.D0,0.D0) + XS = CMPLX(0.D0,0.D0) + DO N1 = 1,NP + IF (N1.NE.N) X = X + EN(N1) + IF (N1.NE.N) XS = XS + SI(N1) + ENDDO + EN1(N) = X / XS + ENDDO + CALL ERRCALC(EN1,XM,XERR) + XERR = XERR*CMPLX(DBLE(NP),0.d0) + DEALLOCATE ( EN1 ) + + RETURN + END SUBROUTINE ERRCALC_JS_C + + + +!******** + SUBROUTINE ERRCALC_JS_REBIN(EN,SI,XM,XERR,NREBIN) +! Calculates jacknife error on the input vector EN with rebinning. Mean and variance. +! The input are the bins. + + IMPLICIT NONE + + REAL (KIND=8), DIMENSION(:) :: EN, SI + REAL (KIND=8) :: XM, XERR, X, Y + REAL (KIND=8), DIMENSION(:), ALLOCATABLE :: EN1, SI1 + INTEGER :: NREBIN, NC, N, NB, NP, NP1 + + NP = SIZE(EN) + NP1 = NP/NREBIN + ALLOCATE (EN1(NP1)) + ALLOCATE (SI1(NP1)) + + ! Rebin + NC = 0 + DO N = 1,NP1 + X = 0.D0; Y = 0.D0 + DO NB = 1,NREBIN + NC = NC + 1 + X = X + EN(NC) + Y = Y + SI(NC) + ENDDO + X = X/DBLE(NREBIN) + Y = Y/DBLE(NREBIN) + EN1(N) = X + SI1(N) = Y + ENDDO + CALL ERRCALC_JS(EN1,SI1,XM,XERR) + + DEALLOCATE (EN1,SI1) + + RETURN + END SUBROUTINE ERRCALC_JS_REBIN + +!****************** + SUBROUTINE INTER_QMC(GR, SIGN1, DTAU, RES, ERR) + + IMPLICIT NONE + ! Given GR(Times, Bins) and Sign1(Bins) calculates the integral and error + ! The sign is the same for all Times. + REAL (KIND=8), DIMENSION(:,:) :: GR + REAL (KIND=8), DIMENSION(:) :: SIGN1 + + !Local + REAL (KIND=8), DIMENSION(: ), ALLOCATABLE :: HLP + REAL (KIND=8), DIMENSION(:,:), ALLOCATABLE :: HLP1 + REAL (KIND=8) :: X, XM, XERR, Y, Err, Res, DTAU + INTEGER :: NT, NT1, NB, NB1, NTDM, NDATA + + NTDM = SIZE(GR,1) + NDATA = SIZE(GR,2) + + + ALLOCATE( HLP(NDATA), HLP1(NTDM,NDATA) ) + DO NT = 1,NTDM + DO NB= 1, NDATA + X = 0.D0 + Y = 0.D0 + DO NB1 = 1,NDATA + IF (NB1.NE.NB) THEN + X = X + GR(NT,NB1) + Y = Y + SIGN1(NB1) + ENDIF + ENDDO + HLP1(NT,NB) = X/Y + ENDDO + ENDDO + + DO NB = 1,NDATA + X = 0.D0 + DO NT = 1,NTDM-1 + X = X + (HLP1(NT,NB) + HLP1(NT+1,NB))*0.5D0 + ENDDO + HLP (NB ) = X * DTAU + ENDDO + + CALL ERRCALC(HLP, RES, ERR) + ERR = ERR*DBLE(NDATA) + + DEALLOCATE( HLP, HLP1 ) + + RETURN + END SUBROUTINE INTER_QMC + +!****************** + REAL (KIND=8) FUNCTION INTER_F(A,B,N,F) + ! integrates the function F from A to B using N points. + + IMPLICIT NONE + + INTEGER :: N, I + REAL (KIND=8) :: A, B, RES, X, X1 + REAL (KIND=8), EXTERNAL :: F + + REAL (KIND=8) :: DEL + + DEL = (B-A)/DBLE(N) + INTER_F = 0.D0 + DO I = 0, N-1 + X = A + DBLE(I )*DEL + X1 = A + DBLE(I+1)*DEL + INTER_F = INTER_F + ( F(X) + F(X1) )*0.5D0 + ENDDO + INTER_F = INTER_F*DEL + END FUNCTION INTER_F + +!****************** Least square fits: + SUBROUTINE FIT(XDATA,FDATA,ERROR,ARES,CHSQ,F) + + IMPLICIT NONE + + REAL (KIND=8), DIMENSION(:) :: XDATA, FDATA, ERROR, ARES + REAL (KIND=8) :: CHSQ, X + REAL (KIND=8), DIMENSION(:,:), ALLOCATABLE :: A, U,V,VINV,V1 + REAL (KIND=8), DIMENSION(: ), ALLOCATABLE :: B,D + REAL (KIND=8), EXTERNAL :: F + INTEGER :: NDATA, NBASIS, I, M, M1, NCON, N + + NDATA = SIZE(XDATA) + NBASIS= SIZE(ARES) + + !WRITE(6,*) 'NDATA, NBASIS: ',NDATA, NBASIS + ALLOCATE (A(NDATA,NBASIS)) + ALLOCATE (U(NDATA,NBASIS)) + ALLOCATE (D(NBASIS)) + ALLOCATE (V (NBASIS,NBASIS)) + ALLOCATE (V1 (NBASIS,NBASIS)) + ALLOCATE (VINV(NBASIS,NBASIS)) + ALLOCATE (B(NDATA)) + + A = 0.D0 + U = 0.D0 + D = 0.D0 + V = 0.D0 + VINV = 0.D0 + V1 = 0.D0 + B = 0.D0 + NCON = 1 + DO M = 1,NBASIS + DO I = 1,NDATA + A(I,M) = F(M,XDATA(I))/ERROR(I) + ENDDO + ENDDO + DO I = 1,NDATA + B(I) = FDATA(I)/ERROR(I) + ENDDO + !write(6,*) A + CALL UDV(A,U,D,V,NCON) + DO M = 1,NBASIS + DO I = 1,NBASIS + V1(I,M) = V(M,I) + ENDDO + ENDDO + X = 0.D0 + CALL INV(V1,VINV,X) + + DO M1 = 1,NBASIS + X = 0.D0 + DO M = 1,NBASIS + DO I = 1,NDATA + X = X + B(I)*U(I,M)*VINV(M,M1)/D(M) + ENDDO + ENDDO + ARES(M1) = X + ENDDO + + CHSQ = 0.D0 + DO N = 1,NDATA + X = 0.D0 + DO M = 1,NBASIS + X = X + ARES(M)*F(M,XDATA(N)) + ENDDO + CHSQ = CHSQ + (FDATA(N) - X)**2/ERROR(N)**2 + ENDDO + CHSQ = CHSQ/DBLE(NDATA) + + DEALLOCATE (A) + DEALLOCATE (U) + DEALLOCATE (D) + DEALLOCATE (V) + DEALLOCATE (V1) + DEALLOCATE (VINV) + DEALLOCATE (B) + + END SUBROUTINE FIT + + SUBROUTINE COVJ(GR, XCOV, XMEAN) + + IMPLICIT NONE + !Given GR(Times, Bins) calculates the mean and the covariance. + REAL (KIND=8), DIMENSION(:,:) :: GR, XCOV + REAL (KIND=8), DIMENSION(:) :: XMEAN + + !Local + REAL (KIND=8), DIMENSION(: ), ALLOCATABLE :: HLP + REAL (KIND=8), DIMENSION(:,:), ALLOCATABLE :: HLP1 + REAL (KIND=8) :: X, XM, XERR + INTEGER :: NT, NT1, NB, NB1, NTDM, NDATA + + NTDM = SIZE(GR,1) + NDATA = SIZE(GR,2) + + IF ( (SIZE(XCOV,1).NE.SIZE(XCOV,2) ) .OR. (SIZE(XCOV,1).NE.NTDM) ) THEN + WRITE(6,*) 'Error in COV' + STOP + ENDIF + + ALLOCATE( HLP(NDATA), HLP1(NTDM,NDATA) ) + DO NT = 1,NTDM + DO NB= 1, NDATA + X = 0.0 + DO NB1 = 1,NDATA + IF (NB1.NE.NB) THEN + X = X + GR(NT,NB1) + ENDIF + ENDDO + HLP1(NT,NB) = X/DBLE(NDATA-1) + HLP (NB ) = X/DBLE(NDATA-1) + ENDDO + CALL ERRCALC(HLP,XM ,XERR) + XMEAN(NT) = XM + ENDDO + + + DO NT = 1,NTDM + DO NT1= 1,NTDM + X = 0.0 + DO NB = 1,NDATA + X = X + HLP1(NT,NB)*HLP1(NT1,NB) + ENDDO + X = X/DBLE(NDATA) + XCOV(NT,NT1) = ( X - XMEAN(NT)*XMEAN(NT1) )*DBLE(NDATA) + ENDDO + ENDDO + + + DEALLOCATE( HLP, HLP1 ) + + RETURN + END SUBROUTINE COVJ + + + SUBROUTINE COVJS(GR, SIGN1, XCOV, XMEAN) + + IMPLICIT NONE + ! Given GR(Times, Bins) and Sign1(Bins) calculates the mean and the covariance. + ! The sign is the same for all Times. + REAL (KIND=8), DIMENSION(:,:) :: GR, XCOV + REAL (KIND=8), DIMENSION(:) :: XMEAN, SIGN1 + + !Local + REAL (KIND=8), DIMENSION(: ), ALLOCATABLE :: HLP + REAL (KIND=8), DIMENSION(:,:), ALLOCATABLE :: HLP1 + REAL (KIND=8) :: X, XM, XERR, Y + INTEGER :: NT, NT1, NB, NB1, NTDM, NDATA + + NTDM = SIZE(GR,1) + NDATA = SIZE(GR,2) + + IF ( (SIZE(XCOV,1).NE.SIZE(XCOV,2) ) .OR. (SIZE(XCOV,1).NE.NTDM) ) THEN + WRITE(6,*) 'Error in COV' + STOP + ENDIF + + ALLOCATE( HLP(NDATA), HLP1(NTDM,NDATA) ) + DO NT = 1,NTDM + DO NB= 1, NDATA + X = 0.D0 + Y = 0.D0 + DO NB1 = 1,NDATA + IF (NB1.NE.NB) THEN + X = X + GR(NT,NB1) + Y = Y + SIGN1(NB1) + ENDIF + ENDDO + HLP1(NT,NB) = X/Y + HLP (NB ) = X/Y + ENDDO + CALL ERRCALC(HLP,XM ,XERR) + XMEAN(NT) = XM + ENDDO + + + DO NT = 1,NTDM + DO NT1= 1,NTDM + X = 0.0 + DO NB = 1,NDATA + X = X + HLP1(NT,NB)*HLP1(NT1,NB) + ENDDO + X = X/DBLE(NDATA) + XCOV(NT,NT1) = ( X - XMEAN(NT)*XMEAN(NT1) )*DBLE(NDATA) + ENDDO + ENDDO + + + DEALLOCATE( HLP, HLP1 ) + + RETURN + END SUBROUTINE COVJS + + + + + SUBROUTINE COVJS_C(GR, SIGN1, XCOV, XMEAN) + + IMPLICIT NONE + ! Given GR(Times, Bins) and Sign1(Bins) calculates the mean and the covariance. + ! The sign is the same for all Times. + Complex (KIND=8), DIMENSION(:,:) :: GR, XCOV + Complex (KIND=8), DIMENSION(:) :: XMEAN + Real (Kind=8), DIMENSION(:) :: SIGN1 + + + !Local + REAL (KIND=8), DIMENSION(: ), ALLOCATABLE :: HLP, XMEAN_R + REAL (KIND=8), DIMENSION(:,:), ALLOCATABLE :: HLP1 + REAL (KIND=8) :: X, XM, XERR, Y + INTEGER :: NT, NT1, NB, NB1, NTDM, NDATA, Nth + COMPLEX (KIND=8) :: Z + + NTDM = SIZE(GR,1) + NDATA = SIZE(GR,2) + + + !Write(6,*) 'Errors.f90 ', NTDM, NDATA + IF ( (SIZE(XCOV,1).NE.SIZE(XCOV,2) ) .OR. (SIZE(XCOV,1).NE.NTDM) ) THEN + WRITE(6,*) 'Error in COV' + STOP + ENDIF + + + + ALLOCATE( HLP(NDATA), HLP1(NTDM,NDATA), XMEAN_R(NTDM) ) + XMEAN = CMPLX(0.d0,0.d0) + XCOV = CMPLX(0.d0,0.d0) + + DO NTH = 1,2 + Z = CMPLX(1.0, 0.0) + IF (NTH .EQ. 2 ) Z = CMPLX( 0.0, -1.0 ) + DO NT = 1,NTDM + DO NB= 1, NDATA + X = 0.D0 + Y = 0.D0 + DO NB1 = 1,NDATA + IF (NB1.NE.NB) THEN + X = X + DBLE ( Z*GR(NT,NB1) ) + Y = Y + SIGN1(NB1) + ENDIF + ENDDO + HLP1(NT,NB) = X/Y + HLP (NB ) = X/Y + ENDDO + CALL ERRCALC(HLP,XM ,XERR) + XMEAN(NT) = XMEAN(NT) + CONJG(Z)*CMPLX(XM,0.d0) + XMEAN_R(NT) = XM + !if (Nth.eq.2) write(6,*) XM + ENDDO + + + DO NT = 1,NTDM + DO NT1= 1,NTDM + X = 0.0 + DO NB = 1,NDATA + X = X + HLP1(NT,NB)*HLP1(NT1,NB) + ENDDO + X = X/DBLE(NDATA) + XCOV(NT,NT1) = XCOV(NT,NT1) + CONJG(Z)* & + & CMPLX( ( X - XMEAN_R(NT)*XMEAN_R(NT1) )*DBLE(NDATA) , 0.d0 ) + ENDDO + ENDDO + ENDDO + + DEALLOCATE( HLP, HLP1, XMEAN_R ) + + RETURN + END SUBROUTINE COVJS_C + + + + + Subroutine COV_ERR(XMEAN, XCOV, ISEED) + ! Given Mean and Cov, diagonalizes the COV and produces a new data set within + ! the errorbars + + Implicit None + ! Parameters + REAL (KIND=8), DIMENSION(:,:) :: XCOV + REAL (KIND=8), DIMENSION(:) :: XMEAN + + Integer :: ntau, I, M, ISeed + Real (Kind = 8) :: X + + Real (Kind=8), Dimension(:,:), allocatable :: UC + Real (Kind=8), Dimension(:), allocatable :: XMEAN_1, SIG_1 + + ntau = size(Xmean,1) + Allocate (UC(ntau,ntau), XMEAN_1(ntau), SIG_1(ntau) ) + + CALL DIAG(XCOV,UC,SIG_1) + + DO I = 1,NTAU + X = 0.D0 + DO M = 1,NTAU + X = X + UC(M,I)* XMEAN(M) + ENDDO + XMEAN_1(I) = X + ENDDO + DO I = 1,NTAU + IF (SIG_1(I).LT.0.d0) Then + write(6,*) 'Error in Cov_err', SIG_1(I) + Endif + XMEAN_1(I) = XMEAN_1(I) + SQRT(ABS(SIG_1(I)))*RANG(ISEED) + ENDDO + DO I = 1,NTAU + X = 0.D0 + DO M = 1,NTAU + X = X + UC(I,M)*XMEAN_1(M) + ENDDO + XMEAN(I) = X + ENDDO + + Deallocate (UC, XMEAN_1, SIG_1) + + + END Subroutine COV_ERR + + SUBROUTINE AUTO_COR(DATA,RES) + + Implicit none + + REAL (Kind=8), DIMENSION(:) :: DATA,RES + + !Local + Integer :: nb, nt, ntau, nt1 + Real (Kind=8) :: X1, X2, X3 + + nb = SIZE(DATA) + nt = SIZE(RES) + if (nb.lt.nt) then + write(6,*) 'Error in autocor' + stop + end if + + DO ntau = 1, nt + X1 = 0.0 + X2 = 0.0 + X3 = 0.0 + DO nt1 = 1, nb - ntau + X1 = X1 + DATA(nt1)*DATA(nt1 + ntau) + X2 = X2 + DATA(nt1)*DATA(nt1) + X3 = X3 + DATA(nt1) + ENDDO + X1 = X1 / dble(nb - ntau) + X2 = X2 / dble(nb - ntau) + X3 = X3 / dble(nb - ntau) + + Res(ntau) = ( X1 - X3**2)/(X2 - X3**2) + + ENDDO + + END SUBROUTINE AUTO_COR + + SUBROUTINE BOOTSTRAPC_FLUC(A,B,AB,NBOOT,ISEED,ZM,ZERR) + !!! COMPUTES - + IMPLICIT NONE + COMPLEX (KIND=8), DIMENSION(:), INTENT(IN) :: A,B,AB + INTEGER, INTENT(IN) :: NBOOT + INTEGER, INTENT(INOUT) :: ISEED + COMPLEX (KIND=8), INTENT(OUT) :: ZM,ZERR + + !Local + INTEGER :: NP, NB, I, J + COMPLEX (KIND=8) :: Z, Z1,Z2,Z12 + !REAL (KIND=8), EXTERNAL :: RANF + + NP = SIZE(A,1) + ZM = CMPLX(0.d0,0.d0,Kind=8) + ZERR = CMPLX(0.d0,0.d0,Kind=8) + DO NB = 1, NBOOT + Z1 = cmplx(0.d0,0.d0,Kind=8) + Z2 = cmplx(0.d0,0.d0,Kind=8) + Z12 = cmplx(0.d0,0.d0,Kind=8) + DO I = 1,NP + J = NINT( DBLE(NP)* RANF(ISEED) + 0.5 ) + IF (J == 0) J = 1 + IF (J > NP) J = NP + Z1 = Z1 + A(J) + Z2 = Z2 + B(J) + Z12 =Z12 + AB(J) + ENDDO + Z1 = Z1 /CMPLX(DBLE(NP),0.d0,Kind=8) + Z2 = Z2 /CMPLX(DBLE(NP),0.d0,Kind=8) + Z12 =Z12/CMPLX(DBLE(NP),0.d0,Kind=8) + + Z = Z12 - Z1*Z2 + ZM = ZM + Z + ZERR = ZERR + Z*Z + ENDDO + ZM = ZM /CMPLX(DBLE(NBOOT),0.d0,Kind=8) + ZERR = ZERR/CMPLX(DBLE(NBOOT),0.d0,Kind=8) + + Z = ZERR - ZM*ZM + ZERR = SQRT(Z) + + END SUBROUTINE BOOTSTRAPC_FLUC + + SUBROUTINE BOOTSTRAP(EN,XM,XERR,NBOOT,ISEED) + + IMPLICIT NONE + REAL (KIND=8), DIMENSION(:) :: EN + REAL (KIND=8) :: XM, XERR, X + INTEGER :: NP, NT, NBOOT, NB, I, ISEED + + NP = SIZE(EN) + + ! Build the Bootstrap samples + + XM = 0.D0 + XERR = 0.D0 + DO NB = 1,NBOOT + X = 0.D0 + DO NT = 1, NP + I = NINT( DBLE(NP)* RANF(ISEED) + 0.5 ) + IF (I.EQ.0 .OR. I.GT.NP ) THEN + WRITE(6,*) 'ERROR IN BOOTSTRAP' + STOP + ENDIF + X = X + EN(I) + ENDDO + X = X/DBLE(NP) + XM = XM + X + XERR = XERR + X*X + ENDDO + + XM = XM /DBLE(NBOOT) + XERR = XERR/DBLE(NBOOT) + + X = XERR - XM*XM + XERR = 0.d0 + IF (X.GT.0.d0) XERR = SQRT(X) + + END SUBROUTINE BOOTSTRAP + + END MODULE ERRORS + + diff --git a/src/Modules/fourier.f90 b/src/Modules/fourier.f90 new file mode 100644 index 000000000..1e92d9710 --- /dev/null +++ b/src/Modules/fourier.f90 @@ -0,0 +1,1592 @@ +Module Fourier + Use MaxEnt_mod + Use MaxEnt_stoch_mod + Use Matrix + + interface Matz_tau + module procedure Matz_tau_T, Matz_tau_T0, Matz_tau_T0_all, Matz_tau_T_all, Matz_tau_T_all_C, & + & Matz_tau_T_cdmft + end interface + + interface Matz_tau_Bose + module procedure Matz_tau_T_Bose + end interface + + interface Tau_Matz + module procedure Tau_Matz_T, Tau_Matz_T0, Tau_Matz_T0_all, Tau_Matz_T_all,& + & tau_matz_spline, tau_matz_spline_all, Tau_Matz_T_stoch, Tau_Matz_T_all_stoch, & + & Tau_Matz_T_all_stoch_C, Tau_Matz_T0_stoch , Tau_Matz_T_all_stoch_cdmft + end interface + + interface Tau_Matz_Bose + module procedure Tau_Matz_T_Bose + end interface + + contains + +!******** + subroutine Matz_tau_T(griom, xiom, grtau, xtau, beta) + implicit none + ! Given the G(i omega) calculates G(tau). + real (Kind=8), Dimension(:) :: xiom, xtau + real (Kind=8) :: beta + complex (Kind=8), Dimension(:) :: griom + real (Kind=8), Dimension(:) :: grtau + + + Integer :: Niom, Ntau, nt, niw, Ntail + Real (Kind=8) :: a,b, x + complex (Kind=8) :: z, z1 + complex (Kind=8), Dimension(:), allocatable :: griom1 + + Niom = size( xiom ,1 ) + Ntau = size( xtau, 1 ) + + allocate ( griom1(Niom) ) + + a = 0.d0 + b = 0.d0 + Ntail = 10 + do niw = Niom - Ntail, Niom + a = a + dble( griom(niw) * cmplx(0.d0,xiom(niw) ) ) + b = b + dble( griom(niw) * ( cmplx(0.d0,xiom(niw)) *cmplx(0.d0,xiom(niw)) ) ) + enddo + a = a/dble(Ntail + 1) + b = b/dble(Ntail + 1) + write(6,*) 'Fourier: a, b ', a, b + a = 1.d0 + do niw = 1,Niom + griom1(niw) = griom(niw)-cmplx(a,0.d0)/cmplx(0.d0,xiom(niw)) & + & -cmplx(b,0.d0)/ ( cmplx(0.d0,xiom(niw))*cmplx(0.d0,xiom(niw)) ) + enddo + + do nt = 1,Ntau + x = 0.d0 + do niw = 1,Niom + x = x + dble(exp( cmplx(0.d0,-xiom(niw)*xtau(nt)) ) *griom1(niw))*2.d0 + enddo + grtau(nt) = x/beta - a/2.d0 + b*xtau(nt)/2.d0 - beta * b/4.d0 + enddo + + deallocate ( griom1 ) + + end subroutine Matz_tau_T + +!------------------ + subroutine Matz_Tau_T_Bose(griom, xiom, grtau, xtau, beta) + !Working on this + implicit none + ! Given the G(i omega) calculates G(tau) ! for bosons. + real (Kind=8), Dimension(:) :: xiom, xtau + real (Kind=8) :: beta + real (Kind=8), Dimension(:) :: griom + real (Kind=8), Dimension(:) :: grtau + + + Integer :: Niom, Ntau, nt, niw, Ntail + Real (Kind=8) :: a,b, x + complex (Kind=8) :: z, z1 + complex (Kind=8), Dimension(:), allocatable :: griom1 + + Niom = size( xiom ,1 ) + Ntau = size( xtau, 1 ) + + allocate ( griom1(Niom) ) + + ! No tail really necessary since decays as 1/Om**2 + !a = 0.d0 + !b = 0.d0 + !Ntail = 10 + !do niw = Niom - Ntail, Niom + ! a = a + dble( griom(niw) * cmplx(0.d0,xiom(niw) ) ) + ! b = b + dble( griom(niw) * ( cmplx(0.d0,xiom(niw)) *cmplx(0.d0,xiom(niw)) ) ) + !enddo + !a = a/dble(Ntail + 1) + !b = b/dble(Ntail + 1) + !!write(6,*) 'Fourier: a, b ', a, b + !!a = 1.d0 + !do niw = 1,Niom + ! griom1(niw) = griom(niw) - cmplx(a,0.d0)/ cmplx( 0.d0,xiom(niw) ) & + ! & - cmplx(b,0.d0)/ ( cmplx( 0.d0,xiom(niw) ) * cmplx(0.d0,xiom(niw)) ) + !enddo + + do nt = 1,Ntau + x = 0.d0 + do niw = 1,Niom + if ( xiom(niw).gt.0.d0) then + x = x + dble(exp( cmplx(0.d0,-xiom(niw)*xtau(nt)) ) * griom(niw))*2.d0 + else + x = x + dble(exp( cmplx(0.d0,-xiom(niw)*xtau(nt)) ) * griom(niw)) + endif + enddo + grtau(nt) = x/beta ! - a/2.d0 + b*xtau(nt)/2.d0 - beta * b/4.d0 + enddo + + deallocate ( griom1 ) + + end subroutine Matz_Tau_T_Bose + + + +!******** + subroutine Matz_tau_T0(griom, xiom, grt0, gr0t, xtau, beta) + implicit none + ! Given the G(i omega) calculates G(tau). + real (Kind=8), Dimension(:) :: xiom, xtau + real (Kind=8) :: beta + complex (Kind=8), Dimension(:) :: griom + real (Kind=8), Dimension(:) :: grt0, gr0t + + + + Integer :: Niom, Ntau, nt, niw, Ntail + Real (Kind=8) :: a,b, xp, xm + complex (Kind=8) :: z, z1 + complex (Kind=8), Dimension(:), allocatable :: griom1 + + Niom = size( xiom ,1 ) + Ntau = size( xtau, 1 ) + + allocate ( griom1(Niom) ) + + a = 0.d0 + b = 0.d0 + Ntail = 10 + do niw = Niom - Ntail, Niom + a = a + dble( griom(niw) * cmplx(0.d0,xiom(niw) ) ) + b = b + dble( griom(niw) * ( cmplx(0.d0,xiom(niw)) *cmplx(0.d0,xiom(niw)) ) ) + enddo + a = a/dble(Ntail + 1) + b = b/dble(Ntail + 1) + write(6,*) 'Fourier: a, b ', a, b + a = 1.d0 + do niw = 1,Niom + griom1(niw) = griom(niw) - cmplx(a,0.d0)/ cmplx(0.d0,xiom(niw)) & + & - cmplx(b,0.d0)/( cmplx(0.d0,xiom(niw)) * cmplx(0.d0,xiom(niw)) ) + enddo + + do nt = 1,Ntau + xp = 0.d0 + xm = 0.d0 + do niw = 1,Niom + xp = xp + dble(exp( cmplx(0.d0,-xiom(niw)*xtau(nt)) ) *griom1(niw))*2.d0 + xm = xm + dble(exp( cmplx(0.d0, xiom(niw)*xtau(nt)) ) *griom1(niw))*2.d0 + enddo + grt0(nt) = xp/beta - a/2.d0 + b*xtau(nt) /2.d0 - beta * b/4.d0 + gr0t(nt) = xm/beta + a/2.d0 - b*(-xtau(nt))/2.d0 - beta * b/4.d0 + enddo + + deallocate ( griom1 ) + + end subroutine Matz_tau_T0 + +!********** + subroutine Matz_tau_T0_all(g_iom, xiom, g_t0, g_0t, xtau, beta) + implicit none + ! Given the G(i omega) calculates G(tau). + real (Kind=8), Dimension(:) :: xiom, xtau + real (Kind=8) :: beta + Type (Mat_C), Dimension(:,:) :: g_iom + Type (Mat_R), Dimension(:,:) :: g_t0, g_0t + + Complex (Kind=8), Dimension(:), allocatable :: giom + Real (Kind=8), Dimension(:), allocatable :: gt0, g0t + + Integer :: Niom, Ntau, nt, niw, Norb, LQ_C + Integer :: nk, no1, no2 + Complex (Kind=8) :: Z1, Z2 + + Write (6,*) "Size of griom: ", size(g_iom,1), size(g_iom,2) + Write (6,*) "Size of grt0 : ", size(g_t0,1), size(g_t0,2) + Write (6,*) "# of orbitals: ", Size(g_t0(1,1)%el,1), Size(g_t0(1,1)%el,2) + Ntau = size(g_t0,2) + If ( Ntau.ne.size(g_0t,2) .OR. Ntau.ne.size(xtau,1) ) Then + write(6,*) 'Error in ntau! (Fourier, Matz_tau_T0_all) ' + endif + LQ_c = size(g_t0,1) + If ( LQ_c.ne.size(g_0t,1) .OR. LQ_C.ne.size(g_iom,1) ) Then + write(6,*) 'Error in LQ_C! (Fourier, Matz_tau_T0_all) ' + endif + Niom = size(g_iom,2) + If ( Niom.ne.size(xiom,1) ) Then + write(6,*) 'Error in Niom! (Fourier, Matz_tau_T0_all) ' + endif + + Norb = Size(g_t0(1,1)%el,1) + Allocate (giom(Niom), gt0(Ntau), g0t(Ntau) ) + + + Do nk = 1,LQ_C + Do no1 = 1,Norb + Do no2 = 1,Norb + If (no1.eq.no2) then + do niw = 1,Niom + giom(niw) = g_iom(nk,niw)%el(no1,no1) + enddo + elseif (no2.gt.no1) then + ! Build Gamma + do niw = 1,Niom + giom(niw) = ( g_iom(nk,niw)%el(no1,no1) + & + & g_iom(nk,niw)%el(no2,no2) + & + & g_iom(nk,niw)%el(no1,no2) + & + & g_iom(nk,niw)%el(no2,no1) ) / cmplx(2.0,0.d0) + enddo + else + ! Build eta + do niw = 1,Niom + giom(niw) = ( g_iom(nk,niw)%el(no1,no1) + & + & g_iom(nk,niw)%el(no2,no2) - & + & g_iom(nk,niw)%el(no1,no2) - & + & g_iom(nk,niw)%el(no2,no1) ) / cmplx(2.0,0.d0) + enddo + endif + Call Matz_tau_T0(giom, xiom, gt0, g0t, xtau, beta) + do nt = 1,ntau + g_0t(nk,nt)%el(no1,no2) = g0t(nt) + g_t0(nk,nt)%el(no1,no2) = gt0(nt) + enddo + enddo + enddo + do nt = 1,ntau + do no1 = 1,Norb + do no2 = no1+1, Norb + Z1 = g_0t(nk,nt)%el(no1,no2) + Z2 = g_0t(nk,nt)%el(no2,no1) + g_0t(nk,nt)%el(no1,no2) = (Z1 - Z2 )/cmplx(2.0,0.0) + g_0t(nk,nt)%el(no2,no1) = (Z1 - Z2 )/cmplx(2.0,0.0) + + Z1 = g_t0(nk,nt)%el(no1,no2) + Z2 = g_t0(nk,nt)%el(no2,no1) + g_t0(nk,nt)%el(no1,no2) = (Z1 - Z2 )/cmplx(2.0,0.0) + g_t0(nk,nt)%el(no2,no1) = (Z1 - Z2 )/cmplx(2.0,0.0) + enddo + enddo + enddo + + enddo + + Deallocate (giom, gt0, g0t ) + + end subroutine Matz_tau_T0_all + +!********** + subroutine Matz_tau_T_all(g_iom, xiom, g_t0, xtau, beta) + implicit none + ! Given the G(i omega) calculates G(tau). + real (Kind=8), Dimension(:) :: xiom, xtau + real (Kind=8) :: beta + Type (Mat_C), Dimension(:,:) :: g_iom + Type (Mat_R), Dimension(:,:) :: g_t0 + + Complex (Kind=8), Dimension(:), allocatable :: giom + Real (Kind=8), Dimension(:), allocatable :: gt0 + + Integer :: Niom, Ntau, nt, niw, Norb, LQ_C + Integer :: nk, no1, no2 + Complex (Kind=8) :: Z1, Z2 + + Write (6,*) "Size of griom: ", size(g_iom,1), size(g_iom,2) + Write (6,*) "Size of grt0 : ", size(g_t0,1), size(g_t0,2) + Write (6,*) "# of orbitals: ", Size(g_t0(1,1)%el,1), Size(g_t0(1,1)%el,2) + Ntau = size(g_t0,2) + If ( Ntau.ne.size(xtau,1) ) Then + write(6,*) 'Error in ntau! (Fourier, Matz_tau_T0_all) ' + endif + LQ_c = size(g_t0,1) + If ( LQ_C.ne.size(g_iom,1) ) Then + write(6,*) 'Error in LQ_C! (Fourier, Matz_tau_T0_all) ' + endif + Niom = size(g_iom,2) + If ( Niom.ne.size(xiom,1) ) Then + write(6,*) 'Error in Niom! (Fourier, Matz_tau_T0_all) ' + endif + + Norb = Size(g_t0(1,1)%el,1) + Allocate (giom(Niom), gt0(Ntau) ) + + + Do nk = 1,LQ_C + Do no1 = 1,Norb + Do no2 = 1,Norb + If (no1.eq.no2) then + do niw = 1,Niom + giom(niw) = g_iom(nk,niw)%el(no1,no1) + enddo + elseif (no2.gt.no1) then + ! Build Gamma + do niw = 1,Niom + giom(niw) = ( g_iom(nk,niw)%el(no1,no1) + & + & g_iom(nk,niw)%el(no2,no2) + & + & g_iom(nk,niw)%el(no1,no2) + & + & g_iom(nk,niw)%el(no2,no1) ) / cmplx(2.0,0.d0) + enddo + else + ! Build eta + do niw = 1,Niom + giom(niw) = ( g_iom(nk,niw)%el(no1,no1) + & + & g_iom(nk,niw)%el(no2,no2) - & + & g_iom(nk,niw)%el(no1,no2) - & + & g_iom(nk,niw)%el(no2,no1) ) / cmplx(2.0,0.d0) + enddo + endif + Call Matz_tau_T(giom, xiom, gt0, xtau, beta) + !write(6,*) 'Back in Matz_tau_T_all' + do nt = 1,ntau + g_t0(nk,nt)%el(no1,no2) = gt0(nt) + enddo + enddo + enddo + do nt = 1,ntau + do no1 = 1,Norb + do no2 = no1+1, Norb + Z1 = g_t0(nk,nt)%el(no1,no2) + Z2 = g_t0(nk,nt)%el(no2,no1) + g_t0(nk,nt)%el(no1,no2) = (Z1 - Z2 )/cmplx(2.0,0.0) + g_t0(nk,nt)%el(no2,no1) = (Z1 - Z2 )/cmplx(2.0,0.0) + enddo + enddo + enddo + + enddo + + Deallocate (giom, gt0 ) + + end subroutine Matz_tau_T_all +!********** + +!********** + subroutine Matz_tau_T_cdmft(g_iom, xiom, g_t0, xtau, beta) + implicit none + ! Given the G(i omega) calculates G(tau). + real (Kind=8), Dimension(:) :: xiom, xtau + real (Kind=8) :: beta + Type (Mat_C), Dimension(:) :: g_iom + Type (Mat_R), Dimension(:) :: g_t0 + + Complex (Kind=8), Dimension(:), allocatable :: giom + Real (Kind=8), Dimension(:), allocatable :: gt0 + + Integer :: Niom, Ntau, nt, niw, Norb + Integer :: nk, no1, no2 + Complex (Kind=8) :: Z1, Z2 + + Write (6,*) "Size of griom: ", size(g_iom,1) + Write (6,*) "Size of grt0 : ", size(g_t0,1) + Write (6,*) "# of orbitals: ", Size(g_t0(1)%el,1) + Ntau = size(g_t0,1) + If ( Ntau.ne.size(xtau,1) ) Then + write(6,*) 'Error in ntau! (Fourier, Matz_tau_T0_all) ' + endif + Niom = size(g_iom,1) + If ( Niom.ne.size(xiom,1) ) Then + write(6,*) 'Error in Niom! (Fourier, Matz_tau_T0_all) ' + endif + + Norb = Size(g_t0(1)%el,1) + Allocate ( giom(Niom), gt0(Ntau) ) + + + Do no1 = 1,Norb + Do no2 = 1,Norb + If (no1.eq.no2) then + do niw = 1,Niom + giom(niw) = g_iom(niw)%el(no1,no1) + enddo + elseif (no2.gt.no1) then + ! Build Gamma + do niw = 1,Niom + giom(niw) = ( g_iom(niw)%el(no1,no1) + & + & g_iom(niw)%el(no2,no2) + & + & g_iom(niw)%el(no1,no2) + & + & g_iom(niw)%el(no2,no1) ) / cmplx(2.0,0.d0) + enddo + else + ! Build eta + do niw = 1,Niom + giom(niw) = ( g_iom(niw)%el(no1,no1) + & + & g_iom(niw)%el(no2,no2) - & + & g_iom(niw)%el(no1,no2) - & + & g_iom(niw)%el(no2,no1) ) / cmplx(2.0,0.d0) + enddo + endif + Call Matz_tau_T(giom, xiom, gt0, xtau, beta) + !write(6,*) 'Back in Matz_tau_T_all' + do nt = 1,ntau + g_t0(nt)%el(no1,no2) = gt0(nt) + enddo + enddo + enddo + do nt = 1,ntau + do no1 = 1,Norb + do no2 = no1+1, Norb + Z1 = g_t0(nt)%el(no1,no2) + Z2 = g_t0(nt)%el(no2,no1) + g_t0(nt)%el(no1,no2) = (Z1 - Z2 )/cmplx(2.0,0.0) + g_t0(nt)%el(no2,no1) = (Z1 - Z2 )/cmplx(2.0,0.0) + enddo + enddo + enddo + + Deallocate (giom, gt0 ) + + end subroutine Matz_tau_T_cdmft +!********** + + +!---------- + subroutine Matz_tau_T_all_C(g_iom, xiom, g_t0, xtau, beta) + implicit none + ! Given the G(i omega) calculates G(tau). + real (Kind=8), Dimension(:) :: xiom, xtau + real (Kind=8) :: beta + Type (Mat_C), Dimension(:,:) :: g_iom + Type (Mat_C), Dimension(:,:) :: g_t0 + + Complex (Kind=8), Dimension(:), allocatable :: giom + Real (Kind=8), Dimension(:), allocatable :: gt0 + + Integer :: Niom, Ntau, nt, niw, Norb, LQ_C + Integer :: nk, no1, no2 + Complex (Kind=8) :: Z1, Z2 + + Write (6,*) "In Matz_tau_T_all_C" + Write (6,*) "Size of griom: ", size(g_iom,1), size(g_iom,2) + Write (6,*) "Size of grt0 : ", size(g_t0,1), size(g_t0,2) + Write (6,*) "# of orbitals: ", Size(g_t0(1,1)%el,1), Size(g_t0(1,1)%el,2) + Ntau = size(g_t0,2) + If ( Ntau.ne.size(xtau,1) ) Then + write(6,*) 'Error in ntau! (Fourier, Matz_tau_T0_all) ' + endif + LQ_c = size(g_t0,1) + If ( LQ_C.ne.size(g_iom,1) ) Then + write(6,*) 'Error in LQ_C! (Fourier, Matz_tau_T0_all) ' + endif + Niom = size(g_iom,2) + If ( Niom.ne.size(xiom,1) ) Then + write(6,*) 'Error in Niom! (Fourier, Matz_tau_T0_all) ' + endif + + Norb = Size(g_t0(1,1)%el,1) + Allocate (giom(Niom), gt0(Ntau) ) + + + Do nk = 1,LQ_C + Do no1 = 1,Norb + Do no2 = 1,Norb + If (no1.eq.no2) then + do niw = 1,Niom + giom(niw) = g_iom(nk,niw)%el(no1,no1) + enddo + elseif (no2.gt.no1) then + ! Build Gamma + do niw = 1,Niom + giom(niw) = ( g_iom(nk,niw)%el(no1,no1) + & + & g_iom(nk,niw)%el(no2,no2) + & + & g_iom(nk,niw)%el(no1,no2) + & + & g_iom(nk,niw)%el(no2,no1) ) / cmplx(2.0,0.d0) + enddo + else + ! Build eta + do niw = 1,Niom + giom(niw) = ( g_iom(nk,niw)%el(no1,no1) + & + & g_iom(nk,niw)%el(no2,no2) + cmplx(0.d0,1.d0) * ( & + & g_iom(nk,niw)%el(no2,no1) - g_iom(nk,niw)%el(no1,no2) ) ) /& + & cmplx(2.d0,0.d0) + enddo + endif + Call Matz_tau_T(giom, xiom, gt0, xtau, beta) + !write(6,*) 'Back in Matz_tau_T_all' + do nt = 1,ntau + g_t0(nk,nt)%el(no1,no2) = cmplx(gt0(nt), 0.d0) + enddo + enddo + enddo + do nt = 1,ntau + do no1 = 1,Norb + do no2 = no1+1, Norb + Z1 = g_t0(nk,nt)%el(no1,no2) - & + & (g_t0(nk,nt)%el(no1,no1) + g_t0(nk,nt)%el(no2,no2) )/cmplx(2.d0,0.d0) + Z2 = g_t0(nk,nt)%el(no2,no1) - & + & (g_t0(nk,nt)%el(no1,no1) + g_t0(nk,nt)%el(no2,no2) )/cmplx(2.d0,0.d0) + g_t0(nk,nt)%el(no1,no2) = Z1 + cmplx(0.0,1.d0) * Z2 + g_t0(nk,nt)%el(no2,no1) = Z1 - cmplx(0.0,1.d0) * Z2 + enddo + enddo + enddo + + enddo + + Deallocate (giom, gt0 ) + + end subroutine Matz_tau_T_all_C + +!------------ + + + + subroutine Tau_Matz_T(griom, xiom, grtau, xtau, beta, A, xom, cov) + Implicit none + + !Arguments + Complex (Kind=8), Dimension(:) :: griom + Real (Kind=8), Dimension(:) :: xiom, xom, grtau, xtau, A + Real (Kind=8), Dimension(:,:) :: cov + Real (Kind=8) :: Beta + + ! Local + Real (Kind=8), Dimension(:), allocatable :: xqmc + Real (Kind=8), Dimension(:,:), allocatable :: xker + + Integer :: Nom, Ntau, Niom, Niw, Nt, Nw + Real (Kind=8) :: Alpha_st, Chisq, x + + Complex (Kind=8) :: z + + Nom = Size(Xom ,1) + Niom = Size(Xiom,1) + Ntau = Size(Xtau,1) + Allocate (Xqmc(Ntau), Xker(Ntau,Nom) ) + xqmc = -grtau + ! Setup data for MaxEnt. + do nt = 1,ntau + do nw = 1,Nom + XKer(nt,nw) = EXP(-xtau(nt)*xom(nw) ) / ( 1.d0 + EXP( -BETA*xom(nw) ) ) + Enddo + Enddo + + + Alpha_st = 1000000.0 + Chisq = 0.d0 + Call MaxEnt(XQMC, COV, A, XKER, ALPHA_ST, CHISQ ) + + do niw = 1,niom + z = cmplx(0.d0,0.d0) + do nw = 1,nom + z = z + cmplx(A(nw),0.d0)/cmplx(-xom(nw), xiom(niw)) + enddo + griom(niw) = z + enddo + + open (unit=60,file='data_out', status='unknown', position='append') + do nt = 1,ntau + x = 0.d0 + do nw = 1,nom + x = x + xker(nt,nw)*a(nw) + enddo + write(60,2004) xtau(nt), xqmc(nt), sqrt(cov(nt,nt)), x + enddo + close(60) +2004 format(f16.8,2x,f16.8,2x,f16.8,2x,f16.8) + + + deallocate (Xqmc, Xker) + + end subroutine Tau_Matz_T + +!-------------------- + + subroutine Tau_Matz_T_stoch(griom, xiom, grtau, xtau, beta, cov, & + & Alpha_tot, OM_ST, OM_EN, Nsweeps, NBins, NWarm, Xker_func ) + Implicit none + + !Arguments + Complex (Kind=8), Dimension(:) :: griom + Real (Kind=8), Dimension(:) :: xiom, grtau, xtau + Real (Kind=8), Dimension(:,:) :: cov + Real (Kind=8) :: Beta, OM_ST, OM_EN + Real (Kind=8), Dimension(:) :: Alpha_tot + Real (Kind=8), external :: xker_func + Integer :: Nsweeps, NBins, NWarm + + ! Local + Real (Kind=8), Dimension(: ), allocatable :: xqmc, A, xom + + Integer :: Ntau, Niom, Niw, Nt, Nw, Ndis, Ngamma, Lcov + Real (Kind=8) :: Chisq, x, dom, xmom1 + Complex (Kind=8) :: z + + Ndis = 5000 + Allocate ( A(ndis),xom(ndis) ) + Niom = Size(Xiom,1) + Ntau = Size(Xtau,1) + Allocate ( Xqmc(Ntau) ) + Ngamma = Nint(dble(Ntau)*1.5) + If (Ngamma.lt. 200 ) Ngamma = 200 + Lcov = 0 + xqmc = -grtau + xmom1 = 1.d0 + Call MaxEnt_stoch_fit(xqmc, xtau, cov, Lcov, xker_func, Xmom1, Beta, Alpha_tot,& + & Ngamma, OM_ST, OM_EN, Nsweeps, NBins, NWarm, A, & + & xom , Chisq ) + + + dom = xom(2) - xom(1) + do niw = 1,niom + z = cmplx(0.d0,0.d0) + do nw = 1,ndis + z = z + cmplx(A(nw),0.d0)/cmplx(-xom(nw), xiom(niw)) + enddo + griom(niw) = z * dom + enddo + + open (unit=60,file='data_out', status='unknown', position='append') + do nt = 1,ntau + x = 0.d0 + do nw = 1,ndis + x = x + Xker_func(Xtau(nt),xom(nw), beta)*a(nw) + enddo + x = x*dom + write(60,2004) xtau(nt), xqmc(nt), sqrt(cov(nt,nt)), x + enddo + close(60) +2004 format(f16.8,2x,f16.8,2x,f16.8,2x,f16.8) + + + deallocate (Xqmc) + deallocate (A,xom ) + + end subroutine Tau_Matz_T_stoch + +!-------------------- + + subroutine Tau_Matz_T_Bose(griom, xiom, grtau, xtau, beta, A, xom, cov) + ! Working on this. + implicit none + ! Arguments + Real ( Kind=8 ) , Dimension(:) :: griom + Real ( Kind=8 ) , Dimension(:) :: xiom, xom, grtau, xtau, A + Real ( Kind=8 ) , Dimension(:,:) :: cov + Real ( Kind=8 ) :: Beta + + ! Local + Real (Kind=8), Dimension(: ), allocatable :: xqmc + Real (Kind=8), Dimension(:,:), allocatable :: xker + + Integer :: Nom, Ntau, Niom, Niw, Nt, Nw + Real (Kind=8) :: Alpha_st, Chisq, x, Zero + + Complex (Kind=8) :: z + + Nom = Size(Xom ,1) + Zero = 1.D-10 + Do Nw = 1,Nom + if ( xom(Nw) .lt. -Zero ) then + Write(6,*) 'Frequencies should be larger than zero' + stop + endif + enddo + Niom = Size(Xiom,1) + Ntau = Size(Xtau,1) + Allocate ( Xqmc(Ntau), Xker(Ntau,Nom) ) + ! Setup data for MaxEnt. + + xqmc = grtau + do nt = 1,ntau + !write(6,*) xtau(nt), xqmc(nt), sqrt(cov(nt,nt)), Beta + do nw = 1,Nom + if (Xom(nw).gt.Zero) then + XKer(nt,nw) = xom(nw)*(EXP(-xtau(nt)*xom(nw))/(1.d0-EXP( -BETA*xom(nw) ) ) - & + & EXP( xtau(nt)*xom(nw))/(1.d0-EXP( BETA*xom(nw) ) ) ) + else + Xker(nt,nw) = 2.d0/Beta + endif + Enddo + Enddo + + + Alpha_st = 1000000.0 + Chisq = 0.d0 + Call MaxEnt(XQMC, COV, A, XKER, ALPHA_ST, CHISQ ) + + do niw = 1,niom + x = 0.d0 + If ( abs(xiom(niw)).gt.Zero) then + do nw = 1,nom + x = x + 2.d0*A(nw) * xom(nw)* xom(nw)/( xom(nw)**2 + xiom(niw)**2) + enddo + else + do nw = 1,nom + x = x + 2.d0*A(nw) + enddo + endif + griom(niw) = x + enddo + + ! A( nw ) = A(w)*Dom + ! A(w) = (1/pi)*chi''(w)/w + open (unit=60,file='data_out', status='unknown', position='append') + do nt = 1,ntau + x = 0.d0 + do nw = 1,nom + x = x + xker(nt,nw)*a(nw) + enddo + write(60,2004) xtau(nt), xqmc(nt), sqrt(cov(nt,nt)), x + enddo + close(60) +2004 format(f16.8,2x,f16.8,2x,f16.8,2x,f16.8) + + + deallocate (Xqmc, Xker) + + end subroutine Tau_Matz_T_Bose + + +!-------------------- +!!!!!! To be tested !!!!! + subroutine Tau_Matz_T0_stoch(griom, xiom, g_t0, cov_t0, g_0t, cov_0t, xtau, beta, Rel_Err, & + & Alpha_tot, OM_ST, OM_EN, Nsweeps, NBins, NWarm, Xker_func ) + Implicit none + + !Arguments + Complex (Kind=8), Dimension(:) :: griom + Real (Kind=8), Dimension(:) :: xiom,g_t0, g_0t, xtau + Real (Kind=8), Dimension(:,:) :: cov_t0, cov_0t + Real (Kind=8) :: Beta, OM_ST, OM_EN, Rel_Err + Real (Kind=8), Dimension(:) :: Alpha_tot + Real (Kind=8), external :: xker_func + Integer :: Nsweeps, NBins, NWarm + + ! Local + Real (Kind=8), Dimension(: ), allocatable :: xqmc, A_t0, A_0t, xom + + Integer :: Ntau, Niom, Niw, Nt, Nw, Ndis, Ngamma, Lcov + Real (Kind=8) :: Chisq, x, dom, xmom1 + Complex (Kind=8) :: z + + Ndis = 5000 + Allocate ( A_0t(ndis),A_t0(ndis), xom(ndis) ) + Niom = Size(Xiom,1) + Ntau = Size(Xtau,1) + Allocate ( Xqmc(Ntau) ) + Ngamma = Nint(dble(Ntau)*1.5) + If (Ngamma.lt. 200 ) Ngamma = 200 + Lcov = 0 + xqmc = -g_t0 + xmom1 = xqmc(1) + Call MaxEnt_stoch_fit(xqmc, xtau, cov_t0, Lcov, xker_func, Xmom1, Beta, Alpha_tot,& + & Ngamma, OM_ST, OM_EN, Nsweeps, NBins, NWarm, A_t0, & + & xom , Chisq ) + + Lcov = 0 + xqmc = g_0t + xmom1 = xqmc(1) + Call MaxEnt_stoch_fit(xqmc, xtau, cov_0t, Lcov, xker_func, Xmom1, Beta, Alpha_tot,& + & Ngamma, OM_ST, OM_EN, Nsweeps, NBins, NWarm, A_0t, & + & xom , Chisq ) + + dom = xom(2) - xom(1) + do niw = 1,niom + z = cmplx(0.d0,0.d0) + do nw = 1, ndis + z = z + cmplx(A_t0(nw),0.d0)/cmplx(-xom(nw), xiom(niw)) + & + & cmplx(A_0t(nw),0.d0)/cmplx( xom(nw), xiom(niw)) + enddo + griom(niw) = z*dom + enddo + + + open (unit=60,file='data_out', status='unknown', position='append') + do nt = ntau,1,-1 + x = 0.d0 + do nw = 1,ndis + x = x + Xker_func(Xtau(nt),xom(nw), beta)*A_0t(nw) + enddo + x = x*dom + write(60,2004) -xtau(nt), g_0t(nt), sqrt(cov_0t(nt,nt)), x + enddo + do nt = 1,ntau + x = 0.d0 + do nw = 1,ndis + x = x + Xker_func(Xtau(nt),xom(nw), beta)*A_t0(nw) + enddo + x = x*dom + write(60,2004) xtau(nt), -g_t0(nt), sqrt(cov_t0(nt,nt)), x + enddo + close(60) +2004 format(f16.8,2x,f16.8,2x,f16.8,2x,f16.8) + + deallocate (Xqmc) + deallocate (A_0t,A_t0,xom ) + + end subroutine Tau_Matz_T0_stoch + +!-------------------- + + subroutine Tau_Matz_T0(griom, xiom, g_t0, cov_t0, g_0t, cov_0t, xtau, A_0t, A_t0, xom, & + & Rel_Err, Beta) + + Implicit none + + !Arguments + Complex (Kind=8), Dimension(:) :: griom + Real (Kind=8), Dimension(:) :: xiom, g_t0, g_0t, xtau, A_0t, A_t0, xom + Real (Kind=8), Dimension(:,:) :: cov_t0, cov_0t + Real (Kind=8) :: Rel_Err + Real (Kind=8), optional :: Beta + + ! Local + Real (Kind=8), Dimension(:), allocatable :: xqmc + Real (Kind=8), Dimension(:,:), allocatable :: xker, xcov + + Integer :: Nom, Ntau, Niom, Niw, Nt, Nw, Ntau_eff + Real (Kind=8) :: Alpha_st, Chisq, x + + Complex (Kind=8) :: z + + Nom = Size(Xom ,1) + Niom = Size(Xiom,1) + Ntau = Size(Xtau,1) + + Allocate (Xqmc(Ntau), Xker(Ntau,Nom)) + Write(6,*) ' Calling Max_Ent from T=0 routine. ' + ! t > 0 + ! Setup data for MaxEnt. + If (Present(Beta)) Then + do nt = 1,ntau + do nw = 1,Nom + XKer(nt,nw) = EXP(-xtau(nt)*xom(nw) )/ ( 1.d0 + EXP( -BETA*xom(nw)) ) + Enddo + Enddo + else + do nt = 1,ntau + do nw = 1,Nom + XKer(nt,nw) = EXP(-xtau(nt)*xom(nw) ) + Enddo + Enddo + endif + Alpha_st = 100000.0 + Chisq = 0.d0 + xqmc = -g_t0 + Open (Unit=13,file='In_MaxEnt_T0', status='unknown', position='append') + do nt = 1,ntau + write(13,2001) xtau(nt), xqmc(nt), sqrt(cov_t0(nt,nt)) + enddo + write(13,*) + close(13) + Call MaxEnt(XQMC, COV_t0, A_t0, XKER, ALPHA_ST, CHISQ, Rel_err ) + + Alpha_st = 100000.0 + Chisq = 0.d0 + xqmc = g_0t + Open (Unit=13,file='In_MaxEnt_T0', status='unknown', position='append') + do nt = 1,ntau + write(13,2001) xtau(nt), xqmc(nt), sqrt(cov_0t(nt,nt)) + enddo + write(13,*) + close(13) + Call MaxEnt(XQMC, COV_0t, A_0t, XKER, ALPHA_ST, CHISQ, Rel_err) + +! do niw = 1,niom +! z = cmplx(0.d0,0.d0) +! do nw = 1,nom +! z = z + cmplx(A(nw),0.d0)/cmplx(-xom(nw), xiom(niw)) +! enddo +! griom(niw) = z +! enddo + + + do niw = 1,niom + z = cmplx(0.d0,0.d0) + do nw = 1,nom + z = z + cmplx(A_t0(nw),0.d0)/cmplx(-xom(nw), xiom(niw)) + & + & cmplx(A_0t(nw),0.d0)/cmplx( xom(nw), xiom(niw)) + enddo + griom(niw) = z + enddo + + + open (unit=60,file='data_out', status='unknown', position='append') + do nt = 1,ntau + x = 0.d0 + do nw = 1,nom + x = x + xker(nt,nw)*a_t0(nw) + enddo + write(60,2004) xtau(nt), -g_t0(nt), sqrt(cov_t0(nt,nt)), x + enddo + write(60,*) + do nt = 1,ntau + x = 0.d0 + do nw = 1,nom + x = x + xker(nt,nw)*a_0t(nw) + enddo + write(60,2004) xtau(nt), g_0t(nt), sqrt(cov_0t (nt,nt)), x + enddo + write(60,*) + + close(60) +2004 format(f16.8,2x,f16.8,2x,f16.8,2x,f16.8) + +2001 format(F16.8,2x,F16.8,2x,F16.8) + + deallocate (Xqmc, Xker) + + + + end subroutine Tau_Matz_T0 + +!************ + subroutine Tau_Matz_T0_all( g_iom_mat, xiom, g_t0_mat, error_t0_mat, g_0t_mat, error_0t_mat, & + & xtau, xom, Rel_err ) + + Implicit none + + !Arguments + Type (Mat_C), Dimension(:,:) :: g_iom_mat + Type (Mat_R), Dimension(:,:) :: g_t0_mat, g_0t_mat + Type (Mat_R), Dimension(:,:) :: error_t0_mat, error_0t_mat + Real (Kind=8), Dimension(:) :: xiom, xtau, xom + Real (Kind=8) :: Rel_err + + Complex (Kind=8), Dimension(:), allocatable :: giom + Real (Kind=8), Dimension(:), allocatable :: gt0, g0t, A0t, At0 + Real (Kind=8), Dimension(:,:), allocatable :: covt0, cov0t + + Integer :: Nom, Ntau, Niom, Niw, Nt, Nw + + ! ******* Input is | g_11 , (g_11 + g_22 + g_12 + g_21)/2.0 | + ! |(g_11 + g_22 - g_12 - g_21)/2.0, g_22 | + ! As a function of tau. + ! + ! ******* Output is | g_11 , g_12 | + ! | g_21 , g_22 | + ! As a funtion of omega_m + + ! Local + Integer :: LQ_c, Norb + Integer :: nt1, nk, no1,no2 + Complex (Kind=8) :: Zp + + Ntau = size(g_t0_mat,2) + If ( Ntau.ne.size(g_0t_mat,2) .OR. Ntau.ne.size(xtau,1) ) Then + write(6,*) 'Error in ntau! (Fourier, Tau_Matz_T0_all) ' + endif + LQ_c = size(g_t0_mat,1) + If ( LQ_c.ne.size(g_0t_mat,1) .OR. LQ_C.ne.size(g_iom_mat,1) ) Then + write(6,*) 'Error in LQ_C! (Fourier, Tau_Matz_T0_all) ' + endif + Niom = size(g_iom_mat,2) + If ( Niom.ne.size(xiom,1) ) Then + write(6,*) 'Error in Niom! (Fourier, Tau_Matz_T0_all) ' + endif + + Norb = Size(g_t0_mat(1,1)%el,1) + Nom = Size(xom,1) + + allocate(giom(Niom), gt0(Ntau), g0t(Ntau), A0t(Nom), At0(Nom), & + & covt0(Ntau,Ntau), cov0t(Ntau,Ntau) ) + + + do nk = 1,LQ_C + do no1 = 1,Norb + do no2 = 1,Norb + do nt = 1,Ntau + gt0(nt) = g_t0_mat(nk,nt)%el(no1,no2) + g0t(nt) = g_0t_mat(nk,nt)%el(no1,no2) + enddo + covt0 = 0.0; cov0t = 0.0 + do nt = 1,Ntau + covt0(nt,nt) = (error_t0_mat(nk,nt)%el(no1,no2))**2 + cov0t(nt,nt) = (error_0t_mat(nk,nt)%el(no1,no2))**2 + enddo + Write(6,* ) ' Nk is : ', nk + call Tau_Matz_T0(giom, xiom, gt0, covt0, g0t, cov0t, xtau, A0t, At0, xom, Rel_err) + do nw = 1,Niom + g_iom_mat(nk,nw)%el(no1,no2) = giom(nw) + enddo + enddo + enddo + do no1 = 1,Norb + do no2 = no1 + 1, Norb + do nw = 1,Niom + Zp = g_iom_mat(nk,nw)%el(no1,no2) - g_iom_mat(nk,nw)%el(no2,no1) + g_iom_mat(nk,nw)%el(no1,no2) = Zp/cmplx(2.0,0.0) + g_iom_mat(nk,nw)%el(no2,no1) = Zp/cmplx(2.0,0.0) + enddo + enddo + enddo + enddo + deallocate( giom, gt0, g0t, A0t, At0, covt0, cov0t ) + + end subroutine Tau_Matz_T0_all + + +!----------------- + subroutine Tau_Matz_T_all_stoch_C(g_iom_mat, xiom, g_t0_mat, error_t0_mat, xtau, Beta,& + & Alpha_tot, OM_ST, OM_EN, Nsweeps, NBins, NWarm, Xker_func ) + + Implicit none + + !Arguments + Type (Mat_C), Dimension(:,:) :: g_iom_mat + Type (Mat_C), Dimension(:,:) :: g_t0_mat + Type (Mat_R), Dimension(:,:) :: error_t0_mat + Real (Kind=8), Dimension(:) :: xiom, xtau + Real (Kind=8) :: Beta, OM_St, OM_EN + Real (Kind=8), external :: Xker_func + Real (Kind=8), Dimension(:) :: Alpha_tot + Integer :: Nsweeps, NBins, NWarm + + Complex (Kind=8), Dimension(:), allocatable :: giom + Real (Kind=8), Dimension(:), allocatable :: gt0 + Real (Kind=8), Dimension(:,:), allocatable :: covt0 + + Integer :: Nom, Ntau, Niom, Niw, Nt, Nw + + ! ******* Input is | g_11 , (g_11 + g_22 + g_12 + g_21)/2.0 | + ! |(g_11 + g_22 - i[g_12 - g_21]) /2.0, g_22 | + ! As a function of tau. Note that input is real since. + ! With gamma = (c + d)/sqrt(2) and eta = (c + i d)/sqrt(2) + ! ******* Input is | cc* , gamma gamma* | + ! | eta eta* , dd* | + + ! + ! ******* Output is | g_11 , g_12 | + ! | g_21 , g_22 | + ! As a funtion of omega_m + + ! Local + Integer :: LQ_c, Norb + Integer :: nt1, nk, no1,no2 + Complex (Kind=8) :: Z1, Z2 + + Ntau = size(g_t0_mat,2) + If ( Ntau.ne.size(xtau,1) ) Then + write(6,*) 'Error in ntau! (Fourier, Tau_Matz_T_all) ' + endif + LQ_c = size(g_t0_mat,1) + If ( LQ_C.ne.size(g_iom_mat,1) ) Then + write(6,*) 'Error in LQ_C! (Fourier, Tau_Matz_T_all) ' + endif + Niom = size(g_iom_mat,2) + If ( Niom.ne.size(xiom,1) ) Then + write(6,*) 'Error in Niom! (Fourier, Tau_Matz_T_all) ' + endif + + Norb = Size(g_t0_mat(1,1)%el,1) + + allocate(giom(Niom), gt0(Ntau), covt0(Ntau,Ntau) ) + + + do nk = 1,LQ_C + do no1 = 1,Norb + do no2 = 1,Norb + do nt = 1,Ntau + gt0(nt) = dble(g_t0_mat(nk,nt)%el(no1,no2)) + enddo + covt0 = 0.0 + do nt = 1,Ntau + covt0(nt,nt) = (error_t0_mat(nk,nt)%el(no1,no2))**2 + enddo + Write(6,* ) ' Nk is : ', nk + Call Tau_Matz_T_stoch(giom, xiom, gt0, xtau, beta, covt0, & + & Alpha_tot, OM_ST, OM_EN, Nsweeps, NBins, NWarm, Xker_func ) + do nw = 1,Niom + g_iom_mat(nk,nw)%el(no1,no2) = giom(nw) + enddo + enddo + enddo + do no1 = 1,Norb + do no2 = no1 + 1, Norb + do nw = 1,Niom + Z1 = g_iom_mat(nk,nw)%el(no1,no2) - & + & (g_iom_mat(nk,nw)%el(no1,no1)+g_iom_mat(nk,nw)%el(no2,no2))/cmplx(2.d0,0.d0) + Z2 = g_iom_mat(nk,nw)%el(no2,no1) - & + & (g_iom_mat(nk,nw)%el(no1,no1)+g_iom_mat(nk,nw)%el(no2,no2))/cmplx(2.d0,0.d0) + g_iom_mat(nk,nw)%el(no1,no2) = Z1 + cmplx(0.0,1.d0)*Z2 + g_iom_mat(nk,nw)%el(no2,no1) = Z1 - cmplx(0.0,1.d0)*Z2 + enddo + enddo + enddo + enddo + deallocate( giom, gt0, covt0) + end subroutine Tau_Matz_T_all_stoch_C + + +!----------------- + subroutine Tau_Matz_T_all_stoch(g_iom_mat, xiom, g_t0_mat, error_t0_mat, xtau, Beta,& + & Alpha_tot, OM_ST, OM_EN, Nsweeps, NBins, NWarm, Xker_func ) + + Implicit none + + !Arguments + Type (Mat_C), Dimension(:,:) :: g_iom_mat + Type (Mat_R), Dimension(:,:) :: g_t0_mat + Type (Mat_R), Dimension(:,:) :: error_t0_mat + Real (Kind=8), Dimension(:) :: xiom, xtau + Real (Kind=8) :: Beta, OM_St, OM_EN + Real (Kind=8), external :: Xker_func + Real (Kind=8), Dimension(:) :: Alpha_tot + Integer :: Nsweeps, NBins, NWarm + + Complex (Kind=8), Dimension(:), allocatable :: giom + Real (Kind=8), Dimension(:), allocatable :: gt0 + Real (Kind=8), Dimension(:,:), allocatable :: covt0 + + Integer :: Nom, Ntau, Niom, Niw, Nt, Nw + + ! ******* Input is | g_11 , (g_11 + g_22 + g_12 + g_21)/2.0 | + ! |(g_11 + g_22 - g_12 - g_21)/2.0, g_22 | + ! As a function of tau. + ! + ! ******* Output is | g_11 , g_12 | + ! | g_21 , g_22 | + ! As a funtion of omega_m + + ! Local + Integer :: LQ_c, Norb + Integer :: nt1, nk, no1,no2 + Complex (Kind=8) :: Zp + + Ntau = size(g_t0_mat,2) + If ( Ntau.ne.size(xtau,1) ) Then + write(6,*) 'Error in ntau! (Fourier, Tau_Matz_T_all) ' + endif + LQ_c = size(g_t0_mat,1) + If ( LQ_C.ne.size(g_iom_mat,1) ) Then + write(6,*) 'Error in LQ_C! (Fourier, Tau_Matz_T_all) ' + endif + Niom = size(g_iom_mat,2) + If ( Niom.ne.size(xiom,1) ) Then + write(6,*) 'Error in Niom! (Fourier, Tau_Matz_T_all) ' + endif + + Norb = Size(g_t0_mat(1,1)%el,1) + + allocate(giom(Niom), gt0(Ntau), covt0(Ntau,Ntau) ) + + + do nk = 1,LQ_C + do no1 = 1,Norb + do no2 = 1,Norb + do nt = 1,Ntau + gt0(nt) = g_t0_mat(nk,nt)%el(no1,no2) + enddo + covt0 = 0.0 + do nt = 1,Ntau + covt0(nt,nt) = (error_t0_mat(nk,nt)%el(no1,no2))**2 + enddo + Write(6,* ) ' Nk is : ', nk + Call Tau_Matz_T_stoch(giom, xiom, gt0, xtau, beta, covt0, & + & Alpha_tot, OM_ST, OM_EN, Nsweeps, NBins, NWarm, Xker_func ) + do nw = 1,Niom + g_iom_mat(nk,nw)%el(no1,no2) = giom(nw) + enddo + enddo + enddo + do no1 = 1,Norb + do no2 = no1 + 1, Norb + do nw = 1,Niom + Zp = g_iom_mat(nk,nw)%el(no1,no2) - g_iom_mat(nk,nw)%el(no2,no1) + g_iom_mat(nk,nw)%el(no1,no2) = Zp/cmplx(2.0,0.0) + g_iom_mat(nk,nw)%el(no2,no1) = Zp/cmplx(2.0,0.0) + enddo + enddo + enddo + enddo + deallocate( giom, gt0, covt0) + end subroutine Tau_Matz_T_all_stoch + +!----------------------- + subroutine Tau_Matz_T_all_stoch_cdmft(g_iom_mat, xiom, g_t0_mat, error_t0_mat, xtau, Beta,& + & Alpha_tot, OM_ST, OM_EN, Nsweeps, NBins, NWarm, Xker_func ) + + Implicit none + + !Arguments + Type (Mat_C), Dimension(:) :: g_iom_mat + Type (Mat_R), Dimension(:) :: g_t0_mat + Type (Mat_R), Dimension(:) :: error_t0_mat + Real (Kind=8), Dimension(:) :: xiom, xtau + Real (Kind=8) :: Beta, OM_St, OM_EN + Real (Kind=8), external :: Xker_func + Real (Kind=8), Dimension(:) :: Alpha_tot + Integer :: Nsweeps, NBins, NWarm + + Complex (Kind=8), Dimension(:), allocatable :: giom + Real (Kind=8), Dimension(:), allocatable :: gt0 + Real (Kind=8), Dimension(:,:), allocatable :: covt0 + + Integer :: Nom, Ntau, Niom, Niw, Nt, Nw + + ! ******* Input is | g_11 , (g_11 + g_22 + g_12 + g_21)/2.0 | + ! |(g_11 + g_22 - g_12 - g_21)/2.0, g_22 | + ! As a function of tau. and generalization thereof for larger matrices. + ! + ! ******* Output is | g_11 , g_12 | + ! | g_21 , g_22 | + ! As a funtion of omega_m + + ! Local + Integer :: LQ_c, Norb + Integer :: nt1, nk, no1,no2 + Complex (Kind=8) :: Zp + + Ntau = size(g_t0_mat,1) + If ( Ntau.ne.size(xtau,1) ) Then + write(6,*) 'Error in ntau! (Fourier, Tau_Matz_T_all) ' + endif + Niom = size(g_iom_mat,1) + If ( Niom.ne.size(xiom,1) ) Then + write(6,*) 'Error in Niom! (Fourier, Tau_Matz_T_all) ' + endif + + Norb = Size(g_t0_mat(1)%el,1) + + allocate(giom(Niom), gt0(Ntau), covt0(Ntau,Ntau) ) + + + do no1 = 1,Norb + do no2 = 1,Norb + + do nt = 1,Ntau + gt0(nt) = g_t0_mat(nt)%el(no1,no2) + enddo + covt0 = 0.0 + do nt = 1,Ntau + covt0(nt,nt) = (error_t0_mat(nt)%el(no1,no2))**2 + enddo + Call Tau_Matz_T_stoch(giom, xiom, gt0, xtau, beta, covt0, & + & Alpha_tot, OM_ST, OM_EN, Nsweeps, NBins, NWarm, Xker_func ) + do nw = 1,Niom + g_iom_mat(nw)%el(no1,no2) = giom(nw) + enddo + enddo + enddo + do no1 = 1,Norb + do no2 = no1 + 1, Norb + do nw = 1,Niom + Zp = g_iom_mat(nw)%el(no1,no2) - g_iom_mat(nw)%el(no2,no1) + g_iom_mat(nw)%el(no1,no2) = Zp/cmplx(2.0,0.0) + g_iom_mat(nw)%el(no2,no1) = Zp/cmplx(2.0,0.0) + enddo + enddo + enddo + deallocate( giom, gt0, covt0) + end subroutine Tau_Matz_T_all_stoch_cdmft + +!----------------- + subroutine Tau_Matz_T_all(g_iom_mat, xiom, g_t0_mat, error_t0_mat, xtau, xom, Beta ) + + Implicit none + + !Arguments + Type (Mat_C), Dimension(:,:) :: g_iom_mat + Type (Mat_R), Dimension(:,:) :: g_t0_mat + Type (Mat_R), Dimension(:,:) :: error_t0_mat + Real (Kind=8), Dimension(:) :: xiom, xtau, xom + Real (Kind=8) :: Beta + + Complex (Kind=8), Dimension(:), allocatable :: giom + Real (Kind=8), Dimension(:), allocatable :: gt0, At0 + Real (Kind=8), Dimension(:,:), allocatable :: covt0 + + Integer :: Nom, Ntau, Niom, Niw, Nt, Nw + + ! ******* Input is | g_11 , (g_11 + g_22 + g_12 + g_21)/2.0 | + ! |(g_11 + g_22 - g_12 - g_21)/2.0, g_22 | + ! As a function of tau. + ! + ! ******* Output is | g_11 , g_12 | + ! | g_21 , g_22 | + ! As a funtion of omega_m + + ! Local + Integer :: LQ_c, Norb + Integer :: nt1, nk, no1,no2 + Complex (Kind=8) :: Zp + + Ntau = size(g_t0_mat,2) + If ( Ntau.ne.size(xtau,1) ) Then + write(6,*) 'Error in ntau! (Fourier, Tau_Matz_T_all) ' + endif + LQ_c = size(g_t0_mat,1) + If ( LQ_C.ne.size(g_iom_mat,1) ) Then + write(6,*) 'Error in LQ_C! (Fourier, Tau_Matz_T_all) ' + endif + Niom = size(g_iom_mat,2) + If ( Niom.ne.size(xiom,1) ) Then + write(6,*) 'Error in Niom! (Fourier, Tau_Matz_T_all) ' + endif + + Norb = Size(g_t0_mat(1,1)%el,1) + Nom = Size(xom,1) + + allocate(giom(Niom), gt0(Ntau), At0(Nom), covt0(Ntau,Ntau) ) + + + do nk = 1,LQ_C + do no1 = 1,Norb + do no2 = 1,Norb + do nt = 1,Ntau + gt0(nt) = g_t0_mat(nk,nt)%el(no1,no2) + enddo + covt0 = 0.0 + do nt = 1,Ntau + covt0(nt,nt) = (error_t0_mat(nk,nt)%el(no1,no2))**2 + enddo + Write(6,* ) ' Nk is : ', nk + Call Tau_Matz_T(giom, xiom, gt0, xtau, beta, At0, xom, covt0) + do nw = 1,Niom + g_iom_mat(nk,nw)%el(no1,no2) = giom(nw) + enddo + enddo + enddo + do no1 = 1,Norb + do no2 = no1 + 1, Norb + do nw = 1,Niom + Zp = g_iom_mat(nk,nw)%el(no1,no2) - g_iom_mat(nk,nw)%el(no2,no1) + g_iom_mat(nk,nw)%el(no1,no2) = Zp/cmplx(2.0,0.0) + g_iom_mat(nk,nw)%el(no2,no1) = Zp/cmplx(2.0,0.0) + enddo + enddo + enddo + enddo + deallocate( giom, gt0, At0, covt0) + + end subroutine Tau_Matz_T_all + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!---------------------------------------------------------------------- + subroutine tau_matz_spline(nspl,griom, xiom, grtau, xtau) + implicit none + + integer, intent(in) :: nspl + real(kind=8), dimension(:), intent(in) :: xiom,xtau,grtau + complex(kind=8), dimension(size(xiom)), intent(out) :: griom + + integer :: itau,iom,ntau,niom + real(kind=8) :: dx + real(kind=8), dimension(:), allocatable :: xtau_spl,grtau_spl + + ntau = size(xtau) + niom = size(xiom) + + allocate(xtau_spl(0:nspl),grtau_spl(0:nspl)) + + dx = xtau(ntau) / dble(nspl) + do itau = 0,nspl + xtau_spl(itau) = dx * dble(itau) + enddo + + call aspline(xtau,grtau,xtau_spl,grtau_spl) + +!!$ open(10,file='spline.dat',position='append') +!!$ do itau = 0,nspl +!!$ write(10,*) xtau_spl(itau),grtau_spl(itau) +!!$ enddo +!!$ write(10,*) +!!$ write(10,*) +!!$ close(10) + + griom = (0.d0,0.d0) + do iom = 1,niom + do itau = 0,nspl + griom(iom) = griom(iom) & + + exp(cmplx(0.d0,xiom(iom)*xtau_spl(itau))) * cmplx(grtau_spl(itau) * dx,0.d0) + enddo + enddo + + deallocate(xtau_spl,grtau_spl) + + end subroutine tau_matz_spline + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!---------------------------------------------------------------------- + subroutine tau_matz_spline_all(nspl, g_iom_mat, xiom, g_t0_mat, xtau) + + Implicit none + + !Arguments + integer :: nspl + Type (Mat_C), Dimension(:,:) :: g_iom_mat + Type (Mat_R), Dimension(:,:) :: g_t0_mat + Real (Kind=8), Dimension(:) :: xiom, xtau + + Complex (Kind=8), Dimension(:), allocatable :: giom + Real (Kind=8), Dimension(:), allocatable :: gt0 + + Integer :: Ntau, Niom, Niw, Nt, Nw + + ! ******* Input is | g_11 , (g_11 + g_22 + g_12 + g_21)/2.0 | + ! |(g_11 + g_22 - g_12 - g_21)/2.0, g_22 | + ! As a function of tau. + ! + ! ******* Output is | g_11 , g_12 | + ! | g_21 , g_22 | + ! As a funtion of omega_m + + ! Local + Integer :: LQ_c, Norb + Integer :: nt1, nk, no1,no2 + Complex (Kind=8) :: Zp + + Ntau = size(g_t0_mat,2) + If ( Ntau.ne.size(xtau,1) ) Then + write(6,*) 'Error in ntau! (Fourier, Tau_Matz_T_all) ' + endif + LQ_c = size(g_t0_mat,1) + If ( LQ_C.ne.size(g_iom_mat,1) ) Then + write(6,*) 'Error in LQ_C! (Fourier, Tau_Matz_T_all) ' + endif + Niom = size(g_iom_mat,2) + If ( Niom.ne.size(xiom,1) ) Then + write(6,*) 'Error in Niom! (Fourier, Tau_Matz_T_all) ' + endif + + Norb = Size(g_t0_mat(1,1)%el,1) + + allocate(giom(Niom), gt0(Ntau)) + + + do nk = 1,LQ_C + do no1 = 1,Norb + do no2 = 1,Norb + do nt = 1,Ntau + gt0(nt) = g_t0_mat(nk,nt)%el(no1,no2) + enddo + Write(6,* ) ' Nk is : ', nk + Call tau_matz_spline(nspl, giom, xiom, gt0, xtau) + do nw = 1,Niom + g_iom_mat(nk,nw)%el(no1,no2) = giom(nw) + enddo + enddo + enddo + do no1 = 1,Norb + do no2 = no1 + 1, Norb + do nw = 1,Niom + Zp = g_iom_mat(nk,nw)%el(no1,no2) - g_iom_mat(nk,nw)%el(no2,no1) + g_iom_mat(nk,nw)%el(no1,no2) = Zp/cmplx(2.0,0.0) + g_iom_mat(nk,nw)%el(no2,no1) = Zp/cmplx(2.0,0.0) + enddo + enddo + enddo + enddo + deallocate( giom, gt0) + + end subroutine Tau_matz_spline_all + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!---------------------------------------------------------------------- +! equidistant x-axis values + subroutine aspline(x,y,x_new,y_new) + implicit none + + real(kind=8), dimension(:), intent(in) :: x,y,x_new + real(kind=8), dimension(:), intent(out) :: y_new + + integer :: i,j,n1,n2 + real(kind=8), dimension(:), allocatable:: x_tmp,y_tmp,t + real(kind=8) :: dx,a,b,m1,m2,m3,m4 + + n1 = size(x) + n2 = size(x_new) + + allocate(x_tmp(n1+4),y_tmp(n1+4)) ! add two points at both sides + + dx = x(2)-x(1) + x_tmp = 0.d0 + y_tmp = 0.d0 + x_tmp(3:n1+2) = x(:) + y_tmp(3:n1+2) = y(:) + +!Corner points + x_tmp(1) = x(1) - 2.d0 * dx + x_tmp(2) = x(1) - dx + x_tmp(n1+3) = x(n1) + dx + x_tmp(n1+4) = x(n1) + 2.d0 * dx + + y_tmp(n1+3) = yup(n1+3,x_tmp,y_tmp) + y_tmp(n1+4) = yup(n1+4,x_tmp,y_tmp) + y_tmp(2) = ydn(2,x_tmp,y_tmp) + y_tmp(1) = ydn(1,x_tmp,y_tmp) + +! Slopes + allocate(t(n1)) + do i = 1,n1 + j = i + 2 + m1 = slope(dx,y_tmp(j-2),y_tmp(j-1)) + m2 = slope(dx,y_tmp(j-1),y_tmp(j)) + m3 = slope(dx,y_tmp(j),y_tmp(j+1)) + m4 = slope(dx,y_tmp(j+1),y_tmp(j+2)) + a = dabs(m4-m3) * m2 + dabs(m2-m1) * m3 + b = dabs(m4-m3) + dabs(m2-m1) + if (b /= 0.d0) then + t(i) = a / b + else + t(i) = 0.5d0 * (m2+m3) + end if + enddo + +! Interpolate + do i = 1,n2 + do j = 1,n1-1 + if (x_new(i) >= x(j) .and. x_new(i) <= x(j+1) ) & + y_new(i) = poly(x(j),x(j+1),y(j),y(j+1),t(j),t(j+1),x_new(i)) + enddo + enddo + + deallocate(x_tmp,y_tmp,t) + + end subroutine aspline + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!---------------------------------------------------------------------- + real(kind=8) function yup(n,x,y) + implicit none + + integer, intent(in) :: n + real(kind=8), dimension(:), intent(in) :: x,y + + yup = (2.d0 & + * (y(n-1)-y(n-2))/(x(n-1)-x(n-2)) - (y(n-2)-y(n-3))/(x(n-2)-x(n-3))) & + * (x(n)-x(n-1)) + y(n-1) + + end function yup + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!---------------------------------------------------------------------- + real(kind=8) function ydn(n,x,y) + implicit none + + integer, intent(in) :: n + real(kind=8), dimension(:), intent(in) :: x,y + + ydn = (-2.d0 & + * (y(n+2)-y(n+1))/(x(n+2)-x(n+1)) + (y(n+3)-y(n+2))/(x(n+3)-x(n+2))) & + * (x(n+1)-x(n)) + y(n+1) + + end function ydn + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!---------------------------------------------------------------------- + real(kind=8) function slope(dx,y_dn,y_up) + implicit none + + real(kind=8), intent(in) :: dx,y_dn,y_up + + slope = (y_up - y_dn) / dx + + end function slope + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!---------------------------------------------------------------------- + real(kind=8) function poly(x1,x2,y1,y2,t1,t2,x) + implicit none + + real(kind=8), intent(in) :: x1,x2,y1,y2,t1,t2,x + real(kind=8) :: p0,p1,p2,p3 + + p0 = y1 + p1 = t1 + p2 = (3.d0*(y2-y1)/(x2-x1)-2.d0*t1-t2)/(x2-x1) + p3 = (t1+t2-2.d0*(y2-y1)/(x2-x1))/(x2-x1)**2 + + poly = p0 + p1 * (x-x1) + p2 * (x-x1)**2 + p3 * (x-x1)**3 + + end function poly + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!---------------------------------------------------------------------- + +end Module Fourier diff --git a/src/Modules/lattices_v3.f90 b/src/Modules/lattices_v3.f90 new file mode 100644 index 000000000..7e4ad8bd3 --- /dev/null +++ b/src/Modules/lattices_v3.f90 @@ -0,0 +1,748 @@ + Module Lattices_v3 + + Use Matrix + Type Lattice + Integer :: N, Ns + Integer, pointer :: list(:,:), invlist(:,:), nnlist(:,:,:), listk(:,:), & + & invlistk(:,:), imj(:,:) + Real (Kind=8), pointer :: a1_p(:), a2_p(:), b1_p(:), b2_p(:), BZ1_p(:), BZ2_p(:), & + & L1_p(:), L2_p(:), b1_perp_p(:), b2_perp_p(:) + end Type Lattice + + Interface Iscalar + module procedure Iscalar_II, Iscalar_IR, Iscalar_RR + end Interface + Interface npbc + module procedure npbc_I, npbc_R + end Interface + Interface Xnorm + module procedure Xnorm_I, Xnorm_R + end Interface + Interface Fourier_K_to_R + module procedure FT_K_to_R, FT_K_to_R_Mat, FT_K_to_R_C, FT_K_to_R_Mat_C + end Interface + Interface Fourier_R_to_K + module procedure FT_R_to_K, FT_R_to_K_mat, FT_R_to_K_C + end Interface + + Contains + + subroutine Make_lattice(L1_p, L2_p, a1_p, a2_p, Latt) + + ! This is for a general tilted square lattice defined by the vector a1, a2 + ! L1_p, L2_p define cluster topology. ( Tilted etc.) + ! L1_p = n*a1_p + m *a2_p + + + Implicit none + + Real (Kind=8), dimension(:) :: L1_p, L2_p, a1_p, a2_p + Type (Lattice) :: Latt + + Real (Kind=8), dimension(:), allocatable :: xk_p, b1_p, b2_p, BZ1_p, BZ2_p, b_p + Real (Kind=8), dimension(:), allocatable :: x_p, x1_p, a_p,d_p + Real (Kind=8), allocatable :: Mat(:,:), Mat_inv(:,:) + + Integer :: ndim, L, L1, nc, i, i1,i2, L_f, LQ, n,m, nd1,nd2,nr, nnr1, nnr2, nnr, nr1, imj_1, imj_2 + Integer :: imj + Real (Kind=8) :: Zero,pi, X + + ndim = size(L1_p) + allocate (Latt%L2_p(ndim), Latt%L1_p(ndim), Latt%a1_p(ndim) , Latt%a2_p(ndim), & + & Latt%b1_p(ndim), Latt%b2_p(ndim), Latt%BZ1_p(ndim), Latt%BZ2_p(ndim) ) + allocate (Latt%b1_perp_p(ndim), Latt%b2_perp_p(ndim) ) + Zero = 1.E-5 + Latt%L1_p = L1_p + Latt%L2_p = L2_p + Latt%a1_p = a1_p + Latt%a2_p = a2_p + + + !Compute the Reciprocal lattice vectors. + Allocate ( b1_p(ndim), b2_p(ndim), xk_p(ndim), b_p(ndim) ) + Allocate ( BZ1_p(ndim), BZ2_p(ndim) ) + Allocate ( x_p(ndim), x1_p(ndim), d_p(ndim), a_p(ndim) ) + + + pi = acos(-1.d0) + + ! Setup the 2X2 matrix to determine BZ1_p, BZ2_p + Allocate ( Mat(2 , 2), Mat_inv( 2 , 2 ) ) + Mat(1,1) = dble(a1_p(1)) + Mat(1,2) = dble(a1_p(2)) + Mat(2,1) = dble(a2_p(1)) + Mat(2,2) = dble(a2_p(2)) + X = Mat(1,1)*Mat(2,2) - Mat(2,1)*Mat(1,2) + Mat_inv(1,1) = Mat(2,2)/X + Mat_inv(2,2) = Mat(1,1)/X + Mat_inv(1,2) = -Mat(1,2)/X + Mat_inv(2,1) = -Mat(2,1)/X + BZ1_p(1) = 2.d0*pi*Mat_inv(1,1) + BZ1_p(2) = 2.d0*pi*Mat_inv(2,1) + BZ2_p(1) = 2.d0*pi*Mat_inv(1,2) + BZ2_p(2) = 2.d0*pi*Mat_inv(2,2) + Latt%BZ1_p = BZ1_p + Latt%BZ2_p = BZ2_p + + + + + ! K-space Quantization from periodicity in L1_p and L2_p + X = 2.d0*pi / ( Iscalar(BZ1_p,L1_p) * Iscalar(BZ2_p,L2_p) - & + & Iscalar(BZ2_p,L1_p) * Iscalar(BZ1_p,L2_p) ) + X = abs(X) + b1_p = X*( Iscalar(BZ2_p,L2_p) * BZ1_p - Iscalar(BZ1_p,L2_p) * BZ2_p ) + b2_p = X*( Iscalar(BZ1_p,L1_p) * BZ2_p - Iscalar(BZ2_p,L1_p) * BZ1_p ) + Latt%b1_p = b1_p + Latt%b2_p = b2_p + + + ! Setup the 2X2 matrix to determine b1_perp_p, b2_perp_p + Mat(1,1) = dble(b1_p(1)) + Mat(1,2) = dble(b1_p(2)) + Mat(2,1) = dble(b2_p(1)) + Mat(2,2) = dble(b2_p(2)) + X = Mat(1,1)*Mat(2,2) - Mat(2,1)*Mat(1,2) + Mat_inv(1,1) = Mat(2,2)/X + Mat_inv(2,2) = Mat(1,1)/X + Mat_inv(1,2) = -Mat(1,2)/X + Mat_inv(2,1) = -Mat(2,1)/X + Latt%b1_perp_p(1) = Mat_inv(1,1) + Latt%b1_perp_p(2) = Mat_inv(2,1) + Latt%b2_perp_p(1) = Mat_inv(1,2) + Latt%b2_perp_p(2) = Mat_inv(2,2) + + Deallocate ( Mat, Mat_inv ) + + + + ! Count the number of lattice points. + L = abs(nint ( Iscalar(Latt%BZ1_p,L1_p) / (2.d0*pi) )) + L1 = abs(nint ( Iscalar(Latt%BZ2_p,L1_p) / (2.d0*pi) )) + if (L1 .gt. L) L = L1 + L1 = abs(nint ( Iscalar(Latt%BZ1_p,L2_p) / (2.d0*pi) )) + if (L1 .gt. L) L = L1 + L1 = abs(nint ( Iscalar(Latt%BZ2_p,L2_p) / (2.d0*pi) )) + if (L1 .gt. L) L = L1 + nc = 0 + do i1 = -L,L + do i2 = -L,L + x_p = dble(i1)*a1_p + dble(i2)*a2_p + L_f = 1 + do i = 1,4 + if (i.eq.1) a_p = L2_p + if (i.eq.2) a_p = L1_p + if (i.eq.3) a_p = L2_p - L1_p + if (i.eq.4) a_p = L2_p + L1_p + if ( Iscalar(x_p, a_p) .le. xnorm(a_p)**2/2.d0 + Zero .and. & + & Iscalar(x_p, a_p) .ge. -xnorm(a_p)**2/2.d0 + Zero ) then + L_f = L_f * 1 + else + L_f = 0 + endif + enddo + if (L_f .eq. 1) then + nc = nc + 1 + endif + enddo + enddo + LQ = nc + Latt%Ns = LQ + Latt%N = LQ + Write(6,*) L, LQ + + + Allocate ( Latt%List(LQ,ndim), Latt%Invlist(-L:L, -L:L ) ) + !Setting up real space lattice + nc = 0 + do i1 = -L,L + do i2 = -L,L + x_p = dble(i1)*a1_p + dble(i2)*a2_p + L_f = 1 + do i = 1,4 + if (i.eq.1) a_p = L2_p + if (i.eq.2) a_p = L1_p + if (i.eq.3) a_p = L2_p - L1_p + if (i.eq.4) a_p = L2_p + L1_p + if ( Iscalar( x_p, a_p ) .le. xnorm(a_p)**2/2.d0 + Zero .and. & + & Iscalar( x_p, a_p ) .ge. -xnorm(a_p)**2/2.d0 + Zero ) then + L_f = L_f * 1 + else + L_f = 0 + endif + enddo + if (L_f .eq. 1) then + nc = nc + 1 + Latt%list(nc,1) = i1 + Latt%list(nc,2) = i2 + Latt%invlist(i1, i2 ) = nc + endif + enddo + enddo + + + Allocate ( Latt%Listk(LQ,ndim), Latt%Invlistk(-L:L, -L:L) ) + nc = 0 + do m = -L,L + do n = -L,L + xk_p = dble(m) * b1_p + dble(n) * b2_p + L_f = 1 + do i = 1,4 + if (i.eq.1) b_p = BZ2_p + if (i.eq.2) b_p = BZ1_p + if (i.eq.3) b_p = BZ2_p - BZ1_p + if (i.eq.4) b_p = BZ2_p + BZ1_p + if ( Iscalar( xk_p, b_p ) .le. xnorm(b_p)**2/2.d0 + Zero .and. & + & Iscalar( xk_p, b_p ) .ge. -xnorm(b_p)**2/2.d0 + Zero ) then + L_f = L_f * 1 + else + L_f = 0 + endif + enddo + if (L_f .eq. 1) then + !write(11,"(F14.7,2x,F14.7)") xk_p(1), xk_p(2) + nc = nc + 1 + Latt%listk(nc,1) = m + Latt%listk(nc,2) = n + Latt%invlistk(m,n) = nc + endif + enddo + enddo + If (nc.ne.Latt%N) Then + write(6,*) 'Error ', nc, Latt%N + stop + endif + + !Setup nnlist + Allocate ( Latt%nnlist(LQ,-1:1,-1:1) ) + + do nr = 1, Latt%N + do nd1 = -1,1 + do nd2 = -1,1 + d_p = dble(nd1)*a1_p + dble(nd2)*a2_p + x_p = dble(Latt%list(nr,1))*Latt%a1_p + dble(Latt%list(nr,2))*Latt%a2_p + d_p + call npbc(x1_p, x_p , Latt%L1_p, Latt%L2_p) + call npbc(x_p , x1_p, Latt%L1_p, Latt%L2_p) + call npbc(x1_p, x_p , Latt%L1_p, Latt%L2_p) + call npbc(x_p , x1_p, Latt%L1_p, Latt%L2_p) + nnr1 = nint ( Iscalar(Latt%BZ1_p,x_p) / (2.d0*pi) ) + nnr2 = nint ( Iscalar(Latt%BZ2_p,x_p) / (2.d0*pi) ) + nnr = Latt%invlist(nnr1,nnr2) + Latt%nnlist(nr,nd1,nd2) = nnr + if ( nnr < 1 .or. nnr > Latt%N ) then + write(6,*) "Error in nnlist ", nnr + x1_p = dble(Latt%list(nr,1))*Latt%a1_p + dble(Latt%list(nr,2))*Latt%a2_p + !Write(91,"(F14.7,2x,F14.7,2x,F14.7,2x,F14.7)") x1_p(1), x1_p(2), d_p(1), d_p(2) + Write(91,"(F14.7,2x,F14.7)") x1_p(1) , x1_p(2) + Write(91,*) + endif + enddo + enddo + enddo + + !Setup imj + If (LQ .lt. 1000 ) then + Allocate ( Latt%imj(LQ,LQ) ) + do nr = 1, Latt%N + x_p = dble(Latt%list(nr,1))*Latt%a1_p + dble(Latt%list(nr,2))*a2_p + do nr1 = 1,Latt%N + x1_p = dble(Latt%list(nr1,1))*Latt%a1_p + dble(Latt%list(nr1,2))*a2_p + d_p = x_p - x1_p + call npbc(x1_p , d_p , Latt%L1_p, Latt%L2_p) + call npbc(d_p , x1_p, Latt%L1_p, Latt%L2_p) + imj_1 = nint ( Iscalar(Latt%BZ1_p,d_p) / (2.d0*pi) ) + imj_2 = nint ( Iscalar(Latt%BZ2_p,d_p) / (2.d0*pi) ) + imj = Latt%invlist(imj_1,imj_2) + Latt%imj(nr,nr1) = imj + enddo + enddo + endif + + deallocate ( b1_p, b2_p, xk_p, b_p ) + deallocate ( BZ1_p, BZ2_p ) + deallocate ( x_p, x1_p, d_p, a_p ) + + + + end subroutine MAKE_LATTICE + +!******** + subroutine npbc_I(nr_p, n_p, L1_p, L2_p) + + Implicit none + + integer, dimension(:) :: nr_p, n_p, L1_p, L2_p + + integer, dimension(:), allocatable :: x_p + Real (Kind=8) :: Zero, X + Integer :: Ndim, i + + Zero = 1.E-5 + nr_p = n_p + ndim = size(nr_p) + + allocate (x_p(ndim)) + + do i = 1,4 + if (i.eq.1) x_p = L2_p + if (i.eq.2) x_p = L1_p + if (i.eq.3) x_p = L2_p - L1_p + if (i.eq.4) x_p = L2_p + L1_p + + X = dble(Iscalar(nr_p,x_p))/(Xnorm(x_p)**2) + if (X .ge. 0.5+Zero ) nr_p = nr_p - x_p + if (X .le. -0.5+Zero ) nr_p = nr_p + x_p + enddo + + deallocate(x_p) + + end subroutine npbc_I + + + subroutine npbc_R(nr_p, n_p, L1_p, L2_p) + + Implicit none + Real (Kind=8), dimension(:) :: nr_p, n_p, L1_p, L2_p + + Real (Kind=8), dimension(:), allocatable :: x_p + + Real (Kind=8) :: Zero, X + Integer :: ndim, i + ndim = size(nr_p) + + allocate (x_p(ndim)) + Zero = 1.E-5 + nr_p = n_p + do i = 1,4 + if (i.eq.1) x_p = L2_p + if (i.eq.2) x_p = L1_p + if (i.eq.3) x_p = L2_p - L1_p + if (i.eq.4) x_p = L2_p + L1_p + X = Iscalar(nr_p,x_p)/(Xnorm(x_p)**2) + if (X .ge. 0.5+Zero ) nr_p = nr_p - x_p + if (X .le. -0.5+Zero ) nr_p = nr_p + x_p + enddo + + deallocate(x_p) + + end subroutine npbc_R + +!******** + integer Function Inv_K(XK_P,Latt) + + Implicit None + Real (Kind=8) :: XK_P(2) + Type (Lattice) :: Latt + + Integer :: nkx, nky, nk + Real (Kind=8) :: XK1_P(2), XK2_P(2), X, Zero + + call npbc(xk1_p, xk_p , Latt%BZ1_p, Latt%BZ2_p) + call npbc(xk2_p, xk1_p, Latt%BZ1_p, Latt%BZ2_p) + + nkx = nint (Iscalar(XK2_P,Latt%b1_perp_p) ) + nky = nint (Iscalar(XK2_P,Latt%b2_perp_p) ) + nk = Latt%Invlistk(nkx,nky) + + !Test + Zero = 1.D-10 + XK1_P = Latt%listk(nk,1)*latt%b1_p + Latt%listk(nk,2)*latt%b2_p + if (Xnorm(XK1_P - XK2_P) < Zero ) then + Inv_K = nk + else + write(6,*) 'Error in Inv_K Lattice_new' + stop + endif + +!!$ nk = 1 +!!$ do +!!$ XK1_P = Latt%listk(nk,1)*latt%b1_p + Latt%listk(nk,2)*latt%b2_p +!!$ if (Xnorm(XK1_P - XK_P) < Zero ) then +!!$ Inv_K = nk +!!$ exit +!!$ elseif (nk < Latt%N) then +!!$ nk = nk + 1 +!!$ else +!!$ write(6,*) 'Error in Inv_K Lattice_new' +!!$ stop +!!$ endif +!!$ enddo + + end Function Inv_K + + + +!******** + integer Function Inv_R(XR_P,Latt) + + Implicit None + Real (Kind=8) :: XR_P(2) + Type (Lattice) :: Latt + + Real (Kind=8) :: XR1_P(2), XR2_P(2) + + Integer :: n_1, n_2 + Real (Kind=8) :: pi + + pi = acos(-1.d0) + call npbc(xr1_p, xr_p , Latt%L1_p, Latt%L2_p) + call npbc(xr2_p, xr1_p, Latt%L1_p, Latt%L2_p) + + n_1 = nint ( Iscalar(Latt%BZ1_p,XR2_p) / (2.d0*pi) ) + n_2 = nint ( Iscalar(Latt%BZ2_p,XR2_p) / (2.d0*pi) ) + Inv_R = Latt%invlist(n_1,n_2) + + end Function Inv_R +!******** + + integer function Iscalar_II(i_p, j_p) + Implicit none + integer, dimension(:) :: i_p, j_p + integer i + + Iscalar_II = 0 + !write(6,*) size(i_p) + do i = 1, size(i_p) + ! write(6,*) i + Iscalar_II = Iscalar_II + i_p(i)*j_p(i) + enddo + end function Iscalar_II + +!******** + Real (Kind=8) function Iscalar_IR(x_p, j_p) + Implicit none + Real (Kind=8), dimension(:) :: x_p + integer, dimension(:) :: j_p + integer i + + Iscalar_IR = 0.d0 + !write(6,*) size(i_p) + do i = 1, size(x_p) + ! write(6,*) i + Iscalar_IR = Iscalar_IR + x_p(i)*dble(j_p(i)) + enddo + end function Iscalar_IR +!******** + + Real (Kind=8) function Iscalar_RR(x_p, y_p) + Implicit none + Real (Kind=8), dimension(:) :: x_p, y_p + integer i + + Iscalar_RR = 0.d0 + do i = 1, size(x_p) + Iscalar_RR = Iscalar_RR + x_p(i)*y_p(i) + enddo + end function Iscalar_RR + +!******** + Real (Kind=8) function Xnorm_I(i_p) + Implicit none + integer, dimension(:) :: i_p + integer :: i + + Xnorm_I = 0.d0 + do i = 1, size(i_p) + Xnorm_I = Xnorm_I + dble(i_p(i)*i_p(i)) + enddo + Xnorm_I = sqrt(Xnorm_I) + end function Xnorm_I + +!******** + Real (Kind=8) function Xnorm_R(x_p) + Implicit none + Real (Kind=8), dimension(:) :: x_p + integer :: i + + Xnorm_R = 0.d0 + do i = 1, size(x_p) + Xnorm_R = Xnorm_R + x_p(i)*x_p(i) + enddo + Xnorm_R = sqrt(Xnorm_R) + end function Xnorm_R + +!******** + subroutine Print_latt(Latt) + + Implicit Real (Kind=8) (A-G,O-Z) + Implicit Integer (H-N) + + Type (Lattice) :: Latt + Real (Kind=8) :: i_p(2),nd_p(2) + Real (Kind=8) :: x_p(2) + + Open (Unit=55,file="Latt_info", status = "unknown") + write(55,*) ' Reciprocal vector 1: ', Latt%BZ1_p(1), Latt%BZ1_p(2) + write(55,*) ' Reciprocal vector 2: ', Latt%BZ2_p(1), Latt%BZ2_p(2) + write(55,*) ' Latt vector 1: ', Latt%a1_p(1), Latt%a1_p(2) + write(55,*) ' Latt vector 2: ', Latt%a2_p(1), Latt%a2_p(2) + close(55) + Open (Unit=56,file="Real_space_latt", status = "unknown") + Open (Unit=57,file="K_space_latt", status = "unknown") + Open (Unit=58,file="nn_latt", status = "unknown") + do n = 1, Latt%n + i_p = dble(Latt%list(n,1))*Latt%a1_p + dble(Latt%list(n,2))*Latt%a2_p + write(56,"(F14.7,2x,F14.7)") i_p(1), i_p(2) + x_p = dble(Latt%listk(n,1))*Latt%b1_p + dble(Latt%listk(n,2))*Latt%b2_p + write(57,"(F14.7,2x,F14.7)") x_p(1), x_p(2) + write(58,*) + write(58,"('I :',F14.7,2x,F14.7)") i_p(1), i_p(2) + do nd1 = -1,1 + do nd2 = -1,1 + nd_p = dble(nd1)*Latt%a1_p + dble(nd2)*Latt%a2_p + nnr = Latt%nnlist(n,nd1,nd2) + !Write(6,*) 'nnr : ', nnr + i_p = dble(Latt%list(nnr,1))*Latt%a1_p + dble(Latt%list(nnr,2))*Latt%a2_p + write(58,"('I+(',F12.6,',',F12.6,')=',2x,F14.7,2x,F14.7)") nd_p(1),nd_p(2),i_p(1), i_p(2) + enddo + enddo + enddo + close(56) + close(57) + close(58) + end subroutine Print_latt + +!******* + subroutine FT_K_to_R_Mat( Xin_K, Xout_R, Latt) + + Implicit none + + Type (Lattice) :: Latt + Type (Mat_R ), Dimension(:,:) :: Xin_K, Xout_R + Real (Kind=8), Dimension(:,:), allocatable :: X_MAT + Real (Kind=8) :: XK_p(2), IR_p(2) + + Integer :: nb, norb, LQ, nt, nr, nk + nb = size(Xin_K,2 ) + norb = size(Xin_K(1,1)%el,1) + LQ = Latt%N + + !Write(6,*) 'Ltrot, norb ', Ltrot, norb + !Write(6,*) Xin_K(1,1)%el(1,1) + !Write(6,*) Xin_K(Latt%N,Ltrot)%el(1,1) + + allocate ( X_MAT(norb,norb) ) + + + do nt = 1,nb + do nr = 1,LQ + IR_p = dble(Latt%list(nr,1))*Latt%a1_p + dble(Latt%list(nr,2))*Latt%a2_p + X_MAT = 0.d0 + do nk = 1,LQ + XK_p = dble(Latt%listk(nk,1))*Latt%b1_p + dble(Latt%listk(nk,2))*Latt%b2_p + X_MAT = X_MAT + cos(Iscalar(XK_p,IR_p))*Xin_K(nk,nt)%el + enddo + Xout_R(nr,nt)%el = X_MAT/dble(LQ) + enddo + enddo + + deallocate(X_Mat) + end subroutine FT_K_to_R_Mat + +!******** + subroutine FT_K_to_R_Mat_C( Xin_K, Xout_R, Latt) + + Implicit none + + Type (Lattice) :: Latt + Type (Mat_C ) , Dimension(:,:) :: Xin_K, Xout_R + Complex (Kind=8), Dimension(:,:), allocatable :: X_MAT + Real (Kind=8) :: XK_p(2), IR_p(2) + + Integer :: nb, norb, LQ, nt, nr, nk + + nb = size(Xin_K,2 ) + norb = size(Xin_K(1,1)%el,1) + LQ = Latt%N + + !Write(6,*) 'Ltrot, norb ', Ltrot, norb + !Write(6,*) Xin_K(1,1)%el(1,1) + !Write(6,*) Xin_K(Latt%N,nb)%el(1,1) + + allocate ( X_MAT(norb,norb) ) + + + do nt = 1,nb + do nr = 1,LQ + IR_p = dble(Latt%list(nr,1))*Latt%a1_p + dble(Latt%list(nr,2))*Latt%a2_p + X_MAT = cmplx(0.d0,0.d0) + do nk = 1,LQ + XK_p = dble(Latt%listk(nk,1))*Latt%b1_p + dble(Latt%listk(nk,2))*Latt%b2_p + X_MAT = X_MAT + exp( cmplx(0.d0,(Iscalar(XK_p,IR_p))) ) *Xin_K(nk,nt)%el + enddo + Xout_R(nr,nt)%el = X_MAT/cmplx(dble(LQ),0.d0) + enddo + enddo + + deallocate(X_Mat) + + end subroutine FT_K_to_R_Mat_C + +!******** + + subroutine FT_K_to_R( Xin_K, Xout_R, Latt) + + Implicit none + + Type (Lattice) :: Latt + Real (Kind=8), Dimension(:,:) :: Xin_K, Xout_R + Real (Kind=8) :: XK_p(2), IR_p(2), X_Mat + Integer :: LQ, nb, nt, nr, nk + + nb = size(Xin_K,2 ) + LQ = Latt%N + + !Write(6,*) 'Ltrot, norb ', Ltrot, norb + !Write(6,*) Xin_K(1,1)%el(1,1) + !Write(6,*) Xin_K(Latt%N,Ltrot)%el(1,1) + + + do nt = 1,nb + do nr = 1,LQ + IR_p = dble(Latt%list(nr,1))*Latt%a1_p + dble(Latt%list(nr,2))*Latt%a2_p + X_MAT = 0.d0 + do nk = 1,LQ + XK_p = dble(Latt%listk(nk,1))*Latt%b1_p + dble(Latt%listk(nk,2))*Latt%b2_p + X_MAT = X_MAT + cos(Iscalar(XK_p,IR_p))*Xin_K(nk,nt) + enddo + Xout_R(nr,nt) = X_MAT/dble(LQ) + enddo + enddo + + end subroutine FT_K_to_R + + + subroutine FT_K_to_R_C( Xin_K, Xout_R, Latt) + + Implicit none + + Type (Lattice) :: Latt + Complex (Kind=8), Dimension(:,:) :: Xin_K, Xout_R + Complex (Kind=8) :: Z + Real (Kind=8) :: XK_p(2), IR_p(2) + + Integer :: nb, LQ, nt, nr, nk + + nb = size(Xin_K,2 ) + LQ = Latt%N + + !Write(6,*) 'Ltrot, norb ', Ltrot, norb + !Write(6,*) Xin_K(1,1)%el(1,1) + !Write(6,*) Xin_K(Latt%N,Ltrot)%el(1,1) + + + do nt = 1,nb + do nr = 1,LQ + IR_p = dble(Latt%list(nr,1))*Latt%a1_p + dble(Latt%list(nr,2))*Latt%a2_p + Z = cmplx(0.d0,0.d0) + do nk = 1,LQ + XK_p = dble(Latt%listk(nk,1))*Latt%b1_p + dble(Latt%listk(nk,2))*Latt%b2_p + Z = Z + cmplx(cos(Iscalar(XK_p,IR_p)),0.d0)*Xin_K(nk,nt) + enddo + Xout_R(nr,nt) = Z/cmplx(dble(LQ),0.d0) + enddo + enddo + + end subroutine FT_K_to_R_C + + + subroutine FT_R_to_K_mat( Xin_R, Xout_K, Latt) + + Implicit none + + Type (Lattice) :: Latt + Type (Mat_R ), Dimension(:,:) :: Xin_R, Xout_K + Real (Kind=8), Dimension(:,:), allocatable :: X_MAT + Real (Kind=8) :: XK_p(2), IR_p(2) + + Integer :: nb, norb, nk, nt, LQ, nr + + nb = size(Xin_R,2 ) + norb = size(Xin_R(1,1)%el,1) + LQ = Latt%N + + !Write(6,*) 'Ltrot, norb ', Ltrot, norb + !Write(6,*) Xin_R(1,1)%el(1,1) + !Write(6,*) Xin_R(Latt%N,Ltrot)%el(1,1) + + allocate ( X_MAT(norb,norb) ) + + + do nt = 1,nb + do nk = 1,LQ + XK_p = dble(Latt%listk(nk,1))*Latt%b1_p + dble(Latt%listk(nk,2))*Latt%b2_p + X_MAT = 0.d0 + do nr = 1,LQ + IR_p = dble(Latt%list(nr,1))*Latt%a1_p + dble(Latt%list(nr,2))*Latt%a2_p + X_MAT = X_MAT + cos(Iscalar(XK_p,IR_p))*Xin_R(nr,nt)%el + enddo + Xout_K(nk,nt)%el = X_MAT/dble(LQ) + enddo + enddo + + deallocate(X_Mat) + end subroutine FT_R_to_K_mat + + subroutine FT_R_to_K( Xin_R, Xout_K, Latt) + + Implicit none + + Type (Lattice) :: Latt + Real (Kind=8), Dimension(:) :: Xin_R, Xout_K + + Real (Kind=8) :: XK_p(2), IR_p(2), X_mat + + Integer :: nb, norb, nk, nt, LQ, nr + + LQ = Latt%N + + !Write(6,*) 'Ltrot, norb ', Ltrot, norb + !Write(6,*) Xin_R(1,1)%el(1,1) + !Write(6,*) Xin_R(Latt%N,Ltrot)%el(1,1) + + do nk = 1,LQ + XK_p = dble(Latt%listk(nk,1))*Latt%b1_p + dble(Latt%listk(nk,2))*Latt%b2_p + X_MAT = 0.d0 + do nr = 1,LQ + IR_p = dble(Latt%list(nr,1))*Latt%a1_p + dble(Latt%list(nr,2))*Latt%a2_p + X_MAT = X_MAT + cos(Iscalar(XK_p,IR_p))*Xin_R(nr) + enddo + Xout_K(nk) = X_MAT/dble(LQ) + enddo + + end subroutine FT_R_to_K + +!******** + subroutine FT_R_to_K_C( Xin_R, Xout_K, Latt) + + Implicit none + + Type (Lattice) :: Latt + Complex (Kind=8), Dimension(:) :: Xin_R, Xout_K + Complex (Kind=8) :: X_MAT + Real (Kind=8) :: XK_p(2), IR_p(2) + + Integer :: nb, norb, LQ, nt, nr, nk + + LQ = Latt%N + + !Write(6,*) 'Ltrot, norb ', Ltrot, norb + !Write(6,*) Xin_K(1,1)%el(1,1) + !Write(6,*) Xin_K(Latt%N,nb)%el(1,1) + + do nk = 1,LQ + XK_p = dble(Latt%listk(nk,1))*Latt%b1_p + dble(Latt%listk(nk,2))*Latt%b2_p + X_MAT = cmplx(0.d0,0.d0) + do nr = 1,LQ + IR_p = dble(Latt%list(nr,1))*Latt%a1_p + dble(Latt%list(nr,2))*Latt%a2_p + X_MAT = X_MAT + exp( cmplx(0.d0,-(Iscalar(XK_p,IR_p))) ) *Xin_R(nr) + enddo + Xout_K(nk) = X_MAT/cmplx(dble(LQ),0.d0) + enddo + + end subroutine FT_R_to_K_C + + + end Module Lattices_v3 + + diff --git a/src/Modules/log_mesh.f90 b/src/Modules/log_mesh.f90 new file mode 100644 index 000000000..4bd964719 --- /dev/null +++ b/src/Modules/log_mesh.f90 @@ -0,0 +1,318 @@ + Module Log_Mesh + + Type logmesh + Real (Kind=8) :: Lambda, Center, Log_Lambda + Real (Kind=8) :: Range + Real (Kind=8) :: Om_st, Om_en, dom + Real (Kind=8) :: Precision + Integer :: Nom,Nw + Real (Kind=8), pointer :: Xom(:),DXom(:) + Character(len=10) :: Type + end Type logmesh + + Interface Lookup_log_mesh + module procedure Lookup_log_mesh_R, Lookup_log_mesh_C + end Interface + Interface Inter_log_mesh + module procedure Inter_log_mesh_R, Inter_log_mesh_C + end Interface + + Contains + + + subroutine Make_log_mesh ( Mesh, Lambda, Center, Range, Type, Nw_1 ) + + Implicit None + + Type (logmesh) :: Mesh + Real (Kind=8) :: Lambda, Center, Range + Integer, Optional :: Nw_1 + Real (Kind=8) :: DeltaX, XS + Integer :: N, nc, Nw + Character(len=10) :: Type + + Real (Kind=8) :: Dom, Om_st, Om_en + + Mesh%Center = Center + Mesh%Range = Range + If (Type == "Log" ) Then + OM_st = Center - Range + OM_en = Center + Range + Mesh%Om_st = Om_st + Mesh%Om_en = Om_en + Mesh%Lambda = Lambda + Mesh%Type = "Log" + if (Present(Nw_1) ) then + Nw = Nw_1 + else + Nw = 10.d0*log(10.d0)/log(Lambda) + endif + Mesh%Nw = Nw + Mesh%Nom = 2*Nw + 3 + Mesh%Log_Lambda = Log(Lambda) + Allocate ( Mesh%Xom(2*Nw + 3), Mesh%DXom(2*Nw+3) ) + Do n = 0,Nw + Mesh%xom (n+1 ) = Center - Range * (Lambda**(-n)) + enddo + Mesh%xom (Nw+2 ) = Center + do n = Nw,0,-1 + Mesh%xom(Nw+3 +(Nw-n) ) = Center + Range * (Lambda**(-n)) + enddo + Mesh%Precision = Mesh%Lambda**(-Mesh%Nw) + elseif (Type == "Lin" ) then + Mesh%Type = "Lin" + If ( Present(Nw_1) ) then + Nw = Nw_1 + Mesh%Nw = Nw + Mesh%Nom = 2*Nw + 1 + Mesh%Type = "Lin" + Allocate ( Mesh%Xom(2*Nw + 1), Mesh%DXom(2*Nw+1) ) + OM_st = Center - Range + OM_en = Center + Range + Dom = Range/dble(Nw_1) + Mesh%Dom = Dom + Mesh%Om_st = Om_st + Mesh%Om_en = Om_en + do n = 1,Mesh%Nom + Mesh%xom(n) = Om_st + dble(n-1)*dom + enddo + else + Write(6,*) ' You need to include Nw for the Lin Mesh ' + stop + endif + else + Write(6,*) 'Mesh has no type!! ' + stop + endif + do n = 1,Mesh%Nom-1 + Mesh%DXom(n) = Mesh%xom (n+1) - Mesh%xom (n ) + enddo + + end subroutine Make_log_mesh + + subroutine Clear_log_mesh ( Mesh ) + Implicit None + + Type (logmesh) :: Mesh + + deallocate ( Mesh%Xom, Mesh%DXom ) + + end subroutine Clear_log_mesh + + Integer Function m_find(X,Mesh) + + Implicit None + + Type (logmesh) :: Mesh + Real (Kind=8) :: X + Integer :: m + + if ( Mesh%Type == "Log" ) then + if ( X > (Mesh%OM_en) .or. X < (Mesh%Om_st) ) then + m = 0 + else + if ( X < Mesh%Xom(Mesh%Nw+1) ) then + m = 2 - Int( log ( (Mesh%Center - X)/Mesh%Range ) / Mesh%Log_Lambda ) + !Write(6,*) 'Hi 1', X + elseif ( X > Mesh%Xom(Mesh%Nw+3) ) then + m = 2*Mesh%Nw + 3 + Int( log ( (X- Mesh%Center) /Mesh%Range ) / Mesh%Log_Lambda ) + !Write(6,*) 'Hi 2', X, Mesh%Center + Mesh%Range + elseif ( X > Mesh%Center ) then + m = Mesh%Nw+3 + else + m = Mesh%Nw+2 + endif + endif + m_find = m + else + m_find = int((x - Mesh%Om_st)/Mesh%dom) + 2 + if (m_find > Mesh%Nom) m_find=Mesh%Nom + if (m_find < 2 ) m_find=2 + endif + + + !Write(6,*) + !Write(6,*) 'Point: ', X + !if ( m > 0 ) then + ! Write(6,*) 'Your point lies inbetween ', Mesh%Xom(m-1), ' and ', Mesh%Xom(m) + !else + ! Write(6,*) 'Out of range ' + !endif + + end Function m_find +!******* + Real(Kind=8) Function Lookup_log_mesh_R(f, x,Mesh,m_1) + + Implicit None + + Type (logmesh) :: Mesh + Real (Kind=8), dimension(:) :: f + Real (Kind=8) :: X + Integer , Optional :: m_1 + + Integer :: n, m + Real (Kind=8) :: X1,X2,Y1,Y2,a,b + + m = m_find(X,Mesh) + if (m == 0 ) then + Lookup_log_mesh_R = 0.d0 + else + x1 = Mesh%xom(m-1) + x2 = Mesh%xom(m ) + y1 = f(m-1) + y2 = f(m) + a = (y1-y2)/(x1-x2) + b = (x1*y2 - x2*y1)/(x1-x2) + Lookup_log_mesh_R = a*x + b + endif + + If ( Present(m_1) ) m_1 = m + + end Function Lookup_log_mesh_R + + + +!******* +!!$ Complex (Kind=8) Function Lookup_log_mesh_C(f, x,Mesh,m_1) +!!$ +!!$ Implicit None +!!$ +!!$ Type (logmesh) :: Mesh +!!$ Complex (Kind=8), dimension(:) :: f +!!$ Real (Kind=8) :: X +!!$ Integer , Optional :: m_1 +!!$ +!!$ +!!$ Integer :: n, m +!!$ Complex (Kind=8) :: X1,X2,Y1,Y2,a,b +!!$ +!!$ m = m_find(X,Mesh) +!!$ if (m == 0 ) then +!!$ Lookup_log_mesh_C = cmplx(0.d0,0.d0) +!!$ else +!!$ x1 = cmplx( Mesh%xom(m-1),0.d0 ) +!!$ x2 = cmplx( Mesh%xom(m ),0.d0 ) +!!$ y1 = f(m-1) +!!$ y2 = f(m ) +!!$ a = (y1-y2)/(x1-x2) +!!$ b = (x1*y2 - x2*y1)/(x1-x2) +!!$ Lookup_log_mesh_C = a*cmplx( x , 0.d0 ) + b +!!$ endif +!!$ +!!$ If ( Present(m_1) ) m_1 = m +!!$ +!!$ end Function Lookup_log_mesh_C + + Complex (Kind=8) Function Lookup_log_mesh_C(f, x,Mesh,m_1) + + Implicit None + + Type (logmesh) :: Mesh + Complex (Kind=8), dimension(:) :: f + Real (Kind=8) :: X + Integer , Optional :: m_1 + + + Integer :: n, m + Complex (Kind=8) :: Z1,Z2, Z + Real (Kind=8) :: x1,x2,t + + m = m_find(X,Mesh) + if (m == 0 ) then + Lookup_log_mesh_C = cmplx(0.d0,0.d0) + else + x1 = Mesh%xom(m-1) + x2 = Mesh%xom(m ) + t = (x1 - X)/(x2-x1) + Z1 = f(m-1) + Z2 = f(m ) + Z = Z1 + (Z1-Z2)*cmplx(t,0.d0) + Lookup_log_mesh_C = Z + endif + + If ( Present(m_1) ) m_1 = m + + end Function Lookup_log_mesh_C + + +!****** + Real (Kind=8) Function Inter_log_mesh_R(f,Mesh) + + Implicit None + + Type (logmesh) :: Mesh + Real (Kind=8), dimension(:) :: f + Real (Kind=8) :: X + Integer :: n + + X = 0.d0 + do n = 1,Mesh%Nom-1 + X = X + Mesh%DXom(n) * (f(n+1) + f(n) ) + enddo + Inter_log_mesh_R = X / 2.d0 + + end Function Inter_log_mesh_R + +!****** + Complex (Kind=8) Function Inter_log_mesh_C(f,Mesh) + + Implicit None + + Type (logmesh) :: Mesh + Complex (Kind=8), dimension(:) :: f + Complex (Kind=8) :: Z + Integer :: n + + Z = cmplx(0.d0,0.d0) + do n = 1,Mesh%Nom-1 + Z = Z + cmplx(Mesh%DXom(n),0.d0) * ( f(n+1) + f(n) ) + enddo + Inter_log_mesh_C = Z / cmplx(2.d0,0.d0) + + end Function Inter_log_mesh_C + + + + subroutine Print_log_mesh(Mesh) + + Implicit None + + Type (logmesh) :: Mesh + + Integer :: n + + If (Mesh%Type == "Log" ) Then + Open (Unit=10,File="Log_Mesh", status="unknown" ) + Write(10,*) '# Log Mesh : ' + Write(10,*) '# Lambda : ', Mesh%Lambda + Write(10,*) '# Range : ', Mesh%Range + Write(10,*) '# Center : ', Mesh%Center + Write(10,*) '# Nom : ', Mesh%Nom + Write(10,*) '# Precision : ', Mesh%Lambda**(-Mesh%Nw) + do n = 1,Mesh%Nom + write(10,"(F16.8)") Mesh%xom(n) + enddo + close(10) + endif + + If (Mesh%Type == "Lin" ) Then + Open (Unit=10,File="Lin_Mesh", status="unknown" ) + Write(10,*) '# Lin Mesh : ' + Write(10,*) '# Range : ', Mesh%Range + Write(10,*) '# Center : ', Mesh%Center + Write(10,*) '# Nom : ', Mesh%Nom + Write(10,*) '# Dom : ', Mesh%dom + do n = 1,Mesh%Nom + write(10,"(F16.8)") Mesh%xom(n) + enddo + close(10) + endif + + + + end subroutine Print_log_mesh + + + end Module Log_Mesh + + diff --git a/src/Modules/machine b/src/Modules/machine new file mode 100644 index 000000000..0caa441b4 --- /dev/null +++ b/src/Modules/machine @@ -0,0 +1 @@ +#define DEC diff --git a/src/Modules/mat_mod.f90 b/src/Modules/mat_mod.f90 new file mode 100644 index 000000000..c9a6fbde5 --- /dev/null +++ b/src/Modules/mat_mod.f90 @@ -0,0 +1,1265 @@ + + MODULE MyMats + + INTERFACE MMULT + !C = A*B MMULT(C, A, B) + MODULE PROCEDURE MMULT_R, MMULT_C + END INTERFACE + INTERFACE INITD + MODULE PROCEDURE INITD_R, INITD_C + END INTERFACE + INTERFACE COMPARE + MODULE PROCEDURE COMPARE_R, COMPARE_C + END INTERFACE + INTERFACE DET + MODULE PROCEDURE DET_C + END INTERFACE DET + INTERFACE INV + MODULE PROCEDURE INV_R0, INV_R_Variable, INV_R_VARIABLE_1, INV_R1, INV_R2, INV_C, INV_C1, & + & INV_C_Variable + END INTERFACE + INTERFACE UDV + MODULE PROCEDURE UDV1_R, UDV_C + END INTERFACE + INTERFACE QR + MODULE PROCEDURE QR_C + END INTERFACE QR + INTERFACE SVD + MODULE PROCEDURE SVD_C + END INTERFACE SVD + INTERFACE DIAG + MODULE PROCEDURE DIAG_R, DIAG_I + END INTERFACE + INTERFACE DIAG_GEN + MODULE PROCEDURE DIAG_GEN + END INTERFACE DIAG_GEN + INTERFACE SECONDS + MODULE PROCEDURE SECONDS + END INTERFACE + CONTAINS + +!************* + SUBROUTINE DIAG_GEN(Z_MAT,U,W,LR,ICON) + IMPLICIT NONE + COMPLEX (KIND=8), INTENT(IN), DIMENSION(:,:) :: Z_MAT + CHARACTER (LEN=1), INTENT(IN) :: LR + COMPLEX (KIND=8), INTENT(INOUT), DIMENSION(:,:) :: U + COMPLEX (KIND=8), INTENT(INOUT), DIMENSION(:) :: W + INTEGER :: ICON + + !!!! Uses Lapack !!! + ! LR = L then U*A = W*U Left eigenvectors + ! LR = R then A*U = W*U Right eigenvectors + + + ! Local space + INTEGER :: N, LDA, LDVL, LDVR, INFO, LWORK, I, J, M + CHARACTER (LEN=1) :: JOBVL, JOBVR + COMPLEX (KIND=8), ALLOCATABLE, DIMENSION(:,:) :: A, VL, VR + REAL (KIND=8) , ALLOCATABLE, DIMENSION(:) :: RWORK + COMPLEX (KIND=8), ALLOCATABLE, DIMENSION(:) :: WORK + + REAL (KIND=8) :: XMAX, X + COMPLEX (KIND=8) :: Z + + N = SIZE(Z_MAT,1) + ALLOCATE(A(N,N)) + A = Z_MAT + LDA = N + + JOBVR = "N" + JOBVL = "N" + LDVL = 1 + LDVR = 1 + IF (LR =="L") THEN + JOBVL ="V" + LDVL = N + ELSEIF (LR =="R") THEN + JOBVR ="V" + LDVR = N + ELSE + WRITE(6,*) 'Error in DIAG_GEN' + STOP + ENDIF + ALLOCATE(VL(LDVL,N), VR(LDVR,N) ) + LWORK = 2*N + ALLOCATE (WORK(LWORK), RWORK(LWORK) ) + + CALL ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, & + & WORK, LWORK, RWORK, INFO ) + + IF (LR=="R") THEN + DO I = 1,N + DO J = 1,N + U(I,J) = VR(I,J) + ENDDO + ENDDO + ELSE + DO I = 1,N + DO J = 1,N + U(I,J) = CONJG(VL(J,I)) + ENDDO + ENDDO + ENDIF + + IF (ICON == 1 ) THEN + !Test + XMAX = 0.d0 + DO I = 1,N + DO J = 1,N + IF (LR=="R") THEN + Z = cmplx(0.d0,0.d0,kind=8) + DO M = 1,N + Z = Z + Z_MAT(I,M)*U(M,J) + ENDDO + Z = Z - W(I)*U(I,J) + X = SQRT( DBLE( Z*CONJG(Z) ) ) + ENDIF + IF (LR=="L") THEN + Z = cmplx(0.d0,0.d0,kind=8) + DO M = 1,N + Z = Z + U(I,M)*Z_MAT(M,J) + ENDDO + Z = Z - W(I)*U(I,J) + X = SQRT( DBLE( Z*CONJG(Z) ) ) + ENDIF + IF ( X > XMAX ) XMAX = X + ENDDO + ENDDO + WRITE(6,*) 'Testing Diag_GEN :', XMAX + !End Test + ENDIF + + DEALLOCATE(VL, VR) + DEALLOCATE(WORK, RWORK) + DEALLOCATE(A) + + + END SUBROUTINE DIAG_GEN +!************* + SUBROUTINE MMULT_R(C, A, B) + IMPLICIT NONE + REAL (KIND=8), DIMENSION(:,:) :: A,B,C + REAL (KIND=8) :: X, ALP, BET + INTEGER I,J, K, N, M, P, LDA, LDB, LDC + N = SIZE(A,1) ! Rows in A + M = SIZE(A,2) ! Columns in A + P = SIZE(B,2) ! Columns in B + LDA = N; LDB = SIZE(B,1); LDC = SIZE(C,1) + + ALP = 1.D0 + BET = 0.D0 + + + CALL DGEMM('n','n',N,P,M,ALP,A,LDA,B,LDB,BET,C,LDC) + + + + + + +! WRITE(6,*) 'In real', N,M,P +! DO I = 1,N +! DO J = 1,P +! X = 0.D0 +! DO K = 1,M +! X = X + A(I,K)*B(K,J) +! ENDDO +! C(I,J) = X +! ENDDO +! ENDDO + END SUBROUTINE MMULT_R + + SUBROUTINE MMULT_C(C, A, B) + IMPLICIT NONE + COMPLEX (KIND=8), DIMENSION(:,:) :: A,B,C + COMPLEX (KIND=8) :: ALP, BET + INTEGER I,J, K, N, M, P, LDA, LDB, LDC + + N = SIZE(A,1) + M = SIZE(A,2) + P = SIZE(B,2) + LDA = N; LDB = SIZE(B,1); LDC = SIZE(C,1) + + ALP = DCMPLX(1.D0,0.D0) + BET = DCMPLX(0.D0,0.D0) + + CALL ZGEMM('n','n',N,P,M,ALP,A,LDA,B,LDB,BET,C,LDC) + + + ! WRITE(6,*) 'In complex', N,M,P + ! DO I = 1,N + ! DO J = 1,P + ! X = CMPLX(0.D0,0.D0) + ! DO K = 1,M + ! X = X + A(I,K)*B(K,J) + ! ENDDO + ! C(I,J) = X + ! ENDDO + ! ENDDO + + END SUBROUTINE MMULT_C + +!********* + SUBROUTINE INITD_R(A,X) + IMPLICIT NONE + REAL (KIND=8), DIMENSION(:,:) :: A + REAL (KIND=8) X + INTEGER I,J, N, M + + N = SIZE(A,1) + M = SIZE(A,2) + + ! WRITE(6,*) 'In Init1 real', N,M + DO I = 1,N + DO J = 1,M + A(I,J) = 0.D0 + ENDDO + ENDDO + DO I = 1,N + A(I,I) = X + ENDDO + END SUBROUTINE INITD_R + + SUBROUTINE INITD_C(A,X) + IMPLICIT NONE + COMPLEX (KIND=8), DIMENSION(:,:) :: A + COMPLEX (KIND=8) X + INTEGER I,J, N, M + + N = SIZE(A,1) + M = SIZE(A,2) + +! WRITE(6,*) 'In Init1 complex', N,M + DO I = 1,N + DO J = 1,M + A(I,J) = CMPLX(0.D0,0.D0) + ENDDO + ENDDO + DO I = 1,N + A(I,I) = X + ENDDO + END SUBROUTINE INITD_C + + +!************* + SUBROUTINE INV_R0(A,AINV,DET) + IMPLICIT NONE + REAL (KIND=8), DIMENSION(:,:) :: A,AINV + REAL (KIND=8) :: DET + INTEGER I,J, N, M + +! Working space. + REAL (KIND=8) :: DET1(2) + REAL (KIND=8), DIMENSION(:), ALLOCATABLE :: WORK + INTEGER, DIMENSION(:), ALLOCATABLE :: IPVT + INTEGER INFO, JOB, LDA + + LDA = SIZE(A,1) +! Working space. + ALLOCATE ( IPVT(LDA) ) + ALLOCATE ( WORK(LDA) ) + + + DO I = 1,LDA + DO J = 1,LDA + AINV(J,I) = A(J,I) + ENDDO + ENDDO + +! Linpack routines. + + CALL DGEFA(AINV,LDA,LDA,IPVT,INFO) + JOB = 11 + CALL DGEDI(AINV,LDA,LDA,IPVT,DET1,WORK,JOB) + + !Write(6,*) 'In Inv_R0', DET1 + DET = DET1(1) * 10.D0**DET1(2) + + + DEALLOCATE (IPVT) + DEALLOCATE (WORK) + END SUBROUTINE INV_R0 + + +!************* + SUBROUTINE INV_R_Variable(A,AINV,DET,Ndim) + IMPLICIT NONE + REAL (KIND=8), DIMENSION(:,:) :: A,AINV + REAL (KIND=8) :: DET + INTEGER I,J, N, M, Ndim + +! Working space. + REAL (KIND=8) :: DET1(2) + REAL (KIND=8), DIMENSION(:), ALLOCATABLE :: WORK + INTEGER, DIMENSION(:), ALLOCATABLE :: IPVT + INTEGER INFO, JOB, LDA + + LDA = SIZE(A,1) +! Working space. + ALLOCATE ( IPVT(Ndim) ) + ALLOCATE ( WORK(Ndim) ) + + + DO I = 1,LDA + DO J = 1,LDA + AINV(J,I) = A(J,I) + ENDDO + ENDDO + +! Linpack routines. + + CALL DGEFA(AINV,LDA,Ndim,IPVT,INFO) + JOB = 11 + CALL DGEDI(AINV,LDA,Ndim,IPVT,DET1,WORK,JOB) + + DET = DET1(1) * 10.D0**DET1(2) + + DEALLOCATE (IPVT) + DEALLOCATE (WORK) + END SUBROUTINE INV_R_VARIABLE + +!************* + SUBROUTINE INV_R_Variable_1(A,AINV,DET,Ndim) + IMPLICIT NONE + REAL (KIND=8), DIMENSION(:,:) :: A,AINV + REAL (KIND=8) :: DET(2) + INTEGER I,J, N, M, Ndim + +! Working space. + REAL (KIND=8) :: DET1(2) + REAL (KIND=8), DIMENSION(:), ALLOCATABLE :: WORK + INTEGER, DIMENSION(:), ALLOCATABLE :: IPVT + INTEGER INFO, JOB, LDA + + LDA = SIZE(A,1) +! Working space. + ALLOCATE ( IPVT(Ndim) ) + ALLOCATE ( WORK(Ndim) ) + + + DO I = 1,LDA + DO J = 1,LDA + AINV(J,I) = A(J,I) + ENDDO + ENDDO + +! Linpack routines. + + CALL DGEFA(AINV,LDA,Ndim,IPVT,INFO) + JOB = 11 + CALL DGEDI(AINV,LDA,Ndim,IPVT,DET1,WORK,JOB) + + ! Determinant = DET1(1) * 10.D0**DET1(2) + DET(1) = DET1(1) + DET(2) = DET1(2) + + DEALLOCATE (IPVT) + DEALLOCATE (WORK) + END SUBROUTINE INV_R_VARIABLE_1 + + +!************* + SUBROUTINE INV_R1(A,AINV,DET1) + IMPLICIT NONE + REAL (KIND=8), DIMENSION(:,:) :: A,AINV + REAL (KIND=8) :: DET1(2) + INTEGER I,J, N, M + +! Working space. + REAL (KIND=8), DIMENSION(:), ALLOCATABLE :: WORK + INTEGER, DIMENSION(:), ALLOCATABLE :: IPVT + INTEGER INFO, JOB, LDA + + LDA = SIZE(A,1) +! Working space. + ALLOCATE ( IPVT(LDA) ) + ALLOCATE ( WORK(LDA) ) + + + DO I = 1,LDA + DO J = 1,LDA + AINV(J,I) = A(J,I) + ENDDO + ENDDO + +! Linpack routines. + + CALL DGEFA(AINV,LDA,LDA,IPVT,INFO) + JOB = 11 + CALL DGEDI(AINV,LDA,LDA,IPVT,DET1,WORK,JOB) + + + + + + + + DEALLOCATE (IPVT) + DEALLOCATE (WORK) + END SUBROUTINE INV_R1 + +!************* + SUBROUTINE INV_R2(A,AINV) + IMPLICIT NONE + REAL (KIND=8), DIMENSION(:,:) :: A,AINV + + INTEGER I,J, N, M + +! Uses Lapack routines. + +! Working space. + REAL (KIND=8), DIMENSION(:), ALLOCATABLE :: WORK + INTEGER, DIMENSION(:), ALLOCATABLE :: IPIV + INTEGER INFO, JOB, LDA, LWORK + + LDA = SIZE(A,1) + + !Write(6,*) 'Inv_r2:', LDA + ALLOCATE ( IPIV(LDA) ) + LWORK = LDA + ALLOCATE ( WORK(LWORK) ) + WORK = 0.0 + IPIV = 0 + DO I = 1,LDA + DO J = 1,LDA + AINV(J,I) = A(J,I) + ENDDO + ENDDO + INFO = 0 + + + CALL DGETRF( LDA, LDA, AINV, LDA, IPIV, INFO ) + CALL DGETRI(LDA, AINV, LDA, IPIV, WORK, LWORK, INFO) + + + + + + + +! Compute the determinant here if needed. +! detz = dcmplx(1.d0,0.d0) +! do n = 1,ne +! detz = detz * AINV(n,n) +! enddo ! Check. This may be wrong. + + + DEALLOCATE (IPIV) + DEALLOCATE (WORK) + END SUBROUTINE INV_R2 +!************* + + SUBROUTINE INV_C(A,AINV,DET) + IMPLICIT NONE + COMPLEX (KIND=8), DIMENSION(:,:) :: A,AINV + COMPLEX (KIND=8) :: DET + INTEGER I,J, N, M + +! Working space. + COMPLEX (KIND=8) :: DET1(2) + COMPLEX (KIND=8), DIMENSION(:), ALLOCATABLE :: WORK + INTEGER, DIMENSION(:), ALLOCATABLE :: IPVT + INTEGER INFO, JOB, LDA + + LDA = SIZE(A,1) +! Working space. + ALLOCATE ( IPVT(LDA) ) + ALLOCATE ( WORK(LDA) ) + + + DO I = 1,LDA + DO J = 1,LDA + AINV(J,I) = A(J,I) + ENDDO + ENDDO + +! Linpack routines. + + CALL ZGEFA(AINV,LDA,LDA,IPVT,INFO) + JOB = 11 + CALL ZGEDI(AINV,LDA,LDA,IPVT,DET1,WORK,JOB) + + + + + + + + DET = DET1(1)*10.D0**DET1(2) + + DEALLOCATE (IPVT) + DEALLOCATE (WORK) + END SUBROUTINE INV_C + +!======================================================================== + SUBROUTINE INV_C_Variable(A,AINV,DET,Ndim) + IMPLICIT NONE + COMPLEX (KIND=8), DIMENSION(:,:) :: A,AINV + COMPLEX (KIND=8) :: DET + INTEGER I,J, N, M,Ndim + +! Working space. + COMPLEX (KIND=8) :: DET1(2) + COMPLEX (KIND=8), DIMENSION(:), ALLOCATABLE :: WORK + INTEGER, DIMENSION(:), ALLOCATABLE :: IPVT + INTEGER INFO, JOB, LDA + + LDA = SIZE(A,1) +! Working space. + ALLOCATE ( IPVT(Ndim) ) + ALLOCATE ( WORK(Ndim) ) + + + DO I = 1,LDA + DO J = 1,LDA + AINV(J,I) = A(J,I) + ENDDO + ENDDO + +! Linpack routines. + + CALL ZGEFA(AINV,LDA,Ndim,IPVT,INFO) + JOB = 11 + CALL ZGEDI(AINV,LDA,Ndim,IPVT,DET1,WORK,JOB) + + + DET = DET1(1)*10.D0**DET1(2) + + DEALLOCATE (IPVT) + DEALLOCATE (WORK) + END SUBROUTINE INV_C_VARIABLE + +!======================================================================== + SUBROUTINE INV_C1(A,AINV,DET1) + IMPLICIT NONE + COMPLEX (KIND=8), DIMENSION(:,:) :: A,AINV + COMPLEX (KIND=8) :: DET1(2) + INTEGER I,J, N, M + +! Working space. + COMPLEX (KIND=8), DIMENSION(:), ALLOCATABLE :: WORK + INTEGER, DIMENSION(:), ALLOCATABLE :: IPVT + INTEGER INFO, JOB, LDA + + LDA = SIZE(A,1) +! Working space. + ALLOCATE ( IPVT(LDA) ) + ALLOCATE ( WORK(LDA) ) + + + DO I = 1,LDA + DO J = 1,LDA + AINV(J,I) = A(J,I) + ENDDO + ENDDO + +! Linpack routines. + + CALL ZGEFA(AINV,LDA,LDA,IPVT,INFO) + JOB = 11 + CALL ZGEDI(AINV,LDA,LDA,IPVT,DET1,WORK,JOB) + + + DEALLOCATE (IPVT) + DEALLOCATE (WORK) + END SUBROUTINE INV_C1 +!***** + + + + SUBROUTINE COMPARE_C(A,B,XMAX,XMEAN) + IMPLICIT NONE + COMPLEX (KIND=8), DIMENSION(:,:) :: A,B + REAL (KIND=8) :: XMAX, XMEAN + INTEGER I,J, N, M + + REAL (KIND=8) :: DIFF + + N = SIZE(A,1) + M = SIZE(A,2) + + XMAX = 0.D0 + XMEAN = 0.D0 + DO I = 1,N + DO J = 1,M + DIFF = SQRT( (A(I,J) - B(I,J))*CONJG(A(I,J)-B(I,J))) + IF (DIFF.GT.XMAX) XMAX = DIFF + XMEAN = XMEAN + DIFF + ENDDO + ENDDO + XMEAN = XMEAN/DBLE(N*M) + END SUBROUTINE COMPARE_C + + SUBROUTINE COMPARE_R(A,B,XMAX,XMEAN) + IMPLICIT NONE + REAL (KIND=8) , INTENT(IN), DIMENSION(:,:) :: A,B + REAL (KIND=8) , INTENT(INOUT) :: XMAX, XMEAN + INTEGER I,J, N, M + + REAL (KIND=8) :: DIFF + + N = SIZE(A,1) + M = SIZE(A,2) + + XMAX = 0.D0 + XMEAN = 0.D0 + DO I = 1,N + DO J = 1,M + DIFF = ABS( ( B(I,J) - A(I,J) ) ) + IF (DIFF.GT.XMAX) XMAX = DIFF + XMEAN = XMEAN + DIFF + ENDDO + ENDDO + XMEAN = XMEAN/DBLE(N*M) + END SUBROUTINE COMPARE_R + +!***************** + SUBROUTINE UDV1_R(A,U,D,V,NCON) + IMPLICIT NONE + REAL (KIND=8), INTENT(IN), DIMENSION(:,:) :: A + REAL (KIND=8), INTENT(INOUT), DIMENSION(:,:) :: U,V + REAL (KIND=8), INTENT(INOUT), DIMENSION(:) :: D + INTEGER, INTENT(IN) :: NCON + INTEGER I,J,K, N, M, ND1, ND2, NR, IMAX, IFAIL + +! The Det of V is not equal to unity. +! Locals: + INTEGER, DIMENSION(:), ALLOCATABLE :: IVPT, IVPTM1 + REAL (KIND=8), DIMENSION(:), ALLOCATABLE :: XNORM, VHELP,& + & THETA, WORK + REAL (KIND=8), DIMENSION(:,:), ALLOCATABLE :: TMP, V1,& + & TEST, TEST1, TEST2 + REAL (KIND=8) :: XMAX, XMEAN, Z, DETV + + ND1 = SIZE(A,1) + ND2 = SIZE(A,2) + + + +! WRITE(6,*) 'Udv A: ',ND1,ND2 +! WRITE(6,*) 'Udv V: ',size(V,1), size(V,2) +! You should now check corresponding sizes for U,V,D. + IF (SIZE(U,1).NE.ND1 .OR. SIZE(U,2).NE.ND2) THEN + WRITE(6,*) 'UDV dim mistake: U' + STOP + ENDIF + IF (SIZE(D,1).NE.ND2 ) THEN + WRITE(6,*) 'UDV dim mistake: D' + STOP + ENDIF + IF (SIZE(V,1).NE.ND2 .OR. SIZE(V,2).NE.ND2) THEN + WRITE(6,*) 'UDV dim mistake: V' + STOP + ENDIF + + ALLOCATE(XNORM (ND2)) + ALLOCATE(VHELP (ND2)) + ALLOCATE(IVPT (ND2)) + ALLOCATE(IVPTM1(ND2)) + ALLOCATE(WORK (ND2)) + ALLOCATE(THETA (ND2)) + + ALLOCATE(TMP(ND1,ND2)) + ALLOCATE(V1 (ND2,ND2)) + + V1 = 0.D0 + + DO I = 1,ND2 + XNORM(I) = 0.D0 + DO NR = 1,ND1 + XNORM(I) = XNORM(I) + ABS(A(NR,I)) + ENDDO + ENDDO + DO I = 1,ND2 + VHELP(I) = XNORM(I) + ENDDO + + DO I = 1,ND2 + XMAX = 0.D0 + DO J = 1,ND2 + IF (VHELP(J).GT.XMAX) IMAX = J + IF (VHELP(J).GT.XMAX) XMAX = VHELP(J) + ENDDO + VHELP(IMAX) = -1.D0 + IVPTM1(IMAX)=I + IVPT(I) = IMAX + ENDDO + + DO I = 1,ND2 + Z = 1.D0/XNORM(IVPT(I)) + K = IVPT(I) + DO NR = 1,ND1 + TMP(NR,I) = A(NR,K)*Z + ENDDO + ENDDO + + + !You now want to UDV TMP. Nag routines. + IFAIL = 0 + + + CALL F01QCF(ND1,ND2,TMP,ND1,THETA,IFAIL) + + + !Scale V1 to a unit triangluar matrix. + DO I = 1,ND2 + D(I) = ABS(TMP(I,I)) + ENDDO + DO I = 1,ND2 + Z = 1.D0/D(I) + DO J = I,ND2 + V1(I,J) = TMP(I,J)*Z + ENDDO + ENDDO + + +! Compute U + IFAIL = 0 + + CALL F01QEF('Separate', ND1,ND2, ND2, TMP,& + & ND1, THETA, WORK, IFAIL) + + + DO I = 1,ND1 + DO J = 1,ND2 + U(I,J) = TMP(I,J) + ENDDO + ENDDO + + +! Finish the pivotting. + DO I = 1,ND2 + D(I) = D(I)*XNORM(IVPT(I)) + ENDDO + DO I = 1,ND2-1 + Z = 1.D0/XNORM(IVPT(I)) + DO J = I+1,ND2 + V1(I,J) = V1(I,J)*XNORM(IVPT(J))*Z + ENDDO + ENDDO + + DO J = 1,ND2 + DO I = 1,ND2 + V(I,J) = V1(I,IVPTM1(J)) + ENDDO + ENDDO + +! Test accuracy. + IF (NCON.EQ.1) THEN + ALLOCATE (TEST(ND1,ND2)) + DO J = 1,ND2 + DO I = 1,ND1 + Z = 0.D0 + DO NR = 1,ND2 + Z = Z + U(I,NR)*D(NR)*V(NR,J) + ENDDO + TEST(I,J) = Z + ENDDO + ENDDO + XMAX = 0.0; XMEAN = 0.0 + CALL COMPARE(TEST,A,XMAX,XMEAN) + WRITE(6,*) 'Accuracy: ',XMAX + DEALLOCATE (TEST) + + ALLOCATE (TEST (ND2,ND1)) + ALLOCATE (TEST1 (ND2,ND2)) + ALLOCATE (TEST2 (ND2,ND2)) + ! Check orthogonality of U + DO I = 1,ND1 + DO J = 1,ND2 + TEST(J,I) = U(I,J) + ENDDO + ENDDO + CALL MMULT(TEST1,TEST,U) + CALL INITD(TEST2,1.D0) + XMAX = 0.0; XMEAN = 0.0 + CALL COMPARE(TEST1,TEST2,XMAX,XMEAN) + WRITE(6,*) 'UDV1 orth U: ',XMAX + DEALLOCATE (TEST ) + DEALLOCATE (TEST1 ) + DEALLOCATE (TEST2 ) + ENDIF + + + DEALLOCATE(XNORM ) + DEALLOCATE(VHELP ) + DEALLOCATE(IVPT ) + DEALLOCATE(IVPTM1) + DEALLOCATE(WORK ) + DEALLOCATE(THETA ) + + DEALLOCATE(TMP) + DEALLOCATE(V1 ) + + END SUBROUTINE UDV1_R + +!*************** + SUBROUTINE UDV_C(A,U,D,V,NCON) + !Uses Nag library. + !#include "machine" + + IMPLICIT NONE + COMPLEX (KIND=8), INTENT(IN), DIMENSION(:,:) :: A + COMPLEX (KIND=8), INTENT(INOUT), DIMENSION(:,:) :: U,V + COMPLEX (KIND=8), INTENT(INOUT), DIMENSION(:) :: D + INTEGER, INTENT(IN) :: NCON + INTEGER :: NE, LQ, IFAIL, I, J, NR + + !Local + COMPLEX (KIND=8), DIMENSION(:,:), ALLOCATABLE :: TMP, TEST + COMPLEX (KIND=8), DIMENSION(:), ALLOCATABLE :: THETA, WORK + COMPLEX (KIND=8) :: Z + REAL (KIND=8) :: DETV, XMDIFF, X + + LQ = SIZE(A,1) + NE = SIZE(A,2) + + U = DCMPLX(0.D0,0.D0) ; V = DCMPLX(0.D0,0.D0); D = DCMPLX(0.D0,0.D0) + ALLOCATE (TMP(LQ,NE), THETA(NE), WORK(NE)) + + TMP = A + + !You now want to UDV TMP. Nag routines. + IFAIL = 0 + + CALL F01RCF(LQ,NE,TMP,LQ,THETA,IFAIL) + + + DO I = 1,NE + DO J = I,NE + V(I,J) = TMP(I,J) + ENDDO + ENDDO + DETV = 1.D0 + !V is an NE by NE upper triangular matrix with real diagonal elements. + DO I = 1,NE + DETV = DETV * DBLE( TMP(I,I) ) + ENDDO + + !Compute U + + CALL F01REF('Separate', LQ,NE, NE, TMP, & + & LQ, THETA, WORK, IFAIL) + + + + + + DO J = 1,NE + DO I = 1,LQ + U(I,J) = TMP(I,J) + ENDDO + ENDDO + + IF (DBLE(DETV).LT.0.D0) THEN + DO I = 1,LQ + U(I,1) = -U(I,1) + ENDDO + DO I = 1,NE + V(1,I) = -V(1,I) + ENDDO + ENDIF + + !Scale V1 to a unit triangluar matrix. + DO I = 1,NE + D(I) = CMPLX(ABS(DBLE(V(I,I))),0.D0) + ENDDO + DO I = 1,NE + Z = DCMPLX(1.D0,0.D0)/D(I) + DO J = I,NE + V(I,J) = V(I,J)*Z + ENDDO + ENDDO + + !Test accuracy. + IF (NCON.EQ.1) THEN + ALLOCATE( TEST(LQ,NE) ) + DO J = 1,NE + DO I = 1,LQ + Z = DCMPLX(0.D0,0.D0) + DO NR = 1,NE + Z = Z + U(I,NR)*D(NR)*V(NR,J) + ENDDO + TEST(I,J) = Z + ENDDO + ENDDO + XMDIFF = 0.D0 + DO J = 1,LQ + DO I = 1,NE + Z = (TEST(J,I)-A(J,I)) * CONJG(TEST(J,I)-A(J,I)) + X = SQRT(DBLE(Z)) + IF (X.GT.XMDIFF) XMDIFF = X + ENDDO + ENDDO + WRITE(6,*) 'Accuracy, ortho: ',XMDIFF + DEALLOCATE( TEST ) + ENDIF + + DEALLOCATE (TMP, THETA, WORK) + + RETURN + END SUBROUTINE UDV_C + +!*************** + SUBROUTINE QR_C(A,U,V,NCON) + !Uses Nag library. + !#include "machine" + + IMPLICIT NONE + COMPLEX (KIND=8), INTENT(IN), DIMENSION(:,:) :: A + COMPLEX (KIND=8), INTENT(INOUT), DIMENSION(:,:) :: U,V + INTEGER, INTENT(IN) :: NCON + INTEGER :: NE, LQ, IFAIL, I, J, NR + + !Local + COMPLEX (KIND=8), DIMENSION(:,:), ALLOCATABLE :: TMP, TEST + COMPLEX (KIND=8), DIMENSION(:), ALLOCATABLE :: THETA, WORK + COMPLEX (KIND=8) :: Z + REAL (KIND=8) :: DETV, XMDIFF, X + + LQ = SIZE(A,1) + NE = SIZE(A,2) + + U = DCMPLX(0.D0,0.D0) ; V = DCMPLX(0.D0,0.D0) + ALLOCATE (TMP(LQ,NE), THETA(NE), WORK(NE)) + + TMP = A + + !You now want to UDV TMP. Nag routines. + IFAIL = 0 + + CALL F01RCF(LQ,NE,TMP,LQ,THETA,IFAIL) + + + DO I = 1,NE + DO J = I,NE + V(I,J) = TMP(I,J) + ENDDO + ENDDO + DETV = 1.D0 + !V is an NE by NE upper triangular matrix with real diagonal elements. + DO I = 1,NE + DETV = DETV * DBLE( TMP(I,I) ) + ENDDO + + !Compute U + + CALL F01REF('Separate', LQ,NE, NE, TMP, & + & LQ, THETA, WORK, IFAIL) + + DO J = 1,NE + DO I = 1,LQ + U(I,J) = TMP(I,J) + ENDDO + ENDDO + + IF (DBLE(DETV).LT.0.D0) THEN + DO I = 1,LQ + U(I,1) = -U(I,1) + ENDDO + DO I = 1,NE + V(1,I) = -V(1,I) + ENDDO + ENDIF + + + !Test accuracy. + IF (NCON.EQ.1) THEN + ALLOCATE( TEST(LQ,NE) ) + DO J = 1,NE + DO I = 1,LQ + Z = DCMPLX(0.D0,0.D0) + DO NR = 1,NE + Z = Z + U(I,NR)*V(NR,J) + ENDDO + TEST(I,J) = Z + ENDDO + ENDDO + XMDIFF = 0.D0 + DO J = 1,LQ + DO I = 1,NE + Z = (TEST(J,I)-A(J,I)) * CONJG(TEST(J,I)-A(J,I)) + X = SQRT(DBLE(Z)) + IF (X.GT.XMDIFF) XMDIFF = X + ENDDO + ENDDO + WRITE(6,*) 'Accuracy, QR: ',XMDIFF + DEALLOCATE( TEST ) + ENDIF + + DEALLOCATE (TMP, THETA, WORK) + + RETURN + END SUBROUTINE QR_C +!******************** + SUBROUTINE SVD_C(A,U,D,V,NCON) + !Uses LaPack Routine + !#include "machine" + + IMPLICIT NONE + COMPLEX (KIND=8), INTENT(IN), DIMENSION(:,:) :: A + COMPLEX (KIND=8), INTENT(INOUT), DIMENSION(:,:) :: U,V + COMPLEX (KIND=8), INTENT(INOUT), DIMENSION(:) :: D + INTEGER, INTENT(IN) :: NCON + + !! Local + REAL (Kind=8), Allocatable :: RWORK(:), S(:) + COMPLEX (Kind=8), Allocatable :: WORK(:), A1(:,:) + CHARACTER (Len=1):: JOBU,JOBVT + INTEGER :: M,N, LDA, LDVT, LDU, LWORK, I, J, I1, INFO + REAL (Kind=8) :: X, Xmax + COMPLEX (Kind=8) :: Z + + JOBU = "A" + JOBVT= "A" + M = SIZE(A,1) + N = SIZE(A,2) + Allocate (A1(M,N)) + Allocate (S(N)) + A1 = A + LDA = M + LDU = M + LDVT = N + if (M > N) then + LWORK = 2*N + M + I = 3*N + IF ( 5*N -4 > I) I = 5*N -4 + ALLOCATE (RWORK(I)) + Else + LWORK = 2*M + N + I = 3*M + IF ( 5*M -4 > I) I = 5*M -4 + ALLOCATE (RWORK(I)) + Endif + Allocate (WORK(LWORK)) + + + CALL ZGESVD( JOBU, JOBVT, M, N, A1, LDA, S, U, LDU, V, LDVT,& + & WORK, LWORK, RWORK, INFO ) + + DO I = 1,N + D(I) = cmplx(S(I),0.d0,kind=8) + ENDDO + + IF (NCON == 1) THEN + Write(6,*) JobU, JobVT + Xmax = 0.d0 + DO I = 1,M + DO I1 = 1,N + Z = cmplx(0.d0,0.d0,Kind=8) + DO J = 1,N + Z = Z + U(I,J) *D(J) *V(J,I1) + ENDDO + X = sqrt(Real((Z - A(I,I1))*Conjg(Z - A(I,I1)))) + IF (X > Xmax ) Xmax = X + ENDDO + ENDDO + WRITE(6,*) "Success (0), PRE ", INFO, Xmax + ENDIF + + + Deallocate (WORK,RWORK,A1,S) + + + END SUBROUTINE SVD_C +!*************** + + SUBROUTINE DIAG_R(A,U,W) + IMPLICIT NONE + REAL (KIND=8), INTENT(IN), DIMENSION(:,:) :: A + REAL (KIND=8), INTENT(INOUT), DIMENSION(:,:) :: U + REAL (KIND=8), INTENT(INOUT), DIMENSION(:) :: W + + + INTEGER ND1,ND2, MATZ,IERR + REAL (KIND=8), DIMENSION(:), ALLOCATABLE :: FV1,FV2 + + ND1 = SIZE(A,1) + ND2 = SIZE(A,2) + + IF (ND1.NE.ND2) THEN + WRITE(6,*) 'Error in matrix dimension DIAG_R' + STOP + ENDIF + + MATZ = 1 + IERR = 0 + U=0 + W=0 + ALLOCATE(FV1(ND1)) + ALLOCATE(FV2(ND1)) + CALL RS(ND1,ND1,A,W,MATZ,U, FV1,FV2,IERR) + DEALLOCATE(FV1) + DEALLOCATE(FV2) + + END SUBROUTINE DIAG_R +!********* + + SUBROUTINE DIAG_I(A,U,W) + ! Uses Lapack + IMPLICIT NONE + COMPLEX (KIND=8), INTENT(IN) , DIMENSION(:,:) :: A + COMPLEX (KIND=8), INTENT(INOUT), DIMENSION(:,:) :: U + REAL (KIND=8), INTENT(INOUT), DIMENSION(:) :: W + + CHARACTER (len=1) :: UPLO, JOBZ + INTEGER :: N, LWORK, INFO + COMPLEX (KIND=8), allocatable :: WORK (:) + REAL (KIND=8), allocatable :: RWORK(:) + Logical :: Test + Integer :: I,J,m + Complex (Kind=8) :: Z + Real (Kind=8) :: X, XMAX + + JOBZ = "V" + UPLO = "U" + N = size(A,1) + U = A + LWORK = 2*N -1 + Allocate ( WORK(LWORK) ) + Allocate ( RWORK(3*N-2)) + + !Write(6,*) 'In Diag' + + Call ZHEEV (JOBZ, UPLO, N, U, N, W, WORK, LWORK, RWORK, INFO) + + Deallocate (WORK, RWORK) + + Test = .false. + If (Test) then + XMAX = 0.d0 + DO I = 1,N + DO J = 1,N + Z = cmplx(0.d0,0.d0,kind=8) + DO m = 1,N + Z = Z + U(I,m)*cmplx(W(m),0.d0, Kind=8)*Conjg(U(J,m)) + ENDDO + Z = Z - A(I,J) + X = sqrt( Z*Conjg(Z) ) + If (X > XMAX ) XMAX = X + ENDDO + ENDDO + write(6,*) ' Test Diag_I: ', XMAX + endif + + End SUBROUTINE DIAG_I +!==================================================== + SUBROUTINE DIAG_I_old(A,U,W) + ! Uses Eispack + IMPLICIT NONE + COMPLEX (KIND=8), INTENT(IN) , DIMENSION(:,:) :: A + COMPLEX (KIND=8), INTENT(INOUT), DIMENSION(:,:) :: U + REAL (KIND=8), INTENT(INOUT), DIMENSION(:) :: W + + + INTEGER ND1,ND2, MATZ,IERR, I,J + REAL (KIND=8), DIMENSION( :), ALLOCATABLE :: FV1,FV2 + REAL (KIND=8), DIMENSION(:,:), ALLOCATABLE :: AR,AI, ER, EI, FM1 + + + ND1 = SIZE(A,1) + ND2 = SIZE(A,2) + + IF (ND1.NE.ND2) THEN + WRITE(6,*) 'Error in matrix dimension DIAG_I' + STOP + ENDIF + ND2 = SIZE(W,1) + IF (ND2.NE.ND1) THEN + WRITE(6,*) 'Error 1 in matrix dimension DIAG_I' + STOP + ENDIF + ND2 = SIZE(U,1) + IF (ND2.NE.ND1) THEN + WRITE(6,*) 'Error 2 in matrix dimension DIAG_I' + STOP + ENDIF + ND2 = SIZE(U,2) + IF (ND2.NE.ND1) THEN + WRITE(6,*) 'Error 3 in matrix dimension DIAG_I' + STOP + ENDIF + ALLOCATE (AR(ND1,ND1), AI(ND1,ND1), ER(ND1,ND1), EI(ND1,ND1)) + ALLOCATE (FV1(ND1), FV2(ND1), FM1(2,ND1)) + + MATZ = 1 + IERR = 0 + U=0 + W=0 + DO J = 1,ND1 + DO I = 1,ND1 + AR(I,J) = DBLE (A(I,J)) + AI(I,J) = AIMAG(A(I,J)) + ENDDO + ENDDO + CALL CH(ND1,ND1,AR,AI, W, MATZ,ER,EI, FV1,FV2,FM1,IERR) + DO J = 1,ND1 + DO I = 1,ND1 + U(I,J) = CMPLX (ER(I,J), EI(I,J)) + ENDDO + ENDDO + + DEALLOCATE (AR, AI, ER, EI) + DEALLOCATE (FV1, FV2, FM1) + + END SUBROUTINE DIAG_I_OLD + + + SUBROUTINE SECONDS(X) + IMPLICIT NONE + REAL (KIND=8), INTENT(INOUT) :: X + + !DATE_AND_TIME(date, time, zone, values) + !date_and_time([date][,time][,zone][,values]) + !Subroutine. Die Parameter haben das Attribut intent(out), geben also Werte zurück. + + ! date: skalare, normale Zeichenvariable von wenigstens 8 Zeichen. Die linken 8 Zeichen bekommen einen Wert der Form JJJJMMTT . JJJJ Jahr, MM Monat, TT Tag im Monat. + !time: skalare, normale Zeichenvariable von wenigstens 10 Zeichen. Die linken 10 Zeichen bekommen einen Wert der Form hhmmss.sss , wobei hh die Stunde des Tages ist, mm die Minute innerhalb der Stunde, und ss.sss die Sekunde mit Bruchteilen. + ! zone: skalare, normale Zeichenvariable von wenigstens 5 Zeichen. Die linken 5 Zeichen bekommen einen Wert der Form hhmm . hh Stunden, mm Minuten Zeitdifferenz gegenüber der UTC-Weltzeit. + !values: Eindimensionales Integer-Feld. Länge wenigstens 8. 1: Jahr, z.B. 1993. 2: Monat. 3: Monatstag. 4: Zeitdifferenz zur Weltzeit in Minuten. 5: Stunde des Tages. 6: Minute innerhalb der Stunde. 7: Sekunden 8. Millisekunden. + + !character(len=10) :: d,t + integer,dimension(8) :: V + !d = "" + !call date_and_time(date=d,time=t) + call date_and_time(values=V) + + X = DBLE(V(5)*3600 + V(6)*60 + V(7)) + + END SUBROUTINE SECONDS + +!==================================================== + Complex (Kind=8) Function DET_C(Mat,N) + + Implicit none + + ! Arguments + Integer, intent(in) :: N + Complex(kind=8), intent(inout) :: mat(N,N) + + integer :: i, info + integer :: ipiv(N) + + integer :: sgn + + ipiv = 0 + + !Lapack LU decomposition + call zgetrf(N, N, mat, N, ipiv, info) + + det_C = cmplx(1.d0,0.d0) + do i = 1, N + det_C = det_C*mat(i, i) + enddo + + sgn = 1 + do i = 1, N + if(ipiv(i) /= i) sgn = -sgn + enddo + if (sgn == -1 ) det_C = - det_C + + end function DET_C + + + END MODULE MyMats diff --git a/src/Modules/matrix.f90 b/src/Modules/matrix.f90 new file mode 100644 index 000000000..295b76179 --- /dev/null +++ b/src/Modules/matrix.f90 @@ -0,0 +1,80 @@ + MODULE Matrix + + + + Type Mat_C + complex (Kind=8), pointer :: el(:,:) + Integer :: dim + end Type Mat_C + + Type Mat_R + Real (Kind=8), pointer :: el(:,:) + Integer :: dim + end Type Mat_R + + Interface Make_Mat + module procedure constructor_C, constructor_R + end Interface + Interface Clear_Mat + module procedure Destroy_C, Destroy_R + end Interface + + Contains + subroutine constructor_C(Mat,N) + type (Mat_C) :: Mat + Integer :: N + allocate (Mat%el(N,N)) + Mat%el = cmplx(0.0,0.0) + Mat%dim = N + end subroutine constructor_C + + subroutine constructor_R(Mat,N) + type (Mat_R) :: Mat + Integer :: N + allocate (Mat%el(N,N)) + Mat%el = 0.0 + Mat%dim = N + end subroutine constructor_R + + subroutine Destroy_C(Mat) + type (Mat_C) :: Mat + deallocate (Mat%el) + end subroutine Destroy_C + + subroutine Destroy_R(Mat) + type (Mat_R) :: Mat + deallocate (Mat%el) + end subroutine Destroy_R + end MODULE Matrix + + + +!!!!!!!!!!!!! Would be nice to implement one day.... !!!!!!!!!!!!!!!!!!!!! +! Use MyMats +! +! interface assignment(=) +! module procedure Equal_C +! end interface +! interface operator(*) +! module procedure Mat_mult_C +! end interface +! subroutine Equal_C(Z_out, Z_in) +! type (Mat_C), intent(in) :: Z_in +! type (MAT_C), intent(out) :: Z_out +! Z_out%A = Z_in%A +! end subroutine Equal_C +! +! function Mat_mult_C(Z1, Z2) result(Z3) +! +! type (Mat_C) , intent(in) :: Z1 , Z2 +! type (Mat_C) :: Z3 +! integer N +! +! N = size(Z1%A,1) +! Call Construct_Mat(Z3,N) +! +! Call MMULT(Z3%A, Z1%A, Z2%A) +! +! end function Mat_mult_C + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/src/Modules/maxent.f90 b/src/Modules/maxent.f90 new file mode 100644 index 000000000..edf239205 --- /dev/null +++ b/src/Modules/maxent.f90 @@ -0,0 +1,807 @@ +Module MaxEnt_mod + + Use MyMats + Use Errors + + + Interface MaxEnt + Module Procedure MaxEnt_T, MaxEnt_T0 + end Interface + + REAL (KIND=8), Private :: ZERO, ALPHA, PI, XMOM1 + REAL (KIND=8), Dimension(:), Private :: XPARAM(20) + REAL (KIND=8), Dimension(:), Allocatable, Private :: XLAM, DEF, SIG1 + REAL (KIND=8), DIMENSION(:,:), Allocatable, Private :: COVM1, UC + Integer, Private :: NTAU, NOM + + + CONTAINS + + Subroutine MaxEnt_T( XQMC, COV, A, XKER, ALPHA_ST, CHISQ,DEFAULT) + + Implicit None + Real (Kind=8), Dimension(:) :: XQMC, A + Real (Kind=8), Dimension(:,:) :: COV, XKER + Real (Kind=8) :: ALPHA_ST, CHISQ, ALPHA_N + Real (Kind=8), Dimension(:), optional :: Default + + Integer :: NT, NT1, NT2, NW, NFLAG, NCOUNT + Real (Kind=8) :: X, XENT, XQ, PR_ALP, XTRACE, DIFF1, DIFF , Tol_chi_def + + + Tol_chi_def = 1000000000000.0 + NTAU = SIZE(XQMC,1) + NOM = SIZE(A, 1) + !WRITE(6,*) 'NTAU, Nom: ', NTAU,NOM + PI = ACOS(-1.d0) + Xmom1 = Xqmc(1) + + ZERO = 1.0D-8 + ALLOCATE ( XLAM(NTAU), SIG1(NTAU), COVM1(NTAU,NTAU), UC(NTAU,NTAU), DEF(NOM) ) + XLAM=0.D0; SIG1=0.D0; UC = 0.D0 + + !Open (Unit=77,File='Aom_steps',Status='unknown') + + !Open(Unit=14) + !do nt = 1, NTAU + ! Write(14,*) Nt, XQMC(nt), sqrt(Cov(Nt,Nt)) + !enddo + !Close(14) + + CALL DIAG(COV,UC,SIG1) + DO NT1 = 1,NTAU + DO NT2 = 1,NTAU + X = 0.D0 + DO NT = 1,NTAU + X = X + UC(NT1,NT)*UC(NT2,NT)/SIG1(NT) + ENDDO + COVM1(NT1,NT2) = X + ENDDO + ENDDO + + + Open (Unit=50, File="info_Maxent", Status="unknown", position="append") + + Write(50,*) 'N E W R U N' + Write(50,*) '# of data points: ', NTAU + Write(6,*) 'N E W R U N' + ! Set the Default. + ALPHA = Alpha_st + DEF = XMOM1/dble(NOM) + XLAM = 0.d0 + if ( Present(Default) ) then + DEF = Default + Write(6,*) 'Default is present' + else + XQ = 0.d0; XENT= 0.d0; CHISQ = 0.d0 + Call Maximize_Newton( XQMC, COV, A, XKER, XQ,XENT,CHISQ) + IF (CHISQ .GT. Tol_chi_def*NTAU ) THEN + DO + XQ = 0.d0; XENT= 0.d0; CHISQ = 0.d0 + Call Maximize_Newton( XQMC, COV, A, XKER, XQ,XENT,CHISQ) + Write(50,*) 'Default: ', Alpha, Chisq + Write(6,*) 'Default: ', Alpha, Chisq + IF (CHISQ .GT. Tol_chi_def*NTAU .AND. ALPHA.GT.100 ) THEN + ALPHA = ALPHA - ALPHA*0.1 + ELSE + CALL SETA(A,XKER) + DO NW = 1,NOM + IF (A(NW).LT.ZERO) THEN + DEF(NW)= ZERO + ELSE + DEF(NW) = A(NW) + ENDIF + ENDDO + EXIT + ENDIF + ENDDO + ELSE + Write(6,*) 'Flat Default' + Endif + !DO NW = 1,NOM + ! Write(13,*) NW, DEF(NW) + !ENDDO + Write(6,*) 'Default Final: ', Alpha, Chisq + + DEF = XMOM1/dble(NOM) + Write(6,*) 'Setting the default to a flat default' + endif + + ! Calssic MaxEnt. + NFLAG = 0 + NCOUNT = 0 + !ALPHA = ALPHA_ST + XLAM = 0.D0 + DO + !WRITE(6,*) 'Starting classic ', ALPHA + WRITE(50,*) '========= Alpha: ', ALPHA + XQ = 0.d0; XENT= 0.d0; CHISQ = 0.d0 + !write(6,*) 'Calling maximize' + CALL MAXIMIZE_Newton( XQMC, COV, A, XKER, XQ,XENT,CHISQ) + !write(6,*) 'Return: Calling maximize' + IF (NFLAG.EQ.0) THEN + CALL CALCPR_ALP(XQMC, COV, A, XKER,XQ,XENT,PR_ALP,XTRACE) + ALPHA_N = -XTRACE/(2.D0*XENT) + WRITE(50,*) 'Max at:', ALPHA_N + WRITE(6,*) 'Max at:', ALPHA_N + WRITE(6,*) 'Old_alp', ALPHA + DIFF1 = ABS(ALPHA_N - ALPHA) + ENDIF + CALL SETA(A,XKER) + CALL SETQ(A,XKER,XQMC, XQ,XENT,CHISQ) + WRITE(50,2006) ALPHA, XQ,XENT,CHISQ + WRITE(6,2006 ) ALPHA, XQ,XENT,CHISQ + DIFF = ALPHA_N - ALPHA + IF ( ABS(DIFF) .GT. 0.1*ALPHA ) THEN + ALPHA = ALPHA + 0.1 * ALPHA * DIFF/ABS(DIFF) + NFLAG = 1 + ELSE + ALPHA = ALPHA_N + NFLAG = 0 + ENDIF + NCOUNT = NCOUNT + 1 + IF (NCOUNT .EQ. 100) THEN + WRITE(50,*) 'NOT CONVERGED' + ENDIF + IF ( ABS(DIFF1)/ABS(ALPHA_N).LT.0.01D0 .OR. NCOUNT.GT.1000 ) Exit + !& + ! & .OR. CHISQ.LT. 0.*dble(NTAU) ) EXIT + ENDDO + + + CLOSE(50) + +2006 FORMAT('Res: Alpha, XQ,S,CHI: ', F24.12,2x,F24.12,2x,F24.12,2x,F24.12) + + + DEALLOCATE ( XLAM, SIG1, COVM1, UC, DEF ) + !Close(77) + End Subroutine MaxEnt_T + + + + Subroutine Maximize_Newton( XQMC, COV, A, XKER, XQ,XENT,CHISQ) + + ! Sloves F(tau) = 0 with Newton. + + + Implicit None + !Arguments + REAL (KIND=8) :: XQ,XENT,CHISQ + REAL (Kind=8), Dimension(:) :: XQMC, A + REAL (Kind=8), Dimension(:,:) :: COV, XKER + + + !Working space + REAL (KIND=8), DIMENSION(:), ALLOCATABLE :: XLAM1, F + REAL (KIND=8), DIMENSION(:,:),ALLOCATABLE :: AH, AHINV + + Real (Kind=8) :: X, XNORM, DET1(2), XMAX + Integer :: NITER, NT, NT1, NW + + + ALLOCATE (XLAM1(NTAU), F(NTAU)) + XLAM1 = 0.D0; F = 0.D0 + ALLOCATE (AH(NTAU,NTAU), AHINV(NTAU,NTAU)) + AH = 0.D0; AHINV = 0.D0 + + NITER = 0 + !WRITE(6,*) "Starting Maximize" + DO + !Write(6,*) ' Iteration :: ', Niter + CALL SETA (A,XKER) + !Write(6,*) ' Back From SetA ' + CALL SETAH(AH, A,XKER,COV) + !Write(6,*) ' Back From SetAH ' + CALL SETF (F, COV, XKER, A, XQMC) + !Write(6,*) ' Back From SetF ' + Write(6,*) 'Calling INV' + CALL INV(AH, AHINV, DET1) + Write(6,*) 'Back Calling INV', Det1(1),Det1(2) + !CALL INV(AH, AHINV) + !Write(6,*) ' Back From INV ' + XNORM = 0.D0 + XMAX = 0.d0 + DO NT = 1,NTAU + X = 0.D0 + DO NT1 = 1,NTAU + X = X + AHINV(NT,NT1)*F(NT1) + ENDDO + XLAM1(NT) = XLAM(NT) - X + XNORM = XNORM + X*X + If (ABS(X).GT.XMAX) XMAX = ABS(X) + ENDDO + !Write(6,*) 'Max Diff Newton: ', XMAX + XNORM = SQRT(XNORM)/DBLE(NTAU) + !DO nw = 1,Nom + !write(77,*) nw, A(nw) + !enddo + !write(77,*) '# Chisq : ', CHISQ, XMAX + !write(77,*) + DO NT = 1,NTAU + XLAM(NT) = XLAM1(NT) + ENDDO + NITER = NITER + 1 + !WRITE(6,*) 'Maximize: ', XNORM, NITER + IF (XNORM.LT.1.0D-6 .OR. NITER.GE.100) EXIT + ENDDO + CALL SETQ(A,XKER,XQMC, XQ,XENT,CHISQ) + + IF (NITER.GE.100) THEN + WRITE(50,*) 'Convergence problem:' + ENDIF + + Deallocate (XLAM1, F) + Deallocate (AH, AHINV) + + END Subroutine Maximize_Newton + + + ! Working HERE + Subroutine Maximize_Self( XQMC, COV, A, XKER, XQ,XENT,CHISQ) + + ! Sloves F(tau) = 0 with self-consistency. + ! That is. Iterate to solve: alpha Cov(t,t1) xlam(t1) = \bar{G}(t) - G_qmc(t) + ! bar{G}(t) is the fit + + Implicit None + + + !Arguments + REAL (KIND=8) :: XQ,XENT,CHISQ + REAL (Kind=8), Dimension(:) :: XQMC, A + REAL (Kind=8), Dimension(:,:) :: COV, XKER + + + !Working space + REAL (KIND=8), DIMENSION(:), ALLOCATABLE :: XLAM1, F, GBAR + + Real (Kind=8) :: X, XNORM, DET1(2), XMAX + Integer :: NITER, NT, NT1, NW + + + ALLOCATE (XLAM1(NTAU), F(NTAU), GBAR(NTAU) ) + XLAM1 = 0.D0; F = 0.D0 + + + NITER = 0 + DO + CALL SETA (A,XKER) + DO NT = 1,NTAU + GBAR(NT) = 0.d0 + DO NW = 1,NOM + GBAR(NT) = GBAR(NT) + XKER(NT,NW)*A(NW) + ENDDO + GBAR(NT) = ( GBAR(NT) - XQMC(NT) ) / ALPHA + ENDDO + XNORM = 0.D0 + DO NT = 1,NTAU + XLAM1(NT) = 0.d0 + DO NT1 = 1,NTAU + XLAM1(NT) = XLAM1(NT) + COVM1(NT,NT1)*GBAR(NT1) + ENDDO + XNORM = XNORM + ( XLAM1(NT) - XLAM(NT) )**2 + ENDDO + IF (MOD(NITER,100) .EQ. 0 ) THEN + DO NT = 1,NTAU + Write(6,*) 'Self: ', XLAM(NT), XLAM1(NT) + ENDDO + ENDIF + XNORM = SQRT(XNORM)/DBLE(NTAU) + DO NT = 1,NTAU + XLAM(NT) = XLAM1(NT) + ENDDO + NITER = NITER + 1 + WRITE(6,*) 'Maximize_Self: ', XNORM, NITER + IF (XNORM.LT.1.0D-6 .OR. NITER.GE.1000) EXIT + ENDDO + CALL SETQ(A,XKER,XQMC, XQ,XENT,CHISQ) + + IF (NITER.GE.100) THEN + WRITE(50,*) 'Convergence problem:' + ENDIF + + Deallocate (XLAM1, F, GBAR ) + + END Subroutine Maximize_Self + + + + Subroutine SETA(A,XKER) + Implicit None + + ! Arguments: + Real (Kind=8), Dimension(:) :: A + Real (Kind=8), Dimension(:,:) :: XKER + + Real (Kind=8) :: X + Integer :: Nw, Nt + + DO NW = 1,NOM + X = 0.D0 + DO NT = 1,NTAU + X = X + XLAM(NT)*XKER(NT,NW) + ENDDO + A(NW) = DEF(NW)*EXP(-X) + !Write(6,*) 'SetA : ',NW, ' ' , X, ' ', A(NW) + ENDDO + End Subroutine SETA + + Subroutine SETAH(AH, A,XKER,COV) + Implicit None + !Given XLAM, A, and alpha, calcluates + !AH(tau,tau1) = \frac{\partial F_tau} {\partial tau1 } + + ! Arguments + REAL (KIND=8), DIMENSION(:,:) :: AH, COV, XKER + REAL (KIND=8), DIMENSION(:) :: A + + Integer NT, NT1, NW + Real (Kind=8) :: X + + IF ( SIZE(AH,1).NE.NTAU .OR. SIZE(AH,2).NE.NTAU) THEN + WRITE(6,*) 'Error in Setah ' + STOP + ENDIF + + DO NT = 1,NTAU + DO NT1 = 1,NTAU + X = 0.D0 + DO NW = 1,NOM + X = X + XKER(NT,NW)*XKER(NT1,NW)*A(NW) + ENDDO + AH(NT,NT1) = COV(NT,NT1)*ALPHA + X + ENDDO + ENDDO + + End Subroutine SETAH + + Subroutine SETF (F,COV,XKER,A,XQMC) + Implicit None + + !Given XLAM, A, and alpha, calcluates F + + + !Arguments + REAL (KIND=8), DIMENSION(:) :: F, A, XQMC + REAL (KIND=8), DIMENSION(:,:) :: COV, XKER + + REAL (Kind=8) :: X, X1 + Integer :: Nt, Nt1, Nw + + IF (SIZE(F,1).NE.NTAU) THEN + WRITE(6,*) 'Error in Setf ' + STOP + ENDIF + DO NT = 1,NTAU + X = 0.D0 + DO NT1 = 1,NTAU + X = X + COV(NT,NT1)*XLAM(NT1) + ENDDO + X = ALPHA*X + X1 = 0.D0 + DO NW = 1,NOM + X1 = X1 + XKER(NT,NW)*A(NW) + ENDDO + F(NT) = X + XQMC(NT) - X1 + ENDDO + End Subroutine SETF + + Subroutine SETQ(A,XKER,XQMC, XQ,XENT,CHISQ) + Implicit None + + !Arguments + REAL (KIND=8) :: XQ, XENT, CHISQ + Real (Kind=8), Dimension(:) :: A, XQMC + Real (Kind=8), Dimension(:,:) :: XKER + + !Local + REAL (KIND=8), DIMENSION(:), ALLOCATABLE :: VHLP + Integer :: Nw, Nt, Nt1 + Real (Kind=8) :: X + + XENT = 0.D0 + CHISQ = 0.D0 + ALLOCATE (VHLP(NTAU)) + + DO NW = 1,NOM + X = A(NW) + IF (A(NW).LT.ZERO) X = ZERO + XENT = XENT + X-DEF(NW) - X*LOG(X/DEF(NW)) + ENDDO + + DO NT = 1,NTAU + X = 0.D0 + DO NW = 1,NOM + X = X + XKER(NT,NW)*A(NW) + ENDDO + VHLP(NT) = XQMC(NT) - X + ENDDO + + DO NT1= 1,NTAU + DO NT = 1,NTAU + CHISQ = CHISQ + VHLP(NT)*COVM1(NT,NT1)*VHLP(NT1) + ENDDO + ENDDO + + XQ = ALPHA*XENT - CHISQ/2.D0 + + DEALLOCATE (VHLP) + End Subroutine SETQ + + SUBROUTINE CALCPR_ALP(XQMC, COV, A, XKER,XQ,XENT,PR_ALP,XTRACE) + Implicit None + + Real (Kind=8), Dimension(:) :: XQMC, A + Real (Kind=8), Dimension(:,:) :: COV, XKER + + + ! Arguments + REAL (KIND=8) :: XQ,XENT, PR_ALP,XTRACE + + + ! Local + REAL (KIND=8), DIMENSION(:) :: DET1(2) + REAL (KIND=8), DIMENSION(:,:), ALLOCATABLE :: XMAT, XMATM1, XKER1 + + Integer :: NFLAG, NW, NT, NT1, NW1 + REAL (Kind=8) :: XLDET + + ALLOCATE (XKER1(NTAU,NOM), XMAT(NOM,NOM), XMATM1(NOM,NOM) ) + XKER1 = 0.D0; XMAT = 0.D0; XMATM1 = 0.D0 + NFLAG = 0 + + IF (NFLAG.EQ.0) THEN + + !WRITE(6,*) 'Hi1' + XKER1 = 0.D0 + DO NW = 1,NOM + DO NT = 1,NTAU + DO NT1 = 1,NTAU + XKER1(NT,NW) = XKER1(NT,NW)+COVM1(NT,NT1)*XKER(NT1,NW) + ENDDO + XKER1(NT,NW) = XKER1(NT,NW)*SQRT(A(NW)) + ENDDO + ENDDO + + DO NW = 1,NOM + DO NW1= 1,NOM + XMAT(NW,NW1) = 0.D0 + DO NT = 1,NTAU + XMAT(NW,NW1)=XMAT(NW,NW1)+XKER(NT,NW)*XKER1(NT,NW1) + ENDDO + XMAT(NW,NW1) = SQRT(A(NW))*XMAT(NW,NW1) + ENDDO + ENDDO + + + DO NW = 1,NOM + XMAT(NW,NW) = XMAT(NW,NW) + ALPHA + ENDDO + + + CALL INV(XMAT, XMATM1, DET1) + + DO NW = 1,NOM + XMAT(NW,NW) = XMAT(NW,NW) - ALPHA + ENDDO + + !write(6,*) XQ, ALPHA, NOM, DET1(1), DET1(2) + XLDET = LOG(DET1(1)) + DET1(2)*LOG(10.D0) + + PR_ALP = XQ + 0.5*LOG(ALPHA)*DBLE(NOM) - 0.5*XLDET + + + XTRACE = 0.D0 + DO NW = 1,NOM + DO NW1 = 1,NOM + XTRACE = XTRACE + XMAT(NW,NW1)*XMATM1(NW1,NW) + ENDDO + ENDDO + + + ENDIF + + DEALLOCATE ( XKER1, XMAT, XMATM1 ) + + RETURN + END SUBROUTINE CALCPR_ALP + + + + + !real (kind=8) function f_fit(k,x) + ! integer k + ! real (kind=8) x + ! + ! if ( k.eq.1) f_fit = 1.d0 + ! if ( k.eq.2) f_fit = x + ! + ! return + !end function f_fit + + + Subroutine MaxEnt_T0 ( XQMC, COV, A, XKER, ALPHA_ST, CHISQ, Rel_err, Shift, xtau, f_fit) + + Implicit None + Real (Kind=8), Dimension(:) :: XQMC, A + Real (Kind=8), Dimension(:,:) :: COV, XKER + Real (Kind=8) :: ALPHA_ST, CHISQ, Rel_err + Real (Kind=8), Optional :: Shift + Real (Kind=8), Dimension(:), Optional :: xtau + Real (Kind=8), external, Optional :: f_fit + + Real (Kind=8), Dimension(:) , Allocatable :: XQMC_1 + Real (Kind=8), Dimension(:,:), Allocatable :: COV_1, XKER_1 + + ! For the fit if requested. + Real (Kind=8) :: chisq_fit, Ares(2) + Real (Kind=8), Dimension(:), allocatable :: xdata_fit, fdata_fit, error_fit + Integer :: Nd_fit + !real (kind=8), external :: f_fit + + Integer nt, nt1, ntau_eff, nw + Real (Kind=8) :: X + + ntau = size(xqmc,1) + Nom = Size(A,1) + ntau_eff = 0 + nt = 0 + do + nt = nt + 1 + X = sqrt( cov(nt,nt) )/ xqmc(nt) + if ( X.lt.Rel_err) then + ntau_eff = ntau_eff + 1 + else + exit + endif + if (nt.eq.ntau) exit + enddo + write(6,*) 'Ntau_eff: ', Ntau_eff + + Write(6,*) 'Resizing' + Allocate ( XQMC_1(Ntau_eff), Cov_1(Ntau_eff,Ntau_eff), Xker_1(Ntau_eff,Nom) ) + do nt = 1,Ntau_eff + xqmc_1(nt) = xqmc(nt) + enddo + do nt = 1,Ntau_eff + do nt1 = 1,Ntau_eff + cov_1(nt,nt1) = cov(nt,nt1) + enddo + enddo + do nt = 1,Ntau_eff + do nw = 1,Nom + XKer_1(nt, nw) = XKer(nt, nw) + enddo + enddo + IF ( PRESENT(Shift) .and. PRESENT(xtau) .and. PRESENT(F_FIT) ) Then + write(6,*) 'The data will be shifted' + shift = 0.d0 + Nd_fit = Ntau_eff/2 + Allocate (xdata_fit(Nd_fit), fdata_fit(Nd_fit), error_fit(Nd_fit) ) + do nt = 1,Nd_fit + xdata_fit(nt) = xtau(nt + Nd_fit) + fdata_fit(nt) = log(xqmc_1(nt + Nd_fit)) + error_fit (nt) = sqrt( cov_1(nt + Nd_fit,nt + Nd_fit) )/xqmc_1(nt + Nd_fit) + enddo + call fit(xdata_fit,fdata_fit,error_fit,ares,chisq_fit,f_fit) + write(6,*) 'The slope is : ', Ares(2) + shift = -Ares(2) - 0.2 + Deallocate (xdata_fit, fdata_fit, error_fit ) + do nt = 1,Ntau_eff + xqmc_1(nt) = xqmc_1(nt)*exp(xtau(nt)*shift) + enddo + do nt = 1,Ntau_eff + do nt1 = 1,Ntau_eff + cov_1(nt,nt1) = cov_1(nt,nt1)*exp( (xtau(nt) + xtau(nt1))*shift ) + enddo + enddo + else + write(6,*) 'The data will not be shifted' + endif + Call MaxEnt_T(XQMC_1, COV_1, A, XKER_1, ALPHA_ST, CHISQ) + Deallocate ( Xqmc_1, Cov_1, Xker_1 ) + + + end Subroutine MaxEnt_T0 + + + + Subroutine MaxEnt_gr(XTAU, XQMC, COV, A, XOM, Beta, ALPHA_ST, CHISQ ) + ! Sets the Kernel for Green functions. + Implicit none + + Real (Kind=8), Dimension(:) :: XTAU, XQMC, A, XOM + Real (Kind=8), Dimension(:,:) :: COV + + Real (Kind=8) :: ALPHA_ST, CHISQ, BETA + + + Real (Kind=8), Dimension(:,:), allocatable :: xker + + Integer :: NT, NW, NTAU, NOM + + + Nom = Size(Xom ,1) + Ntau = Size(Xtau,1) + + Allocate ( Xker(Ntau,Nom) ) + do nt = 1,ntau + do nw = 1,Nom + XKer(nt,nw) = EXP(-xtau(nt)*xom(nw) ) / ( 1.d0 + EXP( -BETA*xom(nw) ) ) + Enddo + Enddo + + Call MaxEnt_T(XQMC, COV, A, XKER, ALPHA_ST, CHISQ ) + + Deallocate ( Xker ) + End Subroutine MaxEnt_gr + + + Subroutine MaxEnt_T_Bryan( XQMC, COV, A, XKER, ALPHA_ST, ALPHA_EN, CHISQ ) + + Implicit None + Real (Kind=8), Dimension(:) :: XQMC, A + Real (Kind=8), Dimension(:,:) :: COV, XKER + Real (Kind=8) :: ALPHA_ST, CHISQ, ALPHA_N, ALPHA_EN + + Integer :: NT, NT1, NT2, NW, NFLAG, NCOUNT, NTH + Real (Kind=8) :: X, XENT, XQ, PR_ALP, XTRACE, DIFF1, DIFF , Tol_chi_def, XNORM, & + & D_ALPHA, ALPHA_OLD, XNORM_TOT + + Real (Kind=8), Dimension(:), allocatable :: A_ME + + Tol_chi_def = 100000000000000.0 + NTAU = SIZE(XQMC,1) + NOM = SIZE(A, 1) + ALLOCATE(A_ME(NOM)) + !WRITE(6,*) 'NTAU, Nom: ', NTAU,NOM + PI = ACOS(-1.d0) + XMOM1= 1.0 !PI + ZERO = 1.0D-8 + ALLOCATE ( XLAM(NTAU), SIG1(NTAU), COVM1(NTAU,NTAU), UC(NTAU,NTAU), DEF(NOM) ) + XLAM=0.D0; SIG1=0.D0; UC = 0.D0 + + !Open (Unit=77,File='Aom_steps',Status='unknown') + !Open(Unit=14) + !do nt = 1, NTAU + ! Write(14,*) Nt, XQMC(nt), sqrt(Cov(Nt,Nt)) + !enddo + !Close(14) + + CALL DIAG(COV,UC,SIG1) + DO NT1 = 1,NTAU + DO NT2 = 1,NTAU + X = 0.D0 + DO NT = 1,NTAU + X = X + UC(NT1,NT)*UC(NT2,NT)/SIG1(NT) + ENDDO + COVM1(NT1,NT2) = X + ENDDO + ENDDO + + + Open (Unit=50, File="info_Maxent", Status="unknown", position="append") + + Write(50,*) 'N E W R U N' + Write(50,*) '# of data points: ', NTAU + Write(6,*) 'N E W R U N' + ! Set the Default. + ALPHA = Alpha_st + DEF = XMOM1/dble(NOM) + XLAM = 0.d0 + XQ = 0.d0; XENT= 0.d0; CHISQ = 0.d0 + Call Maximize_Newton( XQMC, COV, A, XKER, XQ,XENT,CHISQ) + IF (CHISQ .GT. Tol_chi_def*NTAU ) THEN + DO + XQ = 0.d0; XENT= 0.d0; CHISQ = 0.d0 + Call Maximize_Newton( XQMC, COV, A, XKER, XQ,XENT,CHISQ) + Write(50,*) 'Default: ', Alpha, Chisq + Write(6,*) 'Default: ', Alpha, Chisq + IF (CHISQ .GT. Tol_chi_def*NTAU .AND. ALPHA.GT.100 ) THEN + ALPHA = ALPHA - ALPHA*0.1 + ELSE + CALL SETA(A,XKER) + DO NW = 1,NOM + IF (A(NW).LT.ZERO) THEN + DEF(NW)= ZERO + ELSE + DEF(NW) = A(NW) + ENDIF + ENDDO + EXIT + ENDIF + ENDDO + ELSE + Write(6,*) 'Flat Default' + Endif + !DO NW = 1,NOM + ! Write(13,*) NW, DEF(NW) + !ENDDO + Write(6,*) 'Default Final: ', Alpha, Chisq + + DEF = XMOM1/dble(NOM) + Write(6,*) 'Setting the default to a flat default' + + + ! Calssic MaxEnt. + NFLAG = 0 + NCOUNT = 0 + !ALPHA = ALPHA_ST + ALPHA_N = ALPHA_EN + XLAM = 0.D0 + NTH = 0 + A_ME = 0.d0 + XNORM_TOT = 0.d0 + OPEN (Unit=55,File="Tmp",status="unknown") + DO + !WRITE(6,*) 'Starting classic ', ALPHA + WRITE(50,*) '========= Alpha: ', ALPHA + XQ = 0.d0; XENT= 0.d0; CHISQ = 0.d0 + !write(6,*) 'Calling maximize' + CALL MAXIMIZE_Newton( XQMC, COV, A, XKER, XQ,XENT,CHISQ) + !write(6,*) 'Return: Calling maximize' + !IF (NFLAG.EQ.0) THEN + CALL CALCPR_ALP(XQMC, COV, A, XKER,XQ,XENT,PR_ALP,XTRACE) + IF (NTH.EQ.0) XNORM = EXP(PR_ALP) + NTH = NTH + 1 + !ALPHA_N = -XTRACE/(2.D0*XENT) + WRITE(50,*) 'Max at:', ALPHA_N + WRITE(6,*) 'Max at:', ALPHA_N + DIFF1 = ABS(ALPHA_N - ALPHA) + !ENDIF + CALL SETA(A,XKER) + CALL SETQ(A,XKER,XQMC, XQ,XENT,CHISQ) + WRITE(50,2006) ALPHA, XQ,XENT,CHISQ + WRITE(6,2006 ) ALPHA, XQ,XENT,CHISQ + DIFF = ALPHA_N - ALPHA + ALPHA_OLD = ALPHA + IF ( ABS(DIFF) .GT. 0.05*ALPHA ) THEN + D_alpha = 0.05 * ALPHA + ALPHA = ALPHA + 0.05 * ALPHA * DIFF/ABS(DIFF) + NFLAG = 1 + ELSE + D_alpha = ABS(ALPHA_N - ALPHA) + ALPHA = ALPHA_N + NFLAG = 0 + ENDIF + NCOUNT = NCOUNT + 1 + IF (NCOUNT .EQ. 100) THEN + WRITE(50,*) 'NOT CONVERGED' + ENDIF + WRITE(55,*) ALPHA_OLD, EXP(PR_ALP)/XNORM, D_ALPHA + XNORM_TOT = XNORM_TOT + D_ALPHA*(EXP(PR_ALP)/XNORM) + do nw = 1, NOM + A_ME(nw) = A_ME(nw) + D_ALPHA*A(nw)*(EXP(PR_ALP)/XNORM) + enddo + IF ( ABS(DIFF1)/ABS(ALPHA_N).LT.0.01D0 .OR. NCOUNT.GT.1000 ) EXIT + ENDDO + CLOSE(55) + + A_ME = A_ME/XNORM_TOT + A = A_ME + WRITE(50,*) 'Tot Norm:', XNORM_TOT + OPEN(Unit=55,File="Tmp", Status="unknown") + OPEN(Unit=57,File="Pr_alpha", Status="unknown") + do + read(55,*,End=10) ALPHA_OLD, XNORM, D_ALPHA + XNORM = XNORM/XNORM_TOT + write(57,*) ALPHA_OLD, XNORM, D_ALPHA + enddo +10 continue + Close(55) + Close(57) + CLOSE(50) + + +2006 FORMAT('Res: Alpha, XQ,S,CHI: ', F14.7,2x,F14.7,2x,F14.7,2x,F14.7) + + + DEALLOCATE ( XLAM, SIG1, COVM1, UC, DEF ) + DEALLOCATE ( A_ME ) + !Close(77) + End Subroutine MaxEnt_T_Bryan + + end Module MaxEnt_mod + + diff --git a/src/Modules/maxent_stoch.G90 b/src/Modules/maxent_stoch.G90 new file mode 100644 index 000000000..30fd2337b --- /dev/null +++ b/src/Modules/maxent_stoch.G90 @@ -0,0 +1,964 @@ +#include "machine" +#ifdef MPI +Module MaxEnt_stoch_mod_MPI +#else +Module MaxEnt_stoch_mod +#endif + + Use MyMats + Use Files_mod + + + Integer, private :: NTAU, nt, Ngamma, ng, Ndis, nd, Iseed + Real (Kind=8), private :: Delta, Delta2, OM_st_1, Om_en_1, DeltaXMAX, Beta, Pi, Dom + Real (Kind=8), allocatable, private :: XQMC1(:) + + ! You can still optimize a bit for by redefining the Kernel table to: + ! xker_table(nt,nw) -> xker_table(nt,nw) / sigma(nt) + ! This will save quite a lot of divisions in the + ! MC routine. And this is where all the time goes now. + + CONTAINS + + Subroutine MaxEnt_stoch(XQMC, Xtau, COV,Xmom1, XKER, Back_Trans_Aom, Beta_1, Alpha_tot,& + & Ngamma_1, OM_ST, OM_EN, Ndis_1, Nsweeps, NBins, NWarm, L_cov) + + Implicit None + +#ifdef MPI + include 'mpif.h' +#endif + + Real (Kind=8), Dimension(:) :: XQMC, Xtau, Alpha_tot + Real (Kind=8), Dimension(:,:) :: COV + Real (Kind=8), External :: XKER, Back_trans_Aom + Real (Kind=8) :: CHISQ, OM_ST, OM_EN, Beta_1, Xmom1, Err + Integer :: Nsweeps, NBins, Ngamma_1, Ndis_1, nw, nt1 + Integer, optional :: L_cov + + ! Local + Integer lp, NSims, ns, nb, nc, Nwarm, nalp1, nalp2, Nex, p_star, Ndis_table, & + & io_error, io_error1, i, n, nc1 + Real (Kind=8), Allocatable :: Xn_M_tot(:,:), En_M_tot(:), Xn_E_tot(:,:), En_E_tot(:), & + & Xn_tot(:,:,:), En_tot(:) + Real (Kind=8), Allocatable :: G_Mean(:), Xn_m(:), Xn_e(:), Xn(:,:), Vhelp(:) + Real (Kind=8) :: Ranf, En_M, Res, X, Alpha, Acc_1, Acc_2, En, DeltaE, Ratio, D + Real (Kind=8) :: Aom, om, XMAX, tau + Real (Kind=8) :: CPUT, CPUTM + Integer :: ICPU_1, ICPU_2, N_P_SEC + Character (64) :: File_root, File1, File_conf, File_Aom + Real (Kind=8), allocatable :: Xker_table(:,:), U(:,:), sigma(:) + + ! Space for moments. + Real (Kind=8), allocatable:: Mom_M_tot(:,:), Mom_E_tot(:,:) + + +#ifdef MPI + INTEGER, allocatable :: Iseed_table(:), n1, n2, n, IRANK, IERR, ISIZE + INTEGER STATUS(MPI_STATUS_SIZE) + Real (Kind=8), Allocatable :: Collect1(:), Collect2(:,:) + CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) + CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) +#endif + + Pi = acos(-1.d0) + NDis = Ndis_1 + DeltaXMAX = 0.01 + delta = 0.001 + delta2 = delta*delta + Ngamma = Ngamma_1 + Beta = Beta_1 ! Physical temperature for calculation of the kernel. + + Ntau = Size(xqmc,1) + NSims = Size(Alpha_tot,1) + Allocate (Xn_tot(Ngamma,2,NSims)) + Allocate (En_m_tot(NSims), En_e_tot(NSims), En_tot(NSims) ) + Allocate (Xn_m_tot(NDis,NSims), Xn_e_tot(NDis,NSims) ) + Allocate (Mom_M_tot(2,Nsims), Mom_E_tot(2,Nsims) ) + + Allocate (Xn(Ngamma,2)) + Allocate (Xn_m(NDis), Xn_e(NDis) ) + + Om_st_1 = OM_st; Om_en_1 = OM_en + + ! Setup table for the Kernel + Ndis_table = 50000 + Dom = (OM_EN_1 - OM_ST_1)/dble(Ndis_table-1) + Allocate ( Xker_table(Ntau, Ndis_table) ) + do nt = 1,Ntau + do nw = 1,Ndis_table + tau = xtau(nt) + Om = OM_st + dble(nw-1)*dom + Xker_table(nt,nw) = Xker(tau,om,beta) + enddo + enddo + ! Normalize data to have zeroth moment of unity. + xqmc = xqmc / XMOM1 + cov = cov / ((XMOM1)**2) + ! Diagonalize the covariance + + Allocate( U(ntau,ntau), Sigma(ntau), xqmc1(Ntau) ) + If ( Present(L_cov) ) then + Call Diag(cov,U,sigma) + ! Write(6,*) " Cov Used" + else + Write(6,*) "No Cov Used" + U = 0.d0 + do nt = 1,ntau + U(nt,nt) = 1.d0 + sigma(nt) = cov(nt,nt) + enddo + endif + do nt = 1,ntau + sigma(nt) = sqrt(sigma(nt)) + enddo + xqmc1 = 0.d0 + do nt1 = 1,ntau + do nt = 1,ntau + xqmc1(nt1) = xqmc1(nt1) + xqmc(nt)*U(nt,nt1) + enddo + xqmc1(nt1) = xqmc1(nt1)/sigma(nt1) + enddo + ! Transform the Kernel + allocate ( Vhelp(Ntau) ) + do nw = 1,Ndis_table + Vhelp = 0.d0 + do nt1 = 1,Ntau + do nt = 1,Ntau + Vhelp(nt1) = Vhelp(nt1) + Xker_table(nt,nw)*U(nt,nt1) + enddo + enddo + do nt1 = 1,ntau + Xker_table(nt1,nw) = Vhelp(nt1)/sigma(nt1) !! This has changed !! + enddo + enddo + deallocate( U, Sigma ) + Allocate ( G_Mean(Ntau) ) + G_mean = 0.d0 + +! write(6,*) ' There are ', Ngamma,' delta-functions for a spectrum' +! Write(6,*) ' Initializing' + ! D(om) = 1/(Om_en_1 - Om_st_1) + D = 1.d0 / (Om_en_1 - Om_st_1) + +#ifdef MPI + allocate (iseed_table(ISIZE+1)) + if (Irank.eq.0) then + Open (Unit=10,File="seeds", status = "unknown") + do i = 1,isize + 1 + read(10,*) iseed_table(i) + enddo + close(10) + endif + Call MPI_BCAST(Iseed_table ,Isize+1,MPI_INTEGER,0,MPI_COMM_WORLD,IERR) + iseed = iseed_table(Irank + 1) +#else + Iseed = 8752143 +#endif + +#ifdef MPI + File_root = "dump_conf" + File_conf = File_i( File_root, Irank ) + File_root = "dump_Aom" + File_Aom = File_i( File_root, Irank ) +#else + File_conf = "dump_conf" + File_Aom = "dump_Aom" +#endif + + Open(unit=41,file=File_conf,status='old',action='read', iostat=io_error) + Open(unit=42,file=File_Aom, status='old',action='read', iostat=io_error1) + If (io_error == 0 .and. io_error1 == 0 ) then + Nwarm = 0 + read(41,*) Iseed + do ns = 1,Nsims + do ng = 1,Ngamma + read(41,*) Xn_tot(ng,1,ns), Xn_tot(ng,2,ns) + enddo + read(41,*) En_m_tot(ns), En_e_tot(ns) + enddo + read(42,*) nc + do ns = 1,Nsims + do nd = 1,Ndis + read(42,*) Xn_m_tot(nd,ns), Xn_e_tot(nd,ns) + enddo + enddo +#ifdef MPI + if (Irank == 0) then +#endif + Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") + Write(44,*) 'Read from dump: nc = ', nc + close(44) +#ifdef MPI + endif +#endif + else + !Iseed is alrady set. + Do Ns = 1,NSims + do ng = 1,NGamma + Xn_tot(ng,1,ns) = ranf(iseed) + Xn_tot(ng,2,ns) = 1.d0/dble(Ngamma) + enddo + enddo + Xn_m_tot = 0.d0 + En_m_tot = 0.d0 + Xn_e_tot = 0.d0 + En_e_tot = 0.d0 + nc = 0 +#ifdef MPI + if (Irank == 0) then +#endif + Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") + Write(44,*) ' No dump data ' + close(44) +#ifdef MPI + endif +#endif + endif + close(41) + close(42) + + nc1 = 0 + Mom_M_tot = 0.d0 + Mom_E_tot = 0.d0 + + + CALL SYSTEM_CLOCK(COUNT_RATE=N_P_SEC) + CALL SYSTEM_CLOCK(COUNT=ICPU_1) + ! Start Simulations. + do Nb = 1,Nbins + do ns = 1,NSims + do ng = 1,Ngamma + Xn(ng,1) = Xn_tot(ng,1,ns) + Xn(ng,2) = Xn_tot(ng,2,ns) + enddo + Alpha = Alpha_tot(ns) + Call MC(Xtau, Xker_table, Xn, Alpha, NSweeps, Xn_m, En, En_m, & + & Acc_1, Acc_2 ) ! Just one bin + do ng = 1,Ngamma + Xn_tot(ng,1,ns) = Xn(ng,1) + Xn_tot(ng,2,ns) = Xn(ng,2) + enddo + En_tot(ns) = En ! this is the energy of the configuration Xn_tot for simulation ns +#ifdef MPI +#else + Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") + Write(44,2003) 1.d0/Alpha, En_m, Acc_1, Acc_2 + close(44) + +#endif + if (nb.gt.nwarm) then + if (ns.eq.1) nc = nc + 1 + do nd = 1,NDis + Xn_m(nd) = Xn_m(nd) * D * dble(Ndis) + Xn_m_tot(nd,ns) = Xn_m_tot(nd,ns) + Xn_m(nd) + Xn_e_tot(nd,ns) = Xn_e_tot(nd,ns) + Xn_m(nd)*Xn_m(nd) + enddo + En_m_tot(ns) = En_m_tot(ns) + En_m + En_e_tot(ns) = En_e_tot(ns) + En_m*En_m + ! Compute moments + if (ns.eq.1) nc1 = nc1 + 1 + do n = 1,Size(Mom_M_tot,1) + x = 0.d0 + do ng = 1,Ngamma + X = X + ( Phim1(Xn_tot(ng,1,ns))**(n-1) ) * Xn_tot(ng,2,Ns) + enddo + Mom_M_tot(n,ns) = Mom_M_tot(n,ns) + X + Mom_E_tot(n,ns) = Mom_E_tot(n,ns) + X*X + enddo + endif + enddo + ! Exchange + Acc_1 = 0.d0 + Do Nex = 1, 2*NSims + nalp1= nint( ranf(iseed)*dble(NSims-1) + 0.5 ) ! 1..(NSims-1) + nalp2 = nalp1 + 1 + DeltaE = (Alpha_tot(nalp1)*En_tot(nalp2) + Alpha_tot(nalp2)*En_tot(nalp1))& + & -(Alpha_tot(nalp1)*En_tot(nalp1) + Alpha_tot(nalp2)*En_tot(nalp2)) + Ratio = exp(-DeltaE) + if (Ratio.gt.ranf(iseed)) Then + Acc_1 = Acc_1 + 1.0 + !Switch confs an Energies. + do ng = 1,Ngamma + Xn(ng,1) = Xn_tot(ng,1,nalp1) + Xn(ng,2) = Xn_tot(ng,2,nalp1) + enddo + do ng = 1,Ngamma + Xn_tot(ng,1,nalp1) = Xn_tot(ng,1,nalp2) + Xn_tot(ng,2,nalp1) = Xn_tot(ng,2,nalp2) + Xn_tot(ng,1,nalp2) = Xn(ng,1) + Xn_tot(ng,2,nalp2) = Xn(ng,2) + enddo + En_m = En_tot(nalp1) + En_tot(nalp1) = En_tot(nalp2) + En_tot(nalp2) = En_m + endif + enddo + Acc_1 = Acc_1/dble(Nex) +#ifdef MPI +#else + + Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") + Write(44,*) 'Acc Exchange: ', Acc_1 + close(44) +#endif + enddo + + CALL SYSTEM_CLOCK(COUNT=ICPU_2) + CPUT = 0.D0 + CPUT = DBLE(ICPU_2 - ICPU_1)/DBLE(N_P_SEC) +#ifdef MPI + CPUTM = 0.d0 + call MPI_REDUCE(CPUT,CPUTM,1,MPI_REAL8,MPI_SUM, 0,MPI_COMM_WORLD,IERR) + CPUT = CPUTM/dble(Isize) +#endif +#ifdef MPI + if (Irank == 0 ) then +#endif + Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") + Write(44,*) 'Total time: ', CPUT + close(44) +#ifdef MPI + endif +#endif + ! dump so as to restart. + Open(unit=41,file=File_conf,status='unknown') + Open(unit=42,file=File_Aom, status='unknown') + write(41,*) Iseed + do ns = 1,Nsims + do ng = 1,Ngamma + write(41,*) Xn_tot(ng,1,ns), Xn_tot(ng,2,ns) + enddo + write(41,*) En_m_tot(ns), En_e_tot(ns) + enddo + write(42,*) nc + do ns = 1,Nsims + do nd = 1,Ndis + write(42,*) Xn_m_tot(nd,ns), Xn_e_tot(nd,ns) + enddo + enddo + close(41) + close(42) + ! Stop dump + +#ifdef MPI + !Collect En_m_tot(ns), En_e_tot(ns) + n1 = size(En_m_tot,1) + Allocate (Collect1(n1)) + n = n1 + + Collect1 = 0.d0 + call MPI_REDUCE(En_m_tot,Collect1,N,MPI_REAL8,MPI_SUM, 0,MPI_COMM_WORLD,IERR) + En_m_tot = Collect1/dble(Isize) + + Collect1 = 0.d0 + call MPI_REDUCE(En_e_tot,Collect1,N,MPI_REAL8,MPI_SUM, 0,MPI_COMM_WORLD,IERR) + En_e_tot = Collect1/dble(Isize) + + deallocate (Collect1) + + ! Collect Xn_m_tot(nd,ns), Xn_e_tot(nd,ns) + n1 = size(Xn_m_tot,1) + n2 = size(Xn_m_tot,2) + n = n1*n2 + allocate (Collect2(n1,n2)) + + Collect2 = 0.d0 + call MPI_REDUCE(Xn_m_tot,Collect2,N,MPI_REAL8,MPI_SUM, 0,MPI_COMM_WORLD,IERR) + Xn_m_tot = Collect2/dble(Isize) + + Collect2 = 0.d0 + call MPI_REDUCE(Xn_e_tot,Collect2,N,MPI_REAL8,MPI_SUM, 0,MPI_COMM_WORLD,IERR) + Xn_e_tot = Collect2/dble(Isize) + deallocate (Collect2) +#endif + + +#ifdef MPI + if (Irank == 0 ) then +#endif + + Open(Unit=66,File="energies",status="unknown") + do ns = 1,Nsims + En_m_tot(ns) = En_m_tot(ns) / dble(nc) + En_e_tot(ns) = En_e_tot(ns) / dble(nc) + En_e_tot(ns) = ( En_e_tot(ns) - En_m_tot(ns)**2)/dble(nc) + if ( En_e_tot(ns) .gt. 0.d0) then + En_e_tot(ns) = sqrt(En_e_tot(ns)) + else + En_e_tot(ns) = 0.d0 + endif + write(66,*) Alpha_tot(ns), En_m_tot(ns), En_e_tot(ns) + enddo + close(66) + + Open(Unit=66,File="moments",status="unknown") + do ns = 1,Nsims + do n = 1,Size(Mom_m_tot,1) + Mom_m_tot(n,ns) = Mom_m_tot(n,ns) / dble(nc1) + Mom_e_tot(n,ns) = Mom_e_tot(n,ns) / dble(nc1) + Mom_e_tot(n,ns) = ( Mom_e_tot(n,ns) - Mom_m_tot(n,ns)**2)/dble(nc1) + if ( Mom_e_tot(n,ns) .gt. 0.d0) then + Mom_e_tot(n,ns) = sqrt(Mom_e_tot(n,ns)) + else + Mom_e_tot(n,ns) = 0.d0 + endif + enddo + write(66,"(F12.6,2x,F12.6,2x,F12.6,2x,F12.6,2x,F12.6)") & + & Alpha_tot(ns), Mom_m_tot(1,ns), Mom_e_tot(1,ns), & + & Mom_m_tot(2,ns), Mom_e_tot(2,ns) + enddo + close(66) + + File_root = "Aom" + do ns = 1,Nsims + File1 = File_i(File_root,ns) + Open(Unit=66,File=File1,status="unknown") + do nd = 1,Ndis + Xn_m_tot(nd,ns) = Xn_m_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) + Xn_e_tot(nd,ns) = Xn_e_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) + Xn_e_tot(nd,ns) = (Xn_e_tot(nd,ns) - Xn_m_tot(nd,ns)* Xn_m_tot(nd,ns))/dble(nc) + if (Xn_e_tot(nd,ns).gt.0.d0) then + Xn_e_tot(nd,ns) = sqrt(Xn_e_tot(nd,ns)) + else + Xn_e_tot(nd,ns) = 0.d0 + endif + om = PhiM1(dble(nd)/dble(NDis)) + Aom = Xn_m_tot(nd,ns) * Xmom1 + Err = Xn_e_tot(nd,ns) * Xmom1 + write(66,2001) om, Back_Trans_Aom(Aom,Beta,om), Back_Trans_Aom(Err,Beta,om) + ! PhiM1(dble(nd)/dble(NDis)), Xn_m_tot(nd,ns) + enddo + Close(66) + enddo + + ! Now do the averaging. + File_root ="Aom_ps" + do p_star = 1,NSims - 10 + Xn_m = 0.0 + Xn_e = 0.0 + do ns = p_star, NSims-1 + do nd = 1, NDis + Xn_m(nd) = Xn_m(nd) + (En_m_tot(ns) - En_m_tot(ns+1))*Xn_m_tot(nd,ns) + Xn_e(nd) = Xn_e(nd) + (En_m_tot(ns) - En_m_tot(ns+1))*Xn_e_tot(nd,ns) + enddo + enddo + do nd = 1,NDis + Xn_m(nd) = Xn_m(nd) / (En_m_tot(p_star) - En_m_tot(NSims)) + Xn_e(nd) = Xn_e(nd) / (En_m_tot(p_star) - En_m_tot(NSims)) + enddo + File1 = File_i(File_root,p_star) + Open(Unit=66,File=File1,status="unknown") + XMAX = 0.d0 + Do nd = 1,Ndis + om = PhiM1(dble(nd)/dble(NDis)) + Aom = Xn_m(nd) * Xmom1 + Err = Xn_e(nd) * Xmom1 + Xn_m(nd) = Back_Trans_Aom(Aom,Beta,om) + Xn_e(nd) = Back_Trans_Aom(Err,Beta,om) + IF (Xn_m(nd) .gt. XMAX ) XMAX = Xn_m(nd) + enddo + do nd = 1,Ndis + om = PhiM1(dble(nd)/dble(NDis)) + write(66,2005) om, Xn_m(nd), Xn_e(nd), Xn_m(nd)/XMAX, Xn_e(nd)/XMAX + ! PhiM1(dble(nd)/dble(NDis)), Xn_m(nd) + enddo + close(66) + enddo + + Open (Unit=41,File='Best_fit', Status="unknown") + do ng = 1,Ngamma + Write(41,*) Phim1(Xn_tot(ng,1,Nsims)) , Xn_tot(ng,2,Nsims) + enddo + close(41) +#ifdef MPI + endif +#endif + + DeAllocate (Xn_tot) + DeAllocate (En_m_tot, En_e_tot, En_tot ) + DeAllocate (Xn_m_tot, Xn_e_tot ) + DeAllocate (Xn) + DeAllocate (Xn_m, Xn_e) + DeAllocate( G_Mean ) + DeAllocate( xqmc1 ) + Deallocate( Xker_table ) + + +2001 format(F14.7,2x,F14.7,2x,F14.7) +2004 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7) +2005 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7,2x,F14.7) +2003 format('Alpha, En_m, Acc ', F14.7,2x,F24.12,2x,F14.7,2x,F14.7,2x,F14.7) + end Subroutine MaxEnt_stoch + + +#ifdef MPI +#else +!------------------- + Subroutine MaxEnt_stoch_fit(XQMC, Xtau, COV, Lcov, XKER, Xmom1, Beta_1, Alpha_tot,& + & Ngamma_1, OM_ST, OM_EN, Nsweeps, NBins, NWarm, Aom_res,& + & xom_res, Chisq ) + + Implicit None + Real (Kind=8), Dimension(:) :: XQMC, Xtau, Alpha_tot, Aom_res, Xom_res + Real (Kind=8), Dimension(:,:) :: COV + Real (Kind=8), external :: XKER + Real (Kind=8) :: CHISQ, OM_ST, OM_EN, Beta_1, Xmom1, Err + Integer :: Nsweeps, NBins, Ngamma_1, Ndis_1, nw, nt1, Lcov + + ! Local + Integer lp, NSims, ns, nb, nc, Nwarm, nalp1, nalp2, Nex, p_star + Real (Kind=8), Allocatable :: Xn_M_tot(:,:), En_M_tot(:), Xn_E_tot(:,:), En_E_tot(:), & + & Xn_tot(:,:,:), En_tot(:), Xker_table(:,:) + Real (Kind=8), Allocatable :: G_Mean(:), Xn_m(:), Xn_e(:), Xn(:,:), Vhelp(:) + Real (Kind=8) :: Ranf, En_M, Res, X, Alpha, Acc_1, Acc_2, En, DeltaE, Ratio, D + Real (Kind=8) :: Aom, om, XMAX, tau + Real (Kind=8), allocatable :: U(:,:), sigma(:) + + + Pi = acos(-1.d0) + Iseed = 8752143 + NDis = Size(Aom_res,1) + DeltaXMAX = 0.01 + delta = 0.001 + delta2 = delta*delta + Ngamma = Ngamma_1 + Beta = Beta_1 ! Physical temperature for calculation of the kernel. + + Ntau = Size(xqmc,1) + NSims = Size(Alpha_tot,1) + Allocate (Xn_tot(Ngamma,2,NSims)) + Allocate (En_m_tot(NSims), En_e_tot(NSims), En_tot(NSims) ) + Allocate (Xn_m_tot(NDis,NSims), Xn_e_tot(NDis,NSims) ) + + Allocate (Xn(Ngamma,2)) + Allocate (Xn_m(NDis), Xn_e(NDis) ) + + Om_st_1 = OM_st; Om_en_1 = OM_en + + ! Setup table for the Kernel + Ndis = Size(Aom_res) + Dom = (OM_EN_1 - OM_ST_1)/dble(Ndis-1) + Allocate ( Xker_table(Ntau, Ndis) ) + Dom = (OM_EN - OM_ST)/dble(Ndis-1) + do nt = 1,Ntau + do nw = 1,Ndis + tau = xtau(nt) + Om = OM_st + dble(nw-1)*dom + Xker_table(nt,nw) = Xker(tau,om,beta) + enddo + enddo + + ! Normalize data to have zeroth moment of unity. + xqmc = xqmc / XMOM1 + cov = cov / ((XMOM1)**2) + ! Diagonalize the covariance + + If (Lcov.eq.1) then + Allocate( U(ntau,ntau), Sigma(ntau), xqmc1(Ntau) ) + Call Diag(cov,U,sigma) + do nt = 1,ntau + sigma(nt) = sqrt(sigma(nt)) + enddo + xqmc1 = 0.d0 + do nt1 = 1,ntau + do nt = 1,ntau + xqmc1(nt1) = xqmc1(nt1) + xqmc(nt)*U(nt,nt1) + enddo + xqmc1(nt1) = xqmc1(nt1)/sigma(nt1) + enddo + ! Transform the Kernel + allocate ( Vhelp(Ntau) ) + do nw = 1,Ndis + Vhelp = 0.d0 + do nt1 = 1,Ntau + do nt = 1,Ntau + Vhelp(nt1) = Vhelp(nt1) + Xker_table(nt,nw)*U(nt,nt1) + enddo + enddo + do nt1 = 1,ntau + Xker_table(nt1,nw) = Vhelp(nt1)/sigma(nt1) !! This has changed !! + enddo + enddo + Deallocate (U,sigma) + else + Allocate( Sigma(ntau), xqmc1(Ntau) ) + !Call Diag(cov,U,sigma) + do nt = 1,ntau + sigma(nt) = 1.d0/sqrt(cov(nt,nt)) + enddo + xqmc1 = 0.d0 + do nt1 = 1,ntau + xqmc1(nt1) = xqmc(nt1)*sigma(nt1) + enddo + ! Transform the Kernel + allocate ( Vhelp(Ntau) ) + do nw = 1,Ndis + do nt1 = 1,ntau + Xker_table(nt1,nw) = Xker_table(nt1,nw)*sigma(nt1) !! This has changed !! + enddo + enddo + deallocate(Sigma) + endif + Allocate(G_Mean(Ntau)) + G_mean = 0.d0 + +! write(6,*) ' There are ', Ngamma,' delta-functions for a spectrum' +! Write(6,*) ' Initializing' + Do Ns = 1,NSims + do ng = 1,NGamma + Xn_tot(ng,1,ns) = ranf(iseed) + Xn_tot(ng,2,ns) = 1.d0/dble(Ngamma) + enddo + enddo + Xn_m_tot = 0.d0 + En_m_tot = 0.d0 + Xn_e_tot = 0.d0 + En_e_tot = 0.d0 + ! D(om) = 1/(Om_en_1 - Om_st_1) + D = 1.d0 / (Om_en_1 - Om_st_1) + + Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") + Write(44,*) "N E W R U N " + nc = 0 + do Nb = 1,Nbins + do ns = 1,NSims + do ng = 1,Ngamma + Xn(ng,1) = Xn_tot(ng,1,ns) + Xn(ng,2) = Xn_tot(ng,2,ns) + enddo + Alpha = Alpha_tot(ns) + Call MC(Xtau, Xker_table, Xn, Alpha, NSweeps, Xn_m, En, En_m, & + & Acc_1, Acc_2 ) ! Just one bin + do ng = 1,Ngamma + Xn_tot(ng,1,ns) = Xn(ng,1) + Xn_tot(ng,2,ns) = Xn(ng,2) + enddo + En_tot(ns) = En ! this is the energy of the configuration Xn_tot for simulation ns + Write(44,2003) 1.d0/Alpha, En_m, Acc_1, Acc_2 + if (nb.gt.nwarm) then + if (ns.eq.1) nc = nc + 1 + do nd = 1,NDis + Xn_m(nd) = Xn_m(nd) * D * dble(Ndis) + Xn_m_tot(nd,ns) = Xn_m_tot(nd,ns) + Xn_m(nd) + Xn_e_tot(nd,ns) = Xn_e_tot(nd,ns) + Xn_m(nd)*Xn_m(nd) + enddo + En_m_tot(ns) = En_m_tot(ns) + En_m + En_e_tot(ns) = En_e_tot(ns) + En_m*En_m + endif + enddo + ! Exchange + Acc_1 = 0.d0 + Do Nex = 1, 2*NSims + nalp1= nint( ranf(iseed)*dble(NSims-1) + 0.5 ) ! 1..(NSims-1) + nalp2 = nalp1 + 1 + DeltaE = (Alpha_tot(nalp1)*En_tot(nalp2) + Alpha_tot(nalp2)*En_tot(nalp1))& + & -(Alpha_tot(nalp1)*En_tot(nalp1) + Alpha_tot(nalp2)*En_tot(nalp2)) + Ratio = exp(-DeltaE) + if (Ratio.gt.ranf(iseed)) Then + Acc_1 = Acc_1 + 1.0 + !Switch confs an Energies. + do ng = 1,Ngamma + Xn(ng,1) = Xn_tot(ng,1,nalp1) + Xn(ng,2) = Xn_tot(ng,2,nalp1) + enddo + do ng = 1,Ngamma + Xn_tot(ng,1,nalp1) = Xn_tot(ng,1,nalp2) + Xn_tot(ng,2,nalp1) = Xn_tot(ng,2,nalp2) + Xn_tot(ng,1,nalp2) = Xn(ng,1) + Xn_tot(ng,2,nalp2) = Xn(ng,2) + enddo + En_m = En_tot(nalp1) + En_tot(nalp1) = En_tot(nalp2) + En_tot(nalp2) = En_m + endif + enddo + Acc_1 = Acc_1/dble(Nex) + Write(44,*) 'Acc Exchange: ', Acc_1 + enddo + + !Open(Unit=66,File="energies",status="unknown") + do ns = Nsims,Nsims + En_m_tot(ns) = En_m_tot(ns) / dble(nc) + En_e_tot(ns) = En_e_tot(ns) / dble(nc) + En_e_tot(ns) = ( En_e_tot(ns) - En_m_tot(ns)**2)/dble(nc) + if ( En_e_tot(ns) .gt. 0.d0) then + En_e_tot(ns) = sqrt(En_e_tot(ns)) + else + En_e_tot(ns) = 0.d0 + endif + !write(66,*) Alpha_tot(ns), En_m_tot(ns), En_e_tot(ns) + enddo + !close(60) + Chisq = En_e_tot(Nsims) + Close(44) + + do ns = Nsims,Nsims + do nd = 1,Ndis + Xn_m_tot(nd,ns) = Xn_m_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) + Xn_e_tot(nd,ns) = Xn_e_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) + Xn_e_tot(nd,ns) = (Xn_e_tot(nd,ns) - Xn_m_tot(nd,ns)* Xn_m_tot(nd,ns))/dble(nc) + if (Xn_e_tot(nd,ns).gt.0.d0) then + Xn_e_tot(nd,ns) = sqrt(Xn_e_tot(nd,ns)) + else + Xn_e_tot(nd,ns) = 0.d0 + endif + om = PhiM1(dble(nd)/dble(NDis)) + Aom = Xn_m_tot(nd,ns) * Xmom1 + Err = Xn_e_tot(nd,ns) * Xmom1 + !write(66,2001) om, Aom, Err + if (ns.eq.Nsims) then + Aom_res(nd) = Aom + xom_res(nd) = om + endif + enddo + !Close(66) + enddo + + ! Reset the input data + xqmc = XMOM1* xqmc + cov = ((XMOM1)**2)* cov + + + DeAllocate (Xn_tot) + DeAllocate (En_m_tot, En_e_tot, En_tot ) + DeAllocate (Xn_m_tot, Xn_e_tot ) + DeAllocate (Xn) + DeAllocate (Xn_m, Xn_e) + DeAllocate( G_Mean ) + DeAllocate( xqmc1 ) + Deallocate( Xker_table ) + +2001 format(F14.7,2x,F14.7,2x,F14.7) +2004 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7) +2005 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7,2x,F14.7) +2003 format('Alpha, En_m, Acc ', F14.7,2x,F14.7,2x,F14.7,2x,F14.7,2x,F14.7) + end Subroutine MaxEnt_stoch_fit +#endif +!*********** + Real (Kind=8) Function Phim1(x) + Implicit None + ! Flat Default with sum 1. This is the correct sum rule for the data! + ! D(om) = 1/(Om_en_1 - Om_st_1) + Real (Kind=8) :: x + PhiM1 = x*(Om_en_1 - Om_st_1) + Om_st_1 + end Function Phim1 + + + Integer Function NPhim1(x) + Implicit None + + ! Flat Default with sum 1. This is the correct sum rule for the data! + ! D(om) = 1/(Om_en_1 - Om_st_1) + + Real (Kind=8) :: x, om + om = x*(Om_en_1 - Om_st_1) + Om_st_1 + NPhiM1 = Nint ( (om - Om_st_1)/Dom + 0.75 ) + + end Function NPhim1 + + +!*********** + Subroutine Sum_Xn(Xn_m,Xn) + + Implicit none + Real (Kind=8), Dimension(:,:) :: Xn + Real (Kind=8), Dimension(:) :: Xn_m + Real (Kind=8) :: X + + + do nd = 1,NDis + X = dble( nd )/dble( NDis ) + do ng = 1,Ngamma + Xn_m(nd) = Xn_m(nd) + Xn(ng,2)/( (X-Xn(ng,1))**2 + Delta2) + !aimag( cmplx(Xn(ng,2),0.d0)/cmplx( X-Xn(ng,1), -Delta) ) + enddo + enddo + + end Subroutine Sum_Xn + +!*********** + Subroutine Sum_Xn_Boxes(Xn_m,Xn) + + Implicit none + Real (Kind=8), Dimension(:,:) :: Xn + Real (Kind=8), Dimension(:) :: Xn_m + Real (Kind=8) :: X + + + do ng = 1,Ngamma + X = Xn(ng,1) + nd = Nint(dble(NDis)*X + 0.5 ) + Xn_m(nd) = Xn_m(nd) + Xn(ng,2) + Enddo + + end Subroutine Sum_Xn_Boxes + + +!*********** + Subroutine MC(Xtau, Xker_table, Xn, Alpha, NSweeps, Xn_m, En, En_m, Acc_1,Acc_2) + + !Implicit Real (KIND=8) (A-G,O-Z) + !Implicit Integer (H-N) + Implicit None + + Real (Kind=8), Dimension(:,:) :: Xn, Xker_table + Real (Kind=8), Dimension(:) :: Xtau, Xn_m + Real (Kind=8) :: Alpha, En_m, s, ratio, ranf, A_gamma, Z_gamma, Acc_1, Acc_2 + Integer :: NSweeps, nl, Lambda_max, ng1, ng2 + + !Local + Real (Kind=8), Allocatable :: h(:), Deltah(:), A_gamma_p(:), Z_gamma_p(:), & + & A_gamma_o(:), Z_gamma_o(:) + + Real (Kind=8), Allocatable :: XKER_stor(:,:), XKER_new(:) + + Real (Kind=8) :: X, En, En1, DeltaE, XP, XM, om + Integer, Allocatable :: Lambda(:) + Integer :: nb, nsw, Nacc_1, Nacc_2, nw + + Allocate (h(ntau), Deltah(ntau) ) + Allocate (Lambda(2), Z_gamma_p(2), A_gamma_p(2), & + & Z_gamma_o(2), A_gamma_o(2) ) ! Max of moves of two walkers. + + Allocate ( XKer_stor(Ntau,Ngamma), XKer_New(Ntau) ) + + Xn_m = 0.d0 + En_m = 0.d0 + + + ! Setup h(tau) + do nt = 1,Ntau + X = 0.d0 + do ng = 1,Ngamma + A_gamma = xn(ng,1) + Z_gamma = xn(ng,2) + XKer_stor( nt, ng ) = XKER_table(nt, NPhiM1(A_gamma) ) + ! XKER(xtau(nt),PhiM1(A_gamma),beta) + X = X + Xker_stor(nt,ng)*Z_gamma + enddo + h(nt) = X - xqmc1(nt) + enddo + + + NAcc_1 = 0; NAcc_2 = 0; + do nsw = 1,Nsweeps + ! Weight sharing moves. + do ng = 1,Ngamma + x = ranf(iseed) + if (x.gt.0.5) then + ! Weight sharing moves. + Lambda_max = 2 + Lambda(1) = nint(ranf(iseed)*dble(Ngamma) + 0.5) + do + Lambda(2) = nint(ranf(iseed)*dble(Ngamma) + 0.5) + if ( Lambda(2) .ne. Lambda(1) ) exit + enddo + ng1 = Lambda(1) + ng2 = Lambda(2) + + A_gamma_o(1) = Xn(ng1,1) + A_gamma_o(2) = Xn(ng2,1) + Z_gamma_o(1) = Xn(ng1,2) + Z_gamma_o(2) = Xn(ng2,2) + + A_gamma_p(1) = Xn(ng1,1) + A_gamma_p(2) = Xn(ng2,1) + + s = (Z_gamma_o(1) + Z_gamma_o(2))*ranf(iseed) - Z_gamma_o(1) + Z_gamma_p(1) = Z_gamma_o(1) + s + Z_gamma_p(2) = Z_gamma_o(2) - s + + ! Kernel stays unchanged. + + ! Compute Delta H + do nt = 1,ntau + X = Xker_stor(nt,ng1)*( Z_gamma_p(1) - Z_gamma_o(1) ) + & + & Xker_stor(nt,ng2)*( Z_gamma_p(2) - Z_gamma_o(2) ) + Deltah(nt) = X + enddo + else + Lambda_max = 1 + Lambda(1) = nint(ranf(iseed)*dble(Ngamma) + 0.5) + ng1 = Lambda(1) + Z_gamma_o(1) = Xn(ng1,2) + Z_gamma_p(1) = Xn(ng1,2) + + A_gamma_o(1) = Xn(ng1,1) + A_gamma_p(1) = xpbc( Xn(ng1,1) + (ranf(iseed) - 0.5)*DeltaXMAX, 1.d0 ) + + !om = PhiM1(A_gamma_p(1)) + nw = NPhiM1(A_gamma_p(1)) + do nt = 1,ntau + Xker_new(nt) = Xker_table(nt,nw) ! Xker(xtau(nt),om, beta) + enddo + + do nt = 1,ntau + X = ( Xker_new(nt) - Xker_stor(nt,ng1) ) * Z_gamma_o(1) + Deltah(nt) = X + enddo + endif + + + DeltaE = 0.d0 + do nt = 1,ntau + DeltaE = DeltaE + (Deltah(nt) + 2.0 * h(nt) ) *Deltah(nt) + enddo + Ratio = exp( -alpha * DeltaE ) + ! write(6,*) ' Ratio : ',Ratio, DeltaE + if (Ratio .gt. ranf(iseed)) Then + ! write(6,*) 'Accepted' + if (Lambda_max.eq.1) then + Nacc_1 = Nacc_1 + 1 + ng1 = Lambda(1) + do nt = 1,ntau + Xker_stor(nt,ng1) = Xker_new(nt) + enddo + endif + if (Lambda_max.eq.2) Nacc_2 = Nacc_2 + 1 + do nl = 1,Lambda_max + Xn(Lambda(nl),1) = A_gamma_p(nl) + Xn(Lambda(nl),2) = Z_gamma_p(nl) + enddo + do nt = 1,ntau + h(nt) = h(nt) + Deltah(nt) + enddo + endif + enddo + En = 0.0 + do nt = 1,Ntau + En = En + h(nt)*h(nt) + enddo + En_m = En_m + En + Call Sum_Xn_Boxes( Xn_m, Xn ) + enddo + Acc_1 = dble(Nacc_1)/dble(Ngamma*NSweeps) + Acc_2 = dble(Nacc_2)/dble(Ngamma*NSweeps) + En_m = En_m/dble( nsweeps ) + Xn_m = Xn_m/dble( nsweeps ) + + + Deallocate ( h, Deltah ) + Deallocate ( Lambda, Z_gamma_p, A_gamma_p, Z_gamma_o, A_gamma_o ) + Deallocate ( XKER_stor, XKER_new ) + +2005 format(I4,2x,I4,2x,F14.7,2x,F14.7,' --> ',F14.7,2x,F14.7) +2006 format(I4,2x,F14.7, ' --> ',F14.7) + end Subroutine MC + + + +!********** + real (Kind=8) function xpbc(X,XL) + real (kind=8) :: X, XL + XPBC = X + if (X.GT. XL ) XPBC = X - XL + if (X.LT. 0.0) XPBC = X + XL + end function xpbc + + +#ifdef MPI +end Module MaxEnt_stoch_mod_MPI +#else +end Module MaxEnt_stoch_mod +#endif diff --git a/src/Modules/maxent_stoch.f90 b/src/Modules/maxent_stoch.f90 new file mode 100644 index 000000000..418d544e6 --- /dev/null +++ b/src/Modules/maxent_stoch.f90 @@ -0,0 +1,748 @@ +Module MaxEnt_stoch_mod + Use MyMats + Use Files_mod + Integer, private :: NTAU, nt, Ngamma, ng, Ndis, nd, Iseed + Real (Kind=8), private :: Delta, Delta2, OM_st_1, Om_en_1, DeltaXMAX, Beta, Pi, Dom + Real (Kind=8), allocatable, private :: XQMC1(:) + ! You can still optimize a bit for by redefining the Kernel table to: + ! xker_table(nt,nw) -> xker_table(nt,nw) / sigma(nt) + ! This will save quite a lot of divisions in the + ! MC routine. And this is where all the time goes now. + CONTAINS + Subroutine MaxEnt_stoch(XQMC, Xtau, COV,Xmom1, XKER, Back_Trans_Aom, Beta_1, Alpha_tot,& + & Ngamma_1, OM_ST, OM_EN, Ndis_1, Nsweeps, NBins, NWarm, L_cov) + Implicit None + Real (Kind=8), Dimension(:) :: XQMC, Xtau, Alpha_tot + Real (Kind=8), Dimension(:,:) :: COV + Real (Kind=8), External :: XKER, Back_trans_Aom + Real (Kind=8) :: CHISQ, OM_ST, OM_EN, Beta_1, Xmom1, Err + Integer :: Nsweeps, NBins, Ngamma_1, Ndis_1, nw, nt1 + Integer, optional :: L_cov + ! Local + Integer lp, NSims, ns, nb, nc, Nwarm, nalp1, nalp2, Nex, p_star, Ndis_table, & + & io_error, io_error1, i, n, nc1 + Real (Kind=8), Allocatable :: Xn_M_tot(:,:), En_M_tot(:), Xn_E_tot(:,:), En_E_tot(:), & + & Xn_tot(:,:,:), En_tot(:) + Real (Kind=8), Allocatable :: G_Mean(:), Xn_m(:), Xn_e(:), Xn(:,:), Vhelp(:) + Real (Kind=8) :: Ranf, En_M, Res, X, Alpha, Acc_1, Acc_2, En, DeltaE, Ratio, D + Real (Kind=8) :: Aom, om, XMAX, tau + Real (Kind=8) :: CPUT, CPUTM + Integer :: ICPU_1, ICPU_2, N_P_SEC + Character (64) :: File_root, File1, File_conf, File_Aom + Real (Kind=8), allocatable :: Xker_table(:,:), U(:,:), sigma(:) + ! Space for moments. + Real (Kind=8), allocatable:: Mom_M_tot(:,:), Mom_E_tot(:,:) + Pi = acos(-1.d0) + NDis = Ndis_1 + DeltaXMAX = 0.01 + delta = 0.001 + delta2 = delta*delta + Ngamma = Ngamma_1 + Beta = Beta_1 ! Physical temperature for calculation of the kernel. + Ntau = Size(xqmc,1) + NSims = Size(Alpha_tot,1) + Allocate (Xn_tot(Ngamma,2,NSims)) + Allocate (En_m_tot(NSims), En_e_tot(NSims), En_tot(NSims) ) + Allocate (Xn_m_tot(NDis,NSims), Xn_e_tot(NDis,NSims) ) + Allocate (Mom_M_tot(2,Nsims), Mom_E_tot(2,Nsims) ) + Allocate (Xn(Ngamma,2)) + Allocate (Xn_m(NDis), Xn_e(NDis) ) + Om_st_1 = OM_st; Om_en_1 = OM_en + ! Setup table for the Kernel + Ndis_table = 50000 + Dom = (OM_EN_1 - OM_ST_1)/dble(Ndis_table-1) + Allocate ( Xker_table(Ntau, Ndis_table) ) + do nt = 1,Ntau + do nw = 1,Ndis_table + tau = xtau(nt) + Om = OM_st + dble(nw-1)*dom + Xker_table(nt,nw) = Xker(tau,om,beta) + enddo + enddo + ! Normalize data to have zeroth moment of unity. + xqmc = xqmc / XMOM1 + cov = cov / ((XMOM1)**2) + ! Diagonalize the covariance + Allocate( U(ntau,ntau), Sigma(ntau), xqmc1(Ntau) ) + If ( Present(L_cov) ) then + Call Diag(cov,U,sigma) + ! Write(6,*) " Cov Used" + else + Write(6,*) "No Cov Used" + U = 0.d0 + do nt = 1,ntau + U(nt,nt) = 1.d0 + sigma(nt) = cov(nt,nt) + enddo + endif + do nt = 1,ntau + sigma(nt) = sqrt(sigma(nt)) + enddo + xqmc1 = 0.d0 + do nt1 = 1,ntau + do nt = 1,ntau + xqmc1(nt1) = xqmc1(nt1) + xqmc(nt)*U(nt,nt1) + enddo + xqmc1(nt1) = xqmc1(nt1)/sigma(nt1) + enddo + ! Transform the Kernel + allocate ( Vhelp(Ntau) ) + do nw = 1,Ndis_table + Vhelp = 0.d0 + do nt1 = 1,Ntau + do nt = 1,Ntau + Vhelp(nt1) = Vhelp(nt1) + Xker_table(nt,nw)*U(nt,nt1) + enddo + enddo + do nt1 = 1,ntau + Xker_table(nt1,nw) = Vhelp(nt1)/sigma(nt1) !! This has changed !! + enddo + enddo + deallocate( U, Sigma ) + Allocate ( G_Mean(Ntau) ) + G_mean = 0.d0 +! write(6,*) ' There are ', Ngamma,' delta-functions for a spectrum' +! Write(6,*) ' Initializing' + ! D(om) = 1/(Om_en_1 - Om_st_1) + D = 1.d0 / (Om_en_1 - Om_st_1) + Iseed = 8752143 + File_conf = "dump_conf" + File_Aom = "dump_Aom" + Open(unit=41,file=File_conf,status='old',action='read', iostat=io_error) + Open(unit=42,file=File_Aom, status='old',action='read', iostat=io_error1) + If (io_error == 0 .and. io_error1 == 0 ) then + Nwarm = 0 + read(41,*) Iseed + do ns = 1,Nsims + do ng = 1,Ngamma + read(41,*) Xn_tot(ng,1,ns), Xn_tot(ng,2,ns) + enddo + read(41,*) En_m_tot(ns), En_e_tot(ns) + enddo + read(42,*) nc + do ns = 1,Nsims + do nd = 1,Ndis + read(42,*) Xn_m_tot(nd,ns), Xn_e_tot(nd,ns) + enddo + enddo + Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") + Write(44,*) 'Read from dump: nc = ', nc + close(44) + else + !Iseed is alrady set. + Do Ns = 1,NSims + do ng = 1,NGamma + Xn_tot(ng,1,ns) = ranf(iseed) + Xn_tot(ng,2,ns) = 1.d0/dble(Ngamma) + enddo + enddo + Xn_m_tot = 0.d0 + En_m_tot = 0.d0 + Xn_e_tot = 0.d0 + En_e_tot = 0.d0 + nc = 0 + Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") + Write(44,*) ' No dump data ' + close(44) + endif + close(41) + close(42) + nc1 = 0 + Mom_M_tot = 0.d0 + Mom_E_tot = 0.d0 + CALL SYSTEM_CLOCK(COUNT_RATE=N_P_SEC) + CALL SYSTEM_CLOCK(COUNT=ICPU_1) + ! Start Simulations. + do Nb = 1,Nbins + do ns = 1,NSims + do ng = 1,Ngamma + Xn(ng,1) = Xn_tot(ng,1,ns) + Xn(ng,2) = Xn_tot(ng,2,ns) + enddo + Alpha = Alpha_tot(ns) + Call MC(Xtau, Xker_table, Xn, Alpha, NSweeps, Xn_m, En, En_m, & + & Acc_1, Acc_2 ) ! Just one bin + do ng = 1,Ngamma + Xn_tot(ng,1,ns) = Xn(ng,1) + Xn_tot(ng,2,ns) = Xn(ng,2) + enddo + En_tot(ns) = En ! this is the energy of the configuration Xn_tot for simulation ns + Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") + Write(44,2003) 1.d0/Alpha, En_m, Acc_1, Acc_2 + close(44) + if (nb.gt.nwarm) then + if (ns.eq.1) nc = nc + 1 + do nd = 1,NDis + Xn_m(nd) = Xn_m(nd) * D * dble(Ndis) + Xn_m_tot(nd,ns) = Xn_m_tot(nd,ns) + Xn_m(nd) + Xn_e_tot(nd,ns) = Xn_e_tot(nd,ns) + Xn_m(nd)*Xn_m(nd) + enddo + En_m_tot(ns) = En_m_tot(ns) + En_m + En_e_tot(ns) = En_e_tot(ns) + En_m*En_m + ! Compute moments + if (ns.eq.1) nc1 = nc1 + 1 + do n = 1,Size(Mom_M_tot,1) + x = 0.d0 + do ng = 1,Ngamma + X = X + ( Phim1(Xn_tot(ng,1,ns))**(n-1) ) * Xn_tot(ng,2,Ns) + enddo + Mom_M_tot(n,ns) = Mom_M_tot(n,ns) + X + Mom_E_tot(n,ns) = Mom_E_tot(n,ns) + X*X + enddo + endif + enddo + ! Exchange + Acc_1 = 0.d0 + Do Nex = 1, 2*NSims + nalp1= nint( ranf(iseed)*dble(NSims-1) + 0.5 ) ! 1..(NSims-1) + nalp2 = nalp1 + 1 + DeltaE = (Alpha_tot(nalp1)*En_tot(nalp2) + Alpha_tot(nalp2)*En_tot(nalp1))& + & -(Alpha_tot(nalp1)*En_tot(nalp1) + Alpha_tot(nalp2)*En_tot(nalp2)) + Ratio = exp(-DeltaE) + if (Ratio.gt.ranf(iseed)) Then + Acc_1 = Acc_1 + 1.0 + !Switch confs an Energies. + do ng = 1,Ngamma + Xn(ng,1) = Xn_tot(ng,1,nalp1) + Xn(ng,2) = Xn_tot(ng,2,nalp1) + enddo + do ng = 1,Ngamma + Xn_tot(ng,1,nalp1) = Xn_tot(ng,1,nalp2) + Xn_tot(ng,2,nalp1) = Xn_tot(ng,2,nalp2) + Xn_tot(ng,1,nalp2) = Xn(ng,1) + Xn_tot(ng,2,nalp2) = Xn(ng,2) + enddo + En_m = En_tot(nalp1) + En_tot(nalp1) = En_tot(nalp2) + En_tot(nalp2) = En_m + endif + enddo + Acc_1 = Acc_1/dble(Nex) + Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") + Write(44,*) 'Acc Exchange: ', Acc_1 + close(44) + enddo + CALL SYSTEM_CLOCK(COUNT=ICPU_2) + CPUT = 0.D0 + CPUT = DBLE(ICPU_2 - ICPU_1)/DBLE(N_P_SEC) + Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") + Write(44,*) 'Total time: ', CPUT + close(44) + ! dump so as to restart. + Open(unit=41,file=File_conf,status='unknown') + Open(unit=42,file=File_Aom, status='unknown') + write(41,*) Iseed + do ns = 1,Nsims + do ng = 1,Ngamma + write(41,*) Xn_tot(ng,1,ns), Xn_tot(ng,2,ns) + enddo + write(41,*) En_m_tot(ns), En_e_tot(ns) + enddo + write(42,*) nc + do ns = 1,Nsims + do nd = 1,Ndis + write(42,*) Xn_m_tot(nd,ns), Xn_e_tot(nd,ns) + enddo + enddo + close(41) + close(42) + ! Stop dump + Open(Unit=66,File="energies",status="unknown") + do ns = 1,Nsims + En_m_tot(ns) = En_m_tot(ns) / dble(nc) + En_e_tot(ns) = En_e_tot(ns) / dble(nc) + En_e_tot(ns) = ( En_e_tot(ns) - En_m_tot(ns)**2)/dble(nc) + if ( En_e_tot(ns) .gt. 0.d0) then + En_e_tot(ns) = sqrt(En_e_tot(ns)) + else + En_e_tot(ns) = 0.d0 + endif + write(66,*) Alpha_tot(ns), En_m_tot(ns), En_e_tot(ns) + enddo + close(66) + Open(Unit=66,File="moments",status="unknown") + do ns = 1,Nsims + do n = 1,Size(Mom_m_tot,1) + Mom_m_tot(n,ns) = Mom_m_tot(n,ns) / dble(nc1) + Mom_e_tot(n,ns) = Mom_e_tot(n,ns) / dble(nc1) + Mom_e_tot(n,ns) = ( Mom_e_tot(n,ns) - Mom_m_tot(n,ns)**2)/dble(nc1) + if ( Mom_e_tot(n,ns) .gt. 0.d0) then + Mom_e_tot(n,ns) = sqrt(Mom_e_tot(n,ns)) + else + Mom_e_tot(n,ns) = 0.d0 + endif + enddo + write(66,"(F12.6,2x,F12.6,2x,F12.6,2x,F12.6,2x,F12.6)") & + & Alpha_tot(ns), Mom_m_tot(1,ns), Mom_e_tot(1,ns), & + & Mom_m_tot(2,ns), Mom_e_tot(2,ns) + enddo + close(66) + File_root = "Aom" + do ns = 1,Nsims + File1 = File_i(File_root,ns) + Open(Unit=66,File=File1,status="unknown") + do nd = 1,Ndis + Xn_m_tot(nd,ns) = Xn_m_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) + Xn_e_tot(nd,ns) = Xn_e_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) + Xn_e_tot(nd,ns) = (Xn_e_tot(nd,ns) - Xn_m_tot(nd,ns)* Xn_m_tot(nd,ns))/dble(nc) + if (Xn_e_tot(nd,ns).gt.0.d0) then + Xn_e_tot(nd,ns) = sqrt(Xn_e_tot(nd,ns)) + else + Xn_e_tot(nd,ns) = 0.d0 + endif + om = PhiM1(dble(nd)/dble(NDis)) + Aom = Xn_m_tot(nd,ns) * Xmom1 + Err = Xn_e_tot(nd,ns) * Xmom1 + write(66,2001) om, Back_Trans_Aom(Aom,Beta,om), Back_Trans_Aom(Err,Beta,om) + ! PhiM1(dble(nd)/dble(NDis)), Xn_m_tot(nd,ns) + enddo + Close(66) + enddo + ! Now do the averaging. + File_root ="Aom_ps" + do p_star = 1,NSims - 10 + Xn_m = 0.0 + Xn_e = 0.0 + do ns = p_star, NSims-1 + do nd = 1, NDis + Xn_m(nd) = Xn_m(nd) + (En_m_tot(ns) - En_m_tot(ns+1))*Xn_m_tot(nd,ns) + Xn_e(nd) = Xn_e(nd) + (En_m_tot(ns) - En_m_tot(ns+1))*Xn_e_tot(nd,ns) + enddo + enddo + do nd = 1,NDis + Xn_m(nd) = Xn_m(nd) / (En_m_tot(p_star) - En_m_tot(NSims)) + Xn_e(nd) = Xn_e(nd) / (En_m_tot(p_star) - En_m_tot(NSims)) + enddo + File1 = File_i(File_root,p_star) + Open(Unit=66,File=File1,status="unknown") + XMAX = 0.d0 + Do nd = 1,Ndis + om = PhiM1(dble(nd)/dble(NDis)) + Aom = Xn_m(nd) * Xmom1 + Err = Xn_e(nd) * Xmom1 + Xn_m(nd) = Back_Trans_Aom(Aom,Beta,om) + Xn_e(nd) = Back_Trans_Aom(Err,Beta,om) + IF (Xn_m(nd) .gt. XMAX ) XMAX = Xn_m(nd) + enddo + do nd = 1,Ndis + om = PhiM1(dble(nd)/dble(NDis)) + write(66,2005) om, Xn_m(nd), Xn_e(nd), Xn_m(nd)/XMAX, Xn_e(nd)/XMAX + ! PhiM1(dble(nd)/dble(NDis)), Xn_m(nd) + enddo + close(66) + enddo + Open (Unit=41,File='Best_fit', Status="unknown") + do ng = 1,Ngamma + Write(41,*) Phim1(Xn_tot(ng,1,Nsims)) , Xn_tot(ng,2,Nsims) + enddo + close(41) + DeAllocate (Xn_tot) + DeAllocate (En_m_tot, En_e_tot, En_tot ) + DeAllocate (Xn_m_tot, Xn_e_tot ) + DeAllocate (Xn) + DeAllocate (Xn_m, Xn_e) + DeAllocate( G_Mean ) + DeAllocate( xqmc1 ) + Deallocate( Xker_table ) +2001 format(F14.7,2x,F14.7,2x,F14.7) +2004 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7) +2005 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7,2x,F14.7) +2003 format('Alpha, En_m, Acc ', F14.7,2x,F24.12,2x,F14.7,2x,F14.7,2x,F14.7) + end Subroutine MaxEnt_stoch +!------------------- + Subroutine MaxEnt_stoch_fit(XQMC, Xtau, COV, Lcov, XKER, Xmom1, Beta_1, Alpha_tot,& + & Ngamma_1, OM_ST, OM_EN, Nsweeps, NBins, NWarm, Aom_res,& + & xom_res, Chisq ) + Implicit None + Real (Kind=8), Dimension(:) :: XQMC, Xtau, Alpha_tot, Aom_res, Xom_res + Real (Kind=8), Dimension(:,:) :: COV + Real (Kind=8), external :: XKER + Real (Kind=8) :: CHISQ, OM_ST, OM_EN, Beta_1, Xmom1, Err + Integer :: Nsweeps, NBins, Ngamma_1, Ndis_1, nw, nt1, Lcov + ! Local + Integer lp, NSims, ns, nb, nc, Nwarm, nalp1, nalp2, Nex, p_star + Real (Kind=8), Allocatable :: Xn_M_tot(:,:), En_M_tot(:), Xn_E_tot(:,:), En_E_tot(:), & + & Xn_tot(:,:,:), En_tot(:), Xker_table(:,:) + Real (Kind=8), Allocatable :: G_Mean(:), Xn_m(:), Xn_e(:), Xn(:,:), Vhelp(:) + Real (Kind=8) :: Ranf, En_M, Res, X, Alpha, Acc_1, Acc_2, En, DeltaE, Ratio, D + Real (Kind=8) :: Aom, om, XMAX, tau + Real (Kind=8), allocatable :: U(:,:), sigma(:) + Pi = acos(-1.d0) + Iseed = 8752143 + NDis = Size(Aom_res,1) + DeltaXMAX = 0.01 + delta = 0.001 + delta2 = delta*delta + Ngamma = Ngamma_1 + Beta = Beta_1 ! Physical temperature for calculation of the kernel. + Ntau = Size(xqmc,1) + NSims = Size(Alpha_tot,1) + Allocate (Xn_tot(Ngamma,2,NSims)) + Allocate (En_m_tot(NSims), En_e_tot(NSims), En_tot(NSims) ) + Allocate (Xn_m_tot(NDis,NSims), Xn_e_tot(NDis,NSims) ) + Allocate (Xn(Ngamma,2)) + Allocate (Xn_m(NDis), Xn_e(NDis) ) + Om_st_1 = OM_st; Om_en_1 = OM_en + ! Setup table for the Kernel + Ndis = Size(Aom_res) + Dom = (OM_EN_1 - OM_ST_1)/dble(Ndis-1) + Allocate ( Xker_table(Ntau, Ndis) ) + Dom = (OM_EN - OM_ST)/dble(Ndis-1) + do nt = 1,Ntau + do nw = 1,Ndis + tau = xtau(nt) + Om = OM_st + dble(nw-1)*dom + Xker_table(nt,nw) = Xker(tau,om,beta) + enddo + enddo + ! Normalize data to have zeroth moment of unity. + xqmc = xqmc / XMOM1 + cov = cov / ((XMOM1)**2) + ! Diagonalize the covariance + If (Lcov.eq.1) then + Allocate( U(ntau,ntau), Sigma(ntau), xqmc1(Ntau) ) + Call Diag(cov,U,sigma) + do nt = 1,ntau + sigma(nt) = sqrt(sigma(nt)) + enddo + xqmc1 = 0.d0 + do nt1 = 1,ntau + do nt = 1,ntau + xqmc1(nt1) = xqmc1(nt1) + xqmc(nt)*U(nt,nt1) + enddo + xqmc1(nt1) = xqmc1(nt1)/sigma(nt1) + enddo + ! Transform the Kernel + allocate ( Vhelp(Ntau) ) + do nw = 1,Ndis + Vhelp = 0.d0 + do nt1 = 1,Ntau + do nt = 1,Ntau + Vhelp(nt1) = Vhelp(nt1) + Xker_table(nt,nw)*U(nt,nt1) + enddo + enddo + do nt1 = 1,ntau + Xker_table(nt1,nw) = Vhelp(nt1)/sigma(nt1) !! This has changed !! + enddo + enddo + Deallocate (U,sigma) + else + Allocate( Sigma(ntau), xqmc1(Ntau) ) + !Call Diag(cov,U,sigma) + do nt = 1,ntau + sigma(nt) = 1.d0/sqrt(cov(nt,nt)) + enddo + xqmc1 = 0.d0 + do nt1 = 1,ntau + xqmc1(nt1) = xqmc(nt1)*sigma(nt1) + enddo + ! Transform the Kernel + allocate ( Vhelp(Ntau) ) + do nw = 1,Ndis + do nt1 = 1,ntau + Xker_table(nt1,nw) = Xker_table(nt1,nw)*sigma(nt1) !! This has changed !! + enddo + enddo + deallocate(Sigma) + endif + Allocate(G_Mean(Ntau)) + G_mean = 0.d0 +! write(6,*) ' There are ', Ngamma,' delta-functions for a spectrum' +! Write(6,*) ' Initializing' + Do Ns = 1,NSims + do ng = 1,NGamma + Xn_tot(ng,1,ns) = ranf(iseed) + Xn_tot(ng,2,ns) = 1.d0/dble(Ngamma) + enddo + enddo + Xn_m_tot = 0.d0 + En_m_tot = 0.d0 + Xn_e_tot = 0.d0 + En_e_tot = 0.d0 + ! D(om) = 1/(Om_en_1 - Om_st_1) + D = 1.d0 / (Om_en_1 - Om_st_1) + Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") + Write(44,*) "N E W R U N " + nc = 0 + do Nb = 1,Nbins + do ns = 1,NSims + do ng = 1,Ngamma + Xn(ng,1) = Xn_tot(ng,1,ns) + Xn(ng,2) = Xn_tot(ng,2,ns) + enddo + Alpha = Alpha_tot(ns) + Call MC(Xtau, Xker_table, Xn, Alpha, NSweeps, Xn_m, En, En_m, & + & Acc_1, Acc_2 ) ! Just one bin + do ng = 1,Ngamma + Xn_tot(ng,1,ns) = Xn(ng,1) + Xn_tot(ng,2,ns) = Xn(ng,2) + enddo + En_tot(ns) = En ! this is the energy of the configuration Xn_tot for simulation ns + Write(44,2003) 1.d0/Alpha, En_m, Acc_1, Acc_2 + if (nb.gt.nwarm) then + if (ns.eq.1) nc = nc + 1 + do nd = 1,NDis + Xn_m(nd) = Xn_m(nd) * D * dble(Ndis) + Xn_m_tot(nd,ns) = Xn_m_tot(nd,ns) + Xn_m(nd) + Xn_e_tot(nd,ns) = Xn_e_tot(nd,ns) + Xn_m(nd)*Xn_m(nd) + enddo + En_m_tot(ns) = En_m_tot(ns) + En_m + En_e_tot(ns) = En_e_tot(ns) + En_m*En_m + endif + enddo + ! Exchange + Acc_1 = 0.d0 + Do Nex = 1, 2*NSims + nalp1= nint( ranf(iseed)*dble(NSims-1) + 0.5 ) ! 1..(NSims-1) + nalp2 = nalp1 + 1 + DeltaE = (Alpha_tot(nalp1)*En_tot(nalp2) + Alpha_tot(nalp2)*En_tot(nalp1))& + & -(Alpha_tot(nalp1)*En_tot(nalp1) + Alpha_tot(nalp2)*En_tot(nalp2)) + Ratio = exp(-DeltaE) + if (Ratio.gt.ranf(iseed)) Then + Acc_1 = Acc_1 + 1.0 + !Switch confs an Energies. + do ng = 1,Ngamma + Xn(ng,1) = Xn_tot(ng,1,nalp1) + Xn(ng,2) = Xn_tot(ng,2,nalp1) + enddo + do ng = 1,Ngamma + Xn_tot(ng,1,nalp1) = Xn_tot(ng,1,nalp2) + Xn_tot(ng,2,nalp1) = Xn_tot(ng,2,nalp2) + Xn_tot(ng,1,nalp2) = Xn(ng,1) + Xn_tot(ng,2,nalp2) = Xn(ng,2) + enddo + En_m = En_tot(nalp1) + En_tot(nalp1) = En_tot(nalp2) + En_tot(nalp2) = En_m + endif + enddo + Acc_1 = Acc_1/dble(Nex) + Write(44,*) 'Acc Exchange: ', Acc_1 + enddo + !Open(Unit=66,File="energies",status="unknown") + do ns = Nsims,Nsims + En_m_tot(ns) = En_m_tot(ns) / dble(nc) + En_e_tot(ns) = En_e_tot(ns) / dble(nc) + En_e_tot(ns) = ( En_e_tot(ns) - En_m_tot(ns)**2)/dble(nc) + if ( En_e_tot(ns) .gt. 0.d0) then + En_e_tot(ns) = sqrt(En_e_tot(ns)) + else + En_e_tot(ns) = 0.d0 + endif + !write(66,*) Alpha_tot(ns), En_m_tot(ns), En_e_tot(ns) + enddo + !close(60) + Chisq = En_e_tot(Nsims) + Close(44) + do ns = Nsims,Nsims + do nd = 1,Ndis + Xn_m_tot(nd,ns) = Xn_m_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) + Xn_e_tot(nd,ns) = Xn_e_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) + Xn_e_tot(nd,ns) = (Xn_e_tot(nd,ns) - Xn_m_tot(nd,ns)* Xn_m_tot(nd,ns))/dble(nc) + if (Xn_e_tot(nd,ns).gt.0.d0) then + Xn_e_tot(nd,ns) = sqrt(Xn_e_tot(nd,ns)) + else + Xn_e_tot(nd,ns) = 0.d0 + endif + om = PhiM1(dble(nd)/dble(NDis)) + Aom = Xn_m_tot(nd,ns) * Xmom1 + Err = Xn_e_tot(nd,ns) * Xmom1 + !write(66,2001) om, Aom, Err + if (ns.eq.Nsims) then + Aom_res(nd) = Aom + xom_res(nd) = om + endif + enddo + !Close(66) + enddo + ! Reset the input data + xqmc = XMOM1* xqmc + cov = ((XMOM1)**2)* cov + DeAllocate (Xn_tot) + DeAllocate (En_m_tot, En_e_tot, En_tot ) + DeAllocate (Xn_m_tot, Xn_e_tot ) + DeAllocate (Xn) + DeAllocate (Xn_m, Xn_e) + DeAllocate( G_Mean ) + DeAllocate( xqmc1 ) + Deallocate( Xker_table ) +2001 format(F14.7,2x,F14.7,2x,F14.7) +2004 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7) +2005 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7,2x,F14.7) +2003 format('Alpha, En_m, Acc ', F14.7,2x,F14.7,2x,F14.7,2x,F14.7,2x,F14.7) + end Subroutine MaxEnt_stoch_fit +!*********** + Real (Kind=8) Function Phim1(x) + Implicit None + ! Flat Default with sum 1. This is the correct sum rule for the data! + ! D(om) = 1/(Om_en_1 - Om_st_1) + Real (Kind=8) :: x + PhiM1 = x*(Om_en_1 - Om_st_1) + Om_st_1 + end Function Phim1 + Integer Function NPhim1(x) + Implicit None + ! Flat Default with sum 1. This is the correct sum rule for the data! + ! D(om) = 1/(Om_en_1 - Om_st_1) + Real (Kind=8) :: x, om + om = x*(Om_en_1 - Om_st_1) + Om_st_1 + NPhiM1 = Nint ( (om - Om_st_1)/Dom + 0.75 ) + end Function NPhim1 +!*********** + Subroutine Sum_Xn(Xn_m,Xn) + Implicit none + Real (Kind=8), Dimension(:,:) :: Xn + Real (Kind=8), Dimension(:) :: Xn_m + Real (Kind=8) :: X + do nd = 1,NDis + X = dble( nd )/dble( NDis ) + do ng = 1,Ngamma + Xn_m(nd) = Xn_m(nd) + Xn(ng,2)/( (X-Xn(ng,1))**2 + Delta2) + !aimag( cmplx(Xn(ng,2),0.d0)/cmplx( X-Xn(ng,1), -Delta) ) + enddo + enddo + end Subroutine Sum_Xn +!*********** + Subroutine Sum_Xn_Boxes(Xn_m,Xn) + Implicit none + Real (Kind=8), Dimension(:,:) :: Xn + Real (Kind=8), Dimension(:) :: Xn_m + Real (Kind=8) :: X + do ng = 1,Ngamma + X = Xn(ng,1) + nd = Nint(dble(NDis)*X + 0.5 ) + Xn_m(nd) = Xn_m(nd) + Xn(ng,2) + Enddo + end Subroutine Sum_Xn_Boxes +!*********** + Subroutine MC(Xtau, Xker_table, Xn, Alpha, NSweeps, Xn_m, En, En_m, Acc_1,Acc_2) + !Implicit Real (KIND=8) (A-G,O-Z) + !Implicit Integer (H-N) + Implicit None + Real (Kind=8), Dimension(:,:) :: Xn, Xker_table + Real (Kind=8), Dimension(:) :: Xtau, Xn_m + Real (Kind=8) :: Alpha, En_m, s, ratio, ranf, A_gamma, Z_gamma, Acc_1, Acc_2 + Integer :: NSweeps, nl, Lambda_max, ng1, ng2 + !Local + Real (Kind=8), Allocatable :: h(:), Deltah(:), A_gamma_p(:), Z_gamma_p(:), & + & A_gamma_o(:), Z_gamma_o(:) + Real (Kind=8), Allocatable :: XKER_stor(:,:), XKER_new(:) + Real (Kind=8) :: X, En, En1, DeltaE, XP, XM, om + Integer, Allocatable :: Lambda(:) + Integer :: nb, nsw, Nacc_1, Nacc_2, nw + Allocate (h(ntau), Deltah(ntau) ) + Allocate (Lambda(2), Z_gamma_p(2), A_gamma_p(2), & + & Z_gamma_o(2), A_gamma_o(2) ) ! Max of moves of two walkers. + Allocate ( XKer_stor(Ntau,Ngamma), XKer_New(Ntau) ) + Xn_m = 0.d0 + En_m = 0.d0 + ! Setup h(tau) + do nt = 1,Ntau + X = 0.d0 + do ng = 1,Ngamma + A_gamma = xn(ng,1) + Z_gamma = xn(ng,2) + XKer_stor( nt, ng ) = XKER_table(nt, NPhiM1(A_gamma) ) + ! XKER(xtau(nt),PhiM1(A_gamma),beta) + X = X + Xker_stor(nt,ng)*Z_gamma + enddo + h(nt) = X - xqmc1(nt) + enddo + NAcc_1 = 0; NAcc_2 = 0; + do nsw = 1,Nsweeps + ! Weight sharing moves. + do ng = 1,Ngamma + x = ranf(iseed) + if (x.gt.0.5) then + ! Weight sharing moves. + Lambda_max = 2 + Lambda(1) = nint(ranf(iseed)*dble(Ngamma) + 0.5) + do + Lambda(2) = nint(ranf(iseed)*dble(Ngamma) + 0.5) + if ( Lambda(2) .ne. Lambda(1) ) exit + enddo + ng1 = Lambda(1) + ng2 = Lambda(2) + A_gamma_o(1) = Xn(ng1,1) + A_gamma_o(2) = Xn(ng2,1) + Z_gamma_o(1) = Xn(ng1,2) + Z_gamma_o(2) = Xn(ng2,2) + A_gamma_p(1) = Xn(ng1,1) + A_gamma_p(2) = Xn(ng2,1) + s = (Z_gamma_o(1) + Z_gamma_o(2))*ranf(iseed) - Z_gamma_o(1) + Z_gamma_p(1) = Z_gamma_o(1) + s + Z_gamma_p(2) = Z_gamma_o(2) - s + ! Kernel stays unchanged. + ! Compute Delta H + do nt = 1,ntau + X = Xker_stor(nt,ng1)*( Z_gamma_p(1) - Z_gamma_o(1) ) + & + & Xker_stor(nt,ng2)*( Z_gamma_p(2) - Z_gamma_o(2) ) + Deltah(nt) = X + enddo + else + Lambda_max = 1 + Lambda(1) = nint(ranf(iseed)*dble(Ngamma) + 0.5) + ng1 = Lambda(1) + Z_gamma_o(1) = Xn(ng1,2) + Z_gamma_p(1) = Xn(ng1,2) + A_gamma_o(1) = Xn(ng1,1) + A_gamma_p(1) = xpbc( Xn(ng1,1) + (ranf(iseed) - 0.5)*DeltaXMAX, 1.d0 ) + !om = PhiM1(A_gamma_p(1)) + nw = NPhiM1(A_gamma_p(1)) + do nt = 1,ntau + Xker_new(nt) = Xker_table(nt,nw) ! Xker(xtau(nt),om, beta) + enddo + do nt = 1,ntau + X = ( Xker_new(nt) - Xker_stor(nt,ng1) ) * Z_gamma_o(1) + Deltah(nt) = X + enddo + endif + DeltaE = 0.d0 + do nt = 1,ntau + DeltaE = DeltaE + (Deltah(nt) + 2.0 * h(nt) ) *Deltah(nt) + enddo + Ratio = exp( -alpha * DeltaE ) + ! write(6,*) ' Ratio : ',Ratio, DeltaE + if (Ratio .gt. ranf(iseed)) Then + ! write(6,*) 'Accepted' + if (Lambda_max.eq.1) then + Nacc_1 = Nacc_1 + 1 + ng1 = Lambda(1) + do nt = 1,ntau + Xker_stor(nt,ng1) = Xker_new(nt) + enddo + endif + if (Lambda_max.eq.2) Nacc_2 = Nacc_2 + 1 + do nl = 1,Lambda_max + Xn(Lambda(nl),1) = A_gamma_p(nl) + Xn(Lambda(nl),2) = Z_gamma_p(nl) + enddo + do nt = 1,ntau + h(nt) = h(nt) + Deltah(nt) + enddo + endif + enddo + En = 0.0 + do nt = 1,Ntau + En = En + h(nt)*h(nt) + enddo + En_m = En_m + En + Call Sum_Xn_Boxes( Xn_m, Xn ) + enddo + Acc_1 = dble(Nacc_1)/dble(Ngamma*NSweeps) + Acc_2 = dble(Nacc_2)/dble(Ngamma*NSweeps) + En_m = En_m/dble( nsweeps ) + Xn_m = Xn_m/dble( nsweeps ) + Deallocate ( h, Deltah ) + Deallocate ( Lambda, Z_gamma_p, A_gamma_p, Z_gamma_o, A_gamma_o ) + Deallocate ( XKER_stor, XKER_new ) +2005 format(I4,2x,I4,2x,F14.7,2x,F14.7,' --> ',F14.7,2x,F14.7) +2006 format(I4,2x,F14.7, ' --> ',F14.7) + end Subroutine MC +!********** + real (Kind=8) function xpbc(X,XL) + real (kind=8) :: X, XL + XPBC = X + if (X.GT. XL ) XPBC = X - XL + if (X.LT. 0.0) XPBC = X + XL + end function xpbc +end Module MaxEnt_stoch_mod diff --git a/src/Modules/maxent_stoch_w.f90 b/src/Modules/maxent_stoch_w.f90 new file mode 100644 index 000000000..a0baf0565 --- /dev/null +++ b/src/Modules/maxent_stoch_w.f90 @@ -0,0 +1,836 @@ + + + + + + +Module MaxEnt_stoch_mod + + + Use MyMats + Use Files_mod + + + Integer, private :: NTAU, nt, Ngamma, ng, Ndis, nd, Iseed + Real (Kind=8), private :: Delta, Delta2, OM_st_1, Om_en_1, DeltaXMAX, Beta, Pi, Dom + Real (Kind=8), allocatable, private :: XQMC1(:) + + ! You can still optimize a bit for by redefining the Kernel table to: + ! xker_table(nt,nw) -> xker_table(nt,nw) / sigma(nt) + ! This will save quite a lot of divisions in the + ! MC routine. And this is where all the time goes now. + + CONTAINS + + Subroutine MaxEnt_stoch(XQMC, Xtau, COV,Xmom1, XKER, Back_Trans_Aom, Beta_1, Alpha_tot,& + & Ngamma_1, OM_ST, OM_EN, Ndis_1, Nsweeps, NBins, NWarm, L_cov ) + + Implicit None + + + + + + Real (Kind=8), Dimension(:) :: XQMC, Xtau, Alpha_tot + Real (Kind=8), Dimension(:,:) :: COV + Real (Kind=8), External :: XKER, Back_trans_Aom + Real (Kind=8) :: CHISQ, OM_ST, OM_EN, Beta_1, Xmom1, Err + Integer :: Nsweeps, NBins, Ngamma_1, Ndis_1, nw, nt1 + Integer, optional :: L_cov + + ! Local + Integer lp, NSims, ns, nb, nc, Nwarm, nalp1, nalp2, Nex, p_star, Ndis_table, & + & io_error, io_error1, i + Real (Kind=8), Allocatable :: Xn_M_tot(:,:), En_M_tot(:), Xn_E_tot(:,:), En_E_tot(:), & + & Xn_tot(:,:,:), En_tot(:) + Real (Kind=8), Allocatable :: G_Mean(:), Xn_m(:), Xn_e(:), Xn(:,:), Vhelp(:) + Real (Kind=8) :: Ranf, En_M, Res, X, Alpha, Acc_1, Acc_2, En, DeltaE, Ratio, D + Real (Kind=8) :: Aom, om, XMAX, tau + Real (Kind=8) :: CPUT, CPUTM + Integer :: ICPU_1, ICPU_2, N_P_SEC + Character (64) :: File_root, File1, File_conf, File_Aom + Real (Kind=8), allocatable :: Xker_table(:,:), U(:,:), sigma(:) + + + + + + + + + + + Pi = acos(-1.d0) + NDis = Ndis_1 + DeltaXMAX = 0.01 + delta = 0.001 + delta2 = delta*delta + Ngamma = Ngamma_1 + Beta = Beta_1 ! Physical temperature for calculation of the kernel. + + Ntau = Size(xqmc,1) + NSims = Size(Alpha_tot,1) + Allocate (Xn_tot(Ngamma,2,NSims)) + Allocate (En_m_tot(NSims), En_e_tot(NSims), En_tot(NSims) ) + Allocate (Xn_m_tot(NDis,NSims), Xn_e_tot(NDis,NSims) ) + + Allocate (Xn(Ngamma,2)) + Allocate (Xn_m(NDis), Xn_e(NDis) ) + + Om_st_1 = OM_st; Om_en_1 = OM_en + + ! Setup table for the Kernel + Ndis_table = 50000 + Dom = (OM_EN_1 - OM_ST_1)/dble(Ndis_table-1) + Allocate ( Xker_table(Ntau, Ndis_table) ) + do nt = 1,Ntau + do nw = 1,Ndis_table + tau = xtau(nt) + Om = OM_st + dble(nw-1)*dom + Xker_table(nt,nw) = Xker(tau,om,beta) + enddo + enddo + ! Normalize data to have zeroth moment of unity. + xqmc = xqmc / XMOM1 + cov = cov / ((XMOM1)**2) + ! Diagonalize the covariance + + Allocate( U(ntau,ntau), Sigma(ntau), xqmc1(Ntau) ) + If ( Present(L_cov) ) then + Call Diag(cov,U,sigma) + ! Write(6,*) " Cov Used" + else + Write(6,*) "No Cov Used" + U = 0.d0 + do nt = 1,ntau + U(nt,nt) = 1.d0 + sigma(nt) = cov(nt,nt) + enddo + endif + do nt = 1,ntau + sigma(nt) = sqrt(sigma(nt)) + enddo + xqmc1 = 0.d0 + do nt1 = 1,ntau + do nt = 1,ntau + xqmc1(nt1) = xqmc1(nt1) + xqmc(nt)*U(nt,nt1) + enddo + xqmc1(nt1) = xqmc1(nt1)/sigma(nt1) + enddo + ! Transform the Kernel + allocate ( Vhelp(Ntau) ) + do nw = 1,Ndis_table + Vhelp = 0.d0 + do nt1 = 1,Ntau + do nt = 1,Ntau + Vhelp(nt1) = Vhelp(nt1) + Xker_table(nt,nw)*U(nt,nt1) + enddo + enddo + do nt1 = 1,ntau + Xker_table(nt1,nw) = Vhelp(nt1)/sigma(nt1) !! This has changed !! + enddo + enddo + deallocate( U, Sigma ) + Allocate ( G_Mean(Ntau) ) + G_mean = 0.d0 + +! write(6,*) ' There are ', Ngamma,' delta-functions for a spectrum' +! Write(6,*) ' Initializing' + ! D(om) = 1/(Om_en_1 - Om_st_1) + D = 1.d0 / (Om_en_1 - Om_st_1) + + Iseed = 8752143 + + File_conf = "dump_conf" + File_Aom = "dump_Aom" + + Open(unit=41,file=File_conf,status='old',action='read', iostat=io_error) + Open(unit=42,file=File_Aom, status='old',action='read', iostat=io_error1) + If (io_error == 0 .and. io_error1 == 0 ) then + Nwarm = 0 + read(41,*) Iseed + do ns = 1,Nsims + do ng = 1,Ngamma + read(41,*) Xn_tot(ng,1,ns), Xn_tot(ng,2,ns) + enddo + read(41,*) En_m_tot(ns), En_e_tot(ns) + enddo + read(42,*) nc + do ns = 1,Nsims + do nd = 1,Ndis + read(42,*) Xn_m_tot(nd,ns), Xn_e_tot(nd,ns) + enddo + enddo + Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") + Write(44,*) 'Read from dump: nc = ', nc + close(44) + else + !Iseed is alrady set. + Do Ns = 1,NSims + do ng = 1,NGamma + Xn_tot(ng,1,ns) = ranf(iseed) + Xn_tot(ng,2,ns) = 1.d0/dble(Ngamma) + enddo + enddo + Xn_m_tot = 0.d0 + En_m_tot = 0.d0 + Xn_e_tot = 0.d0 + En_e_tot = 0.d0 + nc = 0 + Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") + Write(44,*) ' No dump data ' + close(44) + endif + close(41) + close(42) + + CALL SYSTEM_CLOCK(COUNT_RATE=N_P_SEC) + CALL SYSTEM_CLOCK(COUNT=ICPU_1) + ! Start Simulations. + do Nb = 1,Nbins + do ns = 1,NSims + do ng = 1,Ngamma + Xn(ng,1) = Xn_tot(ng,1,ns) + Xn(ng,2) = Xn_tot(ng,2,ns) + enddo + Alpha = Alpha_tot(ns) + Call MC(Xtau, Xker_table, Xn, Alpha, NSweeps, Xn_m, En, En_m, & + & Acc_1, Acc_2 ) ! Just one bin + do ng = 1,Ngamma + Xn_tot(ng,1,ns) = Xn(ng,1) + Xn_tot(ng,2,ns) = Xn(ng,2) + enddo + En_tot(ns) = En ! this is the energy of the configuration Xn_tot for simulation ns + Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") + Write(44,2003) 1.d0/Alpha, En_m, Acc_1, Acc_2 + close(44) + + if (nb.gt.nwarm) then + if (ns.eq.1) nc = nc + 1 + do nd = 1,NDis + Xn_m(nd) = Xn_m(nd) * D * dble(Ndis) + Xn_m_tot(nd,ns) = Xn_m_tot(nd,ns) + Xn_m(nd) + Xn_e_tot(nd,ns) = Xn_e_tot(nd,ns) + Xn_m(nd)*Xn_m(nd) + enddo + En_m_tot(ns) = En_m_tot(ns) + En_m + En_e_tot(ns) = En_e_tot(ns) + En_m*En_m + endif + enddo + ! Exchange + Acc_1 = 0.d0 + Do Nex = 1, 2*NSims + nalp1= nint( ranf(iseed)*dble(NSims-1) + 0.5 ) ! 1..(NSims-1) + nalp2 = nalp1 + 1 + DeltaE = (Alpha_tot(nalp1)*En_tot(nalp2) + Alpha_tot(nalp2)*En_tot(nalp1))& + & -(Alpha_tot(nalp1)*En_tot(nalp1) + Alpha_tot(nalp2)*En_tot(nalp2)) + Ratio = exp(-DeltaE) + if (Ratio.gt.ranf(iseed)) Then + Acc_1 = Acc_1 + 1.0 + !Switch confs an Energies. + do ng = 1,Ngamma + Xn(ng,1) = Xn_tot(ng,1,nalp1) + Xn(ng,2) = Xn_tot(ng,2,nalp1) + enddo + do ng = 1,Ngamma + Xn_tot(ng,1,nalp1) = Xn_tot(ng,1,nalp2) + Xn_tot(ng,2,nalp1) = Xn_tot(ng,2,nalp2) + Xn_tot(ng,1,nalp2) = Xn(ng,1) + Xn_tot(ng,2,nalp2) = Xn(ng,2) + enddo + En_m = En_tot(nalp1) + En_tot(nalp1) = En_tot(nalp2) + En_tot(nalp2) = En_m + endif + enddo + Acc_1 = Acc_1/dble(Nex) + + Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") + Write(44,*) 'Acc Exchange: ', Acc_1 + close(44) + enddo + + CALL SYSTEM_CLOCK(COUNT=ICPU_2) + CPUT = 0.D0 + CPUT = DBLE(ICPU_2 - ICPU_1)/DBLE(N_P_SEC) + Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") + Write(44,*) 'Total time: ', CPUT + close(44) + ! dump so as to restart. + Open(unit=41,file=File_conf,status='unknown') + Open(unit=42,file=File_Aom, status='unknown') + write(41,*) Iseed + do ns = 1,Nsims + do ng = 1,Ngamma + write(41,*) Xn_tot(ng,1,ns), Xn_tot(ng,2,ns) + enddo + write(41,*) En_m_tot(ns), En_e_tot(ns) + enddo + write(42,*) nc + do ns = 1,Nsims + do nd = 1,Ndis + write(42,*) Xn_m_tot(nd,ns), Xn_e_tot(nd,ns) + enddo + enddo + close(41) + close(42) + ! Stop dump + + + + + Open(Unit=66,File="energies",status="unknown") + do ns = 1,Nsims + En_m_tot(ns) = En_m_tot(ns) / dble(nc) + En_e_tot(ns) = En_e_tot(ns) / dble(nc) + En_e_tot(ns) = ( En_e_tot(ns) - En_m_tot(ns)**2)/dble(nc) + if ( En_e_tot(ns) .gt. 0.d0) then + En_e_tot(ns) = sqrt(En_e_tot(ns)) + else + En_e_tot(ns) = 0.d0 + endif + write(66,*) Alpha_tot(ns), En_m_tot(ns), En_e_tot(ns) + enddo + close(66) + + File_root = "Aom" + do ns = 1,Nsims + File1 = File_i(File_root,ns) + Open(Unit=66,File=File1,status="unknown") + do nd = 1,Ndis + Xn_m_tot(nd,ns) = Xn_m_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) + Xn_e_tot(nd,ns) = Xn_e_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) + Xn_e_tot(nd,ns) = (Xn_e_tot(nd,ns) - Xn_m_tot(nd,ns)* Xn_m_tot(nd,ns))/dble(nc) + if (Xn_e_tot(nd,ns).gt.0.d0) then + Xn_e_tot(nd,ns) = sqrt(Xn_e_tot(nd,ns)) + else + Xn_e_tot(nd,ns) = 0.d0 + endif + om = PhiM1(dble(nd)/dble(NDis)) + Aom = Xn_m_tot(nd,ns) * Xmom1 + Err = Xn_e_tot(nd,ns) * Xmom1 + write(66,2001) om, Back_Trans_Aom(Aom,Beta,om), Back_Trans_Aom(Err,Beta,om) + ! PhiM1(dble(nd)/dble(NDis)), Xn_m_tot(nd,ns) + enddo + Close(66) + enddo + + ! Now do the averaging. + File_root ="Aom_ps" + do p_star = 1,NSims - 10 + Xn_m = 0.0 + Xn_e = 0.0 + do ns = p_star, NSims-1 + do nd = 1, NDis + Xn_m(nd) = Xn_m(nd) + (En_m_tot(ns) - En_m_tot(ns+1))*Xn_m_tot(nd,ns) + Xn_e(nd) = Xn_e(nd) + (En_m_tot(ns) - En_m_tot(ns+1))*Xn_e_tot(nd,ns) + enddo + enddo + do nd = 1,NDis + Xn_m(nd) = Xn_m(nd) / (En_m_tot(p_star) - En_m_tot(NSims)) + Xn_e(nd) = Xn_e(nd) / (En_m_tot(p_star) - En_m_tot(NSims)) + enddo + File1 = File_i(File_root,p_star) + Open(Unit=66,File=File1,status="unknown") + XMAX = 0.d0 + Do nd = 1,Ndis + om = PhiM1(dble(nd)/dble(NDis)) + Aom = Xn_m(nd) * Xmom1 + Err = Xn_e(nd) * Xmom1 + Xn_m(nd) = Back_Trans_Aom(Aom,Beta,om) + Xn_e(nd) = Back_Trans_Aom(Err,Beta,om) + IF (Xn_m(nd) .gt. XMAX ) XMAX = Xn_m(nd) + enddo + do nd = 1,Ndis + om = PhiM1(dble(nd)/dble(NDis)) + write(66,2005) om, Xn_m(nd), Xn_e(nd), Xn_m(nd)/XMAX, Xn_e(nd)/XMAX + ! PhiM1(dble(nd)/dble(NDis)), Xn_m(nd) + enddo + close(66) + enddo + + Open (Unit=41,File='Best_fit', Status="unknown") + do ng = 1,Ngamma + Write(41,*) Phim1(Xn_tot(ng,1,Nsims)) , Xn_tot(ng,2,Nsims) + enddo + close(41) + + DeAllocate (Xn_tot) + DeAllocate (En_m_tot, En_e_tot, En_tot ) + DeAllocate (Xn_m_tot, Xn_e_tot ) + DeAllocate (Xn) + DeAllocate (Xn_m, Xn_e) + DeAllocate( G_Mean ) + DeAllocate( xqmc1 ) + Deallocate( Xker_table ) + + +2001 format(F14.7,2x,F14.7,2x,F14.7) +2004 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7) +2005 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7,2x,F14.7) +2003 format('Alpha, En_m, Acc ', F14.7,2x,F24.12,2x,F14.7,2x,F14.7,2x,F14.7) + end Subroutine MaxEnt_stoch + + +!------------------- + Subroutine MaxEnt_stoch_fit(XQMC, Xtau, COV, Lcov, XKER, Xmom1, Beta_1, Alpha_tot,& + & Ngamma_1, OM_ST, OM_EN, Nsweeps, NBins, NWarm, Aom_res,& + & xom_res, Chisq ) + + Implicit None + Real (Kind=8), Dimension(:) :: XQMC, Xtau, Alpha_tot, Aom_res, Xom_res + Real (Kind=8), Dimension(:,:) :: COV + Real (Kind=8), external :: XKER + Real (Kind=8) :: CHISQ, OM_ST, OM_EN, Beta_1, Xmom1, Err + Integer :: Nsweeps, NBins, Ngamma_1, Ndis_1, nw, nt1, Lcov + + ! Local + Integer lp, NSims, ns, nb, nc, Nwarm, nalp1, nalp2, Nex, p_star + Real (Kind=8), Allocatable :: Xn_M_tot(:,:), En_M_tot(:), Xn_E_tot(:,:), En_E_tot(:), & + & Xn_tot(:,:,:), En_tot(:), Xker_table(:,:) + Real (Kind=8), Allocatable :: G_Mean(:), Xn_m(:), Xn_e(:), Xn(:,:), Vhelp(:) + Real (Kind=8) :: Ranf, En_M, Res, X, Alpha, Acc_1, Acc_2, En, DeltaE, Ratio, D + Real (Kind=8) :: Aom, om, XMAX, tau + Real (Kind=8), allocatable :: U(:,:), sigma(:) + + + Pi = acos(-1.d0) + Iseed = 8752143 + NDis = Size(Aom_res,1) + DeltaXMAX = 0.01 + delta = 0.001 + delta2 = delta*delta + Ngamma = Ngamma_1 + Beta = Beta_1 ! Physical temperature for calculation of the kernel. + + Ntau = Size(xqmc,1) + NSims = Size(Alpha_tot,1) + Allocate (Xn_tot(Ngamma,2,NSims)) + Allocate (En_m_tot(NSims), En_e_tot(NSims), En_tot(NSims) ) + Allocate (Xn_m_tot(NDis,NSims), Xn_e_tot(NDis,NSims) ) + + Allocate (Xn(Ngamma,2)) + Allocate (Xn_m(NDis), Xn_e(NDis) ) + + Om_st_1 = OM_st; Om_en_1 = OM_en + + ! Setup table for the Kernel + Ndis = Size(Aom_res) + Dom = (OM_EN_1 - OM_ST_1)/dble(Ndis-1) + Allocate ( Xker_table(Ntau, Ndis) ) + Dom = (OM_EN - OM_ST)/dble(Ndis-1) + do nt = 1,Ntau + do nw = 1,Ndis + tau = xtau(nt) + Om = OM_st + dble(nw-1)*dom + Xker_table(nt,nw) = Xker(tau,om,beta) + enddo + enddo + + ! Normalize data to have zeroth moment of unity. + xqmc = xqmc / XMOM1 + cov = cov / ((XMOM1)**2) + ! Diagonalize the covariance + + If (Lcov.eq.1) then + Allocate( U(ntau,ntau), Sigma(ntau), xqmc1(Ntau) ) + Call Diag(cov,U,sigma) + do nt = 1,ntau + sigma(nt) = sqrt(sigma(nt)) + enddo + xqmc1 = 0.d0 + do nt1 = 1,ntau + do nt = 1,ntau + xqmc1(nt1) = xqmc1(nt1) + xqmc(nt)*U(nt,nt1) + enddo + xqmc1(nt1) = xqmc1(nt1)/sigma(nt1) + enddo + ! Transform the Kernel + allocate ( Vhelp(Ntau) ) + do nw = 1,Ndis + Vhelp = 0.d0 + do nt1 = 1,Ntau + do nt = 1,Ntau + Vhelp(nt1) = Vhelp(nt1) + Xker_table(nt,nw)*U(nt,nt1) + enddo + enddo + do nt1 = 1,ntau + Xker_table(nt1,nw) = Vhelp(nt1)/sigma(nt1) !! This has changed !! + enddo + enddo + Deallocate (U,sigma) + else + Allocate( Sigma(ntau), xqmc1(Ntau) ) + !Call Diag(cov,U,sigma) + do nt = 1,ntau + sigma(nt) = 1.d0/sqrt(cov(nt,nt)) + enddo + xqmc1 = 0.d0 + do nt1 = 1,ntau + xqmc1(nt1) = xqmc(nt1)*sigma(nt1) + enddo + ! Transform the Kernel + allocate ( Vhelp(Ntau) ) + do nw = 1,Ndis + do nt1 = 1,ntau + Xker_table(nt1,nw) = Xker_table(nt1,nw)*sigma(nt1) !! This has changed !! + enddo + enddo + deallocate(Sigma) + endif + Allocate(G_Mean(Ntau)) + G_mean = 0.d0 + +! write(6,*) ' There are ', Ngamma,' delta-functions for a spectrum' +! Write(6,*) ' Initializing' + Do Ns = 1,NSims + do ng = 1,NGamma + Xn_tot(ng,1,ns) = ranf(iseed) + Xn_tot(ng,2,ns) = 1.d0/dble(Ngamma) + enddo + enddo + Xn_m_tot = 0.d0 + En_m_tot = 0.d0 + Xn_e_tot = 0.d0 + En_e_tot = 0.d0 + ! D(om) = 1/(Om_en_1 - Om_st_1) + D = 1.d0 / (Om_en_1 - Om_st_1) + + Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") + Write(44,*) "N E W R U N " + nc = 0 + do Nb = 1,Nbins + do ns = 1,NSims + do ng = 1,Ngamma + Xn(ng,1) = Xn_tot(ng,1,ns) + Xn(ng,2) = Xn_tot(ng,2,ns) + enddo + Alpha = Alpha_tot(ns) + Call MC(Xtau, Xker_table, Xn, Alpha, NSweeps, Xn_m, En, En_m, & + & Acc_1, Acc_2 ) ! Just one bin + do ng = 1,Ngamma + Xn_tot(ng,1,ns) = Xn(ng,1) + Xn_tot(ng,2,ns) = Xn(ng,2) + enddo + En_tot(ns) = En ! this is the energy of the configuration Xn_tot for simulation ns + Write(44,2003) 1.d0/Alpha, En_m, Acc_1, Acc_2 + if (nb.gt.nwarm) then + if (ns.eq.1) nc = nc + 1 + do nd = 1,NDis + Xn_m(nd) = Xn_m(nd) * D * dble(Ndis) + Xn_m_tot(nd,ns) = Xn_m_tot(nd,ns) + Xn_m(nd) + Xn_e_tot(nd,ns) = Xn_e_tot(nd,ns) + Xn_m(nd)*Xn_m(nd) + enddo + En_m_tot(ns) = En_m_tot(ns) + En_m + En_e_tot(ns) = En_e_tot(ns) + En_m*En_m + endif + enddo + ! Exchange + Acc_1 = 0.d0 + Do Nex = 1, 2*NSims + nalp1= nint( ranf(iseed)*dble(NSims-1) + 0.5 ) ! 1..(NSims-1) + nalp2 = nalp1 + 1 + DeltaE = (Alpha_tot(nalp1)*En_tot(nalp2) + Alpha_tot(nalp2)*En_tot(nalp1))& + & -(Alpha_tot(nalp1)*En_tot(nalp1) + Alpha_tot(nalp2)*En_tot(nalp2)) + Ratio = exp(-DeltaE) + if (Ratio.gt.ranf(iseed)) Then + Acc_1 = Acc_1 + 1.0 + !Switch confs an Energies. + do ng = 1,Ngamma + Xn(ng,1) = Xn_tot(ng,1,nalp1) + Xn(ng,2) = Xn_tot(ng,2,nalp1) + enddo + do ng = 1,Ngamma + Xn_tot(ng,1,nalp1) = Xn_tot(ng,1,nalp2) + Xn_tot(ng,2,nalp1) = Xn_tot(ng,2,nalp2) + Xn_tot(ng,1,nalp2) = Xn(ng,1) + Xn_tot(ng,2,nalp2) = Xn(ng,2) + enddo + En_m = En_tot(nalp1) + En_tot(nalp1) = En_tot(nalp2) + En_tot(nalp2) = En_m + endif + enddo + Acc_1 = Acc_1/dble(Nex) + Write(44,*) 'Acc Exchange: ', Acc_1 + enddo + + !Open(Unit=66,File="energies",status="unknown") + do ns = Nsims,Nsims + En_m_tot(ns) = En_m_tot(ns) / dble(nc) + En_e_tot(ns) = En_e_tot(ns) / dble(nc) + En_e_tot(ns) = ( En_e_tot(ns) - En_m_tot(ns)**2)/dble(nc) + if ( En_e_tot(ns) .gt. 0.d0) then + En_e_tot(ns) = sqrt(En_e_tot(ns)) + else + En_e_tot(ns) = 0.d0 + endif + !write(66,*) Alpha_tot(ns), En_m_tot(ns), En_e_tot(ns) + enddo + !close(60) + Chisq = En_e_tot(Nsims) + Close(44) + + do ns = Nsims,Nsims + do nd = 1,Ndis + Xn_m_tot(nd,ns) = Xn_m_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) + Xn_e_tot(nd,ns) = Xn_e_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) + Xn_e_tot(nd,ns) = (Xn_e_tot(nd,ns) - Xn_m_tot(nd,ns)* Xn_m_tot(nd,ns))/dble(nc) + if (Xn_e_tot(nd,ns).gt.0.d0) then + Xn_e_tot(nd,ns) = sqrt(Xn_e_tot(nd,ns)) + else + Xn_e_tot(nd,ns) = 0.d0 + endif + om = PhiM1(dble(nd)/dble(NDis)) + Aom = Xn_m_tot(nd,ns) * Xmom1 + Err = Xn_e_tot(nd,ns) * Xmom1 + !write(66,2001) om, Aom, Err + if (ns.eq.Nsims) then + Aom_res(nd) = Aom + xom_res(nd) = om + endif + enddo + !Close(66) + enddo + + ! Reset the input data + xqmc = XMOM1* xqmc + cov = ((XMOM1)**2)* cov + + + DeAllocate (Xn_tot) + DeAllocate (En_m_tot, En_e_tot, En_tot ) + DeAllocate (Xn_m_tot, Xn_e_tot ) + DeAllocate (Xn) + DeAllocate (Xn_m, Xn_e) + DeAllocate( G_Mean ) + DeAllocate( xqmc1 ) + Deallocate( Xker_table ) + +2001 format(F14.7,2x,F14.7,2x,F14.7) +2004 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7) +2005 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7,2x,F14.7) +2003 format('Alpha, En_m, Acc ', F14.7,2x,F14.7,2x,F14.7,2x,F14.7,2x,F14.7) + end Subroutine MaxEnt_stoch_fit +!*********** + Real (Kind=8) Function Phim1(x) + Implicit None + ! Flat Default with sum 1. This is the correct sum rule for the data! + ! D(om) = 1/(Om_en_1 - Om_st_1) + Real (Kind=8) :: x + PhiM1 = x*(Om_en_1 - Om_st_1) + Om_st_1 + end Function Phim1 + + + Integer Function NPhim1(x) + Implicit None + + ! Flat Default with sum 1. This is the correct sum rule for the data! + ! D(om) = 1/(Om_en_1 - Om_st_1) + + Real (Kind=8) :: x, om + om = x*(Om_en_1 - Om_st_1) + Om_st_1 + NPhiM1 = Nint ( (om - Om_st_1)/Dom + 0.75 ) + + end Function NPhim1 + + +!*********** + Subroutine Sum_Xn(Xn_m,Xn) + + Implicit none + Real (Kind=8), Dimension(:,:) :: Xn + Real (Kind=8), Dimension(:) :: Xn_m + Real (Kind=8) :: X + + + do nd = 1,NDis + X = dble( nd )/dble( NDis ) + do ng = 1,Ngamma + Xn_m(nd) = Xn_m(nd) + Xn(ng,2)/( (X-Xn(ng,1))**2 + Delta2) + !aimag( cmplx(Xn(ng,2),0.d0)/cmplx( X-Xn(ng,1), -Delta) ) + enddo + enddo + + end Subroutine Sum_Xn + +!*********** + Subroutine Sum_Xn_Boxes(Xn_m,Xn) + + Implicit none + Real (Kind=8), Dimension(:,:) :: Xn + Real (Kind=8), Dimension(:) :: Xn_m + Real (Kind=8) :: X + + + do ng = 1,Ngamma + X = Xn(ng,1) + nd = Nint(dble(NDis)*X + 0.5 ) + Xn_m(nd) = Xn_m(nd) + Xn(ng,2) + Enddo + + end Subroutine Sum_Xn_Boxes + + +!*********** + Subroutine MC(Xtau, Xker_table, Xn, Alpha, NSweeps, Xn_m, En, En_m, Acc_1,Acc_2) + + !Implicit Real (KIND=8) (A-G,O-Z) + !Implicit Integer (H-N) + Implicit None + + Real (Kind=8), Dimension(:,:) :: Xn, Xker_table + Real (Kind=8), Dimension(:) :: Xtau, Xn_m + Real (Kind=8) :: Alpha, En_m, s, ratio, ranf, A_gamma, Z_gamma, Acc_1, Acc_2 + Integer :: NSweeps, nl, Lambda_max, ng1, ng2 + + !Local + Real (Kind=8), Allocatable :: h(:), Deltah(:), A_gamma_p(:), Z_gamma_p(:), & + & A_gamma_o(:), Z_gamma_o(:) + + Real (Kind=8), Allocatable :: XKER_stor(:,:), XKER_new(:) + + Real (Kind=8) :: X, En, En1, DeltaE, XP, XM, om + Integer, Allocatable :: Lambda(:) + Integer :: nb, nsw, Nacc_1, Nacc_2, nw + + Allocate (h(ntau), Deltah(ntau) ) + Allocate (Lambda(2), Z_gamma_p(2), A_gamma_p(2), & + & Z_gamma_o(2), A_gamma_o(2) ) ! Max of moves of two walkers. + + Allocate ( XKer_stor(Ntau,Ngamma), XKer_New(Ntau) ) + + Xn_m = 0.d0 + En_m = 0.d0 + + + ! Setup h(tau) + do nt = 1,Ntau + X = 0.d0 + do ng = 1,Ngamma + A_gamma = xn(ng,1) + Z_gamma = xn(ng,2) + XKer_stor( nt, ng ) = XKER_table(nt, NPhiM1(A_gamma) ) + ! XKER(xtau(nt),PhiM1(A_gamma),beta) + X = X + Xker_stor(nt,ng)*Z_gamma + enddo + h(nt) = X - xqmc1(nt) + enddo + + + NAcc_1 = 0; NAcc_2 = 0; + do nsw = 1,Nsweeps + ! Weight sharing moves. + do ng = 1,Ngamma + x = ranf(iseed) + if (x.gt.0.5) then + ! Weight sharing moves. + Lambda_max = 2 + Lambda(1) = nint(ranf(iseed)*dble(Ngamma) + 0.5) + do + Lambda(2) = nint(ranf(iseed)*dble(Ngamma) + 0.5) + if ( Lambda(2) .ne. Lambda(1) ) exit + enddo + ng1 = Lambda(1) + ng2 = Lambda(2) + + A_gamma_o(1) = Xn(ng1,1) + A_gamma_o(2) = Xn(ng2,1) + Z_gamma_o(1) = Xn(ng1,2) + Z_gamma_o(2) = Xn(ng2,2) + + A_gamma_p(1) = Xn(ng1,1) + A_gamma_p(2) = Xn(ng2,1) + + s = (Z_gamma_o(1) + Z_gamma_o(2))*ranf(iseed) - Z_gamma_o(1) + Z_gamma_p(1) = Z_gamma_o(1) + s + Z_gamma_p(2) = Z_gamma_o(2) - s + + ! Kernel stays unchanged. + + ! Compute Delta H + do nt = 1,ntau + X = Xker_stor(nt,ng1)*( Z_gamma_p(1) - Z_gamma_o(1) ) + & + & Xker_stor(nt,ng2)*( Z_gamma_p(2) - Z_gamma_o(2) ) + Deltah(nt) = X + enddo + else + Lambda_max = 1 + Lambda(1) = nint(ranf(iseed)*dble(Ngamma) + 0.5) + ng1 = Lambda(1) + Z_gamma_o(1) = Xn(ng1,2) + Z_gamma_p(1) = Xn(ng1,2) + + A_gamma_o(1) = Xn(ng1,1) + A_gamma_p(1) = xpbc( Xn(ng1,1) + (ranf(iseed) - 0.5)*DeltaXMAX, 1.d0 ) + + !om = PhiM1(A_gamma_p(1)) + nw = NPhiM1(A_gamma_p(1)) + do nt = 1,ntau + Xker_new(nt) = Xker_table(nt,nw) ! Xker(xtau(nt),om, beta) + enddo + + do nt = 1,ntau + X = ( Xker_new(nt) - Xker_stor(nt,ng1) ) * Z_gamma_o(1) + Deltah(nt) = X + enddo + endif + + + DeltaE = 0.d0 + do nt = 1,ntau + DeltaE = DeltaE + (Deltah(nt) + 2.0 * h(nt) ) *Deltah(nt) + enddo + Ratio = exp( -alpha * DeltaE ) + ! write(6,*) ' Ratio : ',Ratio, DeltaE + if (Ratio .gt. ranf(iseed)) Then + ! write(6,*) 'Accepted' + if (Lambda_max.eq.1) then + Nacc_1 = Nacc_1 + 1 + ng1 = Lambda(1) + do nt = 1,ntau + Xker_stor(nt,ng1) = Xker_new(nt) + enddo + endif + if (Lambda_max.eq.2) Nacc_2 = Nacc_2 + 1 + do nl = 1,Lambda_max + Xn(Lambda(nl),1) = A_gamma_p(nl) + Xn(Lambda(nl),2) = Z_gamma_p(nl) + enddo + do nt = 1,ntau + h(nt) = h(nt) + Deltah(nt) + enddo + endif + enddo + En = 0.0 + do nt = 1,Ntau + En = En + h(nt)*h(nt) + enddo + En_m = En_m + En + Call Sum_Xn_Boxes( Xn_m, Xn ) + enddo + Acc_1 = dble(Nacc_1)/dble(Ngamma*NSweeps) + Acc_2 = dble(Nacc_2)/dble(Ngamma*NSweeps) + En_m = En_m/dble( nsweeps ) + Xn_m = Xn_m/dble( nsweeps ) + + + Deallocate ( h, Deltah ) + Deallocate ( Lambda, Z_gamma_p, A_gamma_p, Z_gamma_o, A_gamma_o ) + Deallocate ( XKER_stor, XKER_new ) + +2005 format(I4,2x,I4,2x,F14.7,2x,F14.7,' --> ',F14.7,2x,F14.7) +2006 format(I4,2x,F14.7, ' --> ',F14.7) + end Subroutine MC + + + +!********** + real (Kind=8) function xpbc(X,XL) + real (kind=8) :: X, XL + XPBC = X + if (X.GT. XL ) XPBC = X - XL + if (X.LT. 0.0) XPBC = X + XL + end function xpbc + + +end Module MaxEnt_stoch_mod diff --git a/src/Modules/pre1 b/src/Modules/pre1 new file mode 100644 index 000000000..38a649688 --- /dev/null +++ b/src/Modules/pre1 @@ -0,0 +1,12 @@ +PRE = cpp +PREF = -P +OBJ= maxent_stoch.f90 + +all: $(OBJ) + +.SUFFIXES: .G90 .f90 +.G90.f90: + $(PRE) $(PREF) $? $@ + +clean: + rm $(OBJ) diff --git a/src/Modules/precdef.mod.f90 b/src/Modules/precdef.mod.f90 new file mode 100644 index 000000000..9b2f2e961 --- /dev/null +++ b/src/Modules/precdef.mod.f90 @@ -0,0 +1,23 @@ +!=============================================================================== + MODULE precdef +!------------------------------------------------------------------------------- +! + IMPLICIT NONE + + INTEGER, PARAMETER :: & + byte = selected_int_kind(2), & ! -128 ... 127, 1 byte + long = selected_int_kind(9), & ! −2147483648 ... 2147483647, 4 byte + int64 = selected_int_kind(18), & ! −9223372036854775808 ... 9223372036854775807 8 byte + single = selected_real_kind(p=6,r=37), & ! kind(1.0), 4 byte + !double = selected_real_kind(p=15,r=307) ! selected_real_kind(2*precision(1.0_double)), 8 byte + double = 8 ! selected_real_kind(2*precision(1.0_double)), 8 byte + + REAL(kind=double), PARAMETER :: & + rone = 1.0D0, & + rzero = 0.0D0 + + COMPLEX(kind=double), PARAMETER :: & + cone = cmplx(rone,rzero,double), & + czero = cmplx(rzero,rzero,double) + + END MODULE precdef diff --git a/src/Modules/smooth_stoch.f90 b/src/Modules/smooth_stoch.f90 new file mode 100644 index 000000000..3207ab751 --- /dev/null +++ b/src/Modules/smooth_stoch.f90 @@ -0,0 +1,40 @@ + Program Trans + + Implicit Real (KIND=8) (A-G,O-Z) + Implicit Integer (H-N) + + parameter (Ndis=650) + Real (Kind=8) :: Xn_m(Ndis), om(Ndis), Xn_m_new(Ndis) + + open (Unit=10, File="Aom_ps_20",status="unknown") + do i = 1,Ndis + read(10,*) om(i), Xn_m(i), X, Y, Z + enddo + close(10) + + pi = acos(-1.0) + Xn_m_new = 0.d0 + Del = om(2) - om(1) + do nd = 1,Ndis + weight = Xn_m(nd) + x_0 = om(nd) + do i = 1,Ndis + x = om(i) + Xn_m_new(i) = Xn_m_new(i) + weight*del*g(10.0*del,x_0,x,pi) + enddo + enddo + + do i = 1,Ndis + write(20,*) Om(i), Xn_m_new(i) + enddo + end Program Trans + + + real (Kind=8) function g(del,a,om,pi) + + implicit none + real (Kind=8) :: del, a, om, pi + + g = exp( -((om - a)/del)**2)/(sqrt(pi)*del) + + end function g diff --git a/src/Modules/tmp.f90 b/src/Modules/tmp.f90 new file mode 100644 index 000000000..83932960a --- /dev/null +++ b/src/Modules/tmp.f90 @@ -0,0 +1,735 @@ + + + + + + +Module MaxEnt_stoch_mod + + + Use MyMats + Use Files_mod + + + Integer, private :: NTAU, nt, Ngamma, ng, Ndis, nd, Iseed + Real (Kind=8), private :: Delta, Delta2, OM_st_1, Om_en_1, DeltaXMAX, Beta, Pi, Dom + Real (Kind=8), allocatable, private :: XQMC1(:) + + ! You can still optimize a bit for by redefining the Kernel table to: + ! xker_table(nt,nw) -> xker_table(nt,nw) / sigma(nt) + ! This will save quite a lot of divisions in the + ! MC routine. And this is where all the time goes now. + + CONTAINS + + Subroutine MaxEnt_stoch(XQMC, Xtau, COV,Xmom1, XKER, Back_Trans_Aom, Beta_1, Alpha_tot,& + & Ngamma_1, OM_ST, OM_EN, Ndis_1, Nsweeps, NBins, NWarm, L_cov ) + + Implicit None + + + + + + Real (Kind=8), Dimension(:) :: XQMC, Xtau, Alpha_tot + Real (Kind=8), Dimension(:,:) :: COV + Real (Kind=8), External :: XKER, Back_trans_Aom + Real (Kind=8) :: CHISQ, OM_ST, OM_EN, Beta_1, Xmom1, Err + Integer :: Nsweeps, NBins, Ngamma_1, Ndis_1, nw, nt1 + Integer, optional :: L_cov + + ! Local + Integer lp, NSims, ns, nb, nc, Nwarm, nalp1, nalp2, Nex, p_star, Ndis_table, & + & io_error, io_error1, i + Real (Kind=8), Allocatable :: Xn_M_tot(:,:), En_M_tot(:), Xn_E_tot(:,:), En_E_tot(:), & + & Xn_tot(:,:,:), En_tot(:) + Real (Kind=8), Allocatable :: G_Mean(:), Xn_m(:), Xn_e(:), Xn(:,:), Vhelp(:) + Real (Kind=8) :: Ranf, En_M, Res, X, Alpha, Acc_1, Acc_2, En, DeltaE, Ratio, D + Real (Kind=8) :: Aom, om, XMAX, tau + Real (Kind=8) :: CPUT, CPUTM + Integer :: ICPU_1, ICPU_2, N_P_SEC + Character (64) :: File_root, File1, File_conf, File_Aom + Real (Kind=8), allocatable :: Xker_table(:,:), U(:,:), sigma(:) + Pi = acos(-1.d0) + NDis = Ndis_1 + DeltaXMAX = 0.01 + delta = 0.001 + delta2 = delta*delta + Ngamma = Ngamma_1 + Beta = Beta_1 ! Physical temperature for calculation of the kernel. + Ntau = Size(xqmc,1) + NSims = Size(Alpha_tot,1) + Allocate (Xn_tot(Ngamma,2,NSims)) + Allocate (En_m_tot(NSims), En_e_tot(NSims), En_tot(NSims) ) + Allocate (Xn_m_tot(NDis,NSims), Xn_e_tot(NDis,NSims) ) + Allocate (Xn(Ngamma,2)) + Allocate (Xn_m(NDis), Xn_e(NDis) ) + Om_st_1 = OM_st; Om_en_1 = OM_en + ! Setup table for the Kernel + Ndis_table = 50000 + Dom = (OM_EN_1 - OM_ST_1)/dble(Ndis_table-1) + Allocate ( Xker_table(Ntau, Ndis_table) ) + do nt = 1,Ntau + do nw = 1,Ndis_table + tau = xtau(nt) + Om = OM_st + dble(nw-1)*dom + Xker_table(nt,nw) = Xker(tau,om,beta) + enddo + enddo + ! Normalize data to have zeroth moment of unity. + xqmc = xqmc / XMOM1 + cov = cov / ((XMOM1)**2) + ! Diagonalize the covariance + Allocate( U(ntau,ntau), Sigma(ntau), xqmc1(Ntau) ) + If ( Present(L_cov) ) then + Call Diag(cov,U,sigma) + ! Write(6,*) " Cov Used" + else + Write(6,*) "No Cov Used" + U = 0.d0 + do nt = 1,ntau + U(nt,nt) = 1.d0 + sigma(nt) = cov(nt,nt) + enddo + endif + do nt = 1,ntau + sigma(nt) = sqrt(sigma(nt)) + enddo + xqmc1 = 0.d0 + do nt1 = 1,ntau + do nt = 1,ntau + xqmc1(nt1) = xqmc1(nt1) + xqmc(nt)*U(nt,nt1) + enddo + xqmc1(nt1) = xqmc1(nt1)/sigma(nt1) + enddo + ! Transform the Kernel + allocate ( Vhelp(Ntau) ) + do nw = 1,Ndis_table + Vhelp = 0.d0 + do nt1 = 1,Ntau + do nt = 1,Ntau + Vhelp(nt1) = Vhelp(nt1) + Xker_table(nt,nw)*U(nt,nt1) + enddo + enddo + do nt1 = 1,ntau + Xker_table(nt1,nw) = Vhelp(nt1)/sigma(nt1) !! This has changed !! + enddo + enddo + deallocate( U, Sigma ) + Allocate ( G_Mean(Ntau) ) + G_mean = 0.d0 +! write(6,*) ' There are ', Ngamma,' delta-functions for a spectrum' +! Write(6,*) ' Initializing' + ! D(om) = 1/(Om_en_1 - Om_st_1) + D = 1.d0 / (Om_en_1 - Om_st_1) + Iseed = 8752143 + File_conf = "dump_conf" + File_Aom = "dump_Aom" + Open(unit=41,file=File_conf,status='old',action='read', iostat=io_error) + Open(unit=42,file=File_Aom, status='old',action='read', iostat=io_error1) + If (io_error == 0 .and. io_error1 == 0 ) then + Nwarm = 0 + read(41,*) Iseed + do ns = 1,Nsims + do ng = 1,Ngamma + read(41,*) Xn_tot(ng,1,ns), Xn_tot(ng,2,ns) + enddo + read(41,*) En_m_tot(ns), En_e_tot(ns) + enddo + read(42,*) nc + do ns = 1,Nsims + do nd = 1,Ndis + read(42,*) Xn_m_tot(nd,ns), Xn_e_tot(nd,ns) + enddo + enddo + Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") + Write(44,*) 'Read from dump: nc = ', nc + close(44) + else + !Iseed is alrady set. + Do Ns = 1,NSims + do ng = 1,NGamma + Xn_tot(ng,1,ns) = ranf(iseed) + Xn_tot(ng,2,ns) = 1.d0/dble(Ngamma) + enddo + enddo + Xn_m_tot = 0.d0 + En_m_tot = 0.d0 + Xn_e_tot = 0.d0 + En_e_tot = 0.d0 + nc = 0 + Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") + Write(44,*) ' No dump data ' + close(44) + endif + close(41) + close(42) + CALL SYSTEM_CLOCK(COUNT_RATE=N_P_SEC) + CALL SYSTEM_CLOCK(COUNT=ICPU_1) + ! Start Simulations. + do Nb = 1,Nbins + do ns = 1,NSims + do ng = 1,Ngamma + Xn(ng,1) = Xn_tot(ng,1,ns) + Xn(ng,2) = Xn_tot(ng,2,ns) + enddo + Alpha = Alpha_tot(ns) + Call MC(Xtau, Xker_table, Xn, Alpha, NSweeps, Xn_m, En, En_m, & + & Acc_1, Acc_2 ) ! Just one bin + do ng = 1,Ngamma + Xn_tot(ng,1,ns) = Xn(ng,1) + Xn_tot(ng,2,ns) = Xn(ng,2) + enddo + En_tot(ns) = En ! this is the energy of the configuration Xn_tot for simulation ns + Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") + Write(44,2003) 1.d0/Alpha, En_m, Acc_1, Acc_2 + close(44) + if (nb.gt.nwarm) then + if (ns.eq.1) nc = nc + 1 + do nd = 1,NDis + Xn_m(nd) = Xn_m(nd) * D * dble(Ndis) + Xn_m_tot(nd,ns) = Xn_m_tot(nd,ns) + Xn_m(nd) + Xn_e_tot(nd,ns) = Xn_e_tot(nd,ns) + Xn_m(nd)*Xn_m(nd) + enddo + En_m_tot(ns) = En_m_tot(ns) + En_m + En_e_tot(ns) = En_e_tot(ns) + En_m*En_m + endif + enddo + ! Exchange + Acc_1 = 0.d0 + Do Nex = 1, 2*NSims + nalp1= nint( ranf(iseed)*dble(NSims-1) + 0.5 ) ! 1..(NSims-1) + nalp2 = nalp1 + 1 + DeltaE = (Alpha_tot(nalp1)*En_tot(nalp2) + Alpha_tot(nalp2)*En_tot(nalp1))& + & -(Alpha_tot(nalp1)*En_tot(nalp1) + Alpha_tot(nalp2)*En_tot(nalp2)) + Ratio = exp(-DeltaE) + if (Ratio.gt.ranf(iseed)) Then + Acc_1 = Acc_1 + 1.0 + !Switch confs an Energies. + do ng = 1,Ngamma + Xn(ng,1) = Xn_tot(ng,1,nalp1) + Xn(ng,2) = Xn_tot(ng,2,nalp1) + enddo + do ng = 1,Ngamma + Xn_tot(ng,1,nalp1) = Xn_tot(ng,1,nalp2) + Xn_tot(ng,2,nalp1) = Xn_tot(ng,2,nalp2) + Xn_tot(ng,1,nalp2) = Xn(ng,1) + Xn_tot(ng,2,nalp2) = Xn(ng,2) + enddo + En_m = En_tot(nalp1) + En_tot(nalp1) = En_tot(nalp2) + En_tot(nalp2) = En_m + endif + enddo + Acc_1 = Acc_1/dble(Nex) + Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") + Write(44,*) 'Acc Exchange: ', Acc_1 + close(44) + enddo + CALL SYSTEM_CLOCK(COUNT=ICPU_2) + CPUT = 0.D0 + CPUT = DBLE(ICPU_2 - ICPU_1)/DBLE(N_P_SEC) + Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") + Write(44,*) 'Total time: ', CPUT + close(44) + ! dump so as to restart. + Open(unit=41,file=File_conf,status='unknown') + Open(unit=42,file=File_Aom, status='unknown') + write(41,*) Iseed + do ns = 1,Nsims + do ng = 1,Ngamma + write(41,*) Xn_tot(ng,1,ns), Xn_tot(ng,2,ns) + enddo + write(41,*) En_m_tot(ns), En_e_tot(ns) + enddo + write(42,*) nc + do ns = 1,Nsims + do nd = 1,Ndis + write(42,*) Xn_m_tot(nd,ns), Xn_e_tot(nd,ns) + enddo + enddo + close(41) + close(42) + ! Stop dump + Open(Unit=66,File="energies",status="unknown") + do ns = 1,Nsims + En_m_tot(ns) = En_m_tot(ns) / dble(nc) + En_e_tot(ns) = En_e_tot(ns) / dble(nc) + En_e_tot(ns) = ( En_e_tot(ns) - En_m_tot(ns)**2)/dble(nc) + if ( En_e_tot(ns) .gt. 0.d0) then + En_e_tot(ns) = sqrt(En_e_tot(ns)) + else + En_e_tot(ns) = 0.d0 + endif + write(66,*) Alpha_tot(ns), En_m_tot(ns), En_e_tot(ns) + enddo + close(66) + File_root = "Aom" + do ns = 1,Nsims + File1 = File_i(File_root,ns) + Open(Unit=66,File=File1,status="unknown") + do nd = 1,Ndis + Xn_m_tot(nd,ns) = Xn_m_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) + Xn_e_tot(nd,ns) = Xn_e_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) + Xn_e_tot(nd,ns) = (Xn_e_tot(nd,ns) - Xn_m_tot(nd,ns)* Xn_m_tot(nd,ns))/dble(nc) + if (Xn_e_tot(nd,ns).gt.0.d0) then + Xn_e_tot(nd,ns) = sqrt(Xn_e_tot(nd,ns)) + else + Xn_e_tot(nd,ns) = 0.d0 + endif + om = PhiM1(dble(nd)/dble(NDis)) + Aom = Xn_m_tot(nd,ns) * Xmom1 + Err = Xn_e_tot(nd,ns) * Xmom1 + write(66,2001) om, Back_Trans_Aom(Aom,Beta,om), Back_Trans_Aom(Err,Beta,om) + ! PhiM1(dble(nd)/dble(NDis)), Xn_m_tot(nd,ns) + enddo + Close(66) + enddo + ! Now do the averaging. + File_root ="Aom_ps" + do p_star = 1,NSims - 10 + Xn_m = 0.0 + Xn_e = 0.0 + do ns = p_star, NSims-1 + do nd = 1, NDis + Xn_m(nd) = Xn_m(nd) + (En_m_tot(ns) - En_m_tot(ns+1))*Xn_m_tot(nd,ns) + Xn_e(nd) = Xn_e(nd) + (En_m_tot(ns) - En_m_tot(ns+1))*Xn_e_tot(nd,ns) + enddo + enddo + do nd = 1,NDis + Xn_m(nd) = Xn_m(nd) / (En_m_tot(p_star) - En_m_tot(NSims)) + Xn_e(nd) = Xn_e(nd) / (En_m_tot(p_star) - En_m_tot(NSims)) + enddo + File1 = File_i(File_root,p_star) + Open(Unit=66,File=File1,status="unknown") + XMAX = 0.d0 + Do nd = 1,Ndis + om = PhiM1(dble(nd)/dble(NDis)) + Aom = Xn_m(nd) * Xmom1 + Err = Xn_e(nd) * Xmom1 + Xn_m(nd) = Back_Trans_Aom(Aom,Beta,om) + Xn_e(nd) = Back_Trans_Aom(Err,Beta,om) + IF (Xn_m(nd) .gt. XMAX ) XMAX = Xn_m(nd) + enddo + do nd = 1,Ndis + om = PhiM1(dble(nd)/dble(NDis)) + write(66,2005) om, Xn_m(nd), Xn_e(nd), Xn_m(nd)/XMAX, Xn_e(nd)/XMAX + ! PhiM1(dble(nd)/dble(NDis)), Xn_m(nd) + enddo + close(66) + enddo + Open (Unit=41,File='Best_fit', Status="unknown") + do ng = 1,Ngamma + Write(41,*) Phim1(Xn_tot(ng,1,Nsims)) , Xn_tot(ng,2,Nsims) + enddo + close(41) + DeAllocate (Xn_tot) + DeAllocate (En_m_tot, En_e_tot, En_tot ) + DeAllocate (Xn_m_tot, Xn_e_tot ) + DeAllocate (Xn) + DeAllocate (Xn_m, Xn_e) + DeAllocate( G_Mean ) + DeAllocate( xqmc1 ) + Deallocate( Xker_table ) +2001 format(F14.7,2x,F14.7,2x,F14.7) +2004 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7) +2005 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7,2x,F14.7) +2003 format('Alpha, En_m, Acc ', F14.7,2x,F14.7,2x,F14.7,2x,F14.7,2x,F14.7) + end Subroutine MaxEnt_stoch +!------------------- + Subroutine MaxEnt_stoch_fit(XQMC, Xtau, COV, Lcov, XKER, Xmom1, Beta_1, Alpha_tot,& + & Ngamma_1, OM_ST, OM_EN, Nsweeps, NBins, NWarm, Aom_res,& + & xom_res, Chisq ) + Implicit None + Real (Kind=8), Dimension(:) :: XQMC, Xtau, Alpha_tot, Aom_res, Xom_res + Real (Kind=8), Dimension(:,:) :: COV + Real (Kind=8), external :: XKER + Real (Kind=8) :: CHISQ, OM_ST, OM_EN, Beta_1, Xmom1, Err + Integer :: Nsweeps, NBins, Ngamma_1, Ndis_1, nw, nt1, Lcov + ! Local + Integer lp, NSims, ns, nb, nc, Nwarm, nalp1, nalp2, Nex, p_star + Real (Kind=8), Allocatable :: Xn_M_tot(:,:), En_M_tot(:), Xn_E_tot(:,:), En_E_tot(:), & + & Xn_tot(:,:,:), En_tot(:), Xker_table(:,:) + Real (Kind=8), Allocatable :: G_Mean(:), Xn_m(:), Xn_e(:), Xn(:,:), Vhelp(:) + Real (Kind=8) :: Ranf, En_M, Res, X, Alpha, Acc_1, Acc_2, En, DeltaE, Ratio, D + Real (Kind=8) :: Aom, om, XMAX, tau + Real (Kind=8), allocatable :: U(:,:), sigma(:) + Pi = acos(-1.d0) + Iseed = 8752143 + NDis = Size(Aom_res,1) + DeltaXMAX = 0.01 + delta = 0.001 + delta2 = delta*delta + Ngamma = Ngamma_1 + Beta = Beta_1 ! Physical temperature for calculation of the kernel. + Ntau = Size(xqmc,1) + NSims = Size(Alpha_tot,1) + Allocate (Xn_tot(Ngamma,2,NSims)) + Allocate (En_m_tot(NSims), En_e_tot(NSims), En_tot(NSims) ) + Allocate (Xn_m_tot(NDis,NSims), Xn_e_tot(NDis,NSims) ) + Allocate (Xn(Ngamma,2)) + Allocate (Xn_m(NDis), Xn_e(NDis) ) + Om_st_1 = OM_st; Om_en_1 = OM_en + ! Setup table for the Kernel + Ndis = Size(Aom_res) + Dom = (OM_EN_1 - OM_ST_1)/dble(Ndis-1) + Allocate ( Xker_table(Ntau, Ndis) ) + Dom = (OM_EN - OM_ST)/dble(Ndis-1) + do nt = 1,Ntau + do nw = 1,Ndis + tau = xtau(nt) + Om = OM_st + dble(nw-1)*dom + Xker_table(nt,nw) = Xker(tau,om,beta) + enddo + enddo + ! Normalize data to have zeroth moment of unity. + xqmc = xqmc / XMOM1 + cov = cov / ((XMOM1)**2) + ! Diagonalize the covariance + If (Lcov.eq.1) then + Allocate( U(ntau,ntau), Sigma(ntau), xqmc1(Ntau) ) + Call Diag(cov,U,sigma) + do nt = 1,ntau + sigma(nt) = sqrt(sigma(nt)) + enddo + xqmc1 = 0.d0 + do nt1 = 1,ntau + do nt = 1,ntau + xqmc1(nt1) = xqmc1(nt1) + xqmc(nt)*U(nt,nt1) + enddo + xqmc1(nt1) = xqmc1(nt1)/sigma(nt1) + enddo + ! Transform the Kernel + allocate ( Vhelp(Ntau) ) + do nw = 1,Ndis + Vhelp = 0.d0 + do nt1 = 1,Ntau + do nt = 1,Ntau + Vhelp(nt1) = Vhelp(nt1) + Xker_table(nt,nw)*U(nt,nt1) + enddo + enddo + do nt1 = 1,ntau + Xker_table(nt1,nw) = Vhelp(nt1)/sigma(nt1) !! This has changed !! + enddo + enddo + Deallocate (U,sigma) + else + Allocate( Sigma(ntau), xqmc1(Ntau) ) + !Call Diag(cov,U,sigma) + do nt = 1,ntau + sigma(nt) = 1.d0/sqrt(cov(nt,nt)) + enddo + xqmc1 = 0.d0 + do nt1 = 1,ntau + xqmc1(nt1) = xqmc(nt1)*sigma(nt1) + enddo + ! Transform the Kernel + allocate ( Vhelp(Ntau) ) + do nw = 1,Ndis + do nt1 = 1,ntau + Xker_table(nt1,nw) = Xker_table(nt1,nw)*sigma(nt1) !! This has changed !! + enddo + enddo + deallocate(Sigma) + endif + Allocate(G_Mean(Ntau)) + G_mean = 0.d0 +! write(6,*) ' There are ', Ngamma,' delta-functions for a spectrum' +! Write(6,*) ' Initializing' + Do Ns = 1,NSims + do ng = 1,NGamma + Xn_tot(ng,1,ns) = ranf(iseed) + Xn_tot(ng,2,ns) = 1.d0/dble(Ngamma) + enddo + enddo + Xn_m_tot = 0.d0 + En_m_tot = 0.d0 + Xn_e_tot = 0.d0 + En_e_tot = 0.d0 + ! D(om) = 1/(Om_en_1 - Om_st_1) + D = 1.d0 / (Om_en_1 - Om_st_1) + Open (Unit=44,File='Max_stoch_log', Status="unknown", position="append") + Write(44,*) "N E W R U N " + nc = 0 + do Nb = 1,Nbins + do ns = 1,NSims + do ng = 1,Ngamma + Xn(ng,1) = Xn_tot(ng,1,ns) + Xn(ng,2) = Xn_tot(ng,2,ns) + enddo + Alpha = Alpha_tot(ns) + Call MC(Xtau, Xker_table, Xn, Alpha, NSweeps, Xn_m, En, En_m, & + & Acc_1, Acc_2 ) ! Just one bin + do ng = 1,Ngamma + Xn_tot(ng,1,ns) = Xn(ng,1) + Xn_tot(ng,2,ns) = Xn(ng,2) + enddo + En_tot(ns) = En ! this is the energy of the configuration Xn_tot for simulation ns + Write(44,2003) 1.d0/Alpha, En_m, Acc_1, Acc_2 + if (nb.gt.nwarm) then + if (ns.eq.1) nc = nc + 1 + do nd = 1,NDis + Xn_m(nd) = Xn_m(nd) * D * dble(Ndis) + Xn_m_tot(nd,ns) = Xn_m_tot(nd,ns) + Xn_m(nd) + Xn_e_tot(nd,ns) = Xn_e_tot(nd,ns) + Xn_m(nd)*Xn_m(nd) + enddo + En_m_tot(ns) = En_m_tot(ns) + En_m + En_e_tot(ns) = En_e_tot(ns) + En_m*En_m + endif + enddo + ! Exchange + Acc_1 = 0.d0 + Do Nex = 1, 2*NSims + nalp1= nint( ranf(iseed)*dble(NSims-1) + 0.5 ) ! 1..(NSims-1) + nalp2 = nalp1 + 1 + DeltaE = (Alpha_tot(nalp1)*En_tot(nalp2) + Alpha_tot(nalp2)*En_tot(nalp1))& + & -(Alpha_tot(nalp1)*En_tot(nalp1) + Alpha_tot(nalp2)*En_tot(nalp2)) + Ratio = exp(-DeltaE) + if (Ratio.gt.ranf(iseed)) Then + Acc_1 = Acc_1 + 1.0 + !Switch confs an Energies. + do ng = 1,Ngamma + Xn(ng,1) = Xn_tot(ng,1,nalp1) + Xn(ng,2) = Xn_tot(ng,2,nalp1) + enddo + do ng = 1,Ngamma + Xn_tot(ng,1,nalp1) = Xn_tot(ng,1,nalp2) + Xn_tot(ng,2,nalp1) = Xn_tot(ng,2,nalp2) + Xn_tot(ng,1,nalp2) = Xn(ng,1) + Xn_tot(ng,2,nalp2) = Xn(ng,2) + enddo + En_m = En_tot(nalp1) + En_tot(nalp1) = En_tot(nalp2) + En_tot(nalp2) = En_m + endif + enddo + Acc_1 = Acc_1/dble(Nex) + Write(44,*) 'Acc Exchange: ', Acc_1 + enddo + !Open(Unit=66,File="energies",status="unknown") + do ns = Nsims,Nsims + En_m_tot(ns) = En_m_tot(ns) / dble(nc) + En_e_tot(ns) = En_e_tot(ns) / dble(nc) + En_e_tot(ns) = ( En_e_tot(ns) - En_m_tot(ns)**2)/dble(nc) + if ( En_e_tot(ns) .gt. 0.d0) then + En_e_tot(ns) = sqrt(En_e_tot(ns)) + else + En_e_tot(ns) = 0.d0 + endif + !write(66,*) Alpha_tot(ns), En_m_tot(ns), En_e_tot(ns) + enddo + !close(60) + Chisq = En_e_tot(Nsims) + Close(44) + do ns = Nsims,Nsims + do nd = 1,Ndis + Xn_m_tot(nd,ns) = Xn_m_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) + Xn_e_tot(nd,ns) = Xn_e_tot(nd,ns) / dble(nc) ! * delta /(dble(nc)*pi) + Xn_e_tot(nd,ns) = (Xn_e_tot(nd,ns) - Xn_m_tot(nd,ns)* Xn_m_tot(nd,ns))/dble(nc) + if (Xn_e_tot(nd,ns).gt.0.d0) then + Xn_e_tot(nd,ns) = sqrt(Xn_e_tot(nd,ns)) + else + Xn_e_tot(nd,ns) = 0.d0 + endif + om = PhiM1(dble(nd)/dble(NDis)) + Aom = Xn_m_tot(nd,ns) * Xmom1 + Err = Xn_e_tot(nd,ns) * Xmom1 + !write(66,2001) om, Aom, Err + if (ns.eq.Nsims) then + Aom_res(nd) = Aom + xom_res(nd) = om + endif + enddo + !Close(66) + enddo + ! Reset the input data + xqmc = XMOM1* xqmc + cov = ((XMOM1)**2)* cov + DeAllocate (Xn_tot) + DeAllocate (En_m_tot, En_e_tot, En_tot ) + DeAllocate (Xn_m_tot, Xn_e_tot ) + DeAllocate (Xn) + DeAllocate (Xn_m, Xn_e) + DeAllocate( G_Mean ) + DeAllocate( xqmc1 ) + Deallocate( Xker_table ) +2001 format(F14.7,2x,F14.7,2x,F14.7) +2004 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7) +2005 format(F14.7,2x,F14.7,2x,F14.7,2x,F14.7,2x,F14.7) +2003 format('Alpha, En_m, Acc ', F14.7,2x,F14.7,2x,F14.7,2x,F14.7,2x,F14.7) + end Subroutine MaxEnt_stoch_fit +!*********** + Real (Kind=8) Function Phim1(x) + Implicit None + ! Flat Default with sum 1. This is the correct sum rule for the data! + ! D(om) = 1/(Om_en_1 - Om_st_1) + Real (Kind=8) :: x + PhiM1 = x*(Om_en_1 - Om_st_1) + Om_st_1 + end Function Phim1 + Integer Function NPhim1(x) + Implicit None + ! Flat Default with sum 1. This is the correct sum rule for the data! + ! D(om) = 1/(Om_en_1 - Om_st_1) + Real (Kind=8) :: x, om + om = x*(Om_en_1 - Om_st_1) + Om_st_1 + NPhiM1 = Nint ( (om - Om_st_1)/Dom + 0.75 ) + end Function NPhim1 +!*********** + Subroutine Sum_Xn(Xn_m,Xn) + Implicit none + Real (Kind=8), Dimension(:,:) :: Xn + Real (Kind=8), Dimension(:) :: Xn_m + Real (Kind=8) :: X + do nd = 1,NDis + X = dble( nd )/dble( NDis ) + do ng = 1,Ngamma + Xn_m(nd) = Xn_m(nd) + Xn(ng,2)/( (X-Xn(ng,1))**2 + Delta2) + !aimag( cmplx(Xn(ng,2),0.d0)/cmplx( X-Xn(ng,1), -Delta) ) + enddo + enddo + end Subroutine Sum_Xn +!*********** + Subroutine Sum_Xn_Boxes(Xn_m,Xn) + Implicit none + Real (Kind=8), Dimension(:,:) :: Xn + Real (Kind=8), Dimension(:) :: Xn_m + Real (Kind=8) :: X + do ng = 1,Ngamma + X = Xn(ng,1) + nd = Nint(dble(NDis)*X + 0.5 ) + Xn_m(nd) = Xn_m(nd) + Xn(ng,2) + Enddo + end Subroutine Sum_Xn_Boxes +!*********** + Subroutine MC(Xtau, Xker_table, Xn, Alpha, NSweeps, Xn_m, En, En_m, Acc_1,Acc_2) + !Implicit Real (KIND=8) (A-G,O-Z) + !Implicit Integer (H-N) + Implicit None + Real (Kind=8), Dimension(:,:) :: Xn, Xker_table + Real (Kind=8), Dimension(:) :: Xtau, Xn_m + Real (Kind=8) :: Alpha, En_m, s, ratio, ranf, A_gamma, Z_gamma, Acc_1, Acc_2 + Integer :: NSweeps, nl, Lambda_max, ng1, ng2 + !Local + Real (Kind=8), Allocatable :: h(:), Deltah(:), A_gamma_p(:), Z_gamma_p(:), & + & A_gamma_o(:), Z_gamma_o(:) + Real (Kind=8), Allocatable :: XKER_stor(:,:), XKER_new(:) + Real (Kind=8) :: X, En, En1, DeltaE, XP, XM, om + Integer, Allocatable :: Lambda(:) + Integer :: nb, nsw, Nacc_1, Nacc_2, nw + Allocate (h(ntau), Deltah(ntau) ) + Allocate (Lambda(2), Z_gamma_p(2), A_gamma_p(2), & + & Z_gamma_o(2), A_gamma_o(2) ) ! Max of moves of two walkers. + Allocate ( XKer_stor(Ntau,Ngamma), XKer_New(Ntau) ) + Xn_m = 0.d0 + En_m = 0.d0 + ! Setup h(tau) + do nt = 1,Ntau + X = 0.d0 + do ng = 1,Ngamma + A_gamma = xn(ng,1) + Z_gamma = xn(ng,2) + XKer_stor( nt, ng ) = XKER_table(nt, NPhiM1(A_gamma) ) + ! XKER(xtau(nt),PhiM1(A_gamma),beta) + X = X + Xker_stor(nt,ng)*Z_gamma + enddo + h(nt) = X - xqmc1(nt) + enddo + NAcc_1 = 0; NAcc_2 = 0; + do nsw = 1,Nsweeps + ! Weight sharing moves. + do ng = 1,Ngamma + x = ranf(iseed) + if (x.gt.0.5) then + ! Weight sharing moves. + Lambda_max = 2 + Lambda(1) = nint(ranf(iseed)*dble(Ngamma) + 0.5) + do + Lambda(2) = nint(ranf(iseed)*dble(Ngamma) + 0.5) + if ( Lambda(2) .ne. Lambda(1) ) exit + enddo + ng1 = Lambda(1) + ng2 = Lambda(2) + A_gamma_o(1) = Xn(ng1,1) + A_gamma_o(2) = Xn(ng2,1) + Z_gamma_o(1) = Xn(ng1,2) + Z_gamma_o(2) = Xn(ng2,2) + A_gamma_p(1) = Xn(ng1,1) + A_gamma_p(2) = Xn(ng2,1) + s = (Z_gamma_o(1) + Z_gamma_o(2))*ranf(iseed) - Z_gamma_o(1) + Z_gamma_p(1) = Z_gamma_o(1) + s + Z_gamma_p(2) = Z_gamma_o(2) - s + ! Kernel stays unchanged. + ! Compute Delta H + do nt = 1,ntau + X = Xker_stor(nt,ng1)*( Z_gamma_p(1) - Z_gamma_o(1) ) + & + & Xker_stor(nt,ng2)*( Z_gamma_p(2) - Z_gamma_o(2) ) + Deltah(nt) = X + enddo + else + Lambda_max = 1 + Lambda(1) = nint(ranf(iseed)*dble(Ngamma) + 0.5) + ng1 = Lambda(1) + Z_gamma_o(1) = Xn(ng1,2) + Z_gamma_p(1) = Xn(ng1,2) + A_gamma_o(1) = Xn(ng1,1) + A_gamma_p(1) = xpbc( Xn(ng1,1) + (ranf(iseed) - 0.5)*DeltaXMAX, 1.d0 ) + !om = PhiM1(A_gamma_p(1)) + nw = NPhiM1(A_gamma_p(1)) + do nt = 1,ntau + Xker_new(nt) = Xker_table(nt,nw) ! Xker(xtau(nt),om, beta) + enddo + do nt = 1,ntau + X = ( Xker_new(nt) - Xker_stor(nt,ng1) ) * Z_gamma_o(1) + Deltah(nt) = X + enddo + endif + DeltaE = 0.d0 + do nt = 1,ntau + DeltaE = DeltaE + (Deltah(nt) + 2.0 * h(nt) ) *Deltah(nt) + enddo + Ratio = exp( -alpha * DeltaE ) + ! write(6,*) ' Ratio : ',Ratio, DeltaE + if (Ratio .gt. ranf(iseed)) Then + ! write(6,*) 'Accepted' + if (Lambda_max.eq.1) then + Nacc_1 = Nacc_1 + 1 + ng1 = Lambda(1) + do nt = 1,ntau + Xker_stor(nt,ng1) = Xker_new(nt) + enddo + endif + if (Lambda_max.eq.2) Nacc_2 = Nacc_2 + 1 + do nl = 1,Lambda_max + Xn(Lambda(nl),1) = A_gamma_p(nl) + Xn(Lambda(nl),2) = Z_gamma_p(nl) + enddo + do nt = 1,ntau + h(nt) = h(nt) + Deltah(nt) + enddo + endif + enddo + En = 0.0 + do nt = 1,Ntau + En = En + h(nt)*h(nt) + enddo + En_m = En_m + En + Call Sum_Xn_Boxes( Xn_m, Xn ) + enddo + Acc_1 = dble(Nacc_1)/dble(Ngamma*NSweeps) + Acc_2 = dble(Nacc_2)/dble(Ngamma*NSweeps) + En_m = En_m/dble( nsweeps ) + Xn_m = Xn_m/dble( nsweeps ) + Deallocate ( h, Deltah ) + Deallocate ( Lambda, Z_gamma_p, A_gamma_p, Z_gamma_o, A_gamma_o ) + Deallocate ( XKER_stor, XKER_new ) +2005 format(I4,2x,I4,2x,F14.7,2x,F14.7,' --> ',F14.7,2x,F14.7) +2006 format(I4,2x,F14.7, ' --> ',F14.7) + end Subroutine MC +!********** + real (Kind=8) function xpbc(X,XL) + real (kind=8) :: X, XL + XPBC = X + if (X.GT. XL ) XPBC = X - XL + if (X.LT. 0.0) XPBC = X + XL + end function xpbc +end Module MaxEnt_stoch_mod diff --git a/src/MyEis/CMakeLists.txt b/src/MyEis/CMakeLists.txt new file mode 100644 index 000000000..1c25eeaee --- /dev/null +++ b/src/MyEis/CMakeLists.txt @@ -0,0 +1,8 @@ +# Eispack library +SET(EIS_src ${SRCEIS}/balanc.f ${SRCEIS}/balbak.f ${SRCEIS}/cbabk2.f ${SRCEIS}/cbal.f ${SRCEIS}/cdiv.f ${SRCEIS}/cg.f ${SRCEIS}/ch.f +${SRCEIS}/comqr.f ${SRCEIS}/comqr2.f ${SRCEIS}/corth.f ${SRCEIS}/csroot.f ${SRCEIS}/elmhes.f ${SRCEIS}/eltran.f ${SRCEIS}/epslon.f ${SRCEIS}/hqr.f + ${SRCEIS}/hqr2.f ${SRCEIS}/htribk.f ${SRCEIS}/htridi.f ${SRCEIS}/pythag.f ${SRCEIS}/rg.f ${SRCEIS}/rs.f ${SRCEIS}/tql2.f + ${SRCEIS}/tqlrat.f ${SRCEIS}/tred1.f ${SRCEIS}/tred2.f) + + +ADD_LIBRARY(${MYEIS} STATIC ${EIS_src}) diff --git a/src/MyEis/Makefile b/src/MyEis/Makefile new file mode 100644 index 000000000..90addb657 --- /dev/null +++ b/src/MyEis/Makefile @@ -0,0 +1,11 @@ +LIB=libeis.a +OBJS=balanc.o cdiv.o comqr2.o eltran.o htribk.o rs.o\ +tred2.o balbak.o cg.o corth.o epslon.o htridi.o tql2.o\ +cbabk2.o ch.o csroot.o hqr.o pythag.o tqlrat.o\ +cbal.o comqr.o elmhes.o hqr2.o rg.o tred1.o +$(LIB): $(OBJS) + ar r $(LIB) $(OBJS) +.f.o: + $(FC) $(FLAGS) $< +clean: + rm $(LIB) $(OBJS) diff --git a/src/MyEis/balanc.f b/src/MyEis/balanc.f new file mode 100644 index 000000000..7addb368d --- /dev/null +++ b/src/MyEis/balanc.f @@ -0,0 +1,166 @@ + SUBROUTINE BALANC(NM,N,A,LOW,IGH,SCALE) +C + INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC + DOUBLE PRECISION A(NM,N),SCALE(N) + DOUBLE PRECISION C,F,G,R,S,B2,RADIX + LOGICAL NOCONV +C +C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BALANCE, +C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. +C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). +C +C THIS SUBROUTINE BALANCES A REAL MATRIX AND ISOLATES +C EIGENVALUES WHENEVER POSSIBLE. +C +C ON INPUT +C +C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL +C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM +C DIMENSION STATEMENT. +C +C N IS THE ORDER OF THE MATRIX. +C +C A CONTAINS THE INPUT MATRIX TO BE BALANCED. +C +C ON OUTPUT +C +C A CONTAINS THE BALANCED MATRIX. +C +C LOW AND IGH ARE TWO INTEGERS SUCH THAT A(I,J) +C IS EQUAL TO ZERO IF +C (1) I IS GREATER THAN J AND +C (2) J=1,...,LOW-1 OR I=IGH+1,...,N. +C +C SCALE CONTAINS INFORMATION DETERMINING THE +C PERMUTATIONS AND SCALING FACTORS USED. +C +C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH +C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED +C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS +C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN +C SCALE(J) = P(J), FOR J = 1,...,LOW-1 +C = D(J,J), J = LOW,...,IGH +C = P(J) J = IGH+1,...,N. +C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1, +C THEN 1 TO LOW-1. +C +C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY. +C +C THE ALGOL PROCEDURE EXC CONTAINED IN BALANCE APPEARS IN +C BALANC IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS +C K,L HAVE BEEN REVERSED.) +C +C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, +C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY +C +C THIS VERSION DATED AUGUST 1983. +C +C ------------------------------------------------------------------ +C + RADIX = 16.0D0 +C + B2 = RADIX * RADIX + K = 1 + L = N + GO TO 100 +C .......... IN-LINE PROCEDURE FOR ROW AND +C COLUMN EXCHANGE .......... + 20 SCALE(M) = J + IF (J .EQ. M) GO TO 50 +C + DO 30 I = 1, L + F = A(I,J) + A(I,J) = A(I,M) + A(I,M) = F + 30 CONTINUE +C + DO 40 I = K, N + F = A(J,I) + A(J,I) = A(M,I) + A(M,I) = F + 40 CONTINUE +C + 50 GO TO (80,130), IEXC +C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE +C AND PUSH THEM DOWN .......... + 80 IF (L .EQ. 1) GO TO 280 + L = L - 1 +C .......... FOR J=L STEP -1 UNTIL 1 DO -- .......... + 100 DO 120 JJ = 1, L + J = L + 1 - JJ +C + DO 110 I = 1, L + IF (I .EQ. J) GO TO 110 + IF (A(J,I) .NE. 0.0D0) GO TO 120 + 110 CONTINUE +C + M = L + IEXC = 1 + GO TO 20 + 120 CONTINUE +C + GO TO 140 +C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE +C AND PUSH THEM LEFT .......... + 130 K = K + 1 +C + 140 DO 170 J = K, L +C + DO 150 I = K, L + IF (I .EQ. J) GO TO 150 + IF (A(I,J) .NE. 0.0D0) GO TO 170 + 150 CONTINUE +C + M = K + IEXC = 2 + GO TO 20 + 170 CONTINUE +C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L .......... + DO 180 I = K, L + 180 SCALE(I) = 1.0D0 +C .......... ITERATIVE LOOP FOR NORM REDUCTION .......... + 190 NOCONV = .FALSE. +C + DO 270 I = K, L + C = 0.0D0 + R = 0.0D0 +C + DO 200 J = K, L + IF (J .EQ. I) GO TO 200 + C = C + DABS(A(J,I)) + R = R + DABS(A(I,J)) + 200 CONTINUE +C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW .......... + IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GO TO 270 + G = R / RADIX + F = 1.0D0 + S = C + R + 210 IF (C .GE. G) GO TO 220 + F = F * RADIX + C = C * B2 + GO TO 210 + 220 G = R * RADIX + 230 IF (C .LT. G) GO TO 240 + F = F / RADIX + C = C / B2 + GO TO 230 +C .......... NOW BALANCE .......... + 240 IF ((C + R) / F .GE. 0.95D0 * S) GO TO 270 + G = 1.0D0 / F + SCALE(I) = SCALE(I) * F + NOCONV = .TRUE. +C + DO 250 J = K, N + 250 A(I,J) = A(I,J) * G +C + DO 260 J = 1, L + 260 A(J,I) = A(J,I) * F +C + 270 CONTINUE +C + IF (NOCONV) GO TO 190 +C + 280 LOW = K + IGH = L + RETURN + END diff --git a/src/MyEis/balbak.f b/src/MyEis/balbak.f new file mode 100644 index 000000000..c57a5c017 --- /dev/null +++ b/src/MyEis/balbak.f @@ -0,0 +1,75 @@ + SUBROUTINE BALBAK(NM,N,LOW,IGH,SCALE,M,Z) +C + INTEGER I,J,K,M,N,II,NM,IGH,LOW + DOUBLE PRECISION SCALE(N),Z(NM,M) + DOUBLE PRECISION S +C +C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BALBAK, +C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. +C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). +C +C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL GENERAL +C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING +C BALANCED MATRIX DETERMINED BY BALANC. +C +C ON INPUT +C +C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL +C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM +C DIMENSION STATEMENT. +C +C N IS THE ORDER OF THE MATRIX. +C +C LOW AND IGH ARE INTEGERS DETERMINED BY BALANC. +C +C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS +C AND SCALING FACTORS USED BY BALANC. +C +C M IS THE NUMBER OF COLUMNS OF Z TO BE BACK TRANSFORMED. +C +C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGEN- +C VECTORS TO BE BACK TRANSFORMED IN ITS FIRST M COLUMNS. +C +C ON OUTPUT +C +C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE +C TRANSFORMED EIGENVECTORS IN ITS FIRST M COLUMNS. +C +C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, +C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY +C +C THIS VERSION DATED AUGUST 1983. +C +C ------------------------------------------------------------------ +C + IF (M .EQ. 0) GO TO 200 + IF (IGH .EQ. LOW) GO TO 120 +C + DO 110 I = LOW, IGH + S = SCALE(I) +C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED +C IF THE FOREGOING STATEMENT IS REPLACED BY +C S=1.0D0/SCALE(I). .......... + DO 100 J = 1, M + 100 Z(I,J) = Z(I,J) * S +C + 110 CONTINUE +C ......... FOR I=LOW-1 STEP -1 UNTIL 1, +C IGH+1 STEP 1 UNTIL N DO -- .......... + 120 DO 140 II = 1, N + I = II + IF (I .GE. LOW .AND. I .LE. IGH) GO TO 140 + IF (I .LT. LOW) I = LOW - II + K = SCALE(I) + IF (K .EQ. I) GO TO 140 +C + DO 130 J = 1, M + S = Z(I,J) + Z(I,J) = Z(K,J) + Z(K,J) = S + 130 CONTINUE +C + 140 CONTINUE +C + 200 RETURN + END diff --git a/src/MyEis/cbabk2.f b/src/MyEis/cbabk2.f new file mode 100644 index 000000000..631e60dbe --- /dev/null +++ b/src/MyEis/cbabk2.f @@ -0,0 +1,83 @@ + SUBROUTINE CBABK2(NM,N,LOW,IGH,SCALE,M,ZR,ZI) +C + INTEGER I,J,K,M,N,II,NM,IGH,LOW + DOUBLE PRECISION SCALE(N),ZR(NM,M),ZI(NM,M) + DOUBLE PRECISION S +C +C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE +C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK, +C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. +C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). +C +C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL +C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING +C BALANCED MATRIX DETERMINED BY CBAL. +C +C ON INPUT +C +C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL +C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM +C DIMENSION STATEMENT. +C +C N IS THE ORDER OF THE MATRIX. +C +C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL. +C +C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS +C AND SCALING FACTORS USED BY CBAL. +C +C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. +C +C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, +C RESPECTIVELY, OF THE EIGENVECTORS TO BE +C BACK TRANSFORMED IN THEIR FIRST M COLUMNS. +C +C ON OUTPUT +C +C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, +C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS +C IN THEIR FIRST M COLUMNS. +C +C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, +C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY +C +C THIS VERSION DATED AUGUST 1983. +C +C ------------------------------------------------------------------ +C + IF (M .EQ. 0) GO TO 200 + IF (IGH .EQ. LOW) GO TO 120 +C + DO 110 I = LOW, IGH + S = SCALE(I) +C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED +C IF THE FOREGOING STATEMENT IS REPLACED BY +C S=1.0D0/SCALE(I). .......... + DO 100 J = 1, M + ZR(I,J) = ZR(I,J) * S + ZI(I,J) = ZI(I,J) * S + 100 CONTINUE +C + 110 CONTINUE +C .......... FOR I=LOW-1 STEP -1 UNTIL 1, +C IGH+1 STEP 1 UNTIL N DO -- .......... + 120 DO 140 II = 1, N + I = II + IF (I .GE. LOW .AND. I .LE. IGH) GO TO 140 + IF (I .LT. LOW) I = LOW - II + K = SCALE(I) + IF (K .EQ. I) GO TO 140 +C + DO 130 J = 1, M + S = ZR(I,J) + ZR(I,J) = ZR(K,J) + ZR(K,J) = S + S = ZI(I,J) + ZI(I,J) = ZI(K,J) + ZI(K,J) = S + 130 CONTINUE +C + 140 CONTINUE +C + 200 RETURN + END diff --git a/src/MyEis/cbal.f b/src/MyEis/cbal.f new file mode 100644 index 000000000..bfc297790 --- /dev/null +++ b/src/MyEis/cbal.f @@ -0,0 +1,181 @@ + SUBROUTINE CBAL(NM,N,AR,AI,LOW,IGH,SCALE) +C + INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC + DOUBLE PRECISION AR(NM,N),AI(NM,N),SCALE(N) + DOUBLE PRECISION C,F,G,R,S,B2,RADIX + LOGICAL NOCONV +C +C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE +C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE, +C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. +C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). +C +C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES +C EIGENVALUES WHENEVER POSSIBLE. +C +C ON INPUT +C +C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL +C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM +C DIMENSION STATEMENT. +C +C N IS THE ORDER OF THE MATRIX. +C +C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, +C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED. +C +C ON OUTPUT +C +C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, +C RESPECTIVELY, OF THE BALANCED MATRIX. +C +C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J) +C ARE EQUAL TO ZERO IF +C (1) I IS GREATER THAN J AND +C (2) J=1,...,LOW-1 OR I=IGH+1,...,N. +C +C SCALE CONTAINS INFORMATION DETERMINING THE +C PERMUTATIONS AND SCALING FACTORS USED. +C +C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH +C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED +C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS +C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN +C SCALE(J) = P(J), FOR J = 1,...,LOW-1 +C = D(J,J) J = LOW,...,IGH +C = P(J) J = IGH+1,...,N. +C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1, +C THEN 1 TO LOW-1. +C +C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY. +C +C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN +C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS +C K,L HAVE BEEN REVERSED.) +C +C ARITHMETIC IS REAL THROUGHOUT. +C +C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, +C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY +C +C THIS VERSION DATED AUGUST 1983. +C +C ------------------------------------------------------------------ +C + RADIX = 16.0D0 +C + B2 = RADIX * RADIX + K = 1 + L = N + GO TO 100 +C .......... IN-LINE PROCEDURE FOR ROW AND +C COLUMN EXCHANGE .......... + 20 SCALE(M) = J + IF (J .EQ. M) GO TO 50 +C + DO 30 I = 1, L + F = AR(I,J) + AR(I,J) = AR(I,M) + AR(I,M) = F + F = AI(I,J) + AI(I,J) = AI(I,M) + AI(I,M) = F + 30 CONTINUE +C + DO 40 I = K, N + F = AR(J,I) + AR(J,I) = AR(M,I) + AR(M,I) = F + F = AI(J,I) + AI(J,I) = AI(M,I) + AI(M,I) = F + 40 CONTINUE +C + 50 GO TO (80,130), IEXC +C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE +C AND PUSH THEM DOWN .......... + 80 IF (L .EQ. 1) GO TO 280 + L = L - 1 +C .......... FOR J=L STEP -1 UNTIL 1 DO -- .......... + 100 DO 120 JJ = 1, L + J = L + 1 - JJ +C + DO 110 I = 1, L + IF (I .EQ. J) GO TO 110 + IF (AR(J,I) .NE. 0.0D0 .OR. AI(J,I) .NE. 0.0D0) GO TO 120 + 110 CONTINUE +C + M = L + IEXC = 1 + GO TO 20 + 120 CONTINUE +C + GO TO 140 +C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE +C AND PUSH THEM LEFT .......... + 130 K = K + 1 +C + 140 DO 170 J = K, L +C + DO 150 I = K, L + IF (I .EQ. J) GO TO 150 + IF (AR(I,J) .NE. 0.0D0 .OR. AI(I,J) .NE. 0.0D0) GO TO 170 + 150 CONTINUE +C + M = K + IEXC = 2 + GO TO 20 + 170 CONTINUE +C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L .......... + DO 180 I = K, L + 180 SCALE(I) = 1.0D0 +C .......... ITERATIVE LOOP FOR NORM REDUCTION .......... + 190 NOCONV = .FALSE. +C + DO 270 I = K, L + C = 0.0D0 + R = 0.0D0 +C + DO 200 J = K, L + IF (J .EQ. I) GO TO 200 + C = C + DABS(AR(J,I)) + DABS(AI(J,I)) + R = R + DABS(AR(I,J)) + DABS(AI(I,J)) + 200 CONTINUE +C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW .......... + IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GO TO 270 + G = R / RADIX + F = 1.0D0 + S = C + R + 210 IF (C .GE. G) GO TO 220 + F = F * RADIX + C = C * B2 + GO TO 210 + 220 G = R * RADIX + 230 IF (C .LT. G) GO TO 240 + F = F / RADIX + C = C / B2 + GO TO 230 +C .......... NOW BALANCE .......... + 240 IF ((C + R) / F .GE. 0.95D0 * S) GO TO 270 + G = 1.0D0 / F + SCALE(I) = SCALE(I) * F + NOCONV = .TRUE. +C + DO 250 J = K, N + AR(I,J) = AR(I,J) * G + AI(I,J) = AI(I,J) * G + 250 CONTINUE +C + DO 260 J = 1, L + AR(J,I) = AR(J,I) * F + AI(J,I) = AI(J,I) * F + 260 CONTINUE +C + 270 CONTINUE +C + IF (NOCONV) GO TO 190 +C + 280 LOW = K + IGH = L + RETURN + END diff --git a/src/MyEis/cdiv.f b/src/MyEis/cdiv.f new file mode 100644 index 000000000..fdca82c97 --- /dev/null +++ b/src/MyEis/cdiv.f @@ -0,0 +1,16 @@ + SUBROUTINE CDIV(AR,AI,BR,BI,CR,CI) + DOUBLE PRECISION AR,AI,BR,BI,CR,CI +C +C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI) +C + DOUBLE PRECISION S,ARS,AIS,BRS,BIS + S = DABS(BR) + DABS(BI) + ARS = AR/S + AIS = AI/S + BRS = BR/S + BIS = BI/S + S = BRS**2 + BIS**2 + CR = (ARS*BRS + AIS*BIS)/S + CI = (AIS*BRS - ARS*BIS)/S + RETURN + END diff --git a/src/MyEis/cg.f b/src/MyEis/cg.f new file mode 100644 index 000000000..6b488a81e --- /dev/null +++ b/src/MyEis/cg.f @@ -0,0 +1,63 @@ + SUBROUTINE CG(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR) +C + INTEGER N,NM,IS1,IS2,IERR,MATZ + DOUBLE PRECISION AR(NM,N),AI(NM,N),WR(N),WI(N),ZR(NM,N),ZI(NM,N), + X FV1(N),FV2(N),FV3(N) +C +C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF +C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) +C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) +C OF A COMPLEX GENERAL MATRIX. +C +C ON INPUT +C +C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL +C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM +C DIMENSION STATEMENT. +C +C N IS THE ORDER OF THE MATRIX A=(AR,AI). +C +C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, +C RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX. +C +C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF +C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO +C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. +C +C ON OUTPUT +C +C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, +C RESPECTIVELY, OF THE EIGENVALUES. +C +C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, +C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO. +C +C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR +C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR +C AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO. +C +C FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS. +C +C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, +C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY +C +C THIS VERSION DATED AUGUST 1983. +C +C ------------------------------------------------------------------ +C + IF (N .LE. NM) GO TO 10 + IERR = 10 * N + GO TO 50 +C + 10 CALL CBAL(NM,N,AR,AI,IS1,IS2,FV1) + CALL CORTH(NM,N,IS1,IS2,AR,AI,FV2,FV3) + IF (MATZ .NE. 0) GO TO 20 +C .......... FIND EIGENVALUES ONLY .......... + CALL COMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR) + GO TO 50 +C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... + 20 CALL COMQR2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR) + IF (IERR .NE. 0) GO TO 50 + CALL CBABK2(NM,N,IS1,IS2,FV1,N,ZR,ZI) + 50 RETURN + END diff --git a/src/MyEis/ch.f b/src/MyEis/ch.f new file mode 100644 index 000000000..302faae4d --- /dev/null +++ b/src/MyEis/ch.f @@ -0,0 +1,70 @@ + SUBROUTINE CH(NM,N,AR,AI,W,MATZ,ZR,ZI,FV1,FV2,FM1,IERR) +C + INTEGER I,J,N,NM,IERR,MATZ + DOUBLE PRECISION AR(NM,N),AI(NM,N),W(N),ZR(NM,N),ZI(NM,N), + X FV1(N),FV2(N),FM1(2,N) +C +C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF +C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) +C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) +C OF A COMPLEX HERMITIAN MATRIX. +C +C ON INPUT +C +C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL +C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM +C DIMENSION STATEMENT. +C +C N IS THE ORDER OF THE MATRIX A=(AR,AI). +C +C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, +C RESPECTIVELY, OF THE COMPLEX HERMITIAN MATRIX. +C +C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF +C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO +C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. +C +C ON OUTPUT +C +C W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. +C +C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, +C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO. +C +C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR +C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT +C AND TQL2. THE NORMAL COMPLETION CODE IS ZERO. +C +C FV1, FV2, AND FM1 ARE TEMPORARY STORAGE ARRAYS. +C +C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, +C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY +C +C THIS VERSION DATED AUGUST 1983. +C +C ------------------------------------------------------------------ +C + IF (N .LE. NM) GO TO 10 + IERR = 10 * N + GO TO 50 +C + 10 CALL HTRIDI(NM,N,AR,AI,W,FV1,FV2,FM1) + IF (MATZ .NE. 0) GO TO 20 +C .......... FIND EIGENVALUES ONLY .......... + CALL TQLRAT(N,W,FV2,IERR) + GO TO 50 +C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... + 20 DO 40 I = 1, N +C + DO 30 J = 1, N + ZR(J,I) = 0.0D0 + 30 CONTINUE +C + ZR(I,I) = 1.0D0 + 40 CONTINUE +C + CALL TQL2(NM,N,W,FV1,ZR,IERR) + IF (IERR .NE. 0) GO TO 50 + CALL HTRIBK(NM,N,AR,AI,FM1,N,ZR,ZI) + 50 RETURN + END diff --git a/src/MyEis/comp b/src/MyEis/comp new file mode 100644 index 000000000..189980942 --- /dev/null +++ b/src/MyEis/comp @@ -0,0 +1 @@ +if77 -c -O4 -Mvect -nx *.f diff --git a/src/MyEis/comqr.f b/src/MyEis/comqr.f new file mode 100644 index 000000000..173afc342 --- /dev/null +++ b/src/MyEis/comqr.f @@ -0,0 +1,222 @@ + SUBROUTINE COMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR) +C + INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR + DOUBLE PRECISION HR(NM,N),HI(NM,N),WR(N),WI(N) + DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2, + X PYTHAG +C +C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE +C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN +C AND WILKINSON. +C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971). +C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS +C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM. +C +C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX +C UPPER HESSENBERG MATRIX BY THE QR METHOD. +C +C ON INPUT +C +C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL +C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM +C DIMENSION STATEMENT. +C +C N IS THE ORDER OF THE MATRIX. +C +C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING +C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, +C SET LOW=1, IGH=N. +C +C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS, +C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX. +C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN +C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN +C THE REDUCTION BY CORTH, IF PERFORMED. +C +C ON OUTPUT +C +C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN +C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE +C CALLING COMQR IF SUBSEQUENT CALCULATION OF +C EIGENVECTORS IS TO BE PERFORMED. +C +C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, +C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR +C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT +C FOR INDICES IERR+1,...,N. +C +C IERR IS SET TO +C ZERO FOR NORMAL RETURN, +C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED +C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. +C +C CALLS CDIV FOR COMPLEX DIVISION. +C CALLS CSROOT FOR COMPLEX SQUARE ROOT. +C CALLS PYTHAG FOR DSQRT(A*A + B*B) . +C +C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, +C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY +C +C THIS VERSION DATED AUGUST 1983. +C +C ------------------------------------------------------------------ +C + IERR = 0 + IF (LOW .EQ. IGH) GO TO 180 +C .......... CREATE REAL SUBDIAGONAL ELEMENTS .......... + L = LOW + 1 +C + DO 170 I = L, IGH + LL = MIN0(I+1,IGH) + IF (HI(I,I-1) .EQ. 0.0D0) GO TO 170 + NORM = PYTHAG(HR(I,I-1),HI(I,I-1)) + YR = HR(I,I-1) / NORM + YI = HI(I,I-1) / NORM + HR(I,I-1) = NORM + HI(I,I-1) = 0.0D0 +C + DO 155 J = I, IGH + SI = YR * HI(I,J) - YI * HR(I,J) + HR(I,J) = YR * HR(I,J) + YI * HI(I,J) + HI(I,J) = SI + 155 CONTINUE +C + DO 160 J = LOW, LL + SI = YR * HI(J,I) + YI * HR(J,I) + HR(J,I) = YR * HR(J,I) - YI * HI(J,I) + HI(J,I) = SI + 160 CONTINUE +C + 170 CONTINUE +C .......... STORE ROOTS ISOLATED BY CBAL .......... + 180 DO 200 I = 1, N + IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200 + WR(I) = HR(I,I) + WI(I) = HI(I,I) + 200 CONTINUE +C + EN = IGH + TR = 0.0D0 + TI = 0.0D0 + ITN = 30*N +C .......... SEARCH FOR NEXT EIGENVALUE .......... + 220 IF (EN .LT. LOW) GO TO 1001 + ITS = 0 + ENM1 = EN - 1 +C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT +C FOR L=EN STEP -1 UNTIL LOW D0 -- .......... + 240 DO 260 LL = LOW, EN + L = EN + LOW - LL + IF (L .EQ. LOW) GO TO 300 + TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1)) + X + DABS(HR(L,L)) + DABS(HI(L,L)) + TST2 = TST1 + DABS(HR(L,L-1)) + IF (TST2 .EQ. TST1) GO TO 300 + 260 CONTINUE +C .......... FORM SHIFT .......... + 300 IF (L .EQ. EN) GO TO 660 + IF (ITN .EQ. 0) GO TO 1000 + IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320 + SR = HR(EN,EN) + SI = HI(EN,EN) + XR = HR(ENM1,EN) * HR(EN,ENM1) + XI = HI(ENM1,EN) * HR(EN,ENM1) + IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GO TO 340 + YR = (HR(ENM1,ENM1) - SR) / 2.0D0 + YI = (HI(ENM1,ENM1) - SI) / 2.0D0 + CALL CSROOT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI) + IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GO TO 310 + ZZR = -ZZR + ZZI = -ZZI + 310 CALL CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI) + SR = SR - XR + SI = SI - XI + GO TO 340 +C .......... FORM EXCEPTIONAL SHIFT .......... + 320 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2)) + SI = 0.0D0 +C + 340 DO 360 I = LOW, EN + HR(I,I) = HR(I,I) - SR + HI(I,I) = HI(I,I) - SI + 360 CONTINUE +C + TR = TR + SR + TI = TI + SI + ITS = ITS + 1 + ITN = ITN - 1 +C .......... REDUCE TO TRIANGLE (ROWS) .......... + LP1 = L + 1 +C + DO 500 I = LP1, EN + SR = HR(I,I-1) + HR(I,I-1) = 0.0D0 + NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR) + XR = HR(I-1,I-1) / NORM + WR(I-1) = XR + XI = HI(I-1,I-1) / NORM + WI(I-1) = XI + HR(I-1,I-1) = NORM + HI(I-1,I-1) = 0.0D0 + HI(I,I-1) = SR / NORM +C + DO 490 J = I, EN + YR = HR(I-1,J) + YI = HI(I-1,J) + ZZR = HR(I,J) + ZZI = HI(I,J) + HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR + HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI + HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR + HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI + 490 CONTINUE +C + 500 CONTINUE +C + SI = HI(EN,EN) + IF (SI .EQ. 0.0D0) GO TO 540 + NORM = PYTHAG(HR(EN,EN),SI) + SR = HR(EN,EN) / NORM + SI = SI / NORM + HR(EN,EN) = NORM + HI(EN,EN) = 0.0D0 +C .......... INVERSE OPERATION (COLUMNS) .......... + 540 DO 600 J = LP1, EN + XR = WR(J-1) + XI = WI(J-1) +C + DO 580 I = L, J + YR = HR(I,J-1) + YI = 0.0D0 + ZZR = HR(I,J) + ZZI = HI(I,J) + IF (I .EQ. J) GO TO 560 + YI = HI(I,J-1) + HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI + 560 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR + HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR + HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI + 580 CONTINUE +C + 600 CONTINUE +C + IF (SI .EQ. 0.0D0) GO TO 240 +C + DO 630 I = L, EN + YR = HR(I,EN) + YI = HI(I,EN) + HR(I,EN) = SR * YR - SI * YI + HI(I,EN) = SR * YI + SI * YR + 630 CONTINUE +C + GO TO 240 +C .......... A ROOT FOUND .......... + 660 WR(EN) = HR(EN,EN) + TR + WI(EN) = HI(EN,EN) + TI + EN = ENM1 + GO TO 220 +C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT +C CONVERGED AFTER 30*N ITERATIONS .......... + 1000 IERR = EN + 1001 RETURN + END diff --git a/src/MyEis/comqr2.f b/src/MyEis/comqr2.f new file mode 100644 index 000000000..919ce50c3 --- /dev/null +++ b/src/MyEis/comqr2.f @@ -0,0 +1,409 @@ + SUBROUTINE COMQR2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR) +C + INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1, + X ITN,ITS,LOW,LP1,ENM1,IEND,IERR + DOUBLE PRECISION HR(NM,N),HI(NM,N),WR(N),WI(N),ZR(NM,N),ZI(NM,N), + X ORTR(IGH),ORTI(IGH) + DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2, + X PYTHAG +C +C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE +C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS +C AND WILKINSON. +C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). +C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS +C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM. +C +C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS +C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR +C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX +C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE +C THIS GENERAL MATRIX TO HESSENBERG FORM. +C +C ON INPUT +C +C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL +C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM +C DIMENSION STATEMENT. +C +C N IS THE ORDER OF THE MATRIX. +C +C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING +C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, +C SET LOW=1, IGH=N. +C +C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS- +C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED. +C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS +C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND +C ORTI(J) TO 0.0D0 FOR THESE ELEMENTS. +C +C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS, +C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX. +C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER +C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE +C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF +C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE +C ARBITRARY. +C +C ON OUTPUT +C +C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI +C HAVE BEEN DESTROYED. +C +C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, +C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR +C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT +C FOR INDICES IERR+1,...,N. +C +C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, +C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS +C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF +C THE EIGENVECTORS HAS BEEN FOUND. +C +C IERR IS SET TO +C ZERO FOR NORMAL RETURN, +C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED +C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. +C +C CALLS CDIV FOR COMPLEX DIVISION. +C CALLS CSROOT FOR COMPLEX SQUARE ROOT. +C CALLS PYTHAG FOR DSQRT(A*A + B*B) . +C +C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, +C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY +C +C THIS VERSION DATED AUGUST 1983. +C +C ------------------------------------------------------------------ +C + IERR = 0 +C .......... INITIALIZE EIGENVECTOR MATRIX .......... + DO 101 J = 1, N +C + DO 100 I = 1, N + ZR(I,J) = 0.0D0 + ZI(I,J) = 0.0D0 + 100 CONTINUE + ZR(J,J) = 1.0D0 + 101 CONTINUE +C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS +C FROM THE INFORMATION LEFT BY CORTH .......... + IEND = IGH - LOW - 1 + IF (IEND) 180, 150, 105 +C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... + 105 DO 140 II = 1, IEND + I = IGH - II + IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GO TO 140 + IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GO TO 140 +C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH .......... + NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I) + IP1 = I + 1 +C + DO 110 K = IP1, IGH + ORTR(K) = HR(K,I-1) + ORTI(K) = HI(K,I-1) + 110 CONTINUE +C + DO 130 J = I, IGH + SR = 0.0D0 + SI = 0.0D0 +C + DO 115 K = I, IGH + SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J) + SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J) + 115 CONTINUE +C + SR = SR / NORM + SI = SI / NORM +C + DO 120 K = I, IGH + ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K) + ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K) + 120 CONTINUE +C + 130 CONTINUE +C + 140 CONTINUE +C .......... CREATE REAL SUBDIAGONAL ELEMENTS .......... + 150 L = LOW + 1 +C + DO 170 I = L, IGH + LL = MIN0(I+1,IGH) + IF (HI(I,I-1) .EQ. 0.0D0) GO TO 170 + NORM = PYTHAG(HR(I,I-1),HI(I,I-1)) + YR = HR(I,I-1) / NORM + YI = HI(I,I-1) / NORM + HR(I,I-1) = NORM + HI(I,I-1) = 0.0D0 +C + DO 155 J = I, N + SI = YR * HI(I,J) - YI * HR(I,J) + HR(I,J) = YR * HR(I,J) + YI * HI(I,J) + HI(I,J) = SI + 155 CONTINUE +C + DO 160 J = 1, LL + SI = YR * HI(J,I) + YI * HR(J,I) + HR(J,I) = YR * HR(J,I) - YI * HI(J,I) + HI(J,I) = SI + 160 CONTINUE +C + DO 165 J = LOW, IGH + SI = YR * ZI(J,I) + YI * ZR(J,I) + ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I) + ZI(J,I) = SI + 165 CONTINUE +C + 170 CONTINUE +C .......... STORE ROOTS ISOLATED BY CBAL .......... + 180 DO 200 I = 1, N + IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200 + WR(I) = HR(I,I) + WI(I) = HI(I,I) + 200 CONTINUE +C + EN = IGH + TR = 0.0D0 + TI = 0.0D0 + ITN = 30*N +C .......... SEARCH FOR NEXT EIGENVALUE .......... + 220 IF (EN .LT. LOW) GO TO 680 + ITS = 0 + ENM1 = EN - 1 +C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT +C FOR L=EN STEP -1 UNTIL LOW DO -- .......... + 240 DO 260 LL = LOW, EN + L = EN + LOW - LL + IF (L .EQ. LOW) GO TO 300 + TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1)) + X + DABS(HR(L,L)) + DABS(HI(L,L)) + TST2 = TST1 + DABS(HR(L,L-1)) + IF (TST2 .EQ. TST1) GO TO 300 + 260 CONTINUE +C .......... FORM SHIFT .......... + 300 IF (L .EQ. EN) GO TO 660 + IF (ITN .EQ. 0) GO TO 1000 + IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320 + SR = HR(EN,EN) + SI = HI(EN,EN) + XR = HR(ENM1,EN) * HR(EN,ENM1) + XI = HI(ENM1,EN) * HR(EN,ENM1) + IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GO TO 340 + YR = (HR(ENM1,ENM1) - SR) / 2.0D0 + YI = (HI(ENM1,ENM1) - SI) / 2.0D0 + CALL CSROOT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI) + IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GO TO 310 + ZZR = -ZZR + ZZI = -ZZI + 310 CALL CDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI) + SR = SR - XR + SI = SI - XI + GO TO 340 +C .......... FORM EXCEPTIONAL SHIFT .......... + 320 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2)) + SI = 0.0D0 +C + 340 DO 360 I = LOW, EN + HR(I,I) = HR(I,I) - SR + HI(I,I) = HI(I,I) - SI + 360 CONTINUE +C + TR = TR + SR + TI = TI + SI + ITS = ITS + 1 + ITN = ITN - 1 +C .......... REDUCE TO TRIANGLE (ROWS) .......... + LP1 = L + 1 +C + DO 500 I = LP1, EN + SR = HR(I,I-1) + HR(I,I-1) = 0.0D0 + NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR) + XR = HR(I-1,I-1) / NORM + WR(I-1) = XR + XI = HI(I-1,I-1) / NORM + WI(I-1) = XI + HR(I-1,I-1) = NORM + HI(I-1,I-1) = 0.0D0 + HI(I,I-1) = SR / NORM +C + DO 490 J = I, N + YR = HR(I-1,J) + YI = HI(I-1,J) + ZZR = HR(I,J) + ZZI = HI(I,J) + HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR + HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI + HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR + HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI + 490 CONTINUE +C + 500 CONTINUE +C + SI = HI(EN,EN) + IF (SI .EQ. 0.0D0) GO TO 540 + NORM = PYTHAG(HR(EN,EN),SI) + SR = HR(EN,EN) / NORM + SI = SI / NORM + HR(EN,EN) = NORM + HI(EN,EN) = 0.0D0 + IF (EN .EQ. N) GO TO 540 + IP1 = EN + 1 +C + DO 520 J = IP1, N + YR = HR(EN,J) + YI = HI(EN,J) + HR(EN,J) = SR * YR + SI * YI + HI(EN,J) = SR * YI - SI * YR + 520 CONTINUE +C .......... INVERSE OPERATION (COLUMNS) .......... + 540 DO 600 J = LP1, EN + XR = WR(J-1) + XI = WI(J-1) +C + DO 580 I = 1, J + YR = HR(I,J-1) + YI = 0.0D0 + ZZR = HR(I,J) + ZZI = HI(I,J) + IF (I .EQ. J) GO TO 560 + YI = HI(I,J-1) + HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI + 560 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR + HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR + HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI + 580 CONTINUE +C + DO 590 I = LOW, IGH + YR = ZR(I,J-1) + YI = ZI(I,J-1) + ZZR = ZR(I,J) + ZZI = ZI(I,J) + ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR + ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI + ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR + ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI + 590 CONTINUE +C + 600 CONTINUE +C + IF (SI .EQ. 0.0D0) GO TO 240 +C + DO 630 I = 1, EN + YR = HR(I,EN) + YI = HI(I,EN) + HR(I,EN) = SR * YR - SI * YI + HI(I,EN) = SR * YI + SI * YR + 630 CONTINUE +C + DO 640 I = LOW, IGH + YR = ZR(I,EN) + YI = ZI(I,EN) + ZR(I,EN) = SR * YR - SI * YI + ZI(I,EN) = SR * YI + SI * YR + 640 CONTINUE +C + GO TO 240 +C .......... A ROOT FOUND .......... + 660 HR(EN,EN) = HR(EN,EN) + TR + WR(EN) = HR(EN,EN) + HI(EN,EN) = HI(EN,EN) + TI + WI(EN) = HI(EN,EN) + EN = ENM1 + GO TO 220 +C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND +C VECTORS OF UPPER TRIANGULAR FORM .......... + 680 NORM = 0.0D0 +C + DO 720 I = 1, N +C + DO 720 J = I, N + TR = DABS(HR(I,J)) + DABS(HI(I,J)) + IF (TR .GT. NORM) NORM = TR + 720 CONTINUE +C + IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GO TO 1001 +C .......... FOR EN=N STEP -1 UNTIL 2 DO -- .......... + DO 800 NN = 2, N + EN = N + 2 - NN + XR = WR(EN) + XI = WI(EN) + HR(EN,EN) = 1.0D0 + HI(EN,EN) = 0.0D0 + ENM1 = EN - 1 +C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- .......... + DO 780 II = 1, ENM1 + I = EN - II + ZZR = 0.0D0 + ZZI = 0.0D0 + IP1 = I + 1 +C + DO 740 J = IP1, EN + ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN) + ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN) + 740 CONTINUE +C + YR = XR - WR(I) + YI = XI - WI(I) + IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GO TO 765 + TST1 = NORM + YR = TST1 + 760 YR = 0.01D0 * YR + TST2 = NORM + YR + IF (TST2 .GT. TST1) GO TO 760 + 765 CONTINUE + CALL CDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN)) +C .......... OVERFLOW CONTROL .......... + TR = DABS(HR(I,EN)) + DABS(HI(I,EN)) + IF (TR .EQ. 0.0D0) GO TO 780 + TST1 = TR + TST2 = TST1 + 1.0D0/TST1 + IF (TST2 .GT. TST1) GO TO 780 + DO 770 J = I, EN + HR(J,EN) = HR(J,EN)/TR + HI(J,EN) = HI(J,EN)/TR + 770 CONTINUE +C + 780 CONTINUE +C + 800 CONTINUE +C .......... END BACKSUBSTITUTION .......... + ENM1 = N - 1 +C .......... VECTORS OF ISOLATED ROOTS .......... + DO 840 I = 1, ENM1 + IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840 + IP1 = I + 1 +C + DO 820 J = IP1, N + ZR(I,J) = HR(I,J) + ZI(I,J) = HI(I,J) + 820 CONTINUE +C + 840 CONTINUE +C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE +C VECTORS OF ORIGINAL FULL MATRIX. +C FOR J=N STEP -1 UNTIL LOW+1 DO -- .......... + DO 880 JJ = LOW, ENM1 + J = N + LOW - JJ + M = MIN0(J,IGH) +C + DO 880 I = LOW, IGH + ZZR = 0.0D0 + ZZI = 0.0D0 +C + DO 860 K = LOW, M + ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J) + ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J) + 860 CONTINUE +C + ZR(I,J) = ZZR + ZI(I,J) = ZZI + 880 CONTINUE +C + GO TO 1001 +C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT +C CONVERGED AFTER 30*N ITERATIONS .......... + 1000 IERR = EN + 1001 RETURN + END diff --git a/src/MyEis/corth.f b/src/MyEis/corth.f new file mode 100644 index 000000000..c09949321 --- /dev/null +++ b/src/MyEis/corth.f @@ -0,0 +1,134 @@ + SUBROUTINE CORTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI) +C + INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW + DOUBLE PRECISION AR(NM,N),AI(NM,N),ORTR(IGH),ORTI(IGH) + DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG +C +C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF +C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968) +C BY MARTIN AND WILKINSON. +C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). +C +C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE +C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS +C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY +C UNITARY SIMILARITY TRANSFORMATIONS. +C +C ON INPUT +C +C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL +C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM +C DIMENSION STATEMENT. +C +C N IS THE ORDER OF THE MATRIX. +C +C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING +C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, +C SET LOW=1, IGH=N. +C +C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, +C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX. +C +C ON OUTPUT +C +C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, +C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION +C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION +C IS STORED IN THE REMAINING TRIANGLES UNDER THE +C HESSENBERG MATRIX. +C +C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE +C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED. +C +C CALLS PYTHAG FOR DSQRT(A*A + B*B) . +C +C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, +C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY +C +C THIS VERSION DATED AUGUST 1983. +C +C ------------------------------------------------------------------ +C + LA = IGH - 1 + KP1 = LOW + 1 + IF (LA .LT. KP1) GO TO 200 +C + DO 180 M = KP1, LA + H = 0.0D0 + ORTR(M) = 0.0D0 + ORTI(M) = 0.0D0 + SCALE = 0.0D0 +C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) .......... + DO 90 I = M, IGH + 90 SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1)) +C + IF (SCALE .EQ. 0.0D0) GO TO 180 + MP = M + IGH +C .......... FOR I=IGH STEP -1 UNTIL M DO -- .......... + DO 100 II = M, IGH + I = MP - II + ORTR(I) = AR(I,M-1) / SCALE + ORTI(I) = AI(I,M-1) / SCALE + H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I) + 100 CONTINUE +C + G = DSQRT(H) + F = PYTHAG(ORTR(M),ORTI(M)) + IF (F .EQ. 0.0D0) GO TO 103 + H = H + F * G + G = G / F + ORTR(M) = (1.0D0 + G) * ORTR(M) + ORTI(M) = (1.0D0 + G) * ORTI(M) + GO TO 105 +C + 103 ORTR(M) = G + AR(M,M-1) = SCALE +C .......... FORM (I-(U*UT)/H) * A .......... + 105 DO 130 J = M, N + FR = 0.0D0 + FI = 0.0D0 +C .......... FOR I=IGH STEP -1 UNTIL M DO -- .......... + DO 110 II = M, IGH + I = MP - II + FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J) + FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J) + 110 CONTINUE +C + FR = FR / H + FI = FI / H +C + DO 120 I = M, IGH + AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I) + AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I) + 120 CONTINUE +C + 130 CONTINUE +C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) .......... + DO 160 I = 1, IGH + FR = 0.0D0 + FI = 0.0D0 +C .......... FOR J=IGH STEP -1 UNTIL M DO -- .......... + DO 140 JJ = M, IGH + J = MP - JJ + FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J) + FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J) + 140 CONTINUE +C + FR = FR / H + FI = FI / H +C + DO 150 J = M, IGH + AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J) + AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J) + 150 CONTINUE +C + 160 CONTINUE +C + ORTR(M) = SCALE * ORTR(M) + ORTI(M) = SCALE * ORTI(M) + AR(M,M-1) = -G * AR(M,M-1) + AI(M,M-1) = -G * AI(M,M-1) + 180 CONTINUE +C + 200 RETURN + END diff --git a/src/MyEis/csroot.f b/src/MyEis/csroot.f new file mode 100644 index 000000000..d81bbfe74 --- /dev/null +++ b/src/MyEis/csroot.f @@ -0,0 +1,17 @@ + SUBROUTINE CSROOT(XR,XI,YR,YI) + DOUBLE PRECISION XR,XI,YR,YI +C +C (YR,YI) = COMPLEX DSQRT(XR,XI) +C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI) +C + DOUBLE PRECISION S,TR,TI,PYTHAG + TR = XR + TI = XI + S = DSQRT(0.5D0*(PYTHAG(TR,TI) + DABS(TR))) + IF (TR .GE. 0.0D0) YR = S + IF (TI .LT. 0.0D0) S = -S + IF (TR .LE. 0.0D0) YI = S + IF (TR .LT. 0.0D0) YR = 0.5D0*(TI/YI) + IF (TR .GT. 0.0D0) YI = 0.5D0*(TI/YR) + RETURN + END diff --git a/src/MyEis/elmhes.f b/src/MyEis/elmhes.f new file mode 100644 index 000000000..a5b7a4846 --- /dev/null +++ b/src/MyEis/elmhes.f @@ -0,0 +1,98 @@ + SUBROUTINE ELMHES(NM,N,LOW,IGH,A,INT) +C + INTEGER I,J,M,N,LA,NM,IGH,KP1,LOW,MM1,MP1 + DOUBLE PRECISION A(NM,N) + DOUBLE PRECISION X,Y + INTEGER INT(IGH) +C +C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ELMHES, +C NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON. +C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). +C +C GIVEN A REAL GENERAL MATRIX, THIS SUBROUTINE +C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS +C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY +C STABILIZED ELEMENTARY SIMILARITY TRANSFORMATIONS. +C +C ON INPUT +C +C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL +C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM +C DIMENSION STATEMENT. +C +C N IS THE ORDER OF THE MATRIX. +C +C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING +C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, +C SET LOW=1, IGH=N. +C +C A CONTAINS THE INPUT MATRIX. +C +C ON OUTPUT +C +C A CONTAINS THE HESSENBERG MATRIX. THE MULTIPLIERS +C WHICH WERE USED IN THE REDUCTION ARE STORED IN THE +C REMAINING TRIANGLE UNDER THE HESSENBERG MATRIX. +C +C INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS +C INTERCHANGED IN THE REDUCTION. +C ONLY ELEMENTS LOW THROUGH IGH ARE USED. +C +C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, +C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY +C +C THIS VERSION DATED AUGUST 1983. +C +C ------------------------------------------------------------------ +C + LA = IGH - 1 + KP1 = LOW + 1 + IF (LA .LT. KP1) GO TO 200 +C + DO 180 M = KP1, LA + MM1 = M - 1 + X = 0.0D0 + I = M +C + DO 100 J = M, IGH + IF (DABS(A(J,MM1)) .LE. DABS(X)) GO TO 100 + X = A(J,MM1) + I = J + 100 CONTINUE +C + INT(M) = I + IF (I .EQ. M) GO TO 130 +C .......... INTERCHANGE ROWS AND COLUMNS OF A .......... + DO 110 J = MM1, N + Y = A(I,J) + A(I,J) = A(M,J) + A(M,J) = Y + 110 CONTINUE +C + DO 120 J = 1, IGH + Y = A(J,I) + A(J,I) = A(J,M) + A(J,M) = Y + 120 CONTINUE +C .......... END INTERCHANGE .......... + 130 IF (X .EQ. 0.0D0) GO TO 180 + MP1 = M + 1 +C + DO 160 I = MP1, IGH + Y = A(I,MM1) + IF (Y .EQ. 0.0D0) GO TO 160 + Y = Y / X + A(I,MM1) = Y +C + DO 140 J = M, N + 140 A(I,J) = A(I,J) - Y * A(M,J) +C + DO 150 J = 1, IGH + 150 A(J,M) = A(J,M) + Y * A(J,I) +C + 160 CONTINUE +C + 180 CONTINUE +C + 200 RETURN + END diff --git a/src/MyEis/eltran.f b/src/MyEis/eltran.f new file mode 100644 index 000000000..b6110930e --- /dev/null +++ b/src/MyEis/eltran.f @@ -0,0 +1,78 @@ + SUBROUTINE ELTRAN(NM,N,LOW,IGH,A,INT,Z) +C + INTEGER I,J,N,KL,MM,MP,NM,IGH,LOW,MP1 + DOUBLE PRECISION A(NM,IGH),Z(NM,N) + INTEGER INT(IGH) +C +C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ELMTRANS, +C NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON. +C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). +C +C THIS SUBROUTINE ACCUMULATES THE STABILIZED ELEMENTARY +C SIMILARITY TRANSFORMATIONS USED IN THE REDUCTION OF A +C REAL GENERAL MATRIX TO UPPER HESSENBERG FORM BY ELMHES. +C +C ON INPUT +C +C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL +C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM +C DIMENSION STATEMENT. +C +C N IS THE ORDER OF THE MATRIX. +C +C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING +C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, +C SET LOW=1, IGH=N. +C +C A CONTAINS THE MULTIPLIERS WHICH WERE USED IN THE +C REDUCTION BY ELMHES IN ITS LOWER TRIANGLE +C BELOW THE SUBDIAGONAL. +C +C INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS +C INTERCHANGED IN THE REDUCTION BY ELMHES. +C ONLY ELEMENTS LOW THROUGH IGH ARE USED. +C +C ON OUTPUT +C +C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE +C REDUCTION BY ELMHES. +C +C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, +C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY +C +C THIS VERSION DATED AUGUST 1983. +C +C ------------------------------------------------------------------ +C +C .......... INITIALIZE Z TO IDENTITY MATRIX .......... + DO 80 J = 1, N +C + DO 60 I = 1, N + 60 Z(I,J) = 0.0D0 +C + Z(J,J) = 1.0D0 + 80 CONTINUE +C + KL = IGH - LOW - 1 + IF (KL .LT. 1) GO TO 200 +C .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... + DO 140 MM = 1, KL + MP = IGH - MM + MP1 = MP + 1 +C + DO 100 I = MP1, IGH + 100 Z(I,MP) = A(I,MP-1) +C + I = INT(MP) + IF (I .EQ. MP) GO TO 140 +C + DO 130 J = MP, IGH + Z(MP,J) = Z(I,J) + Z(I,J) = 0.0D0 + 130 CONTINUE +C + Z(I,MP) = 1.0D0 + 140 CONTINUE +C + 200 RETURN + END diff --git a/src/MyEis/epslon.f b/src/MyEis/epslon.f new file mode 100644 index 000000000..88e25254c --- /dev/null +++ b/src/MyEis/epslon.f @@ -0,0 +1,36 @@ + DOUBLE PRECISION FUNCTION EPSLON (X) + DOUBLE PRECISION X +C +C ESTIMATE UNIT ROUNDOFF IN QUANTITIES OF SIZE X. +C + DOUBLE PRECISION A,B,C,EPS +C +C THIS PROGRAM SHOULD FUNCTION PROPERLY ON ALL SYSTEMS +C SATISFYING THE FOLLOWING TWO ASSUMPTIONS, +C 1. THE BASE USED IN REPRESENTING FLOATING POINT +C NUMBERS IS NOT A POWER OF THREE. +C 2. THE QUANTITY A IN STATEMENT 10 IS REPRESENTED TO +C THE ACCURACY USED IN FLOATING POINT VARIABLES +C THAT ARE STORED IN MEMORY. +C THE STATEMENT NUMBER 10 AND THE GO TO 10 ARE INTENDED TO +C FORCE OPTIMIZING COMPILERS TO GENERATE CODE SATISFYING +C ASSUMPTION 2. +C UNDER THESE ASSUMPTIONS, IT SHOULD BE TRUE THAT, +C A IS NOT EXACTLY EQUAL TO FOUR-THIRDS, +C B HAS A ZERO FOR ITS LAST BIT OR DIGIT, +C C IS NOT EXACTLY EQUAL TO ONE, +C EPS MEASURES THE SEPARATION OF 1.0 FROM +C THE NEXT LARGER FLOATING POINT NUMBER. +C THE DEVELOPERS OF EISPACK WOULD APPRECIATE BEING INFORMED +C ABOUT ANY SYSTEMS WHERE THESE ASSUMPTIONS DO NOT HOLD. +C +C THIS VERSION DATED 4/6/83. +C + A = 4.0D0/3.0D0 + 10 B = A - 1.0D0 + C = B + B + B + EPS = DABS(C-1.0D0) + IF (EPS .EQ. 0.0D0) GO TO 10 + EPSLON = EPS*DABS(X) + RETURN + END diff --git a/src/MyEis/hqr.f b/src/MyEis/hqr.f new file mode 100644 index 000000000..1ec242352 --- /dev/null +++ b/src/MyEis/hqr.f @@ -0,0 +1,234 @@ + SUBROUTINE HQR(NM,N,LOW,IGH,H,WR,WI,IERR) +C + INTEGER I,J,K,L,M,N,EN,LL,MM,NA,NM,IGH,ITN,ITS,LOW,MP2,ENM2,IERR + DOUBLE PRECISION H(NM,N),WR(N),WI(N) + DOUBLE PRECISION P,Q,R,S,T,W,X,Y,ZZ,NORM,TST1,TST2 + LOGICAL NOTLAS +C +C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE HQR, +C NUM. MATH. 14, 219-231(1970) BY MARTIN, PETERS, AND WILKINSON. +C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 359-371(1971). +C +C THIS SUBROUTINE FINDS THE EIGENVALUES OF A REAL +C UPPER HESSENBERG MATRIX BY THE QR METHOD. +C +C ON INPUT +C +C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL +C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM +C DIMENSION STATEMENT. +C +C N IS THE ORDER OF THE MATRIX. +C +C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING +C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, +C SET LOW=1, IGH=N. +C +C H CONTAINS THE UPPER HESSENBERG MATRIX. INFORMATION ABOUT +C THE TRANSFORMATIONS USED IN THE REDUCTION TO HESSENBERG +C FORM BY ELMHES OR ORTHES, IF PERFORMED, IS STORED +C IN THE REMAINING TRIANGLE UNDER THE HESSENBERG MATRIX. +C +C ON OUTPUT +C +C H HAS BEEN DESTROYED. THEREFORE, IT MUST BE SAVED +C BEFORE CALLING HQR IF SUBSEQUENT CALCULATION AND +C BACK TRANSFORMATION OF EIGENVECTORS IS TO BE PERFORMED. +C +C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, +C RESPECTIVELY, OF THE EIGENVALUES. THE EIGENVALUES +C ARE UNORDERED EXCEPT THAT COMPLEX CONJUGATE PAIRS +C OF VALUES APPEAR CONSECUTIVELY WITH THE EIGENVALUE +C HAVING THE POSITIVE IMAGINARY PART FIRST. IF AN +C ERROR EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT +C FOR INDICES IERR+1,...,N. +C +C IERR IS SET TO +C ZERO FOR NORMAL RETURN, +C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED +C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. +C +C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, +C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY +C +C THIS VERSION DATED AUGUST 1983. +C +C ------------------------------------------------------------------ +C + IERR = 0 + NORM = 0.0D0 + K = 1 +C .......... STORE ROOTS ISOLATED BY BALANC +C AND COMPUTE MATRIX NORM .......... + DO 50 I = 1, N +C + DO 40 J = K, N + 40 NORM = NORM + DABS(H(I,J)) +C + K = I + IF (I .GE. LOW .AND. I .LE. IGH) GO TO 50 + WR(I) = H(I,I) + WI(I) = 0.0D0 + 50 CONTINUE +C + EN = IGH + T = 0.0D0 + ITN = 30*N +C .......... SEARCH FOR NEXT EIGENVALUES .......... + 60 IF (EN .LT. LOW) GO TO 1001 + ITS = 0 + NA = EN - 1 + ENM2 = NA - 1 +C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT +C FOR L=EN STEP -1 UNTIL LOW DO -- .......... + 70 DO 80 LL = LOW, EN + L = EN + LOW - LL + IF (L .EQ. LOW) GO TO 100 + S = DABS(H(L-1,L-1)) + DABS(H(L,L)) + IF (S .EQ. 0.0D0) S = NORM + TST1 = S + TST2 = TST1 + DABS(H(L,L-1)) + IF (TST2 .EQ. TST1) GO TO 100 + 80 CONTINUE +C .......... FORM SHIFT .......... + 100 X = H(EN,EN) + IF (L .EQ. EN) GO TO 270 + Y = H(NA,NA) + W = H(EN,NA) * H(NA,EN) + IF (L .EQ. NA) GO TO 280 + IF (ITN .EQ. 0) GO TO 1000 + IF (ITS .NE. 10 .AND. ITS .NE. 20) GO TO 130 +C .......... FORM EXCEPTIONAL SHIFT .......... + T = T + X +C + DO 120 I = LOW, EN + 120 H(I,I) = H(I,I) - X +C + S = DABS(H(EN,NA)) + DABS(H(NA,ENM2)) + X = 0.75D0 * S + Y = X + W = -0.4375D0 * S * S + 130 ITS = ITS + 1 + ITN = ITN - 1 +C .......... LOOK FOR TWO CONSECUTIVE SMALL +C SUB-DIAGONAL ELEMENTS. +C FOR M=EN-2 STEP -1 UNTIL L DO -- .......... + DO 140 MM = L, ENM2 + M = ENM2 + L - MM + ZZ = H(M,M) + R = X - ZZ + S = Y - ZZ + P = (R * S - W) / H(M+1,M) + H(M,M+1) + Q = H(M+1,M+1) - ZZ - R - S + R = H(M+2,M+1) + S = DABS(P) + DABS(Q) + DABS(R) + P = P / S + Q = Q / S + R = R / S + IF (M .EQ. L) GO TO 150 + TST1 = DABS(P)*(DABS(H(M-1,M-1)) + DABS(ZZ) + DABS(H(M+1,M+1))) + TST2 = TST1 + DABS(H(M,M-1))*(DABS(Q) + DABS(R)) + IF (TST2 .EQ. TST1) GO TO 150 + 140 CONTINUE +C + 150 MP2 = M + 2 +C + DO 160 I = MP2, EN + H(I,I-2) = 0.0D0 + IF (I .EQ. MP2) GO TO 160 + H(I,I-3) = 0.0D0 + 160 CONTINUE +C .......... DOUBLE QR STEP INVOLVING ROWS L TO EN AND +C COLUMNS M TO EN .......... + DO 260 K = M, NA + NOTLAS = K .NE. NA + IF (K .EQ. M) GO TO 170 + P = H(K,K-1) + Q = H(K+1,K-1) + R = 0.0D0 + IF (NOTLAS) R = H(K+2,K-1) + X = DABS(P) + DABS(Q) + DABS(R) + IF (X .EQ. 0.0D0) GO TO 260 + P = P / X + Q = Q / X + R = R / X + 170 S = DSIGN(DSQRT(P*P+Q*Q+R*R),P) + IF (K .EQ. M) GO TO 180 + H(K,K-1) = -S * X + GO TO 190 + 180 IF (L .NE. M) H(K,K-1) = -H(K,K-1) + 190 P = P + S + X = P / S + Y = Q / S + ZZ = R / S + Q = Q / P + R = R / P + IF (NOTLAS) GO TO 225 +C .......... ROW MODIFICATION .......... + DO 200 J = K, N + P = H(K,J) + Q * H(K+1,J) + H(K,J) = H(K,J) - P * X + H(K+1,J) = H(K+1,J) - P * Y + 200 CONTINUE +C + J = MIN0(EN,K+3) +C .......... COLUMN MODIFICATION .......... + DO 210 I = 1, J + P = X * H(I,K) + Y * H(I,K+1) + H(I,K) = H(I,K) - P + H(I,K+1) = H(I,K+1) - P * Q + 210 CONTINUE + GO TO 255 + 225 CONTINUE +C .......... ROW MODIFICATION .......... + DO 230 J = K, N + P = H(K,J) + Q * H(K+1,J) + R * H(K+2,J) + H(K,J) = H(K,J) - P * X + H(K+1,J) = H(K+1,J) - P * Y + H(K+2,J) = H(K+2,J) - P * ZZ + 230 CONTINUE +C + J = MIN0(EN,K+3) +C .......... COLUMN MODIFICATION .......... + DO 240 I = 1, J + P = X * H(I,K) + Y * H(I,K+1) + ZZ * H(I,K+2) + H(I,K) = H(I,K) - P + H(I,K+1) = H(I,K+1) - P * Q + H(I,K+2) = H(I,K+2) - P * R + 240 CONTINUE + 255 CONTINUE +C + 260 CONTINUE +C + GO TO 70 +C .......... ONE ROOT FOUND .......... + 270 WR(EN) = X + T + WI(EN) = 0.0D0 + EN = NA + GO TO 60 +C .......... TWO ROOTS FOUND .......... + 280 P = (Y - X) / 2.0D0 + Q = P * P + W + ZZ = DSQRT(DABS(Q)) + X = X + T + IF (Q .LT. 0.0D0) GO TO 320 +C .......... REAL PAIR .......... + ZZ = P + DSIGN(ZZ,P) + WR(NA) = X + ZZ + WR(EN) = WR(NA) + IF (ZZ .NE. 0.0D0) WR(EN) = X - W / ZZ + WI(NA) = 0.0D0 + WI(EN) = 0.0D0 + GO TO 330 +C .......... COMPLEX PAIR .......... + 320 WR(NA) = X + P + WR(EN) = X + P + WI(NA) = ZZ + WI(EN) = -ZZ + 330 EN = ENM2 + GO TO 60 +C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT +C CONVERGED AFTER 30*N ITERATIONS .......... + 1000 IERR = EN + 1001 RETURN + END diff --git a/src/MyEis/hqr2.f b/src/MyEis/hqr2.f new file mode 100644 index 000000000..c22cdece4 --- /dev/null +++ b/src/MyEis/hqr2.f @@ -0,0 +1,449 @@ + SUBROUTINE HQR2(NM,N,LOW,IGH,H,WR,WI,Z,IERR) +C + INTEGER I,J,K,L,M,N,EN,II,JJ,LL,MM,NA,NM,NN, + X IGH,ITN,ITS,LOW,MP2,ENM2,IERR + DOUBLE PRECISION H(NM,N),WR(N),WI(N),Z(NM,N) + DOUBLE PRECISION P,Q,R,S,T,W,X,Y,RA,SA,VI,VR,ZZ,NORM,TST1,TST2 + LOGICAL NOTLAS +C +C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE HQR2, +C NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON. +C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). +C +C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS +C OF A REAL UPPER HESSENBERG MATRIX BY THE QR METHOD. THE +C EIGENVECTORS OF A REAL GENERAL MATRIX CAN ALSO BE FOUND +C IF ELMHES AND ELTRAN OR ORTHES AND ORTRAN HAVE +C BEEN USED TO REDUCE THIS GENERAL MATRIX TO HESSENBERG FORM +C AND TO ACCUMULATE THE SIMILARITY TRANSFORMATIONS. +C +C ON INPUT +C +C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL +C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM +C DIMENSION STATEMENT. +C +C N IS THE ORDER OF THE MATRIX. +C +C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING +C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, +C SET LOW=1, IGH=N. +C +C H CONTAINS THE UPPER HESSENBERG MATRIX. +C +C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED BY ELTRAN +C AFTER THE REDUCTION BY ELMHES, OR BY ORTRAN AFTER THE +C REDUCTION BY ORTHES, IF PERFORMED. IF THE EIGENVECTORS +C OF THE HESSENBERG MATRIX ARE DESIRED, Z MUST CONTAIN THE +C IDENTITY MATRIX. +C +C ON OUTPUT +C +C H HAS BEEN DESTROYED. +C +C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, +C RESPECTIVELY, OF THE EIGENVALUES. THE EIGENVALUES +C ARE UNORDERED EXCEPT THAT COMPLEX CONJUGATE PAIRS +C OF VALUES APPEAR CONSECUTIVELY WITH THE EIGENVALUE +C HAVING THE POSITIVE IMAGINARY PART FIRST. IF AN +C ERROR EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT +C FOR INDICES IERR+1,...,N. +C +C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS. +C IF THE I-TH EIGENVALUE IS REAL, THE I-TH COLUMN OF Z +C CONTAINS ITS EIGENVECTOR. IF THE I-TH EIGENVALUE IS COMPLEX +C WITH POSITIVE IMAGINARY PART, THE I-TH AND (I+1)-TH +C COLUMNS OF Z CONTAIN THE REAL AND IMAGINARY PARTS OF ITS +C EIGENVECTOR. THE EIGENVECTORS ARE UNNORMALIZED. IF AN +C ERROR EXIT IS MADE, NONE OF THE EIGENVECTORS HAS BEEN FOUND. +C +C IERR IS SET TO +C ZERO FOR NORMAL RETURN, +C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED +C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. +C +C CALLS CDIV FOR COMPLEX DIVISION. +C +C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, +C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY +C +C THIS VERSION DATED AUGUST 1983. +C +C ------------------------------------------------------------------ +C + IERR = 0 + NORM = 0.0D0 + K = 1 +C .......... STORE ROOTS ISOLATED BY BALANC +C AND COMPUTE MATRIX NORM .......... + DO 50 I = 1, N +C + DO 40 J = K, N + 40 NORM = NORM + DABS(H(I,J)) +C + K = I + IF (I .GE. LOW .AND. I .LE. IGH) GO TO 50 + WR(I) = H(I,I) + WI(I) = 0.0D0 + 50 CONTINUE +C + EN = IGH + T = 0.0D0 + ITN = 30*N +C .......... SEARCH FOR NEXT EIGENVALUES .......... + 60 IF (EN .LT. LOW) GO TO 340 + ITS = 0 + NA = EN - 1 + ENM2 = NA - 1 +C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT +C FOR L=EN STEP -1 UNTIL LOW DO -- .......... + 70 DO 80 LL = LOW, EN + L = EN + LOW - LL + IF (L .EQ. LOW) GO TO 100 + S = DABS(H(L-1,L-1)) + DABS(H(L,L)) + IF (S .EQ. 0.0D0) S = NORM + TST1 = S + TST2 = TST1 + DABS(H(L,L-1)) + IF (TST2 .EQ. TST1) GO TO 100 + 80 CONTINUE +C .......... FORM SHIFT .......... + 100 X = H(EN,EN) + IF (L .EQ. EN) GO TO 270 + Y = H(NA,NA) + W = H(EN,NA) * H(NA,EN) + IF (L .EQ. NA) GO TO 280 + IF (ITN .EQ. 0) GO TO 1000 + IF (ITS .NE. 10 .AND. ITS .NE. 20) GO TO 130 +C .......... FORM EXCEPTIONAL SHIFT .......... + T = T + X +C + DO 120 I = LOW, EN + 120 H(I,I) = H(I,I) - X +C + S = DABS(H(EN,NA)) + DABS(H(NA,ENM2)) + X = 0.75D0 * S + Y = X + W = -0.4375D0 * S * S + 130 ITS = ITS + 1 + ITN = ITN - 1 +C .......... LOOK FOR TWO CONSECUTIVE SMALL +C SUB-DIAGONAL ELEMENTS. +C FOR M=EN-2 STEP -1 UNTIL L DO -- .......... + DO 140 MM = L, ENM2 + M = ENM2 + L - MM + ZZ = H(M,M) + R = X - ZZ + S = Y - ZZ + P = (R * S - W) / H(M+1,M) + H(M,M+1) + Q = H(M+1,M+1) - ZZ - R - S + R = H(M+2,M+1) + S = DABS(P) + DABS(Q) + DABS(R) + P = P / S + Q = Q / S + R = R / S + IF (M .EQ. L) GO TO 150 + TST1 = DABS(P)*(DABS(H(M-1,M-1)) + DABS(ZZ) + DABS(H(M+1,M+1))) + TST2 = TST1 + DABS(H(M,M-1))*(DABS(Q) + DABS(R)) + IF (TST2 .EQ. TST1) GO TO 150 + 140 CONTINUE +C + 150 MP2 = M + 2 +C + DO 160 I = MP2, EN + H(I,I-2) = 0.0D0 + IF (I .EQ. MP2) GO TO 160 + H(I,I-3) = 0.0D0 + 160 CONTINUE +C .......... DOUBLE QR STEP INVOLVING ROWS L TO EN AND +C COLUMNS M TO EN .......... + DO 260 K = M, NA + NOTLAS = K .NE. NA + IF (K .EQ. M) GO TO 170 + P = H(K,K-1) + Q = H(K+1,K-1) + R = 0.0D0 + IF (NOTLAS) R = H(K+2,K-1) + X = DABS(P) + DABS(Q) + DABS(R) + IF (X .EQ. 0.0D0) GO TO 260 + P = P / X + Q = Q / X + R = R / X + 170 S = DSIGN(DSQRT(P*P+Q*Q+R*R),P) + IF (K .EQ. M) GO TO 180 + H(K,K-1) = -S * X + GO TO 190 + 180 IF (L .NE. M) H(K,K-1) = -H(K,K-1) + 190 P = P + S + X = P / S + Y = Q / S + ZZ = R / S + Q = Q / P + R = R / P + IF (NOTLAS) GO TO 225 +C .......... ROW MODIFICATION .......... + DO 200 J = K, N + P = H(K,J) + Q * H(K+1,J) + H(K,J) = H(K,J) - P * X + H(K+1,J) = H(K+1,J) - P * Y + 200 CONTINUE +C + J = MIN0(EN,K+3) +C .......... COLUMN MODIFICATION .......... + DO 210 I = 1, J + P = X * H(I,K) + Y * H(I,K+1) + H(I,K) = H(I,K) - P + H(I,K+1) = H(I,K+1) - P * Q + 210 CONTINUE +C .......... ACCUMULATE TRANSFORMATIONS .......... + DO 220 I = LOW, IGH + P = X * Z(I,K) + Y * Z(I,K+1) + Z(I,K) = Z(I,K) - P + Z(I,K+1) = Z(I,K+1) - P * Q + 220 CONTINUE + GO TO 255 + 225 CONTINUE +C .......... ROW MODIFICATION .......... + DO 230 J = K, N + P = H(K,J) + Q * H(K+1,J) + R * H(K+2,J) + H(K,J) = H(K,J) - P * X + H(K+1,J) = H(K+1,J) - P * Y + H(K+2,J) = H(K+2,J) - P * ZZ + 230 CONTINUE +C + J = MIN0(EN,K+3) +C .......... COLUMN MODIFICATION .......... + DO 240 I = 1, J + P = X * H(I,K) + Y * H(I,K+1) + ZZ * H(I,K+2) + H(I,K) = H(I,K) - P + H(I,K+1) = H(I,K+1) - P * Q + H(I,K+2) = H(I,K+2) - P * R + 240 CONTINUE +C .......... ACCUMULATE TRANSFORMATIONS .......... + DO 250 I = LOW, IGH + P = X * Z(I,K) + Y * Z(I,K+1) + ZZ * Z(I,K+2) + Z(I,K) = Z(I,K) - P + Z(I,K+1) = Z(I,K+1) - P * Q + Z(I,K+2) = Z(I,K+2) - P * R + 250 CONTINUE + 255 CONTINUE +C + 260 CONTINUE +C + GO TO 70 +C .......... ONE ROOT FOUND .......... + 270 H(EN,EN) = X + T + WR(EN) = H(EN,EN) + WI(EN) = 0.0D0 + EN = NA + GO TO 60 +C .......... TWO ROOTS FOUND .......... + 280 P = (Y - X) / 2.0D0 + Q = P * P + W + ZZ = DSQRT(DABS(Q)) + H(EN,EN) = X + T + X = H(EN,EN) + H(NA,NA) = Y + T + IF (Q .LT. 0.0D0) GO TO 320 +C .......... REAL PAIR .......... + ZZ = P + DSIGN(ZZ,P) + WR(NA) = X + ZZ + WR(EN) = WR(NA) + IF (ZZ .NE. 0.0D0) WR(EN) = X - W / ZZ + WI(NA) = 0.0D0 + WI(EN) = 0.0D0 + X = H(EN,NA) + S = DABS(X) + DABS(ZZ) + P = X / S + Q = ZZ / S + R = DSQRT(P*P+Q*Q) + P = P / R + Q = Q / R +C .......... ROW MODIFICATION .......... + DO 290 J = NA, N + ZZ = H(NA,J) + H(NA,J) = Q * ZZ + P * H(EN,J) + H(EN,J) = Q * H(EN,J) - P * ZZ + 290 CONTINUE +C .......... COLUMN MODIFICATION .......... + DO 300 I = 1, EN + ZZ = H(I,NA) + H(I,NA) = Q * ZZ + P * H(I,EN) + H(I,EN) = Q * H(I,EN) - P * ZZ + 300 CONTINUE +C .......... ACCUMULATE TRANSFORMATIONS .......... + DO 310 I = LOW, IGH + ZZ = Z(I,NA) + Z(I,NA) = Q * ZZ + P * Z(I,EN) + Z(I,EN) = Q * Z(I,EN) - P * ZZ + 310 CONTINUE +C + GO TO 330 +C .......... COMPLEX PAIR .......... + 320 WR(NA) = X + P + WR(EN) = X + P + WI(NA) = ZZ + WI(EN) = -ZZ + 330 EN = ENM2 + GO TO 60 +C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND +C VECTORS OF UPPER TRIANGULAR FORM .......... + 340 IF (NORM .EQ. 0.0D0) GO TO 1001 +C .......... FOR EN=N STEP -1 UNTIL 1 DO -- .......... + DO 800 NN = 1, N + EN = N + 1 - NN + P = WR(EN) + Q = WI(EN) + NA = EN - 1 + IF (Q) 710, 600, 800 +C .......... REAL VECTOR .......... + 600 M = EN + H(EN,EN) = 1.0D0 + IF (NA .EQ. 0) GO TO 800 +C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- .......... + DO 700 II = 1, NA + I = EN - II + W = H(I,I) - P + R = 0.0D0 +C + DO 610 J = M, EN + 610 R = R + H(I,J) * H(J,EN) +C + IF (WI(I) .GE. 0.0D0) GO TO 630 + ZZ = W + S = R + GO TO 700 + 630 M = I + IF (WI(I) .NE. 0.0D0) GO TO 640 + T = W + IF (T .NE. 0.0D0) GO TO 635 + TST1 = NORM + T = TST1 + 632 T = 0.01D0 * T + TST2 = NORM + T + IF (TST2 .GT. TST1) GO TO 632 + 635 H(I,EN) = -R / T + GO TO 680 +C .......... SOLVE REAL EQUATIONS .......... + 640 X = H(I,I+1) + Y = H(I+1,I) + Q = (WR(I) - P) * (WR(I) - P) + WI(I) * WI(I) + T = (X * S - ZZ * R) / Q + H(I,EN) = T + IF (DABS(X) .LE. DABS(ZZ)) GO TO 650 + H(I+1,EN) = (-R - W * T) / X + GO TO 680 + 650 H(I+1,EN) = (-S - Y * T) / ZZ +C +C .......... OVERFLOW CONTROL .......... + 680 T = DABS(H(I,EN)) + IF (T .EQ. 0.0D0) GO TO 700 + TST1 = T + TST2 = TST1 + 1.0D0/TST1 + IF (TST2 .GT. TST1) GO TO 700 + DO 690 J = I, EN + H(J,EN) = H(J,EN)/T + 690 CONTINUE +C + 700 CONTINUE +C .......... END REAL VECTOR .......... + GO TO 800 +C .......... COMPLEX VECTOR .......... + 710 M = NA +C .......... LAST VECTOR COMPONENT CHOSEN IMAGINARY SO THAT +C EIGENVECTOR MATRIX IS TRIANGULAR .......... + IF (DABS(H(EN,NA)) .LE. DABS(H(NA,EN))) GO TO 720 + H(NA,NA) = Q / H(EN,NA) + H(NA,EN) = -(H(EN,EN) - P) / H(EN,NA) + GO TO 730 + 720 CALL CDIV(0.0D0,-H(NA,EN),H(NA,NA)-P,Q,H(NA,NA),H(NA,EN)) + 730 H(EN,NA) = 0.0D0 + H(EN,EN) = 1.0D0 + ENM2 = NA - 1 + IF (ENM2 .EQ. 0) GO TO 800 +C .......... FOR I=EN-2 STEP -1 UNTIL 1 DO -- .......... + DO 795 II = 1, ENM2 + I = NA - II + W = H(I,I) - P + RA = 0.0D0 + SA = 0.0D0 +C + DO 760 J = M, EN + RA = RA + H(I,J) * H(J,NA) + SA = SA + H(I,J) * H(J,EN) + 760 CONTINUE +C + IF (WI(I) .GE. 0.0D0) GO TO 770 + ZZ = W + R = RA + S = SA + GO TO 795 + 770 M = I + IF (WI(I) .NE. 0.0D0) GO TO 780 + CALL CDIV(-RA,-SA,W,Q,H(I,NA),H(I,EN)) + GO TO 790 +C .......... SOLVE COMPLEX EQUATIONS .......... + 780 X = H(I,I+1) + Y = H(I+1,I) + VR = (WR(I) - P) * (WR(I) - P) + WI(I) * WI(I) - Q * Q + VI = (WR(I) - P) * 2.0D0 * Q + IF (VR .NE. 0.0D0 .OR. VI .NE. 0.0D0) GO TO 784 + TST1 = NORM * (DABS(W) + DABS(Q) + DABS(X) + X + DABS(Y) + DABS(ZZ)) + VR = TST1 + 783 VR = 0.01D0 * VR + TST2 = TST1 + VR + IF (TST2 .GT. TST1) GO TO 783 + 784 CALL CDIV(X*R-ZZ*RA+Q*SA,X*S-ZZ*SA-Q*RA,VR,VI, + X H(I,NA),H(I,EN)) + IF (DABS(X) .LE. DABS(ZZ) + DABS(Q)) GO TO 785 + H(I+1,NA) = (-RA - W * H(I,NA) + Q * H(I,EN)) / X + H(I+1,EN) = (-SA - W * H(I,EN) - Q * H(I,NA)) / X + GO TO 790 + 785 CALL CDIV(-R-Y*H(I,NA),-S-Y*H(I,EN),ZZ,Q, + X H(I+1,NA),H(I+1,EN)) +C +C .......... OVERFLOW CONTROL .......... + 790 T = DMAX1(DABS(H(I,NA)), DABS(H(I,EN))) + IF (T .EQ. 0.0D0) GO TO 795 + TST1 = T + TST2 = TST1 + 1.0D0/TST1 + IF (TST2 .GT. TST1) GO TO 795 + DO 792 J = I, EN + H(J,NA) = H(J,NA)/T + H(J,EN) = H(J,EN)/T + 792 CONTINUE +C + 795 CONTINUE +C .......... END COMPLEX VECTOR .......... + 800 CONTINUE +C .......... END BACK SUBSTITUTION. +C VECTORS OF ISOLATED ROOTS .......... + DO 840 I = 1, N + IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840 +C + DO 820 J = I, N + 820 Z(I,J) = H(I,J) +C + 840 CONTINUE +C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE +C VECTORS OF ORIGINAL FULL MATRIX. +C FOR J=N STEP -1 UNTIL LOW DO -- .......... + DO 880 JJ = LOW, N + J = N + LOW - JJ + M = MIN0(J,IGH) +C + DO 880 I = LOW, IGH + ZZ = 0.0D0 +C + DO 860 K = LOW, M + 860 ZZ = ZZ + Z(I,K) * H(K,J) +C + Z(I,J) = ZZ + 880 CONTINUE +C + GO TO 1001 +C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT +C CONVERGED AFTER 30*N ITERATIONS .......... + 1000 IERR = EN + 1001 RETURN + END diff --git a/src/MyEis/htribk.f b/src/MyEis/htribk.f new file mode 100644 index 000000000..cd97b8a8a --- /dev/null +++ b/src/MyEis/htribk.f @@ -0,0 +1,91 @@ + SUBROUTINE HTRIBK(NM,N,AR,AI,TAU,M,ZR,ZI) +C + INTEGER I,J,K,L,M,N,NM + DOUBLE PRECISION AR(NM,N),AI(NM,N),TAU(2,N),ZR(NM,M),ZI(NM,M) + DOUBLE PRECISION H,S,SI +C +C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF +C THE ALGOL PROCEDURE TRBAK1, NUM. MATH. 11, 181-195(1968) +C BY MARTIN, REINSCH, AND WILKINSON. +C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). +C +C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX HERMITIAN +C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING +C REAL SYMMETRIC TRIDIAGONAL MATRIX DETERMINED BY HTRIDI. +C +C ON INPUT +C +C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL +C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM +C DIMENSION STATEMENT. +C +C N IS THE ORDER OF THE MATRIX. +C +C AR AND AI CONTAIN INFORMATION ABOUT THE UNITARY TRANS- +C FORMATIONS USED IN THE REDUCTION BY HTRIDI IN THEIR +C FULL LOWER TRIANGLES EXCEPT FOR THE DIAGONAL OF AR. +C +C TAU CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS. +C +C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. +C +C ZR CONTAINS THE EIGENVECTORS TO BE BACK TRANSFORMED +C IN ITS FIRST M COLUMNS. +C +C ON OUTPUT +C +C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, +C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS +C IN THEIR FIRST M COLUMNS. +C +C NOTE THAT THE LAST COMPONENT OF EACH RETURNED VECTOR +C IS REAL AND THAT VECTOR EUCLIDEAN NORMS ARE PRESERVED. +C +C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, +C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY +C +C THIS VERSION DATED AUGUST 1983. +C +C ------------------------------------------------------------------ +C + IF (M .EQ. 0) GO TO 200 +C .......... TRANSFORM THE EIGENVECTORS OF THE REAL SYMMETRIC +C TRIDIAGONAL MATRIX TO THOSE OF THE HERMITIAN +C TRIDIAGONAL MATRIX. .......... + DO 50 K = 1, N +C + DO 50 J = 1, M + ZI(K,J) = -ZR(K,J) * TAU(2,K) + ZR(K,J) = ZR(K,J) * TAU(1,K) + 50 CONTINUE +C + IF (N .EQ. 1) GO TO 200 +C .......... RECOVER AND APPLY THE HOUSEHOLDER MATRICES .......... + DO 140 I = 2, N + L = I - 1 + H = AI(I,I) + IF (H .EQ. 0.0D0) GO TO 140 +C + DO 130 J = 1, M + S = 0.0D0 + SI = 0.0D0 +C + DO 110 K = 1, L + S = S + AR(I,K) * ZR(K,J) - AI(I,K) * ZI(K,J) + SI = SI + AR(I,K) * ZI(K,J) + AI(I,K) * ZR(K,J) + 110 CONTINUE +C .......... DOUBLE DIVISIONS AVOID POSSIBLE UNDERFLOW .......... + S = (S / H) / H + SI = (SI / H) / H +C + DO 120 K = 1, L + ZR(K,J) = ZR(K,J) - S * AR(I,K) - SI * AI(I,K) + ZI(K,J) = ZI(K,J) - SI * AR(I,K) + S * AI(I,K) + 120 CONTINUE +C + 130 CONTINUE +C + 140 CONTINUE +C + 200 RETURN + END diff --git a/src/MyEis/htridi.f b/src/MyEis/htridi.f new file mode 100644 index 000000000..c68881c00 --- /dev/null +++ b/src/MyEis/htridi.f @@ -0,0 +1,154 @@ + SUBROUTINE HTRIDI(NM,N,AR,AI,D,E,E2,TAU) +C + INTEGER I,J,K,L,N,II,NM,JP1 + DOUBLE PRECISION AR(NM,N),AI(NM,N),D(N),E(N),E2(N),TAU(2,N) + DOUBLE PRECISION F,G,H,FI,GI,HH,SI,SCALE,PYTHAG +C +C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF +C THE ALGOL PROCEDURE TRED1, NUM. MATH. 11, 181-195(1968) +C BY MARTIN, REINSCH, AND WILKINSON. +C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). +C +C THIS SUBROUTINE REDUCES A COMPLEX HERMITIAN MATRIX +C TO A REAL SYMMETRIC TRIDIAGONAL MATRIX USING +C UNITARY SIMILARITY TRANSFORMATIONS. +C +C ON INPUT +C +C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL +C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM +C DIMENSION STATEMENT. +C +C N IS THE ORDER OF THE MATRIX. +C +C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, +C RESPECTIVELY, OF THE COMPLEX HERMITIAN INPUT MATRIX. +C ONLY THE LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED. +C +C ON OUTPUT +C +C AR AND AI CONTAIN INFORMATION ABOUT THE UNITARY TRANS- +C FORMATIONS USED IN THE REDUCTION IN THEIR FULL LOWER +C TRIANGLES. THEIR STRICT UPPER TRIANGLES AND THE +C DIAGONAL OF AR ARE UNALTERED. +C +C D CONTAINS THE DIAGONAL ELEMENTS OF THE THE TRIDIAGONAL MATRIX. +C +C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL +C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO. +C +C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. +C E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. +C +C TAU CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS. +C +C CALLS PYTHAG FOR DSQRT(A*A + B*B) . +C +C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, +C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY +C +C THIS VERSION DATED AUGUST 1983. +C +C ------------------------------------------------------------------ +C + TAU(1,N) = 1.0D0 + TAU(2,N) = 0.0D0 +C + DO 100 I = 1, N + 100 D(I) = AR(I,I) +C .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... + DO 300 II = 1, N + I = N + 1 - II + L = I - 1 + H = 0.0D0 + SCALE = 0.0D0 + IF (L .LT. 1) GO TO 130 +C .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... + DO 120 K = 1, L + 120 SCALE = SCALE + DABS(AR(I,K)) + DABS(AI(I,K)) +C + IF (SCALE .NE. 0.0D0) GO TO 140 + TAU(1,L) = 1.0D0 + TAU(2,L) = 0.0D0 + 130 E(I) = 0.0D0 + E2(I) = 0.0D0 + GO TO 290 +C + 140 DO 150 K = 1, L + AR(I,K) = AR(I,K) / SCALE + AI(I,K) = AI(I,K) / SCALE + H = H + AR(I,K) * AR(I,K) + AI(I,K) * AI(I,K) + 150 CONTINUE +C + E2(I) = SCALE * SCALE * H + G = DSQRT(H) + E(I) = SCALE * G + F = PYTHAG(AR(I,L),AI(I,L)) +C .......... FORM NEXT DIAGONAL ELEMENT OF MATRIX T .......... + IF (F .EQ. 0.0D0) GO TO 160 + TAU(1,L) = (AI(I,L) * TAU(2,I) - AR(I,L) * TAU(1,I)) / F + SI = (AR(I,L) * TAU(2,I) + AI(I,L) * TAU(1,I)) / F + H = H + F * G + G = 1.0D0 + G / F + AR(I,L) = G * AR(I,L) + AI(I,L) = G * AI(I,L) + IF (L .EQ. 1) GO TO 270 + GO TO 170 + 160 TAU(1,L) = -TAU(1,I) + SI = TAU(2,I) + AR(I,L) = G + 170 F = 0.0D0 +C + DO 240 J = 1, L + G = 0.0D0 + GI = 0.0D0 +C .......... FORM ELEMENT OF A*U .......... + DO 180 K = 1, J + G = G + AR(J,K) * AR(I,K) + AI(J,K) * AI(I,K) + GI = GI - AR(J,K) * AI(I,K) + AI(J,K) * AR(I,K) + 180 CONTINUE +C + JP1 = J + 1 + IF (L .LT. JP1) GO TO 220 +C + DO 200 K = JP1, L + G = G + AR(K,J) * AR(I,K) - AI(K,J) * AI(I,K) + GI = GI - AR(K,J) * AI(I,K) - AI(K,J) * AR(I,K) + 200 CONTINUE +C .......... FORM ELEMENT OF P .......... + 220 E(J) = G / H + TAU(2,J) = GI / H + F = F + E(J) * AR(I,J) - TAU(2,J) * AI(I,J) + 240 CONTINUE +C + HH = F / (H + H) +C .......... FORM REDUCED A .......... + DO 260 J = 1, L + F = AR(I,J) + G = E(J) - HH * F + E(J) = G + FI = -AI(I,J) + GI = TAU(2,J) - HH * FI + TAU(2,J) = -GI +C + DO 260 K = 1, J + AR(J,K) = AR(J,K) - F * E(K) - G * AR(I,K) + X + FI * TAU(2,K) + GI * AI(I,K) + AI(J,K) = AI(J,K) - F * TAU(2,K) - G * AI(I,K) + X - FI * E(K) - GI * AR(I,K) + 260 CONTINUE +C + 270 DO 280 K = 1, L + AR(I,K) = SCALE * AR(I,K) + AI(I,K) = SCALE * AI(I,K) + 280 CONTINUE +C + TAU(2,L) = -SI + 290 HH = D(I) + D(I) = AR(I,I) + AR(I,I) = HH + AI(I,I) = SCALE * DSQRT(H) + 300 CONTINUE +C + RETURN + END diff --git a/src/MyEis/pythag.f b/src/MyEis/pythag.f new file mode 100644 index 000000000..b4a8ba6ed --- /dev/null +++ b/src/MyEis/pythag.f @@ -0,0 +1,20 @@ + DOUBLE PRECISION FUNCTION PYTHAG(A,B) + DOUBLE PRECISION A,B +C +C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW +C + DOUBLE PRECISION P,R,S,T,U + P = DMAX1(DABS(A),DABS(B)) + IF (P .EQ. 0.0D0) GO TO 20 + R = (DMIN1(DABS(A),DABS(B))/P)**2 + 10 CONTINUE + T = 4.0D0 + R + IF (T .EQ. 4.0D0) GO TO 20 + S = R/T + U = 1.0D0 + 2.0D0*S + P = U*P + R = (S/U)**2 * R + GO TO 10 + 20 PYTHAG = P + RETURN + END diff --git a/src/MyEis/rg.f b/src/MyEis/rg.f new file mode 100644 index 000000000..34545aea3 --- /dev/null +++ b/src/MyEis/rg.f @@ -0,0 +1,70 @@ + SUBROUTINE RG(NM,N,A,WR,WI,MATZ,Z,IV1,FV1,IERR) +C + INTEGER N,NM,IS1,IS2,IERR,MATZ + DOUBLE PRECISION A(NM,N),WR(N),WI(N),Z(NM,N),FV1(N) + INTEGER IV1(N) +C +C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF +C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) +C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) +C OF A REAL GENERAL MATRIX. +C +C ON INPUT +C +C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL +C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM +C DIMENSION STATEMENT. +C +C N IS THE ORDER OF THE MATRIX A. +C +C A CONTAINS THE REAL GENERAL MATRIX. +C +C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF +C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO +C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. +C +C ON OUTPUT +C +C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, +C RESPECTIVELY, OF THE EIGENVALUES. COMPLEX CONJUGATE +C PAIRS OF EIGENVALUES APPEAR CONSECUTIVELY WITH THE +C EIGENVALUE HAVING THE POSITIVE IMAGINARY PART FIRST. +C +C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS +C IF MATZ IS NOT ZERO. IF THE J-TH EIGENVALUE IS REAL, THE +C J-TH COLUMN OF Z CONTAINS ITS EIGENVECTOR. IF THE J-TH +C EIGENVALUE IS COMPLEX WITH POSITIVE IMAGINARY PART, THE +C J-TH AND (J+1)-TH COLUMNS OF Z CONTAIN THE REAL AND +C IMAGINARY PARTS OF ITS EIGENVECTOR. THE CONJUGATE OF THIS +C VECTOR IS THE EIGENVECTOR FOR THE CONJUGATE EIGENVALUE. +C +C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR +C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR HQR +C AND HQR2. THE NORMAL COMPLETION CODE IS ZERO. +C +C IV1 AND FV1 ARE TEMPORARY STORAGE ARRAYS. +C +C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, +C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY +C +C THIS VERSION DATED AUGUST 1983. +C +C ------------------------------------------------------------------ +C + IF (N .LE. NM) GO TO 10 + IERR = 10 * N + GO TO 50 +C + 10 CALL BALANC(NM,N,A,IS1,IS2,FV1) + CALL ELMHES(NM,N,IS1,IS2,A,IV1) + IF (MATZ .NE. 0) GO TO 20 +C .......... FIND EIGENVALUES ONLY .......... + CALL HQR(NM,N,IS1,IS2,A,WR,WI,IERR) + GO TO 50 +C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... + 20 CALL ELTRAN(NM,N,IS1,IS2,A,IV1,Z) + CALL HQR2(NM,N,IS1,IS2,A,WR,WI,Z,IERR) + IF (IERR .NE. 0) GO TO 50 + CALL BALBAK(NM,N,IS1,IS2,FV1,N,Z) + 50 RETURN + END diff --git a/src/MyEis/rs.f b/src/MyEis/rs.f new file mode 100644 index 000000000..1adcb959d --- /dev/null +++ b/src/MyEis/rs.f @@ -0,0 +1,57 @@ + SUBROUTINE RS(NM,N,A,W,MATZ,Z,FV1,FV2,IERR) +C + INTEGER N,NM,IERR,MATZ + DOUBLE PRECISION A(NM,N),W(N),Z(NM,N),FV1(N),FV2(N) +C +C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF +C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) +C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) +C OF A REAL SYMMETRIC MATRIX. +C +C ON INPUT +C +C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL +C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM +C DIMENSION STATEMENT. +C +C N IS THE ORDER OF THE MATRIX A. +C +C A CONTAINS THE REAL SYMMETRIC MATRIX. +C +C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF +C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO +C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. +C +C ON OUTPUT +C +C W CONTAINS THE EIGENVALUES IN ASCENDING ORDER. +C +C Z CONTAINS THE EIGENVECTORS IF MATZ IS NOT ZERO. +C +C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR +C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR TQLRAT +C AND TQL2. THE NORMAL COMPLETION CODE IS ZERO. +C +C FV1 AND FV2 ARE TEMPORARY STORAGE ARRAYS. +C +C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, +C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY +C +C THIS VERSION DATED AUGUST 1983. +C +C ------------------------------------------------------------------ +C + IF (N .LE. NM) GO TO 10 + IERR = 10 * N + GO TO 50 +C + 10 IF (MATZ .NE. 0) GO TO 20 +C .......... FIND EIGENVALUES ONLY .......... + CALL TRED1(NM,N,A,W,FV1,FV2) + CALL TQLRAT(N,W,FV2,IERR) + GO TO 50 +C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... + 20 CALL TRED2(NM,N,A,W,FV1,Z) + CALL TQL2(NM,N,W,FV1,Z,IERR) + 50 RETURN + END diff --git a/src/MyEis/tql2.f b/src/MyEis/tql2.f new file mode 100644 index 000000000..92321bc5a --- /dev/null +++ b/src/MyEis/tql2.f @@ -0,0 +1,170 @@ + SUBROUTINE TQL2(NM,N,D,E,Z,IERR) +C + INTEGER I,J,K,L,M,N,II,L1,L2,NM,MML,IERR + DOUBLE PRECISION D(N),E(N),Z(NM,N) + DOUBLE PRECISION C,C2,C3,DL1,EL1,F,G,H,P,R,S,S2,TST1,TST2,PYTHAG +C +C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQL2, +C NUM. MATH. 11, 293-306(1968) BY BOWDLER, MARTIN, REINSCH, AND +C WILKINSON. +C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971). +C +C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS +C OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE QL METHOD. +C THE EIGENVECTORS OF A FULL SYMMETRIC MATRIX CAN ALSO +C BE FOUND IF TRED2 HAS BEEN USED TO REDUCE THIS +C FULL MATRIX TO TRIDIAGONAL FORM. +C +C ON INPUT +C +C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL +C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM +C DIMENSION STATEMENT. +C +C N IS THE ORDER OF THE MATRIX. +C +C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. +C +C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX +C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. +C +C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE +C REDUCTION BY TRED2, IF PERFORMED. IF THE EIGENVECTORS +C OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN +C THE IDENTITY MATRIX. +C +C ON OUTPUT +C +C D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN +C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT +C UNORDERED FOR INDICES 1,2,...,IERR-1. +C +C E HAS BEEN DESTROYED. +C +C Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC +C TRIDIAGONAL (OR FULL) MATRIX. IF AN ERROR EXIT IS MADE, +C Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED +C EIGENVALUES. +C +C IERR IS SET TO +C ZERO FOR NORMAL RETURN, +C J IF THE J-TH EIGENVALUE HAS NOT BEEN +C DETERMINED AFTER 30 ITERATIONS. +C +C CALLS PYTHAG FOR DSQRT(A*A + B*B) . +C +C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, +C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY +C +C THIS VERSION DATED AUGUST 1983. +C +C ------------------------------------------------------------------ +C + IERR = 0 + IF (N .EQ. 1) GO TO 1001 +C + DO 100 I = 2, N + 100 E(I-1) = E(I) +C + F = 0.0D0 + TST1 = 0.0D0 + E(N) = 0.0D0 +C + DO 240 L = 1, N + J = 0 + H = DABS(D(L)) + DABS(E(L)) + IF (TST1 .LT. H) TST1 = H +C .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT .......... + DO 110 M = L, N + TST2 = TST1 + DABS(E(M)) + IF (TST2 .EQ. TST1) GO TO 120 +C .......... E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT +C THROUGH THE BOTTOM OF THE LOOP .......... + 110 CONTINUE +C + 120 IF (M .EQ. L) GO TO 220 + 130 IF (J .EQ. 30) GO TO 1000 + J = J + 1 +C .......... FORM SHIFT .......... + L1 = L + 1 + L2 = L1 + 1 + G = D(L) + P = (D(L1) - G) / (2.0D0 * E(L)) + R = PYTHAG(P,1.0D0) + D(L) = E(L) / (P + DSIGN(R,P)) + D(L1) = E(L) * (P + DSIGN(R,P)) + DL1 = D(L1) + H = G - D(L) + IF (L2 .GT. N) GO TO 145 +C + DO 140 I = L2, N + 140 D(I) = D(I) - H +C + 145 F = F + H +C .......... QL TRANSFORMATION .......... + P = D(M) + C = 1.0D0 + C2 = C + EL1 = E(L1) + S = 0.0D0 + MML = M - L +C .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... + DO 200 II = 1, MML + C3 = C2 + C2 = C + S2 = S + I = M - II + G = C * E(I) + H = C * P + R = PYTHAG(P,E(I)) + E(I+1) = S * R + S = E(I) / R + C = P / R + P = C * D(I) - S * G + D(I+1) = H + S * (C * G + S * D(I)) +C .......... FORM VECTOR .......... + DO 180 K = 1, N + H = Z(K,I+1) + Z(K,I+1) = S * Z(K,I) + C * H + Z(K,I) = C * Z(K,I) - S * H + 180 CONTINUE +C + 200 CONTINUE +C + P = -S * S2 * C3 * EL1 * E(L) / DL1 + E(L) = S * P + D(L) = C * P + TST2 = TST1 + DABS(E(L)) + IF (TST2 .GT. TST1) GO TO 130 + 220 D(L) = D(L) + F + 240 CONTINUE +C .......... ORDER EIGENVALUES AND EIGENVECTORS .......... + DO 300 II = 2, N + I = II - 1 + K = I + P = D(I) +C + DO 260 J = II, N + IF (D(J) .GE. P) GO TO 260 + K = J + P = D(J) + 260 CONTINUE +C + IF (K .EQ. I) GO TO 300 + D(K) = D(I) + D(I) = P +C + DO 280 J = 1, N + P = Z(J,I) + Z(J,I) = Z(J,K) + Z(J,K) = P + 280 CONTINUE +C + 300 CONTINUE +C + GO TO 1001 +C .......... SET ERROR -- NO CONVERGENCE TO AN +C EIGENVALUE AFTER 30 ITERATIONS .......... + 1000 IERR = L + 1001 RETURN + END diff --git a/src/MyEis/tqlrat.f b/src/MyEis/tqlrat.f new file mode 100644 index 000000000..41d9c382a --- /dev/null +++ b/src/MyEis/tqlrat.f @@ -0,0 +1,130 @@ + SUBROUTINE TQLRAT(N,D,E2,IERR) +C + INTEGER I,J,L,M,N,II,L1,MML,IERR + DOUBLE PRECISION D(N),E2(N) + DOUBLE PRECISION B,C,F,G,H,P,R,S,T,EPSLON,PYTHAG +C +C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQLRAT, +C ALGORITHM 464, COMM. ACM 16, 689(1973) BY REINSCH. +C +C THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC +C TRIDIAGONAL MATRIX BY THE RATIONAL QL METHOD. +C +C ON INPUT +C +C N IS THE ORDER OF THE MATRIX. +C +C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX. +C +C E2 CONTAINS THE SQUARES OF THE SUBDIAGONAL ELEMENTS OF THE +C INPUT MATRIX IN ITS LAST N-1 POSITIONS. E2(1) IS ARBITRARY. +C +C ON OUTPUT +C +C D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN +C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND +C ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE +C THE SMALLEST EIGENVALUES. +C +C E2 HAS BEEN DESTROYED. +C +C IERR IS SET TO +C ZERO FOR NORMAL RETURN, +C J IF THE J-TH EIGENVALUE HAS NOT BEEN +C DETERMINED AFTER 30 ITERATIONS. +C +C CALLS PYTHAG FOR DSQRT(A*A + B*B) . +C +C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, +C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY +C +C THIS VERSION DATED AUGUST 1983. +C +C ------------------------------------------------------------------ +C + IERR = 0 + IF (N .EQ. 1) GO TO 1001 +C + DO 100 I = 2, N + 100 E2(I-1) = E2(I) +C + F = 0.0D0 + T = 0.0D0 + E2(N) = 0.0D0 +C + DO 290 L = 1, N + J = 0 + H = DABS(D(L)) + DSQRT(E2(L)) + IF (T .GT. H) GO TO 105 + T = H + B = EPSLON(T) + C = B * B +C .......... LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT .......... + 105 DO 110 M = L, N + IF (E2(M) .LE. C) GO TO 120 +C .......... E2(N) IS ALWAYS ZERO, SO THERE IS NO EXIT +C THROUGH THE BOTTOM OF THE LOOP .......... + 110 CONTINUE +C + 120 IF (M .EQ. L) GO TO 210 + 130 IF (J .EQ. 30) GO TO 1000 + J = J + 1 +C .......... FORM SHIFT .......... + L1 = L + 1 + S = DSQRT(E2(L)) + G = D(L) + P = (D(L1) - G) / (2.0D0 * S) + R = PYTHAG(P,1.0D0) + D(L) = S / (P + DSIGN(R,P)) + H = G - D(L) +C + DO 140 I = L1, N + 140 D(I) = D(I) - H +C + F = F + H +C .......... RATIONAL QL TRANSFORMATION .......... + G = D(M) + IF (G .EQ. 0.0D0) G = B + H = G + S = 0.0D0 + MML = M - L +C .......... FOR I=M-1 STEP -1 UNTIL L DO -- .......... + DO 200 II = 1, MML + I = M - II + P = G * H + R = P + E2(I) + E2(I+1) = S * R + S = E2(I) / R + D(I+1) = H + S * (H + D(I)) + G = D(I) - E2(I) / G + IF (G .EQ. 0.0D0) G = B + H = G * P / R + 200 CONTINUE +C + E2(L) = S * G + D(L) = H +C .......... GUARD AGAINST UNDERFLOW IN CONVERGENCE TEST .......... + IF (H .EQ. 0.0D0) GO TO 210 + IF (DABS(E2(L)) .LE. DABS(C/H)) GO TO 210 + E2(L) = H * E2(L) + IF (E2(L) .NE. 0.0D0) GO TO 130 + 210 P = D(L) + F +C .......... ORDER EIGENVALUES .......... + IF (L .EQ. 1) GO TO 250 +C .......... FOR I=L STEP -1 UNTIL 2 DO -- .......... + DO 230 II = 2, L + I = L + 2 - II + IF (P .GE. D(I-1)) GO TO 270 + D(I) = D(I-1) + 230 CONTINUE +C + 250 I = 1 + 270 D(I) = P + 290 CONTINUE +C + GO TO 1001 +C .......... SET ERROR -- NO CONVERGENCE TO AN +C EIGENVALUE AFTER 30 ITERATIONS .......... + 1000 IERR = L + 1001 RETURN + END diff --git a/src/MyEis/tred1.f b/src/MyEis/tred1.f new file mode 100644 index 000000000..cf916ed32 --- /dev/null +++ b/src/MyEis/tred1.f @@ -0,0 +1,135 @@ + SUBROUTINE TRED1(NM,N,A,D,E,E2) +C + INTEGER I,J,K,L,N,II,NM,JP1 + DOUBLE PRECISION A(NM,N),D(N),E(N),E2(N) + DOUBLE PRECISION F,G,H,SCALE +C +C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED1, +C NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. +C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). +C +C THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX +C TO A SYMMETRIC TRIDIAGONAL MATRIX USING +C ORTHOGONAL SIMILARITY TRANSFORMATIONS. +C +C ON INPUT +C +C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL +C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM +C DIMENSION STATEMENT. +C +C N IS THE ORDER OF THE MATRIX. +C +C A CONTAINS THE REAL SYMMETRIC INPUT MATRIX. ONLY THE +C LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED. +C +C ON OUTPUT +C +C A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS- +C FORMATIONS USED IN THE REDUCTION IN ITS STRICT LOWER +C TRIANGLE. THE FULL UPPER TRIANGLE OF A IS UNALTERED. +C +C D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX. +C +C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL +C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO. +C +C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. +C E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. +C +C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, +C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY +C +C THIS VERSION DATED AUGUST 1983. +C +C ------------------------------------------------------------------ +C + DO 100 I = 1, N + D(I) = A(N,I) + A(N,I) = A(I,I) + 100 CONTINUE +C .......... FOR I=N STEP -1 UNTIL 1 DO -- .......... + DO 300 II = 1, N + I = N + 1 - II + L = I - 1 + H = 0.0D0 + SCALE = 0.0D0 + IF (L .LT. 1) GO TO 130 +C .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... + DO 120 K = 1, L + 120 SCALE = SCALE + DABS(D(K)) +C + IF (SCALE .NE. 0.0D0) GO TO 140 +C + DO 125 J = 1, L + D(J) = A(L,J) + A(L,J) = A(I,J) + A(I,J) = 0.0D0 + 125 CONTINUE +C + 130 E(I) = 0.0D0 + E2(I) = 0.0D0 + GO TO 300 +C + 140 DO 150 K = 1, L + D(K) = D(K) / SCALE + H = H + D(K) * D(K) + 150 CONTINUE +C + E2(I) = SCALE * SCALE * H + F = D(L) + G = -DSIGN(DSQRT(H),F) + E(I) = SCALE * G + H = H - F * G + D(L) = F - G + IF (L .EQ. 1) GO TO 285 +C .......... FORM A*U .......... + DO 170 J = 1, L + 170 E(J) = 0.0D0 +C + DO 240 J = 1, L + F = D(J) + G = E(J) + A(J,J) * F + JP1 = J + 1 + IF (L .LT. JP1) GO TO 220 +C + DO 200 K = JP1, L + G = G + A(K,J) * D(K) + E(K) = E(K) + A(K,J) * F + 200 CONTINUE +C + 220 E(J) = G + 240 CONTINUE +C .......... FORM P .......... + F = 0.0D0 +C + DO 245 J = 1, L + E(J) = E(J) / H + F = F + E(J) * D(J) + 245 CONTINUE +C + H = F / (H + H) +C .......... FORM Q .......... + DO 250 J = 1, L + 250 E(J) = E(J) - H * D(J) +C .......... FORM REDUCED A .......... + DO 280 J = 1, L + F = D(J) + G = E(J) +C + DO 260 K = J, L + 260 A(K,J) = A(K,J) - F * E(K) - G * D(K) +C + 280 CONTINUE +C + 285 DO 290 J = 1, L + F = D(J) + D(J) = A(L,J) + A(L,J) = A(I,J) + A(I,J) = F * SCALE + 290 CONTINUE +C + 300 CONTINUE +C + RETURN + END diff --git a/src/MyEis/tred2.f b/src/MyEis/tred2.f new file mode 100644 index 000000000..098703366 --- /dev/null +++ b/src/MyEis/tred2.f @@ -0,0 +1,164 @@ + SUBROUTINE TRED2(NM,N,A,D,E,Z) +C + INTEGER I,J,K,L,N,II,NM,JP1 + DOUBLE PRECISION A(NM,N),D(N),E(N),Z(NM,N) + DOUBLE PRECISION F,G,H,HH,SCALE +C +C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED2, +C NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. +C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). +C +C THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX TO A +C SYMMETRIC TRIDIAGONAL MATRIX USING AND ACCUMULATING +C ORTHOGONAL SIMILARITY TRANSFORMATIONS. +C +C ON INPUT +C +C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL +C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM +C DIMENSION STATEMENT. +C +C N IS THE ORDER OF THE MATRIX. +C +C A CONTAINS THE REAL SYMMETRIC INPUT MATRIX. ONLY THE +C LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED. +C +C ON OUTPUT +C +C D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX. +C +C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL +C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO. +C +C Z CONTAINS THE ORTHOGONAL TRANSFORMATION MATRIX +C PRODUCED IN THE REDUCTION. +C +C A AND Z MAY COINCIDE. IF DISTINCT, A IS UNALTERED. +C +C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, +C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY +C +C THIS VERSION DATED AUGUST 1983. +C +C ------------------------------------------------------------------ +C + DO 100 I = 1, N +C + DO 80 J = I, N + 80 Z(J,I) = A(J,I) +C + D(I) = A(N,I) + 100 CONTINUE +C + IF (N .EQ. 1) GO TO 510 +C .......... FOR I=N STEP -1 UNTIL 2 DO -- .......... + DO 300 II = 2, N + I = N + 2 - II + L = I - 1 + H = 0.0D0 + SCALE = 0.0D0 + IF (L .LT. 2) GO TO 130 +C .......... SCALE ROW (ALGOL TOL THEN NOT NEEDED) .......... + DO 120 K = 1, L + 120 SCALE = SCALE + DABS(D(K)) +C + IF (SCALE .NE. 0.0D0) GO TO 140 + 130 E(I) = D(L) +C + DO 135 J = 1, L + D(J) = Z(L,J) + Z(I,J) = 0.0D0 + Z(J,I) = 0.0D0 + 135 CONTINUE +C + GO TO 290 +C + 140 DO 150 K = 1, L + D(K) = D(K) / SCALE + H = H + D(K) * D(K) + 150 CONTINUE +C + F = D(L) + G = -DSIGN(DSQRT(H),F) + E(I) = SCALE * G + H = H - F * G + D(L) = F - G +C .......... FORM A*U .......... + DO 170 J = 1, L + 170 E(J) = 0.0D0 +C + DO 240 J = 1, L + F = D(J) + Z(J,I) = F + G = E(J) + Z(J,J) * F + JP1 = J + 1 + IF (L .LT. JP1) GO TO 220 +C + DO 200 K = JP1, L + G = G + Z(K,J) * D(K) + E(K) = E(K) + Z(K,J) * F + 200 CONTINUE +C + 220 E(J) = G + 240 CONTINUE +C .......... FORM P .......... + F = 0.0D0 +C + DO 245 J = 1, L + E(J) = E(J) / H + F = F + E(J) * D(J) + 245 CONTINUE +C + HH = F / (H + H) +C .......... FORM Q .......... + DO 250 J = 1, L + 250 E(J) = E(J) - HH * D(J) +C .......... FORM REDUCED A .......... + DO 280 J = 1, L + F = D(J) + G = E(J) +C + DO 260 K = J, L + 260 Z(K,J) = Z(K,J) - F * E(K) - G * D(K) +C + D(J) = Z(L,J) + Z(I,J) = 0.0D0 + 280 CONTINUE +C + 290 D(I) = H + 300 CONTINUE +C .......... ACCUMULATION OF TRANSFORMATION MATRICES .......... + DO 500 I = 2, N + L = I - 1 + Z(N,L) = Z(L,L) + Z(L,L) = 1.0D0 + H = D(I) + IF (H .EQ. 0.0D0) GO TO 380 +C + DO 330 K = 1, L + 330 D(K) = Z(K,I) / H +C + DO 360 J = 1, L + G = 0.0D0 +C + DO 340 K = 1, L + 340 G = G + Z(K,I) * Z(K,J) +C + DO 360 K = 1, L + Z(K,J) = Z(K,J) - G * D(K) + 360 CONTINUE +C + 380 DO 400 K = 1, L + 400 Z(K,I) = 0.0D0 +C + 500 CONTINUE +C + 510 DO 520 I = 1, N + D(I) = Z(N,I) + Z(N,I) = 0.0D0 + 520 CONTINUE +C + Z(N,N) = 1.0D0 + E(1) = 0.0D0 + RETURN + END diff --git a/src/MyLin/CMakeLists.txt b/src/MyLin/CMakeLists.txt new file mode 100644 index 000000000..07ef34f71 --- /dev/null +++ b/src/MyLin/CMakeLists.txt @@ -0,0 +1,12 @@ +# Eispack library +SET(LIN_src ${SRCLIN}/cgedi.f +${SRCLIN}/cgefa.f +${SRCLIN}/dgedi.f +${SRCLIN}/dgefa.f +${SRCLIN}/zgedi.f +${SRCLIN}/zgefa.f +${SRCLIN}/zqrdc.f +${SRCLIN}/zqrsl.f +) + +ADD_LIBRARY(${MYLIN} STATIC ${LIN_src}) diff --git a/src/MyLin/Makefile b/src/MyLin/Makefile new file mode 100644 index 000000000..6ab5dbefc --- /dev/null +++ b/src/MyLin/Makefile @@ -0,0 +1,8 @@ +LIB=liblin.a +OBJS= cgedi.o cgefa.o dgedi.o dgefa.o zgedi.o zgefa.o zqrdc.o zqrsl.o +$(LIB): $(OBJS) + ar r $(LIB) $(OBJS) +.f.o: + $(FC) $(FLAGS) $< +clean: + rm $(LIB) $(OBJS) diff --git a/src/MyLin/bidon b/src/MyLin/bidon new file mode 100644 index 000000000..dbea126e0 --- /dev/null +++ b/src/MyLin/bidon @@ -0,0 +1,6 @@ +dgedi.f +dgefa.f +zgedi.f +zgefa.f +zqrdc.f +zqrsl.f diff --git a/src/MyLin/cgedi.f b/src/MyLin/cgedi.f new file mode 100644 index 000000000..3467f3104 --- /dev/null +++ b/src/MyLin/cgedi.f @@ -0,0 +1,131 @@ + subroutine cgedi(a,lda,n,ipvt,det,work,job) + integer lda,n,ipvt(1),job + complex a(lda,1),det(2),work(1) +c +c cgedi computes the determinant and inverse of a matrix +c using the factors computed by cgeco or cgefa. +c +c on entry +c +c a complex(lda, n) +c the output from cgeco or cgefa. +c +c lda integer +c the leading dimension of the array a . +c +c n integer +c the order of the matrix a . +c +c ipvt integer(n) +c the pivot vector from cgeco or cgefa. +c +c work complex(n) +c work vector. contents destroyed. +c +c job integer +c = 11 both determinant and inverse. +c = 01 inverse only. +c = 10 determinant only. +c +c on return +c +c a inverse of original matrix if requested. +c otherwise unchanged. +c +c det complex(2) +c determinant of original matrix if requested. +c otherwise not referenced. +c determinant = det(1) * 10.0**det(2) +c with 1.0 .le. cabs1(det(1)) .lt. 10.0 +c or det(1) .eq. 0.0 . +c +c error condition +c +c a division by zero will occur if the input factor contains +c a zero on the diagonal and the inverse is requested. +c it will not occur if the subroutines are called correctly +c and if cgeco has set rcond .gt. 0.0 or cgefa has set +c info .eq. 0 . +c +c linpack. this version dated 08/14/78 . +c cleve moler, university of new mexico, argonne national lab. +c +c subroutines and functions +c +c blas caxpy,cscal,cswap +c fortran abs,aimag,cmplx,mod,real +c +c internal variables +c + complex t + real ten + integer i,j,k,kb,kp1,l,nm1 +c + complex zdum + real cabs1 + cabs1(zdum) = abs(real(zdum)) + abs(aimag(zdum)) +c +c compute determinant +c + if (job/10 .eq. 0) go to 70 + det(1) = (1.0e0,0.0e0) + det(2) = (0.0e0,0.0e0) + ten = 10.0e0 + do 50 i = 1, n + if (ipvt(i) .ne. i) det(1) = -det(1) + det(1) = a(i,i)*det(1) +c ...exit + if (cabs1(det(1)) .eq. 0.0e0) go to 60 + 10 if (cabs1(det(1)) .ge. 1.0e0) go to 20 + det(1) = cmplx(ten,0.0e0)*det(1) + det(2) = det(2) - (1.0e0,0.0e0) + go to 10 + 20 continue + 30 if (cabs1(det(1)) .lt. ten) go to 40 + det(1) = det(1)/cmplx(ten,0.0e0) + det(2) = det(2) + (1.0e0,0.0e0) + go to 30 + 40 continue + 50 continue + 60 continue + 70 continue +c +c compute inverse(u) +c + if (mod(job,10) .eq. 0) go to 150 + do 100 k = 1, n + a(k,k) = (1.0e0,0.0e0)/a(k,k) + t = -a(k,k) + call cscal(k-1,t,a(1,k),1) + kp1 = k + 1 + if (n .lt. kp1) go to 90 + do 80 j = kp1, n + t = a(k,j) + a(k,j) = (0.0e0,0.0e0) + call caxpy(k,t,a(1,k),1,a(1,j),1) + 80 continue + 90 continue + 100 continue +c +c form inverse(u)*inverse(l) +c + nm1 = n - 1 + if (nm1 .lt. 1) go to 140 + do 130 kb = 1, nm1 + k = n - kb + kp1 = k + 1 + do 110 i = kp1, n + work(i) = a(i,k) + a(i,k) = (0.0e0,0.0e0) + 110 continue + do 120 j = kp1, n + t = work(j) + call caxpy(n,t,a(1,j),1,a(1,k),1) + 120 continue + l = ipvt(k) + if (l .ne. k) call cswap(n,a(1,k),1,a(1,l),1) + 130 continue + 140 continue + 150 continue + return + end diff --git a/src/MyLin/cgefa.f b/src/MyLin/cgefa.f new file mode 100644 index 000000000..ba12cb860 --- /dev/null +++ b/src/MyLin/cgefa.f @@ -0,0 +1,107 @@ + subroutine cgefa(a,lda,n,ipvt,info) + integer lda,n,ipvt(1),info + complex a(lda,1) +c +c cgefa factors a complex matrix by gaussian elimination. +c +c cgefa is usually called by cgeco, but it can be called +c directly with a saving in time if rcond is not needed. +c (time for cgeco) = (1 + 9/n)*(time for cgefa) . +c +c on entry +c +c a complex(lda, n) +c the matrix to be factored. +c +c lda integer +c the leading dimension of the array a . +c +c n integer +c the order of the matrix a . +c +c on return +c +c a an upper triangular matrix and the multipliers +c which were used to obtain it. +c the factorization can be written a = l*u where +c l is a product of permutation and unit lower +c triangular matrices and u is upper triangular. +c +c ipvt integer(n) +c an integer vector of pivot indices. +c +c info integer +c = 0 normal value. +c = k if u(k,k) .eq. 0.0 . this is not an error +c condition for this subroutine, but it does +c indicate that cgesl or cgedi will divide by zero +c if called. use rcond in cgeco for a reliable +c indication of singularity. +c +c linpack. this version dated 08/14/78 . +c cleve moler, university of new mexico, argonne national lab. +c +c subroutines and functions +c +c blas caxpy,cscal,icamax +c fortran abs,aimag,real +c +c internal variables +c + complex t + integer icamax,j,k,kp1,l,nm1 +c + complex zdum + real cabs1 + cabs1(zdum) = abs(real(zdum)) + abs(aimag(zdum)) +c +c gaussian elimination with partial pivoting +c + info = 0 + nm1 = n - 1 + if (nm1 .lt. 1) go to 70 + do 60 k = 1, nm1 + kp1 = k + 1 +c +c find l = pivot index +c + l = icamax(n-k+1,a(k,k),1) + k - 1 + ipvt(k) = l +c +c zero pivot implies this column already triangularized +c + if (cabs1(a(l,k)) .eq. 0.0e0) go to 40 +c +c interchange if necessary +c + if (l .eq. k) go to 10 + t = a(l,k) + a(l,k) = a(k,k) + a(k,k) = t + 10 continue +c +c compute multipliers +c + t = -(1.0e0,0.0e0)/a(k,k) + call cscal(n-k,t,a(k+1,k),1) +c +c row elimination with column indexing +c + do 30 j = kp1, n + t = a(l,j) + if (l .eq. k) go to 20 + a(l,j) = a(k,j) + a(k,j) = t + 20 continue + call caxpy(n-k,t,a(k+1,k),1,a(k+1,j),1) + 30 continue + go to 50 + 40 continue + info = k + 50 continue + 60 continue + 70 continue + ipvt(n) = n + if (cabs1(a(n,n)) .eq. 0.0e0) info = n + return + end diff --git a/src/MyLin/dgedi.f b/src/MyLin/dgedi.f new file mode 100644 index 000000000..2c02b62b3 --- /dev/null +++ b/src/MyLin/dgedi.f @@ -0,0 +1,128 @@ + subroutine dgedi(a,lda,n,ipvt,det,work,job) + integer lda,n,ipvt(1),job + double precision a(lda,1),det(2),work(1) +c +c dgedi computes the determinant and inverse of a matrix +c using the factors computed by dgeco or dgefa. +c +c on entry +c +c a double precision(lda, n) +c the output from dgeco or dgefa. +c +c lda integer +c the leading dimension of the array a . +c +c n integer +c the order of the matrix a . +c +c ipvt integer(n) +c the pivot vector from dgeco or dgefa. +c +c work double precision(n) +c work vector. contents destroyed. +c +c job integer +c = 11 both determinant and inverse. +c = 01 inverse only. +c = 10 determinant only. +c +c on return +c +c a inverse of original matrix if requested. +c otherwise unchanged. +c +c det double precision(2) +c determinant of original matrix if requested. +c otherwise not referenced. +c determinant = det(1) * 10.0**det(2) +c with 1.0 .le. dabs(det(1)) .lt. 10.0 +c or det(1) .eq. 0.0 . +c +c error condition +c +c a division by zero will occur if the input factor contains +c a zero on the diagonal and the inverse is requested. +c it will not occur if the subroutines are called correctly +c and if dgeco has set rcond .gt. 0.0 or dgefa has set +c info .eq. 0 . +c +c linpack. this version dated 08/14/78 . +c cleve moler, university of new mexico, argonne national lab. +c +c subroutines and functions +c +c blas daxpy,dscal,dswap +c fortran dabs,mod +c +c internal variables +c + double precision t + double precision ten + integer i,j,k,kb,kp1,l,nm1 +c +c +c compute determinant +c + if (job/10 .eq. 0) go to 70 + det(1) = 1.0d0 + det(2) = 0.0d0 + ten = 10.0d0 + do 50 i = 1, n + if (ipvt(i) .ne. i) det(1) = -det(1) + det(1) = a(i,i)*det(1) +c ...exit + if (det(1) .eq. 0.0d0) go to 60 + 10 if (dabs(det(1)) .ge. 1.0d0) go to 20 + det(1) = ten*det(1) + det(2) = det(2) - 1.0d0 + go to 10 + 20 continue + 30 if (dabs(det(1)) .lt. ten) go to 40 + det(1) = det(1)/ten + det(2) = det(2) + 1.0d0 + go to 30 + 40 continue + 50 continue + 60 continue + 70 continue +c +c compute inverse(u) +c + if (mod(job,10) .eq. 0) go to 150 + do 100 k = 1, n + a(k,k) = 1.0d0/a(k,k) + t = -a(k,k) + call dscal(k-1,t,a(1,k),1) + kp1 = k + 1 + if (n .lt. kp1) go to 90 + do 80 j = kp1, n + t = a(k,j) + a(k,j) = 0.0d0 + call daxpy(k,t,a(1,k),1,a(1,j),1) + 80 continue + 90 continue + 100 continue +c +c form inverse(u)*inverse(l) +c + nm1 = n - 1 + if (nm1 .lt. 1) go to 140 + do 130 kb = 1, nm1 + k = n - kb + kp1 = k + 1 + do 110 i = kp1, n + work(i) = a(i,k) + a(i,k) = 0.0d0 + 110 continue + do 120 j = kp1, n + t = work(j) + call daxpy(n,t,a(1,j),1,a(1,k),1) + 120 continue + l = ipvt(k) + if (l .ne. k) call dswap(n,a(1,k),1,a(1,l),1) + 130 continue + 140 continue + 150 continue + return + end diff --git a/src/MyLin/dgefa.f b/src/MyLin/dgefa.f new file mode 100644 index 000000000..37d705f14 --- /dev/null +++ b/src/MyLin/dgefa.f @@ -0,0 +1,103 @@ + subroutine dgefa(a,lda,n,ipvt,info) + integer lda,n,ipvt(1),info + double precision a(lda,1) +c +c dgefa factors a double precision matrix by gaussian elimination. +c +c dgefa is usually called by dgeco, but it can be called +c directly with a saving in time if rcond is not needed. +c (time for dgeco) = (1 + 9/n)*(time for dgefa) . +c +c on entry +c +c a double precision(lda, n) +c the matrix to be factored. +c +c lda integer +c the leading dimension of the array a . +c +c n integer +c the order of the matrix a . +c +c on return +c +c a an upper triangular matrix and the multipliers +c which were used to obtain it. +c the factorization can be written a = l*u where +c l is a product of permutation and unit lower +c triangular matrices and u is upper triangular. +c +c ipvt integer(n) +c an integer vector of pivot indices. +c +c info integer +c = 0 normal value. +c = k if u(k,k) .eq. 0.0 . this is not an error +c condition for this subroutine, but it does +c indicate that dgesl or dgedi will divide by zero +c if called. use rcond in dgeco for a reliable +c indication of singularity. +c +c linpack. this version dated 08/14/78 . +c cleve moler, university of new mexico, argonne national lab. +c +c subroutines and functions +c +c blas daxpy,dscal,idamax +c +c internal variables +c + double precision t + integer idamax,j,k,kp1,l,nm1 +c +c +c gaussian elimination with partial pivoting +c + info = 0 + nm1 = n - 1 + if (nm1 .lt. 1) go to 70 + do 60 k = 1, nm1 + kp1 = k + 1 +c +c find l = pivot index +c + l = idamax(n-k+1,a(k,k),1) + k - 1 + ipvt(k) = l +c +c zero pivot implies this column already triangularized +c + if (a(l,k) .eq. 0.0d0) go to 40 +c +c interchange if necessary +c + if (l .eq. k) go to 10 + t = a(l,k) + a(l,k) = a(k,k) + a(k,k) = t + 10 continue +c +c compute multipliers +c + t = -1.0d0/a(k,k) + call dscal(n-k,t,a(k+1,k),1) +c +c row elimination with column indexing +c + do 30 j = kp1, n + t = a(l,j) + if (l .eq. k) go to 20 + a(l,j) = a(k,j) + a(k,j) = t + 20 continue + call daxpy(n-k,t,a(k+1,k),1,a(k+1,j),1) + 30 continue + go to 50 + 40 continue + info = k + 50 continue + 60 continue + 70 continue + ipvt(n) = n + if (a(n,n) .eq. 0.0d0) info = n + return + end diff --git a/src/MyLin/work.pc b/src/MyLin/work.pc new file mode 100644 index 0000000000000000000000000000000000000000..285842ebb80eef69e4e17d1058603f49efe83fba GIT binary patch literal 1016 zcmZ9KJ4*vW6os#bn6)y9h>uPMA&7*OB4W%MQBwG-L|B$t69ReZMvYU5rKP2%rC9nq zEUhiA{0)ic&dw~88JNtO`}pq3u(|EttqA)&%U+!pi!(IsHE3;qjyxhNVjoWuy-yJ3 z*NGr0L%3jZ-Kwq|VR4L4&dy?Iu$OcU$Jk;<2@%8Cf_51`V$7&nImmP|qmG;L+kti& z1H_o|WaS{!#f(?n4C4*jWqcsUj87{EnJ#90;bs`$&@ST#u`Kqlm4i$dGxB&i^BxP( zE@K5T_EE5MDFA{Qdluu!s$&+ebdDcpTv|Doafh7wFOOE8VLWTbi&=3!XAW zk2F)109EQKQcsa_G6fyg@+j#@rl2F4BGr^#w--}RPW=iylh-$qU}s9GDNM~#Bs(|l zQs7y=QMWI+Le0-o#k_|wPL)7~&`yPRDzsB{RLg&uio(RH68s)QIUTya%IR6HkT{K7 Q+G)(MEk#$owjA^I4?RovNB{r; literal 0 HcmV?d00001 diff --git a/src/MyLin/work.pcl b/src/MyLin/work.pcl new file mode 100644 index 000000000..7f6c06e22 --- /dev/null +++ b/src/MyLin/work.pcl @@ -0,0 +1 @@ +work.pc diff --git a/src/MyLin/zgedi.f b/src/MyLin/zgedi.f new file mode 100644 index 000000000..eab9c9052 --- /dev/null +++ b/src/MyLin/zgedi.f @@ -0,0 +1,135 @@ + subroutine zgedi(a,lda,n,ipvt,det,work,job) + integer lda,n,ipvt(1),job + complex*16 a(lda,1),det(2),work(1) +c +c zgedi computes the determinant and inverse of a matrix +c using the factors computed by zgeco or zgefa. +c +c on entry +c +c a complex*16(lda, n) +c the output from zgeco or zgefa. +c +c lda integer +c the leading dimension of the array a . +c +c n integer +c the order of the matrix a . +c +c ipvt integer(n) +c the pivot vector from zgeco or zgefa. +c +c work complex*16(n) +c work vector. contents destroyed. +c +c job integer +c = 11 both determinant and inverse. +c = 01 inverse only. +c = 10 determinant only. +c +c on return +c +c a inverse of original matrix if requested. +c otherwise unchanged. +c +c det complex*16(2) +c determinant of original matrix if requested. +c otherwise not referenced. +c determinant = det(1) * 10.0**det(2) +c with 1.0 .le. cabs1(det(1)) .lt. 10.0 +c or det(1) .eq. 0.0 . +c +c error condition +c +c a division by zero will occur if the input factor contains +c a zero on the diagonal and the inverse is requested. +c it will not occur if the subroutines are called correctly +c and if zgeco has set rcond .gt. 0.0 or zgefa has set +c info .eq. 0 . +c +c linpack. this version dated 08/14/78 . +c cleve moler, university of new mexico, argonne national lab. +c +c subroutines and functions +c +c blas zaxpy,zscal,zswap +c fortran dabs,dcmplx,mod +c +c internal variables +c + complex*16 t + double precision ten + integer i,j,k,kb,kp1,l,nm1 +c + complex*16 zdum + double precision cabs1 + double precision dreal,dimag + complex*16 zdumr,zdumi + dreal(zdumr) = zdumr + dimag(zdumi) = (0.0d0,-1.0d0)*zdumi + cabs1(zdum) = dabs(dreal(zdum)) + dabs(dimag(zdum)) +c +c compute determinant +c + if (job/10 .eq. 0) go to 70 + det(1) = (1.0d0,0.0d0) + det(2) = (0.0d0,0.0d0) + ten = 10.0d0 + do 50 i = 1, n + if (ipvt(i) .ne. i) det(1) = -det(1) + det(1) = a(i,i)*det(1) +c ...exit + if (cabs1(det(1)) .eq. 0.0d0) go to 60 + 10 if (cabs1(det(1)) .ge. 1.0d0) go to 20 + det(1) = dcmplx(ten,0.0d0)*det(1) + det(2) = det(2) - (1.0d0,0.0d0) + go to 10 + 20 continue + 30 if (cabs1(det(1)) .lt. ten) go to 40 + det(1) = det(1)/dcmplx(ten,0.0d0) + det(2) = det(2) + (1.0d0,0.0d0) + go to 30 + 40 continue + 50 continue + 60 continue + 70 continue +c +c compute inverse(u) +c + if (mod(job,10) .eq. 0) go to 150 + do 100 k = 1, n + a(k,k) = (1.0d0,0.0d0)/a(k,k) + t = -a(k,k) + call zscal(k-1,t,a(1,k),1) + kp1 = k + 1 + if (n .lt. kp1) go to 90 + do 80 j = kp1, n + t = a(k,j) + a(k,j) = (0.0d0,0.0d0) + call zaxpy(k,t,a(1,k),1,a(1,j),1) + 80 continue + 90 continue + 100 continue +c +c form inverse(u)*inverse(l) +c + nm1 = n - 1 + if (nm1 .lt. 1) go to 140 + do 130 kb = 1, nm1 + k = n - kb + kp1 = k + 1 + do 110 i = kp1, n + work(i) = a(i,k) + a(i,k) = (0.0d0,0.0d0) + 110 continue + do 120 j = kp1, n + t = work(j) + call zaxpy(n,t,a(1,j),1,a(1,k),1) + 120 continue + l = ipvt(k) + if (l .ne. k) call zswap(n,a(1,k),1,a(1,l),1) + 130 continue + 140 continue + 150 continue + return + end diff --git a/src/MyLin/zgefa.f b/src/MyLin/zgefa.f new file mode 100644 index 000000000..f5dba9739 --- /dev/null +++ b/src/MyLin/zgefa.f @@ -0,0 +1,111 @@ + subroutine zgefa(a,lda,n,ipvt,info) + integer lda,n,ipvt(1),info + complex*16 a(lda,1) +c +c zgefa factors a complex*16 matrix by gaussian elimination. +c +c zgefa is usually called by zgeco, but it can be called +c directly with a saving in time if rcond is not needed. +c (time for zgeco) = (1 + 9/n)*(time for zgefa) . +c +c on entry +c +c a complex*16(lda, n) +c the matrix to be factored. +c +c lda integer +c the leading dimension of the array a . +c +c n integer +c the order of the matrix a . +c +c on return +c +c a an upper triangular matrix and the multipliers +c which were used to obtain it. +c the factorization can be written a = l*u where +c l is a product of permutation and unit lower +c triangular matrices and u is upper triangular. +c +c ipvt integer(n) +c an integer vector of pivot indices. +c +c info integer +c = 0 normal value. +c = k if u(k,k) .eq. 0.0 . this is not an error +c condition for this subroutine, but it does +c indicate that zgesl or zgedi will divide by zero +c if called. use rcond in zgeco for a reliable +c indication of singularity. +c +c linpack. this version dated 08/14/78 . +c cleve moler, university of new mexico, argonne national lab. +c +c subroutines and functions +c +c blas zaxpy,zscal,izamax +c fortran dabs +c +c internal variables +c + complex*16 t + integer izamax,j,k,kp1,l,nm1 +c + complex*16 zdum + double precision cabs1 + double precision dreal,dimag + complex*16 zdumr,zdumi + dreal(zdumr) = zdumr + dimag(zdumi) = (0.0d0,-1.0d0)*zdumi + cabs1(zdum) = dabs(dreal(zdum)) + dabs(dimag(zdum)) +c +c gaussian elimination with partial pivoting +c + info = 0 + nm1 = n - 1 + if (nm1 .lt. 1) go to 70 + do 60 k = 1, nm1 + kp1 = k + 1 +c +c find l = pivot index +c + l = izamax(n-k+1,a(k,k),1) + k - 1 + ipvt(k) = l +c +c zero pivot implies this column already triangularized +c + if (cabs1(a(l,k)) .eq. 0.0d0) go to 40 +c +c interchange if necessary +c + if (l .eq. k) go to 10 + t = a(l,k) + a(l,k) = a(k,k) + a(k,k) = t + 10 continue +c +c compute multipliers +c + t = -(1.0d0,0.0d0)/a(k,k) + call zscal(n-k,t,a(k+1,k),1) +c +c row elimination with column indexing +c + do 30 j = kp1, n + t = a(l,j) + if (l .eq. k) go to 20 + a(l,j) = a(k,j) + a(k,j) = t + 20 continue + call zaxpy(n-k,t,a(k+1,k),1,a(k+1,j),1) + 30 continue + go to 50 + 40 continue + info = k + 50 continue + 60 continue + 70 continue + ipvt(n) = n + if (cabs1(a(n,n)) .eq. 0.0d0) info = n + return + end diff --git a/src/MyLin/zqrdc.f b/src/MyLin/zqrdc.f new file mode 100644 index 000000000..fd81c52a9 --- /dev/null +++ b/src/MyLin/zqrdc.f @@ -0,0 +1,218 @@ + subroutine zqrdc(x,ldx,n,p,qraux,jpvt,work,job) + integer ldx,n,p,job + integer jpvt(1) + complex*16 x(ldx,1),qraux(1),work(1) +c +c zqrdc uses householder transformations to compute the qr +c factorization of an n by p matrix x. column pivoting +c based on the 2-norms of the reduced columns may be +c performed at the users option. +c +c on entry +c +c x complex*16(ldx,p), where ldx .ge. n. +c x contains the matrix whose decomposition is to be +c computed. +c +c ldx integer. +c ldx is the leading dimension of the array x. +c +c n integer. +c n is the number of rows of the matrix x. +c +c p integer. +c p is the number of columns of the matrix x. +c +c jpvt integer(p). +c jpvt contains integers that control the selection +c of the pivot columns. the k-th column x(k) of x +c is placed in one of three classes according to the +c value of jpvt(k). +c +c if jpvt(k) .gt. 0, then x(k) is an initial +c column. +c +c if jpvt(k) .eq. 0, then x(k) is a free column. +c +c if jpvt(k) .lt. 0, then x(k) is a final column. +c +c before the decomposition is computed, initial columns +c are moved to the beginning of the array x and final +c columns to the end. both initial and final columns +c are frozen in place during the computation and only +c free columns are moved. at the k-th stage of the +c reduction, if x(k) is occupied by a free column +c it is interchanged with the free column of largest +c reduced norm. jpvt is not referenced if +c job .eq. 0. +c +c work complex*16(p). +c work is a work array. work is not referenced if +c job .eq. 0. +c +c job integer. +c job is an integer that initiates column pivoting. +c if job .eq. 0, no pivoting is done. +c if job .ne. 0, pivoting is done. +c +c on return +c +c x x contains in its upper triangle the upper +c triangular matrix r of the qr factorization. +c below its diagonal x contains information from +c which the unitary part of the decomposition +c can be recovered. note that if pivoting has +c been requested, the decomposition is not that +c of the original matrix x but that of x +c with its columns permuted as described by jpvt. +c +c qraux complex*16(p). +c qraux contains further information required to recover +c the unitary part of the decomposition. +c +c jpvt jpvt(k) contains the index of the column of the +c original matrix that has been interchanged into +c the k-th column, if pivoting was requested. +c +c linpack. this version dated 08/14/78 . +c g.w. stewart, university of maryland, argonne national lab. +c +c zqrdc uses the following functions and subprograms. +c +c blas zaxpy,zdotc,zscal,zswap,dznrm2 +c fortran dabs,dmax1,cdabs,dcmplx,cdsqrt,min0 +c +c internal variables +c + integer j,jp,l,lp1,lup,maxj,pl,pu + double precision maxnrm,dznrm2,tt + complex*16 zdotc,nrmxl,t + logical negj,swapj +c + complex*16 csign,zdum,zdum1,zdum2 + double precision cabs1 + double precision dreal,dimag + complex*16 zdumr,zdumi + dreal(zdumr) = zdumr + dimag(zdumi) = (0.0d0,-1.0d0)*zdumi + csign(zdum1,zdum2) = cdabs(zdum1)*(zdum2/cdabs(zdum2)) + cabs1(zdum) = dabs(dreal(zdum)) + dabs(dimag(zdum)) +c + pl = 1 + pu = 0 + if (job .eq. 0) go to 60 +c +c pivoting has been requested. rearrange the columns +c according to jpvt. +c + do 20 j = 1, p + swapj = jpvt(j) .gt. 0 + negj = jpvt(j) .lt. 0 + jpvt(j) = j + if (negj) jpvt(j) = -j + if (.not.swapj) go to 10 + if (j .ne. pl) call zswap(n,x(1,pl),1,x(1,j),1) + jpvt(j) = jpvt(pl) + jpvt(pl) = j + pl = pl + 1 + 10 continue + 20 continue + pu = p + do 50 jj = 1, p + j = p - jj + 1 + if (jpvt(j) .ge. 0) go to 40 + jpvt(j) = -jpvt(j) + if (j .eq. pu) go to 30 + call zswap(n,x(1,pu),1,x(1,j),1) + jp = jpvt(pu) + jpvt(pu) = jpvt(j) + jpvt(j) = jp + 30 continue + pu = pu - 1 + 40 continue + 50 continue + 60 continue +c +c compute the norms of the free columns. +c + if (pu .lt. pl) go to 80 + do 70 j = pl, pu + qraux(j) = dcmplx(dznrm2(n,x(1,j),1),0.0d0) + work(j) = qraux(j) + 70 continue + 80 continue +c +c perform the householder reduction of x. +c + lup = min0(n,p) + do 200 l = 1, lup + if (l .lt. pl .or. l .ge. pu) go to 120 +c +c locate the column of largest norm and bring it +c into the pivot position. +c + maxnrm = 0.0d0 + maxj = l + do 100 j = l, pu + if (dreal(qraux(j)) .le. maxnrm) go to 90 + maxnrm = dreal(qraux(j)) + maxj = j + 90 continue + 100 continue + if (maxj .eq. l) go to 110 + call zswap(n,x(1,l),1,x(1,maxj),1) + qraux(maxj) = qraux(l) + work(maxj) = work(l) + jp = jpvt(maxj) + jpvt(maxj) = jpvt(l) + jpvt(l) = jp + 110 continue + 120 continue + qraux(l) = (0.0d0,0.0d0) + if (l .eq. n) go to 190 +c +c compute the householder transformation for column l. +c + nrmxl = dcmplx(dznrm2(n-l+1,x(l,l),1),0.0d0) + if (cabs1(nrmxl) .eq. 0.0d0) go to 180 + if (cabs1(x(l,l)) .ne. 0.0d0) + * nrmxl = csign(nrmxl,x(l,l)) + call zscal(n-l+1,(1.0d0,0.0d0)/nrmxl,x(l,l),1) + x(l,l) = (1.0d0,0.0d0) + x(l,l) +c +c apply the transformation to the remaining columns, +c updating the norms. +c + lp1 = l + 1 + if (p .lt. lp1) go to 170 + do 160 j = lp1, p + t = -zdotc(n-l+1,x(l,l),1,x(l,j),1)/x(l,l) + call zaxpy(n-l+1,t,x(l,l),1,x(l,j),1) + if (j .lt. pl .or. j .gt. pu) go to 150 + if (cabs1(qraux(j)) .eq. 0.0d0) go to 150 + tt = 1.0d0 - (cdabs(x(l,j))/dreal(qraux(j)))**2 + tt = dmax1(tt,0.0d0) + t = dcmplx(tt,0.0d0) + tt = 1.0d0 + * + 0.05d0*tt + * *(dreal(qraux(j))/dreal(work(j)))**2 + if (tt .eq. 1.0d0) go to 130 + qraux(j) = qraux(j)*cdsqrt(t) + go to 140 + 130 continue + qraux(j) = dcmplx(dznrm2(n-l,x(l+1,j),1),0.0d0) + work(j) = qraux(j) + 140 continue + 150 continue + 160 continue + 170 continue +c +c save the transformation. +c + qraux(l) = x(l,l) + x(l,l) = -nrmxl + 180 continue + 190 continue + 200 continue + return + end diff --git a/src/MyLin/zqrsl.f b/src/MyLin/zqrsl.f new file mode 100644 index 000000000..6ee5f382b --- /dev/null +++ b/src/MyLin/zqrsl.f @@ -0,0 +1,280 @@ + subroutine zqrsl(x,ldx,n,k,qraux,y,qy,qty,b,rsd,xb,job,info) + integer ldx,n,k,job,info + complex*16 x(ldx,1),qraux(1),y(1),qy(1),qty(1),b(1),rsd(1),xb(1) +c +c zqrsl applies the output of zqrdc to compute coordinate +c transformations, projections, and least squares solutions. +c for k .le. min(n,p), let xk be the matrix +c +c xk = (x(jpvt(1)),x(jpvt(2)), ... ,x(jpvt(k))) +c +c formed from columnns jpvt(1), ... ,jpvt(k) of the original +c n x p matrix x that was input to zqrdc (if no pivoting was +c done, xk consists of the first k columns of x in their +c original order). zqrdc produces a factored unitary matrix q +c and an upper triangular matrix r such that +c +c xk = q * (r) +c (0) +c +c this information is contained in coded form in the arrays +c x and qraux. +c +c on entry +c +c x complex*16(ldx,p). +c x contains the output of zqrdc. +c +c ldx integer. +c ldx is the leading dimension of the array x. +c +c n integer. +c n is the number of rows of the matrix xk. it must +c have the same value as n in zqrdc. +c +c k integer. +c k is the number of columns of the matrix xk. k +c must nnot be greater than min(n,p), where p is the +c same as in the calling sequence to zqrdc. +c +c qraux complex*16(p). +c qraux contains the auxiliary output from zqrdc. +c +c y complex*16(n) +c y contains an n-vector that is to be manipulated +c by zqrsl. +c +c job integer. +c job specifies what is to be computed. job has +c the decimal expansion abcde, with the following +c meaning. +c +c if a.ne.0, compute qy. +c if b,c,d, or e .ne. 0, compute qty. +c if c.ne.0, compute b. +c if d.ne.0, compute rsd. +c if e.ne.0, compute xb. +c +c note that a request to compute b, rsd, or xb +c automatically triggers the computation of qty, for +c which an array must be provided in the calling +c sequence. +c +c on return +c +c qy complex*16(n). +c qy conntains q*y, if its computation has been +c requested. +c +c qty complex*16(n). +c qty contains ctrans(q)*y, if its computation has +c been requested. here ctrans(q) is the conjugate +c transpose of the matrix q. +c +c b complex*16(k) +c b contains the solution of the least squares problem +c +c minimize norm2(y - xk*b), +c +c if its computation has been requested. (note that +c if pivoting was requested in zqrdc, the j-th +c component of b will be associated with column jpvt(j) +c of the original matrix x that was input into zqrdc.) +c +c rsd complex*16(n). +c rsd contains the least squares residual y - xk*b, +c if its computation has been requested. rsd is +c also the orthogonal projection of y onto the +c orthogonal complement of the column space of xk. +c +c xb complex*16(n). +c xb contains the least squares approximation xk*b, +c if its computation has been requested. xb is also +c the orthogonal projection of y onto the column space +c of x. +c +c info integer. +c info is zero unless the computation of b has +c been requested and r is exactly singular. in +c this case, info is the index of the first zero +c diagonal element of r and b is left unaltered. +c +c the parameters qy, qty, b, rsd, and xb are not referenced +c if their computation is not requested and in this case +c can be replaced by dummy variables in the calling program. +c to save storage, the user may in some cases use the same +c array for different parameters in the calling sequence. a +c frequently occuring example is when one wishes to compute +c any of b, rsd, or xb and does not need y or qty. in this +c case one may identify y, qty, and one of b, rsd, or xb, while +c providing separate arrays for anything else that is to be +c computed. thus the calling sequence +c +c call zqrsl(x,ldx,n,k,qraux,y,dum,y,b,y,dum,110,info) +c +c will result in the computation of b and rsd, with rsd +c overwriting y. more generally, each item in the following +c list contains groups of permissible identifications for +c a single callinng sequence. +c +c 1. (y,qty,b) (rsd) (xb) (qy) +c +c 2. (y,qty,rsd) (b) (xb) (qy) +c +c 3. (y,qty,xb) (b) (rsd) (qy) +c +c 4. (y,qy) (qty,b) (rsd) (xb) +c +c 5. (y,qy) (qty,rsd) (b) (xb) +c +c 6. (y,qy) (qty,xb) (b) (rsd) +c +c in any group the value returned in the array allocated to +c the group corresponds to the last member of the group. +c +c linpack. this version dated 08/14/78 . +c g.w. stewart, university of maryland, argonne national lab. +c +c zqrsl uses the following functions and subprograms. +c +c blas zaxpy,zcopy,zdotc +c fortran dabs,min0,mod +c +c internal variables +c + integer i,j,jj,ju,kp1 + complex*16 zdotc,t,temp + logical cb,cqy,cqty,cr,cxb +c + complex*16 zdum + double precision cabs1 + double precision dreal,dimag + complex*16 zdumr,zdumi + dreal(zdumr) = zdumr + dimag(zdumi) = (0.0d0,-1.0d0)*zdumi + cabs1(zdum) = dabs(dreal(zdum)) + dabs(dimag(zdum)) +c +c set info flag. +c + info = 0 +c +c determine what is to be computed. +c + cqy = job/10000 .ne. 0 + cqty = mod(job,10000) .ne. 0 + cb = mod(job,1000)/100 .ne. 0 + cr = mod(job,100)/10 .ne. 0 + cxb = mod(job,10) .ne. 0 + ju = min0(k,n-1) +c +c special action when n=1. +c + if (ju .ne. 0) go to 40 + if (cqy) qy(1) = y(1) + if (cqty) qty(1) = y(1) + if (cxb) xb(1) = y(1) + if (.not.cb) go to 30 + if (cabs1(x(1,1)) .ne. 0.0d0) go to 10 + info = 1 + go to 20 + 10 continue + b(1) = y(1)/x(1,1) + 20 continue + 30 continue + if (cr) rsd(1) = (0.0d0,0.0d0) + go to 250 + 40 continue +c +c set up to compute qy or qty. +c + if (cqy) call zcopy(n,y,1,qy,1) + if (cqty) call zcopy(n,y,1,qty,1) + if (.not.cqy) go to 70 +c +c compute qy. +c + do 60 jj = 1, ju + j = ju - jj + 1 + if (cabs1(qraux(j)) .eq. 0.0d0) go to 50 + temp = x(j,j) + x(j,j) = qraux(j) + t = -zdotc(n-j+1,x(j,j),1,qy(j),1)/x(j,j) + call zaxpy(n-j+1,t,x(j,j),1,qy(j),1) + x(j,j) = temp + 50 continue + 60 continue + 70 continue + if (.not.cqty) go to 100 +c +c compute ctrans(q)*y. +c + do 90 j = 1, ju + if (cabs1(qraux(j)) .eq. 0.0d0) go to 80 + temp = x(j,j) + x(j,j) = qraux(j) + t = -zdotc(n-j+1,x(j,j),1,qty(j),1)/x(j,j) + call zaxpy(n-j+1,t,x(j,j),1,qty(j),1) + x(j,j) = temp + 80 continue + 90 continue + 100 continue +c +c set up to compute b, rsd, or xb. +c + if (cb) call zcopy(k,qty,1,b,1) + kp1 = k + 1 + if (cxb) call zcopy(k,qty,1,xb,1) + if (cr .and. k .lt. n) call zcopy(n-k,qty(kp1),1,rsd(kp1),1) + if (.not.cxb .or. kp1 .gt. n) go to 120 + do 110 i = kp1, n + xb(i) = (0.0d0,0.0d0) + 110 continue + 120 continue + if (.not.cr) go to 140 + do 130 i = 1, k + rsd(i) = (0.0d0,0.0d0) + 130 continue + 140 continue + if (.not.cb) go to 190 +c +c compute b. +c + do 170 jj = 1, k + j = k - jj + 1 + if (cabs1(x(j,j)) .ne. 0.0d0) go to 150 + info = j +c ......exit + go to 180 + 150 continue + b(j) = b(j)/x(j,j) + if (j .eq. 1) go to 160 + t = -b(j) + call zaxpy(j-1,t,x(1,j),1,b,1) + 160 continue + 170 continue + 180 continue + 190 continue + if (.not.cr .and. .not.cxb) go to 240 +c +c compute rsd or xb as required. +c + do 230 jj = 1, ju + j = ju - jj + 1 + if (cabs1(qraux(j)) .eq. 0.0d0) go to 220 + temp = x(j,j) + x(j,j) = qraux(j) + if (.not.cr) go to 200 + t = -zdotc(n-j+1,x(j,j),1,rsd(j),1)/x(j,j) + call zaxpy(n-j+1,t,x(j,j),1,rsd(j),1) + 200 continue + if (.not.cxb) go to 210 + t = -zdotc(n-j+1,x(j,j),1,xb(j),1)/x(j,j) + call zaxpy(n-j+1,t,x(j,j),1,xb(j),1) + 210 continue + x(j,j) = temp + 220 continue + 230 continue + 240 continue + 250 continue + return + end diff --git a/src/MyNag/CMakeLists.txt b/src/MyNag/CMakeLists.txt new file mode 100644 index 000000000..7eb8c6eaa --- /dev/null +++ b/src/MyNag/CMakeLists.txt @@ -0,0 +1,26 @@ +# Eispack library +SET(NAG_src ${SRCNAG}/F01QCF.f +${SRCNAG}/F01QDF.f +${SRCNAG}/F01QEF.f +${SRCNAG}/F01RCF.f +${SRCNAG}/F01REF.f +${SRCNAG}/F06AAZ.f +${SRCNAG}/F06FBF.f +${SRCNAG}/F06FJF.f +${SRCNAG}/F06FRF.f +${SRCNAG}/F06HBF.f +${SRCNAG}/F06HRF.f +${SRCNAG}/F06QHF.f +${SRCNAG}/F06KJF.f +${SRCNAG}/F06THF.f +${SRCNAG}/P01ABF.f +${SRCNAG}/P01ABW.f +${SRCNAG}/P01ABZ.f +${SRCNAG}/P01ABY.f +${SRCNAG}/P01ACF.f +${SRCNAG}/X02AJF.f +${SRCNAG}/X04AAF.f +${SRCNAG}/X04BAF.f +) + +ADD_LIBRARY(${MYNAG} STATIC ${NAG_src}) diff --git a/src/MyNag/F01QCF.f b/src/MyNag/F01QCF.f new file mode 100644 index 000000000..d597b551e --- /dev/null +++ b/src/MyNag/F01QCF.f @@ -0,0 +1,258 @@ + SUBROUTINE F01QCF(M,N,A,LDA,ZETA,IFAIL) +C MARK 14 RELEASE. NAG COPYRIGHT 1989. +C +C 1. Purpose +C ======= +C +C F01QCF finds the QR factorization of the real m by n, m .ge. n, +C matrix A, so that A is reduced to upper triangular form by means of +C orthogonal transformations. +C +C 2. Description +C =========== +C +C The m by n matrix A is factorized as +C +C A = Q*( R ) when m.gt.n, +C ( 0 ) +C +C A = Q*R when m = n, +C +C where Q is an m by m orthogonal matrix and R is an n by n upper +C triangular matrix. +C +C The factorization is obtained by Householder's method. The kth +C transformation matrix, Q( k ), which is used to introduce zeros into +C the kth column of A is given in the form +C +C Q( k ) = ( I 0 ), +C ( 0 T( k ) ) +C +C where +C +C T( k ) = I - u( k )*u( k )', +C +C u( k ) = ( zeta( k ) ), +C ( z( k ) ) +C +C zeta( k ) is a scalar and z( k ) is an ( m - k ) element vector. +C zeta( k ) and z( k ) are chosen to annhilate the elements below the +C triangular part of A. +C +C The vector u( k ) is returned in the kth element of ZETA and in the +C kth column of A, such that zeta( k ) is in ZETA( k ) and the elements +C of z( k ) are in a( k + 1, k ), ..., a( m, k ). The elements of R +C are returned in the upper triangular part of A. +C +C Q is given by +C +C Q = ( Q( n )*Q( n - 1 )*...*Q( 1 ) )'. +C +C 3. Parameters +C ========== +C +C M - INTEGER. +C +C On entry, M must specify the number of rows of A. M must be +C at least n. +C +C Unchanged on exit. +C +C N - INTEGER. +C +C On entry, N must specify the number of columns of A. N must +C be at least zero. When N = 0 then an immediate return is +C effected. +C +C Unchanged on exit. +C +C A - REAL array of DIMENSION ( LDA, n ). +C +C Before entry, the leading M by N part of the array A must +C contain the matrix to be factorized. +C +C On exit, the N by N upper triangular part of A will contain +C the upper triangular matrix R and the M by N strictly lower +C triangular part of A will contain details of the +C factorization as described above. +C +C LDA - INTEGER. +C +C On entry, LDA must specify the leading dimension of the +C array A as declared in the calling (sub) program. LDA must +C be at least m. +C +C Unchanged on exit. +C +C ZETA - REAL array of DIMENSION at least ( n ). +C +C On exit, ZETA( k ) contains the scalar zeta( k ) for the +C kth transformation. If T( k ) = I then ZETA( k ) = 0.0, +C otherwise ZETA( k ) contains zeta( k ) as described above +C and zeta( k ) is always in the range ( 1.0, sqrt( 2.0 ) ). +C +C IFAIL - INTEGER. +C +C Before entry, IFAIL must contain one of the values -1 or 0 +C or 1 to specify noisy soft failure or noisy hard failure or +C silent soft failure. ( See Chapter P01 for further details.) +C +C On successful exit IFAIL will be zero, otherwise IFAIL +C will be set to -1 indicating that an input parameter has +C been incorrectly set. See the next section for further +C details. +C +C 4. Diagnostic Information +C ====================== +C +C IFAIL = -1 +C +C One or more of the following conditions holds: +C +C M .lt. N +C N .lt. 0 +C LDA .lt. M +C +C If on entry, IFAIL was either -1 or 0 then further diagnostic +C information will be output on the error message channel. ( See +C routine X04AAF. ) +C +C 5. Further information +C =================== +C +C Following the use of this routine the operations +C +C B := Q*B and B := Q'*B, +C +C where B is an m by k matrix, can be performed by calls to the +C NAG Library routine F01QDF. The operation B := Q*B can be obtained +C by the call: +C +C IFAIL = 0 +C CALL F01QDF( 'No transpose', 'Separate', M, N, A, LDA, ZETA, +C $ K, B, LDB, WORK, IFAIL ) +C +C and B := Q'*B can be obtained by the call: +C +C IFAIL = 0 +C CALL F01QDF( 'Transpose', 'Separate', M, N, A, LDA, ZETA, +C $ K, B, LDB, WORK, IFAIL ) +C +C In both cases WORK must be a k element array that is used as +C workspace. If B is a one-dimensional array (single column) then the +C parameter LDB can be replaced by M. See routine F01QDF for further +C details. +C +C The first k columns of the orthogonal matrix Q can either be obtained +C by setting B to the first k columns of the unit matrix and using the +C first of the above two calls, or by calling the NAG Library routine +C F01QEF, which overwrites the k columns of Q on the first k columns of +C the array A. Q is obtained by the call: +C +C CALL F01QEF( 'Separate', M, N, K, A, LDA, ZETA, WORK, IFAIL ) +C +C As above WORK must be a k element array. If K is larger than N, then +C A must have been declared to have at least K columns. +C +C Operations involving the matrix R can readily be performed by the +C Level 2 BLAS routines DTRSV and DTRMV (see Chapter F06), but note +C that no test for near singularity of R is incorporated in DTRSV . +C If R is singular, or nearly singular then the NAG Library routine +C F02WUF can be used to determine the singular value decomposition +C of R. +C +C +C Nag Fortran 77 Auxiliary linear algebra routine. +C +C -- Written on 21-December-1985. +C Sven Hammarling, Nag Central Office. +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) + CHARACTER*6 SRNAME + PARAMETER (SRNAME='F01QCF') +C .. Scalar Arguments .. + INTEGER IFAIL, LDA, M, N +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), ZETA(*) +C .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER IERR, K, LA +C .. Local Arrays .. + CHARACTER*46 REC(1) +C .. External Functions .. + INTEGER P01ABF + EXTERNAL P01ABF +C .. External Subroutines .. + EXTERNAL DGEMV, DGER, F06FRF, P01ABY +C .. Intrinsic Functions .. + INTRINSIC MIN +C .. Executable Statements .. +C +C Check the input parameters. +C + IERR = 0 + IF (M.LT.N) CALL P01ABY(M,'M',IFAIL,IERR,SRNAME) + IF (N.LT.0) CALL P01ABY(N,'N',IFAIL,IERR,SRNAME) + IF (LDA.LT.M) CALL P01ABY(LDA,'LDA',IFAIL,IERR,SRNAME) + IF (IERR.GT.0) THEN + WRITE (REC,FMT=99999) IERR + IFAIL = P01ABF(IFAIL,-1,SRNAME,1,REC) + RETURN + END IF +C +C Perform the factorization. +C + IF (N.EQ.0) THEN + IFAIL = P01ABF(IFAIL,0,SRNAME,0,REC) + RETURN + END IF + LA = LDA + DO 20 K = 1, MIN(M-1,N) +C +C Use a Householder reflection to zero the kth column of A. +C First set up the reflection. +C + CALL F06FRF(M-K,A(K,K),A(K+1,K),1,ZERO,ZETA(K)) + IF ((ZETA(K).GT.ZERO) .AND. (K.LT.N)) THEN + IF ((K+1).EQ.N) LA = M - K + 1 +C +C Temporarily store beta and put zeta( k ) in a( k, k ). +C + TEMP = A(K,K) + A(K,K) = ZETA(K) +C +C We now perform the operation A := Q( k )*A. +C +C Let B denote the bottom ( m - k + 1 ) by ( n - k ) part +C of A. +C +C First form work = B'*u. ( work is stored in the elements +C ZETA( k + 1 ), ..., ZETA( n ). ) +C + CALL DGEMV('Transpose',M-K+1,N-K,ONE,A(K,K+1),LA,A(K,K),1, + * ZERO,ZETA(K+1),1) +C +C Now form B := B - u*work'. +C + CALL DGER(M-K+1,N-K,-ONE,A(K,K),1,ZETA(K+1),1,A(K,K+1),LA) +C +C Restore beta. +C + A(K,K) = TEMP + END IF + 20 CONTINUE +C +C Set the final ZETA when m.eq.n. +C + IF (M.EQ.N) ZETA(N) = ZERO +C + IFAIL = P01ABF(IFAIL,0,SRNAME,0,REC) + RETURN +C +C +C End of F01QCF. ( SGEQR ) +C +99999 FORMAT (' The input parameters contained ',I2,' error(s)') + END diff --git a/src/MyNag/F01QDF.f b/src/MyNag/F01QDF.f new file mode 100644 index 000000000..c987960e5 --- /dev/null +++ b/src/MyNag/F01QDF.f @@ -0,0 +1,290 @@ + SUBROUTINE F01QDF(TRANS,WHERET,M,N,A,LDA,ZETA,NCOLB,B,LDB,WORK, + * IFAIL) +C MARK 14 RELEASE. NAG COPYRIGHT 1989. +C +C 1. Purpose +C ======= +C +C F01QDF performs one of the transformations +C +C B := Q*B or B := Q'*B, +C +C where B is an m by ncolb real matrix and Q is an m by m orthogonal +C matrix, given as the product of Householder transformation matrices. +C +C This routine is intended for use following NAG Fortran Library +C routine F01QCF. +C +C 2. Description +C =========== +C +C Q is assumed to be given by +C +C Q = ( Q( n )*Q( n - 1 )*...*Q( 1 ) )', +C +C Q( k ) being given in the form +C +C Q( k ) = ( I 0 ), +C ( 0 T( k ) ) +C +C where +C +C T( k ) = I - u( k )*u( k )' +C +C u( k ) = ( zeta( k ) ), +C ( z( k ) ) +C +C zeta( k ) is a scalar and z( k ) is an ( m - k ) element vector. +C +C z( k ) must be supplied in the kth column of A in elements +C a( k + 1, k ), ..., a( m, k ) and zeta( k ) must be supplied either +C in a( k, k ) or in zeta( k ), depending upon the parameter WHERET. +C +C To obtain Q explicitly B may be set to I and premultiplied by Q. This +C is more efficient than obtaining Q'. +C +C 3. Parameters +C ========== +C +C TRANS - CHARACTER*1. +C +C On entry, TRANS specifies the operation to be performed as +C follows. +C +C TRANS = 'N' or 'n' ( No transpose ) +C +C Perform the operation B := Q*B. +C +C TRANS = 'T' or 't' or 'C' or 'c' ( Transpose ) +C +C Perform the operation B := Q'*B. +C +C Unchanged on exit. +C +C WHERET - CHARACTER*1. +C +C On entry, WHERET specifies where the elements of zeta are +C to be found as follows. +C +C WHERET = 'I' or 'i' ( In A ) +C +C The elements of zeta are in A. +C +C WHERET = 'S' or 's' ( Separate ) +C +C The elements of zeta are separate from A, in ZETA. +C +C Unchanged on exit. +C +C M - INTEGER. +C +C On entry, M must specify the number of rows of A. M must be +C at least n. +C +C Unchanged on exit. +C +C N - INTEGER. +C +C On entry, N must specify the number of columns of A. N must +C be at least zero. When N = 0 then an immediate return is +C effected. +C +C Unchanged on exit. +C +C A - REAL array of DIMENSION ( LDA, n ). +C +C Before entry, the leading M by N stricly lower triangular +C part of the array A must contain details of the matrix Q. +C In addition, when WHERET = 'I' or 'i' then the diagonal +C elements of A must contain the elements of zeta as described +C under the argument ZETA below. +C +C When WHERET = 'S' or 's' then the diagonal elements of the +C array A are referenced, since they are used temporarily to +C store the zeta( k ), but they contain their original values +C on return. +C +C Unchanged on exit. +C +C LDA - INTEGER. +C +C On entry, LDA must specify the leading dimension of the +C array A as declared in the calling (sub) program. LDA must +C be at least m. +C +C Unchanged on exit. +C +C ZETA - REAL array of DIMENSION at least ( n ), when +C WHERET = 'S' or 's'. +C +C Before entry with WHERET = 'S' or 's', the array ZETA must +C contain the elements of zeta. If ZETA( k ) = 0.0 then +C T( k ) is assumed to be I otherwise ZETA( k ) is assumed +C to contain zeta( k ). +C +C When WHERET = 'I' or 'i', the array ZETA is not referenced. +C +C Unchanged on exit. +C +C NCOLB - INTEGER. +C +C On entry, NCOLB must specify the number of columns of B. +C NCOLB must be at least zero. When NCOLB = 0 then an +C immediate return is effected. +C +C Unchanged on exit. +C +C B - REAL array of DIMENSION ( LDB, ncolb ). +C +C Before entry, the leading M by NCOLB part of the array B +C must contain the matrix to be transformed. +C +C On exit, B is overwritten by the transformed matrix. +C +C LDB - INTEGER. +C +C On entry, LDB must specify the leading dimension of the +C array B as declared in the calling (sub) program. LDB must +C be at least m. +C +C Unchanged on exit. +C +C WORK - REAL array of DIMENSION at least ( ncolb ). +C +C Used as internal workspace. +C +C IFAIL - INTEGER. +C +C Before entry, IFAIL must contain one of the values -1 or 0 +C or 1 to specify noisy soft failure or noisy hard failure or +C silent soft failure. ( See Chapter P01 for further details.) +C +C On successful exit IFAIL will be zero, otherwise IFAIL +C will be set to -1 indicating that an input parameter has +C been incorrectly set. See the next section for further +C details. +C +C 4. Diagnostic Information +C ====================== +C +C IFAIL = -1 +C +C One or more of the following conditions holds: +C +C TRANS .ne. 'N' or 'n' or 'T' or 't' or 'C' or 'c' +C WHERET .ne. 'I' or 'i' or 'S' or 's' +C M .lt. N +C N .lt. 0 +C LDA .lt. M +C NCOLB .lt. 0 +C LDB .lt. M +C +C If on entry, IFAIL was either -1 or 0 then further diagnostic +C information will be output on the error message channel. ( See +C routine X04AAF. ) +C +C +C Nag Fortran 77 Auxiliary linear algebra routine. +C +C -- Written on 13-November-1987. +C Sven Hammarling, Nag Central Office. +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) + CHARACTER*6 SRNAME + PARAMETER (SRNAME='F01QDF') +C .. Scalar Arguments .. + INTEGER IFAIL, LDA, LDB, M, N, NCOLB + CHARACTER*1 TRANS, WHERET +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), B(LDB,*), WORK(*), ZETA(*) +C .. Local Scalars .. + DOUBLE PRECISION TEMP, ZETAK + INTEGER IERR, K, KK, LB +C .. Local Arrays .. + CHARACTER*46 REC(1) +C .. External Functions .. + INTEGER P01ABF + EXTERNAL P01ABF +C .. External Subroutines .. + EXTERNAL DGEMV, DGER, P01ABW, P01ABY +C .. Intrinsic Functions .. + INTRINSIC MIN +C .. Executable Statements .. +C +C Check the input parameters. +C + IERR = 0 + IF ((TRANS.NE.'N') .AND. (TRANS.NE.'n') .AND. (TRANS.NE.'T') + * .AND. (TRANS.NE.'t') .AND. (TRANS.NE.'C') .AND. (TRANS.NE.'c') + * ) CALL P01ABW(TRANS,'TRANS',IFAIL,IERR,SRNAME) + IF ((WHERET.NE.'I') .AND. (WHERET.NE.'i') .AND. (WHERET.NE.'S') + * .AND. (WHERET.NE.'s')) CALL P01ABW(WHERET,'WHERET',IFAIL, + * IERR,SRNAME) + IF (M.LT.N) CALL P01ABY(M,'M',IFAIL,IERR,SRNAME) + IF (N.LT.0) CALL P01ABY(N,'N',IFAIL,IERR,SRNAME) + IF (LDA.LT.M) CALL P01ABY(LDA,'LDA',IFAIL,IERR,SRNAME) + IF (NCOLB.LT.0) CALL P01ABY(NCOLB,'NCOLB',IFAIL,IERR,SRNAME) + IF (LDB.LT.M) CALL P01ABY(LDB,'LDB',IFAIL,IERR,SRNAME) + IF (IERR.GT.0) THEN + WRITE (REC,FMT=99999) IERR + IFAIL = P01ABF(IFAIL,-1,SRNAME,1,REC) + RETURN + END IF +C +C Perform the transformation. +C + IF (MIN(N,NCOLB).EQ.0) THEN + IFAIL = P01ABF(IFAIL,0,SRNAME,0,REC) + RETURN + END IF + LB = LDB + DO 20 KK = 1, N + IF ((TRANS.EQ.'T') .OR. (TRANS.EQ.'t') .OR. (TRANS.EQ.'C') + * .OR. (TRANS.EQ.'c')) THEN +C +C Q'*B = Q( n )*...*Q( 2 )*Q( 1 )*B, +C + K = KK + ELSE +C +C Q*B = Q( 1 )'*Q( 2 )'*...*Q( n )'*B, +C + K = N + 1 - KK + END IF + IF ((WHERET.EQ.'S') .OR. (WHERET.EQ.'s')) THEN + ZETAK = ZETA(K) + ELSE + ZETAK = A(K,K) + END IF + IF (ZETAK.GT.ZERO) THEN + TEMP = A(K,K) + A(K,K) = ZETAK + IF (NCOLB.EQ.1) LB = M - K + 1 +C +C Let C denote the bottom ( m - k + 1 ) by ncolb part of B. +C +C First form work = C'*u. +C + CALL DGEMV('Transpose',M-K+1,NCOLB,ONE,B(K,1),LB,A(K,K),1, + * ZERO,WORK,1) +C +C Now form C := C - u*work'. +C + CALL DGER(M-K+1,NCOLB,-ONE,A(K,K),1,WORK,1,B(K,1),LB) +C +C Restore the diagonal element of A. +C + A(K,K) = TEMP + END IF + 20 CONTINUE +C + IFAIL = P01ABF(IFAIL,0,SRNAME,0,REC) + RETURN +C +C +C End of F01QDF. ( SGEAPQ ) +C +99999 FORMAT (' The input parameters contained ',I2,' error(s)') + END diff --git a/src/MyNag/F01QEF.f b/src/MyNag/F01QEF.f new file mode 100644 index 000000000..6d435f19e --- /dev/null +++ b/src/MyNag/F01QEF.f @@ -0,0 +1,259 @@ + SUBROUTINE F01QEF(WHERET,M,N,NCOLQ,A,LDA,ZETA,WORK,IFAIL) +C MARK 14 RELEASE. NAG COPYRIGHT 1989. +C MARK 14C REVISED. IER-885 (NOV 1990). +C +C 1. Purpose +C ======= +C +C F01QEF returns the first ncolq columns of the m by m orthogonal +C matrix Q, where Q is given as the product of Householder +C transformation matrices. +C +C This routine is intended for use following NAG Fortran Library +C routine F01QCF. +C +C 2. Description +C =========== +C +C Q is assumed to be given by +C +C Q = ( Q( n )*Q( n - 1 )*...*Q( 1 ) )', +C +C Q( k ) being given in the form +C +C Q( k ) = ( I 0 ), +C ( 0 T( k ) ) +C +C where +C +C T( k ) = I - u( k )*u( k )' +C +C u( k ) = ( zeta( k ) ), +C ( z( k ) ) +C +C zeta( k ) is a scalar and z( k ) is an ( m - k ) element vector. +C +C z( k ) must be supplied in the kth column of A in elements +C a( k + 1, k ), ..., a( m, k ) and zeta( k ) must be supplied either +C in a( k, k ) or in zeta( k ), depending upon the parameter WHERET. +C +C 3. Parameters +C ========== +C +C WHERET - CHARACTER*1. +C +C On entry, WHERET specifies where the elements of zeta are +C to be found as follows. +C +C WHERET = 'I' or 'i' ( In A ) +C +C The elements of zeta are in A. +C +C WHERET = 'S' or 's' ( Separate ) +C +C The elements of zeta are separate from A, in ZETA. +C +C Unchanged on exit. +C +C M - INTEGER. +C +C On entry, M must specify the number of rows of A. M must be +C at least n. +C +C Unchanged on exit. +C +C N - INTEGER. +C +C On entry, N must specify the number of columns of A. N must +C be at least zero. +C +C Unchanged on exit. +C +C NCOLQ - INTEGER. +C +C On entry, NCOLQ must specify the required number of columns +C of Q. NCOLQ must be at least zero and not be larger than m. +C When NCOLQ = 0 then an immediate return is effected. +C +C Unchanged on exit. +C +C A - REAL array of DIMENSION ( LDA, nca ), where nca +C must be at least max( n, ncolq ). +C +C Before entry, the leading M by N stricly lower triangular +C part of the array A must contain details of the matrix Q. +C In addition, when WHERET = 'I' or 'i' then the diagonal +C elements of A must contain the elements of zeta as described +C under the argument ZETA below. +C +C On exit, the first NCOLQ columns of the array A are +C overwritten by the first ncolq columns of the m by m +C orthogonal matrix Q. +C +C Unchanged on exit. +C +C LDA - INTEGER. +C +C On entry, LDA must specify the leading dimension of the +C array A as declared in the calling (sub) program. LDA must +C be at least m. +C +C Unchanged on exit. +C +C ZETA - REAL array of DIMENSION at least ( n ), when +C WHERET = 'S' or 's'. +C +C Before entry with WHERET = 'S' or 's', the array ZETA must +C contain the elements of zeta. If ZETA( k ) = 0.0 then +C T( k ) is assumed to be I, otherwise ZETA( k ) is assumed +C to contain zeta( k ). +C +C When WHERET = 'I' or 'i', the array ZETA is not referenced. +C +C Unchanged on exit. +C +C WORK - REAL array of DIMENSION at least ( ncolq ). +C +C Used as internal workspace. +C +C IFAIL - INTEGER. +C +C Before entry, IFAIL must contain one of the values -1 or 0 +C or 1 to specify noisy soft failure or noisy hard failure or +C silent soft failure. ( See Chapter P01 for further details.) +C +C On successful exit IFAIL will be zero, otherwise IFAIL +C will be set to -1 indicating that an input parameter has +C been incorrectly set. See the next section for further +C details. +C +C 4. Diagnostic Information +C ====================== +C +C IFAIL = -1 +C +C One or more of the following conditions holds: +C +C WHERET .ne. 'I' or 'i' or 'S' or 's' +C M .lt. N +C N .lt. 0 +C NCOLQ .lt. 0 .or. NCOLQ .gt. M +C LDA .lt. M +C +C If on entry, IFAIL was either -1 or 0 then further diagnostic +C information will be output on the error message channel. ( See +C routine X04AAF. ) +C +C +C Nag Fortran 77 Auxiliary linear algebra routine. +C +C -- Written on 13-November-1987. +C Sven Hammarling, Nag Central Office. +C +C .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) + CHARACTER*6 SRNAME + PARAMETER (SRNAME='F01QEF') +C .. Scalar Arguments .. + INTEGER IFAIL, LDA, M, N, NCOLQ + CHARACTER*1 WHERET +C .. Array Arguments .. + DOUBLE PRECISION A(LDA,*), WORK(*), ZETA(*) +C .. Local Scalars .. + DOUBLE PRECISION ZETAK + INTEGER IERR, K, NCQ, P +C .. Local Arrays .. + CHARACTER*46 REC(1) +C .. External Functions .. + INTEGER P01ABF + EXTERNAL P01ABF +C .. External Subroutines .. + EXTERNAL F06FBF, F06QHF, P01ABW, P01ABY, DGEMV, DGER, + * DSCAL +C .. Intrinsic Functions .. + INTRINSIC MIN +C .. Executable Statements .. +C +C Check the input parameters. +C + IERR = 0 + IF ((WHERET.NE.'I') .AND. (WHERET.NE.'i') .AND. (WHERET.NE.'S') + * .AND. (WHERET.NE.'s')) CALL P01ABW(WHERET,'WHERET',IFAIL, + * IERR,SRNAME) + IF (M.LT.N) CALL P01ABY(M,'M',IFAIL,IERR,SRNAME) + IF (N.LT.0) CALL P01ABY(N,'N',IFAIL,IERR,SRNAME) + IF ((NCOLQ.LT.0) .OR. (NCOLQ.GT.M)) CALL P01ABY(NCOLQ,'NCOLQ', + * IFAIL,IERR,SRNAME) + IF (LDA.LT.M) CALL P01ABY(LDA,'LDA',IFAIL,IERR,SRNAME) + IF (IERR.GT.0) THEN + WRITE (REC,FMT=99999) IERR + IFAIL = P01ABF(IFAIL,-1,SRNAME,1,REC) + RETURN + END IF +C +C Start to form Q. First set the elements above the leading diagonal +C to zero. +C + IF (NCOLQ.EQ.0) THEN + IFAIL = P01ABF(IFAIL,0,SRNAME,0,REC) + RETURN + END IF + P = MIN(N,NCOLQ) + IF (P.GT.1) CALL F06QHF('Upper',P-1,P-1,ZERO,ZERO,A(1,2),LDA) + IF (NCOLQ.GT.N) THEN + NCQ = NCOLQ - N +C +C Set the last ( ncolq - n ) columns of Q to those of the unit +C matrix. +C + CALL F06QHF('General',N,NCOLQ-N,ZERO,ZERO,A(1,N+1),LDA) + CALL F06QHF('General',M-N,NCOLQ-N,ZERO,ONE,A(N+1,N+1),LDA) + ELSE + NCQ = 0 + END IF + DO 20 K = P, 1, -1 +C +C Q*E( ncolq ) = Q( 1 )'*...*Q( p )'*E( ncolq ), where E( ncolq ) +C is the matrix containing the first ncolq columns of I. +C + IF ((WHERET.EQ.'S') .OR. (WHERET.EQ.'s')) THEN + ZETAK = ZETA(K) + ELSE + ZETAK = A(K,K) + END IF + IF (ZETAK.GT.ZERO) THEN + A(K,K) = ZETAK +C +C Let C denote the bottom ( m - k + 1 ) by ncq part of Q. +C +C First form work = C'*u. +C + IF ((K.LT.M) .AND. (NCQ.GT.0)) THEN + CALL DGEMV('Transpose',M-K+1,NCQ,ONE,A(K,K+1),LDA,A(K,K), + * 1,ZERO,WORK,1) +C +C Now form C := C - u*work'. +C + CALL DGER(M-K+1,NCQ,-ONE,A(K,K),1,WORK,1,A(K,K+1),LDA) + END IF +C +C Now form the kth column of Q. +C + CALL DSCAL(M-K+1,-ZETAK,A(K,K),1) + A(K,K) = ONE + A(K,K) + ELSE + A(K,K) = ONE + IF (K.LT.M) CALL F06FBF(M-K,ZERO,A(K+1,K),1) + END IF + NCQ = NCQ + 1 + 20 CONTINUE +C + IFAIL = P01ABF(IFAIL,0,SRNAME,0,REC) + RETURN +C +C +C End of F01QEF. ( SGEFQ ) +C +99999 FORMAT (' The input parameters contained ',I2,' error(s)') + END diff --git a/src/MyNag/F01RCF.f b/src/MyNag/F01RCF.f new file mode 100644 index 000000000..194233a28 --- /dev/null +++ b/src/MyNag/F01RCF.f @@ -0,0 +1,282 @@ + SUBROUTINE F01RCF(M,N,A,LDA,THETA,IFAIL) +C MARK 13 RELEASE. NAG COPYRIGHT 1988. +C MARK 14 REVISED. IER-732 (DEC 1989). +C +C 1. Purpose +C ======= +C +C F01RCF finds the QR factorization of the complex m by n, m .ge. n, +C matrix A, so that A is reduced to upper triangular form by means of +C unitary transformations. +C +C 2. Description +C =========== +C +C The m by n matrix A is factorized as +C +C A = Q*( R ) when m.gt.n, +C ( 0 ) +C +C A = Q*R when m = n, +C +C where Q is an m by m unitary matrix and R is an n by n upper +C triangular matrix with real diagonal elements. +C +C The factorization is obtained by Householder's method. The kth +C transformation matrix, Q( k ), which is used to introduce zeros into +C the kth column of A is given in the form +C +C Q( k ) = ( I 0 ), +C ( 0 T( k ) ) +C +C where +C +C T( k ) = I - gamma( k )*u( k )*conjg( u( k )' ), +C +C u( k ) = ( zeta( k ) ), +C ( z( k ) ) +C +C gamma( k ) is a scalar for which real( gamma( k ) ) = 1.0, zeta( k ) +C is a real scalar and z( k ) is an ( m - k ) element vector. +C gamma( k ), zeta( k ) and z( k ) are chosen to annhilate the elements +C below the triangular part of A and to make the diagonal elements +C real. +C +C The scalar gamma( k ) and the vector u( k ) are returned in the kth +C element of THETA and in the kth column of A, such that theta( k ), +C given by +C +C theta( k ) = ( zeta( k ), aimag( gamma( k ) ) ), +C +C is in THETA( k ) and the elements of z( k ) are in a( k + 1, k ), +C ..., a( m, k ). The elements of R are returned in the upper +C triangular part of A. +C +C Q is given by +C +C Q = conjg( ( Q( n )*Q( n - 1 )*...*Q( 1 ) )' ). +C +C 3. Parameters +C ========== +C +C M - INTEGER. +C +C On entry, M must specify the number of rows of A. M must be +C at least n. +C +C Unchanged on exit. +C +C N - INTEGER. +C +C On entry, N must specify the number of columns of A. N must +C be at least zero. When N = 0 then an immediate return is +C effected. +C +C Unchanged on exit. +C +C A - COMPLEX array of DIMENSION ( LDA, n ). +C +C Before entry, the leading M by N part of the array A must +C contain the matrix to be factorized. +C +C On exit, the N by N upper triangular part of A will contain +C the upper triangular matrix R, with the imaginary parts of +C the diagonal elements set to zero, and the M by N strictly +C lower triangular part of A will contain details of the +C factorization as described above. +C +C LDA - INTEGER. +C +C On entry, LDA must specify the leading dimension of the +C array A as declared in the calling (sub) program. LDA must +C be at least m. +C +C Unchanged on exit. +C +C THETA - COMPLEX array of DIMENSION at least ( n ). +C +C On exit, THETA( k ) contains the scalar theta( k ) for the +C kth transformation. If T( k ) = I then THETA( k ) = 0.0, +C if +C +C T( k ) = ( alpha 0 ), real( alpha ) .lt. 0.0, +C ( 0 I ) +C +C then THETA( k ) = alpha, otherwise THETA( k ) contains +C theta( k ) as described above and real( theta( k ) ) is +C always in the range ( 1.0, sqrt( 2.0 ) ). +C +C IFAIL - INTEGER. +C +C Before entry, IFAIL must contain one of the values -1 or 0 +C or 1 to specify noisy soft failure or noisy hard failure or +C silent soft failure. ( See Chapter P01 for further details.) +C +C On successful exit IFAIL will be zero, otherwise IFAIL +C will be set to -1 indicating that an input parameter has +C been incorrectly set. See the next section for further +C details. +C +C 4. Diagnostic Information +C ====================== +C +C IFAIL = -1 +C +C One or more of the following conditions holds: +C +C M .lt. N +C N .lt. 0 +C LDA .lt. M +C +C If on entry, IFAIL was either -1 or 0 then further diagnostic +C information will be output on the error message channel. ( See +C routine X04AAF. ) +C +C 5. Further information +C =================== +C +C Following the use of this routine the operations +C +C B := Q*B and B := conjg( Q' )*B, +C +C where B is an m by k matrix, can be performed by calls to the +C NAG Library routine F01RDF. The operation B := Q*B can be obtained +C by the call: +C +C IFAIL = 0 +C CALL F01RDF( 'No conjugate', 'Separate', M, N, A, LDA, THETA, +C $ K, B, LDB, WORK, IFAIL ) +C +C and B := conjg( Q' )*B can be obtained by the call: +C +C IFAIL = 0 +C CALL F01RDF( 'Conjugate', 'Separate', M, N, A, LDA, THETA, +C $ K, B, LDB, WORK, IFAIL ) +C +C In both cases WORK must be a k element array that is used as +C workspace. If B is a one-dimensional array (single column) then the +C parameter LDB can be replaced by M. See routine F01RDF for further +C details. +C +C The first k columns of the unitary matrix Q can either be obtained +C by setting B to the first k columns of the unit matrix and using the +C first of the above two calls, or by calling the NAG Library routine +C F01REF, which overwrites the k columns of Q on the first k columns of +C the array A. Q is obtained by the call: +C +C CALL F01REF( 'Separate', M, N, K, A, LDA, THETA, WORK, IFAIL ) +C +C As above WORK must be a k element array. If K is larger than N, then +C A must have been declared to have at least K columns. +C +C Operations involving the matrix R can readily be performed by the +C Level 2 BLAS routines CTRSV and CTRMV (see Chapter F06), but note +C that no test for near singularity of R is incorporated in CTRSV . +C If R is singular, or nearly singular then the NAG Library routine +C F02XUF can be used to determine the singular value decomposition +C of R. +C +C +C Nag Fortran 77 Auxiliary linear algebra routine. +C +C -- Written on 21-December-1985. +C Sven Hammarling, Nag Central Office. +C +C .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE=(1.0D+0,0.0D+0)) + COMPLEX*16 ZERO + PARAMETER (ZERO=(0.0D+0,0.0D+0)) + CHARACTER*6 SRNAME + PARAMETER (SRNAME='F01RCF') +C .. Scalar Arguments .. + INTEGER IFAIL, LDA, M, N +C .. Array Arguments .. + COMPLEX*16 A(LDA,*), THETA(*) +C .. Local Scalars .. + COMPLEX*16 GAMMA + DOUBLE PRECISION TEMP + INTEGER IERR, K, LA +C .. Local Arrays .. + COMPLEX*16 DUMMY(1) + CHARACTER*46 REC(1) +C .. External Functions .. + INTEGER P01ABF + EXTERNAL P01ABF +C .. External Subroutines .. + EXTERNAL ZGEMV, ZGERC, ZSCAL, F06HRF, P01ABY +C .. Intrinsic Functions .. + INTRINSIC DIMAG, DCMPLX, MIN, DREAL +C .. Executable Statements .. +C +C Check the input parameters. +C + IF (N.EQ.0) THEN + IFAIL = P01ABF(IFAIL,0,SRNAME,0,REC) + RETURN + END IF + IERR = 0 + IF (M.LT.N) CALL P01ABY(M,'M',IFAIL,IERR,SRNAME) + IF (N.LT.0) CALL P01ABY(N,'N',IFAIL,IERR,SRNAME) + IF (LDA.LT.M) CALL P01ABY(LDA,'LDA',IFAIL,IERR,SRNAME) + IF (IERR.GT.0) THEN + WRITE (REC,FMT=99999) IERR + IFAIL = P01ABF(IFAIL,-1,SRNAME,1,REC) + RETURN + END IF +C +C Perform the factorization. +C + LA = LDA + DO 20 K = 1, MIN(M-1,N) +C +C Use a Householder reflection to zero the kth column of A. +C First set up the reflection. +C + CALL F06HRF(M-K,A(K,K),A(K+1,K),1,DREAL(ZERO),THETA(K)) + IF ((DREAL(THETA(K)).GT.DREAL(ZERO)) .AND. (K.LT.N)) THEN + IF ((K+1).EQ.N) LA = M - K + 1 +C +C Temporarily store beta, put zeta( k ) in a( k, k ) and +C form gamma( k ). +C + TEMP = A(K,K) + A(K,K) = DREAL(THETA(K)) + GAMMA = DCMPLX(DREAL(ONE),DIMAG(THETA(K))) +C +C We now perform the operation A := Q( k )*A. +C +C Let B denote the bottom ( m - k + 1 ) by ( n - k ) part +C of A. +C +C First form work = conjg( B' )*u. ( work is stored in the +C elements THETA( k + 1 ), ..., THETA( n ). ) +C + CALL ZGEMV('Conjugate',M-K+1,N-K,ONE,A(K,K+1),LA,A(K,K),1, + * ZERO,THETA(K+1),1) +C +C Now form B := B - gamma( k )*u*conjg( work' ). +C + CALL ZGERC(M-K+1,N-K,-GAMMA,A(K,K),1,THETA(K+1),1,A(K,K+1), + * LA) +C +C Restore beta. +C + A(K,K) = TEMP + ELSE IF (DIMAG(THETA(K)).NE.DREAL(ZERO)) THEN + CALL ZSCAL(N-K,THETA(K),A(K,K+1),LDA) + END IF + 20 CONTINUE +C +C Find the final THETA when m.eq.n. This ensures that the last +C diagonal element of R is real. +C + IF (M.EQ.N) CALL F06HRF(0,A(N,N),DUMMY,1,DREAL(ZERO),THETA(N)) +C + IFAIL = P01ABF(IFAIL,0,SRNAME,0,REC) + RETURN +C +C End of F01RCF. ( CGEQR ) +C +99999 FORMAT (' The input parameters contained ',I2,' error(s)') + END diff --git a/src/MyNag/F01REF.f b/src/MyNag/F01REF.f new file mode 100644 index 000000000..ed79ed0ee --- /dev/null +++ b/src/MyNag/F01REF.f @@ -0,0 +1,283 @@ + SUBROUTINE F01REF(WHERET,M,N,NCOLQ,A,LDA,THETA,WORK,IFAIL) +C MARK 13 RELEASE. NAG COPYRIGHT 1988. +C MARK 14 REVISED. IER-733 (DEC 1989). +C MARK 14C REVISED. IER-886 (NOV 1990). +C +C 1. Purpose +C ======= +C +C F01REF returns the first ncolq columns of the m by m unitary matrix +C Q, where Q is given as the product of Householder transformation +C matrices. +C +C This routine is intended for use following NAG Fortran Library +C routine F01RCF. +C +C 2. Description +C =========== +C +C Q is assumed to be given by +C +C Q = conjg( ( Q( n )*Q( n - 1 )*...*Q( 1 ) )' ), +C +C Q( k ) being given in the form +C +C Q( k ) = ( I 0 ), +C ( 0 T( k ) ) +C +C where +C +C T( k ) = I - gamma( k )*u( k )*conjg( u( k )' ) +C +C u( k ) = ( zeta( k ) ), +C ( z( k ) ) +C +C gamma( k ) is a scalar for which real( gamma( k ) ) = 1.0, zeta( k ) +C is a real scalar and z( k ) is an ( m - k ) element vector. +C +C z( k ) must be supplied in the kth column of A in elements +C a( k + 1, k ), ..., a( m, k ) and theta( k ), given by +C +C theta( k ) = ( zeta( k ), aimag( gamma( k ) ) ), +C +C must be supplied either in a( k, k ) or in theta( k ), depending upon +C the parameter WHERET. +C +C 3. Parameters +C ========== +C +C WHERET - CHARACTER*1. +C +C On entry, WHERET specifies where the elements of theta are +C to be found as follows. +C +C WHERET = 'I' or 'i' ( In A ) +C +C The elements of theta are in A. +C +C WHERET = 'S' or 's' ( Separate ) +C +C The elements of theta are separate from A, in THETA. +C +C Unchanged on exit. +C +C M - INTEGER. +C +C On entry, M must specify the number of rows of A. M must be +C at least n. +C +C Unchanged on exit. +C +C N - INTEGER. +C +C On entry, N must specify the number of columns of A. N must +C be at least zero. +C +C Unchanged on exit. +C +C NCOLQ - INTEGER. +C +C On entry, NCOLQ must specify the required number of columns +C of Q. NCOLQ must be at least zero and not be larger than m. +C When NCOLQ = 0 then an immediate return is effected. +C +C Unchanged on exit. +C +C A - COMPLEX array of DIMENSION ( LDA, nca ), where nca must be +C at least max( n, ncolq ). +C +C Before entry, the leading M by N stricly lower triangular +C part of the array A must contain details of the matrix Q. +C In addition, when WHERET = 'I' or 'i' then the diagonal +C elements of A must contain the elements of theta as +C described under the argument THETA below. +C +C On exit, the first NCOLQ columns of the array A are +C overwritten by the first ncolq columns of the m by m unitary +C matrix Q. +C +C Unchanged on exit. +C +C LDA - INTEGER. +C +C On entry, LDA must specify the leading dimension of the +C array A as declared in the calling (sub) program. LDA must +C be at least m. +C +C Unchanged on exit. +C +C THETA - COMPLEX array of DIMENSION at least ( n ), when WHERET = 'S' +C or 's'. +C +C Before entry with WHERET = 'S' or 's', the array THETA must +C contain the elements of theta. If THETA( k ) = 0.0 then +C T( k ) is assumed to be I, if THETA( k ) = alpha, with +C real( alpha ) .lt. 0.0 then T( k ) is assumed to be of +C the form +C +C T( k ) = ( alpha 0 ), +C ( 0 I ) +C +C otherwise THETA( k ) is assumed to contain theta( k ) given +C by theta( k ) = ( zeta( k ), aimag( gamma( k ) ) ). +C +C When WHERET = 'I' or 'i', the array THETA is not referenced. +C +C Unchanged on exit. +C +C WORK - COMPLEX array of DIMENSION at least ( ncolq ). +C +C Used as internal workspace. +C +C IFAIL - INTEGER. +C +C Before entry, IFAIL must contain one of the values -1 or 0 +C or 1 to specify noisy soft failure or noisy hard failure or +C silent soft failure. ( See Chapter P01 for further details.) +C +C On successful exit IFAIL will be zero, otherwise IFAIL +C will be set to -1 indicating that an input parameter has +C been incorrectly set. See the next section for further +C details. +C +C 4. Diagnostic Information +C ====================== +C +C IFAIL = -1 +C +C One or more of the following conditions holds: +C +C WHERET .ne. 'I' or 'i' or 'S' or 's' +C M .lt. N +C N .lt. 0 +C NCOLQ .lt. 0 .or. NCOLQ .gt. M +C LDA .lt. M +C +C If on entry, IFAIL was either -1 or 0 then further diagnostic +C information will be output on the error message channel. ( See +C routine X04AAF. ) +C +C +C Nag Fortran 77 Auxiliary linear algebra routine. +C +C -- Written on 13-November-1987. +C Sven Hammarling, Nag Central Office. +C +C .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE=(1.0D+0,0.0D+0)) + COMPLEX*16 ZERO + PARAMETER (ZERO=(0.0D+0,0.0D+0)) + CHARACTER*6 SRNAME + PARAMETER (SRNAME='F01REF') +C .. Scalar Arguments .. + INTEGER IFAIL, LDA, M, N, NCOLQ + CHARACTER*1 WHERET +C .. Array Arguments .. + COMPLEX*16 A(LDA,*), THETA(*), WORK(*) +C .. Local Scalars .. + COMPLEX*16 GAMMA, THETAK + INTEGER IERR, K, NCQ, P +C .. Local Arrays .. + CHARACTER*46 REC(1) +C .. External Functions .. + INTEGER P01ABF + EXTERNAL P01ABF +C .. External Subroutines .. + EXTERNAL ZGEMV, ZGERC, ZSCAL, F06HBF, F06THF, P01ABW, + * P01ABY +C .. Intrinsic Functions .. + INTRINSIC DIMAG, DCMPLX, DCONJG, MIN, DREAL +C .. Executable Statements .. +C +C Check the input parameters. +C + IF (NCOLQ.EQ.0) THEN + IFAIL = P01ABF(IFAIL,0,SRNAME,0,REC) + RETURN + END IF + IERR = 0 + IF ((WHERET.NE.'I') .AND. (WHERET.NE.'i') .AND. (WHERET.NE.'S') + * .AND. (WHERET.NE.'s')) CALL P01ABW(WHERET,'WHERET',IFAIL, + * IERR,SRNAME) + IF (M.LT.N) CALL P01ABY(M,'M',IFAIL,IERR,SRNAME) + IF (N.LT.0) CALL P01ABY(N,'N',IFAIL,IERR,SRNAME) + IF ((NCOLQ.LT.0) .OR. (NCOLQ.GT.M)) CALL P01ABY(NCOLQ,'NCOLQ', + * IFAIL,IERR,SRNAME) + IF (LDA.LT.M) CALL P01ABY(LDA,'LDA',IFAIL,IERR,SRNAME) + IF (IERR.GT.0) THEN + WRITE (REC,FMT=99999) IERR + IFAIL = P01ABF(IFAIL,-1,SRNAME,1,REC) + RETURN + END IF +C +C Start to form Q. First set the elements above the leading diagonal +C to zero. +C + P = MIN(N,NCOLQ) + IF (P.GT.1) CALL F06THF('Upper',P-1,P-1,ZERO,ZERO,A(1,2),LDA) + IF (NCOLQ.GT.N) THEN + NCQ = NCOLQ - N +C +C Set the last ( ncolq - n ) columns of Q to those of the unit +C matrix. +C + CALL F06THF('General',N,NCOLQ-N,ZERO,ZERO,A(1,N+1),LDA) + CALL F06THF('General',M-N,NCOLQ-N,ZERO,ONE,A(N+1,N+1),LDA) + ELSE + NCQ = 0 + END IF + DO 20 K = P, 1, -1 +C +C Q*E( ncolq ) = +C conjg( Q( 1 )' )*...*conjg( Q( p )' )*E( ncolq ), +C where E( ncolq ) is the matrix containing the first ncolq +C columns of I. +C + IF ((WHERET.EQ.'S') .OR. (WHERET.EQ.'s')) THEN + THETAK = THETA(K) + ELSE + THETAK = A(K,K) + END IF +C +C If real( THETA( k ) ) .le. zero then Q( k ) is special. +C + IF (DREAL(THETAK).GT.DREAL(ZERO)) THEN + A(K,K) = DREAL(THETAK) + GAMMA = DCMPLX(DREAL(ONE),-DIMAG(THETAK)) +C +C Let C denote the bottom ( m - k + 1 ) by ncq part of Q. +C +C First form work = conjg( C' )*u. +C + IF ((K.LT.M) .AND. (NCQ.GT.0)) THEN + CALL ZGEMV('Conjugate',M-K+1,NCQ,ONE,A(K,K+1),LDA,A(K,K), + * 1,ZERO,WORK,1) +C +C Now form C := C - gamma( k )*u*conjg( work' ). +C + CALL ZGERC(M-K+1,NCQ,-GAMMA,A(K,K),1,WORK,1,A(K,K+1),LDA) + END IF +C +C Now form the kth column of Q. +C + CALL ZSCAL(M-K+1,-GAMMA*DREAL(THETAK),A(K,K),1) + A(K,K) = ONE + A(K,K) + ELSE + IF (DIMAG(THETAK).EQ.DREAL(ZERO)) THEN + A(K,K) = ONE + ELSE + A(K,K) = DCONJG(THETAK) + END IF + IF (K.LT.M) CALL F06HBF(M-K,ZERO,A(K+1,K),1) + END IF + NCQ = NCQ + 1 + 20 CONTINUE +C + IFAIL = P01ABF(IFAIL,0,SRNAME,0,REC) + RETURN +C +C End of F01REF. ( CGEFQ ) +C +99999 FORMAT (' The input parameters contained ',I2,' error(s)') + END diff --git a/src/MyNag/F06AAZ.f b/src/MyNag/F06AAZ.f new file mode 100644 index 000000000..23b208da2 --- /dev/null +++ b/src/MyNag/F06AAZ.f @@ -0,0 +1,61 @@ + SUBROUTINE F06AAZ ( SRNAME, INFO ) +C MARK 12 RELEASE. NAG COPYRIGHT 1986. +C MARK 15 REVISED. IER-915 (APR 1991). +C .. Scalar Arguments .. + INTEGER INFO + CHARACTER*13 SRNAME +C .. +C +C Purpose +C ======= +C +C F06AAZ is an error handler for the Level 2 BLAS routines. +C +C It is called by the Level 2 BLAS routines if an input parameter is +C invalid. +C +C Parameters +C ========== +C +C SRNAME - CHARACTER*13. +C On entry, SRNAME specifies the name of the routine which +C called F06AAZ. +C +C INFO - INTEGER. +C On entry, INFO specifies the position of the invalid +C parameter in the parameter-list of the calling routine. +C +C +C Auxiliary routine for Level 2 Blas. +C +C Written on 20-July-1986. +C +C .. Local Scalars .. + INTEGER IERR, IFAIL + CHARACTER*4 VARBNM +C .. Local Arrays .. + CHARACTER*80 REC (1) +C .. External Functions .. + INTEGER P01ACF + EXTERNAL P01ACF +C .. +C .. Executable Statements .. + WRITE (REC (1),99999) SRNAME, INFO + IF (SRNAME(1:3).EQ.'F06') THEN + IERR = -1 + VARBNM = ' ' + ELSE + IERR = -INFO + VARBNM = 'INFO' + END IF + IFAIL = 0 + IFAIL = P01ACF (IFAIL, IERR, SRNAME(1:6), VARBNM, 1, REC) +C + RETURN +C +99999 FORMAT ( ' ** On entry to ', A13, ' parameter number ', I2, + $ ' had an illegal value' ) +C +C End of F06AAZ. +C + END diff --git a/src/MyNag/F06FBF.f b/src/MyNag/F06FBF.f new file mode 100644 index 000000000..40454acde --- /dev/null +++ b/src/MyNag/F06FBF.f @@ -0,0 +1,44 @@ + SUBROUTINE F06FBF( N, CONST, X, INCX ) +C MARK 12 RELEASE. NAG COPYRIGHT 1986. +C .. Scalar Arguments .. + DOUBLE PRECISION CONST + INTEGER INCX, N +C .. Array Arguments .. + DOUBLE PRECISION X( * ) +C .. +C +C F06FBF performs the operation +C +C x = const*e, e' = ( 1 1 ... 1 ). +C +C +C Nag Fortran 77 O( n ) basic linear algebra routine. +C +C -- Written on 22-September-1983. +C Sven Hammarling, Nag Central Office. +C +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +C .. Local Scalars .. + INTEGER IX +C .. +C .. Executable Statements .. + IF( N.GT.0 )THEN + IF( CONST.NE.ZERO )THEN + DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX + X( IX ) = CONST + 10 CONTINUE + ELSE + DO 20, IX = 1, 1 + ( N - 1 )*INCX, INCX + X( IX ) = ZERO + 20 CONTINUE + END IF + END IF +C + RETURN +C +C End of F06FBF. ( SLOAD ) +C + END diff --git a/src/MyNag/F06FJF.f b/src/MyNag/F06FJF.f new file mode 100644 index 000000000..9692407fc --- /dev/null +++ b/src/MyNag/F06FJF.f @@ -0,0 +1,62 @@ + SUBROUTINE F06FJF( N, X, INCX, SCALE, SUMSQ ) +C MARK 12 RELEASE. NAG COPYRIGHT 1986. +C .. Scalar Arguments .. + DOUBLE PRECISION SCALE, SUMSQ + INTEGER INCX, N +C .. Array Arguments .. + DOUBLE PRECISION X( * ) +C .. +C +C F06FJF returns the values scl and smsq such that +C +C ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, +C +C where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is assumed +C to be at least unity and the value of smsq will then satisfy +C +C 1.0 .le. smsq .le. ( sumsq + n ) . +C +C scale is assumed to be non-negative and scl returns the value +C +C scl = max( scale, abs( x( i ) ) ) . +C +C scale and sumsq must be supplied in SCALE and SUMSQ respectively. +C scl and smsq are overwritten on SCALE and SUMSQ respectively. +C +C The routine makes only one pass through the vector X. +C +C +C Nag Fortran 77 O( n ) basic linear algebra routine. +C +C -- Written on 22-October-1982. +C Sven Hammarling, Nag Central Office. +C +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +C .. Local Scalars .. + DOUBLE PRECISION ABSXI + INTEGER IX +C .. Intrinsic Functions .. + INTRINSIC ABS +C .. +C .. Executable Statements .. + IF( N.GT.0 )THEN + DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX + IF( X( IX ).NE.ZERO )THEN + ABSXI = ABS( X( IX ) ) + IF( SCALE.LT.ABSXI )THEN + SUMSQ = 1 + SUMSQ*( SCALE/ABSXI )**2 + SCALE = ABSXI + ELSE + SUMSQ = SUMSQ + ( ABSXI/SCALE )**2 + END IF + END IF + 10 CONTINUE + END IF + RETURN +C +C End of F06FJF. ( SSSQ ) +C + END diff --git a/src/MyNag/F06FRF.f b/src/MyNag/F06FRF.f new file mode 100644 index 000000000..726560cf2 --- /dev/null +++ b/src/MyNag/F06FRF.f @@ -0,0 +1,139 @@ + SUBROUTINE F06FRF( N, ALPHA, X, INCX, TOL, ZETA ) +C MARK 12 RELEASE. NAG COPYRIGHT 1986. +C .. Scalar Arguments .. + DOUBLE PRECISION ALPHA, TOL, ZETA + INTEGER INCX, N +C .. Array Arguments .. + DOUBLE PRECISION X( * ) +C .. +C +C F06FRF generates details of a generalized Householder reflection such +C that +C +C P*( alpha ) = ( beta ), P'*P = I. +C ( x ) ( 0 ) +C +C P is given in the form +C +C P = I - ( zeta )*( zeta z' ), +C ( z ) +C +C where z is an n element vector and zeta is a scalar that satisfies +C +C 1.0 .le. zeta .le. sqrt( 2.0 ). +C +C zeta is returned in ZETA unless x is such that +C +C max( abs( x( i ) ) ) .le. max( eps*abs( alpha ), tol ) +C +C where eps is the relative machine precision and tol is the user +C supplied value TOL, in which case ZETA is returned as 0.0 and P can +C be taken to be the unit matrix. +C +C beta is overwritten on alpha and z is overwritten on x. +C the routine may be called with n = 0 and advantage is taken of the +C case where n = 1. +C +C +C Nag Fortran 77 O( n ) basic linear algebra routine. +C +C -- Written on 30-August-1984. +C Sven Hammarling, Nag Central Office. +C This version dated 28-September-1984. +C +C +C .. Parameters .. + DOUBLE PRECISION ONE , ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +C .. Local Scalars .. + DOUBLE PRECISION BETA, EPS, SCALE, SSQ + LOGICAL FIRST +C .. External Functions .. + DOUBLE PRECISION X02AJF + EXTERNAL X02AJF +C .. External Subroutines .. + EXTERNAL F06FJF, DSCAL +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SIGN, SQRT +C .. Save statement .. + SAVE EPS, FIRST +C .. Data statements .. + DATA FIRST/ .TRUE. / +C .. +C .. Executable Statements .. + IF( N.LT.1 )THEN + ZETA = ZERO + ELSE IF( ( N.EQ.1 ).AND.( X( 1 ).EQ.ZERO ) )THEN + ZETA = ZERO + ELSE +C + IF( FIRST )THEN + FIRST = .FALSE. + EPS = X02AJF( ) + END IF +C +C Treat case where P is a 2 by 2 matrix specially. +C + IF( N.EQ.1 )THEN +C +C Deal with cases where ALPHA = zero and +C abs( X( 1 ) ) .le. max( EPS*abs( ALPHA ), TOL ) first. +C + IF( ALPHA.EQ.ZERO )THEN + ZETA = ONE + ALPHA = ABS ( X( 1 ) ) + X( 1 ) = -SIGN( ONE, X( 1 ) ) + ELSE IF( ABS( X( 1 ) ).LE.MAX( EPS*ABS( ALPHA ), TOL ) )THEN + ZETA = ZERO + ELSE + IF( ABS( ALPHA ).GE.ABS( X( 1 ) ) )THEN + BETA = ABS( ALPHA ) *SQRT( 1 + ( X( 1 )/ALPHA )**2 ) + ELSE + BETA = ABS( X( 1 ) )*SQRT( 1 + ( ALPHA/X( 1 ) )**2 ) + END IF + ZETA = SQRT( ( ABS( ALPHA ) + BETA )/BETA ) + IF( ALPHA.GE.ZERO ) + $ BETA = -BETA + X( 1 ) = -X( 1 )/( ZETA*BETA ) + ALPHA = BETA + END IF + ELSE +C +C Now P is larger than 2 by 2. +C + SSQ = ONE + SCALE = ZERO + CALL F06FJF( N, X, INCX, SCALE, SSQ ) +C +C Treat cases where SCALE = zero, +C SCALE .le. max( EPS*abs( ALPHA ), TOL ) and +C ALPHA = zero specially. +C Note that SCALE = max( abs( X( i ) ) ). +C + IF( ( SCALE.EQ.ZERO ).OR. + $ ( SCALE.LE.MAX( EPS*ABS( ALPHA ), TOL ) ) )THEN + ZETA = ZERO + ELSE IF( ALPHA.EQ.ZERO )THEN + ZETA = ONE + ALPHA = SCALE*SQRT( SSQ ) + CALL DSCAL( N, -1/ALPHA, X, INCX ) + ELSE + IF( SCALE.LT.ABS( ALPHA ) )THEN + BETA = ABS( ALPHA )*SQRT( 1 + SSQ*( SCALE/ALPHA )**2 ) + ELSE + BETA = SCALE *SQRT( SSQ + ( ALPHA/SCALE )**2 ) + END IF + ZETA = SQRT( ( BETA + ABS( ALPHA ) )/BETA ) + IF( ALPHA.GT.ZERO ) + $ BETA = -BETA + CALL DSCAL( N, -1/( ZETA*BETA ), X, INCX ) + ALPHA = BETA + END IF + END IF + END IF +C + RETURN +C +C End of F06FRF. ( SGRFG ) +C + END diff --git a/src/MyNag/F06FRF.f~ b/src/MyNag/F06FRF.f~ new file mode 100644 index 000000000..726560cf2 --- /dev/null +++ b/src/MyNag/F06FRF.f~ @@ -0,0 +1,139 @@ + SUBROUTINE F06FRF( N, ALPHA, X, INCX, TOL, ZETA ) +C MARK 12 RELEASE. NAG COPYRIGHT 1986. +C .. Scalar Arguments .. + DOUBLE PRECISION ALPHA, TOL, ZETA + INTEGER INCX, N +C .. Array Arguments .. + DOUBLE PRECISION X( * ) +C .. +C +C F06FRF generates details of a generalized Householder reflection such +C that +C +C P*( alpha ) = ( beta ), P'*P = I. +C ( x ) ( 0 ) +C +C P is given in the form +C +C P = I - ( zeta )*( zeta z' ), +C ( z ) +C +C where z is an n element vector and zeta is a scalar that satisfies +C +C 1.0 .le. zeta .le. sqrt( 2.0 ). +C +C zeta is returned in ZETA unless x is such that +C +C max( abs( x( i ) ) ) .le. max( eps*abs( alpha ), tol ) +C +C where eps is the relative machine precision and tol is the user +C supplied value TOL, in which case ZETA is returned as 0.0 and P can +C be taken to be the unit matrix. +C +C beta is overwritten on alpha and z is overwritten on x. +C the routine may be called with n = 0 and advantage is taken of the +C case where n = 1. +C +C +C Nag Fortran 77 O( n ) basic linear algebra routine. +C +C -- Written on 30-August-1984. +C Sven Hammarling, Nag Central Office. +C This version dated 28-September-1984. +C +C +C .. Parameters .. + DOUBLE PRECISION ONE , ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +C .. Local Scalars .. + DOUBLE PRECISION BETA, EPS, SCALE, SSQ + LOGICAL FIRST +C .. External Functions .. + DOUBLE PRECISION X02AJF + EXTERNAL X02AJF +C .. External Subroutines .. + EXTERNAL F06FJF, DSCAL +C .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SIGN, SQRT +C .. Save statement .. + SAVE EPS, FIRST +C .. Data statements .. + DATA FIRST/ .TRUE. / +C .. +C .. Executable Statements .. + IF( N.LT.1 )THEN + ZETA = ZERO + ELSE IF( ( N.EQ.1 ).AND.( X( 1 ).EQ.ZERO ) )THEN + ZETA = ZERO + ELSE +C + IF( FIRST )THEN + FIRST = .FALSE. + EPS = X02AJF( ) + END IF +C +C Treat case where P is a 2 by 2 matrix specially. +C + IF( N.EQ.1 )THEN +C +C Deal with cases where ALPHA = zero and +C abs( X( 1 ) ) .le. max( EPS*abs( ALPHA ), TOL ) first. +C + IF( ALPHA.EQ.ZERO )THEN + ZETA = ONE + ALPHA = ABS ( X( 1 ) ) + X( 1 ) = -SIGN( ONE, X( 1 ) ) + ELSE IF( ABS( X( 1 ) ).LE.MAX( EPS*ABS( ALPHA ), TOL ) )THEN + ZETA = ZERO + ELSE + IF( ABS( ALPHA ).GE.ABS( X( 1 ) ) )THEN + BETA = ABS( ALPHA ) *SQRT( 1 + ( X( 1 )/ALPHA )**2 ) + ELSE + BETA = ABS( X( 1 ) )*SQRT( 1 + ( ALPHA/X( 1 ) )**2 ) + END IF + ZETA = SQRT( ( ABS( ALPHA ) + BETA )/BETA ) + IF( ALPHA.GE.ZERO ) + $ BETA = -BETA + X( 1 ) = -X( 1 )/( ZETA*BETA ) + ALPHA = BETA + END IF + ELSE +C +C Now P is larger than 2 by 2. +C + SSQ = ONE + SCALE = ZERO + CALL F06FJF( N, X, INCX, SCALE, SSQ ) +C +C Treat cases where SCALE = zero, +C SCALE .le. max( EPS*abs( ALPHA ), TOL ) and +C ALPHA = zero specially. +C Note that SCALE = max( abs( X( i ) ) ). +C + IF( ( SCALE.EQ.ZERO ).OR. + $ ( SCALE.LE.MAX( EPS*ABS( ALPHA ), TOL ) ) )THEN + ZETA = ZERO + ELSE IF( ALPHA.EQ.ZERO )THEN + ZETA = ONE + ALPHA = SCALE*SQRT( SSQ ) + CALL DSCAL( N, -1/ALPHA, X, INCX ) + ELSE + IF( SCALE.LT.ABS( ALPHA ) )THEN + BETA = ABS( ALPHA )*SQRT( 1 + SSQ*( SCALE/ALPHA )**2 ) + ELSE + BETA = SCALE *SQRT( SSQ + ( ALPHA/SCALE )**2 ) + END IF + ZETA = SQRT( ( BETA + ABS( ALPHA ) )/BETA ) + IF( ALPHA.GT.ZERO ) + $ BETA = -BETA + CALL DSCAL( N, -1/( ZETA*BETA ), X, INCX ) + ALPHA = BETA + END IF + END IF + END IF +C + RETURN +C +C End of F06FRF. ( SGRFG ) +C + END diff --git a/src/MyNag/F06HBF.f b/src/MyNag/F06HBF.f new file mode 100644 index 000000000..3471c7b29 --- /dev/null +++ b/src/MyNag/F06HBF.f @@ -0,0 +1,44 @@ + SUBROUTINE F06HBF( N, CONST, X, INCX ) +C MARK 12 RELEASE. NAG COPYRIGHT 1986. +C .. Scalar Arguments .. + COMPLEX*16 CONST + INTEGER INCX, N +C .. Array Arguments .. + COMPLEX*16 X( * ) +C .. +C +C F06HBF performs the operation +C +C x = const*e, e' = ( 1 1 ... 1 ). +C +C +C Nag Fortran 77 O( n ) basic linear algebra routine. +C +C -- Written on 22-September-1983. +C Sven Hammarling, Nag Central Office. +C +C +C .. Parameters .. + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) +C .. Local Scalars .. + INTEGER IX +C .. +C .. Executable Statements .. + IF( N.GT.0 )THEN + IF( CONST.NE.ZERO )THEN + DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX + X( IX ) = CONST + 10 CONTINUE + ELSE + DO 20, IX = 1, 1 + ( N - 1 )*INCX, INCX + X( IX ) = ZERO + 20 CONTINUE + END IF + END IF +C + RETURN +C +C End of F06HBF. ( CLOAD ) +C + END diff --git a/src/MyNag/F06HRF.f b/src/MyNag/F06HRF.f new file mode 100644 index 000000000..103eda7cf --- /dev/null +++ b/src/MyNag/F06HRF.f @@ -0,0 +1,164 @@ + SUBROUTINE F06HRF( N, ALPHA, X, INCX, TOL, THETA ) +C MARK 12 RELEASE. NAG COPYRIGHT 1986. +C .. Scalar Arguments .. + COMPLEX*16 ALPHA, THETA + DOUBLE PRECISION TOL + INTEGER INCX, N +C .. Array Arguments .. + COMPLEX*16 X( * ) +C .. +C +C F06HRF generates details of a generalized Householder reflection such +C that +C +C P*( alpha ) = ( beta ), conjg( P' )*P = I, aimag( beta ) = 0.0. +C ( x ) ( 0 ) +C +C P is given in the form +C +C P = I - gamma*( zeta )*( zeta conjg( z' ) ), +C ( z ) +C +C where z is an n element vector, gamma is a scalar such that +C +C real ( gamma ) = 1.0, +C aimag( gamma ) = aimag( alpha )/( beta - real( alpha ) ) +C +C and zeta is a real scalar that satisfies +C +C 1.0 .le. zeta .le. sqrt( 2.0 ). +C +C Note that when alpha is real then gamma = 1.0. +C +C gamma and zeta are returned in THETA as +C +C THETA = ( zeta, aimag( gamma ) ) +C +C unless x is such that +C +C max( abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ) .le. +C max( tol, eps*max( abs( real( alpha ) ), +C abs( aimag( alpha ) ) ) ), +C +C where eps is the relative machine precision and tol is the user +C supplied tolerance TOL, in which case THETA is returned as 0.0, or +C THETA is such that real( THETA ) .le. 0.0, in which case P can be +C taken to be +C +C P = I when THETA = 0.0, +C +C P = ( THETA 0 ) when real( THETA ) .le. 0.0, THETA .ne. 0.0. +C ( 0 I ) +C +C beta is overwritten on alpha with the imaginary part of alpha set to +C zero and z is overwritten on x. +C +C The routine may be called with n = 0. +C +C +C Nag Fortran 77 O( n ) basic linear algebra routine. +C +C -- Written on 30-August-1984. +C Sven Hammarling, Nag Central Office. +C +C +C .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) +C .. Local Scalars .. + COMPLEX*16 GAMMA + DOUBLE PRECISION BETA, EPS, SCALE, SSQ, ZETA + LOGICAL FIRST +C .. Local Arrays .. + COMPLEX*16 WORK( 1 ) +C .. External Functions .. + DOUBLE PRECISION X02AJF + EXTERNAL X02AJF +C .. External Subroutines .. + EXTERNAL ZSCAL, ZDSCAL, F06KJF +C .. Intrinsic Functions .. + INTRINSIC ABS, DIMAG, DCMPLX, DCONJG, MAX, DREAL, SIGN, + $ SQRT +C .. Save statement .. + SAVE EPS, FIRST +C .. Data statements .. + DATA FIRST/ .TRUE. / +C .. +C .. Executable Statements .. + IF( N.LT.1 )THEN + IF( DIMAG( ALPHA ).EQ.DREAL( ZERO ) )THEN + THETA = ZERO + ELSE + BETA = -SIGN ( ABS( ALPHA ), DREAL( ALPHA ) ) + THETA = DCONJG( ALPHA )/BETA + ALPHA = BETA + END IF + ELSE IF( ( N.EQ.1 ).AND.( X( 1 ).EQ.ZERO ) )THEN + IF( DIMAG( ALPHA ).EQ.DREAL( ZERO ) )THEN + THETA = ZERO + ELSE + BETA = -SIGN ( ABS( ALPHA ), DREAL( ALPHA ) ) + THETA = DCONJG( ALPHA )/BETA + ALPHA = BETA + END IF + ELSE +C + IF( FIRST )THEN + FIRST = .FALSE. + EPS = X02AJF( ) + END IF +C + SSQ = ONE + SCALE = DREAL( ZERO ) + CALL F06KJF( N, X, INCX, SCALE, SSQ ) +C +C Treat cases where SCALE = zero, SCALE is negligible +C and ALPHA = zero specially. +C Note that +C SCALE = max( abs( real( X( i ) ) ), abs( aimag( X( i ) ) ) ). +C + IF( ( SCALE.EQ.DREAL( ZERO ) ).OR. + $ ( SCALE.LE.MAX( TOL, + $ EPS*MAX( ABS( DREAL ( ALPHA ) ), + $ ABS( DIMAG( ALPHA ) ) ) ) ) )THEN + IF( DIMAG( ALPHA ).EQ.DREAL( ZERO ) )THEN + THETA = ZERO + ELSE + BETA = -SIGN ( ABS( ALPHA ), DREAL( ALPHA ) ) + THETA = DCONJG( ALPHA )/BETA + ALPHA = BETA + END IF + ELSE IF( ALPHA.EQ.ZERO )THEN + THETA = ONE + BETA = SCALE*SQRT( SSQ ) + CALL ZDSCAL( N, -1/BETA, X, INCX ) + ALPHA = BETA + ELSE + WORK( 1 ) = ALPHA + CALL F06KJF( 1, WORK, 1, SCALE, SSQ ) + BETA = SCALE*SQRT( SSQ ) + ZETA = SQRT( ( BETA + ABS( DREAL( ALPHA ) ) )/BETA ) + IF( DREAL( ALPHA ).GT.DREAL( ZERO ) ) + $ BETA = -BETA + IF( DIMAG( ALPHA ).EQ.DREAL( ZERO ) )THEN + CALL ZDSCAL( N, -1/( ZETA*BETA ), X, INCX ) + THETA = ZETA + ALPHA = BETA + ELSE + GAMMA = DCMPLX( ONE, + $ DIMAG( ALPHA )/( BETA - DREAL( ALPHA ))) + CALL ZSCAL( N, -1/( DCONJG( GAMMA )*ZETA*BETA ), + $ X, INCX ) + THETA = DCMPLX( ZETA, DIMAG( GAMMA ) ) + ALPHA = BETA + END IF + END IF + END IF +C + RETURN +C +C End of F06HRF. ( CGRFG ) +C + END diff --git a/src/MyNag/F06KJF.f b/src/MyNag/F06KJF.f new file mode 100644 index 000000000..d58f83c74 --- /dev/null +++ b/src/MyNag/F06KJF.f @@ -0,0 +1,74 @@ + SUBROUTINE F06KJF( N, X, INCX, SCALE, SUMSQ ) +C MARK 12 RELEASE. NAG COPYRIGHT 1986. +C .. Scalar Arguments .. + DOUBLE PRECISION SCALE, SUMSQ + INTEGER INCX, N +C .. Array Arguments .. + COMPLEX*16 X( * ) +C .. +C +C F06KJF returns the values scl and ssq such that +C +C ( scl**2 )*ssq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, +C +C where x( i ) = abs( X( 1 + ( i - 1 )*INCX ) ). The value of sumsq is +C assumed to be at least unity and the value of ssq will then satisfy +C +C 1.0 .le. ssq .le. ( sumsq + 2*n ). +C +C scale is assumed to be non-negative and scl returns the value +C +C scl = max( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ), +C i +C +C scale and sumsq must be supplied in SCALE and SUMSQ respectively. +C SCALE and SUMSQ are overwritten by scl and ssq respectively. +C +C The routine makes only one pass through the vector X. +C +C +C Nag Fortran 77 basic linear algebra routine. +C Nag Fortran 77 O( n ) basic linear algebra routine. +C +C -- Written on 27-April-1983. +C Sven Hammarling, Nag Central Office. +C +C +C .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +C .. Local Scalars .. + DOUBLE PRECISION TEMP1 + INTEGER IX +C .. Intrinsic Functions .. + INTRINSIC ABS, DIMAG, DREAL +C .. +C .. Executable Statements .. + IF( N.GT.0 )THEN + DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX + IF( DREAL( X( IX ) ).NE.ZERO )THEN + TEMP1 = ABS( DREAL( X( IX ) ) ) + IF( SCALE.LT.TEMP1 )THEN + SUMSQ = 1 + SUMSQ*( SCALE/TEMP1 )**2 + SCALE = TEMP1 + ELSE + SUMSQ = SUMSQ + ( TEMP1/SCALE )**2 + END IF + END IF + IF( DIMAG( X( IX ) ).NE.ZERO )THEN + TEMP1 = ABS( DIMAG( X( IX ) ) ) + IF( SCALE.LT.TEMP1 )THEN + SUMSQ = 1 + SUMSQ*( SCALE/TEMP1 )**2 + SCALE = TEMP1 + ELSE + SUMSQ = SUMSQ + ( TEMP1/SCALE )**2 + END IF + END IF + 10 CONTINUE + END IF +C + RETURN +C +C End of F06KJF. ( SCSSQ ) +C + END diff --git a/src/MyNag/F06QHF.f b/src/MyNag/F06QHF.f new file mode 100644 index 000000000..e186b4b72 --- /dev/null +++ b/src/MyNag/F06QHF.f @@ -0,0 +1,77 @@ + SUBROUTINE F06QHF( MATRIX, M, N, CONST, DIAG, A, LDA ) +C MARK 13 RELEASE. NAG COPYRIGHT 1988. +C .. Scalar Arguments .. + CHARACTER*1 MATRIX + DOUBLE PRECISION CONST, DIAG + INTEGER LDA, M, N +C .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +C .. +C +C F06QHF forms the m by n matrix A given by +C +C a( i, j ) = ( diag i.eq.j, +C ( +C ( const i.ne.j. +C +C If MATRIX = 'G' or 'g' then A is regarded as a general matrix, +C if MATRIX = 'U' or 'u' then A is regarded as upper triangular, +C and only elements for which i.le.j are +C referenced, +C if MATRIX = 'L' or 'l' then A is regarded as lower triangular, +C and only elements for which i.ge.j are +C referenced. +C +C +C Nag Fortran 77 O( n**2 ) basic linear algebra routine. +C +C -- Written on 21-November-1986. +C Sven Hammarling, Nag Central Office. +C +C +C .. Local Scalars .. + INTEGER I, J +C .. Intrinsic Functions .. + INTRINSIC MIN +C .. +C .. Executable Statements .. + IF( ( MATRIX.EQ.'G' ).OR.( MATRIX.EQ.'g' ) )THEN + DO 20 J = 1, N + DO 10 I = 1, M + A( I, J ) = CONST + 10 CONTINUE + 20 CONTINUE + IF( CONST.NE.DIAG )THEN + DO 30 I = 1, MIN( M, N ) + A( I, I ) = DIAG + 30 CONTINUE + END IF + ELSE IF( ( MATRIX.EQ.'U' ).OR.( MATRIX.EQ.'u' ) )THEN + DO 50 J = 1, N + DO 40 I = 1, MIN( M, J ) + A( I, J ) = CONST + 40 CONTINUE + 50 CONTINUE + IF( CONST.NE.DIAG )THEN + DO 60 I = 1, MIN( M, N ) + A( I, I ) = DIAG + 60 CONTINUE + END IF + ELSE IF( ( MATRIX.EQ.'L' ).OR.( MATRIX.EQ.'l' ) )THEN + DO 80 J = 1, MIN( M, N ) + DO 70 I = J, M + A( I, J ) = CONST + 70 CONTINUE + 80 CONTINUE + IF( CONST.NE.DIAG )THEN + DO 90 I = 1, MIN( M, N ) + A( I, I ) = DIAG + 90 CONTINUE + END IF + END IF +C + RETURN +C +C End of F06QHF. ( SMLOAD ) +C + END diff --git a/src/MyNag/F06THF.f b/src/MyNag/F06THF.f new file mode 100644 index 000000000..1223f09fd --- /dev/null +++ b/src/MyNag/F06THF.f @@ -0,0 +1,77 @@ + SUBROUTINE F06THF( MATRIX, M, N, CONST, DIAG, A, LDA ) +C MARK 13 RELEASE. NAG COPYRIGHT 1988. +C .. Scalar Arguments .. + CHARACTER*1 MATRIX + COMPLEX*16 CONST, DIAG + INTEGER LDA, M, N +C .. Array Arguments .. + COMPLEX*16 A( LDA, * ) +C .. +C +C F06THF forms the m by n matrix A given by +C +C a( i, j ) = ( diag i.eq.j, +C ( +C ( const i.ne.j. +C +C If MATRIX = 'G' or 'g' then A is regarded as a general matrix, +C if MATRIX = 'U' or 'u' then A is regarded as upper triangular, +C and only elements for which i.le.j are +C referenced, +C if MATRIX = 'L' or 'l' then A is regarded as lower triangular, +C and only elements for which i.ge.j are +C referenced. +C +C +C Nag Fortran 77 O( n**2 ) basic linear algebra routine. +C +C -- Written on 21-November-1986. +C Sven Hammarling, Nag Central Office. +C +C +C .. Local Scalars .. + INTEGER I, J +C .. Intrinsic Functions .. + INTRINSIC MIN +C .. +C .. Executable Statements .. + IF( ( MATRIX.EQ.'G' ).OR.( MATRIX.EQ.'g' ) )THEN + DO 20 J = 1, N + DO 10 I = 1, M + A( I, J ) = CONST + 10 CONTINUE + 20 CONTINUE + IF( CONST.NE.DIAG )THEN + DO 30 I = 1, MIN( M, N ) + A( I, I ) = DIAG + 30 CONTINUE + END IF + ELSE IF( ( MATRIX.EQ.'U' ).OR.( MATRIX.EQ.'u' ) )THEN + DO 50 J = 1, N + DO 40 I = 1, MIN( M, J ) + A( I, J ) = CONST + 40 CONTINUE + 50 CONTINUE + IF( CONST.NE.DIAG )THEN + DO 60 I = 1, MIN( M, N ) + A( I, I ) = DIAG + 60 CONTINUE + END IF + ELSE IF( ( MATRIX.EQ.'L' ).OR.( MATRIX.EQ.'l' ) )THEN + DO 80 J = 1, MIN( M, N ) + DO 70 I = J, M + A( I, J ) = CONST + 70 CONTINUE + 80 CONTINUE + IF( CONST.NE.DIAG )THEN + DO 90 I = 1, MIN( M, N ) + A( I, I ) = DIAG + 90 CONTINUE + END IF + END IF +C + RETURN +C +C End of F06THF. ( CMLOAD ) +C + END diff --git a/src/MyNag/Makefile b/src/MyNag/Makefile new file mode 100644 index 000000000..4df7646e8 --- /dev/null +++ b/src/MyNag/Makefile @@ -0,0 +1,11 @@ +LIB=libnag.a +OBJS=F01QCF.o F01REF.o F06FRF.o F06QHF.o P01ABY.o X04AAF.o\ +F01QDF.o F06AAZ.o F06HBF.o F06THF.o P01ABZ.o X04BAF.o\ +F01QEF.o F06FBF.o F06HRF.o P01ABF.o P01ACF.o\ +F01RCF.o F06FJF.o F06KJF.o P01ABW.o X02AJF.o +$(LIB): $(OBJS) + ar r $(LIB) $(OBJS) +.f.o: + $(FC) $(FLAGS) $< +clean: + rm $(LIB) $(OBJS) diff --git a/src/MyNag/P01ABF.f b/src/MyNag/P01ABF.f new file mode 100644 index 000000000..2c26e6712 --- /dev/null +++ b/src/MyNag/P01ABF.f @@ -0,0 +1,82 @@ + INTEGER FUNCTION P01ABF(IFAIL,IERROR,SRNAME,NREC,REC) +C MARK 11.5(F77) RELEASE. NAG COPYRIGHT 1986. +C MARK 13 REVISED. IER-621 (APR 1988). +C MARK 13B REVISED. IER-668 (AUG 1988). +C +C P01ABF is the error-handling routine for the NAG Library. +C +C P01ABF either returns the value of IERROR through the routine +C name (soft failure), or terminates execution of the program +C (hard failure). Diagnostic messages may be output. +C +C If IERROR = 0 (successful exit from the calling routine), +C the value 0 is returned through the routine name, and no +C message is output +C +C If IERROR is non-zero (abnormal exit from the calling routine), +C the action taken depends on the value of IFAIL. +C +C IFAIL = 1: soft failure, silent exit (i.e. no messages are +C output) +C IFAIL = -1: soft failure, noisy exit (i.e. messages are output) +C IFAIL =-13: soft failure, noisy exit but standard messages from +C P01ABF are suppressed +C IFAIL = 0: hard failure, noisy exit +C +C For compatibility with certain routines included before Mark 12 +C P01ABF also allows an alternative specification of IFAIL in which +C it is regarded as a decimal integer with least significant digits +C cba. Then +C +C a = 0: hard failure a = 1: soft failure +C b = 0: silent exit b = 1: noisy exit +C +C except that hard failure now always implies a noisy exit. +C +C S.Hammarling, M.P.Hooper and J.J.du Croz, NAG Central Office. +C +C .. Scalar Arguments .. + INTEGER IERROR, IFAIL, NREC + CHARACTER*(*) SRNAME +C .. Array Arguments .. + CHARACTER*(*) REC(*) +C .. Local Scalars .. + INTEGER I, NERR + CHARACTER*72 MESS +C .. External Subroutines .. + EXTERNAL P01ABZ, X04AAF, X04BAF +C .. Intrinsic Functions .. + INTRINSIC ABS, MOD +C .. Executable Statements .. + IF (IERROR.NE.0) THEN +C Abnormal exit from calling routine + IF (IFAIL.EQ.-1 .OR. IFAIL.EQ.0 .OR. IFAIL.EQ.-13 .OR. + * (IFAIL.GT.0 .AND. MOD(IFAIL/10,10).NE.0)) THEN +C Noisy exit + CALL X04AAF(0,NERR) + DO 20 I = 1, NREC + CALL X04BAF(NERR,REC(I)) + 20 CONTINUE + IF (IFAIL.NE.-13) THEN + WRITE (MESS,FMT=99999) SRNAME, IERROR + CALL X04BAF(NERR,MESS) + IF (ABS(MOD(IFAIL,10)).NE.1) THEN +C Hard failure + CALL X04BAF(NERR, + * ' ** NAG hard failure - execution terminated' + * ) + CALL P01ABZ + ELSE +C Soft failure + CALL X04BAF(NERR, + * ' ** NAG soft failure - control returned') + END IF + END IF + END IF + END IF + P01ABF = IERROR + RETURN +C +99999 FORMAT (' ** ABNORMAL EXIT from NAG Library routine ',A,': IFAIL', + * ' =',I6) + END diff --git a/src/MyNag/P01ABW.f b/src/MyNag/P01ABW.f new file mode 100644 index 000000000..018a9fc29 --- /dev/null +++ b/src/MyNag/P01ABW.f @@ -0,0 +1,54 @@ + SUBROUTINE P01ABW(N,NAME,INFORM,IERR,SRNAME) +C MARK 12 RELEASE. NAG COPYRIGHT 1986. +C +C P01ABW increases the value of IERR by 1 and, if +C +C ( mod( INFORM, 10 ).ne.1 ).or.( mod( INFORM/10, 10 ).ne.0 ) +C +C writes a message on the current error message channel giving the +C value of N, a message to say that N is invalid and the strings +C NAME and SRNAME. +C +C NAME must be the name of the actual argument for N and SRNAME must +C be the name of the calling routine. +C +C This routine is intended for use when N is an invalid input +C parameter to routine SRNAME. For example +C +C IERR = 0 +C IF( N.NE.'Valid value' ) +C $ CALL P01ABW( N, 'N', IDIAG, IERR, SRNAME ) +C +C -- Written on 15-November-1984. +C Sven Hammarling, Nag Central Office. +C +C .. Scalar Arguments .. + INTEGER IERR, INFORM + CHARACTER*(*) N + CHARACTER*(*) NAME, SRNAME +C .. Local Scalars .. + INTEGER NERR +C .. Local Arrays .. + CHARACTER*65 REC(3) +C .. External Subroutines .. + EXTERNAL X04AAF, X04BAF +C .. Intrinsic Functions .. + INTRINSIC MOD +C .. Executable Statements .. + IERR = IERR + 1 + IF ((MOD(INFORM,10).NE.1) .OR. (MOD(INFORM/10,10).NE.0)) THEN + CALL X04AAF(0,NERR) + WRITE (REC,FMT=99999) NAME, SRNAME, N + CALL X04BAF(NERR,' ') + CALL X04BAF(NERR,REC(1)) + CALL X04BAF(NERR,REC(2)) + CALL X04BAF(NERR,REC(3)) + END IF + RETURN +C +C +C End of P01ABW. +C +99999 FORMAT (' ***** Parameter ',A,' is invalid in routine ',A, + * ' ***** ',/8X,'Value supplied is',/8X,A) + END diff --git a/src/MyNag/P01ABY.f b/src/MyNag/P01ABY.f new file mode 100644 index 000000000..b44156602 --- /dev/null +++ b/src/MyNag/P01ABY.f @@ -0,0 +1,50 @@ + SUBROUTINE P01ABY(N,NAME,INFORM,IERR,SRNAME) +C MARK 12 RELEASE. NAG COPYRIGHT 1986. +C +C P01ABY increases the value of IERR by 1 and, if +C +C ( mod( INFORM, 10 ).ne.1 ).or.( mod( INFORM/10, 10 ).ne.0 ) +C +C writes a message on the current error message channel giving the +C value of N, a message to say that N is invalid and the strings +C NAME and SRNAME. +C +C NAME must be the name of the actual argument for N and SRNAME must +C be the name of the calling routine. +C +C This routine is intended for use when N is an invalid input +C parameter to routine SRNAME. For example +C +C IERR = 0 +C IF( N.LT.1 )CALL P01ABY( N, 'N', IDIAG, IERR, SRNAME ) +C +C -- Written on 23-February-1984. Sven. +C +C .. Scalar Arguments .. + INTEGER IERR, INFORM, N + CHARACTER*(*) NAME, SRNAME +C .. Local Scalars .. + INTEGER NERR +C .. Local Arrays .. + CHARACTER*65 REC(2) +C .. External Subroutines .. + EXTERNAL X04AAF, X04BAF +C .. Intrinsic Functions .. + INTRINSIC MOD +C .. Executable Statements .. + IERR = IERR + 1 + IF ((MOD(INFORM,10).NE.1) .OR. (MOD(INFORM/10,10).NE.0)) THEN + CALL X04AAF(0,NERR) + WRITE (REC,FMT=99999) NAME, SRNAME, N + CALL X04BAF(NERR,' ') + CALL X04BAF(NERR,REC(1)) + CALL X04BAF(NERR,REC(2)) + END IF + RETURN +C +C +C End of P01ABY. +C +99999 FORMAT (' ***** Parameter ',A,' is invalid in routine ',A, + * ' ***** ',/8X,'Value supplied is ',I6) + END diff --git a/src/MyNag/P01ABZ.f b/src/MyNag/P01ABZ.f new file mode 100644 index 000000000..f48c1690d --- /dev/null +++ b/src/MyNag/P01ABZ.f @@ -0,0 +1,15 @@ + SUBROUTINE P01ABZ +C MARK 11.5(F77) RELEASE. NAG COPYRIGHT 1986. +C +C Terminates execution when a hard failure occurs. +C +C ******************** IMPLEMENTATION NOTE ******************** +C The following STOP statement may be replaced by a call to an +C implementation-dependent routine to display a message and/or +C to abort the program. +C ************************************************************* +C .. Executable Statements .. +C F.Assaad extension. ERRTRA commented out. +C CALL ERRTRA + STOP + END diff --git a/src/MyNag/P01ACF.f b/src/MyNag/P01ACF.f new file mode 100644 index 000000000..66fbf97ea --- /dev/null +++ b/src/MyNag/P01ACF.f @@ -0,0 +1,96 @@ + INTEGER FUNCTION P01ACF(IFAIL,IERROR,SRNAME,VARBNM,NREC,REC) +C MARK 15 RELEASE. NAG COPYRIGHT 1991. +C +C P01ACF is the error-handling routine for the F06 AND F07 +C Chapters of the NAG Fortran Library. It is a slightly modified +C version of P01ABF. +C +C P01ACF either returns the value of IERROR through the routine +C name (soft failure), or terminates execution of the program +C (hard failure). Diagnostic messages may be output. +C +C If IERROR = 0 (successful exit from the calling routine), +C the value 0 is returned through the routine name, and no +C message is output +C +C If IERROR is non-zero (abnormal exit from the calling routine), +C the action taken depends on the value of IFAIL. +C +C IFAIL = 1: soft failure, silent exit (i.e. no messages are +C output) +C IFAIL = -1: soft failure, noisy exit (i.e. messages are output) +C IFAIL =-13: soft failure, noisy exit but standard messages from +C P01ACF are suppressed +C IFAIL = 0: hard failure, noisy exit +C +C For compatibility with certain routines included before Mark 12 +C P01ACF also allows an alternative specification of IFAIL in which +C it is regarded as a decimal integer with least significant digits +C cba. Then +C +C a = 0: hard failure a = 1: soft failure +C b = 0: silent exit b = 1: noisy exit +C +C except that hard failure now always implies a noisy exit. +C +C S.Hammarling, M.P.Hooper and J.J.du Croz, NAG Central Office. +C +C .. Scalar Arguments .. + INTEGER IERROR, IFAIL, NREC + CHARACTER*(*) SRNAME, VARBNM +C .. Array Arguments .. + CHARACTER*(*) REC(*) +C .. Local Scalars .. + INTEGER I, NERR, VARLEN + CHARACTER*72 MESS +C .. External Subroutines .. + EXTERNAL P01ABZ, X04AAF, X04BAF +C .. Intrinsic Functions .. + INTRINSIC ABS, LEN, MOD +C .. Executable Statements .. + IF (IERROR.NE.0) THEN + VARLEN = 0 + DO 20 I = LEN(VARBNM), 1, -1 + IF (VARBNM(I:I).NE.' ') THEN + VARLEN = I + GO TO 40 + END IF + 20 CONTINUE + 40 CONTINUE +C Abnormal exit from calling routine + IF (IFAIL.EQ.-1 .OR. IFAIL.EQ.0 .OR. IFAIL.EQ.-13 .OR. + * (IFAIL.GT.0 .AND. MOD(IFAIL/10,10).NE.0)) THEN +C Noisy exit + CALL X04AAF(0,NERR) + DO 60 I = 1, NREC + CALL X04BAF(NERR,REC(I)) + 60 CONTINUE + IF (IFAIL.NE.-13) THEN + IF (VARLEN.NE.0) THEN + WRITE (MESS,FMT=99999) SRNAME, VARBNM(1:VARLEN), + * IERROR + ELSE + WRITE (MESS,FMT=99998) SRNAME + END IF + CALL X04BAF(NERR,MESS) + IF (ABS(MOD(IFAIL,10)).NE.1) THEN +C Hard failure + CALL X04BAF(NERR, + * ' ** NAG hard failure - execution terminated' + * ) + CALL P01ABZ + ELSE +C Soft failure + CALL X04BAF(NERR, + * ' ** NAG soft failure - control returned') + END IF + END IF + END IF + END IF + P01ACF = IERROR + RETURN +C +99999 FORMAT (' ** ABNORMAL EXIT from NAG Library routine ',A,': ',A, + * ' =',I6) +99998 FORMAT (' ** ABNORMAL EXIT from NAG Library routine ',A) + END diff --git a/src/MyNag/X02AJF.f b/src/MyNag/X02AJF.f new file mode 100644 index 000000000..aac6508a3 --- /dev/null +++ b/src/MyNag/X02AJF.f @@ -0,0 +1,13 @@ + DOUBLE PRECISION FUNCTION X02AJF() +C MARK 12 RELEASE. NAG COPYRIGHT 1986. +C +C RETURNS (1/2)*B**(1-P) IF ROUNDS IS .TRUE. +C RETURNS B**(1-P) OTHERWISE +C +C .. Local Scalars .. + DOUBLE PRECISION Z + DATA Z/0.222044604925031336E-15/ +C .. Executable Statements .. + X02AJF = Z + RETURN + END diff --git a/src/MyNag/X04AAF.f b/src/MyNag/X04AAF.f new file mode 100644 index 000000000..7395c062c --- /dev/null +++ b/src/MyNag/X04AAF.f @@ -0,0 +1,23 @@ + SUBROUTINE X04AAF(I,NERR) +C MARK 7 RELEASE. NAG COPYRIGHT 1978 +C MARK 7C REVISED IER-190 (MAY 1979) +C MARK 11.5(F77) REVISED. (SEPT 1985.) +C MARK 14 REVISED. IER-829 (DEC 1989). +C IF I = 0, SETS NERR TO CURRENT ERROR MESSAGE UNIT NUMBER +C (STORED IN NERR1). +C IF I = 1, CHANGES CURRENT ERROR MESSAGE UNIT NUMBER TO +C VALUE SPECIFIED BY NERR. +C +C .. Scalar Arguments .. + INTEGER I, NERR +C .. Local Scalars .. + INTEGER NERR1 +C .. Save statement .. + SAVE NERR1 +C .. Data statements .. + DATA NERR1/6/ +C .. Executable Statements .. + IF (I.EQ.0) NERR = NERR1 + IF (I.EQ.1) NERR1 = NERR + RETURN + END diff --git a/src/MyNag/X04BAF.f b/src/MyNag/X04BAF.f new file mode 100644 index 000000000..b1827c4b1 --- /dev/null +++ b/src/MyNag/X04BAF.f @@ -0,0 +1,30 @@ + SUBROUTINE X04BAF(NOUT,REC) +C MARK 11.5(F77) RELEASE. NAG COPYRIGHT 1986. +C +C X04BAF writes the contents of REC to the unit defined by NOUT. +C +C Trailing blanks are not output, except that if REC is entirely +C blank, a single blank character is output. +C If NOUT.lt.0, i.e. if NOUT is not a valid Fortran unit identifier, +C then no output occurs. +C +C .. Scalar Arguments .. + INTEGER NOUT + CHARACTER*(*) REC +C .. Local Scalars .. + INTEGER I +C .. Intrinsic Functions .. + INTRINSIC LEN +C .. Executable Statements .. + IF (NOUT.GE.0) THEN +C Remove trailing blanks + DO 20 I = LEN(REC), 2, -1 + IF (REC(I:I).NE.' ') GO TO 40 + 20 CONTINUE +C Write record to external file + 40 WRITE (NOUT,FMT=99999) REC(1:I) + END IF + RETURN +C +99999 FORMAT (A) + END diff --git a/src/MyNag/comp b/src/MyNag/comp new file mode 100644 index 000000000..189980942 --- /dev/null +++ b/src/MyNag/comp @@ -0,0 +1 @@ +if77 -c -O4 -Mvect -nx *.f diff --git a/src/MyNag/work.pc b/src/MyNag/work.pc new file mode 100644 index 0000000000000000000000000000000000000000..879a952063cf40e6ad65c1aa519d4a43f969c8ad GIT binary patch literal 2673 zcma)7O;1x%5WRqu!bU=nm}pp;$b#T2Azd{lt=JGWrX?gm7h*ps^_x~y?5}X?4=^rS zxNyOe7#GGE7lt))WeiK!>N#`Yyf-|nIHB*JJ2Us(duHx?4CS_-)~nlBFQl7p`pQ{1 zoZfU36XR~eITzrUPC0k?jB}%xo$JTE-}T|?B<~#Z(!jr9^l@Z#9KQklCPN>F6E*;j z96a2M9P_|QjuL#>+Eq*pFfwwy#7xio3OLE}8a|$R*TeuLBgZ~w%JC66$#D>7(@%>Q zhkzW1z{>F*So1it9>@66IH&np{3ORuOtl^;{$x`?H3bEavT|sW0R*G(iAM>oMzV(Q_Bb%r&`8F^RxI#j*8)^_275}AN#UnVlji)^2TuNnmq1F zEqm~Bd~ae&j?aeUz~m{%H~46r)BG%cQp=IyIPSqAjXi~91kKl)jsfdl9HlS39H($h z8IGU_NA5p3iiYD>4~`0ayz31UlY@m1)??Rjyfb;KWgk8o=QKZypXB&tIKKAaID`+M zPxr&bVg~;`9YuoH^gOWc#gR3=1Rs{W852u#+zdJR?Orx{%5eui8s{`Wi=Qc13Nra? z#bGz?!OUYf zQKJAFZE7@ARs{g6pluY$xnnI*(DVu#qF~Tr>`)PlaNVDSK)E^_aSdW5YEIN;yY-K{ z_{!BHMN6UH;*##;PsNVSR;f)^gen_hZBdKzLbwt@Yti;QOXb(J@@o=}Px$9eNV(Nu zE}ti#2eLx*q#ot@upR(fk9Om)RnRJ@SX0~%Tia|tU-3N#(34lIT`J`|c1-TVLLpQL zpn0vRa?7e8K%-&hML+lOK%#OY>>*kUsue(@&?@hQ*Q&iQ$GvZx-X}UP%-W~014-4s zZ@!a}f}-jJPzB8>x}Y}$K%?@;C2oei9Ye0`x8VC|-#=DRs^B@|vubzc%W(30AT^rJ O%e%H35QH_7`}iB4UTl{D literal 0 HcmV?d00001 diff --git a/src/MyNag/work.pcl b/src/MyNag/work.pcl new file mode 100644 index 000000000..7f6c06e22 --- /dev/null +++ b/src/MyNag/work.pcl @@ -0,0 +1 @@ +work.pc diff --git a/src/Prog/CMakeLists.txt b/src/Prog/CMakeLists.txt new file mode 100644 index 000000000..5cde6af0b --- /dev/null +++ b/src/Prog/CMakeLists.txt @@ -0,0 +1,68 @@ +######################################## +# Set up how to compile the source files +######################################## + +# Add the source files +SET(Common_src ${SRCPROG}/Hop_mod.f90 + ${SRCPROG}/Operator.f90 + ${SRCPROG}/UDV_WRAP.F90 + ${SRCPROG}/cgr1.f90 + ${SRCPROG}/cgr2.f90 + ${SRCPROG}/cgr2_1.f90 + ${SRCPROG}/cgr2_2.f90 + ${SRCPROG}/control_mod.F90 + ${SRCPROG}/gperp.F90 + ${SRCPROG}/inconfc.F90 + ${SRCPROG}/main.F90 + ${SRCPROG}/nranf.f90 + ${SRCPROG}/outconfc.F90 + ${SRCPROG}/print_bin_mod.F90 + ${SRCPROG}/tau_m.f90 + ${SRCPROG}/upgrade.f90 + ${SRCPROG}/wrapgrdo.f90 + ${SRCPROG}/wrapgrup.f90 + ${SRCPROG}/wrapul.f90 + ${SRCPROG}/wrapur.f90 +) + +##################################### +# Tell how to install this executable +##################################### + +IF(WIN32) + SET(CMAKE_INSTALL_PREFIX "C:\\Program Files") +ELSE() + SET(CMAKE_INSTALL_PREFIX /usr/local) +ENDIF(WIN32) +#INSTALL(TARGETS ${PROGEXE} RUNTIME DESTINATION bin) + +# Define the executables in terms of the source files +#Add in this loop further models +FOREACH(MODELTYPE Hub SPT Ising) +SET(${MODELTYPE}_src ${SRCPROG}/Hamiltonian_${MODELTYPE}.F90 ${Common_src}) +ADD_EXECUTABLE(${PROGEXE}_${MODELTYPE} ${${MODELTYPE}_src}) + +##################################################### +# Add the needed libraries and special compiler flags +##################################################### +TARGET_LINK_LIBRARIES(${PROGEXE}_${MODELTYPE} ${MODULES} ${MYEIS} ${MYNAG} ${MYLIN}) + +# Uncomment if you need to link to BLAS and LAPACK +TARGET_LINK_LIBRARIES(${PROGEXE}_${MODELTYPE} ${BLAS_LIBRARIES} + ${LAPACK_LIBRARIES} + ${CMAKE_THREAD_LIBS_INIT}) + +# Uncomment if you have parallization +IF(USE_OPENMP) + SET_TARGET_PROPERTIES(${PROGEXE}_${MODELTYPE} PROPERTIES + COMPILE_FLAGS "${OpenMP_Fortran_FLAGS}" + LINK_FLAGS "${OpenMP_Fortran_FLAGS}") +ELSEIF(USE_MPI) + SET_TARGET_PROPERTIES(${PROGEXE}_${MODELTYPE} PROPERTIES + COMPILE_FLAGS "${MPI_Fortran_COMPILE_FLAGS}" + LINK_FLAGS "${MPI_Fortran_LINK_FLAGS}") + INCLUDE_DIRECTORIES(${MPI_Fortran_INCLUDE_PATH}) + TARGET_LINK_LIBRARIES(${PROGEXE}_${MODELTYPE} ${MPI_Fortran_LIBRARIES}) +ENDIF(USE_OPENMP) +INSTALL(TARGETS ${PROGEXE}_${MODELTYPE} RUNTIME DESTINATION bin) +ENDFOREACH() diff --git a/src/Prog/Hamiltonian_Hub.F90 b/src/Prog/Hamiltonian_Hub.F90 new file mode 100644 index 000000000..72a1d5f17 --- /dev/null +++ b/src/Prog/Hamiltonian_Hub.F90 @@ -0,0 +1,539 @@ + Module Hamiltonian + + Use Operator_mod + Use Lattices_v3 + Use MyMats + Use Random_Wrap + Use Files_mod + Use Matrix + Use Print_bin_mod + + + Type (Operator), dimension(:,:), allocatable :: Op_V + Type (Operator), dimension(:,:), allocatable :: Op_T + Integer, allocatable :: nsigma(:,:) + Integer :: Ndim, N_FL, N_SUN, Ltrot + !Complex (Kind=8), dimension(:,:,:), allocatable :: Exp_T(:,:,:), Exp_T_M1(:,:,:) + + ! ToDo. Public and private subroutines. + + ! What is below is private + Type (Lattice), private :: Latt + Integer, private :: L1, L2 + real (Kind=8), private :: ham_T , ham_U, Ham_chem + real (Kind=8), private :: Dtau, Beta + Character (len=64), private :: Model, Lattice_type + Logical, private :: One_dimensional + Integer, private :: N_coord + + + ! Observables + Integer, private :: Nobs, Norb + Complex (Kind=8), allocatable, private :: obs_scal(:) + Complex (Kind=8), allocatable, private :: Green_eq (:,:,:), SpinZ_eq (:,:,:), SpinXY_eq (:,:,:), & + & Den_eq(:,:,:) + Complex (Kind=8), allocatable, private :: Green_eq0 (:), SpinZ_eq0(:), SpinXY_eq0(:), & + & Den_eq0(:) + + ! For time displaced + Integer, private :: NobsT + Complex (Kind=8), private :: Phase_tau + Complex (Kind=8), allocatable, private :: Green_tau(:,:,:,:), Den_tau(:,:,:,:) + + contains + + + Subroutine Ham_Set + + Implicit none +#include "machine" +#ifdef MPI + include 'mpif.h' +#endif + + integer :: ierr + + + NAMELIST /VAR_lattice/ L1, L2, Lattice_type, Model + + NAMELIST /VAR_Hubbard/ ham_T, ham_chem, ham_U, Dtau, Beta + + +#ifdef MPI + Integer :: Isize, Irank + Integer :: STATUS(MPI_STATUS_SIZE) + CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) + CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) +#endif + + + ! NAMELIST /VAR_Model/ N_FL, N_SUN, ham_T , ham_xi, ham_h, ham_J, ham_U, Ham_Vint, & + ! & Dtau, Beta + + +#ifdef MPI + If (Irank == 0 ) then +#endif + OPEN(UNIT=5,FILE='parameters',STATUS='old',ACTION='read',IOSTAT=ierr) + IF (ierr /= 0) THEN + WRITE(*,*) 'unable to open ',ierr + STOP + END IF + READ(5,NML=VAR_lattice) + CLOSE(5) + +#ifdef MPI + Endif + CALL MPI_BCAST(L1 ,1 ,MPI_INTEGER, 0,MPI_COMM_WORLD,ierr) + CALL MPI_BCAST(L2 ,1 ,MPI_INTEGER, 0,MPI_COMM_WORLD,ierr) + CALL MPI_BCAST(Model ,64 ,MPI_CHARACTER, 0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(Lattice_type,64 ,MPI_CHARACTER, 0,MPI_COMM_WORLD,IERR) +#endif + Call Ham_latt + + If ( Model == "Hubbard_Mz") then + N_FL = 2 + N_SUN = 1 + elseif ( Model == "Hubbard_SU2" ) then + N_FL = 1 + N_SUN = 2 + else + Write(6,*) "Model not yet implemented!" + Stop + endif +#ifdef MPI + If (Irank == 0 ) then +#endif + OPEN(UNIT=5,FILE='parameters',STATUS='old',ACTION='read',IOSTAT=ierr) + READ(5,NML=VAR_Hubbard) + CLOSE(5) +#ifdef MPI + endif + CALL MPI_BCAST(ham_T ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) + CALL MPI_BCAST(ham_chem ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) + CALL MPI_BCAST(ham_U ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) + CALL MPI_BCAST(Dtau ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) + CALL MPI_BCAST(Beta ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) +#endif + Call Ham_hop + + Ltrot = nint(beta/dtau) +#ifdef MPI + If (Irank == 0) then +#endif + Open (Unit = 50,file="info",status="unknown",position="append") + Write(50,*) '=====================================' + Write(50,*) 'Model is : ', Model + Write(50,*) 'Beta : ', Beta + Write(50,*) 'dtau,Ltrot : ', dtau,Ltrot + Write(50,*) 'N_SUN : ', N_SUN + Write(50,*) 'N_FL : ', N_FL + Write(50,*) 't : ', Ham_T + Write(50,*) 'Ham_U : ', Ham_U + Write(50,*) 'Ham_chem : ', Ham_chem + close(50) +#ifdef MPI + endif +#endif + call Ham_V + end Subroutine Ham_Set +!============================================================================= + Subroutine Ham_Latt + Implicit none + !Set the lattice + Real (Kind=8) :: a1_p(2), a2_p(2), L1_p(2), L2_p(2) + If ( Lattice_type =="Square" ) then + a1_p(1) = 1.0 ; a1_p(2) = 0.d0 + a2_p(1) = 0.0 ; a2_p(2) = 1.d0 + L1_p = dble(L1)*a1_p + L2_p = dble(L2)*a2_p + Call Make_Lattice( L1_p, L2_p, a1_p, a2_p, Latt ) + Ndim = Latt%N + !Write(6,*) 'Lattice: ', Ndim + One_dimensional = .false. + N_coord = 2 + If ( L1 == 1 .or. L2 == 1 ) then + One_dimensional = .true. + N_coord = 1 + If (L1 == 1 ) then + Write(6,*) ' For one dimensional systems set L2 = 1 ' + Stop + endif + endif + else + Write(6,*) "Lattice not yet implemented!" + Stop + endif + end Subroutine Ham_Latt + +!=================================================================================== + Subroutine Ham_hop + Implicit none + + !Setup the hopping + !Per flavor, the hopping is given by: + ! e^{-dtau H_t} = Prod_{n=1}^{Ncheck} e^{-dtau_n H_{n,t}} + + + Integer :: I, I1, I2, n, Ncheck,nc + Real (Kind=8) :: X + + Ncheck = 1 + allocate(Op_T(Ncheck,N_FL)) + do n = 1,N_FL + Do nc = 1,Ncheck + Call Op_make(Op_T(nc,n),Ndim) + If (One_dimensional ) then + DO I = 1, Latt%N + I1 = Latt%nnlist(I,1,0) + Op_T(nc,n)%O(I,I1) = cmplx(-Ham_T,0.d0) + Op_T(nc,n)%O(I1,I) = cmplx(-Ham_T,0.d0) + Op_T(nc,n)%O(I ,I) = cmplx(-Ham_chem,0.d0) + ENDDO + else + DO I = 1, Latt%N + I1 = Latt%nnlist(I,1,0) + I2 = Latt%nnlist(I,0,1) + Op_T(nc,n)%O(I,I1) = cmplx(-Ham_T, 0.d0) + Op_T(nc,n)%O(I1,I) = cmplx(-Ham_T, 0.d0) + Op_T(nc,n)%O(I,I2) = cmplx(-Ham_T, 0.d0) + Op_T(nc,n)%O(I2,I) = cmplx(-Ham_T, 0.d0) + Op_T(nc,n)%O(I ,I) = cmplx(-Ham_chem,0.d0) + ENDDO + endif + + Do I = 1,Latt%N + Op_T(nc,n)%P(i) = i + Enddo + if ( abs(Ham_T) < 1.E-6 .and. abs(Ham_chem) < 1.E-6 ) then + Op_T(nc,n)%g=cmplx(0.d0 ,0.d0) + else + Op_T(nc,n)%g=cmplx(-Dtau,0.d0) + endif + Op_T(nc,n)%alpha=cmplx(0.d0,0.d0) + !Write(6,*) 'In Ham_hop', Ham_T + Call Op_set(Op_T(nc,n)) + !Write(6,*) 'In Ham_hop 1' + !Do I = 1,Latt%N + ! Write(6,*) Op_T(n)%E(i) + !enddo + !Call Op_exp( cmplx(-Dtau,0.d0), Op_T(n), Exp_T (:,:,n) ) + !Call Op_exp( cmplx( Dtau,0.d0), Op_T(n), Exp_T_M1(:,:,n) ) + enddo + enddo + end Subroutine Ham_hop + +!=================================================================================== + + Subroutine Ham_V + + Implicit none + + Integer :: nf, nth, n, n1, n2, n3, n4, I, I1, I2, J, Ix, Iy, nc + Real (Kind=8) :: X_p(2), X1_p(2), X2_p(2), X + + + If (Model == "Hubbard_SU2") then + !Write(50,*) 'Model is ', Model + Allocate(Op_V(Latt%N,N_FL)) + do nf = 1,N_FL + do i = 1, Latt%N + Call Op_make(Op_V(i,nf),1) + enddo + enddo + Do nf = 1,N_FL + nc = 0 + Do i = 1,Latt%N + nc = nc + 1 + Op_V(nc,nf)%P(1) = I + Op_V(nc,nf)%O(1,1) = cmplx(1.d0 ,0.d0) + Op_V(nc,nf)%g = SQRT(CMPLX(-DTAU*ham_U/(DBLE(N_SUN)),0.D0)) + Op_V(nc,nf)%alpha = cmplx(-0.5d0,0.d0) + Op_V(nc,nf)%type = 2 + Call Op_set( Op_V(nc,nf) ) + ! The operator reads: + ! g*s*( c^{dagger} O c + alpha )) + ! with s the HS field. + Enddo + Enddo + Elseif (Model == "Hubbard_Mz") then + !Write(50,*) 'Model is ', Model + Allocate(Op_V(Latt%N,N_FL)) + do nf = 1,N_FL + do i = 1, Latt%N + Call Op_make(Op_V(i,nf),1) + enddo + enddo + Do nf = 1,N_FL + nc = 0 + X = 1.d0 + if (nf == 2) X = -1.d0 + Do i = 1,Latt%N + nc = nc + 1 + Op_V(nc,nf)%P(1) = I + Op_V(nc,nf)%O(1,1) = cmplx(1.d0 ,0.d0) + Op_V(nc,nf)%g = X*SQRT(CMPLX(DTAU*ham_U/2.d0 ,0.D0)) + Op_V(nc,nf)%alpha = cmplx(0.d0,0.d0) + Op_V(nc,nf)%type = 2 + Call Op_set( Op_V(nc,nf) ) + ! The operator reads: + ! g*s*( c^{dagger} O c - alpha )) + ! with s the HS field. + ! Write(6,*) nc,nf, Op_V(nc,nf)%g + Enddo + Enddo + Endif + end Subroutine Ham_V + +!=================================================================================== + Real (Kind=8) function S0(n,nt) + Implicit none + Integer, Intent(IN) :: n,nt + Integer :: i, nt1 + S0 = 1.d0 + + end function S0 + +!=================================================================================== + Subroutine Alloc_obs(Ltau) + + Implicit none + Integer, Intent(In) :: Ltau + Integer :: I + + Allocate ( Obs_scal(5) ) + Allocate ( Green_eq(Latt%N,1,1), SpinZ_eq(Latt%N,1,1), SpinXY_eq(Latt%N,1,1), & + & Den_eq(Latt%N,1,1) ) + Allocate ( Green_eq0(1), SpinZ_eq0(1), SpinXY_eq0(1), Den_eq0(1) ) + + + If (Ltau == 1) then + Allocate ( Green_tau(Latt%N,Ltrot+1,1,1), Den_tau(Latt%N,Ltrot+1,1,1) ) + endif + + end Subroutine Alloc_obs + +!=================================================================================== + + Subroutine Init_obs(Ltau) + + Implicit none + Integer, Intent(In) :: Ltau + + Integer :: I,n + + Nobs = 0 + Obs_scal = cmplx(0.d0,0.d0) + Green_eq = cmplx(0.d0,0.d0) + SpinZ_eq = cmplx(0.d0,0.d0) + SpinXY_eq = cmplx(0.d0,0.d0) + Den_eq = cmplx(0.d0,0.d0) + Green_eq0 = cmplx(0.d0,0.d0) + SpinZ_eq0 = cmplx(0.d0,0.d0) + SpinXY_eq0= cmplx(0.d0,0.d0) + Den_eq0 = cmplx(0.d0,0.d0) + + + If (Ltau == 1) then + NobsT = 0 + Phase_tau = cmplx(0.d0,0.d0) + Green_tau = cmplx(0.d0,0.d0) + Den_tau = cmplx(0.d0,0.d0) + endif + + end Subroutine Init_obs + +!======================================================================== + Subroutine Obser(GR,Phase,Ntau) + + Implicit none + + Complex (Kind=8), INTENT(IN) :: GR(Ndim,Ndim,N_FL) + Complex (Kind=8), Intent(IN) :: PHASE + Integer, INTENT(IN) :: Ntau + + !Local + Complex (Kind=8) :: GRC(Ndim,Ndim,N_FL), ZK + Complex (Kind=8) :: Zrho, Zkin, ZPot, Z, ZP,ZS + Integer :: I,J, no,no1, n, n1, imj, nf, I1, I2, J1, J2 + + Real (Kind=8) :: G(4,4), X, FI, FJ + + Nobs = Nobs + 1 + ZP = PHASE/cmplx(Real(Phase,kind=8),0.d0) + ZS = cmplx(Real(Phase,kind=8)/Abs(Real(Phase,kind=8)), 0.d0) + + + Do nf = 1,N_FL + Do I = 1,Ndim + Do J = 1,Ndim + ZK = cmplx(0.d0,0.d0) + If ( I == J ) ZK = cmplx(1.d0,0.d0) + GRC(I,J,nf) = ZK - GR(J,I,nf) + Enddo + Enddo + Enddo + ! GRC(i,j,nf) = < c^{dagger}_{j,nf } c_{j,nf } > + ! Compute scalar observables. + Zkin = cmplx(0.d0,0.d0) + Do nf = 1,N_FL + Do J = 1,Ndim + DO I = 1,Ndim + Zkin = Zkin + Op_T(1,nf)%O(i,j)*Grc(i,j,nf) + Enddo + ENddo + Enddo + Zkin = Zkin*cmplx( dble(N_SUN), 0.d0 ) + + Zrho = cmplx(0.d0,0.d0) + Do nf = 1,N_FL + Do I = 1,Ndim + Zrho = Zrho + Grc(i,i,nf) + enddo + enddo + Zrho = Zrho*cmplx( dble(N_SUN), 0.d0 ) + + ZPot = cmplx(0.d0,0.d0) + If ( Model == "Hubbard_SU2" ) then + Do I = 1,Ndim + ZPot = ZPot + Grc(i,i,1) * Grc(i,i,1) + Enddo + Zpot = Zpot*cmplx(ham_U,0.d0) + elseif ( Model == "Hubbard_Mz" ) then + Do I = 1,Ndim + ZPot = ZPot + Grc(i,i,1) * Grc(i,i,2) + Enddo + Zpot = Zpot*cmplx(ham_U,0.d0) + endif + + Obs_scal(1) = Obs_scal(1) + zrho * ZP*ZS + Obs_scal(2) = Obs_scal(2) + zkin * ZP*ZS + Obs_scal(3) = Obs_scal(3) + Zpot * ZP*ZS + Obs_scal(4) = Obs_scal(4) + (zkin + Zpot)*ZP*ZS + Obs_scal(5) = Obs_scal(5) + ZS + ! You will have to allocate more space if you want to include more scalar observables. + + ! Compute spin-spin, Green, and den-den correlation functions ! This is general N_SUN, and N_FL = 1 + If ( Model == "Hubbard_SU2" ) then + Z = cmplx(dble(N_SUN),0.d0) + Do I = 1,Latt%N + Do J = 1,Latt%N + imj = latt%imj(I,J) + GREEN_EQ (imj,1,1) = GREEN_EQ (imj,1,1) + Z * GRC(I,J,1) * ZP*ZS + SPINXY_Eq (imj,1,1) = SPINXY_Eq (imj,1,1) + Z * GRC(I,J,1) * GR(I,J,1) * ZP*ZS + SPINZ_Eq (imj,1,1) = SPINZ_Eq (imj,1,1) + Z * GRC(I,J,1) * GR(I,J,1) * ZP*ZS + DEN_Eq (imj,1,1) = DEN_Eq (imj,1,1) + ( & + & GRC(I,I,1) * GRC(J,J,1) *Z + & + & GRC(I,J,1) * GR(I,J,1) & + & ) * Z* ZP*ZS + ENDDO + Den_eq0(1) = Den_eq0(1) + Z * GRC(I,I,1) * ZP * ZS + ENDDO + elseif (Model == "Hubbard_Mz" ) Then + DO I = 1,Latt%N + DO J = 1, Latt%N + imj = latt%imj(I,J) + SPINZ_Eq (imj,1,1) = SPINZ_Eq (imj,1,1) + & + & ( GRC(I,J,1) * GR(I,J,1) + GRC(I,J,2) * GR(I,J,2) + & + & (GRC(I,I,2) - GRC(I,I,1))*(GRC(J,J,2) - GRC(J,J,1)) ) * ZP*ZS + ! c^d_(i,u) c_(i,d) c^d_(j,d) c_(j,u) + c^d_(i,d) c_(i,u) c^d_(j,u) c_(j,d) + SPINXY_Eq (imj,1,1) = SPINXY_Eq (imj,1,1) + & + & ( GRC(I,J,1) * GR(I,J,2) + GRC(I,J,2) * GR(I,J,1) ) * ZP*ZS + + DEN_Eq (imj,1,1) = DEN_Eq (imj,1,1) + & + & ( GRC(I,J,1) * GR(I,J,1) + GRC(I,J,2) * GR(I,J,2) + & + & (GRC(I,I,2) + GRC(I,I,1))*(GRC(J,J,2) + GRC(J,J,1)) ) * ZP*ZS + enddo + Den_eq0(1) = Den_eq0(1) + (GRC(I,I,2) + GRC(I,I,1)) * ZP*ZS + enddo + Endif + + + end Subroutine Obser +!========================================================== + Subroutine Pr_obs(LTAU) + + Implicit none +#include "machine" +#ifdef MPI + include 'mpif.h' +#endif + + + Integer, Intent(In) :: Ltau + + Character (len=64) :: File_pr + Complex (Kind=8) :: Phase_bin +#ifdef MPI + Integer :: Isize, Irank, Ierr + Integer :: STATUS(MPI_STATUS_SIZE) + CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) + CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) +#endif + +!!$#ifdef MPI +!!$ Write(6,*) Irank, 'In Pr_obs', LTAU +!!$#else +!!$ Write(6,*) 'In Pr_obs', LTAU +!!$#endif + + Phase_bin = Obs_scal(5)/cmplx(dble(Nobs),0.d0) + File_pr ="SpinZ_eq" + Call Print_bin(SpinZ_eq ,SpinZ_eq0, Latt, Nobs, Phase_bin, file_pr) + File_pr ="SpinXY_eq" + Call Print_bin(Spinxy_eq, Spinxy_eq0,Latt, Nobs, Phase_bin, file_pr) + File_pr ="Den_eq" + Call Print_bin(Den_eq, Den_eq0, Latt, Nobs, Phase_bin, file_pr) + File_pr ="Green_eq" + Call Print_bin(Green_eq , Green_eq0 ,Latt, Nobs, Phase_bin, file_pr) + + File_pr ="ener" + Call Print_scal(Obs_scal, Nobs, file_pr) + + If (Ltau == 1) then + Phase_tau = Phase_tau/cmplx(dble(NobsT),0.d0) + File_pr = "Green_tau" + Call Print_bin_tau(Green_tau,Latt,NobsT,Phase_tau, file_pr,dtau) + File_pr = "Den_tau" + Call Print_bin_tau(Den_tau,Latt,NobsT,Phase_tau, file_pr,dtau) + endif + +!!$#ifdef MPI +!!$ Write(6,*) Irank, 'out Pr_obs', LTAU +!!$#else +!!$ Write(6,*) 'out Pr_obs', LTAU +!!$#endif + end Subroutine Pr_obs +!========================================================== + + Subroutine OBSERT(NT, GT0,G0T,G00,GTT, PHASE) + Implicit none + + Integer , INTENT(IN) :: NT + Complex (Kind=8), INTENT(IN) :: GT0(Ndim,Ndim,N_FL),G0T(Ndim,Ndim,N_FL),G00(Ndim,Ndim,N_FL),GTT(Ndim,Ndim,N_FL) + Complex (Kind=8), INTENT(IN) :: Phase + + !Locals + Complex (Kind=8) :: Z, ZP, ZS + Integer :: IMJ, I, J + + ZP = PHASE/cmplx(Real(Phase,kind=8),0.d0) + ZS = cmplx(Real(Phase,kind=8)/Abs(Real(Phase,kind=8)), 0.d0) + If (NT == 0 ) then + Phase_tau = Phase_tau + ZS + NobsT = NobsT + 1 + endif + If ( N_FL == 1 ) then + Z = cmplx(dble(N_SUN),0.d0) + Do I = 1,Latt%N + Do J = 1,Latt%N + imj = latt%imj(I,J) + Green_tau(imj,nt+1,1,1) = green_tau(imj,nt+1,1,1) + Z * GT0(I,J,1) * ZP* ZS + Den_tau (imj,nt+1,1,1) = Den_tau (imj,nt+1,1,1) - Z * GT0(I,J,1)*G0T(J,I,1) * ZP* ZS + Enddo + Enddo + Endif + end Subroutine OBSERT + + + end Module Hamiltonian diff --git a/src/Prog/Hamiltonian_Ising.F90 b/src/Prog/Hamiltonian_Ising.F90 new file mode 100644 index 000000000..8d3cc7e58 --- /dev/null +++ b/src/Prog/Hamiltonian_Ising.F90 @@ -0,0 +1,579 @@ + Module Hamiltonian + + Use Operator_mod + Use Lattices_v3 + Use MyMats + Use Random_Wrap + Use Files_mod + Use Matrix + + + Type (Operator), dimension(:,:), allocatable :: Op_V + Type (Operator), dimension(:,:), allocatable :: Op_T + Integer, allocatable :: nsigma(:,:) + Integer :: Ndim, N_FL, N_SUN, Ltrot + !Complex (Kind=8), dimension(:,:,:), allocatable :: Exp_T(:,:,:), Exp_T_M1(:,:,:) + + + + ! What is below is private + + Type (Lattice), private :: Latt + Integer, private :: L1, L2 + real (Kind=8), private :: ham_T , ham_xi, ham_h, ham_J, ham_U, Ham_Vint, Ham_chem + real (Kind=8), private :: Dtau, Beta + Character (len=64), private :: Model, Lattice_type + Integer, allocatable, private :: L_bond(:,:), Ising_nnlist(:,:) + Real (Kind=8), private :: DW_Ising_tau (-1:1), DW_Ising_Space(-1:1) + Logical, private :: One_dimensional + Integer, private :: N_coord + Real (Kind=8), private :: Bound + + + ! Observables + Integer, private :: Nobs, Norb + Complex (Kind=8), allocatable, private :: obs_scal(:) + Complex (Kind=8), allocatable, private :: Ising_cor(:,:,:) + Complex (Kind=8), allocatable, private :: Green_eq (:,:,:), Spin_eq(:,:,:), Den_eq (:,:,:) + Complex (Kind=8), allocatable, private :: Green_eq0 (:), Spin_eq0(:), Pair_eq0(:), Den_eq0(:) + Complex (Kind=8), allocatable, private :: Ising_cor0(:) + + ! For time displaced + Integer, private :: NobsT + Complex (Kind=8), private :: Phase_tau + Complex (Kind=8), allocatable, private :: Green_tau(:,:,:,:), Den_tau(:,:,:,:) + + contains + + Subroutine Ham_Set + + Implicit none +#include "machine" +#ifdef MPI + include 'mpif.h' +#endif + + integer :: ierr + + NAMELIST /VAR_lattice/ L1, L2, Lattice_type, Model + + + NAMELIST /VAR_Ising/ ham_T, ham_chem, ham_xi, ham_h, ham_J, Beta, dtau, N_SUN + + +#ifdef MPI + Integer :: Isize, Irank + Integer :: STATUS(MPI_STATUS_SIZE) + CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) + CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) +#endif + + +#ifdef MPI + If (Irank == 0 ) then +#endif + OPEN(UNIT=5,FILE='parameters',STATUS='old',ACTION='read',IOSTAT=ierr) + IF (ierr /= 0) THEN + WRITE(*,*) 'unable to open ',ierr + STOP + END IF + READ(5,NML=VAR_lattice) + CLOSE(5) +#ifdef MPI + ENDIF + CALL MPI_BCAST(L1 ,1 ,MPI_INTEGER, 0,MPI_COMM_WORLD,ierr) + CALL MPI_BCAST(L2 ,1 ,MPI_INTEGER, 0,MPI_COMM_WORLD,ierr) + CALL MPI_BCAST(Model ,64 ,MPI_CHARACTER, 0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(Lattice_type,64 ,MPI_CHARACTER, 0,MPI_COMM_WORLD,IERR) +#endif + Call Ham_latt + + If ( Model == "Ising" ) then + N_FL = 1 +#ifdef MPI + If (Irank == 0 ) then +#endif + OPEN(UNIT=5,FILE='parameters',STATUS='old',ACTION='read',IOSTAT=ierr) + READ(5,NML=VAR_Ising) + CLOSE(5) +#ifdef MPI + endif + CALL MPI_BCAST(ham_T ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) + CALL MPI_BCAST(ham_chem ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) + CALL MPI_BCAST(ham_xi ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) + CALL MPI_BCAST(ham_h ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) + CALL MPI_BCAST(ham_J ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) + CALL MPI_BCAST(Beta ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) + CALL MPI_BCAST(dtau ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) + CALL MPI_BCAST(N_SUN ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) +#endif + else + Write(6,*) ' Model not yet programmed : ' + Stop + endif + Call Ham_hop + Ltrot = nint(beta/dtau) +#ifdef MPI + If (Irank == 0) then +#endif + Open (Unit = 50,file="info",status="unknown",position="append") + Write(50,*) '=====================================' + Write(50,*) 'Model is : ', Model + Write(50,*) 'Beta : ', Beta + Write(50,*) 'dtau,Ltrot : ', dtau,Ltrot + Write(50,*) 'N_SUN : ', N_SUN + Write(50,*) 'N_FL : ', N_FL + Write(50,*) 't : ', Ham_T + Write(50,*) 'xi : ', Ham_xi + Write(50,*) 'h : ', Ham_h + Write(50,*) 'Ham_J : ', Ham_J + close(50) +#ifdef MPI + endif +#endif + call Ham_V + end Subroutine Ham_Set +!============================================================================= + Subroutine Ham_Latt + Implicit none + !Set the lattice + Real (Kind=8) :: a1_p(2), a2_p(2), L1_p(2), L2_p(2) + If ( Lattice_type =="Square" ) then + a1_p(1) = 1.0 ; a1_p(2) = 0.d0 + a2_p(1) = 0.0 ; a2_p(2) = 1.d0 + L1_p = dble(L1)*a1_p + L2_p = dble(L2)*a2_p + Call Make_Lattice( L1_p, L2_p, a1_p, a2_p, Latt ) + Ndim = Latt%N + !Write(6,*) 'Lattice: ', Ndim + One_dimensional = .false. + N_coord = 2 + If ( L1 == 1 .or. L2 == 1 ) then + One_dimensional = .true. + N_coord = 1 + If (L1 == 1 ) then + Write(6,*) ' For one dimensional systems set L2 = 1 ' + Stop + endif + endif + else + Write(6,*) "Lattice not yet implemented!" + Stop + endif + end Subroutine Ham_Latt + +!=================================================================================== + Subroutine Ham_hop + Implicit none + + !Setup the hopping + + Integer :: I, I1, I2, n, Ncheck,nc + Real (Kind=8) :: X + + Ncheck = 1 + allocate(Op_T(Ncheck,N_FL)) + do n = 1,N_FL + Do nc = 1,Ncheck + Call Op_make(Op_T(nc,n),Ndim) + If (One_dimensional ) then + DO I = 1, Latt%N + I1 = Latt%nnlist(I,1,0) + Op_T(nc,n)%O(I,I1) = cmplx(-Ham_T,0.d0) + Op_T(nc,n)%O(I1,I) = cmplx(-Ham_T,0.d0) + Op_T(nc,n)%O(I ,I) = cmplx(-Ham_chem,0.d0) + ENDDO + else + DO I = 1, Latt%N + I1 = Latt%nnlist(I,1,0) + I2 = Latt%nnlist(I,0,1) + Op_T(nc,n)%O(I,I1) = cmplx(-Ham_T, 0.d0) + Op_T(nc,n)%O(I1,I) = cmplx(-Ham_T, 0.d0) + Op_T(nc,n)%O(I,I2) = cmplx(-Ham_T, 0.d0) + Op_T(nc,n)%O(I2,I) = cmplx(-Ham_T, 0.d0) + Op_T(nc,n)%O(I ,I) = cmplx(-Ham_chem,0.d0) + ENDDO + endif + + Do I = 1,Latt%N + Op_T(nc,n)%P(i) = i + Enddo + if ( abs(Ham_T) < 1.E-6 .and. abs(Ham_chem) < 1.E-6 ) then + Op_T(nc,n)%g=cmplx(0.d0 ,0.d0) + else + Op_T(nc,n)%g=cmplx(-Dtau,0.d0) + endif + !Write(6,*) 'In Ham_hop', Ham_T + Call Op_set(Op_T(nc,n)) + !Write(6,*) 'In Ham_hop 1' + !Do I = 1,Latt%N + ! Write(6,*) Op_T(n)%E(i) + !enddo + !Call Op_exp( cmplx(-Dtau,0.d0), Op_T(n), Exp_T (:,:,n) ) + !Call Op_exp( cmplx( Dtau,0.d0), Op_T(n), Exp_T_M1(:,:,n) ) + enddo + enddo + end Subroutine Ham_hop + +!=================================================================================== + + Subroutine Ham_V + + Implicit none + + Integer :: nf, nth, n, n1, n2, n3, n4, I, I1, I2, J, Ix, Iy, nc + Real (Kind=8) :: X_p(2), X1_p(2), X2_p(2), X + + + If (Model == "Ising" ) then + Allocate( Op_V(N_coord*Latt%N,N_FL) ) + do nf = 1,N_FL + do i = 1, N_coord*Latt%N + Call Op_make(Op_V(i,nf),2) + enddo + enddo + Allocate (L_Bond(Latt%N,2)) + Do nf = 1,N_FL + nc = 0 + do nth = 1,2*N_coord + Do n1= 1, L1/2 + Do n2 = 1,L2 + nc = nc + 1 + If (nth == 1 ) then + X_p = dble(2*n1)*latt%a1_p + dble(n2)*latt%a2_p + I1 = Inv_R(X_p,Latt) + I2 = Latt%nnlist(I1,1,0) + L_bond(I1,1) = nc + elseif (nth == 2) then + X_p = dble(2*n1)*latt%a1_p + dble(n2)*latt%a2_p + latt%a1_p + I1 = Inv_R(X_p,Latt) + I2 = Latt%nnlist(I1,1,0) + L_bond(I1,1) = nc + elseif (nth == 3) then + X_p = dble(n2)*latt%a1_p + dble(2*n1)*latt%a2_p + I1 = Inv_R(X_p,Latt) + I2 = Latt%nnlist(I1,0,1) + L_bond(I1,2) = nc + elseif (nth == 4) then + X_p = dble(n2)*latt%a1_p + dble(2*n1)*latt%a2_p + latt%a2_p + I1 = Inv_R(X_p,Latt) + I2 = Latt%nnlist(I1,0,1) + L_bond(I1,2) = nc + endif + Op_V(nc,nf)%P(1) = I1; Op_V(nc,nf)%P(2) = I2 + Op_V(nc,nf)%O(1,2) = cmplx(1.d0 ,0.d0) + Op_V(nc,nf)%O(2,1) = cmplx(1.d0 ,0.d0) + Op_V(nc,nf)%g = cmplx(-dtau*Ham_xi,0.d0) + Op_V(nc,nf)%alpha = cmplx(0.d0 ,0.d0) + Op_V(nc,nf)%type = 1 + Call Op_set( Op_V(nc,nf) ) + ! For a single flavour, the operator reads: + ! g*s*( c^{dagger} O c - alpha )) + ! with s the HS field. + Enddo + Enddo + Enddo + Enddo +!!$ Open (Unit=10,File="Latt",status="unknown") +!!$ Do I = 1,Latt%N +!!$ X_p = dble(latt%list(I,1))*latt%a1_p + dble(latt%list(I,2))*latt%a2_p +!!$ Write(10,*) X_p(1), X_p(2) +!!$ Write(10,*) X_p(1)+ latt%a1_p(1), X_p(2) + latt%a1_p(2) +!!$ Write(10,*) +!!$ Write(10,*) X_p(1), X_p(2) +!!$ Write(10,*) X_p(1)+ latt%a2_p(1), X_p(2) + latt%a2_p(2) +!!$ Write(10,*) +!!$ Enddo +!!$ Close(10) + allocate(Ising_nnlist(2*Latt%N,4)) + do I = 1,Latt%N + n = L_bond(I,1) + n1 = L_bond(Latt%nnlist(I, 1, 0),2) + n2 = L_bond(Latt%nnlist(I, 0, 0),2) + n3 = L_bond(Latt%nnlist(I, 0,-1),2) + n4 = L_bond(Latt%nnlist(I, 1,-1),2) + Ising_nnlist(n,1) = n1 + Ising_nnlist(n,2) = n2 + Ising_nnlist(n,3) = n3 + Ising_nnlist(n,4) = n4 + n = L_bond(I,2) + n1 = L_bond(Latt%nnlist(I, 0, 1),1) + n2 = L_bond(Latt%nnlist(I,-1, 1),1) + n3 = L_bond(Latt%nnlist(I,-1, 0),1) + n4 = L_bond(Latt%nnlist(I, 0, 0),1) + Ising_nnlist(n,1) = n1 + Ising_nnlist(n,2) = n2 + Ising_nnlist(n,3) = n3 + Ising_nnlist(n,4) = n4 + enddo + DW_Ising_tau ( 1) = (exp(Dtau*Ham_h) - exp(-Dtau*Ham_h))/(exp(Dtau*Ham_h) + exp(-Dtau*Ham_h)) + DW_Ising_tau (-1) = (exp(Dtau*Ham_h) + exp(-Dtau*Ham_h))/(exp(Dtau*Ham_h) - exp(-Dtau*Ham_h)) + DW_Ising_Space( 1) = exp(-2.d0*Dtau*Ham_J) + DW_Ising_Space(-1) = exp( 2.d0*Dtau*Ham_J) +!!$ Open (Unit=10,File="Ising_latt",status="unknown") +!!$ nf = 1 +!!$ Do I = 1,Latt%N +!!$ I1 = Op_V(L_bond(I,1),nf)%P(2) +!!$ I2 = Op_V(L_bond(I,2),nf)%P(2) +!!$ X_p = dble(latt%list(I,1))*latt%a1_p + dble(latt%list(I,2))*latt%a2_p +!!$ X1_p = dble(latt%list(I1,1))*latt%a1_p + dble(latt%list(I1,2))*latt%a2_p +!!$ X2_p = dble(latt%list(I2,1))*latt%a1_p + dble(latt%list(I2,2))*latt%a2_p +!!$ Write(10,*) X_p (1), X_p (2) +!!$ Write(10,*) X1_p(1), X1_p(2) +!!$ Write(10,*) +!!$ Write(10,*) X_p (1), X_p (2) +!!$ Write(10,*) X2_p(1), X2_p(2) +!!$ Write(10,*) +!!$ Enddo +!!$ Close(10) + endif + end Subroutine Ham_V + +!=================================================================================== + Real (Kind=8) function S0(n,nt) + Implicit none + Integer, Intent(IN) :: n,nt + Integer :: i, nt1 + S0 = 1.d0 + If (Model == "Ising" ) then + do i = 1,4 + S0 = S0*DW_Ising_space(nsigma(n,nt)*nsigma(Ising_nnlist(n,i),nt)) + enddo + nt1 = nt +1 + if (nt1 > Ltrot) nt1 = 1 + S0 = S0*DW_Ising_tau(nsigma(n,nt)*nsigma(n,nt1)) + nt1 = nt - 1 + if (nt1 < 1 ) nt1 = Ltrot + S0 = S0*DW_Ising_tau(nsigma(n,nt)*nsigma(n,nt1)) + If (S0 < 0.d0) Write(6,*) 'S0 : ', S0 + endif + end function S0 + +!=================================================================================== + + Subroutine Alloc_obs(Ltau) + + Implicit none + Integer, Intent(In) :: Ltau + Integer :: I + Norb = 2 + Allocate ( Obs_scal(5) ) + Allocate ( Ising_cor (Latt%N,Norb,Norb) ) + Allocate ( Green_eq(Latt%N,1,1), Spin_eq(Latt%N,1,1), Den_eq(Latt%N,1,1) ) + Allocate ( Ising_cor0(Norb), Green_eq0(1), Spin_eq0(1), Den_eq0(1) ) + If (Ltau == 1) then + Allocate ( Green_tau(Latt%N,Ltrot+1,1,1), Den_tau(Latt%N,Ltrot+1,1,1) ) + endif + + + + end Subroutine Alloc_obs + +!=================================================================================== + + Subroutine Init_obs(Ltau) + + Implicit none + Integer, Intent(In) :: Ltau + + Integer :: I,n + + Nobs = 0 + Obs_scal = cmplx(0.d0,0.d0) + Ising_cor = cmplx(0.d0,0.d0) + Green_eq = cmplx(0.d0,0.d0) + Spin_eq = cmplx(0.d0,0.d0) + Den_eq = cmplx(0.d0,0.d0) + Ising_cor0= cmplx(0.d0,0.d0) + Green_eq0 = cmplx(0.d0,0.d0) + Spin_eq0 = cmplx(0.d0,0.d0) + Den_eq0 = cmplx(0.d0,0.d0) + + If (Ltau == 1) then + NobsT = 0 + Phase_tau = cmplx(0.d0,0.d0) + Green_tau = cmplx(0.d0,0.d0) + Den_tau = cmplx(0.d0,0.d0) + endif + + end Subroutine Init_obs + +!======================================================================== + Subroutine Obser(GR,Phase,Ntau) + + Implicit none + + Complex (Kind=8), INTENT(IN) :: GR(Ndim,Ndim,N_FL) + Complex (Kind=8), Intent(IN) :: PHASE + Integer, INTENT(IN) :: Ntau + + !Local + Complex (Kind=8) :: GRC(Ndim,Ndim,N_FL), ZK + Complex (Kind=8) :: Zrho, Zkin, ZPot, Z, ZP,ZS + Integer :: I,J, no,no1, n, n1, imj, nf, I1, I2, J1, J2 + + Real (Kind=8) :: G(4,4), X, FI, FJ + + Nobs = Nobs + 1 + ZP = PHASE/cmplx(Real(Phase,kind=8),0.d0) + ZS = cmplx(Real(Phase,kind=8)/Abs(Real(Phase,kind=8)), 0.d0) + + + Do nf = 1,N_FL + Do I = 1,Ndim + Do J = 1,Ndim + ZK = cmplx(0.d0,0.d0) + If ( I == J ) ZK = cmplx(1.d0,0.d0) + GRC(I,J,nf) = ZK - GR(J,I,nf) + Enddo + Enddo + Enddo + ! GRC(i,j,nf) = < c^{dagger}_{j,nf } c_{j,nf } > + ! Compute scalar observables. + Zkin = cmplx(0.d0,0.d0) + Do nf = 1,N_FL + Do J = 1,Ndim + DO I = 1,Ndim + Zkin = Zkin + Op_T(1,nf)%O(i,j)*Grc(i,j,nf) + Enddo + ENddo + Enddo + Zkin = Zkin*cmplx( dble(N_SUN), 0.d0 ) + + Zrho = cmplx(0.d0,0.d0) + Do nf = 1,N_FL + Do I = 1,Ndim + Zrho = Zrho + Grc(i,i,nf) + enddo + enddo + Zrho = Zrho*cmplx( dble(N_SUN), 0.d0 ) + + ZPot = cmplx(0.d0,0.d0) + + Obs_scal(1) = Obs_scal(1) + zrho * ZP*ZS + Obs_scal(2) = Obs_scal(2) + zkin * ZP*ZS + Obs_scal(3) = Obs_scal(3) + Zpot * ZP*ZS + Obs_scal(4) = Obs_scal(4) + (zkin + Zpot)*ZP*ZS + Obs_scal(5) = Obs_scal(5) + ZS + ! You will have to allocate more space if you want to include more scalar observables. + + ! Compute spin-spin, Green, and den-den correlation functions ! This is general N_SUN, and N_FL = 1 + If ( N_FL == 1 ) then + Z = cmplx(dble(N_SUN),0.d0) + Do I = 1,Latt%N + Do J = 1,Latt%N + imj = latt%imj(I,J) + GREEN_EQ(imj,1,1) = GREEN_EQ(imj,1,1) + Z * GRC(I,J,1) * ZP*ZS + SPIN_Eq (imj,1,1) = SPIN_Eq (imj,1,1) + Z * GRC(I,J,1) * GR(I,J,1) * ZP*ZS + DEN_Eq (imj,1,1) = DEN_Eq (imj,1,1) + ( & + & GRC(I,I,1) * GRC(J,J,1) *Z + & + & GRC(I,J,1) * GR(I,J,1) & + & ) * Z* ZP*ZS + ENDDO + Den_eq0(1) = Den_eq0(1) + Z* GRC(I,I,1)*ZP*ZS + ENDDO + ENDIF + + If (Model == "Ising" ) then + Do I = 1,Latt%N + do no = 1,Norb + n = L_bond(I,no) + do j = 1,Latt%N + imj = latt%imj(I,J) + do no1 = 1,Norb + n1 = L_bond(J,no1) + Ising_cor(imj,no,no1) = Ising_cor(imj,no,no1) + cmplx(dble(nsigma(n,ntau)*nsigma(n1,ntau)),0.d0)*ZP*ZS + enddo + enddo + enddo + enddo + endif + + end Subroutine Obser +!========================================================== + Subroutine Pr_obs(LTAU) + + + Use Print_bin_mod + Implicit none +#include "machine" +#ifdef MPI + include 'mpif.h' +#endif + + + Integer, Intent(In) :: Ltau + + Character (len=64) :: File_pr + Complex (Kind=8) :: Phase_bin +#ifdef MPI + Integer :: Isize, Irank, Ierr + Integer :: STATUS(MPI_STATUS_SIZE) + CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) + CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) +#endif +!!$#ifdef MPI +!!$ Write(6,*) Irank, 'In Pr_obs', LTAU +!!$#else +!!$ Write(6,*) 'In Pr_obs', LTAU +!!$#endif + + Phase_bin = Obs_scal(5)/cmplx(dble(Nobs),0.d0) + File_pr ="Ising_eq" + Call Print_bin(Ising_cor,Ising_cor0,Latt, Nobs, Phase_bin, file_pr) + File_pr ="Green_eq" + Call Print_bin(Green_eq, Green_eq0, Latt, Nobs, Phase_bin, file_pr) + File_pr ="Spin_eq" + Call Print_bin(Spin_eq, Spin_eq0, Latt, Nobs, Phase_bin, file_pr) + File_pr ="Den_eq" + Call Print_bin(Den_eq, Den_eq0, Latt, Nobs, Phase_bin, file_pr) + + + File_pr ="ener" + Call Print_scal(Obs_scal, Nobs, file_pr) + If (Ltau == 1) then + Phase_tau = Phase_tau/cmplx(dble(NobsT),0.d0) + File_pr = "Green_tau" + Call Print_bin_tau(Green_tau,Latt,NobsT,Phase_tau, file_pr,dtau) + File_pr = "Den_tau" + Call Print_bin_tau(Den_tau,Latt,NobsT,Phase_tau, file_pr,dtau) + endif +!!$#ifdef MPI +!!$ Write(6,*) Irank, 'out Pr_obs', LTAU +!!$#else +!!$ Write(6,*) 'out Pr_obs', LTAU +!!$#endif + end Subroutine Pr_obs +!========================================================== + + Subroutine OBSERT(NT, GT0,G0T,G00,GTT, PHASE) + Implicit none + + Integer , INTENT(IN) :: NT + Complex (Kind=8), INTENT(IN) :: GT0(Ndim,Ndim,N_FL),G0T(Ndim,Ndim,N_FL),G00(Ndim,Ndim,N_FL),GTT(Ndim,Ndim,N_FL) + Complex (Kind=8), INTENT(IN) :: Phase + + !Locals + Complex (Kind=8) :: Z, ZP, ZS + Integer :: IMJ, I, J + + ZP = PHASE/cmplx(Real(Phase,kind=8),0.d0) + ZS = cmplx(Real(Phase,kind=8)/Abs(Real(Phase,kind=8)), 0.d0) + If (NT == 0 ) then + Phase_tau = Phase_tau + ZS + NobsT = NobsT + 1 + endif + If ( N_FL == 1 ) then + Z = cmplx(dble(N_SUN),0.d0) + Do I = 1,Latt%N + Do J = 1,Latt%N + imj = latt%imj(I,J) + Green_tau(imj,nt+1,1,1) = green_tau(imj,nt+1,1,1) + Z * GT0(I,J,1) * ZP* ZS + Den_tau (imj,nt+1,1,1) = Den_tau (imj,nt+1,1,1) - Z * GT0(I,J,1)*G0T(J,I,1) * ZP* ZS + Enddo + Enddo + Endif + end Subroutine OBSERT + + + end Module Hamiltonian diff --git a/src/Prog/Hamiltonian_SPT.F90 b/src/Prog/Hamiltonian_SPT.F90 new file mode 100644 index 000000000..390ca751c --- /dev/null +++ b/src/Prog/Hamiltonian_SPT.F90 @@ -0,0 +1,548 @@ + !Model Hamiltonian for interaction-induced topological reduction + Module Hamiltonian + + Use Operator_mod + Use Lattices_v3 + Use MyMats + Use Random_Wrap + Use Files_mod + Use Matrix + + + Type (Operator), dimension(:,:), allocatable :: Op_V + Type (Operator), dimension(:,:), allocatable :: Op_T + Integer, allocatable :: nsigma(:,:) + Integer :: Ndim, N_FL, N_SUN, Ltrot + + + + ! What is below is private + + Type (Lattice), private :: Latt + Integer, parameter, private :: Norb=16 + Integer, allocatable, private :: List(:,:), Invlist(:,:) + Integer, private :: L1, L2 + real (Kind=8), private :: Ham_T, Ham_Vint, Ham_Lam + real (Kind=8), private :: Dtau, Beta + Character (len=64), private :: Model, Lattice_type + Complex (Kind=8), private :: Gamma_M(4,4,5), Sigma_M(2,2,0:3) + + + ! Observables + Integer, private :: Nobs + Complex (Kind=8), allocatable, private :: obs_scal(:) + Complex (Kind=8), allocatable, private :: Den_eq(:,:,:), Den_eq0(:) + + ! For time displaced + Integer, private :: NobsT + Complex (Kind=8), private :: Phase_tau + Complex (Kind=8), allocatable, private :: Green_tau(:,:,:,:), Den_tau(:,:,:,:) + + contains + + Subroutine Ham_Set + + Implicit none +#include "machine" +#ifdef MPI + include 'mpif.h' +#endif + + integer :: ierr + + NAMELIST /VAR_lattice/ L1, L2, Lattice_type, Model + + NAMELIST /VAR_SPT/ ham_T, Ham_Vint, Ham_Lam, Dtau, Beta + + +#ifdef MPI + Integer :: Isize, Irank + Integer :: STATUS(MPI_STATUS_SIZE) + CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) + CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) + If (Irank == 0 ) then +#endif + OPEN(UNIT=5,FILE='parameters',STATUS='old',ACTION='read',IOSTAT=ierr) + IF (ierr /= 0) THEN + WRITE(*,*) 'unable to open ',ierr + STOP + END IF + READ(5,NML=VAR_lattice) + CLOSE(5) +#ifdef MPI + endif + + CALL MPI_BCAST(L1 ,1 ,MPI_INTEGER, 0,MPI_COMM_WORLD,ierr) + CALL MPI_BCAST(L2 ,1 ,MPI_INTEGER, 0,MPI_COMM_WORLD,ierr) + CALL MPI_BCAST(Model ,64 ,MPI_CHARACTER, 0,MPI_COMM_WORLD,IERR) + CALL MPI_BCAST(Lattice_type,64 ,MPI_CHARACTER, 0,MPI_COMM_WORLD,IERR) +#endif + Call Ham_latt + + N_FL = 1 + N_SUN = 1 + +#ifdef MPI + If (Irank == 0 ) then +#endif + OPEN(UNIT=5,FILE='parameters',STATUS='old',ACTION='read',IOSTAT=ierr) + READ(5,NML=VAR_SPT) + CLOSE(5) +#ifdef MPI + endif + + CALL MPI_BCAST(ham_T ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) + CALL MPI_BCAST(ham_Vint ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) + CALL MPI_BCAST(ham_Lam ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) + CALL MPI_BCAST(Dtau ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) + CALL MPI_BCAST(Beta ,1,MPI_REAL8,0,MPI_COMM_WORLD,ierr) +#endif + + Call Ham_hop + Ltrot = nint(beta/dtau) +#ifdef MPI + If (Irank == 0) then +#endif + Open (Unit = 50,file="info",status="unknown",position="append") + Write(50,*) '=====================================' + Write(50,*) 'Model is : ', Model + Write(50,*) 'Lattice is : ', Lattice_type + Write(50,*) 'Beta : ', Beta + Write(50,*) 'dtau,Ltrot : ', dtau,Ltrot + Write(50,*) 't : ', Ham_T + Write(50,*) 'V : ', Ham_Vint + Write(50,*) 'Lambda : ', Ham_Lam + close(50) +#ifdef MPI + endif +#endif + call Ham_V + end Subroutine Ham_Set +!============================================================================= + + Subroutine Ham_Latt + Implicit none + !Set the lattice + Integer :: no, I, nc + Real (Kind=8) :: a1_p(2), a2_p(2), L1_p(2), L2_p(2) + If ( Lattice_type =="Square" ) then + a1_p(1) = 1.0 ; a1_p(2) = 0.d0 + a2_p(1) = 0.0 ; a2_p(2) = 1.d0 + L1_p = dble(L1)*a1_p + L2_p = dble(L2)*a2_p + Call Make_Lattice( L1_p, L2_p, a1_p, a2_p, Latt ) + !Write(6,*) 'Lattice: ', Ndim + else + Write(6,*) "Lattice not yet implemented!" + Stop + endif + + Ndim = Latt%N*Norb + Allocate (List(Ndim,Norb), Invlist(Latt%N,Norb)) + nc = 0 + Do I = 1,Latt%N + Do no = 1,Norb + nc = nc + 1 + List(nc,1) = I + List(nc,2) = no + Invlist(I,no) = nc + ! no = 1..4 Xi_1 + ! no = 5..8 Xi_2 + ! no = 9..12 Xi_3 + ! no = 13..16 Xi_4 + Enddo + Enddo + + end Subroutine Ham_Latt + +!=================================================================================== + Subroutine Ham_hop + Implicit none + + ! Setup the hopping + ! Per flavor, the hopping is given by: + ! e^{-dtau H_t} = Prod_{n=1}^{Ncheck} e^{-dtau_n H_{n,t}} + + Integer :: I, I1, I2,I3,no, no1, n, Ncheck, nc , nth + Integer, allocatable :: Invlist_1(:,:) + Real (Kind=8) :: X + Complex (Kind=8) :: Z + + + ! Setup Gamma matrices + Gamma_M = cmplx(0.d0,0.d0) + Sigma_M = cmplx(0.d0,0.d0) + Sigma_M(1,1,0) = cmplx( 1.d0, 0.d0) + Sigma_M(2,2,0) = cmplx( 1.d0, 0.d0) + Sigma_M(1,2,1) = cmplx( 1.d0, 0.d0) + Sigma_M(2,1,1) = cmplx( 1.d0, 0.d0) + Sigma_M(1,2,2) = cmplx( 0.d0,-1.d0) + Sigma_M(2,1,2) = cmplx( 0.d0, 1.d0) + Sigma_M(1,1,3) = cmplx( 1.d0, 0.d0) + Sigma_M(2,2,3) = cmplx(-1.d0, 0.d0) + Do no = 1,2 + Do no1 = 1,2 + Gamma_M(no+2,no1 ,1) = Sigma_M(no,no1,0) + Gamma_M(no ,no1+2,1) = Sigma_M(no,no1,0) + Gamma_M(no+2,no1 ,2) = cmplx( 0.d0,-1.d0)*Sigma_M(no,no1,0) + Gamma_M(no ,no1+2,2) = cmplx( 0.d0, 1.d0)*Sigma_M(no,no1,0) + Gamma_M(no ,no1 ,3) = cmplx( 1.d0, 0.d0)*Sigma_M(no,no1,1) + Gamma_M(no+2,no1+2,3) = cmplx(-1.d0, 0.d0)*Sigma_M(no,no1,1) + Gamma_M(no ,no1 ,4) = cmplx( 1.d0, 0.d0)*Sigma_M(no,no1,2) + Gamma_M(no+2,no1+2,4) = cmplx(-1.d0, 0.d0)*Sigma_M(no,no1,2) + Gamma_M(no ,no1 ,5) = cmplx( 1.d0, 0.d0)*Sigma_M(no,no1,3) + Gamma_M(no+2,no1+2,5) = cmplx(-1.d0, 0.d0)*Sigma_M(no,no1,3) + Enddo + Enddo + + Ncheck = 4 + Allocate ( Invlist_1(Latt%N,4) ) + allocate(Op_T(Ncheck,N_FL)) + do n = 1,N_FL + Do nc = 1,NCheck + Call Op_make(Op_T(nc,n),Ndim/4) + I1 = 0 + Do no = 1,4 + DO I = 1, Latt%N + I1 = I1 + 1 + Invlist_1(I,no) = I1 + Op_T(nc,n)%P(I1) = Invlist(I, no + 4*(nc -1) ) + enddo + enddo + Do I = 1,Latt%N + do no = 1,4 + do no1 = 1,4 + Z = cmplx(1.d0*Ham_T,0.d0)*Gamma_M(no,no1,3) + Op_T(nc,n)%O( Invlist_1(I,no) ,Invlist_1(I,no1) ) = Z + enddo + enddo + I1 = Latt%nnlist(I,1,0) + do no = 1,4 + do no1 = 1,4 + Z = (cmplx(0.d0,Ham_T)*Gamma_M(no,no1,1) + cmplx(Ham_T,0.d0)*Gamma_M(no,no1,3))/cmplx(2.d0,0.d0) + Op_T(nc,n)%O( invlist_1(I ,no ), invlist_1(I1,no1 ) ) = Z + Op_T(nc,n)%O( invlist_1(I1,no1 ), invlist_1(I ,no ) ) = conjg(Z) + enddo + enddo + I2 = Latt%nnlist(I,0,1) + do no = 1,4 + do no1 = 1,4 + Z = (cmplx(0.d0,Ham_Lam)*Gamma_M(no,no1,2) + cmplx(Ham_T,0.d0)*Gamma_M(no,no1,3))/cmplx(2.d0,0.d0) + Op_T(nc,n)%O( invlist_1(I ,no ), invlist_1(I2,no1 ) ) = Z + Op_T(nc,n)%O( invlist_1(I2,no1), invlist_1(I ,no ) ) = conjg(Z) + enddo + enddo + enddo + Op_T(nc,n)%g=cmplx(-Dtau,0.d0) + Call Op_set(Op_T(nc,n)) + ! Just for tests + Do I = 1, Ndim/4 + Write(6,*) i,Op_T(nc,n)%E(i) + enddo + enddo + enddo + + deallocate (Invlist_1) + + end Subroutine Ham_hop +!=================================================================================== + Subroutine Ham_V + + Implicit none + + Integer :: nf, nth, n, n1, n2, n3, n4, I, I1, I2, J, Ix, Iy, nc, no,no1, ns, npm + Integer :: nxy + Real (Kind=8) :: X_p(2), X1_p(2), X2_p(2), X, XJ, Xpm + + Complex (Kind=8) :: Ps(4,4,2), Ps_G5(4,4,2), Tmp(4,4), Z + Complex (Kind=8) :: Sx(16,16,2,2), Sy(16,16,2,2) + + + Ps = cmplx(0.d0,0.d0) + Call mmult (Tmp,Gamma_M(:,:,3), Gamma_M(:,:,4) ) + do ns = 1,2 + if (ns == 1) X = 1.d0/2d0 + if (ns == 2) X = -1.d0/2.d0 + Do I = 1,4 + Do J = 1,4 + Z = cmplx(0.d0,0.d0) + if ( I == J ) Z = cmplx(1.d0/2.d0,0.d0) + Ps(I,J,ns) = Z + cmplx(0.d0,X) * tmp(I,J) + Enddo + Enddo + Enddo + + Do ns = 1,2 + Call mmult ( Ps_G5(:,:,ns), Ps(:,:,ns), Gamma_M(:,:,5) ) + enddo + + Sx = cmplx(0.d0,0.d0) + Sy = cmplx(0.d0,0.d0) + Do ns = 1,2 + Do npm = 1,2 + if (npm == 1) Xpm = 1.0 + if (npm == 2) Xpm = -1.0 + Do no = 1,4 + do no1 = 1,4 + Sx(no , no1 + 4 ,ns,npm) = cmplx(1.d0, 0.d0)*Ps_G5(no,no1,ns) + Sx(no +4 , no1 ,ns,npm) = cmplx(1.d0, 0.d0)*Ps_G5(no,no1,ns) + Sx(no +8 , no1 + 12,ns,npm) = cmplx(xpm, 0.d0)*Ps_G5(no,no1,ns) + Sx(no+12 , no1 + 8 ,ns,npm) = cmplx(xpm, 0.d0)*Ps_G5(no,no1,ns) + + Sy(no , no1 + 4 ,ns,npm) = cmplx(0.d0, -1.d0 )*Ps_G5(no,no1,ns) + Sy(no +4 , no1 ,ns,npm) = cmplx(0.d0, 1.d0 )*Ps_G5(no,no1,ns) + Sy(no +8 , no1 + 12,ns,npm) = cmplx(0.d0, 1.d0*xpm)*Ps_G5(no,no1,ns) + Sy(no+12 , no1 + 8 ,ns,npm) = cmplx(0.d0, -1.d0*xpm)*Ps_G5(no,no1,ns) + enddo + enddo + enddo + enddo + + + ! Number of opertors 8 per unit cell + Allocate( Op_V(8*Latt%N,N_FL) ) + do nf = 1,N_FL + do i = 1, 8*Latt%N + Call Op_make(Op_V(i,nf),Norb) + enddo + enddo + nc = 0 + Do nf = 1,N_FL + do nxy = 1,2 + do ns = 1,2 + do npm = 1,2 + Xpm = 1.d0 + if (npm == 2) Xpm = -1.d0 + Do i = 1,Latt%N + nc = nc + 1 + Do no = 1,Norb + Op_V(nc,nf)%P(no) = Invlist(I,no) + enddo + Do no = 1,Norb + Do no1 = 1,Norb + If (nxy == 1) Op_V(nc,nf)%O(no,no1) = Sx(no,no1,ns,npm) + If (nxy == 2) Op_V(nc,nf)%O(no,no1) = Sy(no,no1,ns,npm) + Enddo + Enddo + Op_V(nc,nf)%g = SQRT(CMPLX(-Xpm*DTAU*Ham_Vint/8.d0,0.D0)) + Op_V(nc,nf)%alpha = cmplx(0.d0,0.d0) + Op_V(nc,nf)%type = 2 + Call Op_set( Op_V(nc,nf) ) + ! The operator reads: + ! g*s*( c^{dagger} O c - alpha )) + ! with s the HS field. + Enddo + Enddo + Enddo + Enddo + Enddo + + end Subroutine Ham_V + +!=================================================================================== + Real (Kind=8) function S0(n,nt) + Implicit none + Integer, Intent(IN) :: n,nt + Integer :: i, nt1 + S0 = 1.d0 + end function S0 + +!=================================================================================== + Subroutine Alloc_obs(Ltau) + + Implicit none + Integer, Intent(In) :: Ltau + Integer :: I + Allocate ( Obs_scal(5) ) + Allocate ( Den_eq(Latt%N,Norb,Norb), Den_eq0(Norb) ) + If (Ltau == 1) then + Allocate ( Green_tau(Latt%N,Ltrot+1,Norb,Norb), Den_tau(Latt%N,Ltrot+1,Norb,Norb) ) + endif + + end Subroutine Alloc_obs + +!=================================================================================== + + Subroutine Init_obs(Ltau) + + Implicit none + Integer, Intent(In) :: Ltau + + Integer :: I,n + + Nobs = 0 + Obs_scal = cmplx(0.d0,0.d0) + Den_eq = cmplx(0.d0,0.d0) + Den_eq0 = cmplx(0.d0,0.d0) + + If (Ltau == 1) then + NobsT = 0 + Phase_tau = cmplx(0.d0,0.d0) + Green_tau = cmplx(0.d0,0.d0) + Den_tau = cmplx(0.d0,0.d0) + endif + + end Subroutine Init_obs + +!======================================================================== + Subroutine Obser(GR,Phase,Ntau) + + Implicit none + + Complex (Kind=8), INTENT(IN) :: GR(Ndim,Ndim,N_FL) + Complex (Kind=8), Intent(IN) :: PHASE + Integer, INTENT(IN) :: Ntau + + !Local + Complex (Kind=8) :: GRC(Ndim,Ndim,N_FL), ZK + Complex (Kind=8) :: Zrho, Zkin, ZPot, Z, ZP,ZS + Integer :: I,J, no,no1, n, n1, imj, nf, I1, I2, J1, J2, Nc + + Real (Kind=8) :: G(4,4), X, FI, FJ + + Nobs = Nobs + 1 + ZP = PHASE/cmplx(Real(Phase,kind=8),0.d0) + ZS = cmplx(Real(Phase,kind=8)/Abs(Real(Phase,kind=8)), 0.d0) + + + Do nf = 1,N_FL + Do I = 1,Ndim + Do J = 1,Ndim + ZK = cmplx(0.d0,0.d0) + If ( I == J ) ZK = cmplx(1.d0,0.d0) + GRC(I,J,nf) = ZK - GR(J,I,nf) + Enddo + Enddo + Enddo + ! GRC(i,j,nf) = < c^{dagger}_{j,nf } c_{j,nf } > + ! Compute scalar observables. + + Zkin = cmplx(0.d0,0.d0) + + Nc = Size( Op_T,1) + Do nf = 1,N_FL + Do n = 1,Nc + Do J = 1,Op_T(n,nf)%N + J1 = Op_T(n,nf)%P(J) + DO I = 1,Op_T(n,nf)%N + I1 = Op_T(n,nf)%P(I) + Zkin = Zkin + Op_T(n,nf)%O(i,j)*Grc(i1,j1,nf) + Enddo + ENddo + Enddo + Enddo + Zkin = Zkin*cmplx( dble(N_SUN), 0.d0 ) + + Zrho = cmplx(0.d0,0.d0) + Do nf = 1,N_FL + Do I = 1,Ndim + Zrho = Zrho + Grc(i,i,nf) + enddo + enddo + Zrho = Zrho*cmplx( dble(N_SUN), 0.d0 ) + + ZPot = cmplx(0.d0,0.d0) + + Obs_scal(1) = Obs_scal(1) + zrho * ZP*ZS + Obs_scal(2) = Obs_scal(2) + zkin * ZP*ZS + Obs_scal(3) = Obs_scal(3) + Zpot * ZP*ZS + Obs_scal(4) = Obs_scal(4) + (zkin + Zpot)*ZP*ZS + Obs_scal(5) = Obs_scal(5) + ZS + ! You will have to allocate more space if you want to include more scalar observables. + DO I1 = 1,Ndim + I = List(I1,1) + no = List(I1,2) + DO J1 = 1, Ndim + J = List(J1,1) + no1 = list(J1,2) + imj = latt%imj(I,J) + + DEN_Eq (imj,no,no1) = DEN_Eq (imj,no,no1) + & + & ( GRC(I1,J1,1) * GR (I1,J1,1) + & + & GRC(I1,I1,1) * GRC(J1,J1,1) ) * ZP*ZS + + enddo + Den_eq0(no) = Den_eq0(no) + GRC(I1,I1,1)*ZP*ZS + enddo + + end Subroutine Obser +!========================================================== + + Subroutine Pr_obs(LTAU) + + Use Print_bin_mod + Implicit none +#include "machine" +#ifdef MPI + include 'mpif.h' +#endif + + + Integer, Intent(In) :: Ltau + + Character (len=64) :: File_pr + Complex (Kind=8) :: Phase_bin +#ifdef MPI + Integer :: Isize, Irank, Ierr + Integer :: STATUS(MPI_STATUS_SIZE) + CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) + CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) +#endif +!!$#ifdef MPI +!!$ Write(6,*) Irank, 'In Pr_obs', LTAU +!!$#else +!!$ Write(6,*) 'In Pr_obs', LTAU +!!$#endif + + Phase_bin = Obs_scal(5)/cmplx(dble(Nobs),0.d0) + File_pr ="Den_eq" + Call Print_bin(Den_eq, Den_eq0, Latt, Nobs, Phase_bin, file_pr) + + File_pr ="ener" + Call Print_scal(Obs_scal, Nobs, file_pr) + If (Ltau == 1) then + Phase_tau = Phase_tau/cmplx(dble(NobsT),0.d0) + File_pr = "Green_tau" + Call Print_bin_tau(Green_tau,Latt,NobsT,Phase_tau, file_pr,dtau) + File_pr = "Den_tau" + Call Print_bin_tau(Den_tau,Latt,NobsT,Phase_tau, file_pr,dtau) + endif +!!$#ifdef MPI +!!$ Write(6,*) Irank, 'out Pr_obs', LTAU +!!$#else +!!$ Write(6,*) 'out Pr_obs', LTAU +!!$#endif + end Subroutine Pr_obs +!========================================================== + + Subroutine OBSERT(NT, GT0,G0T,G00,GTT, PHASE) + Implicit none + + Integer , INTENT(IN) :: NT + Complex (Kind=8), INTENT(IN) :: GT0(Ndim,Ndim,N_FL),G0T(Ndim,Ndim,N_FL),G00(Ndim,Ndim,N_FL),GTT(Ndim,Ndim,N_FL) + Complex (Kind=8), INTENT(IN) :: Phase + + !Locals + Complex (Kind=8) :: Z, ZP, ZS + Integer :: IMJ, I, J + + ZP = PHASE/cmplx(Real(Phase,kind=8),0.d0) + ZS = cmplx(Real(Phase,kind=8)/Abs(Real(Phase,kind=8)), 0.d0) + If (NT == 0 ) then + Phase_tau = Phase_tau + ZS + NobsT = NobsT + 1 + endif + If ( N_FL == 1 ) then + Z = cmplx(dble(N_SUN),0.d0) + Do I = 1,Latt%N + Do J = 1,Latt%N + imj = latt%imj(I,J) + Green_tau(imj,nt+1,1,1) = green_tau(imj,nt+1,1,1) + Z * GT0(I,J,1) * ZP* ZS + Den_tau (imj,nt+1,1,1) = Den_tau (imj,nt+1,1,1) - Z * GT0(I,J,1)*G0T(J,I,1) * ZP* ZS + Enddo + Enddo + Endif + end Subroutine OBSERT + + + end Module Hamiltonian diff --git a/src/Prog/Hop_mod.f90 b/src/Prog/Hop_mod.f90 new file mode 100644 index 000000000..0d6028fb4 --- /dev/null +++ b/src/Prog/Hop_mod.f90 @@ -0,0 +1,217 @@ +! This is for the Kondo project with tarun. + Module Hop_mod + + + Use Hamiltonian + Use Random_wrap + Use MyMats + + ! Private variables + Complex (Kind=8), allocatable, private :: Exp_T(:,:,:,:), Exp_T_M1(:,:,:,:) + Complex (Kind=8), allocatable, private :: U_HLP(:,:), U_HLP1(:,:), V_HLP(:,:), V_HLP1(:,:) + Integer, private, save :: Ncheck, Ndim_hop + Real (Kind=8), private, save :: Zero + + Contains + + subroutine Hop_mod_init + + Implicit none + + Integer :: nc, nf + Complex (Kind=8) :: g + + Ncheck = size(Op_T,1) + If ( size(Op_T,2) /= N_FL ) then + Write(6,*) 'Error in the number of flavors.' + Stop + 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(6,*) 'Different size of Hoppings not implemented ' + Stop + 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 ( V_Hlp(Ndim_hop,Ndim) ) + Allocate ( V_Hlp1(Ndim_hop,Ndim) ) + Allocate ( U_Hlp (Ndim, Ndim_hop) ) + Allocate ( U_Hlp1(Ndim, Ndim_hop) ) + + Exp_T = cmplx(0.d0,0.d0) + Exp_T_M1 = cmplx(0.d0,0.d0) + do nf = 1,N_FL + 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)) + enddo + enddo + + Zero = 1.E-12 + + end subroutine Hop_mod_init + +!============================================================================ + Subroutine Hop_mod_mmthr(In, Out,nf) + + + ! In: IN + ! Out: OUT = e^{ -dtau T }.IN + Implicit none + + Complex (Kind=8), intent(IN) :: IN(Ndim,Ndim) + Complex (Kind=8), intent(INOUT) :: OUT(Ndim,Ndim) + Integer :: nf + + !Local + Integer :: nc, I, n + + Out = In + do nc = Ncheck,1,-1 + If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then + do I = 1,Ndim + do n = 1,Ndim_hop + V_Hlp(n,I) = Out(Op_T(nc,nf)%P(n),I) + enddo + enddo + Call mmult(V_HLP1,Exp_T(:,:,nc,nf),V_Hlp) + DO I = 1,Ndim + do n = 1,Ndim_hop + OUT(OP_T(nc,nf)%P(n),I) = V_hlp1(n,I) + Enddo + Enddo + Endif + Enddo + + end Subroutine Hop_mod_mmthr + +!============================================================================ + Subroutine Hop_mod_mmthr_m1(In, Out,nf) + + + ! In: IN + ! Out: OUT = e^{ dtau T }.IN + Implicit none + + Complex (Kind=8), intent(IN) :: IN(Ndim,Ndim) + Complex (Kind=8), intent(INOUT) :: OUT(Ndim,Ndim) + Integer :: nf + + !Local + Integer :: nc, I, n + + + Out = In + do nc = 1,Ncheck + If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then + do I = 1,Ndim + do n = 1,Ndim_hop + V_Hlp(n,I) = Out(Op_T(nc,nf)%P(n),I) + enddo + enddo + Call mmult(V_HLP1,Exp_T_m1(:,:,nc,nf),V_Hlp) + DO I = 1,Ndim + do n = 1,Ndim_hop + OUT(OP_T(nc,nf)%P(n),I) = V_hlp1(n,I) + Enddo + Enddo + Endif + Enddo + + end Subroutine Hop_mod_mmthr_m1 + +!============================================================================ + Subroutine Hop_mod_mmthl (In, Out,nf) + + + ! In: IN + ! Out: OUT = IN * e^{ -dtau T } + Implicit none + + Complex (Kind=8), intent(IN) :: IN(Ndim,Ndim) + Complex (Kind=8), intent(INOUT) :: OUT(Ndim,Ndim) + Integer :: nf + + !Local + Integer :: nc, I, n + + Out = In + do nc = 1, Ncheck + If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then + do n = 1,Ndim_hop + do I = 1,Ndim + U_Hlp(I,n) = Out(I,Op_T(nc,nf)%P(n)) + enddo + enddo + Call mmult(U_Hlp1,U_Hlp,Exp_T(:,:,nc,nf)) + do n = 1,Ndim_hop + DO I = 1,Ndim + OUT(I,OP_T(nc,nf)%P(n)) = U_hlp1(I,n) + Enddo + Enddo + Endif + Enddo + + end Subroutine Hop_mod_mmthl +!============================================================================ + Subroutine Hop_mod_mmthl_m1 (In, Out,nf) + + + ! In: IN + ! Out: OUT = IN * e^{ dtau T } + Implicit none + + Complex (Kind=8), intent(IN) :: IN(Ndim,Ndim) + Complex (Kind=8), intent(INOUT) :: OUT(Ndim,Ndim) + Integer :: nf + + !Local + Integer :: nc, I, n + + Out = In + do nc = Ncheck,1,-1 + If ( dble( Op_T(nc,nf)%g*conjg(Op_T(nc,nf)%g) ) > Zero ) then + do n = 1,Ndim_hop + do I = 1,Ndim + U_Hlp(I,n) = Out(I,Op_T(nc,nf)%P(n)) + enddo + enddo + Call mmult(U_Hlp1,U_Hlp,Exp_T_M1(:,:,nc,nf)) + do n = 1,Ndim_hop + DO I = 1,Ndim + OUT(I,OP_T(nc,nf)%P(n)) = U_hlp1(I,n) + Enddo + Enddo + Endif + Enddo + + end Subroutine Hop_mod_mmthl_m1 + +!============================================================================ +!!$ Subroutine Hop_mod_test +!!$ +!!$ Implicit none +!!$ +!!$ Complex (Kind=8) :: IN(Ndim,Ndim),Out(Ndim,Ndim) +!!$ Complex (Kind=8) :: Test(Ndim,Ndim) +!!$ +!!$ Integer :: I,J +!!$ +!!$ DO I = 1,Ndim +!!$ DO J = 1,Ndim +!!$ IN(J,I) = cmplx(Ranf(),Ranf()) +!!$ ENDDO +!!$ ENDDO +!!$ +!!$ !Write(6,*) IN +!!$ end Subroutine Hop_mod_test + + end Module Hop_mod diff --git a/src/Prog/Makefile b/src/Prog/Makefile new file mode 100644 index 000000000..e20263c71 --- /dev/null +++ b/src/Prog/Makefile @@ -0,0 +1,27 @@ +FC= $(mpif90) +FC= $(f90) +FLAGS= $(FL) +LF = $(Lflags) +LIBS= $(Libs)/Modules/modules_90.a \ + $(Libs)/MyEis/libeis.a \ + $(Libs)/MyNag/libnag.a \ + $(Libs)/MyLin/liblin.a \ + $(LIB_BLAS_LAPACK) + +Hub: + cp $(Libs)/Modules/*.mod . ;\ + (make -f Compile_Hub FC="$(FC)" FLAGS="$(FLAGS)" LIBS="$(LIBS)" ) + +SPT: + cp $(Libs)/Modules/*.mod . ;\ + (make -f Compile_SPT FC="$(FC)" FLAGS="$(FLAGS)" LIBS="$(LIBS)" LF="$(LF)" ) + +Ising: + cp $(Libs)/Modules/*.mod . ;\ + (make -f Compile_Ising FC="$(FC)" FLAGS="$(FLAGS)" LIBS="$(LIBS)" LF="$(LF)" ) + +clean: + (make -f Compile_Hub clean );\ + (make -f Compile_SPT clean );\ + (make -f Compile_Ising clean );\ + rm *.mod *~ \#* diff --git a/src/Prog/Operator.f90 b/src/Prog/Operator.f90 new file mode 100644 index 000000000..e2b1e9fa0 --- /dev/null +++ b/src/Prog/Operator.f90 @@ -0,0 +1,459 @@ +Module Operator_mod + + Use MyMats + + Implicit none + + Real (Kind=8) :: Phi(-2:2,2), Gaml(-2:2,2) + Integer :: NFLIPL(-2:2,3) + + + ! What information should the operator contain + Type Operator + Integer :: N, N_non_zero + complex (kind=8), pointer :: O(:,:), U (:,:) + Real (kind=8), pointer :: E(:) + Integer, pointer :: P(:) + complex (kind=8) :: g + complex (kind=8) :: alpha + Integer :: Type + ! P is an N X Ndim matrix such that P.T*O*P* = A + ! P has only one non-zero entry per column which is specified by P + ! All in all. g * Phi(s,type) * ( c^{dagger} A c + alpha ) + ! The variable Type allows you to define the type of HS. + ! The first N_non_zero elemets of diagonal matrix E are non-zero. The rest vanish. + end type Operator + + +Contains + + Subroutine Op_SetHS + Implicit none + Integer :: n + Phi = 0.d0 + do n = -2,2 + Phi(n,1) = real(n,kind=8) + enddo + Phi(-2,2) = - SQRT(2.D0 * ( 3.D0 + SQRT(6.D0) ) ) + Phi(-1,2) = - SQRT(2.D0 * ( 3.D0 - SQRT(6.D0) ) ) + Phi( 1,2) = SQRT(2.D0 * ( 3.D0 - SQRT(6.D0) ) ) + Phi( 2,2) = SQRT(2.D0 * ( 3.D0 + SQRT(6.D0) ) ) + + Do n = -2,2 + gaml(n,1) = 1.d0 + Enddo + GAML(-2,2) = 1.D0 - SQRT(6.D0)/3.D0 + GAML( 2,2) = 1.D0 - SQRT(6.D0)/3.D0 + GAML(-1,2) = 1.D0 + SQRT(6.D0)/3.D0 + GAML( 1,2) = 1.D0 + SQRT(6.D0)/3.D0 + + NFLIPL(-2,1) = -1 + NFLIPL(-2,2) = 1 + NFLIPL(-2,3) = 2 + + NFLIPL(-1,1) = 1 + NFLIPL(-1,2) = 2 + NFLIPL(-1,3) = -2 + + NFLIPL( 1,1) = 2 + NFLIPL( 1,2) = -2 + NFLIPL( 1,3) = -1 + + NFLIPL( 2,1) = -2 + NFLIPL( 2,2) = -1 + NFLIPL( 2,3) = 1 + + end Subroutine Op_SetHS + + Subroutine Op_phase(Phase,OP_V,Nsigma,N_SUN) ! This also goes in Operator (Input is nsigma, Op_V). + Implicit none + + Complex (Kind=8), Intent(Inout) :: Phase + Integer, Intent(IN) :: N_SUN + Integer, dimension(:,:), Intent(In) :: Nsigma + Type (Operator), dimension(:,:), Intent(In) :: Op_V + + Integer :: n, nf, nt + + do nf = 1,Size(Op_V,2) + do n = 1,size(Op_V,1) + do nt = 1,size(nsigma,2) + Phase = Phase*exp( Op_V(n,nf)%g * Op_V(n,nf)%alpha * Phi(nsigma(n,nt),Op_V(n,nf)%type) ) + enddo + enddo + enddo + Phase = Phase**dble(N_SUN) + + end Subroutine Op_phase + + + subroutine Op_make(Op,N) + Implicit none + Type (Operator), intent(INOUT) :: Op + Integer, Intent(IN) :: N + Allocate (Op%O(N,N), Op%U(N,N), Op%E(N), Op%P(N)) + Op%O = cmplx(0.d0,0.d0) + Op%U = cmplx(0.d0,0.d0) + Op%E = 0.d0 + Op%P = 0 + Op%N = N + Op%N_non_zero = N + Op%g = cmplx(0.d0,0.d0) + Op%alpha = cmplx(0.d0,0.d0) + end subroutine Op_make + + subroutine Op_clear(Op,N) + Implicit none + Type (Operator), intent(INOUT) :: Op + Integer, Intent(IN) :: N + Deallocate (Op%O, Op%U, Op%E, Op%P) + end subroutine Op_clear + +!========================================================================== + subroutine Op_set(Op) + Implicit none + Type (Operator), intent(INOUT) :: Op + + Complex (Kind=8), allocatable :: U(:,:) + Real (Kind=8), allocatable :: E(:) + Real (Kind=8) :: Zero = 1.E-9 + Integer :: N, I,J,np,nz + + If (Op%N > 1) then + !Write(6,*) 'Calling diag', Op%O(1,2), Size(Op%O,1), Size(Op%U,1), Size(Op%E,1) + N = Op%N + Allocate (U(N,N), E(N)) + Call Diag(Op%O,U, E) + Np = 0 + Nz = 0 + do I = 1,N + if ( abs(E(I)) > Zero ) then + np = np + 1 + do j = 1, N + Op%U(j,np) = U(j,i) + enddo + Op%E(np) = E(I) + else + do j = 1, N + Op%U(j,N-nz) = U(j,i) + enddo + Op%E(N-nz) = E(I) + nz = nz + 1 + endif + enddo + Op%N_non_zero = np + !Write(6,*) "Op_set", np,N + deallocate (U, E) + ! Op%U,Op%E) + !Write(6,*) 'Calling diag 1' + else + Op%E(1) = Op%O(1,1) + Op%U(1,1) = cmplx(1.d0,0.d0) + Op%N_non_zero = 1 + endif +!========================================================================== + end subroutine Op_set + + + subroutine Op_exp(g,Op,Mat) + Implicit none + Type (Operator), Intent(IN) :: Op + Complex (Kind=8), Dimension(:,:), INTENT(OUT) :: Mat + Complex (Kind=8), INTENT(IN) :: g + Complex (Kind=8) :: Z, Z1 + + Integer :: n, i,j + + Mat = cmplx(0.d0,0.d0) + Do n = 1,Op%N + Z = exp(g*cmplx(Op%E(n),0.d0)) + do J = 1,Op%N + Z1 = Z*conjg(Op%U(J,n)) + Do I = 1,Op%N + Mat(I,J) = Mat(I,J) + Op%U(I,n)*Z1 + enddo + enddo + enddo + end subroutine Op_exp + + subroutine Op_mmultL(Mat,Op,spin,Ndim) + Implicit none + Integer :: Ndim + Type (Operator) , INTENT(IN ) :: Op + Complex (Kind=8), INTENT(INOUT) :: Mat (Ndim,Ndim) + Real (Kind=8), INTENT(IN ) :: spin + + + ! Local + Complex (Kind=8) :: VH(Ndim,Op%N), Z, Z1 + Integer :: n, i, m, m1 + + + ! In Mat + ! Out Mat = Mat*exp(spin*Op) + + VH = cmplx(0.d0,0.d0) + do n = 1,Op%N + Z = exp(Op%g*cmplx(Op%E(n)*spin,0.d0)) + Do m = 1,Op%N + Z1 = Op%U(m,n)* Z + DO I = 1,Ndim + VH(I,n) = VH(I,n) + Mat(I,Op%P(m)) * Z1 + Enddo + enddo + Enddo + Do n = 1,Op%N + Do I = 1,Ndim + Mat(I,Op%P(n)) = VH(I,n) + Enddo + Enddo + + + VH = cmplx(0.d0,0.d0) + do n = 1,Op%N + Do m = 1,Op%N + Z1 = conjg(Op%U(n,m)) + DO I = 1,Ndim + VH(I,n) = VH(I,n) + Mat(I,Op%P(m)) * Z1 + Enddo + enddo + Enddo + Do n = 1,Op%N + Do I = 1,Ndim + Mat(I,Op%P(n)) = VH(I,n) + Enddo + Enddo + + + + end subroutine Op_mmultL + + subroutine Op_mmultR(Mat,Op,spin,Ndim) + Implicit none + Integer :: Ndim + Type (Operator) , INTENT(IN ) :: Op + Complex (Kind=8), INTENT(INOUT) :: Mat (Ndim,Ndim) + Real (Kind=8), INTENT(IN ) :: spin + + + ! Local + Complex (Kind=8) :: VH(Ndim,Op%N), Z, Z1 + Integer :: n, i, m, m1 + + ! In Mat + ! Out Mat = exp(spin*Op)*Mat + VH = cmplx(0.d0,0.d0) + do n = 1,Op%N + Z1 = exp(Op%g*cmplx(Op%E(n)*spin,0.d0)) + Do m = 1,Op%N + Z = conjg(Op%U(m,n))* Z1 + DO I = 1,Ndim + VH(I,n) = VH(I,n) + Z* Mat(Op%P(m),I) + Enddo + enddo + Enddo + Do n = 1,Op%N + Do I = 1,Ndim + Mat(Op%P(n),I) = VH(I,n) + Enddo + Enddo + VH = cmplx(0.d0,0.d0) + do n = 1,Op%N + Do m = 1,Op%N + Z = Op%U(n,m) + DO I = 1,Ndim + VH(I,n) = VH(I,n) + Z* Mat(Op%P(m),I) + Enddo + enddo + Enddo + Do n = 1,Op%N + Do I = 1,Ndim + Mat(Op%P(n),I) = VH(I,n) + Enddo + Enddo + + + end subroutine Op_mmultR + + Subroutine Op_Wrapup(Mat,Op,spin,Ndim,N_Type) + + Implicit none + + Integer :: Ndim + Type (Operator) , INTENT(IN ) :: Op + Complex (Kind=8), INTENT(INOUT) :: Mat (Ndim,Ndim) + Real (Kind=8), INTENT(IN ) :: spin + Integer, INTENT(IN) :: N_Type + + ! Local + Complex (Kind=8) :: VH(Ndim,Op%N), Z, Z1 + Integer :: n, i, m, m1 + + + + + !!!!! N_Type ==1 + ! exp(Op%g*spin*Op%E)*(Op%U^{dagger})*Mat*Op%U*exp(-Op%g*spin*Op%E) + ! + !!!!! + !!!!! N_Type == 2 + ! Op%U * Mat * (Op%U^{dagger}) + !!!!! + If (N_type == 1) then + VH = cmplx(0.d0,0.d0) + do n = 1,Op%N + Z=cmplx(1.d0,0.d0) + If ( n <= OP%N_non_Zero) Z = exp(-Op%g*cmplx(Op%E(n)*spin,0.d0)) + Do m = 1,Op%N + Z1 = Op%U(m,n) * Z + DO I = 1,Ndim + VH(I,n) = VH(I,n) + Mat(I,Op%P(m)) * Z1 + Enddo + enddo + Enddo + Do n = 1,Op%N + Do I = 1,Ndim + Mat(I,Op%P(n)) = VH(I,n) + Enddo + Enddo + + VH = cmplx(0.d0,0.d0) + do n = 1,Op%N + Z=cmplx(1.d0,0.d0) + If ( n <= OP%N_non_Zero) Z = exp(Op%g*cmplx(Op%E(n)*spin,0.d0)) + Do m = 1,Op%N + Z1 = Z * conjg(Op%U(m,n)) + DO I = 1,Ndim + VH(I,n) = VH(I,n) + Z1* Mat(Op%P(m),I) + Enddo + enddo + enddo + Do n = 1,Op%N + Do I = 1,Ndim + Mat(Op%P(n),I) = VH(I,n) + Enddo + Enddo + elseif (N_Type == 2) then + VH = cmplx(0.d0,0.d0) + do n = 1,Op%N + Do m = 1,Op%N + Z1 = conjg(Op%U(n,m)) + DO I = 1,Ndim + VH(I,n) = VH(I,n) + Mat(I,Op%P(m)) * Z1 + Enddo + enddo + Enddo + Do n = 1,Op%N + Do I = 1,Ndim + Mat(I,Op%P(n)) = VH(I,n) + Enddo + Enddo + + VH = cmplx(0.d0,0.d0) + do n = 1,Op%N + Do m = 1,Op%N + Z1 = Op%U(n,m) + DO I = 1,Ndim + VH(I,n) = VH(I,n) + Z1* Mat(Op%P(m),I) + Enddo + enddo + enddo + Do n = 1,Op%N + Do I = 1,Ndim + Mat(Op%P(n),I) = VH(I,n) + Enddo + Enddo + endif + end Subroutine Op_Wrapup + + Subroutine Op_Wrapdo(Mat,Op,spin,Ndim,N_Type) + + Implicit none + + Integer :: Ndim + Type (Operator) , INTENT(IN ) :: Op + Complex (Kind=8), INTENT(INOUT) :: Mat (Ndim,Ndim) + Real (Kind=8), INTENT(IN ) :: spin + Integer, INTENT(IN) :: N_Type + + ! Local + Complex (Kind=8) :: VH(Ndim,Op%N), Z, Z1 + Integer :: n, i, m, m1 + + !!!!! N_Type == 1 + ! Op%U*exp(-Op%g*spin*Op%E)*Mat*exp(Op%g*spin*Op%E)*(Op%U^{dagger}) + ! + !!!!! + !!!!! N_Type == 2 + ! (Op%U^{dagger}) * Mat * Op%U + !!!!! + If (N_type == 1) then + VH = cmplx(0.d0,0.d0) + Do m = 1,Op%N + Z = cmplx(1.d0,0.d0) + If ( m <= OP%N_non_Zero) Z = exp(Op%g*cmplx(Op%E(m)*spin,0.d0)) + do n = 1,Op%N + Z1 = Z * conjg(Op%U(n,m)) + DO I = 1,Ndim + VH(I,n) = VH(I,n) + Mat(I,Op%P(m)) * Z1 + Enddo + enddo + Enddo + Do n = 1,Op%N + Do I = 1,Ndim + Mat(I,Op%P(n)) = VH(I,n) + Enddo + Enddo + + VH = cmplx(0.d0,0.d0) + Do m = 1,Op%N + Z = cmplx(1.d0,0.d0) + If ( m <= OP%N_non_Zero) Z = exp(-Op%g*cmplx(Op%E(m)*spin,0.d0)) + do n = 1,Op%N + Z1 = Z * Op%U(n,m) + DO I = 1,Ndim + VH(I,n) = VH(I,n) + Z1* Mat(Op%P(m),I) + Enddo + enddo + enddo + Do n = 1,Op%N + Do I = 1,Ndim + Mat(Op%P(n),I) = VH(I,n) + Enddo + Enddo + elseif (N_Type == 2) then + VH = cmplx(0.d0,0.d0) + do n = 1,Op%N + Do m = 1,Op%N + Z1 = Op%U(m,n) + DO I = 1,Ndim + VH(I,n) = VH(I,n) + Mat(I,Op%P(m)) * Z1 + Enddo + enddo + Enddo + Do n = 1,Op%N + Do I = 1,Ndim + Mat(I,Op%P(n)) = VH(I,n) + Enddo + Enddo + + VH = cmplx(0.d0,0.d0) + do n = 1,Op%N + Do m = 1,Op%N + Z1 = conjg(Op%U(m,n)) + DO I = 1,Ndim + VH(I,n) = VH(I,n) + Z1* Mat(Op%P(m),I) + Enddo + enddo + enddo + Do n = 1,Op%N + Do I = 1,Ndim + Mat(Op%P(n),I) = VH(I,n) + Enddo + Enddo + endif + + end Subroutine Op_Wrapdo + + +end Module Operator_mod diff --git a/src/Prog/UDV_WRAP.F90 b/src/Prog/UDV_WRAP.F90 new file mode 100644 index 000000000..4fb367afb --- /dev/null +++ b/src/Prog/UDV_WRAP.F90 @@ -0,0 +1,135 @@ + Module UDV_Wrap_mod + Use MyMats + Use Files_mod + + Contains + +!*************************************************************** + Subroutine UDV_Wrap_Pivot(A,U,D,V,NCON,N1,N2) + + Implicit NONE + COMPLEX (KIND=8), INTENT(IN), DIMENSION(:,:) :: A + COMPLEX (KIND=8), INTENT(INOUT), DIMENSION(:,:) :: U,V + COMPLEX (KIND=8), INTENT(INOUT), DIMENSION(:) :: D + INTEGER, INTENT(IN) :: NCON + INTEGER, INTENT(IN) :: N1,N2 + + ! Locals + REAL (Kind=8) :: VHELP(N2), XNORM(N2), XMAX, XMEAN + INTEGER :: IVPT(N2), IVPTM1(N2), I, J, K, IMAX + COMPLEX (KIND=8) :: A1(N1,N2), A2(N1,N2) + + DO I = 1,N2 + XNORM(I) = 0.D0 + DO J = 1,N1 + XNORM(I) = XNORM(I) + DBLE( A(J,I) * CONJG( A(J,I) ) ) + ENDDO + ENDDO + DO I = 1,N2 + VHELP(I) = XNORM(I) + ENDDO + + DO I = 1,N2 + XMAX = 0.D0 + DO J = 1,N2 + IF (VHELP(J).GT.XMAX) THEN + IMAX = J + XMAX = VHELP(J) + ENDIF + ENDDO + VHELP(IMAX) = -1.D0 + IVPTM1(IMAX)= I + IVPT(I) = IMAX + ENDDO + DO I = 1,N2 + K = IVPT(I) + DO J = 1,N1 + A1(J,I) = A(J,K) + ENDDO + ENDDO + + CALL UDV_Wrap(A1,U,D,V,NCON) + + A1 = V + DO I = 1,N2 + K = IVPTM1(I) + DO J = 1,N1 + V(J,I) = A1(J,K) + ENDDO + ENDDO + + + IF (NCON == 1) THEN + !Check the result A = U D V + DO J = 1,N2 + DO I = 1,N1 + A1(I,J) = D(I)*V(I,J) + ENDDO + ENDDO + Call MMULT (A2,U,A1) + CALL COMPARE(A,A2,XMAX,XMEAN) + Write (6,*) 'Check afer Pivoting', XMAX + ENDIF + + + + End Subroutine UDV_Wrap_Pivot +!*************************************************************** + Subroutine UDV_Wrap(A,U,D,V,NCON) + +#include "machine" + + Implicit None +#ifdef MPI + INCLUDE 'mpif.h' +#endif + COMPLEX (KIND=8), INTENT(IN), DIMENSION(:,:) :: A + COMPLEX (KIND=8), INTENT(INOUT), DIMENSION(:,:) :: U,V + COMPLEX (KIND=8), INTENT(INOUT), DIMENSION(:) :: D + INTEGER, INTENT(IN) :: NCON + + !Local + Complex (Kind=8), Allocatable :: A1(:,:),U1(:,:) + Integer :: I,J, N + character (len=64) :: file_sr, File +#ifdef MPI + INTEGER :: STATUS(MPI_STATUS_SIZE) + INTEGER :: Isize, Irank,Ierr + + CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) + CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) +#endif + + File_sr = "SDV" +#ifdef MPI + File = File_i(File_sr, Irank) +#else + File = File_sr +#endif + !Open (Unit = 78,File=File, Status='UNKNOWN', action="write", position="append") + !Write(78,*) 'Call QR' + !Close(78) + CALL QR(A,U,V,NCON) + !Open (Unit = 78,File=File, Status='UNKNOWN', action="write", position="append") + !Write(78,*) 'End call QR' + !Close(78) + N = Size(V,1) + Allocate (A1(N,N),U1(N,N)) + A1 = V + !Open (Unit = 78,File=File, Status='UNKNOWN') + !Write(78,*) 'Call SVD' + !DO I = 1,N + ! Write(78,*) Real(V(I,I)) + !ENDDO + !Close(78) + CALL SVD(A1,U1,D,V,NCON) + !Open (Unit = 78,File=File, Status='UNKNOWN', action="write", position="append") + !Write(78,*) 'End call SVD' + !Close(78) + Call MMULT(A1,U,U1) + U = A1 + + End Subroutine UDV_Wrap + + End Module UDV_Wrap_mod + diff --git a/src/Prog/cgr1.f90 b/src/Prog/cgr1.f90 new file mode 100644 index 000000000..b7fc92ca1 --- /dev/null +++ b/src/Prog/cgr1.f90 @@ -0,0 +1,110 @@ + SUBROUTINE CGR(PHASE,NVAR, GRUP, URUP,DRUP,VRUP, ULUP,DLUP,VLUP) + + Use UDV_Wrap_mod + + Implicit None + + !!! GRUP = (1 + UR*DR*VR*VL*DL*UL)^-1 + !!! NVAR = 1 Big scales are in DL + !!! NVAR = 2 Big scales are in DR + + !Arguments. + COMPLEX(Kind=8), Dimension(:,:), Intent(IN) :: URUP, VRUP, ULUP, VLUP + COMPLEX(Kind=8), Dimension(:), Intent(In) :: DLUP, DRUP + COMPLEX(Kind=8), Dimension(:,:), Intent(INOUT) :: GRUP + COMPLEX(Kind=8) :: PHASE + INTEGER :: NVAR + + !Local + COMPLEX (Kind=8), Dimension(:,:), Allocatable :: UUP, VUP, TPUP, TPUP1, & + & TPUPM1,TPUP1M1, UUPM1, VUP1 + COMPLEX (Kind=8), Dimension(:) , Allocatable :: DUP + COMPLEX (Kind=8) :: ZDUP1, ZDDO1, ZDUP2, ZDDO2, Z1, ZUP, ZDO, Z + Integer :: I,J, N_size, NCON, NR, NT, N + Real (Kind=8) :: X, Xmax + + N_size = SIZE(DLUP,1) + NCON = 0 + + Allocate( UUP(N_size,N_size), VUP(N_size,N_size), TPUP(N_size,N_size), TPUP1(N_size,N_size), & + & TPUPM1(N_size,N_size),TPUP1M1(N_size,N_size), UUPM1(N_size,N_size), VUP1(N_size,N_size), DUP(N_size) ) + + !Write(6,*) 'In CGR', N_size + CALL MMULT(VUP,VRUP,VLUP) + DO J = 1,N_size + DO I = 1,N_size + TPUP(I,J) = DRUP(I)*VUP(I,J)*DLUP(J) + ENDDO + ENDDO + CALL MMULT(UUP,ULUP,URUP) + DO J = 1,N_size + DO I = 1,N_size + UUPM1(I,J) = CONJG(UUP(J,I)) + ENDDO + ENDDO + DO J = 1,N_size + DO I = 1,N_size + TPUP(I,J) = TPUP(I,J) + UUPM1(I,J) + ENDDO + ENDDO + IF (NVAR.EQ.1) THEN + !WRITE(6,*) 'UDV of U + DR * V * DL' + CALL UDV_WRAP(TPUP,UUP,DUP,VUP,NCON) + !CALL UDV(TPUP,UUP,DUP,VUP,NCON) + CALL MMULT(TPUP,VUP,ULUP) + !Do I = 1,N_size + ! Write(6,*) DLUP(I) + !enddo + CALL INV(TPUP,TPUPM1,ZDUP1) + !WRITE(6,*) 'End called Inv' + CALL MMULT(TPUP1,URUP,UUP) + CALL INV(TPUP1,TPUP1M1,ZDUP2) + Z1 = ZDUP1*ZDUP2 + ELSEIF (NVAR.EQ.2) THEN + !WRITE(6,*) 'UDV of (U + DR * V * DL)^{*}' + DO J = 1,N_size + DO I = 1,N_size + TPUP1(I,J) = CONJG( TPUP(J,I) ) + ENDDO + ENDDO + CALL UDV_WRAP(TPUP1,UUP,DUP,VUP,NCON) + !CALL UDV(TPUP1,UUP,DUP,VUP,NCON) + DO J = 1,N_size + DO I = 1,N_size + TPUP(I,J) = CONJG( ULUP(J,I) ) + ENDDO + ENDDO + CALL MMULT(TPUPM1,TPUP,UUP) + DO J = 1,N_size + DO I = 1,N_size + VUP1(I,J) = CONJG( VUP(J,I) ) + ENDDO + ENDDO + CALL MMULT(TPUP1,URUP,VUP1) + CALL INV(TPUP1,TPUP1M1,ZDUP2) + CALL INV(TPUPM1, TPUP, ZDUP1) + Z1 = ZDUP2/ZDUP1 + ENDIF + DO I = 1,N_size + Z = DUP(I) + if (I == 1) Xmax = real(SQRT( Z* conjg(Z)),kind=8) + if ( real(SQRT( Z* conjg(Z)),kind=8) < Xmax ) Xmax = & + & real(SQRT( Z* conjg(Z)),kind=8) + ENDDO + !Write(6,*) 'Cgr1, Cutoff: ', Xmax + + + DO J = 1,N_size + DO I = 1,N_size + ZUP = CMPLX(0.D0,0.D0) + DO NR = 1,N_size + ZUP = ZUP + TPUPM1(I,NR)*TPUP1M1(NR,J)/DUP(NR) + ENDDO + GRUP(I,J) = ZUP + ENDDO + ENDDO + PHASE = Z1/SQRT( Z1* CONJG(Z1) ) + + Deallocate(UUP, VUP, TPUP,TPUP1,TPUPM1, TPUP1M1, UUPM1, VUP1, DUP ) + + END SUBROUTINE CGR diff --git a/src/Prog/cgr2.f90 b/src/Prog/cgr2.f90 new file mode 100644 index 000000000..213a01b25 --- /dev/null +++ b/src/Prog/cgr2.f90 @@ -0,0 +1,122 @@ + SUBROUTINE CGR2(GRT0, GR00, GRTT, GR0T, U2, D2, V2, U1, D1, V1, LQ) + + ! B2 = U2*D2*V2 + ! B1 = V1*D1*U1 + !Calc: ( 1 B1 )^-1 i.e. 2*LQ \times 2*LQ matrix + ! (-B2 1 ) + + + Use Precdef + Use UDV_WRAP_mod + Use MyMats + + Implicit none + + ! Arguments + Integer :: LQ + Complex (Kind=double), intent(in) :: U1(LQ,LQ), V1(LQ,LQ), U2(LQ,LQ), V2(LQ,LQ) + Complex (Kind=double), intent(in) :: D2(LQ), D1(LQ) + Complex (Kind=double), intent(inout) :: GRT0(LQ,LQ), GR0T(LQ,LQ), GR00(LQ,LQ), GRTT(LQ,LQ) + + + ! Local:: + Complex (Kind=double) :: U3B(2*LQ,2*LQ), V3B(2*LQ,2*LQ), HLPB1(2*LQ,2*LQ), HLPB2(2*LQ,2*LQ), & + & V2INV(LQ,LQ), V1INV(LQ,LQ), HLP2(LQ,LQ) + Complex (Kind=double) :: D3B(2*LQ) + Complex (Kind=double) :: Z + + Integer :: LQ2, I,J, M, ILQ, JLQ, NCON, I1, J1 + + LQ2 = LQ*2 + + HLPB1 = cmplx(0.D0,0.d0,double) + DO I = 1,LQ + HLPB1(I , I + LQ ) = D1(I) + HLPB1(I+LQ, I ) = -D2(I) + ENDDO + CALL INV(V2,V2INV,Z) + CALL INV(V1,V1INV,Z) + CALL MMULT(HLP2,V1INV,V2INV) + DO J = 1,LQ + DO I = 1,LQ + HLPB1(I,J) = HLP2(I,J) + ENDDO + ENDDO + CALL MMULT(HLP2,U1,U2) + DO I = 1,LQ + ILQ = I+LQ + DO J = 1,LQ + JLQ = J + LQ + HLPB1(ILQ,JLQ) = conjg( HLP2(J,I) ) ! = (U1*U2)^T + ENDDO + ENDDO + NCON = 0 + CALL UDV_wrap(HLPB1,U3B,D3B,V3B,NCON) + + + ! Multiplication: + ! U3B^T * ( V1INV 0 ) = U3B + ! ( 0 U2^T ) + + DO I = 1,LQ2 + DO J = 1,LQ2 + HLPB1(I,J) = conjg(U3B(J,I)) + ENDDO + ENDDO + HLPB2 = cmplx(0.D0,0.d0,double) + DO I = 1,LQ + DO J = 1,LQ + HLPB2(I,J) = V1INV(I,J) + ENDDO + ENDDO + DO I = 1,LQ + ILQ = I + LQ + DO J = 1,LQ + JLQ = J + LQ + HLPB2(ILQ,JLQ) = conjg(U2(J,I)) + ENDDO + ENDDO + CALL MMULT(U3B,HLPB1,HLPB2) + + + ! Multiplication: + ! ( V2INV 0 )*(V3B)^{-1} = V3B + ! ( 0 U1^T ) + + CALL INV(V3B,HLPB1,Z) + HLPB2 = cmplx(0.d0,0.d0,double) + DO I = 1,LQ + DO J = 1,LQ + HLPB2(I,J) = V2INV(I,J) + ENDDO + ENDDO + DO I = 1,LQ + ILQ = I + LQ + DO J = 1, LQ + JLQ = J + LQ + HLPB2(ILQ,JLQ) = conjg(U1(J,I)) + ENDDO + ENDDO + CALL MMULT(V3B,HLPB2,HLPB1) + + + ! G = V3B * D3B^{-1}* U3B + DO M = 1,LQ2 + Z = cone/D3B(M) + DO J = 1,LQ2 + U3B(M,J) = Z * U3B(M,J) + ENDDO + ENDDO + CALL MMULT(HLPB2, V3B, U3B) + DO I = 1,LQ + I1 = I+LQ + DO J = 1,LQ + J1 = J + LQ + GR00(I,J) = HLPB2(I ,J ) + GRTT(I,J) = HLPB2(I1,J1) + GRT0(I,J) = HLPB2(I1,J ) + GR0T(I,J) = HLPB2(I,J1 ) + ENDDO + ENDDO + + END SUBROUTINE CGR2 diff --git a/src/Prog/cgr2_1.f90 b/src/Prog/cgr2_1.f90 new file mode 100644 index 000000000..78297bf8d --- /dev/null +++ b/src/Prog/cgr2_1.f90 @@ -0,0 +1,539 @@ + SUBROUTINE CGR2_1(GRT0, GR00, GRTT, GR0T, U2, D2, V2, U1, D1, V1, LQ, NVAR) + + ! B2 = U2*D2*V2 is right (i.e. from time slice 0 to tau) propagation to time tau + ! B1 = V1*D1*U1 is left (i.e. from time slice Ltrot to tau) propagation to time tau + !Calc: ( 1 B1 )^-1 ( G00 G0T ) + ! (-B2 1 ) == ( GT0 GTT ) + ! + ! G00 = (1 + B1*B2)^-1 G0T = -(1 - G00 )*B2^-1 + ! GT0 = B2 * G00 GTT = (1 + B2*B1)^-1 + + ! Here you want to compute G00, G0T, GT0 and GTT just by involving LQ x LQ matrix operations. + ! If NVAR == 1 then the large scales are in D1 + ! If NVAR == 2 then the large scales are in D2 + Use Precdef + Use MyMats + USe UDV_Wrap_mod + + Implicit none + + Interface + SUBROUTINE CGR(Z,NVAR, GRUP, URUP,DRUP,VRUP, ULUP,DLUP,VLUP) + COMPLEX(Kind=8), Dimension(:,:), Intent(In) :: URUP, VRUP, ULUP, VLUP + COMPLEX(Kind=8), Dimension(:), Intent(In) :: DLUP, DRUP + COMPLEX(Kind=8), Dimension(:,:), Intent(INOUT) :: GRUP + + COMPLEX(Kind=8) :: Z + END SUBROUTINE CGR + end Interface + + + ! Arguments + Integer, intent(in) :: LQ, NVAR + Complex (Kind=double), intent(in) :: U1(LQ,LQ), V1(LQ,LQ), U2(LQ,LQ), V2(LQ,LQ) + Complex (Kind=double), intent(in) :: D2(LQ), D1(LQ) + Complex (Kind=double), intent(inout) :: GRT0(LQ,LQ), GR0T(LQ,LQ), GR00(LQ,LQ), GRTT(LQ,LQ) + + + ! Local:: + Complex (Kind=double) :: HLP1(LQ,LQ), HLP2(LQ,LQ), U(LQ,LQ), D(LQ), V(LQ,LQ) + Complex (Kind=double) :: Z, Z1, Z2 + Real (Kind=double) :: X, Xmax, Xmin, X1, X2, Xmax1, Xmax2, Xmean + Integer :: I, J, M, NCON, NVAR1 + + Complex (Kind=double) :: V2inv(LQ,LQ), V1inv(LQ,LQ) + + + NCON = 0 + + Call INV( V2, V2inv, Z2) + CALL INV( V1, V1inv, Z1) + + + DO I = 1,LQ + DO J = 1,LQ + HLP1(I,J) = CONJG( U1(J,I) ) + ENDDO + ENDDO + CALL MMULT(HLP2,HLP1,U1) + HLP1 = cmplx(0.d0,0.d0,kind=8) + DO I = 1,LQ + HLP1(I,I) = cmplx(1.d0,0.d0,kind=8) + ENDDO + Xmax = 0.d0 + CALL COMPARE(HLP1, HLP2, XMAX, XMEAN) + + DO I = 1,LQ + DO J = 1,LQ + HLP1(I,J) = CONJG( U2(J,I) ) + ENDDO + ENDDO + CALL MMULT(HLP2,HLP1,U2) + HLP1 = cmplx(0.d0,0.d0,kind=8) + DO I = 1,LQ + HLP1(I,I) = cmplx(1.d0,0.d0,kind=8) + ENDDO + Xmax1 = 0.d0 + CALL COMPARE(HLP1, HLP2, XMAX1, XMEAN) + Write(77,*) "Cgr2_1 V1inv V2inv : ", Xmax, Xmax1 + +!!$ Xmax = 0.d0 +!!$ do I = 1,LQ +!!$ do j = 1,LQ +!!$ X = sqrt(dble(V1(i,j)*conjg(V1(i,j)))) +!!$ if (X > Xmax) Xmax = X +!!$ enddo +!!$ enddo +!!$ Write(77,*) 'In cgr2_1 Xmax V1: ', Xmax, Z2 +!!$ do I = 1,LQ +!!$ do j = 1,LQ +!!$ X = sqrt(dble(V2(i,j)*conjg(V2(i,j)))) +!!$ if (X > Xmax) Xmax = X +!!$ enddo +!!$ enddo +!!$ Write(77,*) 'In cgr2_1 Xmax V2: ', Xmax, Z1 + + ! Compute G00 + ! G00 = (1 + B1*B2)^-1 = (1 + V1 D1 U1 U2 D2 V2 )^-1 = + ! = ( V1 ( V1^-1 V2^-1 + D1 U1 U2 D2 ) V2 )^-1 = + ! = V2^-1 ( (V2 V1)^-1 + D1 U1 U2 D2 )^-1 V1^-1 + Call MMULT(HLP1,V1inv,V2inv) + Call MMULT(HLP2,U1,U2) + DO J = 1,LQ + DO I = 1,LQ + HLP2(I,J) = D1(I)*HLP2(I,J)*D2(J) + HLP1(I,J) + ENDDO + ENDDO + Xmax1 = dble( D1(1) ) + Xmax2 = dble( D2(1) ) + DO I = 2,LQ + If ( dble( D1(I) ) > Xmax1 ) Xmax1 = dble( D1(I) ) + If ( dble( D2(I) ) > Xmax2 ) Xmax2 = dble( D2(I) ) + Enddo + Nvar1 = 1 + If ( Xmax2 > Xmax1) Nvar1 = 2 + If (Nvar1 == 1) then + ! V2^-1 (UDV )^-1 V1^-1 = V2^-1 V^-1 D^-1 U^-1 V1^-1 + Call UDV_WRAP(HLP2, U, D, V, Ncon) + CALL INV (V,HLP2 ,Z ) + CALL MMULT(V,V2inv,HLP2) + DO J = 1,LQ + DO I = 1,LQ + V(I,J) = V(I,J)/D(J) + ENDDO + ENDDO + DO I = 1,LQ + DO J = 1,LQ + HLP1(I,J) = Conjg(U(J,I)) + ENDDO + ENDDO + CALL MMULT( HLP2, HLP1,V1inv) + CALL MMULT (GR00, V, HLP2) + else + ! V2^-1 (UDV )^(-1,*) V1^-1 = V2^-1 U D^-1 V^(-1,*) V1^-1 + DO J = 1,LQ + DO I = 1,LQ + HLP1(I,J) = conjg(HLP2(J,I)) + ENDDO + ENDDO + Call UDV_WRAP(HLP1, U, D, V, Ncon) + Call MMULT(HLP1, V2inv, U) + DO J = 1,LQ + DO I = 1,LQ + HLP1(I,J) = HLP1(I,J)/D(J) + ENDDO + ENDDO + CALL INV (V, HLP2, Z) + DO J = 1,LQ + DO I = 1,LQ + V(I,J) = CONJG(HLP2(J,I)) + ENDDO + ENDDO + CALL MMULT(HLP2,V,V1inv) + CALL MMULT(GR00,HLP1,HLP2) + endif + + ! Compute G0T + ! G00 = (1 + B1*B2)^-1 G0T = -(1 - (1 + B1*B2)^-1 )*B2^-1 = + ! = -( 1 + B1*B2 - 1) (1 + B1*B2)^-1 * B2^-1 = + ! = - B1 * B2 (1 + B1*B2)^-1 * B2^-1 = + ! = -( B2 ( 1+ B1*B2) * B2^-1 B1^-1)^-1 = + ! = -( B2 ( 1+ B1*B2) * (B1 B2)^-1)^-1 = + ! = -( B2 ( (B1 B2)^-1 + 1 ) )^-1 = + ! = -( B1^-1 + B2)^-1 = + ! -G0T*= ( B1*^-1 + B2*)^-1 = + ! = ( V1*^-1 D1*^-1 U1 + V2* D2* U2*)^-1 = + ! = ( V1*^-1 ( D1*^-1 U1 U2 + V1* V2* D2* ) U2* )^-1 = + ! = U2 ( D1*^-1 (U1 U2) + ( V2 V1)* D2* )^-1 V1* + ! = U2 ( D1*^-1 (U1 U2) + ( V2 V1)* D2* )^-1 V1* + ! B2 = U2*D2*V2 + ! B1 = V1*D1*U1 + Xmax2 = dble(cmplx(1.d0,0.d0)/D1(1)) + Xmax1 = dble(D2(1)) + Do I = 2,LQ + X2 = dble(cmplx(1.d0,0.d0)/D1(I)) + X1 = dble(D2(I)) + If ( X2 > Xmax2 ) Xmax2 = X2 + If ( X1 > Xmax1 ) Xmax1 = X1 + ENDDO + NVAR1 = 1 + If (Xmax2 > Xmax1) Nvar1 = 2 + Call MMULT(HLP1,U1,U2) + DO J = 1,LQ + DO I =1,LQ + HLP1(I,J) = HLP1(I,J)/conjg(D1(I)) + ENDDO + ENDDO + Call MMULT(V,V2,V1) + DO J = 1,LQ + DO I = 1,LQ + HLP2(I,J) = Conjg(V(J,I)) + ENDDO + ENDDO + DO J = 1,LQ + DO I =1,LQ + HLP2(I,J) = HLP1(I,J) + HLP2(I,J)*conjg(D2(J)) + ENDDO + ENDDO + NCON = 0 + IF ( NVAR1 == 1 ) Then + ! UDV of HLP2 + ! -G0T*= U2 V^-1 D^-1 U* V1* + CALL UDV_WRAP(HLP2,U,D,V,NCON) + CALL MMULT (HLP1, V1, U) + DO I = 1,LQ + DO J = 1,LQ + U(I,J) = conjg(HLP1(J,I)) + ENDDO + ENDDO + CALL INV(V,HLP2,Z) + Call MMULT(HLP1,U2,HLP2) + DO J = 1,LQ + Z = cmplx(1.d0,0.d0,kind=8)/D(J) + DO I = 1,LQ + HLP1(I,J) = HLP1(I,J)*Z + ENDDO + ENDDO + Call MMULT (HLP2,HLP1,U) + DO I = 1,LQ + DO J = 1,LQ + GR0T(I,J) = -conjg(HLP2(J,I)) + ENDDO + ENDDO + ELSE + ! UDV of HLP2* + ! -G0T*= U2 (U D V)*^-1 V1* = U2 U D*^-1 V*^-1 V1* + DO I = 1,LQ + DO J = 1,LQ + HLP1(I,J) = conjg(HLP2(J,I)) + ENDDO + ENDDO + CALL UDV_WRAP(HLP1,U,D,V,NCON) + CALL MMULT (HLP1, U2, U) + DO J = 1,LQ + Z = cmplx(1.d0,0.d0,kind=8)/D(J) + DO I = 1,LQ + HLP1(I,J) = HLP1(I,J)*Z + ENDDO + ENDDO + CALL INV(V,HLP2,Z) + Call MMULT(V,V1,HLP2) + DO I = 1,LQ + DO J = 1,LQ + HLP2(I,J) = conjg(V(J,I)) + ENDDO + ENDDO + Call MMULT (V,HLP1,HLP2) + DO I = 1,LQ + DO J = 1,LQ + GR0T(I,J) = -conjg(V(J,I)) + ENDDO + ENDDO + ENDIF + + + + + ! Compute GT0 + ! GT0 = B2 * G00 = ( ( 1 + B1* B2) * B2^-1 )^-1 = ( B2^-1 + B1)^-1 = + ! = (V2^-1 D2^-1 U2^-1 + V1 D1 U1)^-1 = + ! = ( (V2^-1 D2^-1 U2^-1 U1^-1 + V1 D1 ) U1 )^-1 = + ! = U1^-1 ( ( D2^-1 (U1 U2)^-1 + V2*V1 D1 ) )^-1 V2 + Xmax2 = dble(cmplx(1.d0,0.d0)/D2(1)) + Xmax1 = dble(D1(1)) + Do I = 2,LQ + X2 = dble(cmplx(1.d0,0.d0)/D2(I)) + X1 = dble(D1(I)) + If ( X2 > Xmax2 ) Xmax2 = X2 + If ( X1 > Xmax1 ) Xmax1 = X1 + ENDDO + NVAR1 = 1 + If (Xmax2 > Xmax1 ) NVAR1 = 2 + !Write(6,*) "CGR2_1: NVAR,NVAR1 ", NVAR, NVAR1 + Call MMULT(HLP2,U1,U2) + DO J = 1,LQ + DO I = 1,LQ + HLP1(I,J) = Conjg(HLP2(J,I)) + ENDDO + ENDDO + DO J = 1,LQ + DO I =1,LQ + HLP1(I,J) = HLP1(I,J)/D2(I) + ENDDO + ENDDO + Call MMULT(HLP2,V2,V1) + DO J = 1,LQ + DO I =1,LQ + HLP2(I,J) = HLP1(I,J) + HLP2(I,J)*D1(J) + ENDDO + ENDDO + NCON = 0 + IF ( NVAR1 == 1 ) Then + ! UDV of HLP2 + CALL UDV_WRAP(HLP2,U,D,V,NCON) + CALL MMULT (HLP1, V, U1) + CALL INV(HLP1,HLP2,Z) + DO J = 1,LQ + Z = cmplx(1.d0,0.d0)/D(J) + DO I = 1,LQ + HLP2(I,J) = HLP2(I,J)*Z + ENDDO + ENDDO + DO I = 1,LQ + DO J = 1,LQ + HLP1(I,J) = Conjg(U(J,I)) + ENDDO + ENDDO + CALL MMULT(U,HLP1,V2) + Call MMULT (GRT0, HLP2,U) + ELSE + !UDV of HLP2^* + DO J = 1,LQ + DO I =1,LQ + HLP1(I,J) = Conjg(HLP2(J,I)) + ENDDO + ENDDO + CALL UDV_WRAP(HLP1,U,D,V,NCON) + DO I = 1,LQ + DO J = 1,LQ + HLP1(I,J) = conjg(U1(J,I)) + ENDDO + ENDDO + CALL MMULT( HLP2, HLP1,U) + DO J = 1,LQ + DO I = 1,LQ + HLP2(I,J) = HLP2(I,J)/Conjg(D(J)) + ENDDO + ENDDO + DO I = 1,LQ + DO J = 1,LQ + HLP1(I,J) = conjg(V(J,I)) + ENDDO + ENDDO + CALL INV(HLP1,V,Z) + CALL MMULT(U,V,V2) + Call MMULT (GRT0, HLP2,U) + ENDIF + Xmin = abs(dble(D(1))) + DO I = 1,LQ + if (abs(dble(D(I))) < Xmin ) Xmin = abs(dble(D(I))) + ENDDO + Write(6,*) 'Cgr2_1 T0, Xmin: ', Xmin + + + !Compute GRTT + Z = cmplx(1.d0,0.d0,kind=8) + Z1 = cmplx(1.d0,0.d0,kind=8) + CALL CGR(Z,NVAR,GRTT, U2,D2,V2, U1,D1,V1) + + + END SUBROUTINE CGR2_1 + + +!!$ ! Compute G0T +!!$ ! G00 = (1 + B1*B2)^-1 G0T = -(1 - (1 + B1*B2)^-1 )*B2^-1 = +!!$ ! = -( 1 + B1*B2 - 1) (1 + B1*B2)^-1 * B2^-1 = +!!$ ! = - B1 * B2 (1 + B1*B2)^-1 * B2^-1 = +!!$ ! = -( B2 ( 1+ B1*B2) * B2^-1 B1^-1)^-1 = +!!$ ! = -( B2 ( 1+ B1*B2) * (B1 B2)^-1)^-1 = +!!$ ! = -( B2 ( (B1 B2)^-1 + 1 ) )^-1 = +!!$ ! = -( B1^-1 + B2)^-1 = +!!$ ! = -( U1^-1 D1^-1 V1^-1 + U2 D2 V2)^-1 = +!!$ ! = -( ( U1^-1 D1^-1 V1^-1 V2^-1 + U2 D2 ) V2 )^-1 = +!!$ ! = -( U1^-1( D1^-1 (V2 V1)^-1 + U1 U2 D2) V2 )^-1 = +!!$ ! = - V2^-1( D1^-1 (V2 V1)^-1 + U1 U2 D2)^-1 U1 +!!$ ! B2 = U2*D2*V2 +!!$ ! B1 = V1*D1*U1 +!!$ Call MMULT (HLP2, V1inv,V2inv) +!!$ DO J = 1,LQ +!!$ DO I = 1,LQ +!!$ HLP2(I,J) = HLP2(I,J)/D1(I) +!!$ ENDDO +!!$ ENDDO +!!$ Call MMULT (HLP1, U1,U2) +!!$ DO J = 1,LQ +!!$ DO I = 1,LQ +!!$ HLP2(I,J) = HLP2(I,J) + HLP1(I,J)*D2(J) +!!$ ENDDO +!!$ ENDDO +!!$ Xmax2 = dble(cmplx(1.d0,0.d0,Kind=8)/D1(1)) +!!$ Xmax1 = dble(D2(1)) +!!$ Do I = 2,LQ +!!$ X2 = dble(cmplx(1.d0,0.d0,Kind=8)/D1(I)) +!!$ X1 = dble(D2(I)) +!!$ If ( X2 > Xmax2 ) Xmax2 = X2 +!!$ If ( X1 > Xmax1 ) Xmax1 = X1 +!!$ ENDDO +!!$ NVAR1 = 1 +!!$ If (Xmax2 > Xmax1 ) NVAR1 = 2 +!!$ IF (NVAR1 == 1) Then +!!$ ! UDV of HLP2 +!!$ != - V2^-1( U D V )^-1 ) U1 = +!!$ != - V2^-1 V^-1 D^-1 U^-1 U1 = - (V V2)^-1 D^-1 U^-1 U1 +!!$ CALL UDV(HLP2,U,D,V,NCON) +!!$ DO J = 1,LQ +!!$ DO I = 1,LQ +!!$ HLP1(I,J) = conjg(U(J,I)) +!!$ ENDDO +!!$ ENDDO +!!$ CALL MMULT( U, HLP1, U1 ) +!!$ CALL MMULT(HLP1,V, V2) +!!$ CALL INV (HLP1,V ,Z) +!!$ DO J = 1,LQ +!!$ DO I = 1,LQ +!!$ HLP1(I,J) = - V(I,J)/D(J) +!!$ ENDDO +!!$ ENDDO +!!$ CALL MMULT(GR0T, HLP1, U) +!!$ Else +!!$ ! UDV of HLP2^* +!!$ != - V2^-1( U D V)^*,-1 ) U1 = +!!$ != - V2^-1 U D^-1 V^*,-1 U1 +!!$ DO I = 1,LQ +!!$ DO J = 1,LQ +!!$ HLP1(J,I) = Conjg(HLP2(I,J)) +!!$ ENDDO +!!$ ENDDO +!!$ CALL UDV(HLP1,U,D,V,NCON) +!!$ CALL INV(V2,HLP1,Z) +!!$ CALL MMULT(HLP2,HLP1,U) +!!$ DO J = 1,LQ +!!$ DO I = 1,LQ +!!$ HLP1(I,J) = -HLP2(I,J)/conjg(D(J)) +!!$ ENDDO +!!$ ENDDO +!!$ CALL INV(V,HLP2,Z) +!!$ DO J = 1,LQ +!!$ DO I = 1,LQ +!!$ V(I,J) = Conjg(HLP2(J,I)) +!!$ ENDDO +!!$ ENDDO +!!$ CALL MMULT(HLP2,V,U1) +!!$ CALL MMULT(GR0T, HLP1,HLP2) +!!$ endif +!!$ Xmin = abs(dble(D(1))) +!!$ DO I = 1,LQ +!!$ if (abs(dble(D(I))) < Xmin ) Xmin = abs(dble(D(I))) +!!$ ENDDO +!!$ Write(6,*) 'Cgr2_1 0T, Xmin: ', Xmin + + + + +!!$ ! Compute G0T +!!$ ! G00 = (1 + B1*B2)^-1 G0T = -(1 - (1 + B1*B2)^-1 )*B2^-1 = +!!$ ! = -( 1 + B1*B2 - 1) (1 + B1*B2)^-1 * B2^-1 = +!!$ ! = - B1 * B2 (1 + B1*B2)^-1 * B2^-1 = +!!$ ! = -( B2 ( 1+ B1*B2) * B2^-1 B1^-1)^-1 = +!!$ ! = -( B2 ( 1+ B1*B2) * (B1 B2)^-1)^-1 = +!!$ ! = -( B2 ( (B1 B2)^-1 + 1 ) )^-1 = +!!$ ! = -( B1^-1 + B2)^-1 = +!!$ ! = -( U1^-1 D1^-1 V1^-1 + U2 D2 V2)^-1 = +!!$ ! = -(U2 (U2^-1 U1^-1 D1^-1 + D2 V2 V1 ) V1^-1 )^-1 = +!!$ ! = - V1 ( (U1 U2)^-1 D1^-1 + D2 V2 V1 )^-1 U2^-1 +!!$ ! B2 = U2*D2*V2 +!!$ ! B1 = V1*D1*U1 +!!$ Call MMULT (HLP1, U1,U2) +!!$ DO J = 1,LQ +!!$ DO I = 1,LQ +!!$ HLP2(I,J) = Conjg(HLP1(J,I)) +!!$ ENDDO +!!$ ENDDO +!!$ DO J = 1,LQ +!!$ DO I = 1,LQ +!!$ HLP2(I,J) = HLP2(I,J) / D1(J) +!!$ ENDDO +!!$ ENDDO +!!$ +!!$ Call MMULT (HLP1, V2,V1) +!!$ DO J = 1,LQ +!!$ DO I = 1,LQ +!!$ HLP2(I,J) = HLP2(I,J) + D2(I)*HLP1(I,J) +!!$ ENDDO +!!$ ENDDO +!!$ Xmax2 = dble(cmplx(1.d0,0.d0)/D1(1)) +!!$ Xmax1 = dble(D2(1)) +!!$ Do I = 2,LQ +!!$ X2 = dble(cmplx(1.d0,0.d0)/D1(I)) +!!$ X1 = dble(D2(I)) +!!$ If ( X2 > Xmax2 ) Xmax2 = X2 +!!$ If ( X1 > Xmax1 ) Xmax1 = X1 +!!$ ENDDO +!!$ NVAR1 = 1 +!!$ If (Xmax1 > Xmax2 ) NVAR1 = 2 +!!$ IF (NVAR1 == 1) Then +!!$ ! UDV of HLP2 +!!$ != - V1 ( U D V)^-1 U2^-1 +!!$ != - V1 V^-1 D^-1 U^-1 U2^-1 = - V1 V^-1 D^-1 (U2 U)^-1 +!!$ CALL UDV(HLP2,U,D,V,NCON) +!!$ CALL MMULT( HLP2, U2, U ) +!!$ DO J = 1,LQ +!!$ DO I = 1,LQ +!!$ HLP1(I,J) = conjg(HLP2(J,I)) +!!$ ENDDO +!!$ ENDDO +!!$ CALL INV (V, HLP2 ,Z) +!!$ CALL MMULT(V, V1, HLP2) +!!$ DO J = 1,LQ +!!$ DO I = 1,LQ +!!$ HLP2(I,J) = - V(I,J)/D(J) +!!$ ENDDO +!!$ ENDDO +!!$ CALL MMULT(GR0T, HLP2, HLP1) +!!$ Else +!!$ ! UDV of HLP2^* +!!$ != - V1 ( U D V)^(*,-1) U2^-1 +!!$ != - V1 U D^(*,-1) V^(*,-1) U2^-1 +!!$ DO I = 1,LQ +!!$ DO J = 1,LQ +!!$ HLP1(J,I) = Conjg(HLP2(I,J)) +!!$ ENDDO +!!$ ENDDO +!!$ CALL UDV(HLP1,U,D,V,NCON) +!!$ CALL MMULT(HLP2,V1,U) +!!$ DO J = 1,LQ +!!$ DO I = 1,LQ +!!$ HLP2(I,J) = -HLP2(I,J)/conjg(D(J)) +!!$ ENDDO +!!$ ENDDO +!!$ +!!$ CALL INV(V,HLP1,Z) +!!$ DO J = 1,LQ +!!$ DO I = 1,LQ +!!$ V(I,J) = Conjg(HLP1(J,I)) +!!$ ENDDO +!!$ ENDDO +!!$ DO J = 1,LQ +!!$ DO I = 1,LQ +!!$ U(I,J) = Conjg(U2(J,I)) +!!$ ENDDO +!!$ ENDDO +!!$ CALL MMULT(HLP1,V,U) +!!$ +!!$ CALL MMULT(GR0T, HLP2,HLP1) +!!$ endif +!!$ Xmin = abs(dble(D(1))) +!!$ DO I = 1,LQ +!!$ if (abs(dble(D(I))) < Xmin ) Xmin = abs(dble(D(I))) +!!$ ENDDO +!!$ Write(6,*) 'Cgr2_1 0T, Xmin: ', Xmin, NVAR1 diff --git a/src/Prog/cgr2_2.f90 b/src/Prog/cgr2_2.f90 new file mode 100644 index 000000000..87e8a462f --- /dev/null +++ b/src/Prog/cgr2_2.f90 @@ -0,0 +1,176 @@ + SUBROUTINE CGR2_2(GRT0, GR00, GRTT, GR0T, U2, D2, V2, U1, D1, V1, LQ) + + + ! B2 = U2*D2*V2 is right (i.e. from time slice 0 to tau) propagation to time tau + ! B1 = V1*D1*U1 is left (i.e. from time slice Ltrot to tau) propagation to time tau + !Calc: ( 1 B1 )^-1 ( G00 G0T ) + ! (-B2 1 ) == ( GT0 GTT ) + ! + ! G00 = (1 + B1*B2)^-1 G0T = -(1 - G00)*B2^-1 + ! GT0 = B2 * G00 GTT = (1 + B2*B1)^-1 + + !( 1 V1*D1*U1 )^-1 ( ( V1 0 ) ( V1^-1 D1*U1 ) )^-1 + !(-U2*D2*V2 1 ) == ( ( 0 U2 ) * (-D2*V2 U2^-1 ) ) == I + ! You should transpose before carrying out the singular value decomposition + ! + ! + ! ( ( V1 0 ) ( V1^-1 D1*U1 )^*^* )^-1 ( V1^-1 0 ) + ! I == ( ( 0 U2 ) * (-D2*V2 U2^-1 ) ) = (UDV^*)^(-1) * ( 0 U2^-1) = + ! + ! ( V1^-1 0 ) + ! == U * D^(*,-1) * V^(*,-1) * ( 0 U2^-1) + + ! Let's see if this could work. + Use Precdef + Use MyMats + Use UDV_WRAP_mod + Implicit none + + ! Arguments + Integer, intent(in) :: LQ + Complex (Kind=double), intent(in) :: U1(LQ,LQ), V1(LQ,LQ), U2(LQ,LQ), V2(LQ,LQ) + Complex (Kind=double), intent(in) :: D2(LQ), D1(LQ) + Complex (Kind=double), intent(inout) :: GRT0(LQ,LQ), GR0T(LQ,LQ), GR00(LQ,LQ), GRTT(LQ,LQ) + + + ! Local:: + Complex (Kind=double) :: U3B(2*LQ,2*LQ), V3B(2*LQ,2*LQ), HLPB1(2*LQ,2*LQ), HLPB2(2*LQ,2*LQ), & + & V2INV(LQ,LQ), V1INV(LQ,LQ), HLP2(LQ,LQ) + Complex (Kind=double) :: D3B(2*LQ) + Complex (Kind=double) :: Z + Real (Kind=double) :: X, Xmax + + Integer :: LQ2, I,J, M, ILQ, JLQ, NCON, I1, J1,N + + LQ2 = LQ*2 + NCON = 0 + + If (dble(D1(1)) > dble(D2(1)) ) Then + + !Write(6,*) "D1(1) > D2(1)", dble(D1(1)), dble(D2(1)) + + HLPB2 = cmplx(0.D0,0.d0,double) + CALL INV(V1,V1INV,Z) + DO J = 1,LQ + DO I = 1,LQ + HLPB2(I , J ) = V1INV(I,J) + HLPB2(I , J+LQ ) = D1(I)*U1(I,J) + HLPB2(I+LQ, J+LQ ) = Conjg(U2(J,I)) + HLPB2(I+LQ, J ) = -D2(I)*V2(I,J) + ENDDO + ENDDO + DO J = 1,LQ2 + DO I = 1,LQ2 + HLPB1(I,J) = Conjg(HLPB2(J,I)) + ENDDO + ENDDO + + !CALL UDV_wrap(HLPB1,U3B,D3B,V3B,NCON) + CALL UDV_wrap_Pivot(HLPB1,U3B,D3B,V3B,NCON,LQ2,LQ2) + +!!$!!!!!!!!!!!!! Tests +!!$ Xmax = 0.d0 +!!$ DO I = 1,LQ2 +!!$ DO J = 1,LQ2 +!!$ Z = cmplx(0.d0,0.d0) +!!$ DO N = 1,LQ2 +!!$ Z = Z + U3B(I,N) *conjg(U3B(J,N)) +!!$ ENDDO +!!$ if (I == J) Z = Z - cmplx(1.d0,0.d0) +!!$ X = real(SQRT( Z* conjg(Z)),kind=8) +!!$ if (X > Xmax) Xmax = X +!!$ ENDDO +!!$ ENDDO +!!$ !Write(6,*) 'Cgr2_2, ortho: ', Xmax +!!$ DO I = 1,LQ2 +!!$ Z = D3B(I) +!!$ if (I == 1) Xmax = real(SQRT( Z* conjg(Z)),kind=8) +!!$ if ( real(SQRT( Z* conjg(Z)),kind=8) < Xmax ) Xmax = & +!!$ & real(SQRT( Z* conjg(Z)),kind=8) +!!$ ENDDO +!!$ !Write(6,*) 'Cgr2_2, Cutoff: ', Xmax +!!$!!!!!!!!!!!!! End Tests + DO J = 1,LQ2 + DO I = 1,LQ2 + HLPB2(I,J) = Conjg(V3B(J,I)) + ENDDO + ENDDO + CALL INV(HLPB2,V3B,Z) + HLPB1 = cmplx(0.d0,0.d0,double) + DO I = 1,LQ + DO J = 1,LQ + HLPB1(I , J ) = V1INV(I,J) + HLPB1(I+LQ, J+LQ ) = Conjg(U2(J,I)) + ENDDO + ENDDO + CALL MMULT(HLPB2,V3B,HLPB1) + DO J = 1,LQ2 + DO I = 1,LQ2 + HLPB1(I,J) = Conjg(cmplx(1.d0,0.d0,double)/D3B(I))*HLPB2(I,J) + ENDDO + ENDDO + CALL MMULT(HLPB2,U3B,HLPB1) + DO I = 1,LQ + I1 = I+LQ + DO J = 1,LQ + J1 = J + LQ + GR00(I,J) = HLPB2(I ,J ) + GRTT(I,J) = HLPB2(I1,J1) + GRT0(I,J) = HLPB2(I1,J ) + GR0T(I,J) = HLPB2(I,J1 ) + ENDDO + ENDDO + Else + !Write(6,*) "D1(1) < D2(1)", dble(D1(1)), dble(D2(1)) + HLPB2 = cmplx(0.D0,0.d0,double) + CALL INV(V1,V1INV,Z) + DO J = 1,LQ + DO I = 1,LQ + HLPB2(I , J ) = Conjg(U2(J,I)) + HLPB2(I , J+LQ ) = -D2(I)*V2(I,J) + HLPB2(I+LQ, J+LQ ) = V1INV(I,J) + HLPB2(I+LQ, J ) = D1(I)*U1(I,J) + ENDDO + ENDDO + DO J = 1,LQ2 + DO I = 1,LQ2 + HLPB1(I,J) = Conjg(HLPB2(J,I)) + ENDDO + ENDDO + + !CALL UDV_wrap(HLPB1,U3B,D3B,V3B,NCON) + CALL UDV_wrap_Pivot(HLPB1,U3B,D3B,V3B,NCON,LQ2,LQ2) + + DO J = 1,LQ2 + DO I = 1,LQ2 + HLPB2(I,J) = Conjg(V3B(J,I)) + ENDDO + ENDDO + CALL INV(HLPB2,V3B,Z) + HLPB1 = cmplx(0.d0,0.d0,double) + DO I = 1,LQ + DO J = 1,LQ + HLPB1(I , J ) = Conjg(U2(J,I)) + HLPB1(I+LQ, J+LQ ) = V1INV(I,J) + ENDDO + ENDDO + CALL MMULT(HLPB2,V3B,HLPB1) + DO J = 1,LQ2 + DO I = 1,LQ2 + HLPB1(I,J) = Conjg(cmplx(1.d0,0.d0,double)/D3B(I))*HLPB2(I,J) + ENDDO + ENDDO + CALL MMULT(HLPB2,U3B,HLPB1) + DO I = 1,LQ + I1 = I+LQ + DO J = 1,LQ + J1 = J + LQ + GRTT(I,J) = HLPB2(I ,J ) + GR00(I,J) = HLPB2(I1,J1) + GR0T(I,J) = HLPB2(I1,J ) + GRT0(I,J) = HLPB2(I,J1 ) + ENDDO + ENDDO + Endif + + END SUBROUTINE CGR2_2 diff --git a/src/Prog/control_mod.F90 b/src/Prog/control_mod.F90 new file mode 100644 index 000000000..ba1b18a04 --- /dev/null +++ b/src/Prog/control_mod.F90 @@ -0,0 +1,142 @@ + module Control + + Use MyMats + Implicit none + + real (Kind=8) , private, save :: XMEANG, XMAXG, XMAXP, CPU_time_st, CPU_time_en, Xmean_tau, Xmax_tau + Integer , private, save :: NCG, NCG_tau + Integer (Kind=8), private, save :: NC_up, ACC_up + + Contains + + subroutine control_init + Implicit none + XMEANG = 0.d0 + XMEAN_tau = 0.d0 + XMAXG = 0.d0 + XMAX_tau = 0.d0 + NCG = 0 + NCG_tau = 0 + NC_up = 0 + ACC_up = 0 + Call CPU_TIME(CPU_time_st) + end subroutine control_init + + Subroutine Control_upgrade(Log) + Implicit none + Logical :: Log + NC_up = NC_up + 1 + if (Log) ACC_up = ACC_up + 1 + end Subroutine Control_upgrade + + Subroutine Control_PrecisionG(A,B,Ndim) + Implicit none + + Integer :: Ndim + Complex (Kind=8) :: A(Ndim,Ndim), B(Ndim,Ndim) + Real (Kind=8) :: XMAX, XMEAN + + !Local + NCG = NCG + 1 + XMEAN = 0.d0 + XMAX = 0.d0 + CALL COMPARE(A, B, XMAX, XMEAN) + IF (XMAX > XMAXG) XMAXG = XMAX + XMEANG = XMEANG + XMEAN + !Write(6,*) 'Control', XMEAN, XMAX + End Subroutine Control_PrecisionG + + Subroutine Control_Precision_tau(A,B,Ndim) + Implicit none + + Integer :: Ndim + Complex (Kind=8) :: A(Ndim,Ndim), B(Ndim,Ndim) + Real (Kind=8) :: XMAX, XMEAN + + !Local + NCG_tau = NCG_tau + 1 + XMEAN = 0.d0 + XMAX = 0.d0 + CALL COMPARE(A, B, XMAX, XMEAN) + IF (XMAX > XMAX_tau) XMAX_tau = XMAX + XMEAN_tau = XMEAN_tau + XMEAN + !Write(6,*) 'Control_tau', XMEAN, XMAX + End Subroutine Control_Precision_tau + + + Subroutine Control_PrecisionP(Z,Z1) + Implicit none + Complex (Kind=8), INTENT(IN) :: Z,Z1 + Real (Kind=8) :: X + X = sqrt(dble((Z-Z1)*conjg(Z-Z1))) + if ( X > XMAXP ) XMAXP = X + End Subroutine Control_PrecisionP + + + Subroutine control_Print + Implicit none +#include "machine" +#ifdef MPI + include 'mpif.h' +#endif + Real (Kind=8) :: Time, Acc +#ifdef MPI + REAL (KIND=8) :: X + Integer :: Ierr, Isize, Irank + INTEGER :: STATUS(MPI_STATUS_SIZE) + CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) + CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) +#endif + + ACC = 0.d0 + IF (NC_up > 0 ) ACC = dble(ACC_up)/dble(NC_up) + Call CPU_TIME(CPU_time_en) + Time = CPU_time_en - CPU_time_st +#ifdef MPI + X = 0.d0 + CALL MPI_REDUCE(XMEANG,X,1,MPI_REAL8,MPI_SUM, 0,MPI_COMM_WORLD,IERR) + XMEANG = X/dble(Isize) + X = 0.d0 + CALL MPI_REDUCE(XMEAN_tau,X,1,MPI_REAL8,MPI_SUM, 0,MPI_COMM_WORLD,IERR) + XMEAN_tau = X/dble(Isize) + X = 0.d0 + CALL MPI_REDUCE(ACC,X,1,MPI_REAL8,MPI_SUM, 0,MPI_COMM_WORLD,IERR) + ACC = X/dble(Isize) + + X = 0.d0 + CALL MPI_REDUCE(Time,X,1,MPI_REAL8,MPI_SUM, 0,MPI_COMM_WORLD,IERR) + Time = X/dble(Isize) + + + CALL MPI_REDUCE(XMAXG,X,1,MPI_REAL8,MPI_MAX, 0,MPI_COMM_WORLD,IERR) + XMAXG = X + CALL MPI_REDUCE(XMAX_tau,X,1,MPI_REAL8,MPI_MAX, 0,MPI_COMM_WORLD,IERR) + XMAX_tau= X + + + CALL MPI_REDUCE(XMAXP,X,1,MPI_REAL8,MPI_MAX, 0,MPI_COMM_WORLD,IERR) + XMAXP = X + If (Irank == 0 ) then +#endif + + Open (Unit=50,file="info", status="unknown", position="append") + If (NCG > 0 ) then + XMEANG = XMEANG/dble(NCG) + Write(50,*) ' Precision Green Mean, Max : ', XMEANG, XMAXG + Write(50,*) ' Precision Phase, Max : ', XMAXP + endif + If ( NCG_tau > 0 ) then + XMEAN_tau = XMEAN_tau/dble(NCG_tau) + Write(50,*) ' Precision tau Mean, Max : ', XMEAN_tau, XMAX_tau + endif + Write(50,*) ' Acceptance : ', ACC + Write(50,*) ' CPU Time : ', Time + Close(50) +#ifdef MPI + endif +#endif + end Subroutine Control_Print + + end module control + + diff --git a/src/Prog/gperp.F90 b/src/Prog/gperp.F90 new file mode 100644 index 000000000..acb61d3c2 --- /dev/null +++ b/src/Prog/gperp.F90 @@ -0,0 +1,98 @@ + Subroutine Gperp_sub( G, Gperp, Ndim,Irank) + + Use Precdef + Use MyMats + Implicit none + + ! Arguments + Integer, Intent(In) :: Ndim, Irank + Complex (kind=double), Intent(In) :: G(ndim,ndim) + Complex (kind=double), Intent(InOut) :: Gperp(ndim,ndim) + + ! Local space + Complex (Kind=double) :: A(ndim,ndim), W(ndim), VL(Ndim,ndim), VR(Ndim,ndim) + Character (len=1) :: JOBVL, JOBVR + Integer :: INFO, LDA, LDVL, LDVR, N, lp, LWORK, N_c,m, i, j, NCon + Complex (Kind=double) :: WORK(2*Ndim), U(Ndim,Ndim/2), Vec(Ndim),Z + Real (Kind=double) :: RWORK(2*ndim), X, Xmax, Xmean + Complex (Kind=double) :: U1(Ndim,Ndim/2), V(Ndim/2,Ndim/2), D(Ndim/2) + + + A = G + JOBVL = "N" + JOBVR = "V" + LDA = Ndim + LWORK = 2*Ndim + LDVL = Ndim + LDVR = Ndim + N = Ndim + + Call ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO ) + + !lp = 70 + Irank + !Write(lp,*) "Info: ", INFO + N_c = 0 + do n = 1,Ndim + !Write(lp,*) n, W(n) + if ( abs( dble(W(n)) ) < 0.00001 ) then + N_c = N_c + 1 + do i = 1,Ndim + U1(i,N_c) = VR(i,n) + enddo + endif + enddo + !Write(6,*) "N_c ", N_c + NCON = 0 + Call UDV (U1,U,D,V,NCON) + + ! Setpup G_perp + gperp = cmplx(0.d0,0.d0) + Do i = 1,Ndim + do j = 1,Ndim + do n = 1,Ndim/2 + Gperp(i,j) = Gperp(i,j) + U(i,n) * conjg( U(j,n) ) + enddo + enddo + enddo + +#ifdef Test_gperp + X = 0.05 + A = cmplx(1.d0-X,0.d0) * G + cmplx(x,0.d0)*Gperp + Call Inv(A,VR,Z) + Write(lp,*) "Det is ", Z + Call MMult(VL,A,VR) + VR = cmplx(0.d0,0.d0) + do i = 1,Ndim + VR(I,I) = cmplx(1.d0,0.d0) + enddo + Call Compare(VL,VR,Xmax,Xmean) + Write(lp,*) 'Compare: ', Xmax, Xmean + + ! This is for testing + do n = 1,N_c + Vec = cmplx(0.d0,0.d0) + do i = 1,Ndim + do j = 1,Ndim + Vec(i) = Vec(i) + G(i,j) * U(j,n) + enddo + enddo + X = 0.d0 + do i = 1,Ndim + X = X + dble( Vec(i) * conjg(Vec(i))) + enddo + X = sqrt(x) + Write(lp,*) 'n, G*v = ', n, X + enddo + + do n = 1,N_c + do m = n,N_c + Z = cmplx(0.d0,0.d0) + do j = 1,Ndim + Z = Z + Conjg(U(j,m)) * U(j,n) + enddo + Write(lp,*) "n,m,z ", n,m,z + enddo + enddo +#endif + + end Subroutine Gperp_sub diff --git a/src/Prog/inconfc.F90 b/src/Prog/inconfc.F90 new file mode 100644 index 000000000..97dffc123 --- /dev/null +++ b/src/Prog/inconfc.F90 @@ -0,0 +1,126 @@ + SUBROUTINE confin + + Use Hamiltonian + + Implicit none + +#include "machine" + + + +#ifdef MPI + INCLUDE 'mpif.h' + ! Local +#endif + + Integer :: I, IERR, ISIZE, IRANK, seed_in, K, iseed, Nt + Integer, dimension(:), allocatable :: Seed_vec + Real (Kind=8) :: X + Logical :: lconf + character (len=64) :: file_sr, File_tg + +#ifdef MPI + INTEGER :: STATUS(MPI_STATUS_SIZE) + CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) + CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) +#endif + + Allocate (Nsigma(Size(Op_V,1),Ltrot)) + +#ifdef MPI + INQUIRE (FILE='confin_0', EXIST=lconf) + If (lconf) Then + file_sr = "confin" + Call Get_seed_Len(K) + Allocate(Seed_vec(K)) + file_tg = File_i(file_sr,IRANK) + Open (Unit = 10, File=File_tg, status='old', ACTION='read') + Read(10,*) Seed_vec + Call Ranset(Seed_vec) + do NT = 1,LTROT + do I = 1,Size(Op_V,1) + Read(10,*) NSIGMA(I,NT) + enddo + enddo + close(10) + Deallocate(Seed_vec) + else + If (Irank == 0) then + Write(6,*) 'No initial configuration' + OPEN(UNIT=5,FILE='seeds',STATUS='old',ACTION='read',IOSTAT=ierr) + IF (ierr /= 0) THEN + WRITE(*,*) 'unable to open ',ierr + STOP + END IF + DO I = Isize-1,1,-1 + Read (5,*) Seed_in + CALL MPI_SEND(Seed_in,1,MPI_INTEGER, I, I+1024,MPI_COMM_WORLD,IERR) + enddo + Read(5,*) Seed_in + CLOSE(5) + else + CALL MPI_RECV(Seed_in, 1, MPI_INTEGER,0, IRANK + 1024, MPI_COMM_WORLD,STATUS,IERR) + endif + Call Get_seed_Len(K) + !Write(6,*) K + Allocate(Seed_vec(K)) + Do I = 1,K + X = Ranf_Imada(Seed_in) + Seed_vec(I) = Seed_in + enddo + Call Ranset(Seed_vec) + Deallocate(Seed_vec) + do NT = 1,LTROT + do I = 1,Size(Op_V,1) + X = RANF() + NSIGMA(I,NT) = 1 + IF (X.GT.0.5) NSIGMA(I,NT) = -1 + enddo + enddo + endif + +#else + INQUIRE (FILE='confin_0', EXIST=lconf) + If (lconf) Then + file_tg = "confin_0" + Call Get_seed_Len(K) + Allocate(Seed_vec(K)) + Open (Unit = 10, File=File_tg, status='old', ACTION='read') + Read(10,*) Seed_vec + Call Ranset(Seed_vec) + do NT = 1,LTROT + do I = 1,Size(Op_V,1) + Read(10,*) NSIGMA(I,NT) + enddo + enddo + close(10) + Deallocate(Seed_vec) + else + Write(6,*) 'No initial configuration' + OPEN(UNIT=5,FILE='seeds',STATUS='old',ACTION='read',IOSTAT=ierr) + IF (ierr /= 0) THEN + WRITE(*,*) 'unable to open ',ierr + STOP + END IF + Read (5,*) Seed_in + CLOSE(5) + Call Get_seed_Len(K) + !Write(6,*) K + Allocate(Seed_vec(K)) + Do I = 1,K + X = Ranf_Imada(Seed_in) + Seed_vec(I) = Seed_in + enddo + Call Ranset(Seed_vec) + Deallocate(Seed_vec) + do NT = 1,LTROT + do I = 1,Size(Op_V,1) + X = RANF() + NSIGMA(I,NT) = 1 + IF (X.GT.0.5) NSIGMA(I,NT) = -1 + enddo + enddo + endif +#endif + + END SUBROUTINE CONFIN diff --git a/src/Prog/machine b/src/Prog/machine new file mode 100644 index 000000000..2e1fc39e2 --- /dev/null +++ b/src/Prog/machine @@ -0,0 +1 @@ +#define noMPI diff --git a/src/Prog/main.F90 b/src/Prog/main.F90 new file mode 100644 index 000000000..bd810ccd1 --- /dev/null +++ b/src/Prog/main.F90 @@ -0,0 +1,449 @@ +Program Main + + Use Operator_mod + Use Lattices_v3 + Use MyMats + Use Hamiltonian + Use Control + Use Tau_m_mod + Use Hop_mod + Implicit none +#include "machine" +#ifdef MPI + include 'mpif.h' +#endif + + + Interface + SUBROUTINE WRAPUL(NTAU1, NTAU, UL ,DL, VL) + Use Hamiltonian + Implicit none + COMPLEX (KIND=8) :: UL(Ndim,Ndim,N_FL), VL(Ndim,Ndim,N_FL) + COMPLEX (KIND=8) :: DL(Ndim,N_FL) + Integer :: NTAU1, NTAU + END SUBROUTINE WRAPUL + SUBROUTINE CGR(PHASE,NVAR, GRUP, URUP,DRUP,VRUP, ULUP,DLUP,VLUP) + Use UDV_Wrap_mod + Implicit None + COMPLEX(Kind=8), Dimension(:,:), Intent(In) :: URUP, VRUP, ULUP, VLUP + COMPLEX(Kind=8), Dimension(:), Intent(In) :: DLUP, DRUP + COMPLEX(Kind=8), Dimension(:,:), Intent(Inout) :: GRUP + COMPLEX(Kind=8) :: PHASE + INTEGER :: NVAR + END SUBROUTINE CGR + SUBROUTINE WRAPGRUP(GR,NTAU,PHASE) + Use Hamiltonian + Implicit none + COMPLEX (Kind=8), INTENT(INOUT) :: GR(Ndim,Ndim,N_FL) + COMPLEX (Kind=8), INTENT(INOUT) :: PHASE + INTEGER, INTENT(IN) :: NTAU + END SUBROUTINE WRAPGRUP + SUBROUTINE WRAPGRDO(GR,NTAU,PHASE) + Use Hamiltonian + Implicit None + COMPLEX (Kind=8), INTENT(INOUT) :: GR(NDIM,NDIM,N_FL) + COMPLEX (Kind=8), INTENT(INOUT) :: PHASE + Integer :: NTAU + end SUBROUTINE WRAPGRDO + SUBROUTINE WRAPUR(NTAU, NTAU1, UR, DR, VR) + Use Hamiltonian + Use UDV_Wrap_mod + Implicit None + COMPLEX (KIND=8) :: UR(Ndim,Ndim,N_FL), VR(Ndim,Ndim,N_FL) + COMPLEX (KIND=8) :: DR(Ndim,N_FL) + Integer :: NTAU1, NTAU + END SUBROUTINE WRAPUR + + end Interface + + COMPLEX (Kind=8), Dimension(:) , Allocatable :: D + COMPLEX (KIND=8), Dimension(:,:) , Allocatable :: TEST, A, U, V + + COMPLEX (Kind=8), Dimension(:,:) , Allocatable :: DL, DR + COMPLEX (Kind=8), Dimension(:,:,:), Allocatable :: UL, VL, UR, VR + COMPLEX (Kind=8), Dimension(:,:,:), Allocatable :: GR + + + Integer :: Nwrap, NSweep, NBin, Ltau, NSTM, NT, NT1, NVAR, LOBS_EN, LOBS_ST, NBC, NSW + Integer :: NTAU, NTAU1 + + NAMELIST /VAR_QMC/ Nwrap, NSweep, NBin, Ltau, LOBS_EN, LOBS_ST + + Integer :: Ierr, I,J,nf, nst, n + Complex (Kind=8) :: Z_ONE = cmplx(1.d0,0.d0), Phase, Z, Z1 + + ! Space for storage. + COMPLEX (Kind=8), Dimension(:,:,:) , Allocatable :: DST + COMPLEX (Kind=8), Dimension(:,:,:,:), Allocatable :: UST, VST + + ! For tests + Integer, external :: nranf + Real (kind=8) :: Weight + Integer :: nr,nth + Logical :: Log +#ifdef MPI + Integer :: Isize, Irank + INTEGER :: STATUS(MPI_STATUS_SIZE) + CALL MPI_INIT(ierr) + CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) + CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) +#endif + + ! Write(6,*) 'Call Ham_set' + Call Ham_set + ! Write(6,*) 'End Call Ham_set' + Call confin + Call Hop_mod_init + !Call Hop_mod_test + !stop + +#ifdef MPI + If ( Irank == 0 ) then +#endif + OPEN(UNIT=5,FILE='parameters',STATUS='old',ACTION='read',IOSTAT=ierr) + IF (ierr /= 0) THEN + WRITE(*,*) 'unable to open ',ierr + STOP + END IF + READ(5,NML=VAR_QMC) + CLOSE(5) +#ifdef MPI + Endif + CALL MPI_BCAST(Nwrap ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + CALL MPI_BCAST(NSweep ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + CALL MPI_BCAST(NBin ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + CALL MPI_BCAST(Ltau ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + CALL MPI_BCAST(LOBS_EN ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) + CALL MPI_BCAST(LOBS_ST ,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) +#endif + + + Call control_init + Call Alloc_obs(Ltau) + Call Op_SetHS + + +!!$#ifdef Ising_test +!!$ ! Test Ising +!!$ DO NBC = 1, NBIN +!!$ Call Init_obs +!!$ DO NSW = 1, NSWEEP +!!$ do nth = 1,Ltrot*2*Latt%N +!!$ Nt = nranf(Ltrot) +!!$ Nr = nranf(2*Latt%N) +!!$ Weight = S0(nr,nt) +!!$ log =.false. +!!$ if (Weight > ranf()) then +!!$ nsigma(nr,nt) = - nsigma(nr,nt) +!!$ log =.true. +!!$ endif +!!$ Call Control_upgrade(log) +!!$ enddo +!!$ Call Obser +!!$ Enddo +!!$ Call Preq +!!$ Enddo +!!$ Call Ham_confout +!!$ Call control_Print +!!$ Stop +!!$ ! End Test Ising +!!$#endif + + Allocate( DL(NDIM,N_FL), DR(NDIM,N_FL) ) + Allocate( UL(NDIM,NDIM,N_FL), VL(NDIM,NDIM,N_FL), & + & UR(NDIM,NDIM,N_FL), VR(NDIM,NDIM,N_FL), GR(NDIM,NDIM,N_FL ) ) + NSTM = LTROT/NWRAP +#ifdef MPI + if ( Irank == 0 ) then +#endif + Open (Unit = 50,file="info",status="unknown",position="append") + Write(50,*) 'Sweeps : ', Nsweep + Write(50,*) 'Bin : ', NBin + Write(50,*) 'Measure Int. : ', LOBS_ST, LOBS_EN + Write(50,*) 'Stabilization,Wrap : ', Nwrap + Write(50,*) 'Nstm : ', NSTM + Write(50,*) 'Ltau : ', Ltau + close(50) +#ifdef MPI + endif +#endif + + Allocate ( UST(NDIM,NDIM,NSTM,N_FL), VST(NDIM,NDIM,NSTM,N_FL), DST(NDIM,NSTM,N_FL) ) + Allocate ( Test(Ndim,Ndim) ) + + NST = NINT( DBLE(LTROT)/DBLE(NWRAP) ) + !Write(6,*) "Write UL ", NST + Do nf = 1,N_FL + CALL INITD(UL(:,:,Nf),Z_ONE) + do I = 1,Ndim + DL(I,Nf) = Z_ONE + enddo + CALL INITD(VL(:,:,nf),Z_ONE) + DO I = 1,NDim + DO J = 1,NDim + UST(I,J,NST,nf) = UL(I,J,nf) + VST(I,J,NST,nf) = VL(I,J,nf) + ENDDO + ENDDO + DO I = 1,NDim + DST(I,NST,nf) = DL(I,nf) + ENDDO + + CALL INITD(UR(:,:,nf),Z_ONE) + CALL INITD(VR(:,:,nf),Z_ONE) + Do I = 1,Ndim + DR(I,nf) = Z_ONE + Enddo + Enddo + + DO NT = LTROT-NWRAP,NWRAP,-1 + IF ( MOD(NT,NWRAP) == 0 ) THEN + NT1 = NT + NWRAP + !Write(6,*) 'Calling Wrapul:', NT1,NT + CALL WRAPUL(NT1,NT,UL,DL, VL) + NST = NINT( DBLE(NT)/DBLE(NWRAP) ) + !Write(6,*) "Write UL ", NST + Do nf = 1,N_FL + DO I = 1,Ndim + DO J = 1,Ndim + UST(I,J,NST,nf) = UL(I,J,nf) + VST(I,J,NST,nf) = VL(I,J,nf) + ENDDO + ENDDO + DO I = 1,Ndim + DST(I,NST,nf) = DL(I,nf) + ENDDO + ENDDO + ENDIF + ENDDO + CALL WRAPUL(NWRAP,0, UL ,DL, VL) + + !WRITE(6,*) 'Filling up storage' + !Write(6,*) 'Done wrapping' + NVAR = 1 + Phase = cmplx(1.d0,0.d0) + do nf = 1,N_Fl + CALL CGR(Z, NVAR, GR(:,:,nf), UR(:,:,nf),DR(:,nf),VR(:,:,nf), UL(:,:,nf),DL(:,nf),VL(:,:,nf) ) + Phase = Phase*Z + Enddo + call Op_phase(Phase,OP_V,Nsigma,N_SUN) +#ifdef MPI + WRITE(6,*) 'Phase is: ', Irank, PHASE, GR(1,1,1) +#else + WRITE(6,*) 'Phase is: ', PHASE +!!$ if (N_FL == 1) then +!!$ Do n = 1,Ndim +!!$ Write(6,*) GR(1,n,1) +!!$ enddo +!!$ else +!!$ Do n = 1,Ndim +!!$ Write(6,*) GR(1,n,1), GR(1,n,2) +!!$ enddo +!!$ endif +#endif + + Call Control_init + + DO NBC = 1, NBIN + ! Here, you have the green functions on time slice 1. + ! Set bin observables to zero. + + Call Init_obs(Ltau) + DO NSW = 1, NSWEEP + + !Propagation from 1 to Ltrot + !Set the right storage to 1 + + do nf = 1,N_FL + CALL INITD(UR(:,:,nf),Z_ONE) + CALL INITD(VR(:,:,nf),Z_ONE) + do n = 1,Ndim + DR(n,nf)= Z_ONE + Enddo + Enddo + + DO NTAU = 0, LTROT-1 + NTAU1 = NTAU + 1 + !Write(6,*) "Hi" + CALL WRAPGRUP(GR,NTAU,PHASE) + !Write(6,*) "Hi1" + IF ( MOD(NTAU1,NWRAP ) .EQ. 0 ) THEN + NST = NINT( DBLE(NTAU1)/DBLE(NWRAP) ) + NT1 = NTAU1 - NWRAP + CALL WRAPUR(NT1, NTAU1,UR, DR, VR) + Z = cmplx(1.d0,0.d0) + Do nf = 1, N_FL + DO J = 1,Ndim + DO I = 1,Ndim + UL(I,J,nf) = UST(I,J,NST,nf) + VL(I,J,nf) = VST(I,J,NST,nf) + ENDDO + ENDDO + DO I = 1,Ndim + DL(I,nf) = DST(I,NST,nf) + ENDDO + ! Write in store Right prop from 1 to LTROT/NWRAP + !Write(6,*) 'Write UR, read UL ', NTAU1, NST + DO J = 1,Ndim + DO I = 1,Ndim + UST(I,J,NST,nf) = UR(I,J,nf) + VST(I,J,NST,nf) = VR(I,J,nf) + ENDDO + ENDDO + DO I = 1,Ndim + DST(I,NST,nf) = DR(I,nf) + ENDDO + NVAR = 1 + IF (NTAU1 .GT. LTROT/2) NVAR = 2 + !Write(6,*) ' Call Cgr' + do J = 1,Ndim + do I = 1,Ndim + TEST(I,J) = GR(I,J,nf) + enddo + enddo + CALL CGR(Z1, NVAR, GR(:,:,nf), UR(:,:,nf),DR(:,nf),VR(:,:,nf),UL(:,:,nf),DL(:,nf),VL(:,:,nf) ) + Z = Z*Z1 + !Write(6,*) 'Calling control ',NTAU1, Z1 + Call Control_PrecisionG(GR(:,:,nf),Test,Ndim) + ENDDO + call Op_phase(Z,OP_V,Nsigma,N_SUN) + Call Control_PrecisionP(Z,Phase) + Phase = Z + ENDIF + + IF (NTAU1.GE. LOBS_ST .AND. NTAU1.LE. LOBS_EN ) THEN + !Write(6,*) 'Call obser ', Ntau1 + CALL Obser( GR, PHASE, Ntau1 ) + !Write(6,*) 'Return obser' + ENDIF + !Write(6,*) NTAU1 + ENDDO + + Do nf = 1,N_FL + CALL INITD(UL(:,:,nf),Z_ONE) + CALL INITD(VL(:,:,nf),Z_ONE) + Do n = 1,Ndim + DL(n,nf) = Z_ONE + Enddo + ENDDO + + DO NTAU = LTROT,1,-1 + NTAU1 = NTAU - 1 + CALL WRAPGRDO(GR,NTAU, PHASE) + IF (NTAU1.GE. LOBS_ST .AND. NTAU1.LE. LOBS_EN ) THEN + CALL Obser( GR, PHASE, Ntau1 ) + ENDIF + IF ( MOD(NTAU1,NWRAP).EQ.0 .AND. NTAU1.NE.0 ) THEN + ! WRITE(50,*) 'Recalc at :', NTAU1 + NST = NINT( DBLE(NTAU1)/DBLE(NWRAP) ) + NT1 = NTAU1 + NWRAP + !Write(6,*) 'Wrapul : ', NT1, NTAU1 + CALL WRAPUL(NT1,NTAU1, UL, DL, VL ) + !Write(6,*) 'Write UL, read UR ', NTAU1, NST + Z = cmplx(1.d0,0.d0) + do nf = 1,N_FL + DO J = 1,Ndim + DO I = 1,Ndim + UR(I,J,nf) = UST(I,J,NST,nf) + VR(I,J,nf) = VST(I,J,NST,nf) + ENDDO + ENDDO + DO I = 1,Ndim + DR(I,nf) = DST(I,NST,nf) + ENDDO + ! WRITE in store the left prop. from LTROT/NWRAP-1 to 1 + DO J = 1,Ndim + DO I = 1,Ndim + UST(I,J,NST,nf) = UL(I,J,nf) + VST(I,J,NST,nf) = VL(I,J,nf) + ENDDO + ENDDO + DO I = 1,Ndim + DST(I,NST,nf) = DL(I,nf) + ENDDO + NVAR = 1 + IF (NTAU1 .GT. LTROT/2) NVAR = 2 + !Write(6,*) ' Call Cgr' + do J = 1,Ndim + do I = 1,Ndim + TEST(I,J) = GR(I,J,nf) + enddo + enddo + CALL CGR(Z1, NVAR, GR(:,:,nf), UR(:,:,nf),DR(:,nf),VR(:,:,nf), UL(:,:,nf),DL(:,nf),VL(:,:,nf) ) + Z = Z*Z1 + !Write(6,*) 'Calling control: ', NTAU1, Z1 + Call Control_PrecisionG(GR(:,:,nf),Test,Ndim) + ENDDO + call Op_phase(Z,OP_V,Nsigma,N_SUN) + Call Control_PrecisionP(Z,Phase) + Phase = Z + ENDIF + ENDDO + + !Calculate and compare green functions on time slice 0. + NT1 = 0 + CALL WRAPUL(NWRAP,NT1, UL, DL, VL ) + + do nf = 1,N_FL + CALL INITD(UR(:,:,nf),Z_ONE) + CALL INITD(VR(:,:,nf),Z_ONE) + DO I = 1,Ndim + DR(I,nf) = Z_ONE + ENDDO + ENDDO + Z = cmplx(1.d0,0.d0) + do nf = 1,N_FL + do J = 1,Ndim + do I = 1,Ndim + TEST(I,J) = GR(I,J,nf) + enddo + enddo + NVAR = 1 + CALL CGR(Z1, NVAR, GR(:,:,nf), UR(:,:,nf),DR(:,nf),VR(:,:,nf), UL(:,:,nf),DL(:,nf),VL(:,:,nf) ) + Z = Z*Z1 + !Write(6,*) 'Calling control 0', Z1 + Call Control_PrecisionG(GR(:,:,nf),Test,Ndim) + ENDDO + call Op_phase(Z,OP_V,Nsigma,N_SUN) + Call Control_PrecisionP(Z,Phase) + Phase = Z + NST = NINT( DBLE(LTROT)/DBLE(NWRAP) ) + Do nf = 1,N_FL + DO I = 1,Ndim + DO J = 1,Ndim + UST(I,J,NST,nf) = CMPLX(0.D0,0.D0) + VST(I,J,NST,nf) = CMPLX(0.D0,0.D0) + ENDDO + ENDDO + DO I = 1,Ndim + DST(I ,NST,nf) = CMPLX(1.D0,0.D0) + UST(I,I,NST,nf) = CMPLX(1.D0,0.D0) + VST(I,I,NST,nf) = CMPLX(1.D0,0.D0) + ENDDO + enddo + IF ( LTAU == 1 ) then +!!$#ifdef MPI +!!$ Write(6,*) Irank, 'Calling Tau_m', NWRAP, NSTM +!!$#else +!!$ Write(6,*) 'Calling Tau_m', NWRAP, NSTM +!!$#endif + + Call TAU_M( UST,DST,VST, GR, PHASE, NSTM, NWRAP ) +!!$#ifdef MPI +!!$ Write(6,*) Irank, 'Back Calling Tau_m' +!!$#else +!!$ Write(6,*) 'Back Calling Tau_m' +!!$#endif + endif + + ENDDO + Call Pr_obs(Ltau) + Call confout + Enddo + Call Control_Print + +#ifdef MPI + CALL MPI_FINALIZE(ierr) +#endif + +end Program Main diff --git a/src/Prog/nranf.f90 b/src/Prog/nranf.f90 new file mode 100644 index 000000000..4662b0f63 --- /dev/null +++ b/src/Prog/nranf.f90 @@ -0,0 +1,12 @@ + integer function nranf(N) + Use Random_wrap + implicit none + integer :: N + + nranf = nint(ranf()*dble(N) + 0.5) + + if (nranf .lt. 1 ) nranf = 1 + if (nranf .gt. N ) nranf = N + + end function nranf + diff --git a/src/Prog/outconfc.F90 b/src/Prog/outconfc.F90 new file mode 100644 index 000000000..1a8ec4e53 --- /dev/null +++ b/src/Prog/outconfc.F90 @@ -0,0 +1,57 @@ + SUBROUTINE confout + + Use Hamiltonian + + Implicit none + +#include "machine" + + +#ifdef MPI + INCLUDE 'mpif.h' + ! Local +#endif + + Integer :: I, IERR, ISIZE, IRANK, seed_in, K, iseed, Nt, nr + Integer, dimension(:), allocatable :: Seed_vec + Real (Kind=8) :: X + Logical :: lconf + character (len=64) :: file_sr, File_tg + +#ifdef MPI + INTEGER :: STATUS(MPI_STATUS_SIZE) + CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) + CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) + + Call Get_seed_Len(K) + Allocate(Seed_vec(K)) + Call Ranget(Seed_vec) + file_sr = "confout" + file_tg = File_i(file_sr,IRANK) + Open (Unit = 10, File=File_tg, status='unknown', ACTION='write') + Write(10,*) Seed_vec + do NT = 1,LTROT + do I = 1,Size(Nsigma,1) + write(10,*) NSIGMA(I,NT) + enddo + enddo + close(10) + Deallocate(Seed_vec) + +#else + Call Get_seed_Len(K) + Allocate(Seed_vec(K)) + Call Ranget(Seed_vec) + file_tg = "confout_0" + Open (Unit = 10, File=File_tg, status='unknown', ACTION='write') + Write(10,*) Seed_vec + do NT = 1,LTROT + do I = 1,Size(Nsigma,1) + write(10,*) Nsigma(I,NT) + enddo + enddo + close(10) + Deallocate(Seed_vec) +#endif + + END SUBROUTINE CONFOUT diff --git a/src/Prog/print_bin_mod.F90 b/src/Prog/print_bin_mod.F90 new file mode 100644 index 000000000..68376b44d --- /dev/null +++ b/src/Prog/print_bin_mod.F90 @@ -0,0 +1,300 @@ + Module Print_bin_mod + + Interface Print_bin + module procedure Print_bin_C, Print_bin_R + end Interface Print_bin + + Interface Print_bin_tau + module procedure Print_bin_tau_C + end Interface Print_bin_tau + + Contains + + Subroutine Print_bin_C(Dat_eq,Dat_eq0,Latt, Nobs, Phase_bin_tmp, file_pr) + Use Lattices_v3 + Implicit none +#include "machine" +#ifdef MPI + include 'mpif.h' +#endif + + Complex (Kind=8), Dimension(:,:,:), Intent(inout):: Dat_eq + Complex (Kind=8), Dimension(:) , Intent(inout):: Dat_eq0 + Type (Lattice), Intent(In) :: Latt + Complex (Kind=8), Intent(In) :: Phase_bin_tmp + Character (len=64), Intent(In) :: File_pr + Integer, Intent(In) :: Nobs + + ! Local + Integer :: Norb, I, no,no1 + Complex (Kind=8), allocatable :: Tmp(:,:,:), Tmp1(:) + Real (Kind=8) :: x_p(2) + Complex (Kind=8) :: Phase_bin +#ifdef MPI + Complex (Kind=8):: Z + Integer :: Ierr, Isize, Irank + INTEGER :: STATUS(MPI_STATUS_SIZE) + CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) + CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) +#endif + + Phase_bin = Phase_bin_tmp + Norb = size(Dat_eq,3) + if ( .not. (Latt%N == Size(Dat_eq,1) ) ) then + Write(6,*) 'Error in Print_bin' + Stop + endif + Allocate (Tmp(Latt%N,Norb,Norb), Tmp1(Norb) ) + Dat_eq = Dat_eq/cmplx(dble(Nobs),0.d0) + Dat_eq0 = Dat_eq0/cmplx(dble(Nobs)*dble(Latt%N),0.d0) + +#ifdef MPI + I = Latt%N*Norb*Norb + Tmp = cmplx(0.d0,0.d0) + CALL MPI_REDUCE(Dat_eq,Tmp,I,MPI_COMPLEX16,MPI_SUM, 0,MPI_COMM_WORLD,IERR) + Dat_eq = Tmp/CMPLX(DBLE(ISIZE),0.D0) + I = 1 + CALL MPI_REDUCE(Phase_bin,Z,I,MPI_COMPLEX16,MPI_SUM, 0,MPI_COMM_WORLD,IERR) + Phase_bin= Z/CMPLX(DBLE(ISIZE),0.D0) + + I = Norb + CALL MPI_REDUCE(Dat_eq0,Tmp1,I,MPI_COMPLEX16,MPI_SUM, 0,MPI_COMM_WORLD,IERR) + Dat_eq0 = Tmp1/CMPLX(DBLE(ISIZE),0.D0) + + If (Irank == 0 ) then +#endif + do no = 1,Norb + do no1 = 1,Norb + Call Fourier_R_to_K(Dat_eq(:,no,no1), Tmp(:,no,no1), Latt) + enddo + enddo + Open (Unit=10,File=File_pr, status="unknown", position="append") + Write(10,*) dble(Phase_bin),Norb,Latt%N + do no = 1,Norb + Write(10,*) Dat_eq0(no) + enddo + do I = 1,Latt%N + x_p = dble(Latt%listk(i,1))*Latt%b1_p + dble(Latt%listk(i,2))*Latt%b2_p + Write(10,*) X_p(1), X_p(2) + do no = 1,Norb + do no1 = 1,Norb + Write(10,*) tmp(I,no,no1) + enddo + enddo + enddo + close(10) +#ifdef MPI + Endif +#endif + + deallocate (Tmp, tmp1 ) + + + End Subroutine Print_bin_C + + +!========================================================= + + Subroutine Print_bin_R(Dat_eq,Dat_eq0,Latt, Nobs, Phase_bin_tmp, file_pr) + Use Lattices_v3 + Implicit none +#include "machine" +#ifdef MPI + include 'mpif.h' +#endif + + Real (Kind=8), Dimension(:,:,:), Intent(inout) :: Dat_eq + Real (Kind=8), Dimension(:) , Intent(inout) :: Dat_eq0 + Type (Lattice), Intent(In) :: Latt + Complex (Kind=8), Intent(In) :: Phase_bin_tmp + Character (len=64), Intent(In) :: File_pr + Integer, Intent(In) :: Nobs + + ! Local + Integer :: Norb, I, no,no1 + Real (Kind=8), allocatable :: Tmp(:,:,:), Tmp1(:) + Real (Kind=8) :: x_p(2) + Complex (Kind=8) :: Phase_bin +#ifdef MPI + Integer :: Ierr, Isize, Irank + Complex (Kind=8) :: Z + INTEGER :: STATUS(MPI_STATUS_SIZE) + CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) + CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) +#endif + + Phase_bin = Phase_bin_tmp + Norb = size(Dat_eq,3) + if ( .not. (Latt%N == Size(Dat_eq,1) ) ) then + Write(6,*) 'Error in Print_bin' + Stop + endif + Allocate (Tmp(Latt%N,Norb,Norb), Tmp1(Norb) ) + Dat_eq = Dat_eq/dble(Nobs) + Dat_eq0 = Dat_eq0/(dble(Nobs)*dble(Latt%N)) +#ifdef MPI + I = Latt%N*Norb*Norb + Tmp = 0.d0 + CALL MPI_REDUCE(Dat_eq,Tmp,I,MPI_REAL8,MPI_SUM, 0,MPI_COMM_WORLD,IERR) + Dat_eq = Tmp/DBLE(ISIZE) + I = 1 + CALL MPI_REDUCE(Phase_bin,Z,I,MPI_COMPLEX16,MPI_SUM, 0,MPI_COMM_WORLD,IERR) + Phase_bin= Z/CMPLX(DBLE(ISIZE),0.D0) + If (Irank == 0 ) then + + I = Norb + CALL MPI_REDUCE(Dat_eq0,Tmp1,I,MPI_REAL8,MPI_SUM, 0,MPI_COMM_WORLD,IERR) + Dat_eq0 = Tmp1/CMPLX(DBLE(ISIZE),0.D0) + +#endif + + do no = 1,Norb + do no1 = 1,Norb + Call Fourier_R_to_K(Dat_eq(:,no,no1), Tmp(:,no,no1), Latt) + enddo + enddo + Open (Unit=10,File=File_pr, status="unknown", position="append") + Write(10,*) dble(Phase_bin),Norb,Latt%N + do no = 1,Norb + Write(10,*) Dat_eq0(no) + enddo + do I = 1,Latt%N + x_p = dble(Latt%listk(i,1))*Latt%b1_p + dble(Latt%listk(i,2))*Latt%b2_p + Write(10,*) X_p(1), X_p(2) + do no = 1,Norb + do no1 = 1,Norb + Write(10,*) tmp(I,no,no1) + enddo + enddo + enddo + close(10) +#ifdef MPI + endif +#endif + deallocate (Tmp ) + + End Subroutine Print_bin_R +!============================================================ + Subroutine Print_scal(Obs, Nobs, file_pr) + + Implicit none +#include "machine" +#ifdef MPI + include 'mpif.h' +#endif + + Complex (Kind=8), Dimension(:), Intent(inout) :: Obs + Character (len=64), Intent(In) :: File_pr + Integer, Intent(In) :: Nobs + + ! Local + Integer :: Norb,I + Complex (Kind=8), allocatable :: Tmp(:) +#ifdef MPI + Integer :: Ierr, Isize, Irank + INTEGER :: STATUS(MPI_STATUS_SIZE) + CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) + CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) +#endif + + Norb = size(Obs,1) + Allocate ( Tmp(Norb) ) + Obs = Obs/cmplx(dble(Nobs),0.d0) +#ifdef MPI + Tmp = 0.d0 + CALL MPI_REDUCE(Obs,Tmp,Norb,MPI_COMPLEX16,MPI_SUM, 0,MPI_COMM_WORLD,IERR) + Obs = Tmp/cmplx(DBLE(ISIZE),0.d0) + if (Irank == 0 ) then +#endif + Open (Unit=10,File=File_pr, status="unknown", position="append") + WRITE(10,*) (Obs(I), I=1,size(Obs,1)) + close(10) +#ifdef MPI + endif +#endif + deallocate (Tmp ) + + End Subroutine Print_scal + +!============================================================== + Subroutine Print_bin_tau_C(Dat_tau,Latt, Nobs, Phase_bin, file_pr, dtau) + Use Lattices_v3 + Implicit none +#include "machine" +#ifdef MPI + include 'mpif.h' +#endif + + Complex (Kind=8), Dimension(:,:,:,:), Intent(inout):: Dat_tau + Type (Lattice), Intent(In) :: Latt + Complex (Kind=8), Intent(In) :: Phase_bin + Character (len=64), Intent(In) :: File_pr + Integer, Intent(In) :: Nobs + Real (kind=8), Intent(In) :: dtau + + ! Local + Integer :: Norb, I, no,no1, LT, nt + Complex (Kind=8), allocatable :: Tmp(:,:,:,:) + Complex (Kind=8) :: Phase_mean + Real (Kind=8) :: x_p(2) +#ifdef MPI + Complex (Kind=8):: Z + Integer :: Ierr, Isize, Irank + INTEGER :: STATUS(MPI_STATUS_SIZE) + CALL MPI_COMM_SIZE(MPI_COMM_WORLD,ISIZE,IERR) + CALL MPI_COMM_RANK(MPI_COMM_WORLD,IRANK,IERR) +#endif + + Phase_mean = Phase_bin + Norb = size(Dat_tau,3) + if ( .not. (Latt%N == Size(Dat_tau,1) ) ) then + Write(6,*) 'Error in Print_bin' + Stop + endif + LT = Size(Dat_tau,2) + Allocate (Tmp(Latt%N,LT,Norb,Norb) ) + Dat_tau = Dat_tau/cmplx(dble(Nobs),0.d0) + +#ifdef MPI + I = Latt%N*Norb*Norb*LT + Tmp = cmplx(0.d0,0.d0) + CALL MPI_REDUCE(Dat_tau,Tmp,I,MPI_COMPLEX16,MPI_SUM, 0,MPI_COMM_WORLD,IERR) + Dat_tau = Tmp/CMPLX(DBLE(ISIZE),0.D0) + I = 1 + CALL MPI_REDUCE(Phase_mean,Z,I,MPI_COMPLEX16,MPI_SUM, 0,MPI_COMM_WORLD,IERR) + Phase_mean= Z/CMPLX(DBLE(ISIZE),0.D0) + If (Irank == 0 ) then +#endif + do nt = 1,LT + do no = 1,Norb + do no1 = 1,Norb + Call Fourier_R_to_K(Dat_tau(:,nt,no,no1), Tmp(:,nt,no,no1), Latt) + enddo + enddo + enddo + Open (Unit=10,File=File_pr, status="unknown", position="append") + Write(10,*) dble(Phase_mean),Norb,Latt%N, LT, dtau + do I = 1,Latt%N + x_p = dble(Latt%listk(i,1))*Latt%b1_p + dble(Latt%listk(i,2))*Latt%b2_p + Write(10,*) X_p(1), X_p(2) + Do nt = 1,LT + do no = 1,Norb + do no1 = 1,Norb + Write(10,*) tmp(I,nt,no,no1) + enddo + enddo + enddo + enddo + close(10) +#ifdef MPI + Endif +#endif + + deallocate (Tmp ) + + + End Subroutine Print_bin_tau_C + + + + end Module Print_bin_mod diff --git a/src/Prog/tau_m.f90 b/src/Prog/tau_m.f90 new file mode 100644 index 000000000..b1056e18d --- /dev/null +++ b/src/Prog/tau_m.f90 @@ -0,0 +1,236 @@ + Module Tau_m_mod + + Use Hamiltonian + Use Operator_mod + Use Precdef + Use Control + Use Hop_mod + + Contains + + SUBROUTINE TAU_M( UST,DST,VST, GR, PHASE, NSTM, NWRAP ) + + Implicit none + + Interface + SUBROUTINE WRAPUL(NTAU1, NTAU, UL ,DL, VL) + Use Hamiltonian + Implicit none + COMPLEX (KIND=8) :: UL(Ndim,Ndim,N_FL), VL(Ndim,Ndim,N_FL) + COMPLEX (KIND=8) :: DL(Ndim,N_FL) + Integer :: NTAU1, NTAU + END SUBROUTINE WRAPUL + SUBROUTINE CGR2_2(GRT0, GR00, GRTT, GR0T, U2, D2, V2, U1, D1, V1, LQ) + Use Precdef + Use MyMats + Use UDV_WRAP_mod + Implicit none + + ! Arguments + Integer, intent(in) :: LQ + Complex (Kind=double), intent(in) :: U1(LQ,LQ), V1(LQ,LQ), U2(LQ,LQ), V2(LQ,LQ) + Complex (Kind=double), intent(in) :: D2(LQ), D1(LQ) + Complex (Kind=double), intent(inout) :: GRT0(LQ,LQ), GR0T(LQ,LQ), GR00(LQ,LQ), GRTT(LQ,LQ) + end SUBROUTINE CGR2_2 + SUBROUTINE CGR2_1(GRT0, GR00, GRTT, GR0T, U2, D2, V2, U1, D1, V1, LQ, NVAR) + Use Precdef + Use MyMats + USe UDV_Wrap_mod + Implicit none + ! Arguments + Integer, intent(in) :: LQ, NVAR + Complex (Kind=double), intent(in) :: U1(LQ,LQ), V1(LQ,LQ), U2(LQ,LQ), V2(LQ,LQ) + Complex (Kind=double), intent(in) :: D2(LQ), D1(LQ) + Complex (Kind=double), intent(inout) :: GRT0(LQ,LQ), GR0T(LQ,LQ), GR00(LQ,LQ), GRTT(LQ,LQ) + end SUBROUTINE CGR2_1 + SUBROUTINE CGR2(GRT0, GR00, GRTT, GR0T, U2, D2, V2, U1, D1, V1, LQ) + + ! B2 = U2*D2*V2 + ! B1 = V1*D1*U1 + !Calc: ( 1 B1 )^-1 i.e. 2*LQ \times 2*LQ matrix + ! (-B2 1 ) + + + Use Precdef + Use UDV_WRAP_mod + Use MyMats + + Implicit none + + ! Arguments + Integer :: LQ + Complex (Kind=double), intent(in) :: U1(LQ,LQ), V1(LQ,LQ), U2(LQ,LQ), V2(LQ,LQ) + Complex (Kind=double), intent(in) :: D2(LQ), D1(LQ) + Complex (Kind=double), intent(inout) :: GRT0(LQ,LQ), GR0T(LQ,LQ), GR00(LQ,LQ), GRTT(LQ,LQ) + end SUBROUTINE CGR2 + end Interface + + Complex (Kind=double), Intent(in) :: UST(NDIM,NDIM,NSTM,N_FL), VST(NDIM,NDIM,NSTM,N_FL), DST(NDIM,NSTM,N_FL) + Complex (Kind=double), Intent(in) :: GR(NDIM,NDIM,N_FL), Phase + Integer, Intent(In) :: NSTM, NWRAP + + + ! Local + ! This could be placed as private for the module + Complex (Kind=double) :: GT0(NDIM,NDIM,N_FL), G00(NDIM,NDIM,N_FL), GTT(NDIM,NDIM,N_FL), G0T(NDIM,NDIM,N_FL) + Complex (Kind=double) :: UL(Ndim,Ndim,N_FL), DL(Ndim,N_FL), VL(Ndim,Ndim,N_FL) + Complex (Kind=double) :: UR(Ndim,Ndim,N_FL), DR(Ndim,N_FL), VR(Ndim,Ndim,N_FL) + Complex (Kind=double) :: HLP4(Ndim,Ndim), HLP5(Ndim,Ndim), HLP6(Ndim,Ndim) + + Complex (Kind=double) :: Z + Integer :: I, J, nf, NT, NT1, NTST, NST, NVAR + + !Tau = 0 + Do nf = 1, N_FL + DO J = 1,Ndim + DO I = 1,Ndim + Z = cmplx(0.d0,0.d0) + if (I == J ) Z = cone + G00(I,J,nf) = GR(I,J,nf) + GT0(I,J,nf) = GR(I,J,nf) + GTT(I,J,nf) = GR(I,J,nf) + G0T(I,J,nf) = -(Z - GR(I,J,nf)) + ENDDO + ENDDO + Enddo + NT = 0 + ! In Module Hamiltonian + CALL OBSERT(NT, GT0,G0T,G00,GTT, PHASE) + + Do nf = 1, N_FL + CALL INITD(UR(:,:,nf),cone) + CALL INITD(VR(:,:,nf),cone) + enddo + DR = cone + + + DO NT = 0,LTROT - 1 + ! Now wrapup: + NT1 = NT + 1 + CALL PROPR (GT0,NT1) + CALL PROPRM1 (G0T,NT1) + CALL PROPRM1 (GTT,NT1) + CALL PROPR (GTT,NT1) + ! In Module Hamiltonian + CALL OBSERT(NT1, GT0,G0T,G00,GTT,PHASE) + + IF ( MOD(NT1,NWRAP).EQ.0 .AND. NT1.NE.LTROT ) THEN + NTST = NT1 - NWRAP + NST = NT1/(NWRAP) + ! WRITE(6,*) 'NT1, NST: ', NT1,NST + CALL WRAPUR(NTST, NT1,UR, DR, VR) + DO nf = 1,N_FL + DO J = 1,NDIM + DO I = 1,NDIM + UL(I,J,nf) = UST(I,J,NST,nf) + VL(I,J,nf) = VST(I,J,NST,nf) + ENDDO + ENDDO + DO I = 1,NDIM + DL(I,nf) = DST(I,NST,nf) + ENDDO + Enddo + Do nf = 1,N_FL + Do J = 1,Ndim + DO I = 1,Ndim + HLP4(I,J) = GTT(I,J,nf) + HLP5(I,J) = GT0(I,J,nf) + HLP6(I,J) = G0T(I,J,nf) + Enddo + Enddo + NVAR = 1 + IF (NT1 > LTROT/2) NVAR = 2 + !DO I = 1,Ndim + ! Write(6,*) DL(I,nf)*DR(I,nf) + !enddo + !Write(6,*) 'Call CGR2' + Call CGR2_2(GT0(:,:,nf), G00(:,:,nf), GTT(:,:,nf), G0T(:,:,nf), & + & UR(:,:,nf),DR(:,nf),VR(:,:,nf), UL(:,:,nf),DL(:,nf),VL(:,:,nf),NDIM) + !Call CGR2 (GT0(:,:,nf), G00(:,:,nf), GTT(:,:,nf), G0T(:,:,nf), & + ! & UR(:,:,nf),DR(:,nf),VR(:,:,nf), UL(:,:,nf),DL(:,nf),VL(:,:,nf),NDIM) + + !Call CGR2_1(GT0(:,:,nf), G00(:,:,nf), GTT(:,:,nf), G0T(:,:,nf), & + ! & UR(:,:,nf),DR(:,nf),VR(:,:,nf), UL(:,:,nf),DL(:,nf),VL(:,:,nf),NDIM,NVAR) + + !Write(6,*) 'End Call CGR2' + !Write(6,*) ' Tau ', NT1 + !Write(6,*) ' G00 ' + Call Control_Precision_tau(GR(:,:,nf), G00(:,:,nf), Ndim) + !Write(6,*) ' GTT ' + Call Control_Precision_tau(HLP4 , GTT(:,:,nf), Ndim) + !Write(6,*) ' GT0 ' + Call Control_Precision_tau(HLP5 , GT0(:,:,nf), Ndim) + !Write(6,*) ' G0T ' + Call Control_Precision_tau(HLP6 , G0T(:,:,nf), Ndim) + Enddo + Endif + ENDDO + + END SUBROUTINE TAU_M + +!============================================================== + + SUBROUTINE PROPR(AIN,NT) + + ! Ain = B(NT-1, NT1) + ! Aout= Ain = B(NT , NT1) + + Implicit none + Complex (Kind=double), intent(INOUT) :: Ain(Ndim,Ndim,N_FL) + Integer, INTENT(IN) :: NT + + !Locals + Integer :: J,I,nf,n + Complex (Kind=double) :: HLP4(Ndim,Ndim) + Real (Kind=double) :: X + + Do nf = 1,N_FL + !CALL MMULT(HLP4,Exp_T(:,:,nf) ,Ain(:,:,nf)) + Call Hop_mod_mmthr(Ain(:,:,nf),HLP4,nf) + Do n = 1,Size(Op_V,1) + X = Phi(nsigma(n,nt),Op_V(n,nf)%type) + Call Op_mmultR(HLP4,Op_V(n,nf),X,Ndim) + ENDDO + Do J = 1,Ndim + do I = 1,Ndim + Ain(I,J,nf) = HLP4(I,J) + enddo + ENDDO + Enddo + + end SUBROUTINE PROPR +!============================================================== + SUBROUTINE PROPRM1(AIN,NT) + + !Ain = B^{-1}(NT-1, NT1) + !Aout= B^{-1}(NT , NT1) + + + Implicit none + + !Arguments + Complex (Kind=double), intent(Inout) :: AIN(Ndim, Ndim, N_FL) + Integer :: NT + + ! Locals + Integer :: J,I,nf,n + Complex (Kind=double) :: HLP4(Ndim,Ndim) + Real (Kind=double) :: X + + do nf = 1,N_FL + !Call MMULT(HLP4,Ain(:,:,nf),Exp_T_M1(:,:,nf) ) + Call Hop_mod_mmthl_m1(Ain(:,:,nf),HLP4,nf) + Do n =1,Size(Op_V,1) + X = -Phi(nsigma(n,nt),Op_V(n,nf)%type) + Call Op_mmultL(HLP4,Op_V(n,nf),X,Ndim) + Enddo + Do J = 1,Ndim + do I = 1,Ndim + Ain(I,J,nf) = HLP4(I,J) + enddo + Enddo + enddo + + END SUBROUTINE PROPRM1 +!============================================================== + end Module Tau_m_mod diff --git a/src/Prog/upgrade.f90 b/src/Prog/upgrade.f90 new file mode 100644 index 000000000..9553fc22a --- /dev/null +++ b/src/Prog/upgrade.f90 @@ -0,0 +1,149 @@ + Subroutine Upgrade(GR,N_op,NT,PHASE,Op_dim) + + Use Hamiltonian + Use Random_wrap + Use Control + Use Precdef + Implicit none + + Complex (Kind=double) :: GR(Ndim,Ndim, N_FL) + Integer, INTENT(IN) :: N_op, Nt, Op_dim + Complex (Kind=double) :: Phase + + ! Local :: + Complex (Kind=double) :: Mat(Op_dim,Op_Dim), Delta(Op_dim,N_FL) + Complex (Kind=double) :: Ratio(N_FL), Ratiotot, Z1 + Integer :: ns_new, ns_old, n,m,nf, i,j + Complex (Kind= double) :: ZK, Z, D_Mat + Integer, external :: nranf + + Real (Kind = double) :: Weight + Complex (Kind = double) :: u(Ndim,Op_dim), v(Ndim,Op_dim) + Complex (Kind = double) :: x_v(Ndim,Op_dim), y_v(Ndim,Op_dim), xp_v(Ndim,Op_dim) + Complex (Kind = double) :: s_xv(Op_dim), s_yu(Op_dim) + + Logical :: Log + + + if ( sqrt(dble(OP_V(n_op,1)%g*conjg(OP_V(n_op,1)%g))) < 1.D-6 ) return + + ! Compute the ratio + nf = 1 + ns_old = nsigma(n_op,nt) + If ( Op_V(n_op,nf)%type == 1) then + ns_new = -ns_old + else + ns_new = NFLIPL(Ns_old,nranf(3)) + endif + Do nf = 1,N_FL + Z1 = Op_V(n_op,nf)%g * cmplx( Phi(ns_new,Op_V(n_op,nf)%type) - Phi(ns_old,Op_V(n_op,nf)%type), 0.d0) + Do m = 1,Op_V(n_op,nf)%N_non_zero + Z = exp( Z1* Op_V(n_op,nf)%E(m) ) - cmplx(1.d0,0.d0) + Delta(m,nf) = Z + do n = 1,Op_V(n_op,nf)%N_non_zero + ZK = cmplx(0.d0,0.d0) + If (n == m ) ZK = cmplx(1.d0,0.d0) + Mat(n , m ) = ZK + ( ZK - GR( Op_V(n_op,nf)%P(n), Op_V(n_op,nf)%P(m),nf )) * Z + Enddo + Enddo + If (Size(Mat,1) == 1 ) then + D_mat = Mat(1,1) + elseif (Size(Mat,1) == 2 ) then + D_mat = Mat(1,1)*Mat(2,2) - Mat(2,1)*Mat(1,2) + else + D_mat = Det(Mat,Size(Mat,1)) + endif + Ratio(nf) = D_Mat * exp( Z1*Op_V(n_op,nf)%alpha ) + Enddo + + Ratiotot = cmplx(1.d0,0.d0) + Do nf = 1,N_FL + Ratiotot = Ratiotot * Ratio(nf) + enddo + nf = 1 + Ratiotot = (Ratiotot**dble(N_SUN)) * cmplx(Gaml(ns_new, Op_V(n_op,nf)%type)/Gaml(ns_old, Op_V(n_op,nf)%type),0.d0) + Ratiotot = Ratiotot*cmplx(S0(n_op,nt),0.d0) + + + !Write(6,*) Ratiotot + + Weight = abs( real(Phase * Ratiotot, kind=double)/real(Phase,kind=double) ) + + Log = .false. + if ( Weight > ranf() ) Then + Log = .true. + Phase = Phase * Ratiotot/cmplx(weight,0.d0) + !Write(6,*) 'Accepted : ', Ratiotot + + Do nf = 1,N_FL + ! Setup u(i,n), v(n,i) + u = cmplx(0.d0,0.d0) + v = cmplx(0.d0,0.d0) + do n = 1,Op_V(n_op,nf)%N_non_zero + u( Op_V(n_op,nf)%P(n), n) = Delta(n,nf) + do i = 1,Ndim + v(i,n) = - GR( Op_V(n_op,nf)%P(n), i, nf ) + enddo + v(Op_V(n_op,nf)%P(n), n) = cmplx(1.d0,0.d0) - GR( Op_V(n_op,nf)%P(n), Op_V(n_op,nf)%P(n), nf) + enddo + + + x_v = cmplx(0.d0,0.d0) + y_v = cmplx(0.d0,0.d0) + i = Op_V(n_op,nf)%P(1) + x_v(i,1) = u(i,1)/(cmplx(1.d0,0.d0) + v(i,1)*u(i,1) ) + Do i = 1,Ndim + y_v(i,1) = v(i,1) + enddo + do n = 2,Op_V(n_op,nf)%N_non_zero + s_yu = cmplx(0.d0,0.d0) + s_xv = cmplx(0.d0,0.d0) + do m = 1,n-1 + do i = 1,Ndim + s_yu(m) = s_yu(m) + y_v(i,m)*u(i,n) + s_xv(m) = s_xv(m) + x_v(i,m)*v(i,n) + enddo + enddo + Do i = 1,Ndim + x_v(i,n) = u(i,n) + y_v(i,n) = v(i,n) + enddo + Z = cmplx(1.d0,0.d0) + u( Op_V(n_op,nf)%P(n), n)*v(Op_V(n_op,nf)%P(n),n) + do m = 1,n-1 + Z = Z - s_xv(m)*s_yu(m) + Do i = 1,Ndim + x_v(i,n) = x_v(i,n) - x_v(i,m)*s_yu(m) + y_v(i,n) = y_v(i,n) - y_v(i,m)*s_xv(m) + enddo + enddo + Do i = 1,Ndim + x_v(i,n) = x_v(i,n)/Z + Enddo + enddo + xp_v = cmplx(0.d0,0.d0) + do n = 1,Op_dim + do m = 1,Op_dim + j = Op_V(n_op,nf)%P(m) + do i = 1,Ndim + xp_v(i,n) = xp_v(i,n) + gr(i,j,nf)*x_v(j,n) + enddo + enddo + enddo + + do n = 1,Op_dim + do j = 1,Ndim + do i = 1,Ndim + gr(i,j,nf) = gr(i,j,nf) - xp_v(i,n)*y_v(j,n) + enddo + enddo + enddo + enddo + + ! Flip the spin + nsigma(n_op,nt) = ns_new + endif + + Call Control_upgrade(Log) + + + End Subroutine Upgrade diff --git a/src/Prog/wrapgrdo.f90 b/src/Prog/wrapgrdo.f90 new file mode 100644 index 000000000..a7f1c933d --- /dev/null +++ b/src/Prog/wrapgrdo.f90 @@ -0,0 +1,82 @@ + SUBROUTINE WRAPGRDO(GR,NTAU,PHASE) + + Use Hamiltonian + Use MyMats + Use Hop_mod + Implicit None + + Interface + Subroutine Upgrade(GR,N_op,NT,PHASE,Op_dim) + Use Hamiltonian + Implicit none + Complex (Kind=8) :: GR(Ndim,Ndim, N_FL) + Integer, INTENT(IN) :: N_op, Nt, Op_dim + Complex (Kind=8) :: Phase + End Subroutine Upgrade + End Interface + + ! Given GREEN at time NTAU => GREEN at time NTAU - 1, + ! Upgrade NTAU [LTROT:1] + + COMPLEX (Kind=8), INTENT(INOUT) :: GR(Ndim,Ndim,N_FL) + COMPLEX (Kind=8), INTENT(INOUT) :: PHASE + Integer :: NTAU + + ! Local + Complex (Kind=8) :: Mat_TMP(Ndim,Ndim) + Integer :: nf, N_Type, n, I,J + real (Kind=8) :: spin + + Do n = size(Op_V,1), 1, -1 + N_type = 2 + nf = 1 + spin = Phi(nsigma(n,ntau),Op_V(n,nf)%type) + do nf = 1,N_FL + Call Op_Wrapdo( Gr(:,:,nf), Op_V(n,nf), spin, Ndim, N_Type) + enddo + !Write(6,*) 'Upgrade : ', ntau,n + Call Upgrade(GR,n,ntau,PHASE,Op_V(n,1)%N_non_zero) + ! The spin has changed after the upgrade! + nf = 1 + spin = Phi(nsigma(n,ntau),Op_V(n,nf)%type) + N_type = 1 + do nf = 1,N_FL + Call Op_Wrapdo( Gr(:,:,nf), Op_V(n,nf), spin, Ndim, N_Type ) + enddo + enddo + DO nf = 1,N_FL + Call Hop_mod_mmthl (GR(:,:,nf), MAT_TMP, nf) + Call Hop_mod_mmthr_m1(MAT_TMP, GR(:,:,nf), nf) + !CALL MMULT(MAT_TMP , GR(:,:,nf) , Exp_T(:,:,nf) ) + !CALL MMULT(GR(:,:,nf), Exp_T_M1(:,:,nf), MAT_TMP ) + enddo + +!!$ ! Test +!!$ Mat_TMP = cmplx(0.d0,0.d0) +!!$ DO I = 1,Ndim +!!$ Mat_TMP(I,I) = cmplx(1.d0,0.d0) +!!$ Enddo +!!$ Do n = size(Op_V,1), 1, -1 +!!$ N_type = 2 +!!$ nf = 1 +!!$ spin = Phi(nsigma(n,ntau),Op_V(n,nf)%type) +!!$ Write(6,*) n, spin +!!$ do nf = 1,N_FL +!!$ Call Op_Wrapdo( Mat_tmp, Op_V(n,nf), spin, Ndim, N_Type) +!!$ enddo +!!$ !Upgrade +!!$ N_type = 1 +!!$ do nf = 1,N_FL +!!$ Call Op_Wrapdo( Mat_tmp, Op_V(n,nf), spin, Ndim, N_Type ) +!!$ enddo +!!$ enddo +!!$ +!!$ DO I = 1,Ndim +!!$ Do J = 1,NDIM +!!$ WRITE(6,*) I,J, Mat_tmp(I,J) +!!$ ENDDO +!!$ ENDDO +!!$ +!!$ STOP + + END SUBROUTINE WRAPGRDO diff --git a/src/Prog/wrapgrup.f90 b/src/Prog/wrapgrup.f90 new file mode 100644 index 000000000..cb5b9f1a6 --- /dev/null +++ b/src/Prog/wrapgrup.f90 @@ -0,0 +1,53 @@ + SUBROUTINE WRAPGRUP(GR,NTAU,PHASE) + + Use Hamiltonian + Use Hop_mod + Implicit none + + Interface + Subroutine Upgrade(GR,N_op,NT,PHASE,Op_dim) + Use Hamiltonian + Implicit none + Complex (Kind=8) :: GR(Ndim,Ndim, N_FL) + Integer, INTENT(IN) :: N_op, Nt, Op_dim + Complex (Kind=8) :: Phase + End Subroutine Upgrade + End Interface + + ! Given GRUP at time NTAU => GRUP at time NTAU + 1. + ! Upgrade NTAU + 1 NTAU: [0:LTROT-1] + + ! Arguments + COMPLEX (Kind=8), INTENT(INOUT) :: GR(Ndim,Ndim,N_FL) + COMPLEX (Kind=8), INTENT(INOUT) :: PHASE + INTEGER, INTENT(IN) :: NTAU + + !Local + Integer :: nf, N_Type, NTAU1,n + Complex (Kind=8) :: Mat_TMP(Ndim,Ndim) + Real (Kind=8) :: X + + ! Wrap up, upgrade ntau1. with B^{1}(tau1) + NTAU1 = NTAU + 1 + Do nf = 1,N_FL + CALL HOP_MOD_mmthr( GR(:,:,nf), MAT_TMP,nf) + CALL HOP_MOD_mmthl_m1(MAT_TMP,GR(:,:,nf), nf ) + !CALL MMULT ( MAT_TMP, Exp_T(:,:,nf), GR(:,:,nf) ) + !CALL MMULT ( GR(:,:,nf), MAT_TMP , Exp_T_M1(:,:,nf) ) + Enddo + Do n = 1,Size(Op_V,1) + Do nf = 1, N_FL + X = Phi(nsigma(n,ntau1),Op_V(n,nf)%type) + N_type = 1 + Call Op_Wrapup(Gr(:,:,nf),Op_V(n,nf),X,Ndim,N_Type) + enddo + nf = 1 + !Write(6,*) 'Upgrade: ', ntau1,n + Call Upgrade(GR,N,ntau1,PHASE,Op_V(n,nf)%N_non_Zero) + do nf = 1,N_FL + N_type = 2 + Call Op_Wrapup(Gr(:,:,nf),Op_V(n,nf),X,Ndim,N_Type) + enddo + Enddo + + END SUBROUTINE WRAPGRUP diff --git a/src/Prog/wrapul.f90 b/src/Prog/wrapul.f90 new file mode 100644 index 000000000..8d93cb17c --- /dev/null +++ b/src/Prog/wrapul.f90 @@ -0,0 +1,77 @@ + SUBROUTINE WRAPUL(NTAU1, NTAU, UL ,DL, VL) + + !Given B(LTROT,NTAU1,Nf ) = VLUP, DLUP, ULUP + !Returns B(LTROT,NTAU, Nf ) = VLUP, DLUP, ULUP + + + !NOTE: NTAU1 > NTAU. + ! Does this for all replicas + Use Hamiltonian + Use Hop_mod + Use UDV_Wrap_mod + + Implicit none + + ! Arguments + COMPLEX (KIND=8) :: UL(Ndim,Ndim,N_FL), VL(Ndim,Ndim,N_FL) + COMPLEX (KIND=8) :: DL(Ndim,N_FL) + Integer :: NTAU1, NTAU + + + ! Working space. + COMPLEX (Kind=8) :: U(Ndim,Ndim), U1(Ndim,Ndim), V1(Ndim,Ndim), TMP(Ndim,Ndim), TMP1(Ndim,Ndim) + COMPLEX (Kind=8) :: D1(Ndim), Z_ONE + Integer :: I, J, NT, NCON, nr, n, nf + Real (Kind=8) :: X + + + + NCON = 0 ! Test for UDV :::: 0: Off, 1: On. + + Z_ONE = cmplx(1.d0,0.d0) + Do nf = 1, N_FL + CALL INITD(TMP,Z_ONE) + DO NT = NTAU1, NTAU+1 , -1 + Do n = Size(Op_V,1),1,-1 + X = Phi(nsigma(n,nt),Op_V(n,nf)%type) + Call Op_mmultL(Tmp,Op_V(n,nf),X,Ndim) + enddo + !CALL MMULT( TMP1,Tmp,Exp_T(:,:,nf) ) + Call Hop_mod_mmthl (Tmp, Tmp1,nf) + Tmp = Tmp1 + ENDDO + + !Carry out U,D,V decomposition. + DO J = 1,NDim + DO I = 1,NDim + TMP1(I,J) = CONJG( TMP(J,I) ) + U (I,J) = CONJG( UL (J,I,nf) ) + ENDDO + ENDDO + CALL MMULT(TMP,TMP1,U) + DO J = 1,NDim + DO I = 1,NDim + TMP(I,J) = TMP(I,J)*DL(J,nf) + ENDDO + ENDDO + CALL UDV_WRAP(TMP,U1,D1,V1,NCON) + !CALL UDV(TMP,U1,D1,V1,NCON) + DO J = 1,NDim + DO I = 1,NDim + UL (I,J,nf) = CONJG( U1(J,I) ) + TMP(I,J) = CONJG( V1(J,I) ) + ENDDO + ENDDO + CALL MMULT(TMP1,VL(:,:,nf),TMP) + DO J = 1,NDim + DO I = 1,NDim + VL(I,J,nf) = TMP1(I,J) + ENDDO + ENDDO + DO I = 1,NDim + DL(I,nf) = D1(I) + ENDDO + ENDDO + + END SUBROUTINE WRAPUL + diff --git a/src/Prog/wrapur.f90 b/src/Prog/wrapur.f90 new file mode 100644 index 000000000..c53b28ce3 --- /dev/null +++ b/src/Prog/wrapur.f90 @@ -0,0 +1,48 @@ + SUBROUTINE WRAPUR(NTAU, NTAU1, UR, DR, VR) + + ! Given B(NTAU, 1 ) = UR, DR, VR + ! Returns B(NTAU1, 1 ) = UR, DR, VR + ! NOTE: NTAU1 > NTAU. + + Use Hamiltonian + Use UDV_Wrap_mod + Use Hop_mod + Implicit None + + ! Arguments + COMPLEX (KIND=8) :: UR(Ndim,Ndim,N_FL), VR(Ndim,Ndim,N_FL) + COMPLEX (KIND=8) :: DR(Ndim,N_FL) + Integer :: NTAU1, NTAU + + + ! Working space. + Complex (Kind=8) :: Z_ONE + COMPLEX (Kind=8) :: V1(Ndim,Ndim), TMP(Ndim,Ndim), TMP1(Ndim,Ndim) + Integer ::NCON, NT, I, J, n, nf + Real (Kind=8) :: X + + NCON = 0 ! Test for UDV :::: 0: Off, 1: On. + Z_ONE = cmplx(1.d0,0.d0) + + Do nf = 1,N_FL + CALL INITD(TMP,Z_ONE) + DO NT = NTAU + 1, NTAU1 + !CALL MMULT(TMP1,Exp_T(:,:,nf) ,TMP) + Call Hop_mod_mmthr(TMP,TMP1,nf) + TMP = TMP1 + Do n = 1,Size(Op_V,1) + X = Phi(nsigma(n,nt),Op_V(n,nf)%type) + Call Op_mmultR(Tmp,Op_V(n,nf),X,Ndim) + ENDDO + ENDDO + CALL MMULT(TMP1,TMP,UR(:,:,nf)) + DO J = 1,NDim + DO I = 1,NDim + TMP1(I,J) = TMP1(I,J)*DR(J,nf) + TMP(I,J) = VR(I,J,nf) + ENDDO + ENDDO + CALL UDV_WRAP(TMP1,UR(:,:,nf),DR(:,nf),V1,NCON) + CALL MMULT(VR(:,:,nf),V1,TMP) + ENDDO + END SUBROUTINE WRAPUR From f24564b2cce7e6328d16d4702ac614c6b4a20d07 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Wed, 1 Jun 2016 20:07:07 +0200 Subject: [PATCH 03/11] add relevant cmake infrastructure. --- src/Modules/Compile | 13 ------------- src/Modules/Makefile | 15 --------------- src/Modules/Makefile_Juropa | 15 --------------- src/Modules/Makefile_cl | 14 -------------- src/Modules/pre1 | 12 ------------ 5 files changed, 69 deletions(-) delete mode 100644 src/Modules/Compile delete mode 100644 src/Modules/Makefile delete mode 100644 src/Modules/Makefile_Juropa delete mode 100644 src/Modules/Makefile_cl delete mode 100644 src/Modules/pre1 diff --git a/src/Modules/Compile b/src/Modules/Compile deleted file mode 100644 index b602a560e..000000000 --- a/src/Modules/Compile +++ /dev/null @@ -1,13 +0,0 @@ -OBJS=mat_mod.o Random_Wrap.o errors.o Files_mod.o maxent.o matrix.o maxent_stoch.o fourier.o \ - Histogram.o lattices_v3.o Natural_constants.o log_mesh.o precdef.mod.o \ - Histogram_v2.o - -$(LIB): $(OBJS) - ar -r $(LIB) $(OBJS) - -.SUFFIXES: .f90 -.f90.o: - $(FC) $(SUFFIX) $(FLAGS) $< - -clean: - rm $(OBJS) diff --git a/src/Modules/Makefile b/src/Modules/Makefile deleted file mode 100644 index da09025d1..000000000 --- a/src/Modules/Makefile +++ /dev/null @@ -1,15 +0,0 @@ -#FC= $(f90) -#FC= mpxlf90 -#FLAGS= -c -q64 -O4 -#FLAGS= -c -O3 -fbounds-check -FLAGS= -c -O3 -SUFFIX= -qsuffix=f=f90 -LF= -LIB=modules_90.a - -all: - (make -f Compile FC="$(FC)" FLAGS="$(FLAGS)" LIB="$(LIB)" ) - -clean: - (make -f Compile clean ) ;\ - rm *.mod *~ \#* diff --git a/src/Modules/Makefile_Juropa b/src/Modules/Makefile_Juropa deleted file mode 100644 index fb198fdf5..000000000 --- a/src/Modules/Makefile_Juropa +++ /dev/null @@ -1,15 +0,0 @@ -FC= ifort -#FC= mpxlf90 -#FLAGS= -c -q64 -O4 -#FLAGS= -c -O1 -pg -FLAGS= -c -O3 -SUFFIX= -qsuffix=f=f90 -LF= -warn all -LIB=modules_90.a - -all: - (make -f Compile FC="$(FC)" FLAGS="$(FLAGS)" LIB="$(LIB)" ) - -clean: - (make -f Compile clean ) ;\ - rm *.mod diff --git a/src/Modules/Makefile_cl b/src/Modules/Makefile_cl deleted file mode 100644 index 624f8fd2e..000000000 --- a/src/Modules/Makefile_cl +++ /dev/null @@ -1,14 +0,0 @@ -FC= ifort -#FC= mpxlf90 -#FLAGS= -c -q64 -O4 -FLAGS= -c -O3 -SUFFIX= -qsuffix=f=f90 -LF= -LIB=modules_90.a - -all: - (make -f Compile FC="$(FC)" FLAGS="$(FLAGS)" LIB="$(LIB)" ) - -clean: - (make -f Compile clean ) ;\ - rm *.mod *~ \#* diff --git a/src/Modules/pre1 b/src/Modules/pre1 deleted file mode 100644 index 38a649688..000000000 --- a/src/Modules/pre1 +++ /dev/null @@ -1,12 +0,0 @@ -PRE = cpp -PREF = -P -OBJ= maxent_stoch.f90 - -all: $(OBJ) - -.SUFFIXES: .G90 .f90 -.G90.f90: - $(PRE) $(PREF) $? $@ - -clean: - rm $(OBJ) From 53af1103c55443e5d3b5f851a59a3fe7cc1bb544 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Wed, 1 Jun 2016 20:12:13 +0200 Subject: [PATCH 04/11] Add missing files. --- CMakeLists.txt | 89 +++++++++++++++++++++++++++++++++++++++++++++++++ distclean.cmake | 68 +++++++++++++++++++++++++++++++++++++ 2 files changed, 157 insertions(+) create mode 100644 CMakeLists.txt create mode 100644 distclean.cmake diff --git a/CMakeLists.txt b/CMakeLists.txt new file mode 100644 index 000000000..eb5186731 --- /dev/null +++ b/CMakeLists.txt @@ -0,0 +1,89 @@ +# CMake project file for General QMCT + +################################################## +# Define the project and the depencies that it has +################################################## + +CMAKE_MINIMUM_REQUIRED(VERSION 2.8.5) +PROJECT(General_QMCT Fortran) + +# Set the General QMCT version +SET(VERSION 1.0) + +# Add our local modlues to the module path +SET(CMAKE_MODULE_PATH "${CMAKE_SOURCE_DIR}/cmake/Modules/") + +# Uncomment if it is required that Fortran 90 is supported +IF(NOT CMAKE_Fortran_COMPILER_SUPPORTS_F90) + MESSAGE(FATAL_ERROR "Fortran compiler does not support F90") +ENDIF(NOT CMAKE_Fortran_COMPILER_SUPPORTS_F90) + +# Set some options the user may choose +# Uncomment the below if you want the user to choose a parallelization library +OPTION(USE_MPI "Use the MPI library for parallelization" OFF) +#OPTION(USE_OPENMP "Use OpenMP for parallelization" OFF) + +# This INCLUDE statement executes code that sets the compile flags for DEBUG, +# RELEASE, and TESTING. You should review this file and make sure the flags +# are to your liking. +INCLUDE(${CMAKE_MODULE_PATH}/SetFortranFlags.cmake) +# Locate and set parallelization libraries. There are some CMake peculiarities +# taken care of here, such as the fact that the FindOpenMP routine doesn't know +# about Fortran. +INCLUDE(${CMAKE_MODULE_PATH}/SetParallelizationLibrary.cmake) +# Setup the LAPACK libraries. This also takes care of peculiarities, such as +# the fact the searching for MKL requires a C compiler, and that the results +# are not stored in the cache. +INCLUDE(${CMAKE_MODULE_PATH}/SetUpLAPACK.cmake) + +# There is an error in CMAKE with this flag for pgf90. Unset it +GET_FILENAME_COMPONENT(FCNAME ${CMAKE_Fortran_COMPILER} NAME) +IF(FCNAME STREQUAL "pgf90") + UNSET(CMAKE_SHARED_LIBRARY_LINK_Fortran_FLAGS) +ENDIF(FCNAME STREQUAL "pgf90") + +############################################################ +# Define the actual files and folders that make up the build +############################################################ + +# Define the executable name +SET(PROGEXE qmct) +SET(BLA_STATIC TRUE) + +#SET(CMAKE_AR gcc-ar) +#SET(CMAKE_RANLIB gcc-ranlib) + +# Define some directories +SET(SRC ${CMAKE_SOURCE_DIR}/src) +SET(LIB ${CMAKE_SOURCE_DIR}/lib) +SET(BIN ${CMAKE_SOURCE_DIR}/bin) + +# Define the library names +SET(MODULES modules) +SET(MYEIS myeis) +SET(MYNAG mynag) +SET(MYLIN mylin) + +SET(SRCMODULES ${SRC}/Modules) +SET(SRCEIS ${SRC}/MyEis) +SET(SRCNAG ${SRC}/MyNag) +SET(SRCLIN ${SRC}/MyLin) +SET(SRCPROG ${SRC}/Prog) + +# Have the .mod files placed in the lib folder +SET(CMAKE_Fortran_MODULE_DIRECTORY ${LIB}) + +# The sources for the libraries and have it placed in the lib folder +ADD_SUBDIRECTORY(${SRCMODULES} ${LIB}/Modules) +ADD_SUBDIRECTORY(${SRCEIS} ${LIB}/MyEis) + +ADD_SUBDIRECTORY(${SRCNAG} ${LIB}/MyNAG) +ADD_SUBDIRECTORY(${SRCLIN} ${LIB}/MyLin) + +# The source for the FOO binary and have it placed in the bin folder +ADD_SUBDIRECTORY(${SRCPROG} ${BIN}) + +# Add a distclean target to the Makefile +ADD_CUSTOM_TARGET(distclean + COMMAND ${CMAKE_COMMAND} -P ${CMAKE_SOURCE_DIR}/distclean.cmake +) diff --git a/distclean.cmake b/distclean.cmake new file mode 100644 index 000000000..8e24f9e49 --- /dev/null +++ b/distclean.cmake @@ -0,0 +1,68 @@ +# This CMake script will delete build directories and files to bring the +# package back to it's distribution state + +# We want to start from the top of the source dir, so if we are in build +# we want to start one directory up +GET_FILENAME_COMPONENT(BASEDIR ${CMAKE_SOURCE_DIR} NAME) +IF(${BASEDIR} STREQUAL "build") + SET(TOPDIR "${CMAKE_SOURCE_DIR}/..") +ELSE() + SET(TOPDIR "${CMAKE_SOURCE_DIR}") +ENDIF() + +MACRO(GET_PARENT_DIRECTORIES search_string return_list grandparents) + FILE(GLOB_RECURSE new_list ${search_string}) + SET(dir_list "") + FOREACH(file_path ${new_list}) + GET_FILENAME_COMPONENT(dir_path ${file_path} PATH) + # Remove an extra directory component to return grandparent + IF(${grandparents}) + # Tack on a fake extension to trick CMake into removing a second + # path component + SET(dir_path "${dir_path}.tmp") + GET_FILENAME_COMPONENT(dir_path ${dir_path} PATH) + ENDIF(${grandparents}) + SET(dir_list ${dir_list} ${dir_path}) + ENDFOREACH() + LIST(REMOVE_DUPLICATES dir_list) + SET(${return_list} ${dir_list}) +ENDMACRO() + +# Find directories and files that we will want to remove +FILE(GLOB_RECURSE CMAKECACHE "${TOPDIR}/*CMakeCache.txt") +FILE(GLOB_RECURSE CMAKEINSTALL "${TOPDIR}/*cmake_install.cmake" + "${TOPDIR}/*install_manifest.txt") +FILE(GLOB_RECURSE MAKEFILE "${TOPDIR}/*Makefile") +FILE(GLOB_RECURSE CMAKETESTFILES "${TOPDIR}/*CTestTestfile.cmake") +SET(TOPDIRECTORIES "${TOPDIR}/lib" + "${TOPDIR}/test" + "${TOPDIR}/bin" +) + +# CMake has trouble finding directories recursively, so locate these +# files and then save the parent directory of the files +GET_PARENT_DIRECTORIES(Makefile.cmake CMAKEFILES 0) +GET_PARENT_DIRECTORIES(LastTest.log CMAKETESTING 1) + +# Place these files and directories into a list +SET(DEL ${TOPDIRECTORIES} + ${CMAKECACHE} + ${CMAKEINSTALL} + ${MAKEFILE} + ${CMAKEFILES} + ${CMAKETESTING} + ${CMAKETESTFILES} +) + +# If we are not in the build dir, delete that as well +IF(NOT (${BASEDIR} STREQUAL "build")) + FILE(GLOB BUILD "${TOPDIR}/build") + SET(DEL ${DEL} ${BUILD}) +ENDIF() + +# Loop over the directories and delete each one +FOREACH(D ${DEL}) + IF(EXISTS ${D}) + FILE(REMOVE_RECURSE ${D}) + ENDIF() +ENDFOREACH() From 7f5fdbb1b77c693e14dbcc427a7f31850623fddd Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Wed, 1 Jun 2016 20:30:35 +0200 Subject: [PATCH 05/11] cmakify the analysis tools. --- src/Analysis/CMakeLists.txt | 8 ++++++++ src/Analysis/Compile_cov | 14 -------------- src/Analysis/Compile_en | 14 -------------- src/Analysis/Compile_eq | 14 -------------- src/Analysis/Makefile | 19 ------------------- src/Analysis/{cov_eq.f90 => cov_eq.F90} | 0 6 files changed, 8 insertions(+), 61 deletions(-) create mode 100644 src/Analysis/CMakeLists.txt delete mode 100644 src/Analysis/Compile_cov delete mode 100644 src/Analysis/Compile_en delete mode 100644 src/Analysis/Compile_eq delete mode 100644 src/Analysis/Makefile rename src/Analysis/{cov_eq.f90 => cov_eq.F90} (100%) diff --git a/src/Analysis/CMakeLists.txt b/src/Analysis/CMakeLists.txt new file mode 100644 index 000000000..76d395f25 --- /dev/null +++ b/src/Analysis/CMakeLists.txt @@ -0,0 +1,8 @@ +add_executable(jackv5 jackv5.f90) +add_executable(cov_eq cov_eq.F90) +add_executable(cov_tau cov_tau.f90) + +foreach(analysisbinary jackv5 cov_eq cov_tau) +target_link_libraries(${analysisbinary} ${MODULES} ${MYEIS} ${MYNAG} ${MYLIN}) +target_link_libraries(${analysisbinary} ${BLAS_LIBRARIES} ${LAPACK_LIBRARIES} ${CMAKE_THREAD_LIBS_INIT}) +endforeach() diff --git a/src/Analysis/Compile_cov b/src/Analysis/Compile_cov deleted file mode 100644 index d3643a78f..000000000 --- a/src/Analysis/Compile_cov +++ /dev/null @@ -1,14 +0,0 @@ -TARGET= cov_tau.out -OBJS= cov_tau.o - - -.SUFFIXES: .f90 .f -.f.o .f90.o: - $(FC) -c -cpp -o $@ $(FLAGS) $< - -$(TARGET): $(OBJS) - $(FC) $(LF) -o $(TARGET) $(OBJS) $(LIBS) - -clean: - rm $(OBJS) - diff --git a/src/Analysis/Compile_en b/src/Analysis/Compile_en deleted file mode 100644 index 8767339d4..000000000 --- a/src/Analysis/Compile_en +++ /dev/null @@ -1,14 +0,0 @@ -TARGET= jackv5.out -OBJS= jackv5.o - - -.SUFFIXES: .f90 .f -.f.o .f90.o: - $(FC) -c -cpp -o $@ $(FLAGS) $< - -$(TARGET): $(OBJS) - $(FC) $(LF) -o $(TARGET) $(OBJS) $(LIBS) - -clean: - rm $(OBJS) - diff --git a/src/Analysis/Compile_eq b/src/Analysis/Compile_eq deleted file mode 100644 index 9613a2271..000000000 --- a/src/Analysis/Compile_eq +++ /dev/null @@ -1,14 +0,0 @@ -TARGET= cov_eq.out -OBJS= cov_eq.o - - -.SUFFIXES: .f90 .f -.f.o .f90.o: - $(FC) -c -cpp -o $@ $(FLAGS) $< - -$(TARGET): $(OBJS) - $(FC) $(LF) -o $(TARGET) $(OBJS) $(LIBS) - -clean: - rm $(OBJS) - diff --git a/src/Analysis/Makefile b/src/Analysis/Makefile deleted file mode 100644 index c92c401c8..000000000 --- a/src/Analysis/Makefile +++ /dev/null @@ -1,19 +0,0 @@ -FC= $(mpif90) -FC= $(f90) -FLAGS= $(FL) -LIBS= $(Libs)/Modules/modules_90.a \ - $(Libs)/MyEis/libeis.a \ - $(Libs)/MyNag/libnag.a \ - $(Libs)/MyLin/liblin.a \ - $(LIB_BLAS_LAPACK) - -all: - cp $(Libs)/Modules/*.mod . ;\ - (make -f Compile_en FC="$(FC)" FLAGS="$(FLAGS)" LIBS="$(LIBS)" ) ;\ - (make -f Compile_cov FC="$(FC)" FLAGS="$(FLAGS)" LIBS="$(LIBS)" ) ;\ - (make -f Compile_eq FC="$(FC)" FLAGS="$(FLAGS)" LIBS="$(LIBS)" ) -clean: - (make -f Compile_eq clean );\ - (make -f Compile_cov clean );\ - (make -f Compile_en clean );\ - rm *.mod *~ \#* *.out diff --git a/src/Analysis/cov_eq.f90 b/src/Analysis/cov_eq.F90 similarity index 100% rename from src/Analysis/cov_eq.f90 rename to src/Analysis/cov_eq.F90 From fb7e1e83946e2ca7c9a07a3b2dcdd47c660de5a6 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Wed, 1 Jun 2016 20:33:45 +0200 Subject: [PATCH 06/11] Add the Analysis tools to our main file. --- CMakeLists.txt | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CMakeLists.txt b/CMakeLists.txt index eb5186731..172c23aea 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -69,6 +69,7 @@ SET(SRCEIS ${SRC}/MyEis) SET(SRCNAG ${SRC}/MyNag) SET(SRCLIN ${SRC}/MyLin) SET(SRCPROG ${SRC}/Prog) +SET(SRCANALYSIS ${SRC}/Analysis) # Have the .mod files placed in the lib folder SET(CMAKE_Fortran_MODULE_DIRECTORY ${LIB}) @@ -82,6 +83,7 @@ ADD_SUBDIRECTORY(${SRCLIN} ${LIB}/MyLin) # The source for the FOO binary and have it placed in the bin folder ADD_SUBDIRECTORY(${SRCPROG} ${BIN}) +ADD_SUBDIRECTORY(${SRCANALYSIS} ${BIN}/Analysis) # Add a distclean target to the Makefile ADD_CUSTOM_TARGET(distclean From f993ec9ca89be6a1815644e9f7bf54f2c39ae60d Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Wed, 1 Jun 2016 20:41:25 +0200 Subject: [PATCH 07/11] Add missing files --- cmake/Modules/FindOpenMP_Fortran.cmake | 106 ++++++++++ cmake/Modules/SetCompileFlag.cmake | 112 +++++++++++ cmake/Modules/SetFortranFlags.cmake | 185 ++++++++++++++++++ cmake/Modules/SetParallelizationLibrary.cmake | 39 ++++ cmake/Modules/SetUpLAPACK.cmake | 11 ++ 5 files changed, 453 insertions(+) create mode 100644 cmake/Modules/FindOpenMP_Fortran.cmake create mode 100644 cmake/Modules/SetCompileFlag.cmake create mode 100644 cmake/Modules/SetFortranFlags.cmake create mode 100644 cmake/Modules/SetParallelizationLibrary.cmake create mode 100644 cmake/Modules/SetUpLAPACK.cmake diff --git a/cmake/Modules/FindOpenMP_Fortran.cmake b/cmake/Modules/FindOpenMP_Fortran.cmake new file mode 100644 index 000000000..bca09d058 --- /dev/null +++ b/cmake/Modules/FindOpenMP_Fortran.cmake @@ -0,0 +1,106 @@ +# - Finds OpenMP support +# This module can be used to detect OpenMP support in a compiler. +# If the compiler supports OpenMP, the flags required to compile with +# openmp support are set. +# +# This module was modified from the standard FindOpenMP module to find Fortran +# flags. +# +# The following variables are set: +# OpenMP_Fortran_FLAGS - flags to add to the Fortran compiler for OpenMP +# support. In general, you must use these at both +# compile- and link-time. +# OMP_NUM_PROCS - the max number of processors available to OpenMP + +#============================================================================= +# Copyright 2009 Kitware, Inc. +# Copyright 2008-2009 André Rigland Brodtkorb +# +# Distributed under the OSI-approved BSD License (the "License"); +# see accompanying file Copyright.txt for details. +# +# This software is distributed WITHOUT ANY WARRANTY; without even the +# implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +# See the License for more information. +#============================================================================= +# (To distribute this file outside of CMake, substitute the full +# License text for the above reference.) + +INCLUDE (${CMAKE_ROOT}/Modules/FindPackageHandleStandardArgs.cmake) + +SET (OpenMP_Fortran_FLAG_CANDIDATES + #Microsoft Visual Studio + "/openmp" + #Intel windows + "/Qopenmp" + #Intel + "-openmp" + # Intel 16+ + "-qopenmp" + #Gnu + "-fopenmp" + #Empty, if compiler automatically accepts openmp + " " + #Sun + "-xopenmp" + #HP + "+Oopenmp" + #IBM XL C/c++ + "-qsmp" + #Portland Group + "-mp" +) + +IF (DEFINED OpenMP_Fortran_FLAGS) + SET (OpenMP_Fortran_FLAG_CANDIDATES) +ENDIF (DEFINED OpenMP_Fortran_FLAGS) + +# check fortran compiler. also determine number of processors +FOREACH (FLAG ${OpenMP_Fortran_FLAG_CANDIDATES}) + SET (SAFE_CMAKE_REQUIRED_FLAGS "${CMAKE_REQUIRED_FLAGS}") + SET (CMAKE_REQUIRED_FLAGS "${FLAG}") + UNSET (OpenMP_FLAG_DETECTED CACHE) + MESSAGE (STATUS "Try OpenMP Fortran flag = [${FLAG}]") + FILE (WRITE "${CMAKE_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/CMakeTmp/testFortranOpenMP.f90" +" +program TestOpenMP + use omp_lib + write(*,'(I2)',ADVANCE='NO') omp_get_num_procs() +end program TestOpenMP +") + SET (MACRO_CHECK_FUNCTION_DEFINITIONS + "-DOpenMP_FLAG_DETECTED ${CMAKE_REQUIRED_FLAGS}") + TRY_RUN (OpenMP_RUN_FAILED OpenMP_FLAG_DETECTED ${CMAKE_BINARY_DIR} + ${CMAKE_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/CMakeTmp/testFortranOpenMP.f90 + COMPILE_DEFINITIONS ${CMAKE_REQUIRED_DEFINITIONS} + CMAKE_FLAGS -DCOMPILE_DEFINITIONS:STRING=${MACRO_CHECK_FUNCTION_DEFINITIONS} + COMPILE_OUTPUT_VARIABLE OUTPUT + RUN_OUTPUT_VARIABLE OMP_NUM_PROCS_INTERNAL) + IF (OpenMP_FLAG_DETECTED) + FILE (APPEND ${CMAKE_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/CMakeOutput.log + "Determining if the Fortran compiler supports OpenMP passed with " + "the following output:\n${OUTPUT}\n\n") + SET (OpenMP_FLAG_DETECTED 1) + IF (OpenMP_RUN_FAILED) + MESSAGE (FATAL_ERROR "OpenMP found, but test code did not run") + ENDIF (OpenMP_RUN_FAILED) + SET (OMP_NUM_PROCS ${OMP_NUM_PROCS_INTERNAL} CACHE + STRING "Number of processors OpenMP may use" FORCE) + SET (OpenMP_Fortran_FLAGS_INTERNAL "${FLAG}") + BREAK () + ELSE () + FILE (APPEND ${CMAKE_BINARY_DIR}${CMAKE_FILES_DIRECTORY}/CMakeError.log + "Determining if the Fortran compiler supports OpenMP failed with " + "the following output:\n${OUTPUT}\n\n") + SET (OpenMP_FLAG_DETECTED 0) + ENDIF (OpenMP_FLAG_DETECTED) +ENDFOREACH (FLAG ${OpenMP_Fortran_FLAG_CANDIDATES}) + +SET (OpenMP_Fortran_FLAGS "${OpenMP_Fortran_FLAGS_INTERNAL}" + CACHE STRING "Fortran compiler flags for OpenMP parallization") + +# handle the standard arguments for FIND_PACKAGE +FIND_PACKAGE_HANDLE_STANDARD_ARGS (OpenMP_Fortran DEFAULT_MSG + OpenMP_Fortran_FLAGS) + +MARK_AS_ADVANCED(OpenMP_Fortran_FLAGS) diff --git a/cmake/Modules/SetCompileFlag.cmake b/cmake/Modules/SetCompileFlag.cmake new file mode 100644 index 000000000..04ff3ffbd --- /dev/null +++ b/cmake/Modules/SetCompileFlag.cmake @@ -0,0 +1,112 @@ +############################################################################# +# Given a list of flags, this function will try each, one at a time, +# and choose the first flag that works. If no flags work, then nothing +# will be set, unless the REQUIRED key is given, in which case an error +# will be given. +# +# Call is: +# SET_COMPILE_FLAG(FLAGVAR FLAGVAL (Fortran|C|CXX) flag1 flag2...) +# +# For example, if you have the flag CMAKE_C_FLAGS and you want to add +# warnings and want to fail if this is not possible, you might call this +# function in this manner: +# SET_COMPILE_FLAGS(CMAKE_C_FLAGS "${CMAKE_C_FLAGS}" C REQUIRED +# "-Wall" # GNU +# "-warn all" # Intel +# ) +# The optin "-Wall" will be checked first, and if it works, will be +# appended to the CMAKE_C_FLAGS variable. If it doesn't work, then +# "-warn all" will be tried. If this doesn't work then checking will +# terminate because REQUIRED was given. +# +# The reasong that the variable must be given twice (first as the name then +# as the value in quotes) is because of the way CMAKE handles the passing +# of variables in functions; it is difficult to extract a variable's +# contents and assign new values to it from within a function. +############################################################################# + +INCLUDE(${CMAKE_ROOT}/Modules/CheckCCompilerFlag.cmake) +INCLUDE(${CMAKE_ROOT}/Modules/CheckCXXCompilerFlag.cmake) + +FUNCTION(SET_COMPILE_FLAG FLAGVAR FLAGVAL LANG) + + # Do some up front setup if Fortran + IF(LANG STREQUAL "Fortran") + # Create a list of error messages from compilers + SET(FAIL_REGEX + "ignoring unknown option" # Intel + "invalid argument" # Intel + "unrecognized .*option" # GNU + "[Uu]nknown switch" # Portland Group + "ignoring unknown option" # MSVC + "warning D9002" # MSVC, any lang + "[Uu]nknown option" # HP + "[Ww]arning: [Oo]ption" # SunPro + "command option .* is not recognized" # XL + ) + ENDIF(LANG STREQUAL "Fortran") + + # Make a variable holding the flags. Filter out REQUIRED if it is there + SET(FLAG_REQUIRED FALSE) + SET(FLAG_FOUND FALSE) + UNSET(FLAGLIST) + FOREACH (var ${ARGN}) + STRING(TOUPPER "${var}" UP) + IF(UP STREQUAL "REQUIRED") + SET(FLAG_REQUIRED TRUE) + ELSE() + SET(FLAGLIST ${FLAGLIST} "${var}") + ENDIF(UP STREQUAL "REQUIRED") + ENDFOREACH (var ${ARGN}) + + # Now, loop over each flag + FOREACH(flag ${FLAGLIST}) + + UNSET(FLAG_WORKS) + # Check the flag for the given language + IF(LANG STREQUAL "C") + CHECK_C_COMPILER_FLAG("${flag}" FLAG_WORKS) + ELSEIF(LANG STREQUAL "CXX") + CHECK_CXX_COMPILER_FLAG("${flag}" FLAG_WORKS) + ELSEIF(LANG STREQUAL "Fortran") + # There is no nice function to do this for FORTRAN, so we must manually + # create a test program and check if it compiles with a given flag. + SET(TESTFILE "${CMAKE_BINARY_DIR}${CMAKE_FILES_DIRECTORY}") + SET(TESTFILE "${TESTFILE}/CMakeTmp/testFortranFlags.f90") + FILE(WRITE "${TESTFILE}" +" +program dummyprog + i = 5 +end program dummyprog +") + TRY_COMPILE(FLAG_WORKS ${CMAKE_BINARY_DIR} ${TESTFILE} + COMPILE_DEFINITIONS "${flag}" OUTPUT_VARIABLE OUTPUT) + + # Check that the output message doesn't match any errors + FOREACH(rx ${FAIL_REGEX}) + IF("${OUTPUT}" MATCHES "${rx}") + SET(FLAG_WORKS FALSE) + ENDIF("${OUTPUT}" MATCHES "${rx}") + ENDFOREACH(rx ${FAIL_REGEX}) + + ELSE() + MESSAGE(FATAL_ERROR "Unknown language in SET_COMPILE_FLAGS: ${LANG}") + ENDIF(LANG STREQUAL "C") + + # If this worked, use these flags, otherwise use other flags + IF(FLAG_WORKS) + # Append this flag to the end of the list that already exists + SET(${FLAGVAR} "${FLAGVAL} ${flag}" CACHE STRING + "Set the ${FLAGVAR} flags" FORCE) + SET(FLAG_FOUND TRUE) + BREAK() # We found something that works, so exit + ENDIF(FLAG_WORKS) + + ENDFOREACH(flag ${FLAGLIST}) + + # Raise an error if no flag was found + IF(FLAG_REQUIRED AND NOT FLAG_FOUND) + MESSAGE(FATAL_ERROR "No compile flags were found") + ENDIF(FLAG_REQUIRED AND NOT FLAG_FOUND) + +ENDFUNCTION() diff --git a/cmake/Modules/SetFortranFlags.cmake b/cmake/Modules/SetFortranFlags.cmake new file mode 100644 index 000000000..ae1eb702b --- /dev/null +++ b/cmake/Modules/SetFortranFlags.cmake @@ -0,0 +1,185 @@ +###################################################### +# Determine and set the Fortran compiler flags we want +###################################################### + +#################################################################### +# Make sure that the default build type is RELEASE if not specified. +#################################################################### +INCLUDE(${CMAKE_MODULE_PATH}/SetCompileFlag.cmake) + +# Make sure the build type is uppercase +STRING(TOUPPER "${CMAKE_BUILD_TYPE}" BT) + +IF(BT STREQUAL "RELEASE") + SET(CMAKE_BUILD_TYPE RELEASE CACHE STRING + "Choose the type of build, options are DEBUG, RELEASE, or TESTING." + FORCE) +ELSEIF(BT STREQUAL "DEBUG") + SET (CMAKE_BUILD_TYPE DEBUG CACHE STRING + "Choose the type of build, options are DEBUG, RELEASE, or TESTING." + FORCE) +ELSEIF(BT STREQUAL "TESTING") + SET (CMAKE_BUILD_TYPE TESTING CACHE STRING + "Choose the type of build, options are DEBUG, RELEASE, or TESTING." + FORCE) +ELSEIF(NOT BT) + SET(CMAKE_BUILD_TYPE RELEASE CACHE STRING + "Choose the type of build, options are DEBUG, RELEASE, or TESTING." + FORCE) + MESSAGE(STATUS "CMAKE_BUILD_TYPE not given, defaulting to RELEASE") +ELSE() + MESSAGE(FATAL_ERROR "CMAKE_BUILD_TYPE not valid, choices are DEBUG, RELEASE, or TESTING") +ENDIF(BT STREQUAL "RELEASE") + +######################################################### +# If the compiler flags have already been set, return now +######################################################### + +IF(CMAKE_Fortran_FLAGS_RELEASE AND CMAKE_Fortran_FLAGS_TESTING AND CMAKE_Fortran_FLAGS_DEBUG) + RETURN () +ENDIF(CMAKE_Fortran_FLAGS_RELEASE AND CMAKE_Fortran_FLAGS_TESTING AND CMAKE_Fortran_FLAGS_DEBUG) + +######################################################################## +# Determine the appropriate flags for this compiler for each build type. +# For each option type, a list of possible flags is given that work +# for various compilers. The first flag that works is chosen. +# If none of the flags work, nothing is added (unless the REQUIRED +# flag is given in the call). This way unknown compiles are supported. +####################################################################### + +##################### +### GENERAL FLAGS ### +##################### + +# Don't add underscores in symbols for C-compatability +#SET_COMPILE_FLAG(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS}" +# Fortran "-fno-underscoring") + +# There is some bug where -march=native doesn't work on Mac +IF(APPLE) + SET(GNUNATIVE "-mtune=native") +ELSE() + SET(GNUNATIVE "-march=native") +ENDIF() + +#THe folowing does not seem to get added... +SET_COMPILE_FLAG(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS}" + Fortran "-fimplicit-none" # GNU +) + +# Optimize for the host's architecture +SET_COMPILE_FLAG(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS}" + Fortran "-xHost" # Intel + "/QxHost" # Intel Windows + ${GNUNATIVE} # GNU + "-ta=host" # Portland Group + ) + +SET_COMPILE_FLAG(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS}" + Fortran "-ffree-form" # GNU + "-free" #Intel Linux and MacOS + "/free" #Intel Windows +) + +SET_COMPILE_FLAG(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS}" + Fortran "-ffree-line-length-none" # GNU +) + +SET_COMPILE_FLAG(CMAKE_Fortran_FLAGS_RELEASE "${CMAKE_Fortran_FLAGS_RELEASE}" + Fortran "-cpp" # GNU + "-fpp" # Intel + "/fpp" # Intel Windows + "-Mpreprocess" # Portland Group + ) + +################### +### DEBUG FLAGS ### +################### + +# NOTE: debugging symbols (-g or /debug:full) are already on by default + +# Disable optimizations +SET_COMPILE_FLAG(CMAKE_Fortran_FLAGS_DEBUG "${CMAKE_Fortran_FLAGS_DEBUG}" + Fortran REQUIRED "-O0" # All compilers not on Windows + "/Od" # Intel Windows + ) + +# Turn on all warnings +SET_COMPILE_FLAG(CMAKE_Fortran_FLAGS_DEBUG "${CMAKE_Fortran_FLAGS_DEBUG}" + Fortran "-warn all" # Intel + "/warn:all" # Intel Windows + "-Wall" # GNU + # Portland Group (on by default) + ) + +# Traceback +SET_COMPILE_FLAG(CMAKE_Fortran_FLAGS_DEBUG "${CMAKE_Fortran_FLAGS_DEBUG}" + Fortran "-traceback" # Intel/Portland Group + "/traceback" # Intel Windows + "-fbacktrace" # GNU (gfortran) + "-ftrace=full" # GNU (g95) + ) + +# Check array bounds +SET_COMPILE_FLAG(CMAKE_Fortran_FLAGS_DEBUG "${CMAKE_Fortran_FLAGS_DEBUG}" + Fortran "-check bounds" # Intel + "/check:bounds" # Intel Windows + "-fcheck=bounds" # GNU (New style) + "-fbounds-check" # GNU (Old style) + "-Mbounds" # Portland Group + ) + +##################### +### TESTING FLAGS ### +##################### + +# Optimizations +SET_COMPILE_FLAG(CMAKE_Fortran_FLAGS_TESTING "${CMAKE_Fortran_FLAGS_TESTING}" + Fortran REQUIRED "-O2" # All compilers not on Windows + "/O2" # Intel Windows + ) + +##################### +### RELEASE FLAGS ### +##################### + +# NOTE: agressive optimizations (-O3) are already turned on by default + + +# Unroll loops +SET_COMPILE_FLAG(CMAKE_Fortran_FLAGS_RELEASE "${CMAKE_Fortran_FLAGS_RELEASE}" + Fortran "-funroll-loops" # GNU + "-unroll" # Intel + "/unroll" # Intel Windows + "-Munroll" # Portland Group + ) + +# Inline functions +SET_COMPILE_FLAG(CMAKE_Fortran_FLAGS_RELEASE "${CMAKE_Fortran_FLAGS_RELEASE}" + Fortran "-inline" # Intel + "/Qinline" # Intel Windows + "-finline-functions" # GNU + "-Minline" # Portland Group + ) + +# Interprocedural (link-time) optimizations +#SET_COMPILE_FLAG(CMAKE_Fortran_FLAGS_RELEASE "${CMAKE_Fortran_FLAGS_RELEASE}" +# Fortran "-ipo" # Intel +# "/Qipo" # Intel Windows +# "-flto" # GNU +# "-Mipa" # Portland Group +# ) + +# Single-file optimizations +SET_COMPILE_FLAG(CMAKE_Fortran_FLAGS_RELEASE "${CMAKE_Fortran_FLAGS_RELEASE}" + Fortran "-ip" # Intel + "/Qip" # Intel Windows + ) + +# Vectorize code +SET_COMPILE_FLAG(CMAKE_Fortran_FLAGS_RELEASE "${CMAKE_Fortran_FLAGS_RELEASE}" + Fortran "-vec-report0" # Intel + "-qopt-report0" # Intel 16+ + "/Qvec-report0" # Intel Windows + "-Mvect" # Portland Group + ) diff --git a/cmake/Modules/SetParallelizationLibrary.cmake b/cmake/Modules/SetParallelizationLibrary.cmake new file mode 100644 index 000000000..603d4299c --- /dev/null +++ b/cmake/Modules/SetParallelizationLibrary.cmake @@ -0,0 +1,39 @@ +# Turns on either OpenMP or MPI +# If both are requested, the other is disabled +# When one is turned on, the other is turned off +# If both are off, we explicitly disable them just in case + +IF (USE_OPENMP AND USE_MPI) + MESSAGE (FATAL_ERROR "Cannot use both OpenMP and MPI") +ELSEIF (USE_OPENMP) + # Find OpenMP + IF (NOT OpenMP_Fortran_FLAGS) + FIND_PACKAGE (OpenMP_Fortran) + IF (NOT OpenMP_Fortran_FLAGS) + MESSAGE (FATAL_ERROR "Fortran compiler does not support OpenMP") + ENDIF (NOT OpenMP_Fortran_FLAGS) + ENDIF (NOT OpenMP_Fortran_FLAGS) + # Turn of MPI + UNSET (MPI_FOUND CACHE) + UNSET (MPI_COMPILER CACHE) + UNSET (MPI_LIBRARY CACHE) +ELSEIF (USE_MPI) + # Find MPI + IF (NOT MPI_Fortran_FOUND) + FIND_PACKAGE (MPI REQUIRED) + ENDIF (NOT MPI_Fortran_FOUND) + # Turn off OpenMP + SET (OMP_NUM_PROCS 0 CACHE + STRING "Number of processors OpenMP may use" FORCE) + UNSET (OpenMP_C_FLAGS CACHE) + UNSET (GOMP_Fortran_LINK_FLAGS CACHE) +ELSE () + # Turn off both OpenMP and MPI + SET (OMP_NUM_PROCS 0 CACHE + STRING "Number of processors OpenMP may use" FORCE) + UNSET (OpenMP_Fortran_FLAGS CACHE) + UNSET (GOMP_Fortran_LINK_FLAGS CACHE) + UNSET (MPI_FOUND CACHE) + UNSET (MPI_COMPILER CACHE) + UNSET (MPI_LIBRARY CACHE) +ENDIF (USE_OPENMP AND USE_MPI) diff --git a/cmake/Modules/SetUpLAPACK.cmake b/cmake/Modules/SetUpLAPACK.cmake new file mode 100644 index 000000000..ae5bdea52 --- /dev/null +++ b/cmake/Modules/SetUpLAPACK.cmake @@ -0,0 +1,11 @@ +# Find LAPACK (finds BLAS also) if not already found +IF(NOT LAPACK_FOUND) + ENABLE_LANGUAGE(C) # Some libraries need a C compiler to find + FIND_PACKAGE(LAPACK REQUIRED) + # Remember that LAPACK (and BLAS) was found. For some reason the + # FindLAPACK routine doesn't place these into the CACHE. + SET(BLAS_FOUND TRUE CACHE INTERNAL "BLAS was found" FORCE) + SET(LAPACK_FOUND TRUE CACHE INTERNAL "LAPACK was found" FORCE) + SET(BLAS_LIBRARIES ${BLAS_LIBRARIES} CACHE INTERNAL "BLAS LIBS" FORCE) + SET(LAPACK_LIBRARIES ${LAPACK_LIBRARIES} CACHE INTERNAL "LAPACK LIBS" FORCE) +ENDIF(NOT LAPACK_FOUND) From 8cdb894aa446d13b380be154c5c03307fb78f27d Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Wed, 1 Jun 2016 21:06:36 +0200 Subject: [PATCH 08/11] Update the CI file to reflect the new binaries. --- .gitlab-ci.yml | 39 +++++++++++++++++++++++++++++++-------- 1 file changed, 31 insertions(+), 8 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 0bf7a033e..e20c6b625 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -3,13 +3,36 @@ types: - test -GQMCT: +Ising: type: build script: - - . configure.sh - - cd Libraries - - make - - cd .. - - cd Prog_8 - - make - + - cmake -E make_directory build + - cd build + - cmake -G "Unix Makefiles" -DCMAKE_BUILD_TYPE=Release .. + - cmake --build . --target qmct_Hub --config Release + +Hubbard: + type: build + script: + - cmake -E make_directory build + - cd build + - cmake -G "Unix Makefiles" -DCMAKE_BUILD_TYPE=Release .. + - cmake --build . --target qmct_Hub --config Release + +SPT: + type: build + script: + - cmake -E make_directory build + - cd build + - cmake -G "Unix Makefiles" -DCMAKE_BUILD_TYPE=Release .. + - cmake --build . --target qmct_SPT --config Release + +Analysis: + type: build + script: + - cmake -E make_directory build + - cd build + - cmake -G "Unix Makefiles" -DCMAKE_BUILD_TYPE=Release .. + - cmake --build . --target cov_eq --config Release + - cmake --build . --target cov_tau --config Release + - cmake --build . --target jackv5 --config Release From 94f2a8520b4c489e94bd074aaf500e99d286c8fa Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Wed, 1 Jun 2016 21:07:51 +0200 Subject: [PATCH 09/11] Forgot a file --- cmake/Modules/SetFortranFlags.cmake | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/cmake/Modules/SetFortranFlags.cmake b/cmake/Modules/SetFortranFlags.cmake index ae1eb702b..02fadb289 100644 --- a/cmake/Modules/SetFortranFlags.cmake +++ b/cmake/Modules/SetFortranFlags.cmake @@ -75,22 +75,22 @@ SET_COMPILE_FLAG(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS}" "-ta=host" # Portland Group ) -SET_COMPILE_FLAG(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS}" - Fortran "-ffree-form" # GNU - "-free" #Intel Linux and MacOS - "/free" #Intel Windows -) +#SET_COMPILE_FLAG(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS}" +# Fortran "-ffree-form" # GNU +# "-free" #Intel Linux and MacOS +# "/free" #Intel Windows +#) -SET_COMPILE_FLAG(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS}" - Fortran "-ffree-line-length-none" # GNU -) +#SET_COMPILE_FLAG(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS}" +# Fortran "-ffree-line-length-none" # GNU +#) -SET_COMPILE_FLAG(CMAKE_Fortran_FLAGS_RELEASE "${CMAKE_Fortran_FLAGS_RELEASE}" - Fortran "-cpp" # GNU - "-fpp" # Intel - "/fpp" # Intel Windows - "-Mpreprocess" # Portland Group - ) +#SET_COMPILE_FLAG(CMAKE_Fortran_FLAGS_RELEASE "${CMAKE_Fortran_FLAGS_RELEASE}" +# Fortran "-cpp" # GNU +# "-fpp" # Intel +# "/fpp" # Intel Windows +# "-Mpreprocess" # Portland Group +# ) ################### ### DEBUG FLAGS ### From d91bd7493862c36fd1d1f2558c1edb63cff5f46b Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Thu, 2 Jun 2016 00:34:37 +0200 Subject: [PATCH 10/11] use current wording in --- .gitlab-ci.yml | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index e20c6b625..474b90296 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -1,10 +1,13 @@ -types: +stages: + - SCA + - style - build - test + - deploy Ising: - type: build + stage: build script: - cmake -E make_directory build - cd build @@ -12,7 +15,7 @@ Ising: - cmake --build . --target qmct_Hub --config Release Hubbard: - type: build + stage: build script: - cmake -E make_directory build - cd build @@ -20,7 +23,7 @@ Hubbard: - cmake --build . --target qmct_Hub --config Release SPT: - type: build + stage: build script: - cmake -E make_directory build - cd build @@ -28,7 +31,7 @@ SPT: - cmake --build . --target qmct_SPT --config Release Analysis: - type: build + stage: build script: - cmake -E make_directory build - cd build From dcff7b65cf5d6c586606fd1aed4133ac75229442 Mon Sep 17 00:00:00 2001 From: Florian Goth Date: Tue, 7 Jun 2016 15:59:12 +0200 Subject: [PATCH 11/11] help the compiler in the optimization --- src/Prog/Operator.f90 | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/Prog/Operator.f90 b/src/Prog/Operator.f90 index e2b1e9fa0..82dc0012e 100644 --- a/src/Prog/Operator.f90 +++ b/src/Prog/Operator.f90 @@ -287,7 +287,7 @@ Subroutine Op_Wrapup(Mat,Op,spin,Ndim,N_Type) ! Local Complex (Kind=8) :: VH(Ndim,Op%N), Z, Z1 - Integer :: n, i, m, m1 + Integer :: n, i, m, m1, oppm, oppn @@ -329,17 +329,19 @@ Subroutine Op_Wrapup(Mat,Op,spin,Ndim,N_Type) enddo enddo Do n = 1,Op%N + oppn = Op%P(n) Do I = 1,Ndim - Mat(Op%P(n),I) = VH(I,n) + Mat(oppn,I) = VH(I,n) Enddo Enddo elseif (N_Type == 2) then VH = cmplx(0.d0,0.d0) do n = 1,Op%N Do m = 1,Op%N - Z1 = conjg(Op%U(n,m)) + Z1 = conjg(Op%U(n,m)) + oppm = Op%P(m) DO I = 1,Ndim - VH(I,n) = VH(I,n) + Mat(I,Op%P(m)) * Z1 + VH(I,n) = VH(I,n) + Mat(I,oppm) * Z1 Enddo enddo Enddo