path: root/fortran/navy_four_levels/FourLevelPulseProp_Double.f95

program FourLevelPulseProp_v3_Double
!
!	Written by:	Dr. Frank A. Narducci
!	Written on:	May 12, 2008
!
!	This program calculates the propagation of a pulse of arbitrary strength 
!	through a two level medium. The equations used are the full equations 
!	based on the Risken-Numedal discretization technique.
!
!	This program only "watches" the evolution of the pulse in the cell. This is 
!	due to the constraint that the cell is very small relative to the pulse lengths
!	that we want to use. If we watched the pulse outside the cell and then increased the 
!	resolution within the cell, the increased burden outside the cell because huge. 
!
!	v2 Notes: This program is based on the dimensionless equatiosn derived on 5/16
	implicit none
!	
!	Double Notes: This program is the same as TwoLevelPulseProp_v2 but with double precision
	complex ci
!
!	ThreeLevel Notes: This program is the same as TwoLevelPulseProp_v2_Double but now for a 
!	three level system
!
!	Four Level Notes: Valid to first order in dt
!
!	Version 3: Make a step function in the coupling field.

	character*150 fname
	integer nmat,npts,Nframe,Nframemax,NSkip,NWrite,zpts
	parameter (nmat=3,npts=100)	!matrix size, number of detuning points in dispersion curve
	!tpts is the number of temporal points in the cell 
	!zpts is the number of z output slices - 1
	parameter (zpts=100)	! Number of slices in z direction
	parameter (Nframemax=2000000)
	parameter (NWrite=1)		!number of frames to actually write
	integer m,n
	complex*16 a1,a2,a3,a4,a5,a6
	complex*16 b1,b2,b3,b4,b5,b6,b7
	complex*16 c1,c2,c3,c4,c5,c6
	complex*16 d1,d2,d3,d4,d5,d6,d7
	complex*16 e1,e2,e3,e4,e5
	complex*16 f1,f2,f3,f4,f5
	complex*16 g1,g2,g3,g4,g5,g6,g7
	complex*16 h1,h2,h3,h4,h5
	complex*16 i1,i2,i3,i4,i5,i6,i7
	complex*16 j1,j2,j3,j4,j5,j6,j7,j8
	complex*16 k1,k2,k3,k4,k5,k6,k7,k8,k9,k10
	complex*16 l1,l2,l3,l4,l5
	
	complex *16 Omold, Omold_vac
	real*8 alpha1,alpha2,alpha1tilde,alpha2tilde,alphac,alphactilde,beta,c,delmax,del1_prop,del2_prop,delc_prop
	real*8 dt,dz,eta
	real*8 W12,W21,W31,W32,W41,W42,W43,W34,ga12,ga13,ga14,ga23,ga24,ga34
	real*8 Ga2,Ga4,Om_crit
	real*8 Lcell,Om1peak,Om2peak,Omcpeak,pi,tmax,tmin,tp,tshift,t_end,t_start,t_elapsed
	real*8 tpeak,tpeak_vac
	real*8 epsil,hbar,lambda
	real*8 t,z(zpts)


	complex*16 Om1(zpts),Om2(zpts),Omc(zpts),Om_vac(zpts)
	complex*16 rho11(zpts),rho12(zpts),rho13(zpts),rho14(zpts),rho21(zpts),rho22(zpts),rho23(zpts),rho24(zpts)
	complex*16 rho31(zpts),rho32(zpts),rho33(zpts),rho34(zpts),rho41(zpts),rho42(zpts),rho43(zpts),rho44(zpts)
	complex*16 rho11_last(zpts),rho12_last(zpts),rho13_last(zpts),rho14_last(zpts)
	complex*16 rho21_last(zpts),rho22_last(zpts),rho23_last(zpts),rho24_last(zpts)
	complex*16 rho31_last(zpts),rho32_last(zpts),rho33_last(zpts),rho34_last(zpts)
	complex*16 rho41_last(zpts),rho42_last(zpts),rho43_last(zpts),rho44_last(zpts)
	
	!No Om_last because we never need the previous spatial point

	common/para/ga12,W21


	! Fundamental numbers
	ci=cmplx(0.,1.)
	pi=acos(-1.0)
	c=3e8
	hbar=1.055e-34
	epsil=8.85e-12

	! Atomic numbers (based on Rubidium 85)
	beta=2*pi*3e6	!in Hz
	W41=0
	W42=1
	W43=0
	W32=1.
	W31=1.
	W21=.001
	W12=W21
	W34=0
	ga12=0.5*(W21+W12)
	ga13=0.5*(W31+W12+W32)
	ga14=0.5*(W41+W42+W12)
	ga23=0.5*(W32+W31+W21)
	ga24=0.5*(W21+W41+W42+W43)
	ga34=0.5*(W31+W41+W32+W42+W43)
	lambda=780.24e-9
	
	! Atomic parameters
	write (*,*)'New version from moved folder'
	eta=6.9e11	! density in m^-1
	alpha1=3*eta*lambda*lambda/(2*pi)
	alpha1tilde=alpha1*c/beta
	alpha2=3*eta*lambda*lambda/(2*pi)
	alpha2tilde=alpha2*c/beta
	alphac=3*eta*lambda*lambda/(2*pi)
	alphactilde=alphac*c/beta


	! User defined numbers
	Om1peak=0.01	! Field 1 peak scaled Rabi frequency for the pump at entrance of cell
	Om2peak=1	! Field 2 peak scaled Rabi frequency for the pump at entrance of cell
	Omcpeak=0.0	! Field 3 peak scaled Rabi frequency for the pump at entrance of cell
	! Maximum detuning in MHz for dispersion lineshape plot
	delmax=0
	Ga4=(W41+W42+W43)
	Ga2=W21
	Om_crit=sqrt(Om1peak**4+4*Om1peak*Om1peak*(Ga4*Ga4+Ga2*Ga4))
	Om_crit=Om_crit-Om1peak*Om1peak-2*Ga2*Ga4
	Om_crit=sqrt(Om_crit/2)
	write (*,*)'Om_crit = ',Om_crit


	! Now that the user has an idea of the dispersion, do the full propagation problem

	! Detuning of center frequency of the coupling pulse in MHz
	delc_prop=0
	delc_prop=2*pi*1e6*delc_prop/beta	!Now dimensionless

	! Detuning of center frequency of the pump pulse in MHz
	del2_prop=0.
	del2_prop=2*pi*1e6*del2_prop/beta	!Now dimensionless
	! Detuning of center frequency of the probe pulse in MHz
	del1_prop=0.
	del1_prop=2*pi*1e6*del1_prop/beta	!Now dimensionless
	

	! Pulse width in nsec
	tp=1e-6
	tp=beta*tp	!Now dimensionless
	! Length of cell in m
	Lcell=100
	Lcell=beta*Lcell/c	!Now dimensionless
	t_start=secnds(0.E0)
	write (*,*)'t_start = ',t_start
	!
	! Set up initial pulse.
	!
	tshift=0
        write (*,*) 'peak center at the cell begining i.e. tshift = ', tshift
	tmax=Lcell*20	!Length of time to pass cell (no c because we're dimensionless)
	tmax=60.0
	tmin = -tmax
	write(*,*) 'tmax = ', tmax
	write(*,*) 'Lcell = ', Lcell
	dz=Lcell/(zpts-1)	!(no c because we're dimensionless)
	! It is crucial that dz = dt in unitless coordinates, there is built in
	! cancellation of some term on grid because of it. See Simon's note.
	dt = dz 
	Nframe=(tmax-tmin)/dz+1
	if (Nframe.ge.Nframemax) write (*,*)'Error!!!!Nframe>Nframemax'	
	!
	! Initialize matrices
	!
	Omold=cmplx(0.,0.)
	Omold_vac=cmplx(0.,0.)
	tpeak=-1
	tpeak_vac=-1
	write (*,*)'Nframe= ', Nframe

	do m=1,zpts
		Om1(m)=cmplx(0.,0.)
		Om2(m)=cmplx(0.,0.)
		Omc(m)=cmplx(0.,0.)

		Om_vac(m)=cmplx(0.,0.)
		rho11(m)=cmplx(1.,0.)	!Change this to change the initial condition
		rho12(m)=cmplx(0.,0.)
		rho13(m)=cmplx(0.,0.)
		rho14(m)=cmplx(0.,0.)
		rho21(m)=cmplx(0.,0.)
		rho22(m)=cmplx(0.,0.)
		rho23(m)=cmplx(0.,0.)
		rho24(m)=cmplx(0.,0.)
		rho31(m)=cmplx(0.,0.)
		rho32(m)=cmplx(0.,0.)
		rho33(m)=cmplx(0.,0.)
		rho34(m)=cmplx(0.,0.)
		rho41(m)=cmplx(0.,0.)
		rho42(m)=cmplx(0.,0.)
		rho43(m)=cmplx(0.,0.)
		rho44(m)=cmplx(0.,0.)
		
	end do



	!	Propagation co-efficients
	!
	
	a1=1.
	a2=0.5*ci*alpha1tilde*dt
	a3=0.5*ci*alpha1tilde*dt
	a4=0.
	a5=0.
	a6=0.
	
	b1=1.
	b2=0.5*ci*alpha2tilde*dt
	b3=0.5*ci*alpha2tilde*dt
	b4=0.
	b5=0.
	b6=0.
	b7=0.
	
	c1=1.
	c2=0.5*ci*alphactilde*dt
	c3=0.5*ci*alphactilde*dt
	c4=0.
	c5=0.
	c6=0.
	
	d1=1-(ga12-ci*(del2_prop-del1_prop))*dt
	d2=0.25*ci*dt
	d3=-0.25*ci*dt
	d4=-0.25*ci*dt
	d5=0.25*ci*dt
	d6=-0.25*ci*dt
	d7=-0.25*ci*dt
	
	e1=1-(ga13+ci*del1_prop)*dt
	e2=0.25*ci*dt
	e3=-0.25*ci*dt
	e4=0.25*ci*dt
	e5=-0.25*ci*dt
	
	f1=1-(ga14-ci*(del2_prop-del1_prop-delc_prop))*dt
	f2=0.25*ci*dt
	f3=-0.25*ci*dt
	f4=0.25*ci*dt
	f5=-0.25*ci*dt
	
	g1=1-(ga23+ci*del1_prop)*dt
	g2=-0.25*ci*dt
	g3=0.25*ci*dt
	g4=0.25*ci*dt
	g5=-0.25*ci*dt
	g6=0.25*ci*dt
	g7=0.25*ci*dt
	
	h1=1-(ga24+ci*delc_prop)*dt
	h2=0.25*ci*dt
	h3=0.25*ci*dt
	h4=0.25*ci*dt
	h5=0.25*ci*dt
	
	i1=1-(ga34-ci*(del2_prop-delc_prop))*dt
	i2=-0.25*ci*dt
	i3=0.25*ci*dt
	i4=0.25*ci*dt
	i5=-0.25*ci*dt
	i6=0.25*ci*dt
	i7=0.25*ci*dt
	
	j1=1-W12*dt
	j2=W21*dt
	j3=W31*dt
	j4=0.25*ci*dt
	j5=-0.25*ci*dt
	j6=0.25*ci*dt
	j7=-0.25*ci*dt
	j8=W41*dt
	
	k1=1-(W32+W31+W34)*dt
	k2=W43*dt
	k3=-0.25*ci*dt
	k4=-0.25*ci*dt
	k5=0.25*ci*dt
	k6=0.25*ci*dt
	k7=-0.25*ci*dt
	k8=-0.25*ci*dt
	k9=0.25*ci*dt
	k10=0.25*ci*dt
	
	l1=1-(W43+W42+W41)*dt
	l2=-0.25*ci*dt
	l3=0.25*ci*dt
	l4=-0.25*ci*dt
	l5=0.25*ci*dt

	NSkip=int(NFrame/NWrite)	
							
	fname='MovieParameters4level.txt' ! File name to save parameters
	open(9,file=fname)
	write (9,133)Nframe,zpts,beta,NSkip,dt
133	format(1x,i10,',',i5,',',f12.2,',',i5,',',f12.2)
	close (9)
	
	fname='Movie4level.dat' ! File name to save movie
	open(9,file=fname)

	fname='Movie4level_EndPoints.dat' ! File name to save endpoints
        open(10,file=fname)

        do n=1,Nframe
                t=tmin+float(n-1)*dt
                Om1(1)=Om1peak*exp(-(t-tshift)**2/(tp*tp))	
                Om2(1)=Om2peak
                Omc(1)=Omcpeak
                Om_vac(1)=Om1(1)

		do m=1,zpts
			rho11_last(m)=rho11(m)
			rho12_last(m)=rho12(m)
			rho13_last(m)=rho13(m)
			rho14_last(m)=rho14(m)
			rho21_last(m)=rho21(m)
			rho22_last(m)=rho22(m)
			rho23_last(m)=rho23(m)
			rho24_last(m)=rho24(m)
			rho31_last(m)=rho31(m)
			rho32_last(m)=rho32(m)
			rho33_last(m)=rho33(m)
			rho34_last(m)=rho34(m)
			rho41_last(m)=rho41(m)
			rho42_last(m)=rho42(m)
			rho43_last(m)=rho43(m)
			rho44_last(m)=rho44(m)
	        end do

		do m=zpts,2,-1
			z(m)=float(m-1)*dz
			
			Om_vac(m)=a1*Om_vac(m-1)

			Om1(m)=a1*Om1(m-1)+a2*rho31_last(m)+a3*rho31_last(m-1)

			Om2(m)=b1*Om2(m-1)+b2*rho32_last(m)+b3*rho32_last(m-1)
			
			Omc(m)=c1*Omc(m-1)+c2*rho42_last(m)+c3*rho42_last(m-1)

			rho11(m)=j1*rho11_last(m)+j2*rho22_last(m)+j3*rho33_last(m)+j4*conjg(Om1(m))*rho31_last(m)
			rho11(m)=rho11(m)+j5*Om1(m)*rho13_last(m)+j6*conjg(Om1(m-1))*rho31_last(m)+j7*Om1(m-1)*rho13_last(m)
			rho11(m)=rho11(m)+j8*rho44_last(m)
			
			rho12(m)=d1*rho12_last(m)+d2*conjg(Om1(m))*rho32_last(m)+d3*Om2(m)*rho13_last(m)
			rho12(m)=rho12(m)+d4*Omc(m)*rho14_last(m)+d5*conjg(Om1(m-1))*rho32_last(m)
			rho12(m)=rho12(m)+d6*Om2(m-1)*rho13_last(m)+d7*Omc(m-1)*rho14_last(m)

			rho13(m)=e1*rho13_last(m)+e2*conjg(Om1(m))*(rho33_last(m)-rho11_last(m))
			rho13(m)=rho13(m)+e3*conjg(Om2(m))*rho12_last(m)+e4*conjg(Om1(m-1))*(rho33_last(m)-rho11_last(m))
			rho13(m)=rho13(m)+e5*conjg(Om2(m-1))*rho12_last(m)
			
			rho14(m)=f1*rho14_last(m)+f2*conjg(Om1(m))*rho34_last(m)+f3*conjg(Omc(m))*rho12_last(m)
			rho14(m)=rho14(m)+f4*conjg(Om1(m-1))*rho34_last(m)+f5*conjg(Omc(m-1))*rho12_last(m)
			
			rho21(m)=conjg(rho12(m))
			
			! rho22(m) needs to be calculated lower down

			rho23(m)=g1*rho23_last(m)+g2*conjg(Om1(m))*rho21_last(m)+g3*conjg(Om2(m))*(rho33_last(m)-rho22_last(m))
			rho23(m)=rho23(m)+g4*conjg(Omc(m))*rho43_last(m)+g5*conjg(Om1(m-1))*rho21_last(m)
			rho23(m)=rho23(m)+g6*conjg(Om2(m-1))*(rho33_last(m)-rho22_last(m))+g7*conjg(Omc(m-1))*rho43_last(m)
			
			rho24(m)=h1*rho24_last(m)+h2*conjg(Om2(m))*rho34_last(m)+h3*conjg(Omc(m))*(rho44_last(m)-rho22_last(m))
			rho24(m)=rho24(m)+h4*conjg(Om2(m-1))*rho34_last(m)+h5*conjg(Omc(m-1))*(rho44_last(m)-rho22_last(m))
			
			rho31(m)=conjg(rho13(m))
			
			rho32(m)=conjg(rho23(m))
			
			rho33(m)=k1*rho33_last(m)+k2*rho44_last(m)+k3*conjg(Om1(m))*rho31_last(m)+k4*conjg(Om2(m))*rho32_last(m)
			rho33(m)=rho33(m)+k5*Om1(m)*rho13_last(m)+k6*Om2(m)*rho23_last(m)+k7*conjg(Om1(m-1))*rho31_last(m)
			rho33(m)=rho33(m)+k8*conjg(Om2(m-1))*rho32_last(m)+k9*Om1(m-1)*rho13_last(m)+k10*Om2(m-1)*rho23_last(m)
			
			rho34(m)=i1*rho34_last(m)+i2*conjg(Omc(m))*rho32_last(m)+i3*Om1(m)*rho14_last(m)+i4*Om2(m)*rho24_last(m)
			rho34(m)=rho34(m)+i5*conjg(Omc(m-1))*rho32_last(m)+i6*Om1(m-1)*rho14_last(m)+i7*Om2(m-1)*rho24_last(m)
			
			rho41(m)=conjg(rho14(m))

			rho42(m)=conjg(rho24(m))

			rho43(m)=conjg(rho34(m))
			
			rho44(m)=l1*rho44_last(m)+l2*conjg(Omc(m))*rho42_last(m)+l3*Omc(m)*rho24_last(m)
			rho44(m)=rho44(m)+l4*conjg(Omc(m-1))*rho42_last(m)+l5*Omc(m-1)*rho24(m)
			
			rho22(m)=1-rho11(m)-rho33(m)-rho44(m)
			
			
			rho11_last(m)=rho11(m)
			rho12_last(m)=rho12(m)
			rho13_last(m)=rho13(m)
			rho14_last(m)=rho14(m)
			rho21_last(m)=rho21(m)
			rho22_last(m)=rho22(m)
			rho23_last(m)=rho23(m)
			rho24_last(m)=rho24(m)
			rho31_last(m)=rho31(m)
			rho32_last(m)=rho32(m)
			rho33_last(m)=rho33(m)
			rho34_last(m)=rho34(m)
			rho41_last(m)=rho41(m)
			rho42_last(m)=rho42(m)
			rho43_last(m)=rho43(m)
			rho44_last(m)=rho44(m)



			write (9,120) t,z(m),cdabs(Om1(m)),cdabs(Om2(m)),cdabs(Omc(m)),cdabs(Om_vac(m))

                end do
		if (cdabs(Om2(zpts)).gt.cdabs(Omold))	 tpeak=t
		if (cdabs(Om_vac(zpts)).gt.cdabs(Omold_vac)) tpeak_vac=t
		write (10,139) t,cdabs(Om1(zpts)),cdabs(Om_vac(zpts))	!EndPoint File
		Omold=Om2(zpts)
		Omold_vac=Om_vac(zpts)

	end do

	close(9)
	close(10)
139	format(1x,f12.6,',',F12.6,',',F12.6)
120	format(f12.6,',',f12.6,',',f12.6,',',f12.6,',',f12.6,',',f12.6,',',f12.6,',',f12.6,',',f12.6)
	t_end=secnds(0.E0)
	t_elapsed=t_end-t_start
	write(*,*)'T elapsed = ',t_elapsed
	stop
end