tebdol

Simulation of ultracold atoms in optical lattices
git clone https://miroslavurbanek.com/git/tebdol.git
Log | Files | Refs | README

bhm.lisp (6262B)


      1 (defpackage :bhm
      2   (:use :common-lisp :blas :tensor :mps)
      3   (:export :ket-physical-index
      4 	   :bra-physical-index
      5 	   :bose-hubbard-site-hamiltonian
      6 	   :binary-bose-hubbard-site-hamiltonian))
      7 
      8 (in-package :bhm)
      9 
     10 (defun ket-physical-index (n)
     11   (loop for i below n collect
     12        (make-segment :numbers (list i) :dimension 1)))
     13 
     14 (defun bra-physical-index (n)
     15   (loop for i below n collect
     16        (make-segment :numbers (list (- i)) :dimension 1)))
     17 
     18 ;;
     19 ;; bose-hubbard site hamiltonian
     20 ;;
     21 ;;         -1    0 0       1
     22 ;;
     23 ;;            +------+
     24 ;; -1         | b+ 0 |
     25 ;;    +-------+------+-------+
     26 ;;  0 |     0 |  1 0 |     0 |
     27 ;;  0 | -j*b+ |  h 1 | -j*b- |
     28 ;;    +-------+------+-------+
     29 ;;  1         | b- 0 |
     30 ;;            +------+
     31 ;;
     32 
     33 (defun bose-hubbard-site-operators (j u e)
     34   (list
     35    (cons    '0 #'(lambda (n) (declare (ignore n)) 0))
     36    (cons    '1 #'(lambda (n) (declare (ignore n)) 1))
     37    (cons   'b- #'(lambda (n) (sqrt n)))
     38    (cons   'b+ #'(lambda (n) (sqrt (1+ n))))
     39    (cons '-jb- #'(lambda (n) (* (- j) (sqrt n))))
     40    (cons '-jb+ #'(lambda (n) (* (- j) (sqrt (1+ n)))))
     41    (cons    'h #'(lambda (n) (+ (* 1/2 u n (1- n)) (* e n))))))
     42 
     43 (defun bose-hubbard-site-hamiltonian (dimension j u e)
     44   (let ((ops (bose-hubbard-site-operators j u e))
     45 	(tbl (flet ((f (x y z)
     46 		      (cons (list (make-subscript
     47 				   :numbers (list (first x))
     48 				   :subscript (second x))
     49 				  (make-subscript
     50 				   :numbers (list (first y))
     51 				   :subscript (second y)))
     52 			    z)))
     53 	       (list
     54 		(f '(-1 0) '( 0 0)   'b+)
     55 		(f '(-1 0) '( 0 1)    '0)
     56 		(f '( 0 0) '(-1 0)    '0)
     57 		(f '( 0 0) '( 0 0)    '1)
     58 		(f '( 0 0) '( 0 1)     0)
     59 		(f '( 0 0) '( 1 0)    '0)
     60 		(f '( 0 1) '(-1 0) '-jb+)
     61 		(f '( 0 1) '( 0 0)    'h)
     62 		(f '( 0 1) '( 0 1)    '1)
     63 		(f '( 0 1) '( 1 0) '-jb-)
     64 		(f '( 1 0) '( 0 0)   'b-)
     65 		(f '( 1 0) '( 0 1)    '0)))))
     66     (let ((l (list (make-segment :numbers '(-1) :dimension 1)
     67 		   (make-segment :numbers '(0) :dimension 2)
     68 		   (make-segment :numbers '(1) :dimension 1))))
     69       (functional-tensor
     70        (list l (ket-physical-index dimension) (bra-physical-index dimension) l)
     71        #'(lambda (s)
     72 	(let ((x (find
     73 		  (list (first s) (fourth s))
     74 		  tbl
     75 		  :test #'equalp
     76 		  :key #'car)))
     77 	  (if x
     78 	      (funcall (cdr (find (cdr x) ops :key #'car))
     79 		       (- (first (subscript-numbers (third s)))))
     80 	      0)))))))
     81 
     82 ;;
     83 ;; binary bose-hubbard site hamiltonian
     84 ;;
     85 
     86 (defun bose-hubbard-site-hamiltonian-a (dimension j u e ux)
     87   (let ((ops (cons
     88 	      (cons 'uxn #'(lambda (n) (* ux n)))
     89 	      (bose-hubbard-site-operators j u e)))
     90 	(tbl (flet ((f (x y z)
     91 		      (cons (list (make-subscript
     92 				   :numbers (first x)
     93 				   :subscript (second x))
     94 				  (make-subscript
     95 				   :numbers (first y)
     96 				   :subscript (second y)))
     97 			    z)))
     98 	       (list
     99 		(f '((-1  0) 0) '(( 0  0) 0)   'b+)
    100 		(f '(( 0 -1) 0) '(( 0  1) 0)    '1)
    101 		(f '(( 0  0) 0) '(( 0  0) 0)    '1)
    102 		(f '(( 0  0) 1) '((-1  0) 0) '-jb+)
    103 		(f '(( 0  0) 1) '(( 0  0) 0)    'h)
    104 		(f '(( 0  0) 1) '(( 0  0) 1)    'uxn)
    105 		(f '(( 0  0) 1) '(( 0  0) 2)    '1)
    106 		(f '(( 0  0) 1) '(( 1  0) 0) '-jb-)
    107 		(f '(( 0  1) 0) '(( 0 -1) 0)    '1)
    108 		(f '(( 1  0) 0) '(( 0  0) 0)   'b-)))))
    109     (functional-tensor
    110      (list
    111       (list (make-segment :numbers '(-1  0) :dimension 1)
    112 	    (make-segment :numbers '( 0 -1) :dimension 1)
    113 	    (make-segment :numbers '( 0  0) :dimension 2)
    114 	    (make-segment :numbers '( 0  1) :dimension 1)
    115 	    (make-segment :numbers '( 1  0) :dimension 1))
    116       (loop for i below dimension collect
    117 	   (make-segment :numbers (list i 0) :dimension 1))
    118       (loop for i below dimension collect
    119 	   (make-segment :numbers (list (- i) 0) :dimension 1))
    120       (list (make-segment :numbers '(-1  0) :dimension 1)
    121 	    (make-segment :numbers '( 0 -1) :dimension 1)
    122 	    (make-segment :numbers '( 0  0) :dimension 3)
    123 	    (make-segment :numbers '( 0  1) :dimension 1)
    124 	    (make-segment :numbers '( 1  0) :dimension 1)))
    125      #'(lambda (s)
    126       (let ((x (find
    127 		(list (first s) (fourth s))
    128 		tbl
    129 		:test #'equalp
    130 		:key #'car)))
    131 	(if x
    132 	    (funcall (cdr (find (cdr x) ops :key #'car))
    133 		     (- (first (subscript-numbers (third s)))))
    134 	    0))))))
    135 
    136 (defun bose-hubbard-site-hamiltonian-b (dimension j u e)
    137   (let ((ops (cons
    138 	      (cons 'n #'(lambda (n) n))
    139 	      (bose-hubbard-site-operators j u e)))
    140 	(tbl (flet ((f (x y z)
    141 		      (cons (list (make-subscript
    142 				   :numbers (first x)
    143 				   :subscript (second x))
    144 				  (make-subscript
    145 				   :numbers (first y)
    146 				   :subscript (second y)))
    147 			    z)))
    148 	       (list
    149 		(f '((-1  0) 0) '(( 1  0) 0)    '1)
    150 		(f '(( 0 -1) 0) '(( 0  0) 0)   'b+)
    151 		(f '(( 0  0) 0) '(( 0  0) 0)    '1)
    152 		(f '(( 0  0) 1) '(( 0  0) 0)    'n)
    153 		(f '(( 0  0) 2) '(( 0 -1) 0) '-jb+)
    154 		(f '(( 0  0) 2) '(( 0  0) 0)    'h)
    155 		(f '(( 0  0) 2) '(( 0  0) 1)    '1)
    156 		(f '(( 0  0) 2) '(( 0  1) 0) '-jb-)
    157 		(f '(( 0  1) 0) '(( 0  0) 0)   'b-)
    158 		(f '(( 1  0) 0) '((-1  0) 0)    '1)))))
    159     (functional-tensor
    160      (list
    161       (list (make-segment :numbers '(-1  0) :dimension 1)
    162 	    (make-segment :numbers '( 0 -1) :dimension 1)
    163 	    (make-segment :numbers '( 0  0) :dimension 3)
    164 	    (make-segment :numbers '( 0  1) :dimension 1)
    165 	    (make-segment :numbers '( 1  0) :dimension 1))
    166       (loop for i below dimension collect
    167 	   (make-segment :numbers (list 0 i) :dimension 1))
    168       (loop for i below dimension collect
    169 	   (make-segment :numbers (list 0 (- i)) :dimension 1))
    170       (list (make-segment :numbers '(-1  0) :dimension 1)
    171 	    (make-segment :numbers '( 0 -1) :dimension 1)
    172 	    (make-segment :numbers '( 0  0) :dimension 2)
    173 	    (make-segment :numbers '( 0  1) :dimension 1)
    174 	    (make-segment :numbers '( 1  0) :dimension 1)))
    175      #'(lambda (s)
    176       (let ((x (find
    177 		(list (first s) (fourth s))
    178 		tbl
    179 		:test #'equalp
    180 		:key #'car)))
    181 	(if x
    182 	    (funcall (cdr (find (cdr x) ops :key #'car))
    183 		     (- (second (subscript-numbers (third s)))))
    184 	    0))))))
    185 
    186 (defun binary-bose-hubbard-site-hamiltonian (dimensiona dimensionb ja jb ua ub ux ea eb)
    187   (let ((a (bose-hubbard-site-hamiltonian-a dimensiona ja ua ea ux))
    188 	(b (bose-hubbard-site-hamiltonian-b dimensionb jb ub eb)))
    189     (tensor-fuse
    190      (tensor-permute
    191       (tensor-contract a 3 b 0)
    192       '(0 1 3 2 4 5))
    193      '(1 3 5)
    194      '(:normal :normal :reverse :reverse))))