├── qutipf90mc ├── tests │ ├── __init__.py │ └── test_mcsolve_f90.py ├── .f2py_f2cmap ├── testing.py ├── examples │ ├── __init__.py │ ├── ex_31.py │ ├── ex_30.py │ ├── mpi_example.py │ ├── ex_34.py │ ├── ex_33.py │ ├── ex_24.py │ └── ex_32.py ├── __init__.py ├── qutraj_precision.f90 ├── qutraj_nolinalg.f90 ├── zvode │ ├── Makefile │ ├── zcopy.f │ ├── zgefa.f │ ├── zgesl.f │ ├── zgbsl.f │ └── zgbfa.f ├── qutraj_linalg.f90 ├── setup.py ├── Makefile ├── compare.py ├── qutraj_general.f90 ├── tester.py ├── linked_list.f90 ├── qutraj_run.pyf ├── mt19937.f90 ├── qutraj_evolve.f90 ├── qutraj_run.f90 ├── mcsolve_f90.py └── qutraj_hilbert.f90 ├── .gitignore ├── .f2py_f2cmap ├── README └── setup.py /qutipf90mc/tests/__init__.py: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.out 3 | fort.8 4 | *.mod 5 | *.o 6 | *.so 7 | *.pyc 8 | src/old/ 9 | *.sw* 10 | *.backup 11 | -------------------------------------------------------------------------------- /.f2py_f2cmap: -------------------------------------------------------------------------------- 1 | dict(real=dict(sp='float', dp='double', wp='double'),complex=dict(sp='complex_float', dp='complex_double', wp='complex_double')) 2 | -------------------------------------------------------------------------------- /qutipf90mc/.f2py_f2cmap: -------------------------------------------------------------------------------- 1 | dict(real=dict(sp='float', dp='double', wp='double'),complex=dict(sp='complex_float', dp='complex_double', wp='complex_double')) 2 | -------------------------------------------------------------------------------- /qutipf90mc/testing.py: -------------------------------------------------------------------------------- 1 | #function to run the nose test scripts 2 | def test(): 3 | import nose 4 | nose.run(defaultTest="qutipf90mc.tests",argv=['nosetests', '-v']) #runs tests in qutipf90mc/tests module only 5 | 6 | -------------------------------------------------------------------------------- /qutipf90mc/examples/__init__.py: -------------------------------------------------------------------------------- 1 | import qutipf90mc.examples.ex_24 2 | import qutipf90mc.examples.ex_30 3 | import qutipf90mc.examples.ex_31 4 | #import qutipf90mc.examples.ex_32 5 | import qutipf90mc.examples.ex_33 6 | import qutipf90mc.examples.ex_34 7 | -------------------------------------------------------------------------------- /qutipf90mc/__init__.py: -------------------------------------------------------------------------------- 1 | # Initializaiton 2 | 3 | # what to import when using import * 4 | #all = [''] 5 | 6 | from mcsolve_f90 import mcsolve_f90 7 | #from mcsolve_f90_par import mcsolve_f90_serial, mcsolve_f90_par 8 | from tester import alldemos, rundemo 9 | from testing import test 10 | import compare 11 | import examples 12 | -------------------------------------------------------------------------------- /qutipf90mc/qutraj_precision.f90: -------------------------------------------------------------------------------- 1 | module qutraj_precision 2 | ! Module for setting working precision 3 | 4 | implicit none 5 | 6 | !integer, parameter :: sp = kind(1.0e0) ! single precision 7 | !integer, parameter :: dp = kind(1.0d0) ! double precision 8 | integer, parameter :: sp = selected_real_kind(6,37) ! single precision 9 | integer, parameter :: dp = selected_real_kind(15,307) ! double precision 10 | integer, parameter :: wp = dp ! working precision 11 | 12 | ! small and large number 13 | real, parameter :: epsi=5*epsilon(1.0) 14 | real, parameter :: huge1=0.2*huge(1.0) 15 | 16 | end module 17 | -------------------------------------------------------------------------------- /qutipf90mc/qutraj_nolinalg.f90: -------------------------------------------------------------------------------- 1 | module qutraj_linalg 2 | ! 3 | ! Dummy module 4 | ! 5 | 6 | use qutraj_precision 7 | use qutraj_general 8 | use qutraj_hilbert 9 | 10 | implicit none 11 | 12 | contains 13 | 14 | subroutine eigenvalues(rho,eig,n) 15 | ! Eigenvalues of dense hermitian matrix rho 16 | complex(wp), intent(in) :: rho(:,:) 17 | integer, intent(in) :: n 18 | real(wp), intent(out) :: eig(n) 19 | call error('eigenvalues: subroutine not available.') 20 | end subroutine 21 | 22 | subroutine entropy(rho,S) 23 | ! Calculate entropy for dense density matrix 24 | complex(wp), intent(in) :: rho(:,:) 25 | real(wp), intent(out) :: S 26 | call error('eigenvalues: subroutine not available.') 27 | end subroutine 28 | 29 | end module 30 | -------------------------------------------------------------------------------- /qutipf90mc/zvode/Makefile: -------------------------------------------------------------------------------- 1 | TARGET = zvode 2 | 3 | F90 = gfortran 4 | F90FLAGS = 5 | LDFLAGS = -lblas 6 | F77 = gfortran 7 | F77FLAGS = 8 | 9 | ZVODE = zvode zcopy zgbfa zgbsl zgefa zgesl 10 | ZVODE_OBJS = $(ZVODE:=.o) 11 | ZVODE_SRCS = $(ZVODE:=.f) 12 | 13 | .PHONY: all clean 14 | 15 | all: $(ZVODE_OBJS) 16 | 17 | clean: 18 | $(RM) *.o 19 | $(RM) *.mod 20 | $(RM) *.so 21 | 22 | .SUFFIXES: $(SUFFIXES) .f90 .f 23 | # 24 | # Need to override standard rule for mod files since make thinks they are modula-2 files 25 | %.o: %.mod 26 | .f90.o: 27 | # Rule on how to convert from .f90 to .o 28 | # $< macro refers to the name of the related file that caused the action. 29 | $(F90) $(F90FLAGS) -c $< 30 | .f90.mod: 31 | $(F90) $(F90FLAGS) -c $< 32 | .f.o: 33 | $(F77) $(F77FLAGS) -c -fPIC $< 34 | 35 | 36 | -------------------------------------------------------------------------------- /qutipf90mc/zvode/zcopy.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE ZCOPY(N,ZX,INCX,ZY,INCY) 2 | * .. Scalar Arguments .. 3 | INTEGER INCX,INCY,N 4 | * .. 5 | * .. Array Arguments .. 6 | DOUBLE COMPLEX ZX(*),ZY(*) 7 | * .. 8 | * 9 | * Purpose 10 | * ======= 11 | * 12 | * ZCOPY copies a vector, x, to a vector, y. 13 | * 14 | * Further Details 15 | * =============== 16 | * 17 | * jack dongarra, linpack, 4/11/78. 18 | * modified 12/3/93, array(1) declarations changed to array(*) 19 | * 20 | * ===================================================================== 21 | * 22 | * .. Local Scalars .. 23 | INTEGER I,IX,IY 24 | * .. 25 | IF (N.LE.0) RETURN 26 | IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN 27 | * 28 | * code for both increments equal to 1 29 | * 30 | DO I = 1,N 31 | ZY(I) = ZX(I) 32 | END DO 33 | ELSE 34 | * 35 | * code for unequal increments or equal increments 36 | * not equal to 1 37 | * 38 | IX = 1 39 | IY = 1 40 | IF (INCX.LT.0) IX = (-N+1)*INCX + 1 41 | IF (INCY.LT.0) IY = (-N+1)*INCY + 1 42 | DO I = 1,N 43 | ZY(IY) = ZX(IX) 44 | IX = IX + INCX 45 | IY = IY + INCY 46 | END DO 47 | END IF 48 | RETURN 49 | END 50 | -------------------------------------------------------------------------------- /qutipf90mc/qutraj_linalg.f90: -------------------------------------------------------------------------------- 1 | module qutraj_linalg 2 | ! 3 | ! This module depends on LAPACK 4 | ! 5 | 6 | use qutraj_precision 7 | use qutraj_general 8 | use qutraj_hilbert 9 | 10 | implicit none 11 | 12 | contains 13 | 14 | subroutine eigenvalues(rho,eig,n) 15 | ! Eigenvalues of dense hermitian matrix rho 16 | complex(wp), intent(in) :: rho(:,:) 17 | integer, intent(in) :: n 18 | real(wp), intent(out) :: eig(n) 19 | double complex :: ap(n*(n+1)/2), z(1,1),work(2*n-1) 20 | double precision :: eig_dp(n),rwork(3*n-2) 21 | integer info,i,j 22 | do i=1,n 23 | do j=i,n 24 | ap(i+(j-1)*j/2) = rho(i,j) 25 | enddo 26 | enddo 27 | call zhpev('N','U',n,ap,eig_dp,z,1,work,rwork,info) 28 | eig = eig_dp 29 | end subroutine 30 | 31 | subroutine entropy(rho,S) 32 | ! Calculate entropy for dense density matrix 33 | complex(wp), intent(in) :: rho(:,:) 34 | real(wp), intent(out) :: S 35 | real(wp), dimension(2) :: eig_r 36 | integer :: i 37 | call eigenvalues(rho,eig_r,size(rho,1)) 38 | S = 0 39 | do i=1,size(eig_r) 40 | ! Rule: 0 log(0) = 0 41 | if (eig_r(i) < -epsi) & 42 | write(*,*) "entropy: negative eigenvalue!", eig_r(i) 43 | if (abs(eig_r(i)) > epsi) then 44 | S = S -eig_r(i)*log(eig_r(i))/log(2.) 45 | endif 46 | enddo 47 | end subroutine 48 | 49 | 50 | end module 51 | -------------------------------------------------------------------------------- /qutipf90mc/examples/ex_31.py: -------------------------------------------------------------------------------- 1 | # 2 | # Occupation number of two coupled osciilators with 3 | # oscillator A driven by an external classical drive. 4 | # Both oscillators are assumed to start in the ground 5 | # state. 6 | # 7 | from qutip import * 8 | from pylab import * 9 | import qutipf90mc as mcf90 10 | 11 | def run(): 12 | wa = 1.0 * 2 * pi # frequency of system a 13 | wb = 1.0 * 2 * pi # frequency of system a 14 | wab = 0.2 * 2 * pi # coupling frequency 15 | ga = 0.2 * 2 * pi # dissipation rate of system a 16 | gb = 0.1 * 2 * pi # dissipation rate of system b 17 | Na = 10 # number of states in system a 18 | Nb = 10 # number of states in system b 19 | E = 1.0 * 2 * pi # Oscillator A driving strength 20 | 21 | a = tensor(destroy(Na), qeye(Nb)) 22 | b = tensor(qeye(Na), destroy(Nb)) 23 | na = a.dag() * a 24 | nb = b.dag() * b 25 | H = wa*na + wb*nb + wab*(a.dag()*b+a*b.dag()) + E*(a.dag()+a) 26 | 27 | # start with both oscillators in ground state 28 | psi0 = tensor(basis(Na), basis(Nb)) 29 | 30 | c_op_list = [] 31 | c_op_list.append(sqrt(ga) * a) 32 | c_op_list.append(sqrt(gb) * b) 33 | 34 | tlist = linspace(0, 5, 101) 35 | 36 | #run simulation 37 | data = mcf90.mcsolve_f90(H,psi0,tlist,c_op_list,[na,nb]) 38 | #data = mcsolve(H,psi0,tlist,c_op_list,[na,nb]) 39 | 40 | #plot results 41 | plot(tlist,data.expect[0],'b',tlist,data.expect[1],'r',lw=2) 42 | xlabel('Time',fontsize=14) 43 | ylabel('Excitations',fontsize=14) 44 | legend(('Oscillator A', 'Oscillator B')) 45 | show() 46 | 47 | if __name__=='__main__': 48 | run() 49 | -------------------------------------------------------------------------------- /qutipf90mc/examples/ex_30.py: -------------------------------------------------------------------------------- 1 | # 2 | # Monte Carlo evoution of a coherently driven cavity with a two-level atom 3 | # initially in the ground state and no photons in the cavity 4 | # 5 | #Adapted from qotoolbox example 'probqmc3' by Sze M. Tan 6 | # 7 | from qutip import * 8 | from pylab import * 9 | import qutipf90mc as mcf90 10 | 11 | def run(): 12 | # set system parameters 13 | kappa=2.0 #mirror coupling 14 | gamma=0.2 #spontaneous emission rate 15 | g=1 #atom/cavity coupling strength 16 | wc=0 #cavity frequency 17 | w0=0 #atom frequency 18 | wl=0 #driving frequency 19 | E=0.5 #driving amplitude 20 | N=4 #number of cavity energy levels (0->3 Fock states) 21 | tlist=linspace(0,10,101) #times for expectation values 22 | 23 | # construct Hamiltonian 24 | ida=qeye(N) 25 | idatom=qeye(2) 26 | a=tensor(destroy(N),idatom) 27 | sm=tensor(ida,sigmam()) 28 | H=(w0-wl)*sm.dag()*sm+(wc-wl)*a.dag()*a+1j*g*(a.dag()*sm-sm.dag()*a)+E*(a.dag()+a) 29 | 30 | #collapse operators 31 | C1=sqrt(2*kappa)*a 32 | C2=sqrt(gamma)*sm 33 | C1dC1=C1.dag()*C1 34 | C2dC2=C2.dag()*C2 35 | 36 | #intial state 37 | psi0=tensor(basis(N,0),basis(2,1)) 38 | 39 | #run monte-carlo solver with default 500 trajectories 40 | data=mcf90.mcsolve_f90(H,psi0,tlist,[C1,C2],[C1dC1,C2dC2]) 41 | #data=mcsolve(H,psi0,tlist,[C1,C2],[C1dC1,C2dC2]) 42 | #plot expectation values 43 | plot(tlist,data.expect[0],tlist,data.expect[1],lw=2) 44 | legend(('Transmitted Cavity Intensity','Spontaneous Emission')) 45 | ylabel('Counts') 46 | xlabel('Time') 47 | show() 48 | 49 | if __name__=='__main__': 50 | run() 51 | 52 | 53 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | qutipf90mc 2 | 3 | The development of a "wave-function monte carlo" solver written in Fortran 90/95, with a python interface trough f2py. The program is intended to be used with the qutip python package. 4 | 5 | Features: 6 | 7 | - Usage (almost, see missing features) identical to QuTiP v.2.1.0's mcsolve 8 | - Uses sparse (compressed row format) matrices for operators 9 | - Uses zvode to integrate in time 10 | - Time evolution algorithm from QuTiP v2.1.0 to find correct times for jumps. 11 | - Automatic parallelization via Python's multiprocessing module. 12 | 13 | Missing features: 14 | - Does not accept list as "ntraj" argument. 15 | - Only solves prolbems without explicit time-dependence. 16 | 17 | 18 | Dependencies: 19 | 20 | - QuTiP v.2.1.0 or higher and all its dependencies. 21 | - A fortran compiler and the BLAS library (BLAS comes with many fortran compilers, such as gfortran). 22 | 23 | 24 | Installation: 25 | 26 | 1. Download code with 27 | git clone https://github.com/arnelg/qutipf90mc.git 28 | 29 | 2. Enter directory and install 30 | cd qutipf90mc 31 | python setup.py install 32 | 33 | Or, if you prefer to install locally: 34 | python setup.py build_ext --inplace 35 | 36 | 37 | Testing and usage: 38 | 39 | Test the installation by leaving the directory, starting python and entering 40 | import qutipf90mc 41 | 42 | To run a few unit tests do: 43 | qutipf90mc.test() 44 | 45 | To run a few demos do: 46 | qutipf90mc.alldemos() 47 | 48 | This will run some demos from QuTiP where the call to qutip.mcsolve has been replaced by qutipf90mc.mcsolve_f90. 49 | 50 | For general usage see 51 | help(qutipf90mc.mcsolve_f90) 52 | 53 | You can also run qutipf90mc.compare.run(dim,ntraj) to compare the speed of mcsolve_f90 vs. mcsolve for a decaying system with Hilbert space dimension dim, and ntraj trajectories, run on a single CPU. 54 | -------------------------------------------------------------------------------- /qutipf90mc/examples/mpi_example.py: -------------------------------------------------------------------------------- 1 | """ 2 | This examplifies how to use MPI with qutip(f90mc). It requires MPI and the 3 | python package mpi4py. You can install e.g. openmpi on ubuntu by 4 | 5 | sudo apt-get install openmpi-bin openmpi-doc libopenmpi-dev 6 | 7 | Then mpi4py can be installed in the usual way you install python packages. 8 | For example with pip 9 | 10 | pip install mpi4py 11 | 12 | To run this example on 4 CPUS: 13 | 14 | mpiexec -n 4 python mpi_example.py 15 | """ 16 | 17 | import numpy as np 18 | import matplotlib.pyplot as plt 19 | import qutip as qt 20 | import qutipf90mc as mcf90 21 | 22 | def run(): 23 | from mpi4py import MPI 24 | comm = MPI.COMM_WORLD 25 | size = comm.Get_size() 26 | rank = comm.Get_rank() 27 | print "Process number", rank, "of", size, "total." 28 | 29 | neq = 2 30 | gamma = 1.0 31 | psi0 = qt.basis(neq,neq-1) 32 | H = qt.sigmax() 33 | c_ops = [np.sqrt(gamma)*qt.sigmax()] 34 | e_ops = [qt.sigmam()*qt.sigmap()] 35 | 36 | tlist = np.linspace(0,10,100) 37 | 38 | ntraj=100 39 | 40 | # One CPU per MPI process 41 | opts = qt.Odeoptions() 42 | opts.num_cpus = 1 43 | 44 | # Solve 45 | sols = mcf90.mcsolve_f90(H,psi0,tlist,c_ops,e_ops,ntraj=ntraj,options=opts) 46 | #sols = qt.mcsolve(H,psi0,tlist,c_ops,e_ops,ntraj=ntraj,options=opts) 47 | 48 | # Gather data 49 | sols = comm.gather(sols,root=0) 50 | if (rank==0): 51 | sol = sols[0] 52 | sol.expect = np.array(sols[0].expect) 53 | plt.figure() 54 | plt.plot(tlist,sols[0].expect[0],'r',label='proc '+str(0)) 55 | for i in range(1,size): 56 | plt.plot(tlist,sols[i].expect[0],'r',label='proc '+str(i)) 57 | sol.expect += np.array(sols[i].expect) 58 | sol.expect = sol.expect/size 59 | plt.plot(tlist,sol.expect[0],'b',label='average') 60 | plt.legend() 61 | plt.show() 62 | 63 | if (__name__ == '__main__'): 64 | run() 65 | 66 | -------------------------------------------------------------------------------- /qutipf90mc/examples/ex_34.py: -------------------------------------------------------------------------------- 1 | # 2 | # Example showing which times and operators 3 | # were responsible for wave function collapse 4 | # in the monte-carlo simulation of a dissipative 5 | # trilinear Hamiltonian. 6 | # 7 | 8 | from qutip import * 9 | from pylab import * 10 | import qutipf90mc as mcf90 11 | 12 | def run(): 13 | #number of states for each mode 14 | N0=6 15 | N1=6 16 | N2=6 17 | #damping rates 18 | gamma0=0.1 19 | gamma1=0.4 20 | gamma2=0.1 21 | alpha=sqrt(2)#initial coherent state param for mode 0 22 | tlist=linspace(0,4,200) 23 | ntraj=500#number of trajectories 24 | 25 | #define operators 26 | a0=tensor(destroy(N0),qeye(N1),qeye(N2)) 27 | a1=tensor(qeye(N0),destroy(N1),qeye(N2)) 28 | a2=tensor(qeye(N0),qeye(N1),destroy(N2)) 29 | 30 | #number operators for each mode 31 | num0=a0.dag()*a0 32 | num1=a1.dag()*a1 33 | num2=a2.dag()*a2 34 | 35 | #dissipative operators for zero-temp. baths 36 | C0=sqrt(2.0*gamma0)*a0 37 | C1=sqrt(2.0*gamma1)*a1 38 | C2=sqrt(2.0*gamma2)*a2 39 | 40 | #initial state: coherent mode 0 & vacuum for modes #1 & #2 41 | psi0=tensor(coherent(N0,alpha),basis(N1,0),basis(N2,0)) 42 | 43 | #trilinear Hamiltonian 44 | H=1j*(a0*a1.dag()*a2.dag()-a0.dag()*a1*a2) 45 | 46 | #run Monte-Carlo 47 | data=mcf90.mcsolve_f90(H,psi0,tlist,[C0,C1,C2],[num0,num1,num2]) 48 | #data=mcsolve(H,psi0,tlist,[C0,C1,C2],[num0,num1,num2]) 49 | 50 | #plot results 51 | fig = figure() 52 | ax = fig.add_subplot(111) 53 | cs=['b','r','g'] #set three colors, one for each operator 54 | for k in range(ntraj): 55 | if len(data.col_times[k])>0:#just in case no collapse 56 | colors=[cs[j] for j in data.col_which[k]]#set color 57 | xdat=[k for x in range(len(data.col_times[k]))] 58 | ax.scatter(xdat,data.col_times[k],marker='o',c=colors) 59 | ax.set_xlim([-1,ntraj+1]) 60 | ax.set_ylim([0,tlist[-1]]) 61 | ax.set_xlabel('Trajectory',fontsize=14) 62 | ax.set_ylabel('Collpase Time',fontsize=14) 63 | ax.set_title('Blue = C0, Red = C1, Green= C2') 64 | show() 65 | 66 | if __name__=='__main__': 67 | run() 68 | -------------------------------------------------------------------------------- /qutipf90mc/examples/ex_33.py: -------------------------------------------------------------------------------- 1 | # 2 | # Demonstrate the deviation from a thermal distribution 3 | # for the trilinear Hamiltonian. 4 | # 5 | # Adapted from Nation & Blencowe, NJP 12 095013 (2010) 6 | # 7 | from qutip import * 8 | from pylab import * 9 | import qutipf90mc as mcf90 10 | 11 | def run(): 12 | #number of states for each mode 13 | N0=15 14 | N1=15 15 | N2=15 16 | 17 | #define operators 18 | a0=tensor(destroy(N0),qeye(N1),qeye(N2)) 19 | a1=tensor(qeye(N0),destroy(N1),qeye(N2)) 20 | a2=tensor(qeye(N0),qeye(N1),destroy(N2)) 21 | 22 | #number operators for each mode 23 | num0=a0.dag()*a0 24 | num1=a1.dag()*a1 25 | num2=a2.dag()*a2 26 | 27 | #initial state: coherent mode 0 & vacuum for modes #1 & #2 28 | alpha=sqrt(7)#initial coherent state param for mode 0 29 | psi0=tensor(coherent(N0,alpha),basis(N1,0),basis(N2,0)) 30 | 31 | #trilinear Hamiltonian 32 | H=1.0j*(a0*a1.dag()*a2.dag()-a0.dag()*a1*a2) 33 | 34 | #run Monte-Carlo 35 | tlist=linspace(0,2.5,50) 36 | output=mcf90.mcsolve_f90(H,psi0,tlist,[],[],ntraj=1) 37 | #output=mcsolve(H,psi0,tlist,[],[],ntraj=1) 38 | 39 | #extrace mode 1 using ptrace 40 | mode1=[psi.ptrace(1) for psi in output.states] 41 | #get diagonal elements 42 | diags1=[k.diag() for k in mode1] 43 | #calculate num of particles in mode 1 44 | num1=[expect(num1,k) for k in output.states] 45 | #generate thermal state with same # of particles 46 | thermal=[thermal_dm(N1,k).diag() for k in num1] 47 | 48 | #plot results 49 | from mpl_toolkits.mplot3d import Axes3D 50 | from matplotlib import cm 51 | colors=['m', 'g','orange','b', 'y','pink'] 52 | x=arange(N1) 53 | params = {'axes.labelsize': 14,'text.fontsize': 14,'legend.fontsize': 12,'xtick.labelsize': 14,'ytick.labelsize': 14} 54 | rcParams.update(params) 55 | fig = plt.figure() 56 | ax = Axes3D(fig) 57 | for j in range(5): 58 | ax.bar(x, diags1[10*j], zs=tlist[10*j], zdir='y',color=colors[j],linewidth=1.0,alpha=0.6,align='center') 59 | ax.plot(x,thermal[10*j],zs=tlist[10*j],zdir='y',color='r',linewidth=3,alpha=1) 60 | ax.set_zlabel(r'Probability') 61 | ax.set_xlabel(r'Number State') 62 | ax.set_ylabel(r'Time') 63 | ax.set_zlim3d(0,1) 64 | show() 65 | 66 | if __name__=='__main__': 67 | run() 68 | 69 | -------------------------------------------------------------------------------- /qutipf90mc/setup.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python 2 | from os.path import join 3 | 4 | def configuration(parent_package='',top_path=None): 5 | from numpy.distutils.misc_util import Configuration 6 | from numpy.distutils.system_info import get_info, NotFoundError 7 | 8 | config = Configuration('qutipf90mc', parent_package, top_path) 9 | 10 | sources=[ 11 | 'qutraj_run.pyf', 12 | 'qutraj_precision.f90', 13 | 'mt19937.f90', 14 | 'linked_list.f90', 15 | 'qutraj_general.f90', 16 | 'qutraj_hilbert.f90', 17 | 'qutraj_evolve.f90', 18 | ] 19 | 20 | libs = [ 21 | 'zvode', 22 | ] 23 | 24 | config.add_library('zvode', 25 | sources=[join('zvode','*.f')]) 26 | 27 | # 28 | # LAPACK? 29 | # 30 | 31 | lapack_opt = get_info('lapack_opt',notfound_action=1) 32 | 33 | if not lapack_opt: 34 | #raise NotFoundError,'no lapack resources found' 35 | print("Warning: No lapack resource found. Linear algebra routines" 36 | +" like 'eigenvalues' and 'entropy' will not be available.") 37 | sources.append('qutraj_nolinalg.f90') 38 | else: 39 | sources.append('qutraj_linalg.f90') 40 | libs.extend(lapack_opt['libraries']) 41 | 42 | # 43 | # BLAS 44 | # 45 | 46 | if not lapack_opt: 47 | blas_opt = get_info('blas_opt',notfound_action=2) 48 | else: 49 | blas_opt = lapack_opt 50 | 51 | # Remove libraries key from blas_opt 52 | if 'libraries' in blas_opt: # key doesn't exist on OS X ... 53 | libs.extend(blas_opt['libraries']) 54 | newblas = {} 55 | for key in blas_opt.keys(): 56 | if key == 'libraries': 57 | continue 58 | newblas[key] = blas_opt[key] 59 | 60 | # Add this last 61 | sources.append('qutraj_run.f90') 62 | 63 | config.add_extension('qutraj_run', 64 | sources=sources, 65 | extra_compile_args=[ 66 | #'-DF2PY_REPORT_ON_ARRAY_COPY=1', 67 | ], 68 | libraries=libs, 69 | **newblas 70 | ) 71 | 72 | config.add_subpackage('examples') 73 | config.add_subpackage('tests') 74 | 75 | return config 76 | 77 | if (__name__ == '__main__'): 78 | from numpy.distutils.core import setup 79 | setup(**configuration(top_path='').todict()) 80 | #setup(packages=['qutipf90mc']) 81 | 82 | -------------------------------------------------------------------------------- /qutipf90mc/tests/test_mcsolve_f90.py: -------------------------------------------------------------------------------- 1 | # 2 | # Unit tests for mcsolve_f90 3 | # Adapdted from qutip/tests/test_mcsolve.py 4 | # 5 | 6 | from qutip import * 7 | from qutip.odechecks import _ode_checks 8 | from numpy import allclose 9 | from numpy.testing import assert_equal 10 | from numpy.testing.decorators import skipif 11 | from qutipf90mc import mcsolve_f90 12 | import unittest 13 | #find Cython if it exists 14 | try: 15 | import Cython 16 | except: 17 | Cython_found=0 18 | else: 19 | Cython_found=1 20 | 21 | kappa=0.2 22 | def sqrt_kappa(t,args): 23 | return sqrt(kappa) 24 | 25 | def sqrt_kappa2(t,args): 26 | return sqrt(kappa*exp(-t)) 27 | 28 | def const_H1_coeff(t,args): 29 | return 0.0 30 | 31 | #average error for failure 32 | mc_error=5e-2 #5% for ntraj=500 33 | 34 | def test_MCNoCollExpt(): 35 | "Monte-carlo: Constant H with no collapse ops (expect)" 36 | error=1e-8 37 | N=10 #number of basis states to consider 38 | a=destroy(N) 39 | H=a.dag()*a 40 | psi0=basis(N,9) #initial state 41 | kappa=0.2 #coupling to oscillator 42 | c_op_list=[] 43 | tlist=linspace(0,10,100) 44 | mcdata=mcsolve_f90(H,psi0,tlist,c_op_list,[a.dag()*a],options=Odeoptions(gui=False)) 45 | expt=mcdata.expect[0] 46 | actual_answer=9.0*ones(len(tlist)) 47 | diff=mean(abs(actual_answer-expt)/actual_answer) 48 | assert_equal(diff 0.0: 56 | c_op_list.append(sqrt(gamma[n]) * sz_list[n]) 57 | 58 | # evolve and calculate expectation values 59 | if solver == "me": 60 | output = mesolve(H, psi0, tlist, c_op_list, sz_list) 61 | elif solver == "mc": 62 | output = mcsolve(H, psi0, tlist, c_op_list, sz_list) 63 | elif solver == "mcf90": 64 | output = mcf90.mcsolve_f90(H, psi0, tlist, c_op_list, sz_list) 65 | 66 | return output.expect 67 | 68 | def run(): 69 | 70 | # 71 | # set up the calculation 72 | # 73 | 74 | solver = "mcf90" # select solver "me" or "mc" or "mcf90" 75 | #solver = "mc" # select solver "me" or "mc" or "mcf90" 76 | N = 4 # number of spins 77 | 78 | # array of spin energy splittings and coupling strengths. here we use 79 | # uniform parameters, but in general we don't have too 80 | h = 1.0 * 2 * pi * ones(N) 81 | Jz = 0.1 * 2 * pi * ones(N) 82 | Jx = 0.1 * 2 * pi * ones(N) 83 | Jy = 0.1 * 2 * pi * ones(N) 84 | 85 | # dephasing rate 86 | gamma = 0.01 * ones(N) 87 | 88 | # intial state, first spin in state |1>, the rest in state |0> 89 | psi_list = [] 90 | psi_list.append(basis(2,1)) 91 | for n in range(N-1): 92 | psi_list.append(basis(2,0)) 93 | psi0 = tensor(psi_list) 94 | 95 | tlist = linspace(0, 50, 300) 96 | 97 | sz_expt = integrate(N, h, Jx, Jy, Jz, psi0, tlist, gamma, solver) 98 | 99 | rc('font', family='Bitstream Vera Sans') 100 | for n in range(N): 101 | plot(tlist, real(sz_expt[n]), label=r'$\langle\sigma_z($'+str(n)+r'$)\rangle$',lw=2) 102 | xlabel(r'Time [ns]',fontsize=14) 103 | ylabel(r'$\langle\sigma_{z}\rangle$',fontsize=14) 104 | title(r'Dynamics of a Heisenberg spin chain') 105 | legend(loc = "lower right") 106 | 107 | show() 108 | 109 | if __name__=="__main__": 110 | run() 111 | 112 | -------------------------------------------------------------------------------- /qutipf90mc/zvode/zgefa.f: -------------------------------------------------------------------------------- 1 | subroutine zgefa(a,lda,n,ipvt,info) 2 | integer lda,n,ipvt(1),info 3 | complex*16 a(lda,1) 4 | c 5 | c zgefa factors a complex*16 matrix by gaussian elimination. 6 | c 7 | c zgefa is usually called by zgeco, but it can be called 8 | c directly with a saving in time if rcond is not needed. 9 | c (time for zgeco) = (1 + 9/n)*(time for zgefa) . 10 | c 11 | c on entry 12 | c 13 | c a complex*16(lda, n) 14 | c the matrix to be factored. 15 | c 16 | c lda integer 17 | c the leading dimension of the array a . 18 | c 19 | c n integer 20 | c the order of the matrix a . 21 | c 22 | c on return 23 | c 24 | c a an upper triangular matrix and the multipliers 25 | c which were used to obtain it. 26 | c the factorization can be written a = l*u where 27 | c l is a product of permutation and unit lower 28 | c triangular matrices and u is upper triangular. 29 | c 30 | c ipvt integer(n) 31 | c an integer vector of pivot indices. 32 | c 33 | c info integer 34 | c = 0 normal value. 35 | c = k if u(k,k) .eq. 0.0 . this is not an error 36 | c condition for this subroutine, but it does 37 | c indicate that zgesl or zgedi will divide by zero 38 | c if called. use rcond in zgeco for a reliable 39 | c indication of singularity. 40 | c 41 | c linpack. this version dated 08/14/78 . 42 | c cleve moler, university of new mexico, argonne national lab. 43 | c 44 | c subroutines and functions 45 | c 46 | c blas zaxpy,zscal,izamax 47 | c fortran dabs 48 | c 49 | c internal variables 50 | c 51 | complex*16 t 52 | integer izamax,j,k,kp1,l,nm1 53 | c 54 | complex*16 zdum 55 | double precision cabs1 56 | double precision dreal,dimag 57 | complex*16 zdumr,zdumi 58 | dreal(zdumr) = zdumr 59 | dimag(zdumi) = (0.0d0,-1.0d0)*zdumi 60 | cabs1(zdum) = dabs(dreal(zdum)) + dabs(dimag(zdum)) 61 | c 62 | c gaussian elimination with partial pivoting 63 | c 64 | info = 0 65 | nm1 = n - 1 66 | if (nm1 .lt. 1) go to 70 67 | do 60 k = 1, nm1 68 | kp1 = k + 1 69 | c 70 | c find l = pivot index 71 | c 72 | l = izamax(n-k+1,a(k,k),1) + k - 1 73 | ipvt(k) = l 74 | c 75 | c zero pivot implies this column already triangularized 76 | c 77 | if (cabs1(a(l,k)) .eq. 0.0d0) go to 40 78 | c 79 | c interchange if necessary 80 | c 81 | if (l .eq. k) go to 10 82 | t = a(l,k) 83 | a(l,k) = a(k,k) 84 | a(k,k) = t 85 | 10 continue 86 | c 87 | c compute multipliers 88 | c 89 | t = -(1.0d0,0.0d0)/a(k,k) 90 | call zscal(n-k,t,a(k+1,k),1) 91 | c 92 | c row elimination with column indexing 93 | c 94 | do 30 j = kp1, n 95 | t = a(l,j) 96 | if (l .eq. k) go to 20 97 | a(l,j) = a(k,j) 98 | a(k,j) = t 99 | 20 continue 100 | call zaxpy(n-k,t,a(k+1,k),1,a(k+1,j),1) 101 | 30 continue 102 | go to 50 103 | 40 continue 104 | info = k 105 | 50 continue 106 | 60 continue 107 | 70 continue 108 | ipvt(n) = n 109 | if (cabs1(a(n,n)) .eq. 0.0d0) info = n 110 | return 111 | end 112 | -------------------------------------------------------------------------------- /qutipf90mc/qutraj_general.f90: -------------------------------------------------------------------------------- 1 | module qutraj_general 2 | ! 3 | ! Global constants and general purpose subroutines 4 | ! 5 | 6 | use qutraj_precision 7 | 8 | implicit none 9 | 10 | ! 11 | ! Constants 12 | ! 13 | 14 | ! error params 15 | integer, parameter :: blas_error_param = -23 16 | 17 | ! imaginary unit 18 | complex(wp), parameter :: ii = (0._wp,1._wp) 19 | 20 | ! 21 | ! Interfaces 22 | ! 23 | 24 | interface new 25 | module procedure int_array_init 26 | module procedure int_array_init2 27 | module procedure wp_array_init 28 | module procedure wp_array_init2 29 | end interface 30 | 31 | interface finalize 32 | module procedure int_array_finalize 33 | module procedure wp_array_finalize 34 | end interface 35 | 36 | contains 37 | 38 | ! 39 | ! Initializers and finalizers 40 | ! 41 | 42 | subroutine int_array_init(this,n) 43 | integer, allocatable, intent(inout) :: this(:) 44 | integer, intent(in) :: n 45 | integer :: istat 46 | if (allocated(this)) then 47 | deallocate(this,stat=istat) 48 | endif 49 | allocate(this(n),stat=istat) 50 | if (istat.ne.0) then 51 | call fatal_error("int_array_init: could not allocate.",istat) 52 | endif 53 | end subroutine 54 | 55 | subroutine int_array_init2(this,val) 56 | integer, allocatable, intent(inout) :: this(:) 57 | integer, intent(in), dimension(:) :: val 58 | call int_array_init(this,size(val)) 59 | this = val 60 | end subroutine 61 | 62 | subroutine wp_array_init(this,n) 63 | real(wp), allocatable, intent(inout) :: this(:) 64 | integer, intent(in) :: n 65 | integer :: istat 66 | if (allocated(this)) then 67 | deallocate(this,stat=istat) 68 | endif 69 | allocate(this(n),stat=istat) 70 | if (istat.ne.0) then 71 | call fatal_error("sp_array_init: could not allocate.",istat) 72 | endif 73 | end subroutine 74 | 75 | subroutine wp_array_init2(this,val) 76 | real(wp), allocatable, intent(inout) :: this(:) 77 | real(wp), intent(in), dimension(:) :: val 78 | call wp_array_init(this,size(val)) 79 | this = val 80 | end subroutine 81 | 82 | subroutine int_array_finalize(this) 83 | integer, allocatable, intent(inout) :: this(:) 84 | integer :: istat=0 85 | if (allocated(this)) then 86 | deallocate(this,stat=istat) 87 | endif 88 | if (istat.ne.0) then 89 | call error("int_array_finalize: could not deallocate.",istat) 90 | endif 91 | end subroutine 92 | 93 | subroutine wp_array_finalize(this) 94 | real(wp), allocatable, intent(inout) :: this(:) 95 | integer :: istat=0 96 | if (allocated(this)) then 97 | deallocate(this,stat=istat) 98 | endif 99 | if (istat.ne.0) then 100 | call error("wp_array_finalize: could not deallocate.",istat) 101 | endif 102 | end subroutine 103 | 104 | ! 105 | ! Error handling 106 | ! 107 | 108 | subroutine error(errormsg,ierror) 109 | character(len=*), intent(in), optional :: errormsg 110 | integer, intent(in), optional :: ierror 111 | if (present(errormsg)) then 112 | write(*,*) 'error: ',errormsg 113 | endif 114 | if (present(ierror)) then 115 | write(*,*) 'error flag=',ierror 116 | endif 117 | end subroutine 118 | 119 | subroutine fatal_error(errormsg,ierror) 120 | character(len=*), intent(in), optional :: errormsg 121 | integer, intent(in), optional :: ierror 122 | if (present(errormsg)) then 123 | write(*,*) 'fatal error: ',errormsg 124 | endif 125 | if (present(ierror)) then 126 | write(*,*) 'error flag=',ierror 127 | endif 128 | write(*,*) 'halting' 129 | stop 1 130 | end subroutine 131 | 132 | end module 133 | -------------------------------------------------------------------------------- /qutipf90mc/zvode/zgesl.f: -------------------------------------------------------------------------------- 1 | subroutine zgesl(a,lda,n,ipvt,b,job) 2 | integer lda,n,ipvt(1),job 3 | complex*16 a(lda,1),b(1) 4 | c 5 | c zgesl solves the complex*16 system 6 | c a * x = b or ctrans(a) * x = b 7 | c using the factors computed by zgeco or zgefa. 8 | c 9 | c on entry 10 | c 11 | c a complex*16(lda, n) 12 | c the output from zgeco or zgefa. 13 | c 14 | c lda integer 15 | c the leading dimension of the array a . 16 | c 17 | c n integer 18 | c the order of the matrix a . 19 | c 20 | c ipvt integer(n) 21 | c the pivot vector from zgeco or zgefa. 22 | c 23 | c b complex*16(n) 24 | c the right hand side vector. 25 | c 26 | c job integer 27 | c = 0 to solve a*x = b , 28 | c = nonzero to solve ctrans(a)*x = b where 29 | c ctrans(a) is the conjugate transpose. 30 | c 31 | c on return 32 | c 33 | c b the solution vector x . 34 | c 35 | c error condition 36 | c 37 | c a division by zero will occur if the input factor contains a 38 | c zero on the diagonal. technically this indicates singularity 39 | c but it is often caused by improper arguments or improper 40 | c setting of lda . it will not occur if the subroutines are 41 | c called correctly and if zgeco has set rcond .gt. 0.0 42 | c or zgefa has set info .eq. 0 . 43 | c 44 | c to compute inverse(a) * c where c is a matrix 45 | c with p columns 46 | c call zgeco(a,lda,n,ipvt,rcond,z) 47 | c if (rcond is too small) go to ... 48 | c do 10 j = 1, p 49 | c call zgesl(a,lda,n,ipvt,c(1,j),0) 50 | c 10 continue 51 | c 52 | c linpack. this version dated 08/14/78 . 53 | c cleve moler, university of new mexico, argonne national lab. 54 | c 55 | c subroutines and functions 56 | c 57 | c blas zaxpy,zdotc 58 | c fortran dconjg 59 | c 60 | c internal variables 61 | c 62 | complex*16 zdotc,t 63 | integer k,kb,l,nm1 64 | double precision dreal,dimag 65 | complex*16 zdumr,zdumi 66 | dreal(zdumr) = zdumr 67 | dimag(zdumi) = (0.0d0,-1.0d0)*zdumi 68 | c 69 | nm1 = n - 1 70 | if (job .ne. 0) go to 50 71 | c 72 | c job = 0 , solve a * x = b 73 | c first solve l*y = b 74 | c 75 | if (nm1 .lt. 1) go to 30 76 | do 20 k = 1, nm1 77 | l = ipvt(k) 78 | t = b(l) 79 | if (l .eq. k) go to 10 80 | b(l) = b(k) 81 | b(k) = t 82 | 10 continue 83 | call zaxpy(n-k,t,a(k+1,k),1,b(k+1),1) 84 | 20 continue 85 | 30 continue 86 | c 87 | c now solve u*x = y 88 | c 89 | do 40 kb = 1, n 90 | k = n + 1 - kb 91 | b(k) = b(k)/a(k,k) 92 | t = -b(k) 93 | call zaxpy(k-1,t,a(1,k),1,b(1),1) 94 | 40 continue 95 | go to 100 96 | 50 continue 97 | c 98 | c job = nonzero, solve ctrans(a) * x = b 99 | c first solve ctrans(u)*y = b 100 | c 101 | do 60 k = 1, n 102 | t = zdotc(k-1,a(1,k),1,b(1),1) 103 | b(k) = (b(k) - t)/dconjg(a(k,k)) 104 | 60 continue 105 | c 106 | c now solve ctrans(l)*x = y 107 | c 108 | if (nm1 .lt. 1) go to 90 109 | do 80 kb = 1, nm1 110 | k = n - kb 111 | b(k) = b(k) + zdotc(n-k,a(k+1,k),1,b(k+1),1) 112 | l = ipvt(k) 113 | if (l .eq. k) go to 70 114 | t = b(l) 115 | b(l) = b(k) 116 | b(k) = t 117 | 70 continue 118 | 80 continue 119 | 90 continue 120 | 100 continue 121 | return 122 | end 123 | -------------------------------------------------------------------------------- /qutipf90mc/examples/ex_32.py: -------------------------------------------------------------------------------- 1 | # This is a Monte-Carlo simulation showing the decay of a cavity 2 | # Fock state |1> in a thermal environment with an average 3 | # occupation number of n=0.063. Here, the coupling strength is given 4 | # by the inverse of the cavity ring-down time Tc=0.129. 5 | # 6 | # The parameters chosen here correspond to those from 7 | # S. Gleyzes, et al., Nature 446, 297 (2007). 8 | # 9 | 10 | #load qutip and matplotlib 11 | from qutip import * 12 | from pylab import * 13 | import qutipf90mc as mcf90 14 | 15 | def run(): 16 | # define parameters 17 | N=4 # number of basis states to consider 18 | kappa=1.0/0.129 # coupling to heat bath 19 | nth= 0.063 # temperature with =0.063 20 | 21 | # create operators and initial |1> state 22 | a=destroy(N) # cavity destruction operator 23 | H=a.dag()*a # harmonic oscillator Hamiltonian 24 | psi0=basis(N,1) # initial Fock state with one photon 25 | 26 | # collapse operators 27 | c_op_list = [] 28 | # decay operator 29 | c_op_list.append(sqrt(kappa * (1 + nth)) * a) 30 | # excitation operator 31 | c_op_list.append(sqrt(kappa * nth) * a.dag()) 32 | 33 | # run monte carlo simulation 34 | ntraj=[1,5,15,904] # list of number of trajectories to avg. over 35 | tlist=linspace(0,0.6,100) 36 | mc = mcf90.mcsolve_f90(H,psi0,tlist,c_op_list,[a.dag()*a],ntraj) 37 | #mc = mcsolve(H,psi0,tlist,c_op_list,[a.dag()*a],ntraj) 38 | # get expectation values from mc data (need extra index since ntraj is list) 39 | ex1=mc.expect[0][0] #for ntraj=1 40 | ex5=mc.expect[1][0] #for ntraj=5 41 | ex15=mc.expect[2][0] #for ntraj=15 42 | ex904=mc.expect[3][0] #for ntraj=904 43 | 44 | ## run master equation to get ensemble average expectation values ## 45 | me = mesolve(H,psi0,tlist,c_op_list, [a.dag()*a]) 46 | 47 | # calulate final state using steadystate solver 48 | final_state=steadystate(H,c_op_list) # find steady-state 49 | fexpt=expect(a.dag()*a,final_state) # find expectation value for particle number 50 | 51 | # 52 | # plot results using vertically stacked plots 53 | # 54 | 55 | # set legend fontsize 56 | import matplotlib.font_manager 57 | leg_prop = matplotlib.font_manager.FontProperties(size=10) 58 | 59 | f = figure(figsize=(6,9)) 60 | subplots_adjust(hspace=0.001) #no space between plots 61 | 62 | # subplot 1 (top) 63 | ax1 = subplot(411) 64 | ax1.plot(tlist,ex1,'b',lw=2) 65 | ax1.axhline(y=fexpt,color='k',lw=1.5) 66 | yticks(linspace(0,2,5)) 67 | ylim([-0.1,1.5]) 68 | ylabel('$\left< N \\right>$',fontsize=14) 69 | title("Ensemble Averaging of Monte Carlo Trajectories") 70 | legend(('Single trajectory','steady state'),prop=leg_prop) 71 | 72 | # subplot 2 73 | ax2=subplot(412,sharex=ax1) #share x-axis of subplot 1 74 | ax2.plot(tlist,ex5,'b',lw=2) 75 | ax2.axhline(y=fexpt,color='k',lw=1.5) 76 | yticks(linspace(0,2,5)) 77 | ylim([-0.1,1.5]) 78 | ylabel('$\left< N \\right>$',fontsize=14) 79 | legend(('5 trajectories','steadystate'),prop=leg_prop) 80 | 81 | # subplot 3 82 | ax3=subplot(413,sharex=ax1) #share x-axis of subplot 1 83 | ax3.plot(tlist,ex15,'b',lw=2) 84 | ax3.plot(tlist,me.expect[0],'r--',lw=1.5) 85 | ax3.axhline(y=fexpt,color='k',lw=1.5) 86 | yticks(linspace(0,2,5)) 87 | ylim([-0.1,1.5]) 88 | ylabel('$\left< N \\right>$',fontsize=14) 89 | legend(('15 trajectories','master equation','steady state'),prop=leg_prop) 90 | 91 | # subplot 4 (bottom) 92 | ax4=subplot(414,sharex=ax1) #share x-axis of subplot 1 93 | ax4.plot(tlist,ex904,'b',lw=2) 94 | ax4.plot(tlist,me.expect[0],'r--',lw=1.5) 95 | ax4.axhline(y=fexpt,color='k',lw=1.5) 96 | yticks(linspace(0,2,5)) 97 | ylim([-0.1,1.5]) 98 | ylabel('$\left< N \\right>$',fontsize=14) 99 | legend(('904 trajectories','master equation','steady state'),prop=leg_prop) 100 | 101 | #remove x-axis tick marks from top 3 subplots 102 | xticklabels = ax1.get_xticklabels()+ax2.get_xticklabels()+ax3.get_xticklabels() 103 | setp(xticklabels, visible=False) 104 | 105 | ax1.xaxis.set_major_locator(MaxNLocator(4)) 106 | xlabel('Time (sec)',fontsize=14) 107 | show() 108 | return mc 109 | 110 | 111 | if __name__=="__main__": 112 | run() 113 | -------------------------------------------------------------------------------- /qutipf90mc/zvode/zgbsl.f: -------------------------------------------------------------------------------- 1 | subroutine zgbsl(abd,lda,n,ml,mu,ipvt,b,job) 2 | integer lda,n,ml,mu,ipvt(1),job 3 | complex*16 abd(lda,1),b(1) 4 | c 5 | c zgbsl solves the complex*16 band system 6 | c a * x = b or ctrans(a) * x = b 7 | c using the factors computed by zgbco or zgbfa. 8 | c 9 | c on entry 10 | c 11 | c abd complex*16(lda, n) 12 | c the output from zgbco or zgbfa. 13 | c 14 | c lda integer 15 | c the leading dimension of the array abd . 16 | c 17 | c n integer 18 | c the order of the original matrix. 19 | c 20 | c ml integer 21 | c number of diagonals below the main diagonal. 22 | c 23 | c mu integer 24 | c number of diagonals above the main diagonal. 25 | c 26 | c ipvt integer(n) 27 | c the pivot vector from zgbco or zgbfa. 28 | c 29 | c b complex*16(n) 30 | c the right hand side vector. 31 | c 32 | c job integer 33 | c = 0 to solve a*x = b , 34 | c = nonzero to solve ctrans(a)*x = b , where 35 | c ctrans(a) is the conjugate transpose. 36 | c 37 | c on return 38 | c 39 | c b the solution vector x . 40 | c 41 | c error condition 42 | c 43 | c a division by zero will occur if the input factor contains a 44 | c zero on the diagonal. technically this indicates singularity 45 | c but it is often caused by improper arguments or improper 46 | c setting of lda . it will not occur if the subroutines are 47 | c called correctly and if zgbco has set rcond .gt. 0.0 48 | c or zgbfa has set info .eq. 0 . 49 | c 50 | c to compute inverse(a) * c where c is a matrix 51 | c with p columns 52 | c call zgbco(abd,lda,n,ml,mu,ipvt,rcond,z) 53 | c if (rcond is too small) go to ... 54 | c do 10 j = 1, p 55 | c call zgbsl(abd,lda,n,ml,mu,ipvt,c(1,j),0) 56 | c 10 continue 57 | c 58 | c linpack. this version dated 08/14/78 . 59 | c cleve moler, university of new mexico, argonne national lab. 60 | c 61 | c subroutines and functions 62 | c 63 | c blas zaxpy,zdotc 64 | c fortran dconjg,min0 65 | c 66 | c internal variables 67 | c 68 | complex*16 zdotc,t 69 | integer k,kb,l,la,lb,lm,m,nm1 70 | double precision dreal,dimag 71 | complex*16 zdumr,zdumi 72 | dreal(zdumr) = zdumr 73 | dimag(zdumi) = (0.0d0,-1.0d0)*zdumi 74 | c 75 | m = mu + ml + 1 76 | nm1 = n - 1 77 | if (job .ne. 0) go to 50 78 | c 79 | c job = 0 , solve a * x = b 80 | c first solve l*y = b 81 | c 82 | if (ml .eq. 0) go to 30 83 | if (nm1 .lt. 1) go to 30 84 | do 20 k = 1, nm1 85 | lm = min0(ml,n-k) 86 | l = ipvt(k) 87 | t = b(l) 88 | if (l .eq. k) go to 10 89 | b(l) = b(k) 90 | b(k) = t 91 | 10 continue 92 | call zaxpy(lm,t,abd(m+1,k),1,b(k+1),1) 93 | 20 continue 94 | 30 continue 95 | c 96 | c now solve u*x = y 97 | c 98 | do 40 kb = 1, n 99 | k = n + 1 - kb 100 | b(k) = b(k)/abd(m,k) 101 | lm = min0(k,m) - 1 102 | la = m - lm 103 | lb = k - lm 104 | t = -b(k) 105 | call zaxpy(lm,t,abd(la,k),1,b(lb),1) 106 | 40 continue 107 | go to 100 108 | 50 continue 109 | c 110 | c job = nonzero, solve ctrans(a) * x = b 111 | c first solve ctrans(u)*y = b 112 | c 113 | do 60 k = 1, n 114 | lm = min0(k,m) - 1 115 | la = m - lm 116 | lb = k - lm 117 | t = zdotc(lm,abd(la,k),1,b(lb),1) 118 | b(k) = (b(k) - t)/dconjg(abd(m,k)) 119 | 60 continue 120 | c 121 | c now solve ctrans(l)*x = y 122 | c 123 | if (ml .eq. 0) go to 90 124 | if (nm1 .lt. 1) go to 90 125 | do 80 kb = 1, nm1 126 | k = n - kb 127 | lm = min0(ml,n-k) 128 | b(k) = b(k) + zdotc(lm,abd(m+1,k),1,b(k+1),1) 129 | l = ipvt(k) 130 | if (l .eq. k) go to 70 131 | t = b(l) 132 | b(l) = b(k) 133 | b(k) = t 134 | 70 continue 135 | 80 continue 136 | 90 continue 137 | 100 continue 138 | return 139 | end 140 | -------------------------------------------------------------------------------- /setup.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python 2 | """ 3 | qutipf90mc doc 4 | """ 5 | 6 | DOCLINES = __doc__.split('\n') 7 | 8 | from distutils.core import Command 9 | import os 10 | from glob import glob 11 | from os.path import join 12 | from os.path import splitext, basename, join as pjoin 13 | from unittest import TextTestRunner, TestLoader 14 | 15 | #------ clean command for removing .pyc, .o, .mod and .so files --------# 16 | 17 | class CleanCommand(Command): 18 | user_options = [("all", "a", "All")] 19 | 20 | def initialize_options(self): 21 | self._clean_me_pyc = [] 22 | self._clean_me_o = [] 23 | self._clean_me_so = [] 24 | self._clean_me_mod = [] 25 | self._clean_me_other = [] 26 | self.all = None 27 | for root, dirs, files in os.walk('.'): 28 | for f in files: 29 | if f.endswith('.pyc'): 30 | self._clean_me_pyc.append(pjoin(root, f)) 31 | if f.endswith('.o'): 32 | self._clean_me_o.append(pjoin(root, f)) 33 | if f.endswith('.so'): 34 | self._clean_me_so.append(pjoin(root, f)) 35 | if f.endswith('.mod'): 36 | self._clean_me_mod.append(pjoin(root, f)) 37 | if f=='qutraj_run-f2pywrappers2.f90': 38 | self._clean_me_other.append(pjoin(root, f)) 39 | if f=='qutraj_runmodule.c': 40 | self._clean_me_other.append(pjoin(root, f)) 41 | 42 | def finalize_options(self): 43 | pass 44 | 45 | def run(self): 46 | pyc_rm=0; o_rm=0; so_rm=0; mod_rm=0 47 | for clean_me in self._clean_me_pyc: 48 | try: 49 | os.unlink(clean_me) 50 | except: 51 | pyc_rm+=1 52 | for clean_me in self._clean_me_o: 53 | try: 54 | os.unlink(clean_me) 55 | except: 56 | o_rm+=1 57 | for clean_me in self._clean_me_so: 58 | try: 59 | os.unlink(clean_me) 60 | except: 61 | so_rm+=1 62 | for clean_me in self._clean_me_mod: 63 | try: 64 | os.unlink(clean_me) 65 | except: 66 | mod_rm+=1 67 | if pyc_rm>0: 68 | print("Could not remove "+str(pyc_rm)+" pyc files.") 69 | else: 70 | print("Removed all .pyc files.") 71 | if o_rm>0: 72 | print("Could not remove "+str(o_rm)+" .o files.") 73 | else: 74 | print("Removed all .o files.") 75 | if so_rm>0: 76 | print("Could not remove "+str(so_rm)+" .so files.") 77 | else: 78 | print("Removed all .so files.") 79 | if mod_rm>0: 80 | print("Could not remove "+str(mod_rm)+" .mod files.") 81 | else: 82 | print("Removed all .mod files.") 83 | for clean_me in self._clean_me_other: 84 | try: 85 | os.unlink(clean_me) 86 | print "Removed", clean_me 87 | except: 88 | print "Could not remote", clean_me 89 | 90 | #--------- configuration -------------# 91 | 92 | def configuration(parent_package='',top_path=None): 93 | from numpy.distutils.misc_util import Configuration 94 | from numpy.distutils.system_info import get_info 95 | config = Configuration(None, parent_package, top_path) 96 | config.add_subpackage('qutipf90mc') 97 | config.set_options(ignore_setup_xxx_py=True, 98 | assume_default_configuration=True, 99 | delegate_options_to_subpackages=True, 100 | quiet=True) 101 | return config 102 | 103 | 104 | def setup_package(): 105 | from numpy.distutils.core import setup 106 | try: 107 | setup( 108 | name = 'qutipf90mc', 109 | version = '0.1', 110 | maintainer = "Arne L. Grimsmo", 111 | maintainer_email = "arne.grimsmo@gmail.com", 112 | description = DOCLINES[0], 113 | long_description = "\n".join(DOCLINES[2:]), 114 | url = "", 115 | download_url = "https://github.com/arnelg/qutipf90mc", 116 | license = 'GPL3', 117 | #classifiers=[_f for _f in CLASSIFIERS.split('\n') if _f], 118 | platforms = ["Linux", "Mac OS-X"], 119 | cmdclass = { 'clean': CleanCommand}, 120 | configuration=configuration ) 121 | finally: 122 | #del sys.path[0] 123 | #os.chdir(old_path) 124 | pass 125 | return 126 | 127 | 128 | if __name__ == '__main__': 129 | setup_package() 130 | -------------------------------------------------------------------------------- /qutipf90mc/tester.py: -------------------------------------------------------------------------------- 1 | import numpy as np 2 | import matplotlib.pyplot as plt 3 | import qutip as qt 4 | import qutipf90mc as mcf90 5 | import time 6 | 7 | def ptracetest(): 8 | gamma = 1. 9 | neq = 2 10 | psi0 = qt.basis(neq,neq-1) 11 | psi0 = qt.tensor(psi0,psi0) 12 | H = qt.tensor(qt.sigmax(),qt.sigmay()) 13 | c1 = np.sqrt(gamma)*qt.sigmax() 14 | e1 = np.sqrt(gamma)*qt.sigmaz() 15 | c_ops = [qt.tensor(c1,c1)] 16 | e_ops = [qt.tensor(e1,e1),qt.tensor(c1,c1)] 17 | #e_ops = [] 18 | tlist = np.linspace(0,10,100) 19 | ntraj = 2000 20 | ptrace_sel = [0] 21 | sol_f90 = mcf90.mcsolve_f90(H,psi0,tlist,c_ops,e_ops,ntraj=ntraj, 22 | ptrace_sel=ptrace_sel,calc_entropy=True) 23 | #sol_f90 = mcf90.mcsolve_f90(H,psi0,tlist,c_ops,e_ops,ntraj=ntraj) 24 | #sol_me = qt.mesolve(H,psi0,tlist,c_ops,e_ops) 25 | #exp_f90 = qt.expect(e1,sol_f90.states) 26 | #exp_me = qt.expect(qt.tensor(e1,qt.qeye(neq)),sol_me.states) 27 | #plt.figure() 28 | #plt.plot(tlist,exp_me) 29 | #plt.plot(tlist,exp_f90) 30 | #return sol_f90#,sol_me 31 | 32 | def test(): 33 | gamma = 1. 34 | neq = 2 35 | psi0 = qt.basis(neq,neq-1) 36 | #a = qt.destroy(neq) 37 | #ad = a.dag() 38 | #H = ad*a 39 | #c_ops = [gamma*a] 40 | #e_ops = [ad*a] 41 | H = qt.sigmax() 42 | c_ops = [np.sqrt(gamma)*qt.sigmax()] 43 | #c_ops = [] 44 | e_ops = [qt.sigmam()*qt.sigmap(),qt.sigmap()*qt.sigmam()] 45 | #e_ops = [] 46 | 47 | # Times 48 | T = 2.0 49 | dt = 0.1 50 | nstep = int(T/dt) 51 | tlist = np.linspace(0,T,nstep) 52 | 53 | ntraj=100 54 | 55 | # set options 56 | opts = qt.Odeoptions() 57 | opts.num_cpus=2 58 | #opts.mc_avg = True 59 | #opts.gui=False 60 | #opts.max_step=1000 61 | #opts.atol = 62 | #opts.rtol = 63 | 64 | sol_f90 = qt.Odedata() 65 | start_time = time.time() 66 | sol_f90 = mcf90.mcsolve_f90(H,psi0,tlist,c_ops,e_ops,ntraj=ntraj,options=opts) 67 | print "mcsolve_f90 solutiton took", time.time()-start_time, "s" 68 | 69 | sol_me = qt.Odedata() 70 | start_time = time.time() 71 | sol_me = qt.mesolve(H,psi0,tlist,c_ops,e_ops,options=opts) 72 | print "mesolve solutiton took", time.time()-start_time, "s" 73 | 74 | sol_mc = qt.Odedata() 75 | start_time = time.time() 76 | sol_mc = qt.mcsolve(H,psi0,tlist,c_ops,e_ops,ntraj=ntraj,options=opts) 77 | print "mcsolve solutiton took", time.time()-start_time, "s" 78 | 79 | if (e_ops == []): 80 | e_ops = [qt.sigmam()*qt.sigmap(),qt.sigmap()*qt.sigmam()] 81 | sol_f90expect = [np.array([0.+0.j]*nstep)]*len(e_ops) 82 | sol_mcexpect = [np.array([0.+0.j]*nstep)]*len(e_ops) 83 | sol_meexpect = [np.array([0.+0.j]*nstep)]*len(e_ops) 84 | for i in range(len(e_ops)): 85 | if (not opts.mc_avg): 86 | sol_f90expect[i] = sum([qt.expect(e_ops[i], 87 | sol_f90.states[j]) for j in range(ntraj)])/ntraj 88 | sol_mcexpect[i] = sum([qt.expect(e_ops[i], 89 | sol_mc.states[j]) for j in range(ntraj)])/ntraj 90 | else: 91 | sol_f90expect[i] = qt.expect(e_ops[i],sol_f90.states) 92 | sol_mcexpect[i] = qt.expect(e_ops[i],sol_mc.states) 93 | sol_meexpect[i] = qt.expect(e_ops[i],sol_me.states) 94 | elif (not opts.mc_avg): 95 | sol_f90expect = sum(sol_f90.expect,0)/ntraj 96 | sol_mcexpect = sum(sol_f90.expect,0)/ntraj 97 | sol_meexpect = sol_me.expect 98 | else: 99 | sol_f90expect = sol_f90.expect 100 | sol_mcexpect = sol_mc.expect 101 | sol_meexpect = sol_me.expect 102 | 103 | plt.figure() 104 | for i in range(len(e_ops)): 105 | plt.plot(tlist,sol_f90expect[i],'b') 106 | plt.plot(tlist,sol_mcexpect[i],'g') 107 | plt.plot(tlist,sol_meexpect[i],'k') 108 | 109 | return sol_f90, sol_mc 110 | 111 | def rundemo(no,fig=False): 112 | """ Run a demo adapted from qutip 113 | 114 | Parameters 115 | ---------- 116 | no : int 117 | Demo number. Available demos are: 118 | 24 - Dynamics of a Heisenberg spin chain 119 | 30 - MC Cavity+Qubig 120 | 31 - Coupled Oscillators 121 | 33 - Trilinear Hamiltonian 122 | 34 - Visualize MC Dissipation 123 | fig : boolean 124 | Open a new pyplot.figure before running demo? Default is False. 125 | 126 | See also qutipf90mc.alldemos. 127 | """ 128 | import qutipf90mc.examples as examples 129 | print 'running demo #',str(no),'from qutip' 130 | raw_input('press a key to continue') 131 | funcstr = 'examples.ex_'+str(no)+'.run()' 132 | ex_code = compile(funcstr,'','exec') 133 | if (fig): plt.figure() 134 | eval(ex_code) 135 | 136 | def alldemos(): 137 | """ 138 | Run all available demos. See also qutipf90mc.rundemo. 139 | """ 140 | rundemo(24,fig=True) 141 | rundemo(30,fig=True) 142 | rundemo(31,fig=True) 143 | rundemo(33) 144 | rundemo(34) 145 | 146 | if __name__ == '__main__': 147 | ptracetest() 148 | -------------------------------------------------------------------------------- /qutipf90mc/linked_list.f90: -------------------------------------------------------------------------------- 1 | module linked_list 2 | ! 3 | ! Linked list module 4 | ! 5 | 6 | use qutraj_precision 7 | 8 | implicit none 9 | 10 | type llnode_real 11 | type(llnode_real), pointer :: next=>null() 12 | real(wp) :: a 13 | end type 14 | 15 | type llnode_int 16 | type(llnode_int), pointer :: next=>null() 17 | integer :: a 18 | end type 19 | 20 | type linkedlist_real 21 | type(llnode_real), pointer :: head=>null(), tail=>null() 22 | integer :: nelements = 0 23 | end type 24 | 25 | type linkedlist_int 26 | type(llnode_int), pointer :: head=>null(), tail=>null() 27 | integer :: nelements = 0 28 | end type 29 | 30 | interface new 31 | module procedure init_node_real 32 | module procedure init_node_int 33 | end interface 34 | 35 | interface finalize 36 | module procedure finalize_ll_real 37 | module procedure finalize_ll_int 38 | end interface 39 | 40 | interface append 41 | module procedure ll_append_real 42 | module procedure ll_append_int 43 | end interface 44 | 45 | interface ll_to_array 46 | module procedure ll_to_array_real 47 | module procedure ll_to_array_int 48 | end interface 49 | 50 | contains 51 | 52 | subroutine init_node_real(node,a) 53 | type(llnode_real), pointer, intent(inout) :: node 54 | real(wp) :: a 55 | allocate(node) 56 | node%a=a 57 | node%next=>null() 58 | end subroutine 59 | 60 | subroutine init_node_int(node,a) 61 | type(llnode_int), pointer, intent(inout) :: node 62 | integer :: a 63 | allocate(node) 64 | node%a=a 65 | node%next=>null() 66 | end subroutine 67 | 68 | subroutine ll_append_real(list, a) 69 | !Add a node to the end of the list. 70 | type(linkedlist_real), intent(inout) :: list 71 | real(wp), intent(in) :: a 72 | type(llnode_real), pointer :: node 73 | call new(node,a) 74 | if (associated(list%head)) then 75 | list%tail%next => node 76 | node%next => null() 77 | list%tail => node 78 | else 79 | list%head => node 80 | list%tail => node 81 | list%tail%next => null() 82 | end if 83 | list%nelements = list%nelements+1 84 | end subroutine 85 | 86 | subroutine ll_append_int(list, a) 87 | !Add a node to the end of the list. 88 | type(linkedlist_int), intent(inout) :: list 89 | integer, intent(in) :: a 90 | type(llnode_int), pointer :: node 91 | call new(node,a) 92 | if (associated(list%head)) then 93 | list%tail%next => node 94 | node%next => null() 95 | list%tail => node 96 | else 97 | list%head => node 98 | list%tail => node 99 | list%tail%next => null() 100 | end if 101 | list%nelements = list%nelements+1 102 | end subroutine 103 | 104 | subroutine ll_to_array_real(list, table) 105 | ! Makes an array out of the list 106 | ! while deleting the list nodes! 107 | type(linkedlist_real), intent(inout) :: list 108 | real(wp), allocatable, intent(out) :: table(:) 109 | type(llnode_real), pointer :: move, tmp 110 | integer :: i 111 | ! Check if empty. 112 | if (.not. associated(list%head)) then 113 | return 114 | else 115 | ! Allocate table 116 | allocate(table(list%nelements)) 117 | ! Load the table with the list. 118 | move=>list%head 119 | do i=1, list%nelements 120 | table(i)=move%a 121 | if (associated(move%next)) then 122 | tmp=>move 123 | move=>move%next 124 | deallocate(tmp) 125 | nullify(tmp) 126 | endif 127 | end do 128 | list%head => null() 129 | list%tail => null() 130 | end if 131 | end subroutine 132 | 133 | subroutine ll_to_array_int(list, table) 134 | ! Makes an array out of the list 135 | ! while deleting the list nodes! 136 | type(linkedlist_int), intent(inout) :: list 137 | integer, allocatable, intent(out) :: table(:) 138 | type(llnode_int), pointer :: move, tmp 139 | integer :: i 140 | ! Check if empty. 141 | if (.not. associated(list%head)) then 142 | return 143 | else 144 | ! Allocate table 145 | allocate(table(list%nelements)) 146 | ! Load the table with the list. 147 | move=>list%head 148 | do i=1, list%nelements 149 | table(i)=move%a 150 | if (associated(move%next)) then 151 | tmp=>move 152 | move=>move%next 153 | deallocate(tmp) 154 | nullify(tmp) 155 | endif 156 | end do 157 | list%head => null() 158 | list%tail => null() 159 | end if 160 | end subroutine 161 | 162 | !Delete all elements in a list. Leaves the list initialized. 163 | subroutine finalize_ll_real(list) 164 | implicit none 165 | type(linkedlist_real), intent(inout) :: list 166 | type(llnode_real), pointer :: move 167 | do 168 | !Check if list empty. 169 | if (.not. associated(list%head)) then 170 | exit 171 | else 172 | !Check if more than 1 node. 173 | if (associated(list%head%next)) then !more than one node. 174 | move => list%head 175 | list%head => list%head%next 176 | move%next => null() 177 | else 178 | move => list%head 179 | list%head => null() 180 | list%tail => null() 181 | end if 182 | !call ll_del_first(list,move) 183 | deallocate(move) 184 | nullify(move) 185 | end if 186 | end do 187 | end subroutine 188 | 189 | subroutine finalize_ll_int(list) 190 | implicit none 191 | type(linkedlist_int), intent(inout) :: list 192 | type(llnode_int), pointer :: move 193 | do 194 | !Check if list empty. 195 | if (.not. associated(list%head)) then 196 | exit 197 | else 198 | !Check if more than 1 node. 199 | if (associated(list%head%next)) then !more than one node. 200 | move => list%head 201 | list%head => list%head%next 202 | move%next => null() 203 | else 204 | move => list%head 205 | list%head => null() 206 | list%tail => null() 207 | end if 208 | !call ll_del_first(list,move) 209 | deallocate(move) 210 | nullify(move) 211 | end if 212 | end do 213 | end subroutine 214 | 215 | end module linked_list 216 | 217 | 218 | 219 | 220 | 221 | 222 | 223 | 224 | 225 | 226 | 227 | 228 | 229 | 230 | 231 | 232 | 233 | 234 | 235 | 236 | 237 | 238 | 239 | 240 | 241 | 242 | -------------------------------------------------------------------------------- /qutipf90mc/zvode/zgbfa.f: -------------------------------------------------------------------------------- 1 | subroutine zgbfa(abd,lda,n,ml,mu,ipvt,info) 2 | integer lda,n,ml,mu,ipvt(1),info 3 | complex*16 abd(lda,1) 4 | c 5 | c zgbfa factors a complex*16 band matrix by elimination. 6 | c 7 | c zgbfa is usually called by zgbco, but it can be called 8 | c directly with a saving in time if rcond is not needed. 9 | c 10 | c on entry 11 | c 12 | c abd complex*16(lda, n) 13 | c contains the matrix in band storage. the columns 14 | c of the matrix are stored in the columns of abd and 15 | c the diagonals of the matrix are stored in rows 16 | c ml+1 through 2*ml+mu+1 of abd . 17 | c see the comments below for details. 18 | c 19 | c lda integer 20 | c the leading dimension of the array abd . 21 | c lda must be .ge. 2*ml + mu + 1 . 22 | c 23 | c n integer 24 | c the order of the original matrix. 25 | c 26 | c ml integer 27 | c number of diagonals below the main diagonal. 28 | c 0 .le. ml .lt. n . 29 | c 30 | c mu integer 31 | c number of diagonals above the main diagonal. 32 | c 0 .le. mu .lt. n . 33 | c more efficient if ml .le. mu . 34 | c on return 35 | c 36 | c abd an upper triangular matrix in band storage and 37 | c the multipliers which were used to obtain it. 38 | c the factorization can be written a = l*u where 39 | c l is a product of permutation and unit lower 40 | c triangular matrices and u is upper triangular. 41 | c 42 | c ipvt integer(n) 43 | c an integer vector of pivot indices. 44 | c 45 | c info integer 46 | c = 0 normal value. 47 | c = k if u(k,k) .eq. 0.0 . this is not an error 48 | c condition for this subroutine, but it does 49 | c indicate that zgbsl will divide by zero if 50 | c called. use rcond in zgbco for a reliable 51 | c indication of singularity. 52 | c 53 | c band storage 54 | c 55 | c if a is a band matrix, the following program segment 56 | c will set up the input. 57 | c 58 | c ml = (band width below the diagonal) 59 | c mu = (band width above the diagonal) 60 | c m = ml + mu + 1 61 | c do 20 j = 1, n 62 | c i1 = max0(1, j-mu) 63 | c i2 = min0(n, j+ml) 64 | c do 10 i = i1, i2 65 | c k = i - j + m 66 | c abd(k,j) = a(i,j) 67 | c 10 continue 68 | c 20 continue 69 | c 70 | c this uses rows ml+1 through 2*ml+mu+1 of abd . 71 | c in addition, the first ml rows in abd are used for 72 | c elements generated during the triangularization. 73 | c the total number of rows needed in abd is 2*ml+mu+1 . 74 | c the ml+mu by ml+mu upper left triangle and the 75 | c ml by ml lower right triangle are not referenced. 76 | c 77 | c linpack. this version dated 08/14/78 . 78 | c cleve moler, university of new mexico, argonne national lab. 79 | c 80 | c subroutines and functions 81 | c 82 | c blas zaxpy,zscal,izamax 83 | c fortran dabs,max0,min0 84 | c 85 | c internal variables 86 | c 87 | complex*16 t 88 | integer i,izamax,i0,j,ju,jz,j0,j1,k,kp1,l,lm,m,mm,nm1 89 | c 90 | complex*16 zdum 91 | double precision cabs1 92 | double precision dreal,dimag 93 | complex*16 zdumr,zdumi 94 | dreal(zdumr) = zdumr 95 | dimag(zdumi) = (0.0d0,-1.0d0)*zdumi 96 | cabs1(zdum) = dabs(dreal(zdum)) + dabs(dimag(zdum)) 97 | c 98 | m = ml + mu + 1 99 | info = 0 100 | c 101 | c zero initial fill-in columns 102 | c 103 | j0 = mu + 2 104 | j1 = min0(n,m) - 1 105 | if (j1 .lt. j0) go to 30 106 | do 20 jz = j0, j1 107 | i0 = m + 1 - jz 108 | do 10 i = i0, ml 109 | abd(i,jz) = (0.0d0,0.0d0) 110 | 10 continue 111 | 20 continue 112 | 30 continue 113 | jz = j1 114 | ju = 0 115 | c 116 | c gaussian elimination with partial pivoting 117 | c 118 | nm1 = n - 1 119 | if (nm1 .lt. 1) go to 130 120 | do 120 k = 1, nm1 121 | kp1 = k + 1 122 | c 123 | c zero next fill-in column 124 | c 125 | jz = jz + 1 126 | if (jz .gt. n) go to 50 127 | if (ml .lt. 1) go to 50 128 | do 40 i = 1, ml 129 | abd(i,jz) = (0.0d0,0.0d0) 130 | 40 continue 131 | 50 continue 132 | c 133 | c find l = pivot index 134 | c 135 | lm = min0(ml,n-k) 136 | l = izamax(lm+1,abd(m,k),1) + m - 1 137 | ipvt(k) = l + k - m 138 | c 139 | c zero pivot implies this column already triangularized 140 | c 141 | if (cabs1(abd(l,k)) .eq. 0.0d0) go to 100 142 | c 143 | c interchange if necessary 144 | c 145 | if (l .eq. m) go to 60 146 | t = abd(l,k) 147 | abd(l,k) = abd(m,k) 148 | abd(m,k) = t 149 | 60 continue 150 | c 151 | c compute multipliers 152 | c 153 | t = -(1.0d0,0.0d0)/abd(m,k) 154 | call zscal(lm,t,abd(m+1,k),1) 155 | c 156 | c row elimination with column indexing 157 | c 158 | ju = min0(max0(ju,mu+ipvt(k)),n) 159 | mm = m 160 | if (ju .lt. kp1) go to 90 161 | do 80 j = kp1, ju 162 | l = l - 1 163 | mm = mm - 1 164 | t = abd(l,j) 165 | if (l .eq. mm) go to 70 166 | abd(l,j) = abd(mm,j) 167 | abd(mm,j) = t 168 | 70 continue 169 | call zaxpy(lm,t,abd(m+1,k),1,abd(mm+1,j),1) 170 | 80 continue 171 | 90 continue 172 | go to 110 173 | 100 continue 174 | info = k 175 | 110 continue 176 | 120 continue 177 | 130 continue 178 | ipvt(n) = n 179 | if (cabs1(abd(m,n)) .eq. 0.0d0) info = n 180 | return 181 | end 182 | -------------------------------------------------------------------------------- /qutipf90mc/qutraj_run.pyf: -------------------------------------------------------------------------------- 1 | ! -*- f90 -*- 2 | ! Note: the context of this file is case sensitive. 3 | 4 | python module qutraj_run ! in 5 | interface ! in :qutraj_run 6 | module qutraj_run ! in :qutraj_run:qutraj_run.f90 7 | use qutraj_precision 8 | use qutraj_general 9 | use qutraj_hilbert 10 | use qutraj_evolve 11 | use qutraj_linalg 12 | use mt19937 13 | use linked_list 14 | integer, optional :: ntraj=1 15 | integer, optional :: unravel_type=2 16 | logical, optional :: mc_avg = .true. 17 | double precision, allocatable,dimension(:) :: tlist 18 | integer, optional :: order=0 19 | integer, optional :: nsteps=0 20 | double precision, optional :: first_step=0 21 | double precision, optional :: min_step=0 22 | double precision, optional :: max_step=0 23 | complex(kind=wp), allocatable,dimension(:) :: psi0 24 | !integer, optional :: norm_steps=5 25 | !real(kind=wp), optional :: norm_tol=0.001 26 | logical, optional :: rho_return_sparse = .true. 27 | complex(kind=wp), allocatable,dimension(:,:,:,:) :: sol 28 | complex(kind=wp), allocatable,dimension(:) :: csr_val 29 | integer, allocatable,dimension(:) :: csr_col 30 | integer, allocatable,dimension(:) :: csr_ptr 31 | integer :: csr_nrows 32 | integer :: csr_ncols 33 | real(kind=wp), allocatable,dimension(:) :: col_times 34 | integer, allocatable,dimension(:) :: col_which 35 | integer, allocatable,dimension(:) :: psi0_dims1 36 | integer, allocatable,dimension(:) :: ptrace_sel 37 | integer :: rho_reduced_dim 38 | logical, optional :: calc_entropy = .false. 39 | real(kind=wp), allocatable,dimension(:) :: reduced_state_entropy 40 | subroutine init_tlist(val,n) ! in :qutraj_run:qutraj_run.f90:qutraj_run 41 | use qutraj_precision 42 | real(kind=wp) dimension(n),intent(in) :: val 43 | integer, optional,intent(in),check(len(val)>=n),depend(val) :: n=len(val) 44 | end subroutine init_tlist 45 | subroutine init_psi0(val,n) ! in :qutraj_run:qutraj_run.f90:qutraj_run 46 | use qutraj_precision 47 | complex(kind=wp) dimension(n),intent(in) :: val 48 | integer, optional,intent(in),check(len(val)>=n),depend(val) :: n=len(val) 49 | end subroutine init_psi0 50 | subroutine init_ptrace_stuff(dims,sel,reduced_dim,ndims,nsel) ! in :qutraj_run:qutraj_run.f90:qutraj_run 51 | integer dimension(ndims),intent(in) :: dims 52 | integer dimension(nsel),intent(in) :: sel 53 | integer,intent(in) :: reduced_dim 54 | integer, optional,intent(in),check(len(dims)>=ndims),depend(dims) :: ndims=len(dims) 55 | integer, optional,intent(in),check(len(sel)>=nsel),depend(sel) :: nsel=len(sel) 56 | end subroutine init_ptrace_stuff 57 | subroutine init_hamiltonian(val,col,ptr,m,k,nnz,nptr) ! in :qutraj_run:qutraj_run.f90:qutraj_run 58 | use qutraj_precision 59 | complex(kind=wp) dimension(nnz),intent(in) :: val 60 | integer dimension(nnz),intent(in),depend(nnz) :: col 61 | integer dimension(nptr),intent(in) :: ptr 62 | integer intent(in) :: m 63 | integer intent(in) :: k 64 | integer, optional,intent(in),check(len(val)>=nnz),depend(val) :: nnz=len(val) 65 | integer, optional,intent(in),check(len(ptr)>=nptr),depend(ptr) :: nptr=len(ptr) 66 | !integer intent(in) :: nnz 67 | !integer intent(in) :: nptr 68 | end subroutine init_hamiltonian 69 | subroutine init_c_ops(i,n,val,col,ptr,m,k,first,nnz,nptr) ! in :qutraj_run:qutraj_run.f90:qutraj_run 70 | use qutraj_precision 71 | integer intent(in) :: i 72 | integer intent(in) :: n 73 | complex(kind=wp) dimension(nnz),intent(in) :: val 74 | integer dimension(nnz),intent(in),depend(nnz) :: col 75 | integer dimension(nptr),intent(in) :: ptr 76 | integer intent(in) :: m 77 | integer intent(in) :: k 78 | integer, optional,intent(in),check(len(val)>=nnz),depend(val) :: nnz=len(val) 79 | integer, optional,intent(in),check(len(ptr)>=nptr),depend(ptr) :: nptr=len(ptr) 80 | logical, optional :: first 81 | end subroutine init_c_ops 82 | subroutine init_e_ops(i,n,val,col,ptr,m,k,first,nnz,nptr) ! in :qutraj_run:qutraj_run.f90:qutraj_run 83 | use qutraj_precision 84 | integer intent(in) :: i 85 | integer intent(in) :: n 86 | complex(kind=wp) dimension(nnz),intent(in) :: val 87 | integer dimension(nnz),intent(in),depend(nnz) :: col 88 | integer dimension(nptr),intent(in) :: ptr 89 | integer intent(in) :: m 90 | integer intent(in) :: k 91 | integer, optional,intent(in),check(len(val)>=nnz),depend(val) :: nnz=len(val) 92 | integer, optional,intent(in),check(len(ptr)>=nptr),depend(ptr) :: nptr=len(ptr) 93 | logical, optional :: first 94 | end subroutine init_e_ops 95 | subroutine init_odedata(neq,atol,rtol,mf,norm_steps,norm_tol,lzw,lrw,liw,ml,mu,natol,nrtol) ! in :qutraj_run:qutraj_run.f90:qutraj_run 96 | use qutraj_precision 97 | integer intent(in) :: neq 98 | double precision dimension(natol),intent(in) :: atol 99 | double precision dimension(nrtol),intent(in) :: rtol 100 | integer, optional,intent(in) :: mf = 0 101 | integer, optional,intent(in) :: norm_steps = 0 102 | real(kind=wp), optional,intent(in) :: norm_tol = 0.0 103 | integer, optional,intent(in) :: lzw = 0 104 | integer, optional,intent(in) :: lrw = 0 105 | integer, optional,intent(in) :: liw = 0 106 | integer, optional,intent(in) :: ml = 0 107 | integer, optional,intent(in) :: mu = 0 108 | integer, optional,intent(in),check(len(atol)>=natol),depend(atol) :: natol=len(atol) 109 | integer, optional,intent(in),check(len(rtol)>=nrtol),depend(rtol) :: nrtol=len(rtol) 110 | end subroutine init_odedata 111 | subroutine get_rho_sparse(i) 112 | integer intent(in) :: i 113 | end subroutine get_rho_sparse 114 | subroutine get_collapses(traj) 115 | integer intent(in) :: traj 116 | end subroutine get_collapses 117 | subroutine evolve(instanceno,rngseed) ! in :qutraj_run:qutraj_run.f90:qutraj_run 118 | integer intent(in) :: instanceno 119 | integer intent(in) :: rngseed 120 | end subroutine evolve 121 | subroutine finalize_work ! in :qutraj_run:qutraj_run.f90:qutraj_run 122 | end subroutine finalize_work 123 | subroutine finalize_sol ! in :qutraj_run:qutraj_run.f90:qutraj_run 124 | end subroutine finalize_sol 125 | subroutine test_real_precision ! in :qutraj_run:qutraj_run.f90:qutraj_run 126 | use qutraj_precision 127 | end subroutine test_real_precision 128 | end module qutraj_run 129 | end python module qutraj_run 130 | -------------------------------------------------------------------------------- /qutipf90mc/mt19937.f90: -------------------------------------------------------------------------------- 1 | ! A Fortran-program for MT19937: Real number version 2 | 3 | ! Code converted using TO_F90 by Alan Miller 4 | ! Date: 1999-11-26 Time: 17:09:23 5 | ! Latest revision - 5 February 2002 6 | ! A new seed initialization routine has been added based upon the new 7 | ! C version dated 26 January 2002. 8 | ! This version assumes that integer overflows do NOT cause crashes. 9 | ! This version is compatible with Lahey's ELF90 compiler, 10 | ! and should be compatible with most full Fortran 90 or 95 compilers. 11 | ! Notice the strange way in which umask is specified for ELF90. 12 | 13 | ! genrand() generates one pseudorandom real number (double) which is 14 | ! uniformly distributed on [0,1]-interval, for each call. 15 | ! sgenrand(seed) set initial values to the working area of 624 words. 16 | ! Before genrand(), sgenrand(seed) must be called once. (seed is any 32-bit 17 | ! integer except for 0). 18 | ! Integer generator is obtained by modifying two lines. 19 | ! Coded by Takuji Nishimura, considering the suggestions by 20 | ! Topher Cooper and Marc Rieffel in July-Aug. 1997. 21 | 22 | ! This library is free software; you can redistribute it and/or modify it 23 | ! under the terms of the GNU Library General Public License as published by 24 | ! the Free Software Foundation; either version 2 of the License, or (at your 25 | ! option) any later version. This library is distributed in the hope that 26 | ! it will be useful, but WITHOUT ANY WARRANTY; without even the implied 27 | ! warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 28 | ! See the GNU Library General Public License for more details. 29 | ! You should have received a copy of the GNU Library General Public License 30 | ! along with this library; if not, write to the Free Foundation, Inc., 31 | ! 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 32 | 33 | ! Copyright (C) 1997 Makoto Matsumoto and Takuji Nishimura. 34 | ! When you use this, send an email to: matumoto@math.keio.ac.jp 35 | ! with an appropriate reference to your work. 36 | 37 | !*********************************************************************** 38 | ! Fortran translation by Hiroshi Takano. Jan. 13, 1999. 39 | 40 | ! genrand() -> double precision function grnd() 41 | ! sgenrand(seed) -> subroutine sgrnd(seed) 42 | ! integer seed 43 | 44 | ! This program uses the following standard intrinsics. 45 | ! ishft(i,n): If n > 0, shifts bits in i by n positions to left. 46 | ! If n < 0, shifts bits in i by n positions to right. 47 | ! iand (i,j): Performs logical AND on corresponding bits of i and j. 48 | ! ior (i,j): Performs inclusive OR on corresponding bits of i and j. 49 | ! ieor (i,j): Performs exclusive OR on corresponding bits of i and j. 50 | 51 | !*********************************************************************** 52 | 53 | MODULE mt19937 54 | use qutraj_precision 55 | 56 | IMPLICIT NONE 57 | !INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(12, 60) 58 | 59 | ! Period parameters 60 | INTEGER, PARAMETER :: n = 624, n1 = n+1, m = 397, mata = -1727483681 61 | ! constant vector a 62 | INTEGER, PARAMETER :: umask = -2147483647 - 1 63 | ! most significant w-r bits 64 | INTEGER, PARAMETER :: lmask = 2147483647 65 | ! least significant r bits 66 | ! Tempering parameters 67 | INTEGER, PARAMETER :: tmaskb= -1658038656, tmaskc= -272236544 68 | 69 | ! the array for the state vector 70 | INTEGER, SAVE :: mt(0:n-1), mti = n1 71 | ! mti==N+1 means mt[N] is not initialized 72 | 73 | PRIVATE 74 | PUBLIC :: dp, sgrnd, grnd, init_genrand 75 | 76 | CONTAINS 77 | 78 | 79 | SUBROUTINE sgrnd(seed) 80 | ! This is the original version of the seeding routine. 81 | ! It was replaced in the Japanese version in C on 26 January 2002 82 | ! It is recommended that routine init_genrand is used instead. 83 | 84 | INTEGER, INTENT(IN) :: seed 85 | 86 | ! setting initial seeds to mt[N] using the generator Line 25 of Table 1 in 87 | ! [KNUTH 1981, The Art of Computer Programming Vol. 2 (2nd Ed.), pp102] 88 | 89 | mt(0)= IAND(seed, -1) 90 | DO mti=1,n-1 91 | mt(mti) = IAND(69069 * mt(mti-1), -1) 92 | END DO 93 | 94 | RETURN 95 | END SUBROUTINE sgrnd 96 | !*********************************************************************** 97 | 98 | SUBROUTINE init_genrand(seed) 99 | ! This initialization is based upon the multiplier given on p.106 of the 100 | ! 3rd edition of Knuth, The Art of Computer Programming Vol. 2. 101 | 102 | ! This version assumes that integer overflow does NOT cause a crash. 103 | 104 | INTEGER, INTENT(IN) :: seed 105 | 106 | INTEGER :: latest 107 | 108 | mt(0) = seed 109 | latest = seed 110 | DO mti = 1, n-1 111 | latest = IEOR( latest, ISHFT( latest, -30 ) ) 112 | latest = latest * 1812433253 + mti 113 | mt(mti) = latest 114 | END DO 115 | 116 | RETURN 117 | END SUBROUTINE init_genrand 118 | !*********************************************************************** 119 | 120 | FUNCTION grnd() RESULT(fn_val) 121 | use qutraj_precision 122 | REAL (dp) :: fn_val 123 | 124 | INTEGER, SAVE :: mag01(0:1) = (/ 0, mata /) 125 | ! mag01(x) = x * MATA for x=0,1 126 | INTEGER :: kk, y 127 | 128 | ! These statement functions have been replaced with separate functions 129 | ! tshftu(y) = ISHFT(y,-11) 130 | ! tshfts(y) = ISHFT(y,7) 131 | ! tshftt(y) = ISHFT(y,15) 132 | ! tshftl(y) = ISHFT(y,-18) 133 | 134 | IF(mti >= n) THEN 135 | ! generate N words at one time 136 | IF(mti == n+1) THEN 137 | ! if sgrnd() has not been called, 138 | CALL sgrnd(4357) 139 | ! a default initial seed is used 140 | END IF 141 | 142 | DO kk = 0, n-m-1 143 | y = IOR(IAND(mt(kk),umask), IAND(mt(kk+1),lmask)) 144 | mt(kk) = IEOR(IEOR(mt(kk+m), ISHFT(y,-1)),mag01(IAND(y,1))) 145 | END DO 146 | DO kk = n-m, n-2 147 | y = IOR(IAND(mt(kk),umask), IAND(mt(kk+1),lmask)) 148 | mt(kk) = IEOR(IEOR(mt(kk+(m-n)), ISHFT(y,-1)),mag01(IAND(y,1))) 149 | END DO 150 | y = IOR(IAND(mt(n-1),umask), IAND(mt(0),lmask)) 151 | mt(n-1) = IEOR(IEOR(mt(m-1), ISHFT(y,-1)),mag01(IAND(y,1))) 152 | mti = 0 153 | END IF 154 | 155 | y = mt(mti) 156 | mti = mti + 1 157 | y = IEOR(y, tshftu(y)) 158 | y = IEOR(y, IAND(tshfts(y),tmaskb)) 159 | y = IEOR(y, IAND(tshftt(y),tmaskc)) 160 | y = IEOR(y, tshftl(y)) 161 | 162 | IF(y < 0) THEN 163 | fn_val = (DBLE(y) + 2.0D0**32) / (2.0D0**32 - 1.0D0) 164 | ELSE 165 | fn_val = DBLE(y) / (2.0D0**32 - 1.0D0) 166 | END IF 167 | 168 | RETURN 169 | END FUNCTION grnd 170 | 171 | 172 | FUNCTION tshftu(y) RESULT(fn_val) 173 | INTEGER, INTENT(IN) :: y 174 | INTEGER :: fn_val 175 | 176 | fn_val = ISHFT(y,-11) 177 | RETURN 178 | END FUNCTION tshftu 179 | 180 | 181 | FUNCTION tshfts(y) RESULT(fn_val) 182 | INTEGER, INTENT(IN) :: y 183 | INTEGER :: fn_val 184 | 185 | fn_val = ISHFT(y,7) 186 | RETURN 187 | END FUNCTION tshfts 188 | 189 | 190 | FUNCTION tshftt(y) RESULT(fn_val) 191 | INTEGER, INTENT(IN) :: y 192 | INTEGER :: fn_val 193 | 194 | fn_val = ISHFT(y,15) 195 | RETURN 196 | END FUNCTION tshftt 197 | 198 | 199 | FUNCTION tshftl(y) RESULT(fn_val) 200 | INTEGER, INTENT(IN) :: y 201 | INTEGER :: fn_val 202 | 203 | fn_val = ISHFT(y,-18) 204 | RETURN 205 | END FUNCTION tshftl 206 | 207 | END MODULE mt19937 208 | 209 | 210 | 211 | ! this main() outputs the first 1000 generated numbers 212 | PROGRAM main 213 | USE mt19937 214 | IMPLICIT NONE 215 | 216 | INTEGER, PARAMETER :: no = 1000 217 | INTEGER :: count, j, k, seed 218 | REAL (dp) :: temp, r(0:7), big, small, average, sumsq, stdev 219 | 220 | ! call sgrnd(4357) 221 | ! any nonzero integer can be used as a seed 222 | WRITE(*, '(a)', ADVANCE='NO') ' Enter integer random number seed: ' 223 | READ(*, *) seed 224 | CALL init_genrand(seed) 225 | WRITE(*, *) 'Seed = ', seed 226 | 227 | big = 0.5_dp 228 | small = 0.5_dp 229 | count = 0 230 | average = 0.0_dp 231 | sumsq = 0.0_dp 232 | 233 | DO j=0,no-1 234 | temp = grnd() 235 | IF (temp > big) THEN 236 | big = temp 237 | ELSE IF (temp < small) THEN 238 | small = temp 239 | END IF 240 | CALL update(temp, count, average, sumsq) 241 | r(MOD(j,8)) = temp 242 | IF(MOD(j,8) == 7) THEN 243 | WRITE(*, '(8(f8.6, '' ''))') r(0:7) 244 | ELSE IF(j == no-1) THEN 245 | WRITE(*, '(8(f8.6, '' ''))') (r(k),k=0,MOD(no-1,8)) 246 | END IF 247 | END DO 248 | 249 | stdev = SQRT( sumsq / (count - 1) ) 250 | WRITE(*, '(a, f10.6, a, f10.6)') ' Smallest = ', small, ' Largest = ', big 251 | WRITE(*, '(a, f9.5, a, f9.5)') ' Average = ', average, ' Std. devn. = ', stdev 252 | WRITE(*, *) ' Std. devn. should be about 1/sqrt(12) = 0.288675' 253 | 254 | STOP 255 | 256 | 257 | CONTAINS 258 | 259 | 260 | SUBROUTINE update(x, n, avge, sumsq) 261 | REAL (dp), INTENT(IN) :: x 262 | INTEGER, INTENT(IN OUT) :: n 263 | REAL (dp), INTENT(IN OUT) :: avge, sumsq 264 | 265 | REAL (dp) :: dev 266 | 267 | n = n + 1 268 | dev = x - avge 269 | avge = avge + dev / n 270 | sumsq = sumsq + dev*(x - avge) 271 | 272 | RETURN 273 | END SUBROUTINE update 274 | 275 | END PROGRAM main 276 | !*********************************************************************** 277 | -------------------------------------------------------------------------------- /qutipf90mc/qutraj_evolve.f90: -------------------------------------------------------------------------------- 1 | module qutraj_evolve 2 | use qutraj_precision 3 | use qutraj_general 4 | use qutraj_hilbert 5 | use linked_list 6 | use mt19937 7 | 8 | implicit none 9 | 10 | ! 11 | ! Types 12 | ! 13 | 14 | type odeoptions 15 | ! No. of ODES 16 | integer :: neq=1 17 | ! work array zwork should have length 15*neq for non-stiff 18 | integer :: lzw = 0 19 | double complex, allocatable :: zwork(:) 20 | ! work array rwork should have length 20+neq for non-siff 21 | integer :: lrw = 0 22 | double precision, allocatable :: rwork(:) 23 | ! work array iwork should have length 30 for non-stiff 24 | integer :: liw = 0 25 | integer, allocatable :: iwork(:) 26 | ! method flag mf should be 10 for non-stiff 27 | integer :: mf = 10 28 | ! arbitrary real/complex and int array for user def input to rhs 29 | double complex :: rpar(1) 30 | integer :: ipar(1) 31 | ! abs. tolerance, rel. tolerance 32 | double precision, allocatable :: atol(:), rtol(:) 33 | ! iopt=number of optional inputs, itol=1 for atol scalar, 2 otherwise 34 | integer :: iopt, itol 35 | ! task and state of solver 36 | integer :: itask, istate 37 | ! tolerance for trying to find correct jump times 38 | integer :: norm_steps = 5 39 | real(wp) :: norm_tol = 0.001 40 | end type 41 | 42 | ! 43 | ! Public data 44 | ! 45 | 46 | type(operat) :: hamilt 47 | type(operat), allocatable :: c_ops(:), e_ops(:) 48 | type(odeoptions) :: ode 49 | 50 | ! Hermitian conjugated operators 51 | type(operat), allocatable :: c_ops_hc(:) 52 | 53 | contains 54 | 55 | ! 56 | ! Evolution subs 57 | ! 58 | 59 | subroutine evolve_nocollapse(t,tout,y,y_tmp,ode) 60 | double complex, intent(inout) :: y(:),y_tmp(:) 61 | double precision, intent(inout) :: t, tout 62 | type(odeoptions) :: ode 63 | 64 | ! integrate up to tout without overshooting 65 | ode%rwork(1) = tout 66 | 67 | call nojump(y,t,tout,ode%itask,ode) 68 | if (ode%istate.lt.0) then 69 | write(*,*) "zvode error: istate=",ode%istate 70 | !stop 71 | endif 72 | end subroutine 73 | 74 | subroutine evolve_jump(t,tout,y,y_tmp,p,mu,nu,& 75 | ll_col_times,ll_col_which,ode) 76 | ! 77 | ! Evolve quantum trajectory y(t) to y(tout) using ``jump'' method 78 | ! 79 | ! Input: t, tout, y 80 | ! Work arrays: y_tmp, p 81 | ! mu, nu: two random numbers 82 | ! 83 | double complex, intent(inout) :: y(:),y_tmp(:) 84 | double precision, intent(inout) :: t, tout 85 | real(wp), intent(inout) :: p(:) 86 | real(wp), intent(inout) :: mu,nu 87 | type(linkedlist_real), intent(inout) :: ll_col_times 88 | type(linkedlist_int), intent(inout) :: ll_col_which 89 | type(odeoptions) :: ode 90 | double precision :: t_prev, t_final, t_guess 91 | integer :: j,k 92 | integer :: cnt 93 | real(wp) :: norm2_psi,norm2_prev,norm2_guess,sump 94 | logical, save :: first = .true. 95 | 96 | ode%rwork(1) = tout 97 | norm2_psi = abs(braket(y,y)) 98 | do while(t in dpsi, for jump-operator c_ops(i) 268 | ! ! B&P p. 331 eq (6.181) 269 | ! complex(wp), intent(in) :: psi(:) 270 | ! complex(wp), intent(out) :: dpsi(:) 271 | ! !complex(wp), allocatable :: psi_tmp(:) 272 | ! integer, intent(in) :: i 273 | ! complex(wp) :: tmp1, tmp2 274 | ! !call new(psi_tmp,size(psi)) 275 | ! tmp1 = braket(psi,c_ops(i)*psi) 276 | ! tmp2 = braket(psi,c_ops(i)*psi) 277 | ! dpsi = 0.5_wp*(tmp1+tmp2)*(c_ops(i)*psi) 278 | ! dpsi = dpsi-(0.5_wp)*(c_ops_hc(i)*(c_ops(i)*psi)) 279 | ! dpsi = dpsi-(0.125_wp*(tmp1+tmp2)*(tmp1+tmp2))*psi 280 | !end subroutine 281 | 282 | !subroutine d2_bp(i,psi,dpsi) 283 | ! ! D2 term from Breuer & Pettruccione 284 | ! ! Return D2 |Psi(t)> in dpsi, for jump-operator c_ops(i) 285 | ! ! B&P p. 331 eq (6.181) 286 | ! complex(wp), intent(in) :: psi(:) 287 | ! complex(wp), intent(out) :: dpsi(:) 288 | ! integer, intent(in) :: i 289 | ! complex(wp) :: tmp1, tmp2 290 | ! tmp1 = braket(psi,c_ops(i)*psi) 291 | ! tmp2 = braket(psi,c_ops_hc(i)*psi) 292 | ! dpsi = c_ops(i)*psi 293 | ! dpsi = dpsi - (0.5_wp*(tmp1+tmp2))*psi 294 | !end subroutine 295 | 296 | end module 297 | 298 | -------------------------------------------------------------------------------- /qutipf90mc/qutraj_run.f90: -------------------------------------------------------------------------------- 1 | ! 2 | ! TODO: 3 | ! 4 | 5 | module qutraj_run 6 | ! 7 | ! This is the main module on the fortran side of things 8 | ! 9 | 10 | use qutraj_precision 11 | use qutraj_general 12 | use qutraj_hilbert 13 | use qutraj_evolve 14 | use qutraj_linalg 15 | use mt19937 16 | use linked_list 17 | 18 | implicit none 19 | 20 | ! 21 | ! Data defining the problem 22 | ! 23 | ! Invisible to python: hamilt, c_ops, e_opts, ode 24 | ! (because f2py can't handle derived types) 25 | ! 26 | 27 | !type(operat) :: hamilt 28 | !type(operat), allocatable :: c_ops(:), e_ops(:) 29 | !type(odeoptions) :: ode 30 | 31 | real(wp), allocatable :: tlist(:) 32 | complex(wp), allocatable :: psi0(:) 33 | 34 | integer :: ntraj=1 35 | !integer :: norm_steps = 5 36 | !real(wp) :: norm_tol = 0.001 37 | integer :: n_c_ops = 0 38 | integer :: n_e_ops = 0 39 | logical :: mc_avg = .true. 40 | 41 | ! Optional ode options, 0 means use default values 42 | integer :: order=0,nsteps=0 43 | double precision :: first_step=0,min_step=0,max_step=0 44 | 45 | ! Solution 46 | ! format: 47 | ! all states: sol(1,trajectory,time,y(:)) 48 | ! all expect: sol(e_ops(i),trajectory,time,expecation value) 49 | ! avg. expect: sol(e_ops(i),1,time,expectation value) 50 | ! if returning averaged dense density matrices: 51 | ! sol(1,time,rho_i,rho_j) 52 | complex(wp), allocatable :: sol(:,:,:,:) 53 | ! if returning averaged density matrices in sparse CSR format, 54 | ! use the following solution array and get_rho_sparse instead. 55 | type(operat), allocatable :: sol_rho(:) 56 | 57 | ! use sparse density matrices during computation? 58 | logical :: rho_return_sparse = .true. 59 | 60 | ! temporary storage for csr matrix, available for python 61 | ! this is needed because you can't send assumed 62 | ! shape arrays to python 63 | complex(wp), allocatable :: csr_val(:) 64 | integer, allocatable :: csr_col(:), csr_ptr(:) 65 | integer :: csr_nrows,csr_ncols 66 | 67 | ! Collapse times and integer denoting which operator did it 68 | ! temporary storage available for python 69 | real(wp), allocatable :: col_times(:) 70 | integer, allocatable :: col_which(:) 71 | ! data stored internally in linked lists, one per trajectory 72 | type(linkedlist_real), allocatable :: ll_col_times(:) 73 | type(linkedlist_int), allocatable :: ll_col_which(:) 74 | 75 | ! Integer denoting the type of unravelling 76 | ! 1 for no collapse operatros 77 | ! 2 for jump unravelling 78 | ! diffusive unravellings to be implemented 79 | integer :: unravel_type = 2 80 | 81 | ! Stuff needed for partial trace 82 | integer, allocatable :: psi0_dims1(:),ptrace_sel(:) 83 | integer :: rho_reduced_dim=0 84 | ! Calculate average entropy of reduced state over trajectories? 85 | logical :: calc_entropy = .false. 86 | real(wp), allocatable :: reduced_state_entropy(:) 87 | 88 | ! 89 | ! Interfaces 90 | ! 91 | 92 | interface finalize 93 | module procedure odeoptions_finalize 94 | end interface 95 | 96 | contains 97 | 98 | ! 99 | ! Initialize problem 100 | ! 101 | 102 | subroutine init_tlist(val,n) 103 | use qutraj_precision 104 | real(wp), intent(in) :: val(n) 105 | integer, intent(in) :: n 106 | call new(tlist,val) 107 | end subroutine 108 | 109 | subroutine init_psi0(val,n) 110 | use qutraj_precision 111 | complex(wp), intent(in) :: val(n) 112 | integer, intent(in) :: n 113 | call new(psi0,val) 114 | end subroutine 115 | 116 | subroutine init_ptrace_stuff(dims,sel,reduced_dim,ndims,nsel) 117 | integer, intent(in) :: dims(ndims),sel(nsel),reduced_dim 118 | integer, intent(in) :: ndims, nsel 119 | !complex(wp), allocatable :: rho(:,:) 120 | !real(wp) :: S 121 | call new(psi0_dims1,dims) 122 | call new(ptrace_sel,sel) 123 | rho_reduced_dim = reduced_dim 124 | !allocate(rho(rho_reduced_dim,rho_reduced_dim)) 125 | !call ptrace_pure(psi0,rho,ptrace_sel,psi0_dims1) 126 | !write(*,*) rho 127 | !call entropy(rho,S) 128 | !write(*,*) S 129 | end subroutine 130 | 131 | subroutine init_hamiltonian(val,col,ptr,m,k,nnz,nptr) 132 | ! Hamiltonian is assumed to be given as 133 | ! -i*(H - i/2 sum c_ops(i)^* c_ops(i)) 134 | use qutraj_precision 135 | integer, intent(in) :: nnz,nptr,m,k 136 | complex(wp), intent(in) :: val(nnz) 137 | integer, intent(in) :: col(nnz),ptr(nptr) 138 | call new(hamilt,val,col,ptr,m,k) 139 | end subroutine 140 | 141 | subroutine init_c_ops(i,n,val,col,ptr,m,k,first,nnz,nptr) 142 | use qutraj_precision 143 | integer, intent(in) :: i,n 144 | integer, intent(in) :: nnz,nptr,m,k 145 | complex(wp), intent(in) :: val(nnz) 146 | integer, intent(in) :: col(nnz),ptr(nptr) 147 | logical, optional :: first 148 | if (.not.present(first)) then 149 | first = .false. 150 | endif 151 | if (first) then 152 | call new(c_ops,n) 153 | endif 154 | if (.not.allocated(c_ops)) then 155 | call error('init_c_ops: c_ops not allocated. call with first=True first.') 156 | endif 157 | n_c_ops = n 158 | call new(c_ops(i),val,col,ptr,m,k) 159 | end subroutine 160 | 161 | subroutine init_e_ops(i,n,val,col,ptr,m,k,first,nnz,nptr) 162 | use qutraj_precision 163 | integer, intent(in) :: i,n 164 | integer, intent(in) :: nnz,nptr,m,k 165 | complex(wp), intent(in) :: val(nnz) 166 | integer, intent(in) :: col(nnz),ptr(nptr) 167 | logical, optional :: first 168 | if (.not.present(first)) then 169 | first = .false. 170 | endif 171 | if (first) then 172 | call new(e_ops,n) 173 | endif 174 | if (.not.allocated(e_ops)) then 175 | call error('init_e_ops: e_ops not allocated. call with first=True first.') 176 | endif 177 | n_e_ops = n 178 | call new(e_ops(i),val,col,ptr,m,k) 179 | end subroutine 180 | 181 | subroutine init_odedata(neq,atol,rtol,mf,norm_steps,norm_tol,& 182 | lzw,lrw,liw,ml,mu,natol,nrtol) 183 | use qutraj_precision 184 | integer, intent(in) :: neq 185 | integer, intent(in), optional :: lzw,lrw,liw,mf,norm_steps 186 | integer, intent(in) :: natol,nrtol 187 | double precision, optional :: atol(1),rtol(1) 188 | real(wp), optional :: norm_tol 189 | integer, intent(in), optional :: ml,mu 190 | integer :: istat 191 | 192 | ode%neq = neq 193 | if (lzw.ne.0) then 194 | ode%lzw = lzw 195 | endif 196 | if (lrw.ne.0) then 197 | ode%lrw = lrw 198 | endif 199 | if (liw.ne.0) then 200 | ode%liw = liw 201 | endif 202 | if (lrw.eq.0) then 203 | ode%lrw = 20+neq 204 | endif 205 | 206 | if (mf==0 .or. mf==10) then 207 | ! assuming non-stiff by default 208 | ode%mf=10 209 | if (lzw.eq.0) then 210 | ode%lzw = 15*neq 211 | endif 212 | if (liw.eq.0) then 213 | ode%liw = 30 214 | endif 215 | elseif (mf==21.or.mf==22) then 216 | ode%mf = mf 217 | if (lzw.eq.0) then 218 | ode%lzw = 8*neq+2*neq**2 219 | endif 220 | if (liw.eq.0) then 221 | ode%liw = 30+neq 222 | endif 223 | elseif (mf==24.or.mf==25) then 224 | ode%mf = mf 225 | if (lzw.eq.0) then 226 | ! mf=24,25 requires ml and mu 227 | ode%lzw = 10*neq + (3*ml + 2*mu)*neq 228 | endif 229 | if (liw.eq.0) then 230 | ode%liw = 30+neq 231 | endif 232 | endif 233 | 234 | call new(ode%zwork,ode%lzw) 235 | call new(ode%rwork,ode%lrw) 236 | call new(ode%iwork,ode%liw) 237 | call new(ode%atol,atol) 238 | call new(ode%rtol,rtol) 239 | if (size(ode%atol)==1) then 240 | ode%itol=1 241 | else 242 | ode%itol=2 243 | endif 244 | ode%iopt = 0 245 | 246 | if (norm_steps.ne.0) ode%norm_steps = norm_steps 247 | if (norm_tol.ne.0.) ode%norm_tol = norm_tol 248 | end subroutine 249 | 250 | subroutine get_rho_sparse(i) 251 | integer, intent(in) :: i 252 | call new(csr_val,sol_rho(i)%a) 253 | call new(csr_col,sol_rho(i)%ia1) 254 | call new(csr_ptr,sol_rho(i)%pb) 255 | csr_nrows = sol_rho(i)%m 256 | csr_ncols = sol_rho(i)%k 257 | end subroutine 258 | 259 | subroutine get_collapses(traj) 260 | integer, intent(in) :: traj 261 | integer :: i 262 | ! Turn linked lists into arrays 263 | call ll_to_array(ll_col_times(traj),col_times) 264 | call ll_to_array(ll_col_which(traj),col_which) 265 | if (traj==ntraj) then 266 | do i=1,ntraj 267 | call finalize(ll_col_times(i)) 268 | call finalize(ll_col_which(i)) 269 | enddo 270 | deallocate(ll_col_times,ll_col_which) 271 | endif 272 | end subroutine 273 | 274 | ! 275 | ! Evolution 276 | ! 277 | 278 | subroutine evolve(instanceno,rngseed) 279 | ! What process # am I? 280 | integer, intent(in) :: instanceno,rngseed 281 | double precision :: t, tout 282 | double complex, allocatable :: y(:),y_tmp(:),rho(:,:) 283 | logical :: states 284 | type(operat) :: rho_sparse 285 | integer :: istat=0,istat2=0,traj,progress 286 | integer :: i,j,l,m,n 287 | real(wp) :: mu,nu,S 288 | real(wp), allocatable :: p(:) 289 | ! ITASK = An index specifying the task to be performed. 290 | ! Input only. ITASK has the following values and meanings. 291 | ! 1 means normal computation of output values of y(t) at 292 | ! t = TOUT (by overshooting and interpolating). 293 | ! 2 means take one step only and return. 294 | ! 3 means stop at the first internal mesh point at or 295 | ! beyond t = TOUT and return. 296 | ! 4 means normal computation of output values of y(t) at 297 | ! t = TOUT but without overshooting t = TCRIT. 298 | ! TCRIT must be input as RWORK(1). TCRIT may be equal to 299 | ! or beyond TOUT, but not behind it in the direction of 300 | ! integration. This option is useful if the problem 301 | ! has a singularity at or beyond t = TCRIT. 302 | ! 5 means take one step, without passing TCRIT, and return. 303 | ! TCRIT must be input as RWORK(1). 304 | ! 305 | ! Note: If ITASK = 4 or 5 and the solver reaches TCRIT 306 | ! (within roundoff), it will return T = TCRIT (exactly) to 307 | ! indicate this (unless ITASK = 4 and TOUT comes before 308 | ! TCRIT, in which case answers at T = TOUT are returned 309 | ! first). 310 | 311 | ! States or expectation values 312 | !if (n_e_ops == 0 .and. .not.calc_entropy) then 313 | if (n_e_ops == 0) then 314 | states = .true. 315 | else 316 | states = .false. 317 | endif 318 | ! Allocate solution array 319 | if (allocated(sol)) then 320 | deallocate(sol,stat=istat) 321 | if (istat.ne.0) then 322 | call error("evolve: could not deallocate.",istat) 323 | endif 324 | endif 325 | if (states) then 326 | if (mc_avg) then 327 | if (rho_return_sparse) then 328 | call new(sol_rho,size(tlist)) 329 | call new(rho_sparse,1,1) 330 | else 331 | if (rho_reduced_dim == 0) then 332 | ! Not doing partial trace 333 | allocate(sol(1,size(tlist),ode%neq,ode%neq),stat=istat) 334 | allocate(rho(ode%neq,ode%neq),stat=istat2) 335 | else 336 | ! Doing partial trace 337 | allocate(sol(1,size(tlist),& 338 | rho_reduced_dim,rho_reduced_dim),stat=istat) 339 | allocate(rho(rho_reduced_dim,rho_reduced_dim),stat=istat2) 340 | endif 341 | sol = (0.,0.) 342 | rho = (0.,0.) 343 | endif 344 | else 345 | allocate(sol(1,ntraj,size(tlist),ode%neq),stat=istat) 346 | sol = (0.,0.) 347 | endif 348 | elseif (n_e_ops>0) then 349 | if (mc_avg) then 350 | allocate(sol(n_e_ops,1,size(tlist),1),stat=istat) 351 | sol = (0.,0.) 352 | else 353 | allocate(sol(n_e_ops,ntraj,size(tlist),1),stat=istat) 354 | sol = (0.,0.) 355 | endif 356 | endif 357 | if (istat.ne.0) call fatal_error("evolve: could not allocate.",istat) 358 | if (istat2.ne.0) call fatal_error("evolve: could not allocate.",& 359 | istat2) 360 | ! Array for average entropy 361 | if (calc_entropy) then 362 | if (.not.allocated(rho)) then 363 | allocate(rho(rho_reduced_dim,rho_reduced_dim),stat=istat2) 364 | endif 365 | call new(reduced_state_entropy,size(tlist)) 366 | reduced_state_entropy = 0. 367 | endif 368 | 369 | ! Allocate linked lists for collapse times and operators 370 | if (allocated(ll_col_times)) then 371 | deallocate(ll_col_times,stat=istat) 372 | if (istat.ne.0) then 373 | call error("evolve: could not deallocate.",istat) 374 | endif 375 | endif 376 | if (allocated(ll_col_times)) then 377 | deallocate(ll_col_times,stat=istat) 378 | if (istat.ne.0) then 379 | call error("evolve: could not deallocate.",istat) 380 | endif 381 | endif 382 | allocate(ll_col_times(ntraj),stat=istat) 383 | if (istat.ne.0) call fatal_error("evolve: could not allocate.",istat) 384 | allocate(ll_col_which(ntraj),stat=istat) 385 | if (istat.ne.0) call fatal_error("evolve: could not allocate.",istat) 386 | 387 | ! Allocate work arrays 388 | call new(y,ode%neq) 389 | call new(y_tmp,ode%neq) 390 | ! Allocate tmp array for jump probabilities 391 | call new(p,n_c_ops) 392 | ! Initalize rng 393 | call init_genrand(rngseed) 394 | 395 | ! Initial ode setup 396 | if (unravel_type==1) then 397 | ! integrate one until specified time, w/o overshooting 398 | ode%itask = 4 399 | elseif (unravel_type==2) then 400 | ! integrate one step at the time, w/o overshooting 401 | ode%itask = 5 402 | endif 403 | ! set optinal arguments 404 | ! see zvode.f 405 | ode%rwork = 0.0 406 | ode%iwork = 0 407 | ode%rwork(5) = first_step 408 | ode%rwork(6) = max_step 409 | ode%rwork(7) = min_step 410 | ode%iwork(5) = order 411 | ode%iwork(6) = nsteps 412 | ode%iopt = 1 413 | ! first call to zvode 414 | ode%istate = 1 415 | 416 | ! Loop over trajectories 417 | progress = 1 418 | do traj=1,ntraj 419 | ! two random numbers 420 | mu = grnd() 421 | nu = grnd() 422 | ! First call to zvode 423 | ode%istate = 1 424 | ! Initial values 425 | y = psi0 426 | ! Initial value of indep. variable 427 | t = tlist(1) 428 | do i=1,size(tlist) 429 | ! Solution wanted at 430 | if (i==1) then 431 | ! found this to be necessary due to round off error 432 | tout = t 433 | else 434 | tout = tlist(i) 435 | endif 436 | select case(unravel_type) 437 | case(1) 438 | call evolve_nocollapse(t,tout,y,y_tmp,ode) 439 | case(2) 440 | call evolve_jump(t,tout,y,y_tmp,p,mu,nu,& 441 | ll_col_times(traj),ll_col_which(traj),ode) 442 | case default 443 | call fatal_error('Unknown unravel type.') 444 | end select 445 | y_tmp = y 446 | call normalize(y_tmp) 447 | 448 | ! Compute solution 449 | if (rho_reduced_dim.ne.0) then 450 | call ptrace_pure(y_tmp,rho,ptrace_sel,psi0_dims1) 451 | endif 452 | if (states) then 453 | if (mc_avg) then 454 | ! construct density matrix 455 | if (rho_return_sparse) then 456 | call densitymatrix_sparse(y_tmp,rho_sparse) 457 | if (traj==1) then 458 | sol_rho(i) = rho_sparse 459 | else 460 | sol_rho(i) = sol_rho(i) + rho_sparse 461 | endif 462 | else 463 | if (rho_reduced_dim == 0) then 464 | call densitymatrix_dense(y_tmp,rho) 465 | !else 466 | ! call ptrace_pure(y_tmp,rho,ptrace_sel,psi0_dims1) 467 | endif 468 | sol(1,i,:,:) = sol(1,i,:,:) + rho 469 | endif 470 | else 471 | sol(1,traj,i,:) = y_tmp 472 | endif 473 | else 474 | if (mc_avg) then 475 | do l=1,n_e_ops 476 | sol(l,1,i,1) = sol(l,1,i,1)+braket(y_tmp,e_ops(l)*y_tmp) 477 | enddo 478 | else 479 | do l=1,n_e_ops 480 | sol(l,traj,i,1) = braket(y_tmp,e_ops(l)*y_tmp) 481 | enddo 482 | endif 483 | endif 484 | if (calc_entropy) then 485 | call entropy(rho,S) 486 | reduced_state_entropy(i) = reduced_state_entropy(i) + S 487 | endif 488 | ! End time loop 489 | enddo 490 | ! Indicate progress 491 | if (instanceno == 1 .and. traj.ge.progress*ntraj/10.0) then 492 | write(*,*) "progress of process 1: ", progress*10, "%" 493 | progress=progress+1 494 | endif 495 | ! End loop over trajectories 496 | enddo 497 | ! Normalize 498 | if (mc_avg) then 499 | if (states .and. rho_return_sparse) then 500 | do j=1,size(sol_rho) 501 | sol_rho(j) = (1._wp/ntraj)*sol_rho(j) 502 | enddo 503 | elseif (allocated(sol)) then 504 | sol = (1._wp/ntraj)*sol 505 | endif 506 | if (calc_entropy) then 507 | reduced_state_entropy = (1._wp/ntraj)*reduced_state_entropy 508 | endif 509 | endif 510 | ! Deallocate 511 | call finalize(y) 512 | call finalize(y_tmp) 513 | call finalize(p) 514 | if (allocated(rho)) then 515 | deallocate(rho) 516 | endif 517 | end subroutine 518 | 519 | ! 520 | ! Misc 521 | ! 522 | 523 | ! Deallocate stuff 524 | 525 | subroutine odeoptions_finalize(this) 526 | type(odeoptions), intent(inout) :: this 527 | integer :: istat 528 | if (allocated(this%zwork)) then 529 | deallocate(this%zwork,stat=istat) 530 | if (istat.ne.0) then 531 | call error("odeoptions_finalize: could not deallocate.",istat) 532 | endif 533 | endif 534 | if (allocated(this%rwork)) then 535 | deallocate(this%rwork,stat=istat) 536 | if (istat.ne.0) then 537 | call error("odeoptions_finalize: could not deallocate.",istat) 538 | endif 539 | endif 540 | if (allocated(this%iwork)) then 541 | deallocate(this%iwork,stat=istat) 542 | if (istat.ne.0) then 543 | call error("odeoptions_finalize: could not deallocate.",istat) 544 | endif 545 | endif 546 | if (allocated(this%atol)) then 547 | deallocate(this%atol,stat=istat) 548 | if (istat.ne.0) then 549 | call error("odeoptions_finalize: could not deallocate.",istat) 550 | endif 551 | endif 552 | if (allocated(this%rtol)) then 553 | deallocate(this%rtol,stat=istat) 554 | if (istat.ne.0) then 555 | call error("odeoptions_finalize: could not deallocate.",istat) 556 | endif 557 | endif 558 | end subroutine 559 | 560 | subroutine finalize_work 561 | integer :: istat=0 562 | call finalize(psi0) 563 | call finalize(hamilt) 564 | call finalize(c_ops) 565 | call finalize(e_ops) 566 | call finalize(ode) 567 | end subroutine 568 | 569 | subroutine finalize_sol 570 | integer :: istat=0 571 | call finalize(tlist) 572 | call finalize(sol_rho) 573 | if (allocated(ll_col_times)) then 574 | deallocate(ll_col_times,stat=istat) 575 | endif 576 | if (istat.ne.0) then 577 | call error("finalize_sol: could not deallocate.",istat) 578 | endif 579 | if (allocated(ll_col_which)) then 580 | deallocate(ll_col_which,stat=istat) 581 | endif 582 | if (istat.ne.0) then 583 | call error("finalize_sol: could not deallocate.",istat) 584 | endif 585 | if (allocated(sol)) then 586 | deallocate(sol,stat=istat) 587 | endif 588 | if (istat.ne.0) then 589 | call error("finalize_sol: could not deallocate.",istat) 590 | endif 591 | end subroutine 592 | 593 | ! Misc 594 | 595 | subroutine test_real_precision 596 | use qutraj_precision 597 | real(wp) :: b,a 598 | integer :: i 599 | write(*,*) "wp=",wp 600 | b = 1.0 601 | a = 1.0 602 | i = 1 603 | do while (b.ne.b+a) 604 | a = a*0.1 605 | if (b==b+a) then 606 | write(*,*) "number of decimals working precision: ",i-1 607 | endif 608 | i = i+1 609 | enddo 610 | end subroutine 611 | 612 | end module 613 | -------------------------------------------------------------------------------- /qutipf90mc/mcsolve_f90.py: -------------------------------------------------------------------------------- 1 | import numpy as np 2 | from qutip import * 3 | import qutraj_run as qtf90 4 | from qutip.odeconfig import odeconfig 5 | from qutip.mcsolve import _mc_data_config 6 | 7 | # Working precision 8 | wpr = dtype(float64) 9 | wpc = dtype(complex128) 10 | 11 | def mcsolve_f90(H,psi0,tlist,c_ops,e_ops,ntraj=500, 12 | options=Odeoptions(),sparse_dms=True,serial=False, 13 | ptrace_sel=[],calc_entropy=False): 14 | """ 15 | Monte-Carlo wave function solver with fortran 90 backend. 16 | Usage is identical to qutip.mcsolve, for problems without explicit 17 | time-dependence, and with some optional input: 18 | 19 | Parameters 20 | ---------- 21 | H : qobj 22 | System Hamiltonian. 23 | psi0 : qobj 24 | Initial state vector 25 | tlist : array_like 26 | Times at which results are recorded. 27 | ntraj : int 28 | Number of trajectories to run. 29 | c_ops : array_like 30 | ``list`` or ``array`` of collapse operators. 31 | e_ops : array_like 32 | ``list`` or ``array`` of operators for calculating expectation values. 33 | options : Odeoptions 34 | Instance of ODE solver options. 35 | sparse_dms : boolean 36 | If averaged density matrices are returned, they will be stored as sparse (Compressed Row Format) matrices during computation if sparse_dms = True (default), and dense matrices otherwise. Dense matrices might be preferable for smaller systems. 37 | serial : boolean 38 | If True (default is False) the solver will not make use of the multiprocessing module, and simply run in serial. 39 | ptrace_sel: list 40 | This optional argument specifies a list of components to keep when returning a partially traced density matrix. This can be convenient for large systems where memory becomes a problem, but you are only interested in parts of the density matrix. 41 | calc_entropy : boolean 42 | If ptrace_sel is specified, calc_entropy=True will have the solver return the averaged entropy over trajectories in results.entropy. This can be interpreted as a measure of entanglement. See Phys. Rev. Lett. 93, 120408 (2004), Phys. Rev. A 86, 022310 (2012). 43 | 44 | Returns 45 | ------- 46 | results : Odedata 47 | Object storing all results from simulation. 48 | 49 | """ 50 | if psi0.type!='ket': 51 | raise Exception("Initial state must be a state vector.") 52 | odeconfig.options = options 53 | #set num_cpus to the value given in qutip.settings 54 | # if none in Odeoptions 55 | if not odeconfig.options.num_cpus: 56 | odeconfig.options.num_cpus=qutip.settings.num_cpus 57 | #set initial value data 58 | if options.tidy: 59 | odeconfig.psi0=psi0.tidyup(options.atol).full() 60 | else: 61 | odeconfig.psi0=psi0.full() 62 | odeconfig.psi0_dims=psi0.dims 63 | odeconfig.psi0_shape=psi0.shape 64 | #set general items 65 | odeconfig.tlist=tlist 66 | if isinstance(ntraj,(list,ndarray)): 67 | print 'mcsolve_f90: Sorry, ntraj as list argument is not supported.' 68 | return 69 | #odeconfig.ntraj=sort(ntraj)[-1] 70 | #ntraj_list = ntraj 71 | else: 72 | odeconfig.ntraj=ntraj 73 | #ntraj_list = [ntraj] 74 | #set norm finding constants 75 | odeconfig.norm_tol=options.norm_tol 76 | odeconfig.norm_steps=options.norm_steps 77 | 78 | if (not options.rhs_reuse): 79 | odeconfig.soft_reset() 80 | # no time dependence 81 | odeconfig.tflag=0 82 | # no gui 83 | odeconfig.options.gui=False 84 | #check for collapse operators 85 | if len(c_ops)>0: 86 | odeconfig.cflag=1 87 | else: 88 | odeconfig.cflag=0 89 | #Configure data 90 | _mc_data_config(H, psi0, [], c_ops, [], [], e_ops, options, odeconfig) 91 | # We don't use the tdfunc structure 92 | odeconfig.tdfunc = None 93 | 94 | # Load Monte Carlo class 95 | mc = _MC_class() 96 | # Set solver type 97 | if (options.method == 'adams'): 98 | mc.mf = 10 99 | elif (options.method == 'bdf'): 100 | mc.mf = 22 101 | else: 102 | print 'Unrecognized method for ode solver, using "adams".' 103 | mc.mf = 10 104 | # store ket and density matrix dims and shape for convenience 105 | mc.psi0_dims = psi0.dims 106 | mc.psi0_shape = psi0.shape 107 | mc.dm_dims = (psi0*psi0.dag()).dims 108 | mc.dm_shape = (psi0*psi0.dag()).shape 109 | # use sparse density matrices during computation? 110 | mc.sparse_dms = sparse_dms 111 | # run in serial? 112 | mc.serial_run = serial 113 | # are we doing a partial trace for returned states? 114 | mc.ptrace_sel = ptrace_sel 115 | if (ptrace_sel != []): 116 | print 'ptrace_sel set to',ptrace_sel 117 | print 'ps. We are using dense density matrices during computation when performing partial trace. Setting sparse_dms = False' 118 | print 'This feature is experimental.' 119 | mc.sparse_dms = False 120 | mc.dm_dims = psi0.ptrace(ptrace_sel).dims 121 | mc.dm_shape = psi0.ptrace(ptrace_sel).shape 122 | if (calc_entropy): 123 | if (ptrace_sel == []): 124 | print 'calc_entropy = True, but ptrace_sel = []. Please set a list of components to keep when calculating average entropy of reduced density matrix in ptrace_sel. Setting calc_entropy = False.' 125 | calc_entropy = False 126 | mc.calc_entropy = calc_entropy 127 | 128 | # construct output Odedata object 129 | output = Odedata() 130 | 131 | # Run 132 | mc.run() 133 | output.states = mc.sol.states 134 | output.expect = mc.sol.expect 135 | output.col_times=mc.sol.col_times 136 | output.col_which=mc.sol.col_which 137 | if (hasattr(mc.sol,'entropy')): 138 | output.entropy = mc.sol.entropy 139 | 140 | output.solver = 'Fortran 90 Monte Carlo solver' 141 | #simulation parameters 142 | output.times=odeconfig.tlist 143 | output.num_expect=odeconfig.e_num 144 | output.num_collapse=odeconfig.c_num 145 | output.ntraj=odeconfig.ntraj 146 | 147 | return output 148 | 149 | class _MC_class(): 150 | def __init__(self): 151 | self.cpus = odeconfig.options.num_cpus 152 | self.nprocs = self.cpus 153 | self.sol = Odedata() 154 | self.mf = 10 155 | # If returning density matrices, return as sparse or dense? 156 | self.sparse_dms = True 157 | # Run in serial? 158 | self.serial_run = False 159 | self.ntraj = odeconfig.ntraj 160 | self.ntrajs = [] 161 | self.seed = None 162 | self.psi0_dims = None 163 | self.psi0_shape = None 164 | self.dm_dims = None 165 | self.dm_shape = None 166 | self.unravel_type = 2 167 | self.ptrace_sel = [] 168 | self.calc_entropy = False 169 | 170 | def parallel(self): 171 | from multiprocessing import Process, Queue, JoinableQueue 172 | self.ntrajs = [] 173 | for i in range(self.cpus): 174 | self.ntrajs.append(min(int(floor(float(self.ntraj) 175 | /self.cpus)), 176 | self.ntraj-sum(self.ntrajs))) 177 | cnt = sum(self.ntrajs) 178 | while cnt=self.ntraj): 183 | break 184 | self.ntrajs = np.array(self.ntrajs) 185 | self.ntrajs = self.ntrajs[np.where(self.ntrajs>0)] 186 | self.nprocs = len(self.ntrajs) 187 | sols = [] 188 | processes = [] 189 | resq = JoinableQueue() 190 | print "Number of cpus:", self.cpus 191 | print "Trying to start", self.nprocs, "process(es)." 192 | print "Number of trajectories for each process:" 193 | print self.ntrajs 194 | for i in range(self.nprocs): 195 | p = Process(target=self.evolve_serial, 196 | args=((resq,self.ntrajs[i],i,self.seed*(i+1)),)) 197 | p.start() 198 | processes.append(p) 199 | resq.join() 200 | cnt = 0 201 | while True: 202 | try: 203 | sols.append(resq.get()) 204 | resq.task_done() 205 | cnt += 1 206 | if (cnt >= self.nprocs): break 207 | except KeyboardInterrupt: 208 | break 209 | except: 210 | pass 211 | resq.join() 212 | for proc in processes: 213 | try: 214 | proc.join() 215 | except KeyboardInterrupt: 216 | print("Cancel thread on keyboard interrupt") 217 | proc.terminate() 218 | proc.join() 219 | resq.close() 220 | return sols 221 | 222 | def serial(self): 223 | self.nprocs = 1 224 | self.ntrajs = [self.ntraj] 225 | print "Running in serial." 226 | print "Number of trajectories:", self.ntraj 227 | sol = self.evolve_serial((0,self.ntraj,0,self.seed)) 228 | return [sol] 229 | 230 | def run(self): 231 | from numpy.random import random_integers 232 | if (odeconfig.c_num == 0): 233 | # force one trajectory if no collapse operators 234 | odeconfig.ntraj=1 235 | self.ntraj=1 236 | # Set unravel_type to 1 to integrate without collapses 237 | self.unravel_type = 1 238 | if (odeconfig.e_num==0): 239 | # If we are returning states, and there are no 240 | # collapse operators, set mc_avg to False to return 241 | # ket vectors instead of density matrices 242 | odeconfig.options.mc_avg=False 243 | # generate a random seed, useful if e.g. running with MPI 244 | self.seed = random_integers(1e8) 245 | if (self.serial_run): 246 | # run in serial 247 | sols = self.serial() 248 | else: 249 | # run in paralell 250 | sols = self.parallel() 251 | # gather data 252 | self.sol = _gather(sols) 253 | 254 | def evolve_serial(self,args): 255 | # run ntraj trajectories for one process via fortran 256 | # get args 257 | queue,ntraj,instanceno,rngseed = args 258 | # initialize the problem in fortran 259 | _init_tlist() 260 | _init_psi0() 261 | if (self.ptrace_sel != []): 262 | _init_ptrace_stuff(self.ptrace_sel) 263 | _init_hamilt() 264 | if (odeconfig.c_num != 0): 265 | _init_c_ops() 266 | if (odeconfig.e_num != 0): 267 | _init_e_ops() 268 | # set options 269 | qtf90.qutraj_run.n_c_ops = odeconfig.c_num 270 | qtf90.qutraj_run.n_e_ops = odeconfig.e_num 271 | qtf90.qutraj_run.ntraj = ntraj 272 | qtf90.qutraj_run.unravel_type = self.unravel_type 273 | qtf90.qutraj_run.mc_avg = odeconfig.options.mc_avg 274 | qtf90.qutraj_run.init_odedata(odeconfig.psi0_shape[0], 275 | odeconfig.options.atol,odeconfig.options.rtol,mf=self.mf, 276 | norm_steps=odeconfig.norm_steps,norm_tol=odeconfig.norm_tol) 277 | # set optional arguments 278 | qtf90.qutraj_run.order = odeconfig.options.order 279 | qtf90.qutraj_run.nsteps = odeconfig.options.nsteps 280 | qtf90.qutraj_run.first_step = odeconfig.options.first_step 281 | qtf90.qutraj_run.min_step = odeconfig.options.min_step 282 | qtf90.qutraj_run.max_step = odeconfig.options.max_step 283 | qtf90.qutraj_run.norm_steps=odeconfig.options.norm_steps 284 | qtf90.qutraj_run.norm_tol=odeconfig.options.norm_tol 285 | # use sparse density matrices during computation? 286 | qtf90.qutraj_run.rho_return_sparse = self.sparse_dms 287 | # calculate entropy of reduced density matrice? 288 | qtf90.qutraj_run.calc_entropy = self.calc_entropy 289 | # run 290 | qtf90.qutraj_run.evolve(instanceno,rngseed) 291 | # construct Odedata instance 292 | sol = Odedata() 293 | sol.ntraj = ntraj 294 | #sol.col_times = qtf90.qutraj_run.col_times 295 | #sol.col_which = qtf90.qutraj_run.col_which-1 296 | sol.col_times, sol.col_which = self.get_collapses(ntraj) 297 | if (odeconfig.e_num==0): 298 | sol.states = self.get_states(len(odeconfig.tlist),ntraj) 299 | else: 300 | sol.expect = self.get_expect(len(odeconfig.tlist),ntraj) 301 | if (self.calc_entropy): 302 | sol.entropy = self.get_entropy(len(odeconfig.tlist)) 303 | if (not self.serial_run): 304 | # put to queue 305 | queue.put(sol) 306 | #queue.put('STOP') 307 | #deallocate stuff 308 | #finalize() 309 | return sol 310 | 311 | # Routines for retrieving data data from fortran 312 | def get_collapses(self,ntraj): 313 | col_times = np.zeros((ntraj),dtype=np.ndarray) 314 | col_which = np.zeros((ntraj),dtype=np.ndarray) 315 | if (odeconfig.c_num==0): 316 | # no collapses 317 | return col_times, col_which 318 | for i in range(ntraj): 319 | qtf90.qutraj_run.get_collapses(i+1) 320 | times = qtf90.qutraj_run.col_times 321 | which = qtf90.qutraj_run.col_which 322 | if (times==None): times = array([]) 323 | if (which==None): which = array([]) 324 | else: which = which-1 325 | col_times[i] = np.array(times,copy=True) 326 | col_which[i] = np.array(which,copy=True) 327 | return col_times, col_which 328 | 329 | def get_states(self,nstep,ntraj): 330 | from scipy.sparse import csr_matrix 331 | if (odeconfig.options.mc_avg): 332 | states=np.array([Qobj()]*nstep) 333 | if (self.sparse_dms): 334 | # averaged sparse density matrices 335 | for i in range(nstep): 336 | qtf90.qutraj_run.get_rho_sparse(i+1) 337 | val = qtf90.qutraj_run.csr_val 338 | col = qtf90.qutraj_run.csr_col-1 339 | ptr = qtf90.qutraj_run.csr_ptr-1 340 | m = qtf90.qutraj_run.csr_nrows 341 | k = qtf90.qutraj_run.csr_ncols 342 | states[i] = Qobj(csr_matrix((val,col,ptr), 343 | (m,k)).toarray(), 344 | dims=self.dm_dims,shape=self.dm_shape) 345 | else: 346 | # averaged dense density matrices 347 | for i in range(nstep): 348 | states[i] = Qobj(qtf90.qutraj_run.sol[0,i,:,:], 349 | dims=self.dm_dims,shape=self.dm_shape) 350 | else: 351 | # all trajectories as kets 352 | if (ntraj==1): 353 | states=np.array([Qobj()]*nstep) 354 | for i in range(nstep): 355 | states[i] = Qobj(matrix( 356 | qtf90.qutraj_run.sol[0,0,i,:]).transpose(), 357 | dims=self.psi0_dims,shape=self.psi0_shape) 358 | else: 359 | states=np.array([np.array([Qobj()]*nstep)]*ntraj) 360 | for traj in range(ntraj): 361 | for i in range(nstep): 362 | states[traj][i] = Qobj(matrix( 363 | qtf90.qutraj_run.sol[0,traj,i,:]).transpose(), 364 | dims=self.psi0_dims,shape=self.psi0_shape) 365 | return states 366 | 367 | def get_expect(self,nstep,ntraj): 368 | if (odeconfig.options.mc_avg): 369 | expect=np.array([np.array([0.+0.j]*nstep)]*odeconfig.e_num) 370 | for j in range(odeconfig.e_num): 371 | expect[j] = qtf90.qutraj_run.sol[j,0,:,0] 372 | else: 373 | expect=np.array([[np.array([0.+0.j]*nstep)]*odeconfig.e_num] 374 | *ntraj) 375 | for j in range(odeconfig.e_num): 376 | expect[:,j,:] = qtf90.qutraj_run.sol[j,:,:,0] 377 | return expect 378 | 379 | def get_entropy(self,nstep): 380 | if (not self.calc_entropy): 381 | print 'get_entropy: calc_entropy=False. Aborting.' 382 | return 383 | entropy = np.array([0.]*nstep) 384 | entropy[:] = qtf90.qutraj_run.reduced_state_entropy[:] 385 | return entropy 386 | 387 | def finalize(): 388 | # not in use... 389 | qtf90.qutraj_run.finalize_work() 390 | qtf90.qutraj_run.finalize_sol() 391 | 392 | def _gather(sols): 393 | # gather list of Odedata objects, sols, into one. 394 | sol = Odedata() 395 | #sol = sols[0] 396 | ntraj = sum([a.ntraj for a in sols]) 397 | sol.col_times = np.zeros((ntraj),dtype=np.ndarray) 398 | sol.col_which = np.zeros((ntraj),dtype=np.ndarray) 399 | sol.col_times[0:sols[0].ntraj] = sols[0].col_times 400 | sol.col_which[0:sols[0].ntraj] = sols[0].col_which 401 | sol.states = np.array(sols[0].states) 402 | sol.expect = np.array(sols[0].expect) 403 | if (hasattr(sols[0],'entropy')): 404 | sol.entropy = np.array(sols[0].entropy) 405 | sofar = 0 406 | for j in range(1,len(sols)): 407 | sofar = sofar + sols[j-1].ntraj 408 | sol.col_times[sofar:sofar+sols[j].ntraj] = ( 409 | sols[j].col_times) 410 | sol.col_which[sofar:sofar+sols[j].ntraj] = ( 411 | sols[j].col_which) 412 | if (odeconfig.e_num==0): 413 | if (odeconfig.options.mc_avg): 414 | # collect states, averaged over trajectories 415 | sol.states += np.array(sols[j].states) 416 | else: 417 | # collect states, all trajectories 418 | sol.states = np.vstack((sol.states, 419 | np.array(sols[j].states))) 420 | else: 421 | if (odeconfig.options.mc_avg): 422 | # collect expectation values, averaged 423 | for i in range(odeconfig.e_num): 424 | sol.expect[i] += np.array(sols[j].expect[i]) 425 | else: 426 | # collect expectation values, all trajectories 427 | sol.expect = np.vstack((sol.expect, 428 | np.array(sols[j].expect))) 429 | if (hasattr(sols[j],'entropy')): 430 | if (odeconfig.options.mc_avg): 431 | # collect entropy values, averaged 432 | sol.entropy += np.array(sols[j].entropy) 433 | else: 434 | # collect entropy values, all trajectories 435 | sol.entropy = np.vstack((sol.entropy, 436 | np.array(sols[j].entropy))) 437 | if (odeconfig.options.mc_avg): 438 | if (odeconfig.e_num==0): 439 | sol.states = sol.states/len(sols) 440 | else: 441 | sol.expect = sol.expect/len(sols) 442 | if (hasattr(sols[0],'entropy')): 443 | sol.entropy = sol.entropy/len(sols) 444 | # convert to list/array to be consistent with qutip mcsolve 445 | sol.states = list(sol.states) 446 | #sol.expect = list(sol.expect) 447 | return sol 448 | 449 | # 450 | # Functions to initialize the problem in fortran 451 | # 452 | 453 | def _init_tlist(): 454 | Of = _realarray_to_fortran(odeconfig.tlist) 455 | qtf90.qutraj_run.init_tlist(Of, 456 | size(Of)) 457 | 458 | def _init_psi0(): 459 | #Of = _qobj_to_fortranfull(odeconfig.psi0) 460 | Of = _complexarray_to_fortran(odeconfig.psi0) 461 | qtf90.qutraj_run.init_psi0(Of,size(Of)) 462 | 463 | def _init_ptrace_stuff(sel): 464 | psi0 = Qobj(odeconfig.psi0, 465 | dims=odeconfig.psi0_dims,shape=odeconfig.psi0_shape) 466 | qtf90.qutraj_run.init_ptrace_stuff(odeconfig.psi0_dims[0], 467 | np.array(sel)+1,psi0.ptrace(sel).shape[0]) 468 | 469 | def _init_hamilt(): 470 | # construct effective non-Hermitian Hamiltonian 471 | #H_eff = H - 0.5j*sum([c_ops[i].dag()*c_ops[i] 472 | # for i in range(len(c_ops))]) 473 | #Of = _qobj_to_fortrancsr(H_eff) 474 | #qtf90.qutraj_run.init_hamiltonian(Of[0],Of[1], 475 | # Of[2],Of[3],Of[4]) 476 | d = size(odeconfig.psi0) 477 | qtf90.qutraj_run.init_hamiltonian( 478 | _complexarray_to_fortran(odeconfig.h_data), 479 | odeconfig.h_ind+1,odeconfig.h_ptr+1,d,d) 480 | 481 | def _init_c_ops(): 482 | d = size(odeconfig.psi0) 483 | n = odeconfig.c_num 484 | first = True 485 | for i in range(n): 486 | #Of = _qobj_to_fortrancsr(c_ops[i]) 487 | #qtf90.qutraj_run.init_c_ops(i+1,n,Of[0],Of[1], 488 | # Of[2],Of[3],Of[4],first) 489 | qtf90.qutraj_run.init_c_ops(i+1,n, 490 | _complexarray_to_fortran(odeconfig.c_ops_data[i]), 491 | odeconfig.c_ops_ind[i]+1,odeconfig.c_ops_ptr[i]+1,d,d, 492 | first) 493 | first = False 494 | 495 | def _init_e_ops(): 496 | d = size(odeconfig.psi0) 497 | #n = odeconfig.e_num 498 | n = len(odeconfig.e_ops_data) 499 | first = True 500 | for i in range(n): 501 | #Of = _qobj_to_fortrancsr(e_ops[i]) 502 | #qtf90.qutraj_run.init_e_ops(i+1,n,Of[0],Of[1], 503 | # Of[2],Of[3],Of[4],first) 504 | qtf90.qutraj_run.init_e_ops(i+1,n, 505 | _complexarray_to_fortran(odeconfig.e_ops_data[i]), 506 | odeconfig.e_ops_ind[i]+1,odeconfig.e_ops_ptr[i]+1,d,d, 507 | first) 508 | first = False 509 | # 510 | # Misc. converison functions 511 | # 512 | 513 | def _realarray_to_fortran(a): 514 | datad = np.array(a,dtype=wpr) 515 | return datad 516 | 517 | def _complexarray_to_fortran(a): 518 | datad = np.array(a,dtype=wpc) 519 | return datad 520 | 521 | def _qobj_to_fortranfull(A): 522 | datad = np.array(A.data.toarray(),dtype=wpc) 523 | return datad 524 | 525 | def _qobj_to_fortrancsr(A): 526 | data = np.array(A.data.data,dtype=wpc) 527 | indices = np.array(A.data.indices) 528 | indptr = np.array(A.data.indptr) 529 | m = A.data.shape[0] 530 | k = A.data.shape[1] 531 | return data,indices+1,indptr+1,m,k 532 | 533 | -------------------------------------------------------------------------------- /qutipf90mc/qutraj_hilbert.f90: -------------------------------------------------------------------------------- 1 | module qutraj_hilbert 2 | ! 3 | ! Module implementing and providing abstraction of 4 | ! the Hilbert space 5 | ! 6 | ! States are complex 1d arrays, and 7 | ! operators are CSR matrices 8 | ! 9 | 10 | use qutraj_precision 11 | use qutraj_general 12 | 13 | implicit none 14 | 15 | ! 16 | ! Types 17 | ! 18 | 19 | type operat 20 | ! Operators are represented as spare matrices 21 | ! stored in compressed row format (CSR) 22 | 23 | ! m = number of rows, k = number of cols 24 | ! (should have m=k for operators!) 25 | integer :: m,k 26 | ! number of values 27 | integer :: nnz 28 | !! compression format is CSR 29 | !character*5 :: fida = 'CSR' 30 | !! base: Fortran or C base 31 | !integer :: base = 1 ! 32 | !! diag: 'U' for un-stored diag entries, assumed to be one 33 | !character*11 :: diag = 'N' 34 | !! typem: 'S' for symmetric, 'H' for Hermitian 35 | !character*11 :: typem = 'G' 36 | !!both/lower/upper half of matrix specified 37 | !character*11 :: part = 'B' 38 | ! values 39 | complex(wp), allocatable :: a(:) 40 | integer, allocatable :: ia1(:),pb(:)!,pe(:) 41 | ! notice: pe(i) = pb(i+1)-1 42 | end type 43 | 44 | ! 45 | ! Interfaces 46 | ! 47 | 48 | interface new 49 | module procedure state_init 50 | module procedure state_init2_wp 51 | module procedure operat_init 52 | module procedure operat_init2_wp 53 | module procedure operat_list_init 54 | end interface 55 | 56 | interface finalize 57 | module procedure state_finalize 58 | module procedure operat_finalize 59 | module procedure operat_list_finalize 60 | end interface 61 | 62 | interface assignment(=) 63 | module procedure operat_operat_eq 64 | end interface 65 | 66 | interface operator(*) 67 | module procedure operat_state_mult 68 | module procedure real_operat_mult 69 | module procedure operat_operat_mult 70 | end interface 71 | 72 | interface operator(+) 73 | module procedure operat_operat_add 74 | end interface 75 | 76 | ! 77 | ! Subs and funcs 78 | ! 79 | 80 | contains 81 | 82 | ! 83 | ! Initializers & finalizers 84 | ! 85 | 86 | subroutine state_init(this,n) 87 | complex(wp), allocatable :: this(:) 88 | integer, intent(in) :: n 89 | integer :: istat=0 90 | if (allocated(this)) then 91 | deallocate(this,stat=istat) 92 | endif 93 | allocate(this(n),stat=istat) 94 | if (istat.ne.0) then 95 | call fatal_error("state_init: could not allocate.",istat) 96 | endif 97 | end subroutine 98 | 99 | subroutine state_init2_wp(this,val) 100 | complex(wp), allocatable :: this(:) 101 | complex(wp), intent(in) :: val(:) 102 | call state_init(this,size(val)) 103 | this = val 104 | end subroutine 105 | 106 | subroutine state_finalize(this) 107 | complex(wp), allocatable :: this(:) 108 | integer :: istat=0 109 | if (allocated(this)) then 110 | deallocate(this,stat=istat) 111 | endif 112 | if (istat.ne.0) then 113 | call error("state_finalize: could not deallocate.",istat) 114 | endif 115 | end subroutine 116 | 117 | subroutine operat_init(this,nnz,nptr) 118 | ! todo: add special support for Hermitian matrix 119 | type(operat), intent(out) :: this 120 | integer, intent(in) :: nnz,nptr 121 | integer :: istat=0,nnz_,nptr_ 122 | if (allocated(this%a)) then 123 | deallocate(this%a,stat=istat) 124 | endif 125 | if (allocated(this%ia1)) then 126 | deallocate(this%ia1,stat=istat) 127 | endif 128 | if (allocated(this%pb)) then 129 | deallocate(this%pb,stat=istat) 130 | endif 131 | nnz_ = nnz 132 | nptr_ = nptr 133 | if (nnz==0) nnz_= 1 134 | if (nptr==0) nptr_= 1 135 | this%nnz = nnz_ 136 | allocate(this%a(nnz_),stat=istat) 137 | if (istat.ne.0) then 138 | call fatal_error("operat_init: could not allocate.",istat) 139 | endif 140 | allocate(this%ia1(nnz_),stat=istat) 141 | if (istat.ne.0) then 142 | call fatal_error("operat_init: could not allocate.",istat) 143 | endif 144 | allocate(this%pb(nptr_),stat=istat) 145 | if (istat.ne.0) then 146 | call fatal_error("operat_init: could not allocate.",istat) 147 | endif 148 | ! Set to zero 149 | this%a = (0.,0.) 150 | !this%ia1 = 1 151 | !this%pb = 1 152 | !this%m = 1 153 | !this%k = 1 154 | ! Set default parameters 155 | !this%fida = 'CSR' 156 | !this%base = 1 ! fortran base 157 | !this%diag = 'N' 158 | !this%typem = 'G' 159 | !this%part = 'B' 160 | end subroutine 161 | 162 | subroutine operat_init2_wp(this,val,col,ptr,m,k) 163 | integer, intent(in) :: m,k 164 | type(operat), intent(out) :: this 165 | complex(wp), intent(in) :: val(:) 166 | integer, intent(in) :: col(:),ptr(:) 167 | integer :: i 168 | if (size(val)==0) then 169 | call operat_init(this,1,1) 170 | this%m = 1 171 | this%k = 1 172 | this%a = (/(0.,0.)/) 173 | this%ia1 = (/1/) 174 | this%pb = (/1,2/) 175 | else 176 | call operat_init(this,size(val),size(ptr)) 177 | this%m = m 178 | this%k = k 179 | this%a = val 180 | this%ia1 = col 181 | this%pb = ptr 182 | endif 183 | end subroutine 184 | 185 | subroutine operat_list_init(this,n) 186 | type(operat), intent(inout), allocatable :: this(:) 187 | integer, intent(in) :: n 188 | integer :: istat 189 | if (allocated(this)) then 190 | deallocate(this,stat=istat) 191 | endif 192 | allocate(this(n),stat=istat) 193 | if (istat.ne.0) then 194 | call fatal_error("operat_list_init: could not allocate.",istat) 195 | endif 196 | end subroutine 197 | 198 | subroutine operat_finalize(this) 199 | type(operat), intent(inout) :: this 200 | integer :: istat=0 201 | if (allocated(this%a)) then 202 | deallocate(this%a,stat=istat) 203 | if (istat.ne.0) then 204 | call error("operat_finalize: could not deallocate.",istat) 205 | endif 206 | endif 207 | if (allocated(this%ia1)) then 208 | deallocate(this%ia1,stat=istat) 209 | if (istat.ne.0) then 210 | call error("operat_finalize: could not deallocate.",istat) 211 | endif 212 | endif 213 | if (allocated(this%pb)) then 214 | deallocate(this%pb,stat=istat) 215 | if (istat.ne.0) then 216 | call error("operat_finalize: could not deallocate.",istat) 217 | endif 218 | endif 219 | end subroutine 220 | 221 | subroutine operat_list_finalize(this) 222 | type(operat), intent(inout), allocatable :: this(:) 223 | integer :: istat=0,i 224 | if (allocated(this)) then 225 | do i=1,size(this) 226 | call finalize(this(i)) 227 | enddo 228 | deallocate(this,stat=istat) 229 | endif 230 | if (istat.ne.0) then 231 | call error("operat_list_finalize: could not deallocate.",istat) 232 | endif 233 | end subroutine 234 | 235 | ! 236 | ! State/operator arithmetic 237 | ! 238 | 239 | subroutine operat_operat_eq(this,a) 240 | type(operat), intent(out) :: this 241 | type(operat), intent(in) :: a 242 | call new(this,a%a,a%ia1,a%pb,a%m,a%k) 243 | end subroutine 244 | 245 | function operat_operat_add(a,b) 246 | type(operat) :: operat_operat_add 247 | type(operat), intent(in) :: a,b 248 | type(operat) :: c,d 249 | integer :: nzmax,ierr 250 | integer, allocatable :: iw(:) 251 | call new(iw,a%k) 252 | nzmax = size(a%a) + size(b%a) 253 | call new(c,nzmax,a%m+1) 254 | call aplb(a%m,a%k,1,a%a,a%ia1,a%pb,b%a,b%ia1,b%pb,c%a,c%ia1,c%pb,& 255 | nzmax,iw,ierr) 256 | if (ierr.ne.0) then 257 | call error('operat_operat_add',ierr) 258 | endif 259 | !call finalize(iw) 260 | nzmax = count(c%a.ne.0) 261 | c%pb(size(c%pb)) = nzmax+1 262 | call new(d,c%a(1:nzmax),c%ia1(1:nzmax),c%pb,a%m,b%k) 263 | operat_operat_add = d 264 | end function 265 | 266 | function operat_state_mult(oper,psi) 267 | complex(wp), intent(in) :: psi(:) 268 | type(operat), intent(in) :: oper 269 | complex(wp):: operat_state_mult(size(psi)) 270 | complex(wp), allocatable :: tmp(:) 271 | integer :: ierr 272 | call new(tmp,size(psi)) 273 | call sparse_mv_mult(oper,psi,tmp,ierr) 274 | if (ierr.ne.0) then 275 | call error("operate_state_mult: error",ierr) 276 | endif 277 | operat_state_mult = tmp 278 | call finalize(tmp) 279 | end function 280 | 281 | function real_operat_mult(r,a) 282 | type(operat) :: real_operat_mult 283 | real(wp), intent(in) :: r 284 | type(operat), intent(in) :: a 285 | type(operat) :: c 286 | call new(c,r*a%a,a%ia1,a%pb,a%m,a%k) 287 | real_operat_mult = c 288 | end function 289 | 290 | function operat_operat_mult(a,b) 291 | type(operat) :: operat_operat_mult 292 | type(operat), intent(in) :: a,b 293 | type(operat) :: c,d 294 | integer :: nzmax,ierr 295 | integer, allocatable :: iw(:) 296 | call new(iw,b%k) 297 | nzmax = a%nnz*b%nnz 298 | call new(c,nzmax,a%m+1) 299 | call amub(a%m,b%k,1,a%a,a%ia1,a%pb,b%a,b%ia1,b%pb,& 300 | c%a,c%ia1,c%pb,nzmax,iw,ierr) 301 | if (ierr.ne.0) call error('operat_operat_mult',ierr) 302 | !call finalize(iw) 303 | nzmax = count(c%a.ne.0) 304 | c%pb(size(c%pb)) = nzmax+1 305 | call new(d,c%a(1:nzmax),c%ia1(1:nzmax),c%pb,a%m,b%k) 306 | operat_operat_mult = d 307 | end function 308 | 309 | subroutine operat_operat_mult_sub(a,b,d) 310 | type(operat), intent(out) :: d 311 | type(operat), intent(in) :: a,b 312 | type(operat) :: c 313 | integer :: nzmax,ierr 314 | integer, allocatable :: iw(:) 315 | call new(iw,b%k) 316 | nzmax = a%nnz*b%nnz 317 | write(*,*) 'a%m',a%m,'a%k',a%k,'a%nnz',a%nnz 318 | write(*,*) 'b%m',b%m,'b%k',b%k,'b%nnz',b%nnz 319 | call new(c,nzmax,a%m+1) 320 | write(*,*) 'created c' 321 | call amub(a%m,b%k,1,a%a,a%ia1,a%pb,b%a,b%ia1,b%pb,& 322 | c%a,c%ia1,c%pb,nzmax,iw,ierr) 323 | if (ierr.ne.0) call error('operat_operat_mult',ierr) 324 | write(*,*) 'product' 325 | write(*,*) size(c%a),size(c%pb) 326 | !call finalize(iw) 327 | nzmax = count(c%a.ne.0) 328 | write(*,*) 'nzmax=',nzmax 329 | c%pb(size(c%pb)) = nzmax+1 330 | write(*,*) 'before d' 331 | call new(d,c%a(1:nzmax),c%ia1(1:nzmax),c%pb,a%m,b%k) 332 | !call finalize(c) 333 | write(*,*) 'd%m',d%m,'d%k',d%k,'d%nnz',d%nnz,size(d%a),size(d%pb) 334 | write(*,*) 'mult done' 335 | end subroutine 336 | 337 | function braket(fi,psi) 338 | ! return 339 | complex(wp) :: braket 340 | complex(wp), intent(in) :: fi(:),psi(:) 341 | braket = sum(conjg(fi)*psi) 342 | end function 343 | 344 | subroutine normalize(psi) 345 | complex(wp), intent(inout) :: psi(:) 346 | real(wp) :: tmp 347 | tmp = sqrt(abs(braket(psi,psi))) 348 | ! Check for division by zero 349 | if (abs(tmp) < epsi) then 350 | psi = 0. 351 | else 352 | psi = psi/tmp 353 | end if 354 | end subroutine 355 | 356 | function ket_to_operat(psi) 357 | ! Turns a 1d complex array psi into derived type operat 358 | ! psi is interpreted as a column vector 359 | ! i.e. no of rows = size(psi), no of columns = 1 360 | type(operat) :: ket_to_operat 361 | complex(wp), intent(in) :: psi(:) 362 | type(operat) :: c,d 363 | integer :: nzmax,ierr 364 | nzmax = count(psi.ne.0) 365 | call new(c,nzmax,size(psi)+1) 366 | !state_to_operat = c 367 | call dnscsr(size(psi),1,nzmax,psi,size(psi),c%a,c%ia1,c%pb,ierr) 368 | !nzmax = count(abs(c%a).ge.epsi) 369 | call new(d,c%a,c%ia1,c%pb,size(psi),1) 370 | ket_to_operat = d 371 | end function 372 | 373 | function bra_to_operat(psi) 374 | ! Turns a 1d complex array psi into derived type operat 375 | ! psi is interpreted as a row vector 376 | ! i.e. no of rows = 1, no of columns = size(psi) 377 | type(operat) :: bra_to_operat 378 | complex(wp), intent(in) :: psi(:) 379 | type(operat) :: c,d 380 | integer :: nzmax,ierr 381 | nzmax = count(psi.ne.0) 382 | call new(c,nzmax,1+1) 383 | !state_to_operat = c 384 | call dnscsr(1,size(psi),nzmax,psi,1,c%a,c%ia1,c%pb,ierr) 385 | !nzmax = count(abs(c%a).ge.epsi) 386 | call new(d,c%a,c%ia1,c%pb,1,size(psi)) 387 | bra_to_operat = d 388 | end function 389 | 390 | ! 391 | ! Misc. 392 | ! 393 | 394 | subroutine densitymatrix_dense(psi,rho) 395 | ! Dense density matrix from pure state 396 | complex(wp), intent(in) :: psi(:) 397 | complex(wp), intent(out) :: rho(:,:) 398 | complex(wp), allocatable :: tmp(:,:) 399 | integer istat 400 | allocate(tmp(1,size(psi)),stat=istat) 401 | tmp(1,:) = psi 402 | rho = matmul(transpose(conjg(tmp)),tmp) 403 | end subroutine 404 | 405 | subroutine densitymatrix_sparse(psi,rho) 406 | ! Sparse density matrix from pure state 407 | complex(wp), intent(in) :: psi(:) 408 | type(operat), intent(out) :: rho 409 | type(operat) :: a,b 410 | rho = ket_to_operat(psi)*bra_to_operat(conjg(psi)) 411 | end subroutine 412 | 413 | subroutine ptrace_pure(psi,rho,sel,dims) 414 | ! Partial trace over pure state 415 | ! Under construction 416 | ! Currently only correct for sel = (/1,2,../) 417 | ! i.e. no permutations 418 | complex(wp), intent(in) :: psi(:) 419 | integer, intent(in) :: sel(:),dims(:) 420 | complex(wp), intent(out) :: rho(:,:) 421 | complex(wp), allocatable :: a(:,:) 422 | integer :: m,n,prod_dims_sel,prod_dims_rest 423 | integer :: i,j,istat 424 | logical :: insel 425 | 426 | m = 1 427 | n = 1 428 | prod_dims_sel = 1 429 | prod_dims_rest = 1 430 | do i=1,size(dims) 431 | n=n*dims(i) 432 | insel = .false. 433 | do j=1,size(sel) 434 | if (i==sel(j)) then 435 | m=m*dims(i) 436 | prod_dims_sel = prod_dims_sel*dims(i) 437 | insel=.true. 438 | endif 439 | enddo 440 | if (.not.insel) then 441 | prod_dims_rest = prod_dims_rest*dims(i) 442 | endif 443 | enddo 444 | allocate(a(prod_dims_rest,prod_dims_sel),stat=istat) 445 | a = reshape(psi,(/prod_dims_rest,prod_dims_sel/)) 446 | !allocate(rho(prod_dims_sel,prod_dims_sel),stat=istat) 447 | rho = matmul(transpose(conjg(a)),a) 448 | end subroutine 449 | 450 | ! 451 | ! Sparse matrix routines 452 | ! 453 | 454 | subroutine sparse_mv_mult(mat,x,y,ierr) 455 | ! y = Ax 456 | ! Adapted from sparse blas 457 | type(operat) :: mat 458 | complex(KIND=wp) , dimension(:), intent(in) :: x 459 | complex(KIND=wp) , dimension(:), intent(out) :: y 460 | integer, intent(out) :: ierr 461 | integer :: m,n,base,ofs,i,pntr 462 | character :: diag,type,part 463 | ierr = -1 464 | m = size(y) 465 | n = size(x) 466 | !if ((mat%FIDA.ne.'CSR').or.(mat%M.ne.m).or.(mat%K.ne.n)) then 467 | ! ierr = blas_error_param 468 | ! return 469 | !end if 470 | !base = mat%base 471 | !ofs = 1 - base 472 | !diag = mat%diag 473 | !type = mat%typem 474 | !part = mat%part 475 | ofs = 0 476 | y = (0.0d0, 0.0d0) 477 | !if (diag.eq.'U') then !process unstored diagonal 478 | ! if (m.eq.n) then 479 | ! y = x 480 | ! else 481 | ! ierr = blas_error_param 482 | ! return 483 | ! end if 484 | !end if 485 | !if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then 486 | ! if (part.eq.'U') then 487 | ! do i = 1, mat%M 488 | ! pntr = mat%pb(i) 489 | ! do while(pntr.lt.mat%pe(i)) 490 | ! if(i.eq.mat%IA1(pntr + ofs) + ofs) then 491 | ! y(i) = y(i) & 492 | ! + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) 493 | ! else if (i.lt.mat%IA1(pntr + ofs) + ofs) then 494 | ! y(i) = y(i) & 495 | ! + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) 496 | ! y(mat%IA1(pntr + ofs) + ofs) = & 497 | ! y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) 498 | ! end if 499 | ! pntr = pntr + 1 500 | ! end do 501 | ! end do 502 | ! else 503 | ! do i = 1, mat%M 504 | ! pntr = mat%pb(i) 505 | ! do while(pntr.lt.mat%pe(i)) 506 | ! if(i.eq.mat%IA1(pntr + ofs) + ofs) then 507 | ! y(i) = y(i) & 508 | ! + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) 509 | ! else if (i.gt.mat%IA1(pntr + ofs) + ofs) then 510 | ! y(i) = y(i) & 511 | ! + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) 512 | ! y(mat%IA1(pntr + ofs) + ofs) = & 513 | ! y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) 514 | ! end if 515 | ! pntr = pntr + 1 516 | ! end do 517 | ! end do 518 | ! end if 519 | ! ierr = 0 520 | !else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then 521 | ! if (part.eq.'U') then 522 | ! do i = 1, mat%M 523 | ! pntr = mat%pb(i) 524 | ! do while(pntr.lt.mat%pe(i)) 525 | ! if(i.eq.mat%IA1(pntr + ofs) + ofs) then 526 | ! y(i) = y(i) & 527 | ! + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) 528 | ! else if (i.lt.mat%IA1(pntr + ofs) + ofs) then 529 | ! y(i) = y(i) & 530 | ! + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) 531 | ! y(mat%IA1(pntr+ofs)+ofs)=y(mat%IA1(pntr+ofs)+ofs) & 532 | ! + conjg (mat%A(pntr + ofs)) * x(i) 533 | ! end if 534 | ! pntr = pntr + 1 535 | ! end do 536 | ! end do 537 | ! else 538 | ! do i = 1, mat%M 539 | ! pntr = mat%pb(i) 540 | ! do while(pntr.lt.mat%pe(i)) 541 | ! if(i.eq.mat%IA1(pntr + ofs) + ofs) then 542 | ! y(i) = y(i) & 543 | ! + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) 544 | ! else if (i.gt.mat%IA1(pntr + ofs) + ofs) then 545 | ! y(i) = y(i) & 546 | ! + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) 547 | ! y(mat%IA1(pntr+ofs)+ofs)=y(mat%IA1(pntr+ofs)+ofs) & 548 | ! + conjg (mat%A(pntr + ofs)) * x(i) 549 | ! end if 550 | ! pntr = pntr + 1 551 | ! end do 552 | ! end do 553 | ! end if 554 | ! ierr = 0 555 | !else 556 | do i = 1, mat%M 557 | pntr = mat%pb(i) 558 | !do while(pntr.lt.mat%pe(i)) 559 | do while(pntr.lt.mat%pb(i+1)) 560 | y(i) = y(i) & 561 | + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) 562 | pntr = pntr + 1 563 | end do 564 | end do 565 | ierr = 0 566 | !end if 567 | end subroutine 568 | 569 | 570 | ! subroutine amux ( n, x, y, a, ja, ia ) 571 | ! ! Aadapted from sparsekit 572 | ! 573 | ! !*****************************************************************************80 574 | ! ! 575 | ! !! AMUX multiplies a CSR matrix A times a vector. 576 | ! ! 577 | ! ! Discussion: 578 | ! ! 579 | ! ! This routine multiplies a matrix by a vector using the dot product form. 580 | ! ! Matrix A is stored in compressed sparse row storage. 581 | ! ! 582 | ! ! Modified: 583 | ! ! 584 | ! ! 07 January 2004 585 | ! ! 586 | ! ! Author: 587 | ! ! 588 | ! ! Youcef Saad 589 | ! ! 590 | ! ! Parameters: 591 | ! ! 592 | ! ! Input, integer N, the row dimension of the matrix. 593 | ! ! 594 | ! ! Input, real X(*), and array of length equal to the column dimension 595 | ! ! of A. 596 | ! ! 597 | ! ! Input, real A(*), integer JA(*), IA(NROW+1), the matrix in CSR 598 | ! ! Compressed Sparse Row format. 599 | ! ! 600 | ! ! Output, real Y(N), the product A * X. 601 | ! ! 602 | ! implicit none 603 | ! 604 | ! integer n 605 | ! 606 | ! complex ( kind = wp ) a(*) 607 | ! integer i 608 | ! integer ia(*) 609 | ! integer ja(*) 610 | ! integer k 611 | ! complex ( kind = wp ) t 612 | ! complex ( kind = wp ) x(*) 613 | ! complex ( kind = wp ) y(n) 614 | ! 615 | ! do i = 1, n 616 | ! ! 617 | ! ! Compute the inner product of row I with vector X. 618 | ! ! 619 | ! t = (0.0,0.0) 620 | ! do k = ia(i), ia(i+1)-1 621 | ! t = t + a(k) * x(ja(k)) 622 | ! end do 623 | ! 624 | ! y(i) = t 625 | ! 626 | ! end do 627 | ! 628 | ! return 629 | ! end 630 | ! 631 | 632 | subroutine aplb ( nrow, ncol, job, a, ja, ia, b, jb, ib, c, jc, ic, nzmax, & 633 | iw, ierr ) 634 | 635 | ! Adapted from sparsekit 636 | 637 | !*****************************************************************************80 638 | ! 639 | !! APLB performs the CSR matrix sum C = A + B. 640 | ! 641 | ! Modified: 642 | ! 643 | ! 07 January 2004 644 | ! 645 | ! Author: 646 | ! 647 | ! Youcef Saad 648 | ! 649 | ! Parameters: 650 | ! 651 | ! Input, integer NROW, the row dimension of A and B. 652 | ! 653 | ! Input, integer NCOL, the column dimension of A and B. 654 | ! 655 | ! Input, integer JOB. When JOB = 0, only the structure 656 | ! (i.e. the arrays jc, ic) is computed and the 657 | ! real values are ignored. 658 | ! 659 | ! Input, real A(*), integer JA(*), IA(NROW+1), the matrix in CSR 660 | ! Compressed Sparse Row format. 661 | ! 662 | ! b, 663 | ! jb, 664 | ! ib = Matrix B in compressed sparse row format. 665 | ! 666 | ! nzmax = integer. The length of the arrays c and jc. 667 | ! amub will stop if the result matrix C has a number 668 | ! of elements that exceeds exceeds nzmax. See ierr. 669 | ! 670 | ! on return: 671 | ! 672 | ! c, 673 | ! jc, 674 | ! ic = resulting matrix C in compressed sparse row sparse format. 675 | ! 676 | ! ierr = integer. serving as error message. 677 | ! ierr = 0 means normal return, 678 | ! ierr > 0 means that amub stopped while computing the 679 | ! i-th row of C with i = ierr, because the number 680 | ! of elements in C exceeds nzmax. 681 | ! 682 | ! work arrays: 683 | ! 684 | ! iw = integer work array of length equal to the number of 685 | ! columns in A. 686 | ! 687 | implicit none 688 | 689 | integer ncol 690 | integer nrow 691 | 692 | complex ( kind = wp ) a(*) 693 | complex ( kind = wp ) b(*) 694 | complex ( kind = wp ) c(*) 695 | integer ia(nrow+1) 696 | integer ib(nrow+1) 697 | integer ic(nrow+1) 698 | integer ierr 699 | integer ii 700 | integer iw(ncol) 701 | integer ja(*) 702 | integer jb(*) 703 | integer jc(*) 704 | integer jcol 705 | integer job 706 | integer jpos 707 | integer k 708 | integer ka 709 | integer kb 710 | integer len 711 | integer nzmax 712 | logical values 713 | 714 | values = ( job /= 0 ) 715 | ierr = 0 716 | len = 0 717 | ic(1) = 1 718 | iw(1:ncol) = 0 719 | 720 | do ii = 1, nrow 721 | ! 722 | ! Row I. 723 | ! 724 | do ka = ia(ii), ia(ii+1)-1 725 | 726 | len = len + 1 727 | jcol = ja(ka) 728 | 729 | if ( nzmax < len ) then 730 | ierr = ii 731 | return 732 | end if 733 | 734 | jc(len) = jcol 735 | if ( values ) then 736 | c(len) = a(ka) 737 | end if 738 | iw(jcol) = len 739 | end do 740 | 741 | do kb = ib(ii), ib(ii+1)-1 742 | 743 | jcol = jb(kb) 744 | jpos = iw(jcol) 745 | 746 | if ( jpos == 0 ) then 747 | 748 | len = len + 1 749 | 750 | if ( nzmax < len ) then 751 | ierr = ii 752 | return 753 | end if 754 | 755 | jc(len) = jcol 756 | if ( values ) then 757 | c(len) = b(kb) 758 | end if 759 | iw(jcol)= len 760 | else 761 | if ( values ) then 762 | c(jpos) = c(jpos) + b(kb) 763 | end if 764 | end if 765 | 766 | end do 767 | 768 | do k = ic(ii), len 769 | iw(jc(k)) = 0 770 | end do 771 | 772 | ic(ii+1) = len+1 773 | end do 774 | 775 | return 776 | end 777 | subroutine amub ( nrow, ncol, job, a, ja, ia, b, jb, ib, c, jc, ic, nzmax, & 778 | iw, ierr ) 779 | ! Aadapted from sparsekit 780 | 781 | !*****************************************************************************80 782 | ! 783 | !! AMUB performs the matrix product C = A * B. 784 | ! 785 | ! Discussion: 786 | ! 787 | ! The column dimension of B is not needed. 788 | ! 789 | ! Modified: 790 | ! 791 | ! 08 January 2004 792 | ! 793 | ! Author: 794 | ! 795 | ! Youcef Saad 796 | ! 797 | ! Parameters: 798 | ! 799 | ! Input, integer NROW, the row dimension of the matrix. 800 | ! 801 | ! Input, integer NCOL, the column dimension of the matrix. 802 | ! 803 | ! Input, integer JOB, job indicator. When JOB = 0, only the structure 804 | ! is computed, that is, the arrays JC and IC, but the real values 805 | ! are ignored. 806 | ! 807 | ! Input, real A(*), integer JA(*), IA(NROW+1), the matrix in CSR 808 | ! Compressed Sparse Row format. 809 | ! 810 | ! Input, b, jb, ib, matrix B in compressed sparse row format. 811 | ! 812 | ! Input, integer NZMAX, the length of the arrays c and jc. 813 | ! The routine will stop if the result matrix C has a number 814 | ! of elements that exceeds exceeds NZMAX. 815 | ! 816 | ! on return: 817 | ! 818 | ! c, 819 | ! jc, 820 | ! ic = resulting matrix C in compressed sparse row sparse format. 821 | ! 822 | ! ierr = integer. serving as error message. 823 | ! ierr = 0 means normal return, 824 | ! ierr > 0 means that amub stopped while computing the 825 | ! i-th row of C with i = ierr, because the number 826 | ! of elements in C exceeds nzmax. 827 | ! 828 | ! work arrays: 829 | ! 830 | ! iw = integer work array of length equal to the number of 831 | ! columns in A. 832 | ! 833 | implicit none 834 | 835 | integer ncol 836 | integer nrow 837 | integer nzmax 838 | 839 | complex ( kind = wp ) a(*) 840 | complex ( kind = wp ) b(*) 841 | complex ( kind = wp ) c(nzmax) 842 | integer ia(nrow+1) 843 | integer ib(ncol+1) 844 | integer ic(ncol+1) 845 | integer ierr 846 | integer ii 847 | integer iw(ncol) 848 | integer ja(*) 849 | integer jb(*) 850 | integer jc(nzmax) 851 | integer jcol 852 | integer jj 853 | integer job 854 | integer jpos 855 | integer k 856 | integer ka 857 | integer kb 858 | integer len 859 | complex ( kind = wp ) scal 860 | logical values 861 | 862 | values = ( job /= 0 ) 863 | len = 0 864 | ic(1) = 1 865 | ierr = 0 866 | ! 867 | ! Initialize IW. 868 | ! 869 | iw(1:ncol) = 0 870 | 871 | do ii = 1, nrow 872 | ! 873 | ! Row I. 874 | ! 875 | do ka = ia(ii), ia(ii+1)-1 876 | 877 | if ( values ) then 878 | scal = a(ka) 879 | end if 880 | 881 | jj = ja(ka) 882 | 883 | do kb = ib(jj), ib(jj+1)-1 884 | 885 | jcol = jb(kb) 886 | jpos = iw(jcol) 887 | 888 | if ( jpos == 0 ) then 889 | len = len + 1 890 | if ( nzmax < len ) then 891 | ierr = ii 892 | return 893 | end if 894 | jc(len) = jcol 895 | iw(jcol)= len 896 | if ( values ) then 897 | c(len) = scal * b(kb) 898 | end if 899 | else 900 | if ( values ) then 901 | c(jpos) = c(jpos) + scal * b(kb) 902 | end if 903 | end if 904 | 905 | end do 906 | 907 | end do 908 | 909 | do k = ic(ii), len 910 | iw(jc(k)) = 0 911 | end do 912 | 913 | ic(ii+1) = len + 1 914 | 915 | end do 916 | 917 | return 918 | end 919 | 920 | 921 | subroutine dnscsr ( nrow, ncol, nzmax, dns, ndns, a, ja, ia, ierr ) 922 | 923 | ! Adapted from Sparsekit 924 | 925 | !*****************************************************************************80 926 | ! 927 | !! DNSCSR converts Dense to Compressed Row Sparse format. 928 | ! 929 | ! Discussion: 930 | ! 931 | ! This routine converts a densely stored matrix into a row orientied 932 | ! compactly sparse matrix. It is the reverse of CSRDNS. 933 | ! 934 | ! This routine does not check whether an element is small. It considers 935 | ! that A(I,J) is zero only if it is exactly equal to zero. 936 | ! 937 | ! Modified: 938 | ! 939 | ! 07 January 2004 940 | ! 941 | ! Author: 942 | ! 943 | ! Youcef Saad 944 | ! 945 | ! Parameters: 946 | ! 947 | ! Input, integer NROW, the row dimension of the matrix. 948 | ! 949 | ! Input, integer NCOL, the column dimension of the matrix. 950 | ! 951 | ! Input, integer NZMAX, the maximum number of nonzero elements 952 | ! allowed. This should be set to be the lengths of the arrays A and JA. 953 | ! 954 | ! Input, real DNS(NDNS,NCOL), an NROW by NCOL dense matrix. 955 | ! 956 | ! Input, integer NDNS, the first dimension of DNS, which must be 957 | ! at least NROW. 958 | ! 959 | ! Output, real A(*), integer JA(*), IA(NROW+1), the matrix in CSR 960 | ! Compressed Sparse Row format. 961 | ! 962 | ! Output, integer IERR, error indicator. 963 | ! 0 means normal return; 964 | ! I, means that the the code stopped while processing row I, because 965 | ! there was no space left in A and JA, as defined by NZMAX. 966 | ! 967 | implicit none 968 | 969 | integer ncol 970 | integer ndns 971 | integer nrow 972 | 973 | complex ( kind = wp ) a(*) 974 | complex ( kind = wp ) dns(ndns,ncol) 975 | integer i 976 | integer ia(nrow+1) 977 | integer ierr 978 | integer j 979 | integer ja(*) 980 | integer next 981 | integer nzmax 982 | 983 | ierr = 0 984 | next = 1 985 | ia(1) = 1 986 | 987 | do i = 1, nrow 988 | 989 | do j = 1, ncol 990 | 991 | if ( dns(i,j) /= 0.0D+00 ) then 992 | 993 | if ( nzmax < next ) then 994 | ierr = i 995 | return 996 | end if 997 | 998 | ja(next) = j 999 | a(next) = dns(i,j) 1000 | next = next + 1 1001 | 1002 | end if 1003 | 1004 | end do 1005 | 1006 | ia(i+1) = next 1007 | 1008 | end do 1009 | 1010 | return 1011 | end 1012 | 1013 | end module 1014 | --------------------------------------------------------------------------------