C.5. Năng lượng của hệ
1.3. Giải phương trình Hartree-Fock
HartreeFock[ _, _,d_,k_,V0_]:=Module[{ =2 d,h=0,t1=0,t2=0}, t1=First[Timing[
InitialiseMatrixElements[ ];]];
t2=First[Timing[
InitialiseCoefficients[ , ,k];
StateSolve[ , ,k,V0,h];
While[Abs[ ]>d, h++;
StateSolve[ , ,k,V0,h];
= [ , ,k,h+1]- [ , ,k,h]
] ]];
SaveIntegrals;
PrintOutput[ , ,h];
Print["Initialisation Time = ",t1];
Print["Running Time = ",t2]
]
InitialiseMatrixElements[ _]:=Module[{}, SetDirectory[$HomeDirectory];
If[FileNames["HFData"]=={},CreateDirectory["HFData"]];
If[FileNames[ToFileName["HFData","matrix"<>ToString[ ]<>".mx"]]=={},
Table[ X {i,j},{p,q},1 \ ,{i,0, -1},{j,0, -1},{p,0, -1},{q,0, -1}];
Table[ X {i,j},{p,q},2 \ ,{i,0, -1},{j,0, -1},{p,0, -1},{q,0, -1}];
DumpSave[ToFileName["HFData","matrix"<>ToString[ ]<>".mx"],AngleBracket], Get[ToFileName["HFData","matrix"<>ToString[ ]<>".mx"]]];
If[FileNames[ToFileName["HFData","d.mx"]]π{}, Get[ToFileName["HFData","d.mx"]]];
If[FileNames[ToFileName["HFData","f.mx"]]π{}, Get[ToFileName["HFData","f.mx"]]]
]
InitialiseCoefficients@ _, _, k_D:= Module@8c, m , n<, c = Table@0,8j, <D;
Do@n = PiTP1T; m = PiTP2T;
cê: cPiT,0= NormaliseCoefficients@ReplacePart@c, 1, n + 1D, k, mD; ,8i, Length@D<D
D
NormaliseCoefficients@c_List, k_, m_D:= c
"########################################c . Length@cD@k, mD.c ; StateSolve@ _, _, k_, V0_, h _D:= ModuleA8l,ả, c<,
DoAl = PiT; 8ả, c<=
TransposeA
SelectAIChopAEigensystemAH@k, lP2TDL-1. @l, , k, V0, hD êêNEEMT, First@#1D< 0 &EE;
cê: cl,h+1= Part@NormaliseCoefficients@#1, k, lP2TD&êû c, lP1T+1D; ờ: l,h+1=ảPlP1T+1T;
,8i, Length@D<E E
SaveIntegrals:=Module[{},
DumpSave[ToFileName["HFData","d.mx"], ];
DumpSave[ToFileName["HFData","f.mx"],];
ResetDirectory[];
]
PrintOutput@ _, _, h_D:= ModuleB8Hartree = 27.2116, e = 12.53, = 0.067<, DoBê:Length@D,@@iDD= 1000 Hartree
e2 @@iDD,h+1;
ê:Length@D,@@iDD= c@@iDD,h+1, 8i, Length@D<F;
ê:Length@D= 1000 Hartree
e2 @ , , k, h + 1D; Print@"Total Energy = ", Length@D, " meV"D; Print@"Number of Iterations = ", h +1D; Print@"Convergence = ", D
F
PHỤ LỤC E: Chương trình Fortran xác định hệ số hấp thụ ánh sáng
implicit double precision (a-h,o-z) parameter(nmx1=400000,nmx2=200)
parameter(nprg=5000,ftol=1d-12,eps=1d-15,dlt=.1) parameter(nmnm=-20,nmm_ps=12,nmm_ng=12)
parameter(nmnmab=abs(nmnm),nmn=nmnmab/2)
parameter(nmm=max((abs(nmm_ps)),(abs(nmm_ng)))) parameter(nmf=2*nmn+nmm,nmc=4*nmn+2*nmm,nmcp=nmc+1) parameter(nmdf=max(4*(nmn+2*nmm+2),4*(2*nmn+nmm)-1)) parameter(nma1=max(2*nmc,nmc+1))
dimension mna(nmx2),mnb(nmx2),ina(nmx2),inb(nmx2) dimension idn2p(2*nmx2),idp2n(0:nmn,-nmm_ng:nmm_ps) dimension bs(0:nmx1),idbs(nmx1),bsh(0:nmx1),idbsh(nmx1)
dimension ea(nmx2),eb(nmx2),ea2(nmx2),eb2(nmx2),eh(nmx2),eh2(nmx2) dimension fa((nmx2*(nmx2+1))/2),fb((nmx2*(nmx2+1))/2)
dimension pa(nmx2*nmx2),pb(nmx2*nmx2),ph(nmx2*nmx2) dimension ca(nmx2*nmx2),cb(nmx2*nmx2),v(nmx2*nmx2) dimension ca2(nmx2*nmx2),cb2(nmx2*nmx2),v2(nmx2*nmx2)
dimension w(nmx2*6),lw(nmx2*3),c0(nmx2*nmx2),c02(nmx2*nmx2) dimension fact(-1:nmf),dfact(-3:nmdf)
dimension comb(((nmc+1)*(nmc+2))/2)
dimension fh((nmx2*(nmx2+1))/2),ff((nmx2*(nmx2+1))/2) dimension mnh(nmx2),inh(nmx2),id(nmx2)
dimension ehm(nmx2*nmx2),ideh(2*nmx2) dimension cam(nmx2*nmx2),cbm(nmx2*nmx2)
dimension mnam(nmx2),mnbm(nmx2),inam(nmx2),inbm(nmx2) dimension mnhm(nmx2),inhm(nmx2)
parameter (mcd=20)
dimension ix(1:mcd),tranup(nmx2,nmx2),trandn(nmx2,nmx2),rr_(0:2) parameter(ie=1000)
dimension absorp1(0:ie),absorp2(0:ie),absorp3(0:ie) dimension app1(0:ie),app2(0:ie)
dimension oscsum(nmx2),osumh(nmx2),osume(nmx2)
if (nmcp.gt.nmx2*nmx2) stop 'nmx2*nmx2 is small.' if (nmcp.gt.nmx2*6) stop 'nmx2*6 is small.'
if (mod(nmx1,nprg).ne.0) stop 'change nprg.' if (nmm_ps+nmm_ng.lt.0) stop 'change nmm_.' pi=1
pi=4*atan(pi)
C Calculate n!, n!! and Combitorial fact(-1)=1
fact(0)=1 wk=1
do i=1,nmf fact(i)=wk wk=wk*(i+1) enddo
dfact(-3)=1 dfact(-1)=1 wk=1
do i=1,nmdf,2 dfact(i)=wk wk=wk*(i+2) enddo
dfact(-2)=1 dfact(0)=1 wk=2
do i=2,nmdf,2 dfact(i)=wk wk=wk*(i+2) enddo
do i=0,nmc
iwk=(i*(i+1))/2+1 comb(iwk)=1
comb(iwk+i)=1 enddo
do i=2,nmc do j=1,i-1
comb((i*(i+1))/2+j+1)=comb(((i-1)*i)/2+j+1) $ +comb(((i-1)*i)/2+j)
enddo enddo
open(1,file='param.dat')
read(1,*) itm,ifrg,rr,na,nb,rlx,c,gf,rlxh,hb,hbh,em,emh read(1,*)
read(1,*) read(1,*) read(1,*) read(1,*) read(1,*) read(1,*)
read(1,*) read(1,*) ieh close(1)
if (na.ge.1.and.(mna(na).gt.nmm_ps.or.mna(1).lt.-nmm_ng)) $ stop 'Bad mna parameter.'
if (nb.ge.1.and.(mnb(nb).gt.nmm_ps.or.mnb(1).lt.-nmm_ng)) $ stop 'Bad mnb parameter.'
if (na+nb+1.gt.mcd)stop'Increase mcd!' nab=na+nb
rr_(0)=rr
if (rr.ge.0.81) then rr_(1)=0.5
rr_(2)=0.8
elseif (rr.lt.0.81.and.rr.ge.0.51) then rr_(1)=1
rr_(2)=0.5 else
rr_(1)=1 rr_(2)=0.8 endif
Ry2=11.61 r2=2 c2=c*hb/2 c2h=c*hbh/2 a=1/(rlx*rlx) oe=Ry2*a
ah=1/(rlxh*rlxh) oh=Ry2*ah
a=sqrt(a*a+c2*c2) ah=sqrt(ah*ah+c2h*c2h) gma=sqrt(em/emh*a/ah)
write(*,'(1x,a,20e15.5)')'em,emh,B,gma=',em,emh,c,gma C base.dat for e-e matrix elements
open(1,file='base.dat',form='unformatted')
read(1) mbs,nmbs,iwk3,iwk4,iwk5,iwk6,wk1,wk2,wk3,wk4,wk5,wk6,wk7 if (mbs.gt.nmx1.or.wk1.ne.rlx.or.wk2.ne.c.or.wk3.ne.rlxh.or.wk4.
$ ne.hb.or.wk5.ne.hbh.or.wk6.ne.em.or.wk7.ne.emh)then close(1)
write(*,*) mbs,wk1,wk2,wk3,wk4,wk5,wk6,wk7 write(*,*) nmx1,rlx,c,rlxh,hb,hbh,em,emh stop 'cannot read this base.dat file.' endif
read(1) (idbs(i),i=1,mbs) read(1) (bs(i),i=1,mbs) close(1)
write(*,*) mbs,nmbs,nmnm,nmm,nmm_ps,nmm_ng write(*,*) itm,ifrg,rr,na,nb,rlx,c,gf,rlxh
c test for no e-h interaction: put ieh=0 in 'param.dat' if(ieh.ne.0)then
C baseh.dat for e-h matrix elements
open(1,file='baseh.dat',form='unformatted')
read(1) mbsh,nmbsh,iwk3,iwk4,iwk5,iwk6,wk1,wk2,wk3,wk4,wk5,wk6,wk7 if (mbsh.gt.nmx1.or.wk1.ne.rlx.or.wk2.ne.c.or.wk3.ne.rlxh.or.wk4.
$ ne.hb.or.wk5.ne.hbh.or.wk6.ne.em.or.wk7.ne.emh)then close(1)
stop 'cannot read this baseh.dat file.'
endif
read(1) (idbsh(i),i=1,mbsh) read(1) (bsh(i),i=1,mbsh) close(1)
else
nmbsh=nmbs mbsh=mbs do i=1,nmx1 bsh(i)=0 idbsh(i)=0 enddo
endif
if (nmbs.ne.nmbsh) stop 'nmbs<>nmbsh'
c first run ground.f to obtain the 'ground.dat' for the ground state c pause 'Have you ground.dat, continue?'
open(1,file='ground.dat',form='unformatted') read(1)nmbs,nam,nbm
read(1)(idn2p(i),i=1,nmbs*2) read(1)(ea(i),i=1,nam)
read(1)(eb(i),i=1,nbm),e0i
read(1)((cam(i+(j-1)*nmbs),i=1,nmbs),j=1,nam) read(1)((cbm(i+(j-1)*nmbs),i=1,nmbs),j=1,nbm) read(1)(inam(i),mnam(i),i=1,nam)
read(1)(inbm(i),mnbm(i),i=1,nbm) close(1)
write(*,*)'e0min=',e0i do i=1,nmbs
idp2n(idn2p(i*2-1),idn2p(i*2))=i enddo
if(nam+nbm.ne.nab) then
write(*,'(1x,a,i3)')'Not correct ground state for N=',nab stop
endif
if (nab.ne.0) then
open(1,file='tranN0.dat',form='unformatted') read(1) iwk,wk1,wk2,wk3,wk4,wk5,wk6,wk7
if (iwk.ne.nmbs.or.wk1.ne.rlx.or.wk2.ne.c.or.wk3.ne.rlxh.
$ or.wk4.ne.hb.or.wk5.ne.hbh.or.wk6.ne.em.or.wk7.ne.emh)then close(1)
stop 'cannot read this tranN0.dat file.' endif
read(1) ((tranup(i,j),i=1,nmbs),j=1,nmbs) read(1) ((trandn(i,j),i=1,nmbs),j=1,nmbs) close(1)
else
do i=1,nmbs do j=1,nmbs tranup(i,j)=0 trandn(i,j)=0 enddo
enddo endif
c calculate electron-photon interaction
call ehmatx(nmbs,nmx2,idn2p,fact,dfact,comb, $ nmf,nmdf,nmc,gma, mbse,ehm,ideh)
write(*,*)'Total number of e-h matrix elements=',mbse
c pause itran=15 c for strong case E1=0.0 E2=26.0
Eg=1500.0/Ry2 damp1=0.1 damp2=0.5 damp30=2.0 damp31=1.1 c for weak case c E1=-1.
c E2=5.
c damp1=0.01 c damp2=0.1 c damp30=0.5 c damp31=0.2 delE=(E2-E1)/ie
write(*,*)'delE=',delE do i=0,ie
absorp1(i)=0 absorp2(i)=0 absorp3(i)=0 app1(i)=0 app2(i)=0 enddo
open(1,file='myview.dat',access='append') write(1,*)'B=',c,' a=',a ,' ah=',ah close(1)
open(1,file='shift',access='append')
write(1,'(1x,a,F8.4,a,F8.4,a,F8.4,a,F5.2,a,F5.2)')
$ 'B=',c,' me=',em,' mh=',emh,' oe=',oe,' oh=',oh write(1,*)'N-1=',nam+nbm
write(1,*)'a:',(i,':',inam(i),mnam(i),i=1,nam) write(1,*)'b:',(i,':',inbm(i),mnbm(i),i=1,nbm) close(1)
do i=1,nmbs oscsum(i)=0 osumh(i)=0 osume(i)=0 enddo
do icch=1,itran do i=1,nmbs id(i)=0 enddo do i=1,nam
id(idp2n(inam(i),mnam(i)))=1 enddo
do i=1,nbm
id(idp2n(inbm(i),mnbm(i)))=2+id(idp2n(inbm(i),mnbm(i))) enddo
c write(*,*)(idp2n(idn2p(i*2-1),idn2p(i*2)),':',idn2p(i*2-1), c $ idn2p(i*2),id(i),i=1,nmbs)
c pause
nh=1
inhm(nh)=idn2p(2*icch-1) mnhm(nh)=idn2p(2*icch)
iosch=2*inhm(nh)+abs(mnhm(nh))+1 do icc=1,itran
c do icc=icch,icch !for metric case
if((mnhm(nh).eq.idn2p(2*icc)).and.(id(icc).lt.3))then
if(em.eq.emh.and.rlx.eq.rlxh.and.inhm(nh).ne.idn2p(2*icc-1)) $ goto 333
do iccc=1,2
c iccc=1 for up-spin, iccc=2 for down-spin inh(nh)=inhm(nh)
mnh(nh)=mnhm(nh) if (iccc.eq.1)then
if (id(icc).eq.1) goto 222 id(icc)=id(icc)+1
na=nam+1 nb=nbm
ina(na)=idn2p(2*icc-1) mna(na)=idn2p(2*icc)
c write(*,112)'icch,nh-a:',icch,inh(1),mnh(1),' - ',ina(na), c $ mna(na)
else
if (id(icc).ge.2)goto 222 id(icc)=id(icc)+2
na=nam nb=nbm+1
inb(nb)=idn2p(2*icc-1) mnb(nb)=idn2p(2*icc)
c write(*,112)'icch,nh-b:',icch,inh(1),mnh(1),' - ',inb(nb), c $ mnb(nb)
endif
112 format(1x,a,3i3,a,2i3)
iosce=2*idn2p(2*icc-1)+abs(idn2p(2*icc))+1 do i=1,nam
ina(i)=inam(i) mna(i)=mnam(i) enddo
do i=1,nbm
inb(i)=inbm(i) mnb(i)=mnbm(i) enddo
c write(*,*)'a:',(i,':',ina(i),mna(i),i=1,na) c write(*,*)'b:',(i,':',inb(i),mnb(i),i=1,nb) c write(*,*)'h:',inh(1),mnh(1)
c pause
do i=1,nmx2*nmx2 ca(i)=0
cb(i)=0 c0(i)=0 pa(i)=0 pb(i)=0 ph(i)=0 enddo
C we can take the initial pa(i)=pb(i)=0, however it'd better to do so:
if(na.ge.1) then do i=1,na
if (nmnm.ge.1) then
if(ina(i)*2+(abs(mna(i))).gt.nmnm)stop 'nmnm is small.' else
if(ina(i).gt.nmnmab/2) stop 'nmnmab is small.' endif
ca(idp2n(ina(i),mna(i))+(i-1)*nmbs)=1 enddo
endif
if(nb.ge.1) then do i=1,nb
if (nmnm.ge.1) then
if(inb(i)*2+(abs(mnb(i))).gt.nmnm)stop 'nmnm is small.' else
if(inb(i).gt.nmnmab/2) stop 'nmnmab is small.' endif
cb(idp2n(inb(i),mnb(i))+(i-1)*nmbs)=1 enddo
endif
if(nh.ge.1) then do i=1,nh
if (nmnm.ge.1) then
if(inh(i)*2+(abs(mnh(i))).gt.nmnm)stop 'nmnm is small.' else
if(inh(i).gt.nmnmab/2) stop 'nmnmab is small.' endif
cb(idp2n(inh(i),mnh(i))+(i-1)*nmbs)=1 enddo
endif
C ’èâ’ÅÙ’ạễ’ẻú’Ôẻ’ẵộ’´ỹ’Àò’Äờ do i=1,nmbs
do j=1,nmbs wk1=0 wk2=0 wk3=0 do k=1,na
wk1=wk1+ca(i+(k-1)*nmbs)*ca(j+(k-1)*nmbs) enddo
do k=1,nb
wk2=wk2+cb(i+(k-1)*nmbs)*cb(j+(k-1)*nmbs) enddo
do k=1,nh
wk2=wk2+c0(i+(k-1)*nmbs)*c0(j+(k-1)*nmbs) enddo
pa(j+(i-1)*nmbs)=wk1 pb(j+(i-1)*nmbs)=wk2 ph(j+(i-1)*nmbs)=wk3 enddo
enddo
do i=1,nmx2*nmx2 ca(i)=0
cb(i)=0 c0(i)=0 pa(i)=0 pb(i)=0 ph(i)=0 enddo
iwk2=(nab+nh)*nmbs
if (nab+nh.eq.0) iwk2=nmbs irr=0
rr=rr_(irr) 2222 do ic=1,itm,2 if(ic.eq.31)then irr=irr+1
if (irr.gt.10)stop'failed to convergence!' write(*,*)'Bad convergence for rr=',rr rr=rr_(mod(irr,3))
write(*,*)'Change to -> new rr=',rr goto 2222
endif
call fmatrx(a,c2,ah,c2h,nmbs,mbs,nmx1,nmx2,mbsh, $ idn2p,idbs,idbsh,bs,bsh,pa,pb,ph, fa,fb,fh) c write(*,*)'fa=',(fa(i),i=1,nmbs)
c do i=1,nmbs
c write(*,*)'fh=',(fh((i-1)*i/2+j),j=1,nmbs) c enddo
c do i=1,nmbs
c write(*,*)'fa=',(fa((i-1)*i/2+j),j=1,nmbs) c enddo
wk1=0
call eigrs(fa,nmbs,-nmbs,nmbs,eps,w,lw,ea2,v2) c write(*,*)(ea2(i),i=1,nmbs)
call new(v2,ea2,lw,nmx2,nmbs,idn2p,na,mna,ina, v,ea) c write(*,*)'ea=', ea2(1), ea(1)
do i=1,nmbs do j=1,nmbs wk=0
do k=1,na
wk=wk+v(i+(k-1)*nmbs)*v(j+(k-1)*nmbs) enddo
wk1=wk1+(wk-pa(j+(i-1)*nmbs))*(wk-pa(j+(i-1)*nmbs)) enddo
enddo do i=1,na do j=1,nmbs
ca2(j+(i-1)*nmbs)=(1-rr)*ca(j+(i-1)*nmbs)+rr*v(j+(i-1)*nmbs) enddo
enddo
do i=1,nmbs do j=1,nmbs wk=0
do k=1,na
wk=wk+ca2(i+(k-1)*nmbs)*ca2(j+(k-1)*nmbs) enddo
pa(j+(i-1)*nmbs)=wk enddo
enddo
call eigrs(fb,nmbs,-nmbs,nmbs,eps,w,lw,eb2,v2)
call new(v2,eb2,lw,nmx2,nmbs,idn2p,nb,mnb,inb, v,eb) do i=1,nmbs
do j=1,nmbs wk=0
do k=1,nb
wk=wk+v(i+(k-1)*nmbs)*v(j+(k-1)*nmbs) enddo
wk1=wk1+(wk-pb(j+(i-1)*nmbs))*(wk-pb(j+(i-1)*nmbs)) enddo
enddo do i=1,nb do j=1,nmbs
cb2(j+(i-1)*nmbs)=(1-rr)*cb(j+(i-1)*nmbs)+rr*v(j+(i-1)*nmbs) enddo
enddo do i=1,nmbs do j=1,nmbs wk=0
do k=1,nb
wk=wk+cb2(i+(k-1)*nmbs)*cb2(j+(k-1)*nmbs) enddo
pb(j+(i-1)*nmbs)=wk enddo
enddo
call eigrs(fh,nmbs,-nmbs,nmbs,eps,w,lw,eh2,v2) c write(*,*)(eh2(i),i=1,nmbs)
c do j=1,nmbs
c write(*,'(1x,F5.3,3x,F5.3,3x,F5.3)')(v2((i-1)*nmbs+j),i=1,nmbs) c enddo
c do j=1,nmbs
c write(*,*)idn2p(2*j-1),idn2p(2*j),(idn2p(2*i-1), c $ idn2p(2*i),i=1,nmbs)
c enddo
call new(v2,eh2,lw,nmx2,nmbs,idn2p,nh,mnh,inh, v,eh) c write(*,*)'eh=', eh2(1), eh(1)
do i=1,nmbs do j=1,nmbs wk=0
do k=1,nh
wk=wk+v(i+(k-1)*nmbs)*v(j+(k-1)*nmbs) enddo
wk1=wk1+(wk-ph(j+(i-1)*nmbs))*(wk-ph(j+(i-1)*nmbs)) enddo
enddo do i=1,nh do j=1,nmbs
c02(j+(i-1)*nmbs)=(1-rr)*c0(j+(i-1)*nmbs)+rr*v(j+(i-1)*nmbs) enddo
enddo do i=1,nmbs do j=1,nmbs wk=0
do k=1,nh
wk=wk+c02(i+(k-1)*nmbs)*c02(j+(k-1)*nmbs) enddo
ph(j+(i-1)*nmbs)=wk enddo
enddo c pause '1' wk1=wk1/iwk2
c write(*,'(1x,a,i3,e15.5)')'ic,wk1', ic,real(wk1)
if (wk1.le.ftol) then
call result(rlx,a,c,c2,gf,e0,ina,inb,rlxh,ah,ch,c2h,ff,
$ nmnm,nmn,nmm,nmm_ps,nmm_ng,na,nb,mbs,nmx1,nmx2,nmbs,c0,fh,ph, $ ea,eb,eh,eh2,ea2,eb2,ca,cb,v,v2,fa,fb,pa,pb,idn2p,idbs,idp2n, $ bs,eps,w,lw,mna,mnb,idbsh,bsh,mnh,inh,nh,mbsh,em,emh,iccc) goto 10000
endif
call fmatrx(a,c2,ah,c2h,nmbs,mbs,nmx1,nmx2,mbsh, $ idn2p,idbs,idbsh,bs,bsh,pa,pb,ph, fa,fb,fh) c write(*,*)'fa=',(fa(i),i=1,nmbs)
c write(*,*)'fh=',(fh(i),i=1,nmbs) wk1=0
call eigrs(fa,nmbs,-nmbs,nmbs,eps,w,lw,ea2,v2) c write(*,*)(ea2(i),i=1,nmbs)
call new(v2,ea2,lw,nmx2,nmbs,idn2p,na,mna,ina, v,ea) c write(*,*)'ea=', ea2(1), ea(1)
do i=1,nmbs do j=1,nmbs wk=0
do k=1,na
wk=wk+v(i+(k-1)*nmbs)*v(j+(k-1)*nmbs) enddo
wk1=wk1+(wk-pa(j+(i-1)*nmbs))*(wk-pa(j+(i-1)*nmbs)) enddo
enddo
if (ifrg.le.2) then do i=1,na
do j=1,nmbs
ca(j+(i-1)*nmbs)=(1-rr)*ca2(j+(i-1)*nmbs)+rr*v(j+(i-1)*nmbs) enddo
enddo
elseif (ifrg.eq.3) then do i=1,na
do j=1,nmbs
iwk=j+(i-1)*nmbs
wk=(1-rr)*ca2(iwk)+rr*v(iwk)
ca(iwk)=(wk*ca(iwk)-ca2(iwk)*ca2(iwk))/(wk-2*ca2(iwk)+ca(iwk)) enddo
enddo
elseif (ifrg.eq.4) then do i=1,na
alph=0 beta=0 gamm=0 do j=1,nmbs
iwk=j+(i-1)*nmbs
v(iwk)=(1-rr)*ca2(iwk)+rr*v(iwk)
alph=alph+(v(iwk)-ca2(iwk))*(v(iwk)-ca2(iwk)) beta=beta+(v(iwk)-ca2(iwk))*(ca2(iwk)-ca(iwk)) gamm=gamm+(ca2(iwk)-ca(iwk))*(ca2(iwk)-ca(iwk)) enddo
beta=beta+beta
wk2=1/(alph-beta+gamm) do j=1,nmbs
iwk=j+(i-1)*nmbs
ca(iwk)=wk2*(alph*ca(iwk)-beta*ca2(iwk)+gamm*v(iwk)) enddo
enddo
endif
do i=1,nmbs do j=1,nmbs wk=0
do k=1,na
wk=wk+ca(i+(k-1)*nmbs)*ca(j+(k-1)*nmbs) enddo
pa(j+(i-1)*nmbs)=wk enddo
enddo
call eigrs(fb,nmbs,-nmbs,nmbs,eps,w,lw,eb2,v2)
call new(v2,eb2,lw,nmx2,nmbs,idn2p,nb,mnb,inb, v,eb) do i=1,nmbs
do j=1,nmbs wk=0
do k=1,nb
wk=wk+v(i+(k-1)*nmbs)*v(j+(k-1)*nmbs) enddo
wk1=wk1+(wk-pb(j+(i-1)*nmbs))*(wk-pb(j+(i-1)*nmbs)) enddo
enddo
if (ifrg.le.2) then do i=1,nb
do j=1,nmbs
cb(j+(i-1)*nmbs)=(1-rr)*cb2(j+(i-1)*nmbs)+
$ rr*v(j+(i-1)*nmbs) enddo
enddo
elseif (ifrg.eq.3) then do i=1,nb
do j=1,nmbs
iwk=j+(i-1)*nmbs
wk=(1-rr)*cb2(iwk)+rr*v(iwk)
cb(iwk)=(wk*cb(iwk)-cb2(iwk)*cb2(iwk))/
$ (wk-2*cb2(iwk)+cb(iwk)) enddo
enddo
elseif (ifrg.eq.4) then do i=1,nb
alph=0 beta=0 gamm=0 do j=1,nmbs
iwk=j+(i-1)*nmbs
v(iwk)=(1-rr)*cb2(iwk)+rr*v(iwk)
alph=alph+(v(iwk)-cb2(iwk))*(v(iwk)-cb2(iwk)) beta=beta+(v(iwk)-cb2(iwk))*(cb2(iwk)-cb(iwk)) gamm=gamm+(cb2(iwk)-cb(iwk))*(cb2(iwk)-cb(iwk)) enddo
beta=beta+beta
wk2=1/(alph-beta+gamm) do j=1,nmbs
iwk=j+(i-1)*nmbs
cb(iwk)=wk2*(alph*cb(iwk)-beta*cb2(iwk)+gamm*v(iwk)) enddo
enddo endif
do i=1,nmbs
do j=1,nmbs wk=0
do k=1,nb
wk=wk+cb(i+(k-1)*nmbs)*cb(j+(k-1)*nmbs) enddo
pb(j+(i-1)*nmbs)=wk enddo
enddo
call eigrs(fh,nmbs,-nmbs,nmbs,eps,w,lw,eh2,v2) c write(*,*)(eh2(i),i=1,nmbs)
call new(v2,eh2,lw,nmx2,nmbs,idn2p,nh,mnh,inh, v,eh) c write(*,*)'eh2=', eh2(1), eh(1)
do i=1,nmbs do j=1,nmbs wk=0
do k=1,nh
wk=wk+v(i+(k-1)*nmbs)*v(j+(k-1)*nmbs) enddo
wk1=wk1+(wk-ph(j+(i-1)*nmbs))*(wk-ph(j+(i-1)*nmbs)) enddo
enddo
if (ifrg.le.2) then do i=1,nh
do j=1,nmbs
c0(j+(i-1)*nmbs)=(1-rr)*c02(j+(i-1)*nmbs)+
$ rr*v(j+(i-1)*nmbs) enddo
enddo
elseif (ifrg.eq.3) then do i=1,nh
do j=1,nmbs
iwk=j+(i-1)*nmbs
wk=(1-rr)*c02(iwk)+rr*v(iwk)
c0(iwk)=(wk*c0(iwk)-c02(iwk)*c02(iwk))/
$ (wk-2*c02(iwk)+c0(iwk)) enddo
enddo
elseif (ifrg.eq.4) then do i=1,nh
alph=0 beta=0 gamm=0 do j=1,nmbs
iwk=j+(i-1)*nmbs
v(iwk)=(1-rr)*c02(iwk)+rr*v(iwk)
alph=alph+(v(iwk)-c02(iwk))*(v(iwk)-c02(iwk)) beta=beta+(v(iwk)-c02(iwk))*(c02(iwk)-c0(iwk)) gamm=gamm+(c02(iwk)-c0(iwk))*(c02(iwk)-c0(iwk)) enddo
beta=beta+beta
wk2=1/(alph-beta+gamm) do j=1,nmbs
iwk=j+(i-1)*nmbs
c0(iwk)=wk2*(alph*c0(iwk)-beta*c02(iwk)+gamm*v(iwk)) enddo
enddo endif
do i=1,nmbs do j=1,nmbs wk=0
do k=1,nh
wk=wk+c0(i+(k-1)*nmbs)*c0(j+(k-1)*nmbs) enddo
ph(j+(i-1)*nmbs)=wk enddo
enddo c pause
wk1=wk1/iwk2
c write(*,'(1x,a,i3,e15.5)')'ic,wk:', ic+1,real(wk1) if (wk1.le.ftol) then
call result(rlx,a,c,c2,gf,e0,ina,inb,rlxh,ah,ch,c2h,ff,
$ nmnm,nmn,nmm,nmm_ps,nmm_ng,na,nb,mbs,nmx1,nmx2,nmbs,c0,fh,ph, $ ea,eb,eh,eh2,ea2,eb2,ca,cb,v,v2,fa,fb,pa,pb,idn2p,idbs,idp2n, $ bs,eps,w,lw,mna,mnb,idbsh,bsh,mnh,inh,nh,mbsh,em,emh,iccc) goto 10000
endif enddo
write(*,*) 'main exceeded maximum iterations. na=',na, $ ' nb=',nb,' B=',c,'[T]'
stop
10000 continue
write(*,*)'Converged at ic=',ic
open(1,file='myview.dat',access='append') write(1,*)'B=',c,' a=',a ,' ah=',ah
write(1,*)'na,nb,nh,ieh,nmbs,mbs=',na,nb,nh,ieh,nmbs,mbs,mbsh write(1,'(1x,a,F15.5)')'e0=',e0
write(1,'(1x,a,20F15.5)')'ea=', (ea(i),i=1,na) write(1,'(1x,a,20F15.5)')'eb=', (eb(i),i=1,nb) write(1,'(1x,a,F15.5)')'eh=', (eh(i),i=1,nh)
write(1,'(1x,a,30i3)')'lwa=', (ina(i),lw(i),i=1,na) write(1,'(1x,a,30i3)')'lwb=',(inb(i),lw(nmx2+i),i=1,nb) write(1,'(1x,a,30i3)')'lwh=',(inh(i),lw(2*nmx2+i),i=1,nh) c if (na.ne.0)then
c write(1,*)' n , m , ca= 1,.., na' c do l=1,nmbs
c write(1,'(1x,2i3,20e15.5)')idn2p(2*l-1),idn2p(2*l), c $ (ca(l+(j-1)*nmbs),j=1,na)
c enddo c endif
c if (nb.ne.0)then
c write(1,*)' n , m , cb= 1,.., nb' c do l=1,nmbs
c write(1,'(1x,2i3,20e15.5)')idn2p(2*l-1),idn2p(2*l), c $ (cb(l+(j-1)*nmbs),j=1,nb)
c enddo c endif
c write(1,*)' n , m for hole: c0= 1' c do l=1,nmbs
c write(1,'(1x,2i3,20e15.5)') idn2p(2*l-1),idn2p(2*l),c0(l) c enddo
c close(1)
c stop 'We''ve got good result already!'
open(1,file='shift',access='append') if (iccc.eq.1)then
if (nab.eq.0) tranup(icch,icc)=e0-e0i
write(1,111)'up:',inh(nh),lw(2*nmx2+nh),' -',
$ ina(na),lw(na),e0-e0i,(e0-e0i-tranup(icch,icc)) else
if (nab.eq.0) trandn(icch,icc)=e0-e0i
write(1,111)'dn:',inh(nh),lw(2*nmx2+nh),' -',
$ inb(nb),lw(nmx2+nb),e0-e0i,(e0-e0i-tranup(icch,icc)) endif
close(1)
111 format(1x,a,2i3,a,2i3,2F15.5) c begin calculation of M_if
if(nam.eq.0) then ta=1
else ta=0
call appr1(nam,ix, nmx2,ca,cam,nmbs,ta) endif
if(nbm.eq.0) then tb=1
else tb=0
call appr1(nbm,ix, nmx2,cb,cbm,nmbs,tb) endif
c write(*,*)'ta,tb=',ta,tb if (iccc.eq.1)then
gd1=0
do i= 1,nmbs me=idn2p(i*2) do j=1,nmbs mh=idn2p(j*2)
if (me.eq.mh) gd1=gd1+ca(nam*nmbs+i)*c0(j)*
$ ehm(idh(i,j,nmbs,mbse,ideh)) enddo
enddo
if(nam.eq.0) then exac=gd1
else exac=0
call appr2(na,ix, nmx2,ca,cam,c0,nmbs, $ idn2p,ehm,ideh,mbse,exac)
endif
exac=exac*tb
i_e=2*ina(na)+abs(lw(na))+1 else
gd1=0
do i= 1,nmbs me=idn2p(i*2) do j=1,nmbs mh=idn2p(j*2)
if (me.eq.mh) gd1=gd1+cb(nbm*nmbs+i)*c0(j)*
$ ehm(idh(i,j,nmbs,mbse,ideh)) enddo
enddo
if(nbm.eq.0) then exac=gd1
else
exac=0
call appr2(nb,ix, nmx2,cb,cbm,c0,nmbs, $ idn2p,ehm,ideh,mbse,exac)
endif
exac=exac*ta
i_e=2*inb(nb)+abs(lw(nmx2+nb))+1 endif
i_h=2*inh(nh)+abs(lw(2*nmx2+nh))+1 gd2=gd1*ta*tb
tgd12=gd1*gd1 tgd22=gd2*gd2 texac2=exac*exac
c write(*,*)'gd12exac=',gd1,gd2,exac
c oscsum(iosch)=oscsum(iosch)+texac2/(e0+Eg) osumh(iosch)=osumh(iosch)+texac2
osume(iosce)=osume(iosce)+texac2
if(iosch.eq.iosce) oscsum(iosce)=oscsum(iosce)+texac2 write(*,'(1x,a,2i4,E15.5)')'ic,iosch=',icch,iosch,texac2 damp3=sqrt(damp30*damp30+i_e*i_h*damp31*damp31)
open(1,file='Mif.dat',access='append') write(1,*)e0-e0i,texac2,i_e,i_h
close(1) do i=0,ie
eprob=E1+i*delE
temp1=exp(-(eprob+e0i-e0)**2/damp1**2)/sqrt(pi)/damp1 temp2=exp(-(eprob+e0i-e0)**2/damp2**2)/sqrt(pi)/damp2 temp3=exp(-(eprob+e0i-e0)**2/damp3**2)/sqrt(pi)/damp3 absorp1(i)=absorp1(i)+texac2*temp1
absorp2(i)=absorp2(i)+texac2*temp2 absorp3(i)=absorp3(i)+texac2*temp3 app1(i)=app1(i)+tgd12*temp1
app2(i)=app2(i)+tgd22*temp1 enddo
222 continue c finish icccloop enddo
endif 333 continue c finish icc-loop enddo
c finish icch - loop enddo
open(1,file='osc0',access='append') open(2,file='osc1',access='append') open(3,file='osc2',access='append') do i=1,3
write(i,*)nab,oscsum(i) close(i)
enddo
open(1,file='osh0',access='append') open(2,file='osh1',access='append') open(3,file='osh2',access='append') do i=1,3
write(i,*)nab,osumh(i) close(i)
enddo